Tezos

These are the sources Tezos imported to Coq by the current development version of coq-of-ocaml. Tezos is a crypto-currency with smart-contracts and an upgradable protocol. The market cap of Tezos is more than US $500 millions at the time of writting. Write at web [at] clarus [dot] me for more information. Work currently made at Nomadic Labs.

src/bin_attacker/attacker_main.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () = Attacker_minimal.main ()
src/bin_attacker/attacker_main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/bin_attacker/attacker_minimal.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Format

include Logging.Make (struct
  let name = "attacker"
end)

module Proto = Client_embedded_proto_alpha

(* the genesis block and network *)
let genesis_block_hashed =
  Block_hash.of_b58check "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let network = Store.Net genesis_block_hashed

let network = Store.Chain_id.Id genesis_block_hashed

(* the bootstrap accounts and actions like signing to do with them *)
let source_account = List.nth Proto.Bootstrap_storage.accounts 4

let destination_account = List.nth Proto.Bootstrap_storage.accounts 0

let wrong_account = List.nth Proto.Bootstrap_storage.accounts 1

let another_account = List.nth Proto.Bootstrap_storage.accounts 2

let signed = Ed25519.append_signature source_account.secret_key

let signed_wrong = Ed25519.append_signature wrong_account.secret_key

(* forge a block from a list of operations *)
let block_forged ?prev ops =
  let from_int64 x =
    [ Bytes.of_string Proto.Constants_repr.version_number;
      Proto.Fitness_repr.int64_to_bytes x ]
  in
  let pred = match prev with None -> genesis_block_hashed | Some x -> x in
  let block ops =
    Store.Block_header.
      {
        chain_id = network;
        predecessor = pred;
        timestamp = Systime_os.now ();
        fitness = from_int64 1L;
        operations = ops;
      }
  in
  let open Proto in
  let generate_proof_of_work_nonce () =
    Rand.generate Proto.Alpha_context.Constants.proof_of_work_nonce_size
  in
  let generate_seed_nonce () =
    match
      Proto.Nonce_storage.of_bytes
      @@ Rand.generate Proto.Alpha_context.Constants.nonce_length
    with
    | Error _ ->
        assert false
    | Ok nonce ->
        nonce
  in
  Block_repr.forge_header
    (block ops)
    Block_repr.
      {
        baking_slot = {level = Raw_level_repr.of_int32_exn 1l; priority = 0l};
        seed_nonce_hash = Proto.Nonce_storage.hash (generate_seed_nonce ());
        proof_of_work_nonce = generate_proof_of_work_nonce ();
      }

(* forge a transaction *)
let tx_forged ?dest amount fee =
  let open Proto.Operation_repr in
  let open Proto.Tez_repr in
  let open Proto.Contract_repr in
  let trgt =
    match dest with None -> destination_account | Some dest -> dest
  in
  let src = source_account in
  let tx =
    Transaction
      {
        amount = of_cents_exn amount;
        parameters = None;
        destination = default_contract trgt.public_key_hash;
      }
  in
  let op =
    Sourced_operations
      (Manager_operations
         {
           source = default_contract src.public_key_hash;
           public_key = Some src.public_key;
           fee = of_cents_exn fee;
           counter = 1l;
           operations = [tx];
         })
  in
  forge {chain_id = network} op

(* forge a list of proposals, california eat your heart out *)
let props_forged period props =
  let open Proto.Operation_repr in
  let src = source_account in
  let props = Proposals {period; proposals = props} in
  let op =
    Sourced_operations
      (Delegate_operations {source = src.public_key; operations = [props]})
  in
  forge {chain_id = network} op

(* "forge" a ballot *)
let ballot_forged period prop vote =
  let open Proto.Operation_repr in
  let src = source_account in
  let ballot = Ballot {period; proposal = prop; ballot = vote} in
  let op =
    Sourced_operations
      (Delegate_operations {source = src.public_key; operations = [ballot]})
  in
  forge {chain_id = network} op

let identity = P2p_identity.generate Crypto_box.default_target

(* connect to the network, run an action and then disconnect *)
let try_action addr port action =
  let socket = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
  let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
  Lwt_unix.connect socket (Lwt_unix.ADDR_INET (uaddr, port))
  >>= fun () ->
  let io_sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 14) () in
  let conn = P2p_io_scheduler.register io_sched socket in
  P2p_connection.authenticate
    ~proof_of_work_target:Crypto_box.default_target
    ~incoming:false
    conn
    (addr, port)
    identity
    Distributed_db.Raw.supported_versions
  >>=? fun (_, auth_fd) ->
  P2p_connection.accept auth_fd Distributed_db.Raw.encoding
  >>= function
  | Error _ ->
      failwith "Connection rejected by peer."
  | Ok conn ->
      action conn
      >>=? fun () -> P2p_connection.close conn >>= fun () -> return_unit

let replicate n x =
  let rec replicate_acc acc n x =
    if n <= 0 then acc else replicate_acc (x :: acc) (n - 1) x
  in
  replicate_acc [] n x

let send conn (msg : Distributed_db.Message.t) =
  P2p_connection.write conn (P2p.Raw.Message msg)

let request_block_times block_hash n conn =
  let open Block_hash in
  lwt_log_notice "requesting %a block %d times" pp_short block_hash n
  >>= fun () ->
  let block_hashes = replicate n block_hash in
  send conn (Get_block_headers (network, block_hashes))

let request_op_times op_signed n conn =
  let open Operation_hash in
  let op_hash = hash_bytes [op_signed] in
  lwt_log_notice "sending %a transaction" pp_short op_hash
  >>= fun () ->
  send conn (Operation op_signed)
  >>=? fun () ->
  lwt_log_notice "requesting %a transaction %d times" pp_short op_hash n
  >>= fun () ->
  let op_hashes = replicate n op_hash in
  send conn (Get_operations op_hashes)

let send_block_size n conn =
  let bytes = Bytes.create n in
  let open Block_hash in
  lwt_log_notice
    "propagating fake %d byte block %a"
    n
    pp_short
    (hash_bytes [bytes])
  >>= fun () -> send conn (Block bytes)

let send_protocol_size n conn =
  let bytes = Bytes.create n in
  let open Protocol_hash in
  lwt_log_notice
    "propagating fake %d byte protocol %a"
    n
    pp_short
    (hash_bytes [bytes])
  >>= fun () -> send conn (Protocol bytes)

let send_operation_size n conn =
  let op_faked = Bytes.create n in
  let op_hashed = Operation_hash.hash_bytes [op_faked] in
  lwt_log_notice
    "propagating fake %d byte operation %a"
    n
    Operation_hash.pp_short
    op_hashed
  >>= fun () ->
  send conn (Operation op_faked)
  >>=? fun () ->
  let block = signed (block_forged [op_hashed]) in
  let block_hashed = Block_hash.hash_bytes [block] in
  lwt_log_notice
    "propagating block %a with operation"
    Block_hash.pp_short
    block_hashed
  >>= fun () -> send conn (Block block)

let send_operation_bad_signature () conn =
  let open Operation_hash in
  let signed_wrong_op = signed_wrong (tx_forged 5L 1L) in
  let hashed_wrong_op = hash_bytes [signed_wrong_op] in
  lwt_log_notice
    "propagating operation %a with wrong signature"
    pp_short
    hashed_wrong_op
  >>= fun () ->
  send conn (Operation signed_wrong_op)
  >>=? fun () ->
  let block = signed (block_forged [hashed_wrong_op]) in
  let block_hashed = Block_hash.hash_bytes [block] in
  lwt_log_notice
    "propagating block %a with operation"
    Block_hash.pp_short
    block_hashed
  >>= fun () -> send conn (Block block)

let send_block_bad_signature () conn =
  let open Block_hash in
  let signed_wrong_block = signed_wrong (block_forged []) in
  lwt_log_notice
    "propagating block %a with wrong signature"
    pp_short
    (hash_bytes [signed_wrong_block])
  >>= fun () -> send conn (Block signed_wrong_block)

let double_spend () conn =
  let spend account =
    let op_signed = signed (tx_forged ~dest:account 199999999L 1L) in
    let op_hashed = Operation_hash.hash_bytes [op_signed] in
    let block_signed = signed (block_forged [op_hashed]) in
    let block_hashed = Block_hash.hash_bytes [block_signed] in
    lwt_log_notice "propagating operation %a" Operation_hash.pp_short op_hashed
    >>= fun () ->
    send conn (Operation op_signed)
    >>=? fun () ->
    lwt_log_notice "propagating block %a" Block_hash.pp_short block_hashed
    >>= fun () -> send conn (Block block_signed)
  in
  spend destination_account >>=? fun () -> spend another_account

let long_chain n conn =
  lwt_log_notice "propogating %d blocks" n
  >>= fun () ->
  let prev_ref = ref genesis_block_hashed in
  let rec loop k =
    if k < 1 then return_unit
    else
      let block = signed (block_forged ~prev:!prev_ref []) in
      prev_ref := Block_hash.hash_bytes [block] ;
      send conn (Block block) >>=? fun () -> loop (k - 1)
  in
  loop n

let lots_transactions amount fee n conn =
  let signed_op = signed (tx_forged amount fee) in
  let rec loop k =
    if k < 1 then return_unit
    else send conn (Operation signed_op) >>=? fun () -> loop (k - 1)
  in
  let ops = replicate n (Operation_hash.hash_bytes [signed_op]) in
  let signed_block = signed (block_forged ops) in
  lwt_log_notice "propogating %d transactions" n
  >>= fun () ->
  loop n
  >>=? fun () ->
  lwt_log_notice
    "propagating block %a with wrong signature"
    Block_hash.pp_short
    (Block_hash.hash_bytes [signed_block])
  >>= fun () -> send conn (Block signed_block)

let main () =
  let addr = Ipaddr.V6.localhost in
  let port = 9732 in
  let run_action action = try_action addr port action in
  let run_cmd_unit lwt =
    Arg.Unit
      (fun () ->
        Lwt_main.run
          ( lwt ()
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error err ->
              lwt_log_error "Error: %a" pp_print_error err
              >>= fun () -> Lwt.return_unit ))
  in
  let run_cmd_int_suffix lwt =
    Arg.String
      (fun str ->
        let last = str.[String.length str - 1] in
        let init = String.sub str 0 (String.length str - 1) in
        let n =
          if last == 'k' || last == 'K' then int_of_string init * (1 lsl 10)
          else if last == 'm' || last == 'M' then
            int_of_string init * (1 lsl 20)
          else if last == 'g' || last == 'G' then
            int_of_string init * (1 lsl 30)
          else int_of_string str
        in
        Lwt_main.run
          ( lwt n
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error err ->
              lwt_log_error "Error: %a" pp_print_error err
              >>= fun () -> Lwt.return_unit ))
  in
  let cmds =
    [ ( "-1",
        run_cmd_int_suffix
          (run_action << request_block_times genesis_block_hashed),
        "[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}blocks."
      );
      ( "-2",
        run_cmd_int_suffix
          (run_action << request_op_times (signed (tx_forged 5L 1L))),
        "[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}ops."
      );
      ( "-3",
        run_cmd_int_suffix (run_action << send_block_size),
        "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
         block." );
      ( "-4",
        run_cmd_int_suffix (run_action << send_operation_size),
        "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
         operation." );
      ( "-5",
        run_cmd_int_suffix (run_action << send_protocol_size),
        "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
         protocol." );
      ( "-6",
        run_cmd_unit (run_action << send_operation_bad_signature),
        "Attempt to propagate a transaction with a bad signature." );
      ( "-7",
        run_cmd_unit (run_action << send_block_bad_signature),
        "Attempt to propagate a block with a bad signature." );
      ( "-8",
        run_cmd_unit (run_action << double_spend),
        "Attempt to send the same transaction in two blocks" );
      ( "-9",
        run_cmd_int_suffix (run_action << long_chain),
        "[N {,K,M,G}] Attempt to send a chain of N {,kilo,mega,giga}blocks" );
      ( "-10",
        run_cmd_int_suffix (run_action << lots_transactions 0L 0L),
        "[N {,K,M,G}] Attempt to send N {,kilo,mega,giga}ops" ) ]
  in
  Arg.parse cmds print_endline "Tezos Evil Client"
src/bin_attacker/attacker_minimal.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Stdlib.Format.

Definition genesis_block_hashed {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition network {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition network {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition source_account {A : Type} : A :=
  Stdlib.List.nth op_star_t_y_p_e_minus_e_r_r_o_r_star 4.

Definition destination_account {A : Type} : A :=
  Stdlib.List.nth op_star_t_y_p_e_minus_e_r_r_o_r_star 0.

Definition wrong_account {A : Type} : A :=
  Stdlib.List.nth op_star_t_y_p_e_minus_e_r_r_o_r_star 1.

Definition another_account {A : Type} : A :=
  Stdlib.List.nth op_star_t_y_p_e_minus_e_r_r_o_r_star 2.

Definition signed {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star (secret_key source_account).

Definition signed_wrong {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star (secret_key wrong_account).

Definition block_forged {A B C : Type} (prev : option A) (ops : B) : C :=
  let from_int64 {D : Type} (x : D) : list string :=
    cons (Stdlib.Bytes.of_string op_star_t_y_p_e_minus_e_r_r_o_r_star)
      (cons (op_star_t_y_p_e_minus_e_r_r_o_r_star x) []) in
  let pred :=
    match prev with
    | None => genesis_block_hashed
    | Some x => x
    end in
  let block {D E : Type} (ops : D) : E :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star in
  let generate_proof_of_work_nonce {D : Type} (function_parameter : unit) : D :=
    match function_parameter with
    | tt =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
    end in
  let generate_seed_nonce {D : Type} (function_parameter : unit) : D :=
    match function_parameter with
    | tt =>
      match
        apply op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star) with
      | inr _ => false
      | inl nonce => nonce
      end
    end in
  op_star_t_y_p_e_minus_e_r_r_o_r_star (block ops)
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition tx_forged {A B C D : Type} (dest : option A) (amount : B) (fee : C)
  : D := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition props_forged {A B C : Type} (period : A) (props : B) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition ballot_forged {A B C D : Type} (period : A) (prop : B) (vote : C)
  : D := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition identity {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition try_action {A B C D E : Type} (addr : A) (port : B) (action : C -> D)
  : E :=
  let socket :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star 0 in
  let uaddr := op_star_t_y_p_e_minus_e_r_r_o_r_star addr in
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star socket
      op_star_t_y_p_e_minus_e_r_r_o_r_star)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let io_sched := op_star_t_y_p_e_minus_e_r_r_o_r_star (Z.shiftl 1 14) tt
          in
        let conn := op_star_t_y_p_e_minus_e_r_r_o_r_star io_sched socket in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star false conn (addr, port)
            identity op_star_t_y_p_e_minus_e_r_r_o_r_star)
          (fun function_parameter =>
            match function_parameter with
            | (_, auth_fd) =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star auth_fd
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | inr _ =>
                    OCaml.Stdlib.failwith
                      "Connection rejected by peer." % string
                  | inl conn =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star (action conn)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star conn)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
                              end)
                        end)
                  end)
            end)
      end).

Definition replicate {A : Type} (n : Z) (x : A) : list A :=
  let fix replicate_acc {B : Type} (acc : list B) (n : Z) (x : B) : list B :=
    if OCaml.Stdlib.le n 0 then
      acc
    else
      replicate_acc (cons x acc) (Z.sub n 1) x in
  replicate_acc [] n x.

Definition send {A B C : Type} (conn : A) (function_parameter : B) : C :=
  match function_parameter with
  | _ =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star conn
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition request_block_times {A B C D : Type}
  (block_hash : A) (n : B) (conn : C) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition request_op_times {A B C D : Type} (op_signed : A) (n : B) (conn : C)
  : D := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition send_block_size {A B : Type} (n : Z) (conn : A) : B :=
  let bytes := Stdlib.Bytes.create n in
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition send_protocol_size {A B : Type} (n : Z) (conn : A) : B :=
  let bytes := Stdlib.Bytes.create n in
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition send_operation_size {A B : Type} (n : Z) (conn : A) : B :=
  let op_faked := Stdlib.Bytes.create n in
  let op_hashed := op_star_t_y_p_e_minus_e_r_r_o_r_star (cons op_faked []) in
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      "propagating fake %d byte operation %a" % string n
      op_star_t_y_p_e_minus_e_r_r_o_r_star op_hashed)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (send conn op_star_t_y_p_e_minus_e_r_r_o_r_star)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let block := signed (block_forged None (cons op_hashed [])) in
              let block_hashed :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star (cons block []) in
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "propagating block %a with operation" % string
                  op_star_t_y_p_e_minus_e_r_r_o_r_star block_hashed)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => send conn op_star_t_y_p_e_minus_e_r_r_o_r_star
                  end)
            end)
      end).

Definition send_operation_bad_signature {A B : Type} (function_parameter : unit)
  : A -> B :=
  match function_parameter with
  | tt => fun conn => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition send_block_bad_signature {A B : Type} (function_parameter : unit)
  : A -> B :=
  match function_parameter with
  | tt => fun conn => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition double_spend {A B : Type} (function_parameter : unit) : A -> B :=
  match function_parameter with
  | tt =>
    fun conn =>
      let spend {C D : Type} (account : C) : D :=
        let op_signed := signed (tx_forged (Some account) 199999999 1) in
        let op_hashed :=
          op_star_t_y_p_e_minus_e_r_r_o_r_star (cons op_signed []) in
        let block_signed := signed (block_forged None (cons op_hashed [])) in
        let block_hashed :=
          op_star_t_y_p_e_minus_e_r_r_o_r_star (cons block_signed []) in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "propagating operation %a" % string
            op_star_t_y_p_e_minus_e_r_r_o_r_star op_hashed)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (send conn op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "propagating block %a" % string
                        op_star_t_y_p_e_minus_e_r_r_o_r_star block_hashed)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => send conn op_star_t_y_p_e_minus_e_r_r_o_r_star
                        end)
                  end)
            end) in
      op_star_t_y_p_e_minus_e_r_r_o_r_star (spend destination_account)
        (fun function_parameter =>
          match function_parameter with
          | tt => spend another_account
          end)
  end.

Definition long_chain {A B : Type} (n : Z) (conn : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "propogating %d blocks" % string n)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let prev_ref := Stdlib.ref genesis_block_hashed in
        let fix loop {C : Type} (k : Z) : C :=
          if OCaml.Stdlib.lt k 1 then
            op_star_t_y_p_e_minus_e_r_r_o_r_star
          else
            let block :=
              signed (block_forged (Some (Stdlib.op_exclamation prev_ref)) [])
              in
            Stdlib.op_colon_eq prev_ref
              (op_star_t_y_p_e_minus_e_r_r_o_r_star (cons block []));
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (send conn op_star_t_y_p_e_minus_e_r_r_o_r_star)
              (fun function_parameter =>
                match function_parameter with
                | tt => loop (Z.sub k 1)
                end) in
        loop n
      end).

Definition lots_transactions {A B C D : Type}
  (amount : A) (fee : B) (n : Z) (conn : C) : D :=
  let signed_op := signed (tx_forged None amount fee) in
  let fix loop {E : Type} (k : Z) : E :=
    if OCaml.Stdlib.lt k 1 then
      op_star_t_y_p_e_minus_e_r_r_o_r_star
    else
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (send conn op_star_t_y_p_e_minus_e_r_r_o_r_star)
        (fun function_parameter =>
          match function_parameter with
          | tt => loop (Z.sub k 1)
          end) in
  let ops :=
    replicate n (op_star_t_y_p_e_minus_e_r_r_o_r_star (cons signed_op [])) in
  let signed_block := signed (block_forged None ops) in
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "propogating %d transactions" % string
      n)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star (loop n)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "propagating block %a with wrong signature" % string
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star (cons signed_block [])))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => send conn op_star_t_y_p_e_minus_e_r_r_o_r_star
                  end)
            end)
      end).

Definition main (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let addr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let port := 9732 in
    let run_action {A B C : Type} (action : A -> B) : C :=
      try_action addr port action in
    let run_cmd_unit {A : Type} (lwt : unit -> A) : Stdlib.Arg.spec :=
      Arg.Unit
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star (lwt tt)
                (fun function_parameter =>
                  match function_parameter with
                  | inl tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
                  | inr err =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star "Error: %a" % string
                        op_star_t_y_p_e_minus_e_r_r_o_r_star err)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
                        end)
                  end))
          end) in
    let run_cmd_int_suffix {A : Type} (lwt : Z -> A) : Stdlib.Arg.spec :=
      Arg.String
        (fun str =>
          let last := Stdlib.String.get str (Z.sub (OCaml.String.length str) 1)
            in
          let init :=
            Stdlib.String.sub str 0 (Z.sub (OCaml.String.length str) 1) in
          let n :=
            if
              orb (Stdlib.op_eq_eq last "k" % char)
                (Stdlib.op_eq_eq last "K" % char) then
              Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 10)
            else
              if
                orb (Stdlib.op_eq_eq last "m" % char)
                  (Stdlib.op_eq_eq last "M" % char) then
                Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 20)
              else
                if
                  orb (Stdlib.op_eq_eq last "g" % char)
                    (Stdlib.op_eq_eq last "G" % char) then
                  Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 30)
                else
                  OCaml.Stdlib.int_of_string str in
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star (lwt n)
              (fun function_parameter =>
                match function_parameter with
                | inl tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
                | inr err =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star "Error: %a" % string
                      op_star_t_y_p_e_minus_e_r_r_o_r_star err)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
                      end)
                end))) in
    let cmds :=
      cons
        ("-1" % string,
          (run_cmd_int_suffix
            (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
              (request_block_times genesis_block_hashed))),
          "[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}blocks."
            % string)
        (cons
          ("-2" % string,
            (run_cmd_int_suffix
              (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
                (request_op_times (signed (tx_forged None 5 1))))),
            "[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}ops."
              % string)
          (cons
            ("-3" % string,
              (run_cmd_int_suffix
                (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action send_block_size)),
              "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake block."
                % string)
            (cons
              ("-4" % string,
                (run_cmd_int_suffix
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
                    send_operation_size)),
                "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake operation."
                  % string)
              (cons
                ("-5" % string,
                  (run_cmd_int_suffix
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
                      send_protocol_size)),
                  "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake protocol."
                    % string)
                (cons
                  ("-6" % string,
                    (run_cmd_unit
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
                        send_operation_bad_signature)),
                    "Attempt to propagate a transaction with a bad signature." %
                      string)
                  (cons
                    ("-7" % string,
                      (run_cmd_unit
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
                          send_block_bad_signature)),
                      "Attempt to propagate a block with a bad signature." %
                        string)
                    (cons
                      ("-8" % string,
                        (run_cmd_unit
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
                            double_spend)),
                        "Attempt to send the same transaction in two blocks" %
                          string)
                      (cons
                        ("-9" % string,
                          (run_cmd_int_suffix
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
                              long_chain)),
                          "[N {,K,M,G}] Attempt to send a chain of N {,kilo,mega,giga}blocks"
                            % string)
                        (cons
                          ("-10" % string,
                            (run_cmd_int_suffix
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star run_action
                                (lots_transactions 0 0))),
                            "[N {,K,M,G}] Attempt to send N {,kilo,mega,giga}ops"
                              % string) []))))))))) in
    Stdlib.Arg.parse cmds OCaml.Stdlib.print_endline
      "Tezos Evil Client" % string
  end.
src/bin_attacker/attacker_minimal.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val main : unit -> unit
src/bin_attacker/attacker_minimal.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter main : unit -> unit.
src/bin_client/client_protocols_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let group =
  {Clic.name = "protocols"; title = "Commands for managing protocols"}

let proto_param ~name ~desc t =
  Clic.param
    ~name
    ~desc
    (Clic.parameter (fun _ str -> Lwt.return (Protocol_hash.of_b58check str)))
    t

let commands () =
  let open Clic in
  let check_dir _ dn =
    if Sys.is_directory dn then return dn
    else failwith "%s is not a directory" dn
  in
  let check_dir_parameter = parameter check_dir in
  [ command
      ~group
      ~desc:"List protocols known by the node."
      no_options
      (prefixes ["list"; "protocols"] stop)
      (fun () (cctxt : #Client_context.full) ->
        Shell_services.Protocol.list cctxt
        >>=? fun protos ->
        Lwt_list.iter_s
          (fun ph -> cctxt#message "%a" Protocol_hash.pp ph)
          protos
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Inject a new protocol into the node."
      no_options
      ( prefixes ["inject"; "protocol"]
      @@ param
           ~name:"dir"
           ~desc:"directory containing the sources of a protocol"
           check_dir_parameter
      @@ stop )
      (fun () dirname (cctxt : #Client_context.full) ->
        Lwt.catch
          (fun () ->
            Tezos_base_unix.Protocol_files.read_dir dirname
            >>=? fun (_hash, proto) ->
            Shell_services.Injection.protocol cctxt proto
            >>= function
            | Ok hash ->
                cctxt#message
                  "Injected protocol %a successfully"
                  Protocol_hash.pp
                  hash
                >>= fun () -> return_unit
            | Error err ->
                cctxt#error
                  "Error while injecting protocol from %s: %a"
                  dirname
                  Error_monad.pp_print_error
                  err
                >>= fun () -> return_unit)
          (fun exn ->
            cctxt#error
              "Error while injecting protocol from %s: %a"
              dirname
              Error_monad.pp_print_error
              [Error_monad.Exn exn]
            >>= fun () -> return_unit));
    command
      ~group
      ~desc:"Dump a protocol from the node's record of protocol."
      no_options
      ( prefixes ["dump"; "protocol"]
      @@ proto_param ~name:"protocol hash" ~desc:""
      @@ stop )
      (fun () ph (cctxt : #Client_context.full) ->
        Shell_services.Protocol.contents cctxt ph
        >>=? fun proto ->
        Tezos_base_unix.Protocol_files.write_dir
          (Protocol_hash.to_short_b58check ph)
          ~hash:ph
          proto
        >>=? fun () ->
        cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Fetch a protocol from the network."
      no_options
      ( prefixes ["fetch"; "protocol"]
      @@ proto_param ~name:"protocol hash" ~desc:""
      @@ stop )
      (fun () hash (cctxt : #Client_context.full) ->
        Shell_services.Protocol.fetch cctxt hash
        >>= function
        | Ok () ->
            cctxt#message
              "Protocol %a successfully fetched."
              Protocol_hash.pp_short
              hash
            >>= fun () -> return_unit
        | Error err ->
            cctxt#error
              "Error while fetching protocol: %a"
              Error_monad.pp_print_error
              err
            >>= fun () -> return_unit) ]
src/bin_client/client_protocols_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "protocols" % string;
    Clic.title := "Commands for managing protocols" % string |}.

Definition proto_param {A B : Type}
  (name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.Protocol_hash.t -> A) B :=
  Tezos_base__TzPervasives.Clic.param name desc
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun str =>
            Lwt._return (Tezos_base__TzPervasives.Protocol_hash.of_b58check str)
        end)) t.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  match function_parameter with
  | tt =>
    let check_dir {J : Type} (function_parameter : J)
      : string -> Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
      match function_parameter with
      | _ =>
        fun dn =>
          if Stdlib.Sys.is_directory dn then
            Tezos_base__TzPervasives._return dn
          else
            Tezos_base__TzPervasives.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " is not a directory" % string
                    CamlinternalFormatBasics.End_of_format))
                "%s is not a directory" % string) dn
      end in
    let check_dir_parameter :=
      Tezos_base__TzPervasives.Clic.parameter None check_dir in
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "List protocols known by the node." % string
        Tezos_base__TzPervasives.Clic.no_options
        (Tezos_base__TzPervasives.Clic.prefixes
          (cons "list" % string (cons "protocols" % string []))
          Tezos_base__TzPervasives.Clic.stop)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun cctxt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell_services.Shell_services.Protocol.list cctxt)
                (fun protos =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Lwt_list.iter_s
                      (fun ph =>
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string)
                          Tezos_base__TzPervasives.Protocol_hash.pp ph) protos)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end))
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Inject a new protocol into the node." % string
          Tezos_base__TzPervasives.Clic.no_options
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "inject" % string (cons "protocol" % string [])))
            (apply
              (Tezos_base__TzPervasives.Clic.param "dir" % string
                "directory containing the sources of a protocol" % string
                check_dir_parameter) Tezos_base__TzPervasives.Clic.stop))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              fun dirname =>
                fun cctxt =>
                  Lwt.catch
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base_unix.Protocol_files.read_dir dirname)
                          (fun function_parameter =>
                            match function_parameter with
                            | (_hash, proto) =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_shell_services.Shell_services.Injection.protocol
                                  cctxt None proto)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | inl hash =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Injected protocol " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                " successfully" % string
                                                CamlinternalFormatBasics.End_of_format)))
                                          "Injected protocol %a successfully" %
                                            string)
                                        Tezos_base__TzPervasives.Protocol_hash.pp
                                        hash)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.return_unit
                                        end)
                                  | inr err =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Error while injecting protocol from "
                                              % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.String_literal
                                                ": " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  CamlinternalFormatBasics.End_of_format))))
                                          "Error while injecting protocol from %s: %a"
                                            % string) dirname
                                        Tezos_base__TzPervasives.Error_monad.pp_print_error
                                        err)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.return_unit
                                        end)
                                  end)
                            end)
                      end)
                    (fun exn =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Error while injecting protocol from " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  ": " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))))
                            "Error while injecting protocol from %s: %a" %
                              string) dirname
                          Tezos_base__TzPervasives.Error_monad.pp_print_error
                          (cons (Error_monad.Exn exn) []))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives.return_unit
                          end))
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Dump a protocol from the node's record of protocol." % string
            Tezos_base__TzPervasives.Clic.no_options
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "dump" % string (cons "protocol" % string [])))
              (apply (proto_param "protocol hash" % string "" % string)
                Tezos_base__TzPervasives.Clic.stop))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun ph =>
                  fun cctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell_services.Shell_services.Protocol.contents
                        cctxt ph)
                      (fun proto =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base_unix.Protocol_files.write_dir
                            (Tezos_base__TzPervasives.Protocol_hash.to_short_b58check
                              ph) (Some ph) proto)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Extracted protocol " % string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))
                                    "Extracted protocol %a" % string)
                                  Tezos_base__TzPervasives.Protocol_hash.pp_short
                                  ph)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                            end))
              end))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Fetch a protocol from the network." % string
              Tezos_base__TzPervasives.Clic.no_options
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "fetch" % string (cons "protocol" % string [])))
                (apply (proto_param "protocol hash" % string "" % string)
                  Tezos_base__TzPervasives.Clic.stop))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun hash =>
                    fun cctxt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell_services.Shell_services.Protocol.fetch
                          cctxt hash)
                        (fun function_parameter =>
                          match function_parameter with
                          | inl tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Protocol " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " successfully fetched." % string
                                        CamlinternalFormatBasics.End_of_format)))
                                  "Protocol %a successfully fetched." % string)
                                Tezos_base__TzPervasives.Protocol_hash.pp_short
                                hash)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_unit
                                end)
                          | inr err =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Error while fetching protocol: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format))
                                  "Error while fetching protocol: %a" % string)
                                Tezos_base__TzPervasives.Error_monad.pp_print_error
                                err)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_unit
                                end)
                          end)
                end)) [])))
  end.
src/bin_client/client_protocols_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> Client_commands.command list
src/bin_client/client_protocols_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands : unit -> list Tezos_client_commands.Client_commands.command.
src/bin_client/client_rpc_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Command line interface - Generic JSON RPC interface *)

open Lwt.Infix
open Clic
open Json_schema

(*-- Assisted, schema directed input fill in --------------------------------*)

exception Unsupported_construct

type input = {
  int : int -> int -> string option -> string list -> int Lwt.t;
  float : string option -> string list -> float Lwt.t;
  string : string option -> string list -> string Lwt.t;
  bool : string option -> string list -> bool Lwt.t;
  continue : string option -> string list -> bool Lwt.t;
  display : string -> unit Lwt.t;
}

(* generic JSON generation from a schema with callback for random or
   interactive filling *)
let fill_in ?(show_optionals = true) input schema =
  let rec element path {title; kind; _} =
    match kind with
    | Integer {minimum; maximum; _} ->
        let minimum =
          match minimum with
          | None ->
              min_int
          | Some (m, `Inclusive) ->
              int_of_float m
          | Some (m, `Exclusive) ->
              int_of_float m + 1
        in
        let maximum =
          match maximum with
          | None ->
              max_int
          | Some (m, `Inclusive) ->
              int_of_float m
          | Some (m, `Exclusive) ->
              int_of_float m - 1
        in
        input.int minimum maximum title path
        >>= fun i -> Lwt.return (`Float (float i))
    | Number _ ->
        input.float title path >>= fun f -> Lwt.return (`Float f)
    | Boolean ->
        input.bool title path >>= fun f -> Lwt.return (`Bool f)
    | String _ ->
        input.string title path >>= fun f -> Lwt.return (`String f)
    | Combine ((One_of | Any_of), elts) ->
        let nb = List.length elts in
        input.int 0 (nb - 1) (Some "Select the schema to follow") path
        >>= fun n -> element path (List.nth elts n)
    | Combine ((All_of | Not), _) ->
        Lwt.fail Unsupported_construct
    | Def_ref name ->
        Lwt.return (`String (Json_query.json_pointer_of_path name))
    | Id_ref _ | Ext_ref _ ->
        Lwt.fail Unsupported_construct
    | Array (elts, _) ->
        let rec fill_loop acc n ls =
          match ls with
          | [] ->
              Lwt.return acc
          | elt :: elts ->
              element (string_of_int n :: path) elt
              >>= fun json -> fill_loop (json :: acc) (succ n) elts
        in
        fill_loop [] 0 elts >>= fun acc -> Lwt.return (`A (List.rev acc))
    | Object {properties; _} ->
        let properties =
          if show_optionals then properties
          else List.filter (fun (_, _, b, _) -> b) properties
        in
        let rec fill_loop acc ls =
          match ls with
          | [] ->
              Lwt.return acc
          | (n, elt, _, _) :: elts ->
              element (n :: path) elt
              >>= fun json -> fill_loop ((n, json) :: acc) elts
        in
        fill_loop [] properties >>= fun acc -> Lwt.return (`O (List.rev acc))
    | Monomorphic_array (elt, specs) ->
        let rec fill_loop acc min n max =
          if n > max then Lwt.return acc
          else
            element (string_of_int n :: path) elt
            >>= fun json ->
            (if n < min then Lwt.return_true else input.continue title path)
            >>= function
            | true ->
                fill_loop (json :: acc) min (succ n) max
            | false ->
                Lwt.return (json :: acc)
        in
        let max = match specs.max_items with None -> max_int | Some m -> m in
        fill_loop [] specs.min_items 0 max
        >>= fun acc -> Lwt.return (`A (List.rev acc))
    | Any ->
        Lwt.fail Unsupported_construct
    | Dummy ->
        Lwt.fail Unsupported_construct
    | Null ->
        Lwt.return `Null
  in
  element [] (Json_schema.root schema)

let random_fill_in ?(show_optionals = true) schema =
  let display _ = Lwt.return_unit in
  let int min max _ _ =
    let max = Int64.of_int max and min = Int64.of_int min in
    let range = Int64.sub max min in
    let random_int64 = Int64.add (Random.int64 range) min in
    Lwt.return (Int64.to_int random_int64)
  in
  let string _title _ = Lwt.return "" in
  let float _ _ = Lwt.return (Random.float infinity) in
  let bool _ _ = Lwt.return (Random.int 2 = 0) in
  let continue _ _ = Lwt.return (Random.int 4 = 0) in
  Lwt.catch
    (fun () ->
      fill_in
        ~show_optionals
        {int; float; string; bool; display; continue}
        schema
      >>= fun json -> Lwt.return_ok json)
    (fun e ->
      let msg =
        Printf.sprintf "Fill-in failed %s\n%!" (Printexc.to_string e)
      in
      Lwt.return_error msg)

let editor_fill_in ?(show_optionals = true) schema =
  let tmp = Filename.temp_file "tezos_rpc_call_" ".json" in
  let rec init () =
    (* write a temp file with instructions *)
    random_fill_in ~show_optionals schema
    >>= function
    | Error msg ->
        Lwt.return_error msg
    | Ok json ->
        Lwt_io.(
          with_file ~mode:Output tmp (fun fp ->
              write_line fp (Data_encoding.Json.to_string json)))
        >>= fun () -> edit ()
  and edit () =
    (* launch the user's editor on it *)
    let editor_cmd =
      let ed =
        match (Sys.getenv_opt "EDITOR", Sys.getenv_opt "VISUAL") with
        | (Some ed, _) ->
            ed
        | (None, Some ed) ->
            ed
        | (None, None) when Sys.win32 ->
            (* TODO: I have no idea what I'm doing here *)
            "notepad.exe"
        | _ ->
            (* TODO: vi on MacOSX ? *)
            "nano"
      in
      Lwt_process.shell (ed ^ " " ^ tmp)
    in
    (Lwt_process.open_process_none editor_cmd)#status
    >>= function
    | Unix.WEXITED 0 ->
        reread () >>= fun json -> delete () >>= fun () -> Lwt.return json
    | Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x ->
        let msg = Printf.sprintf "FAILED %d \n%!" x in
        delete () >>= fun () -> Lwt.return_error msg
  and reread () =
    (* finally reread the file *)
    Lwt_io.(with_file ~mode:Input tmp (fun fp -> read fp))
    >>= fun text ->
    match Data_encoding.Json.from_string text with
    | Ok r ->
        Lwt.return_ok r
    | Error msg ->
        Lwt.return_error (Format.asprintf "bad input: %s" msg)
  and delete () =
    (* and delete the temp file *)
    Lwt_unix.unlink tmp
  in
  init ()

(*-- Nice list display ------------------------------------------------------*)

let rec count =
  let open RPC_description in
  function
  | Empty ->
      0
  | Dynamic _ ->
      1
  | Static {services; subdirs} ->
      let service = RPC_service.MethMap.cardinal services in
      let subdirs =
        match subdirs with
        | None ->
            0
        | Some (Suffixes subdirs) ->
            Resto.StringMap.fold (fun _ t r -> r + count t) subdirs 0
        | Some (Arg (_, subdir)) ->
            count subdir
      in
      service + subdirs

(*-- Commands ---------------------------------------------------------------*)

let list url (cctxt : #Client_context.full) =
  let args = String.split '/' url in
  RPC_description.describe cctxt ~recurse:true args
  >>=? fun tree ->
  let open RPC_description in
  let collected_args = ref [] in
  let collect arg =
    if not (arg.RPC_arg.descr <> None && List.mem arg !collected_args) then
      collected_args := arg :: !collected_args
  in
  let display_paragraph ppf description =
    Format.fprintf
      ppf
      "@,    @[%a@]"
      (fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words)
      (String.split ' ' description)
  in
  let display_arg ppf arg =
    match arg.RPC_arg.descr with
    | None ->
        Format.fprintf ppf "%s" arg.RPC_arg.name
    | Some descr ->
        Format.fprintf ppf "<%s>%a" arg.RPC_arg.name display_paragraph descr
  in
  let display_service ppf (_path, tpath, service) =
    Format.fprintf
      ppf
      "- %s /%s"
      (RPC_service.string_of_meth service.meth)
      (String.concat "/" tpath) ;
    match service.description with
    | None | Some "" ->
        ()
    | Some description ->
        display_paragraph ppf description
  in
  let display_services ppf (_path, tpath, services) =
    Format.pp_print_list
      (fun ppf (_, s) -> display_service ppf (_path, tpath, s))
      ppf
      (RPC_service.MethMap.bindings services)
  in
  let rec display ppf (path, tpath, tree) =
    match tree with
    | Dynamic description -> (
        Format.fprintf ppf "- /%s <dynamic>" (String.concat "/" tpath) ;
        match description with
        | None | Some "" ->
            ()
        | Some description ->
            display_paragraph ppf description )
    | Empty ->
        ()
    | Static {services; subdirs = None} ->
        display_services ppf (path, tpath, services)
    | Static {services; subdirs = Some (Suffixes subdirs)} -> (
      match
        ( RPC_service.MethMap.cardinal services,
          Resto.StringMap.bindings subdirs )
      with
      | (0, []) ->
          ()
      | (0, [(n, solo)]) ->
          display ppf (path @ [n], tpath @ [n], solo)
      | (_, items) when count tree >= 3 && path <> [] ->
          Format.fprintf
            ppf
            "@[<v 2>+ %s/@,%a@]"
            (String.concat "/" path)
            (display_list tpath)
            items
      | (_, items) when count tree >= 3 && path <> [] ->
          Format.fprintf
            ppf
            "@[<v 2>+ %s@,%a@,%a@]"
            (String.concat "/" path)
            display_services
            (path, tpath, services)
            (display_list tpath)
            items
      | (0, (n, t) :: items) ->
          Format.fprintf ppf "%a" display (path @ [n], tpath @ [n], t) ;
          List.iter
            (fun (n, t) ->
              Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t))
            items
      | (_, items) ->
          display_services ppf (path, tpath, services) ;
          List.iter
            (fun (n, t) ->
              Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t))
            items )
    | Static {services; subdirs = Some (Arg (arg, solo))}
      when RPC_service.MethMap.cardinal services = 0 ->
        collect arg ;
        let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
        display ppf (path @ [name], tpath @ [name], solo)
    | Static {services; subdirs = Some (Arg (arg, solo))} ->
        collect arg ;
        display_services ppf (path, tpath, services) ;
        Format.fprintf ppf "@," ;
        let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
        display ppf (path @ [name], tpath @ [name], solo)
  and display_list tpath =
    Format.pp_print_list (fun ppf (n, t) -> display ppf ([n], tpath @ [n], t))
  in
  cctxt#message
    "@ @[<v 2>Available services:@ @ %a@]@."
    display
    (args, args, tree)
  >>= fun () ->
  if !collected_args <> [] then
    cctxt#message
      "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
      (Format.pp_print_list display_arg)
      !collected_args
    >>= fun () -> return_unit
  else return_unit

let schema meth url (cctxt : #Client_context.full) =
  let args = String.split '/' url in
  let open RPC_description in
  RPC_description.describe cctxt ~recurse:false args
  >>=? function
  | Static {services; _} -> (
    match RPC_service.MethMap.find_opt meth services with
    | None ->
        cctxt#message
          "No service found at this URL (but this is a valid prefix)\n%!"
        >>= fun () -> return_unit
    | Some {input = Some input; output; _} ->
        let json =
          `O
            [ ("input", Json_schema.to_json (fst input));
              ("output", Json_schema.to_json (fst output)) ]
        in
        cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
        >>= fun () -> return_unit
    | Some {input = None; output; _} ->
        let json = `O [("output", Json_schema.to_json (fst output))] in
        cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
        >>= fun () -> return_unit )
  | _ ->
      cctxt#message
        "No service found at this URL (but this is a valid prefix)\n%!"
      >>= fun () -> return_unit

let format binary meth url (cctxt : #Client_context.io_rpcs) =
  let args = String.split '/' url in
  let open RPC_description in
  let pp =
    if binary then fun ppf (_, schema) ->
      Data_encoding.Binary_schema.pp ppf schema
    else fun ppf (schema, _) -> Json_schema.pp ppf schema
  in
  RPC_description.describe cctxt ~recurse:false args
  >>=? function
  | Static {services; _} -> (
    match RPC_service.MethMap.find_opt meth services with
    | None ->
        cctxt#message
          "No service found at this URL (but this is a valid prefix)\n%!"
        >>= fun () -> return_unit
    | Some {input = Some input; output; _} ->
        cctxt#message
          "@[<v 0>@[<v 2>Input format:@,%a@]@,@[<v 2>Output format:@,%a@]@,@]"
          pp
          input
          pp
          output
        >>= fun () -> return_unit
    | Some {input = None; output; _} ->
        cctxt#message "@[<v 0>@[<v 2>Output format:@,%a@]@,@]" pp output
        >>= fun () -> return_unit )
  | _ ->
      cctxt#message
        "No service found at this URL (but this is a valid prefix)\n%!"
      >>= fun () -> return_unit

let fill_in ?(show_optionals = true) schema =
  let open Json_schema in
  match (root schema).kind with
  | Null ->
      Lwt.return_ok `Null
  | Any | Object {properties = []; _} ->
      Lwt.return_ok (`O [])
  | _ ->
      editor_fill_in ~show_optionals schema

let display_answer (cctxt : #Client_context.full) = function
  | `Ok json ->
      cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
      >>= fun () -> return_unit
  | `Not_found _ ->
      cctxt#message "No service found at this URL\n%!"
      >>= fun () -> return_unit
  | `Error (Some json) ->
      cctxt#message
        "@[<v 2>Command failed :@[ %a@]@]@."
        (Format.pp_print_list Error_monad.pp)
        (Data_encoding.Json.destruct
           (Data_encoding.list Error_monad.error_encoding)
           json)
      >>= fun () -> return_unit
  | `Error None | `Unauthorized _ | `Forbidden _ | `Conflict _ ->
      cctxt#message "Unexpected server answer\n%!" >>= fun () -> return_unit

let call meth raw_url (cctxt : #Client_context.full) =
  let uri = Uri.of_string raw_url in
  let args = String.split_path (Uri.path uri) in
  RPC_description.describe cctxt ~recurse:false args
  >>=? function
  | Static {services; _} -> (
    match RPC_service.MethMap.find_opt meth services with
    | None ->
        cctxt#message
          "No service found at this URL with this method (but this is a valid \
           prefix)\n\
           %!"
        >>= fun () -> return_unit
    | Some {input = None; _} ->
        cctxt#generic_json_call meth uri >>=? display_answer cctxt
    | Some {input = Some input; _} -> (
        fill_in ~show_optionals:false (fst input)
        >>= function
        | Error msg ->
            cctxt#error "%s" msg >>= fun () -> return_unit
        | Ok json ->
            cctxt#generic_json_call meth ~body:json uri
            >>=? display_answer cctxt ) )
  | _ ->
      cctxt#message "No service found at this URL\n%!"
      >>= fun () -> return_unit

let call_with_json meth raw_url json (cctxt : #Client_context.full) =
  let uri = Uri.of_string raw_url in
  match Data_encoding.Json.from_string json with
  | exception Assert_failure _ ->
      (* Ref : https://github.com/mirage/ezjsonm/issues/31 *)
      cctxt#error
        "Failed to parse the provided json: unwrapped JSON value.\n%!"
  | Error err ->
      cctxt#error "Failed to parse the provided json: %s\n%!" err
  | Ok body ->
      cctxt#generic_json_call meth ~body uri >>=? display_answer cctxt

let call_with_file_or_json meth url maybe_file (cctxt : #Client_context.full) =
  ( match TzString.split ':' ~limit:1 maybe_file with
  | ["file"; filename] ->
      (* Mostly copied from src/client/client_aliases.ml *)
      Lwt.catch
        (fun () ->
          Lwt_io.(with_file ~mode:Input filename read)
          >>= fun content -> return content)
        (fun exn -> failwith "cannot read file (%s)" (Printexc.to_string exn))
  | _ ->
      return maybe_file )
  >>=? fun json -> call_with_json meth url json cctxt

let meth_params ?(name = "HTTP method") ?(desc = "") params =
  param
    ~name
    ~desc
    (parameter
       ~autocomplete:(fun _ ->
         return
         @@ List.map String.lowercase_ascii
         @@ List.map Resto.string_of_meth
         @@ [`GET; `POST; `DELETE; `PUT; `PATCH])
       (fun _ name ->
         match Resto.meth_of_string (String.uppercase_ascii name) with
         | None ->
             failwith "Unknown HTTP method: %s" name
         | Some meth ->
             return meth))
    params

let group = {Clic.name = "rpc"; title = "Commands for the low level RPC layer"}

let commands =
  [ command
      ~group
      ~desc:
        "List RPCs under a given URL prefix.\n\
         Some parts of the RPC service hierarchy depend on parameters,\n\
         they are marked by a suffix `<dynamic>`.\n\
         You can list these sub-hierarchies by providing a concrete URL \
         prefix whose arguments are set to a valid value."
      no_options
      ( prefixes ["rpc"; "list"]
      @@ string ~name:"url" ~desc:"the URL prefix"
      @@ stop )
      (fun () -> list);
    command
      ~group
      ~desc:"Alias to `rpc list /`."
      no_options
      (prefixes ["rpc"; "list"] @@ stop)
      (fun () -> list "/");
    command
      ~group
      ~desc:"Get the input and output JSON schemas of an RPC."
      no_options
      ( prefixes ["rpc"; "schema"]
      @@ meth_params
      @@ string ~name:"url" ~desc:"the RPC url"
      @@ stop )
      (fun () -> schema);
    command
      ~group
      ~desc:"Get the humanoid readable input and output formats of an RPC."
      (args1 (switch ~doc:"Binary format" ~short:'b' ~long:"binary" ()))
      ( prefixes ["rpc"; "format"]
      @@ meth_params
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      format;
    command
      ~group
      ~desc:"Call an RPC with the GET method."
      no_options
      ( prefixes ["rpc"; "get"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      (fun () -> call `GET);
    command
      ~group
      ~desc:
        "Call an RPC with the POST method.\n\
         It invokes $EDITOR if input data is needed."
      no_options
      ( prefixes ["rpc"; "post"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      (fun () -> call `POST);
    command
      ~group
      ~desc:
        "Call an RPC with the POST method,  providing input data via the \
         command line."
      no_options
      ( prefixes ["rpc"; "post"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ prefix "with"
      @@ string
           ~name:"input"
           ~desc:
             "the raw JSON input to the RPC\n\
              For instance, use `{}` to send the empty document.\n\
              Alternatively, use `file:path` to read the JSON data from a file."
      @@ stop )
      (fun () -> call_with_file_or_json `POST);
    command
      ~group
      ~desc:
        "Call an RPC with the PUT method.\n\
         It invokes $EDITOR if input data is needed."
      no_options
      ( prefixes ["rpc"; "put"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      (fun () -> call `PUT);
    command
      ~group
      ~desc:
        "Call an RPC with the PUT method,  providing input data via the \
         command line."
      no_options
      ( prefixes ["rpc"; "put"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ prefix "with"
      @@ string
           ~name:"input"
           ~desc:
             "the raw JSON input to the RPC\n\
              For instance, use `{}` to send the empty document.\n\
              Alternatively, use `file:path` to read the JSON data from a file."
      @@ stop )
      (fun () -> call_with_file_or_json `PUT);
    command
      ~group
      ~desc:"Call an RPC with the DELETE method."
      no_options
      ( prefixes ["rpc"; "delete"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      (fun () -> call `DELETE) ]
src/bin_client/client_rpc_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Import Tezos_base__TzPervasives.Clic.

Import Json_schema.

Record input := {
  int : Z -> Z -> (option string) -> (list string) -> Lwt.t Z;
  float : (option string) -> (list string) -> Lwt.t float;
  string : (option string) -> (list string) -> Lwt.t string;
  bool : (option string) -> (list string) -> Lwt.t bool;
  continue : (option string) -> (list string) -> Lwt.t bool;
  display : string -> Lwt.t unit }.

Definition fill_in (op_star_o_p_t_star : option bool)
  : input -> Json_schema.schema -> Lwt.t variant :=
  let show_optionals :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun input =>
    fun schema =>
      let fix element
        (path : list string) (function_parameter : Json_schema.element)
        : Lwt.t variant :=
        match function_parameter with
        | {| title := title; kind := kind |} =>
          match kind with
          | Integer {| minimum := minimum; maximum := maximum |} =>
            let minimum :=
              match minimum with
              | None => Stdlib.min_int
              | Some (m, Inclusive) => Stdlib.int_of_float m
              | Some (m, Exclusive) => Z.add (Stdlib.int_of_float m) 1
              end in
            let maximum :=
              match maximum with
              | None => Stdlib.max_int
              | Some (m, Inclusive) => Stdlib.int_of_float m
              | Some (m, Exclusive) => Z.sub (Stdlib.int_of_float m) 1
              end in
            Lwt.Infix.op_gt_gt_eq ((Z input) minimum maximum title path)
              (fun i => Lwt._return variant)
          | Number _ =>
            Lwt.Infix.op_gt_gt_eq ((float input) title path)
              (fun f => Lwt._return variant)
          | Boolean =>
            Lwt.Infix.op_gt_gt_eq ((bool input) title path)
              (fun f => Lwt._return variant)
          | String _ =>
            Lwt.Infix.op_gt_gt_eq ((string input) title path)
              (fun f => Lwt._return variant)
          | Combine (One_of | Any_of) elts =>
            let nb := Tezos_base__TzPervasives.List.length elts in
            Lwt.Infix.op_gt_gt_eq
              ((Z input) 0 (Z.sub nb 1)
                (Some "Select the schema to follow" % string) path)
              (fun n => element path (Tezos_base__TzPervasives.List.nth elts n))
          | Combine (All_of | Not) _ => Lwt.fail Unsupported_construct
          | Def_ref name => Lwt._return variant
          | Id_ref _ | Ext_ref _ => Lwt.fail Unsupported_construct
          | Array elts _ =>
            let fix fill_loop
              (acc : list variant) (n : Z) (ls : list Json_schema.element)
              : Lwt.t (list variant) :=
              match ls with
              | [] => Lwt._return acc
              | cons elt elts =>
                Lwt.Infix.op_gt_gt_eq
                  (element (cons (OCaml.Stdlib.string_of_int n) path) elt)
                  (fun json => fill_loop (cons json acc) (Z.succ n) elts)
              end in
            Lwt.Infix.op_gt_gt_eq (fill_loop [] 0 elts)
              (fun acc => Lwt._return variant)
          | Object {| properties := properties |} =>
            let properties :=
              if show_optionals then
                properties
              else
                Tezos_base__TzPervasives.List.filter
                  (fun function_parameter =>
                    match function_parameter with
                    | (_, _, b, _) => b
                    end) properties in
            let fix fill_loop {A B : Type}
              (acc : list (string * variant)) (ls :
              list (string * Json_schema.element * A * B))
              : Lwt.t (list (string * variant)) :=
              match ls with
              | [] => Lwt._return acc
              | cons (n, elt, _, _) elts =>
                Lwt.Infix.op_gt_gt_eq (element (cons n path) elt)
                  (fun json => fill_loop (cons (n, json) acc) elts)
              end in
            Lwt.Infix.op_gt_gt_eq (fill_loop [] properties)
              (fun acc => Lwt._return variant)
          | Monomorphic_array elt specs =>
            let fix fill_loop (acc : list variant) (min : Z) (n : Z) (max : Z)
              : Lwt.t (list variant) :=
              if OCaml.Stdlib.gt n max then
                Lwt._return acc
              else
                Lwt.Infix.op_gt_gt_eq
                  (element (cons (OCaml.Stdlib.string_of_int n) path) elt)
                  (fun json =>
                    Lwt.Infix.op_gt_gt_eq
                      (if OCaml.Stdlib.lt n min then
                        Lwt.return_true
                      else
                        (continue input) title path)
                      (fun function_parameter =>
                        match function_parameter with
                        | true => fill_loop (cons json acc) min (Z.succ n) max
                        | false => Lwt._return (cons json acc)
                        end)) in
            let max :=
              match max_items specs with
              | None => Stdlib.max_int
              | Some m => m
              end in
            Lwt.Infix.op_gt_gt_eq (fill_loop [] (min_items specs) 0 max)
              (fun acc => Lwt._return variant)
          | Any => Lwt.fail Unsupported_construct
          | Dummy => Lwt.fail Unsupported_construct
          | Null => Lwt._return variant
          end
        end in
      element [] (Json_schema.root schema).

Definition random_fill_in (op_star_o_p_t_star : option bool)
  : Json_schema.schema -> Lwt.t (Result.result variant string) :=
  let show_optionals :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun schema =>
    let display {A : Type} (function_parameter : A) : Lwt.t unit :=
      match function_parameter with
      | _ => Lwt.return_unit
      end in
    let int {A B : Type} (min : Z) (max : Z) (function_parameter : A)
      : B -> Lwt.t Z :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ =>
            let max : int64 :=
              Stdlib.Int64.of_int max
            with min : int64 :=
              Stdlib.Int64.of_int min in
            let range := Stdlib.Int64.sub max min in
            let random_int64 := Stdlib.Int64.add (Stdlib.Random.int64 range) min
              in
            Lwt._return (Stdlib.Int64.to_int random_int64)
          end
      end in
    let string {A B : Type} (_title : A) (function_parameter : B)
      : Lwt.t string :=
      match function_parameter with
      | _ => Lwt._return "" % string
      end in
    let float {A B : Type} (function_parameter : A) : B -> Lwt.t float :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => Lwt._return (Stdlib.Random.float Stdlib.infinity)
          end
      end in
    let bool {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => Lwt._return (equiv_decb (Stdlib.Random.int 2) 0)
          end
      end in
    let continue {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => Lwt._return (equiv_decb (Stdlib.Random.int 4) 0)
          end
      end in
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Lwt.Infix.op_gt_gt_eq
            (fill_in (Some show_optionals)
              {| Z := Z; float := float; string := string; bool := bool;
                continue := continue; display := display |} schema)
            (fun json => Lwt.return_ok json)
        end)
      (fun e =>
        let msg :=
          Stdlib.Printf.sprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Fill-in failed " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal "010" % char
                    (CamlinternalFormatBasics.Flush
                      CamlinternalFormatBasics.End_of_format))))
              "Fill-in failed %s
%!" % string) (Stdlib.Printexc.to_string e) in
        Lwt.return_error msg).

Definition editor_fill_in (op_star_o_p_t_star : option bool)
  : Json_schema.schema ->
    Lwt.t
      (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
  let show_optionals :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun schema =>
    let tmp :=
      Stdlib.Filename.temp_file None "tezos_rpc_call_" % string ".json" % string
      in
    let fix init (function_parameter : unit)
      : Lwt.t
        (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
      match function_parameter with
      | tt =>
        Lwt.Infix.op_gt_gt_eq (random_fill_in (Some show_optionals) schema)
          (fun function_parameter =>
            match function_parameter with
            | inr msg => Lwt.return_error msg
            | inl json =>
              Lwt.Infix.op_gt_gt_eq
                (Lwt_io.with_file None None None Output tmp
                  (fun fp =>
                    Lwt_io.write_line fp
                      (Tezos_base__TzPervasives.Data_encoding.Json.to_string
                        None None json)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => edit tt
                  end)
            end)
      end
    with edit (function_parameter : unit)
      : Lwt.t
        (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
      match function_parameter with
      | tt =>
        let editor_cmd :=
          let ed :=
            match
              ((Stdlib.Sys.getenv_opt "EDITOR" % string),
                (Stdlib.Sys.getenv_opt "VISUAL" % string)) with
            | (Some ed, _) => ed
            | (None, Some ed) => ed
            | _ => "nano" % string
            end in
          Lwt_process.shell (String.append ed (String.append " " % string tmp))
          in
        Lwt.Infix.op_gt_gt_eq send
          (fun function_parameter =>
            match function_parameter with
            | Unix.WEXITED 0 =>
              Lwt.Infix.op_gt_gt_eq (reread tt)
                (fun json =>
                  Lwt.Infix.op_gt_gt_eq (delete tt)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Lwt._return json
                      end))
            | Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x =>
              let msg :=
                Stdlib.Printf.sprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "FAILED " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal " 
" % string
                          (CamlinternalFormatBasics.Flush
                            CamlinternalFormatBasics.End_of_format))))
                    "FAILED %d 
%!" % string) x in
              Lwt.Infix.op_gt_gt_eq (delete tt)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Lwt.return_error msg
                  end)
            end)
      end
    with reread (function_parameter : unit)
      : Lwt.t
        (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
      match function_parameter with
      | tt =>
        Lwt.Infix.op_gt_gt_eq
          (Lwt_io.with_file None None None Input tmp
            (fun fp => Lwt_io.read None fp))
          (fun text =>
            match Tezos_base__TzPervasives.Data_encoding.Json.from_string text
              with
            | inl r => Lwt.return_ok r
            | inr msg =>
              Lwt.return_error
                (Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "bad input: " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "bad input: %s" % string) msg)
            end)
      end
    with delete (function_parameter : unit) : Lwt.t unit :=
      match function_parameter with
      | tt => Lwt_unix.unlink tmp
      end in
    init tt.

Fixpoint count {A : Type}
  (function_parameter : Tezos_base__TzPervasives.RPC_description.directory A)
  : Z :=
  match function_parameter with
  | Empty => 0
  | Dynamic _ => 1
  | Static {| services := services; subdirs := subdirs |} =>
    let service :=
      Tezos_base__TzPervasives.RPC_service.MethMap.cardinal services in
    let subdirs :=
      match subdirs with
      | None => 0
      | Some (Suffixes subdirs) =>
        Resto.StringMap.fold
          (fun function_parameter =>
            match function_parameter with
            | _ => fun t => fun r => Z.add r (count t)
            end) subdirs 0
      | Some (Arg _ subdir) => count subdir
      end in
    Z.add service subdirs
  end.

Definition list {F G I a b i o p q : Type}
  (url : string)
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let args := Tezos_base__TzPervasives.String.split "/" % char None None url in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.RPC_description.describe cctxt (Some true) args)
    (fun tree =>
      let collected_args := Stdlib.ref [] in
      let collect (arg : Tezos_base__TzPervasives.RPC_arg.descr) : unit :=
        if
          negb
            (andb (nequiv_decb (RPC_arg.descr arg) None)
              (Tezos_base__TzPervasives.List.mem arg
                (Stdlib.op_exclamation collected_args))) then
          Stdlib.op_colon_eq collected_args
            (cons arg (Stdlib.op_exclamation collected_args))
        else
          tt in
      let display_paragraph
        (ppf : Stdlib.Format.formatter) (description : string) : unit :=
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "    " % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@,    @[%a@]" % string)
          (fun ppf =>
            fun words =>
              Tezos_base__TzPervasives.List.iter
                (Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        CamlinternalFormatBasics.End_of_format)) "%s@ " % string))
                words)
          (Tezos_base__TzPervasives.String.split " " % char None None
            description) in
      let display_arg
        (ppf : Stdlib.Format.formatter) (arg :
        Tezos_base__TzPervasives.RPC_arg.descr) : unit :=
        match RPC_arg.descr arg with
        | None =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string)
            (RPC_arg.name arg)
        | Some descr =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Char_literal "<" % char
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal ">" % char
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))
              "<%s>%a" % string) (RPC_arg.name arg) display_paragraph descr
        end in
      let display_service {J K : Type}
        (ppf : Stdlib.Format.formatter) (function_parameter :
        J * (list string) * (Tezos_base__TzPervasives.RPC_description.service K))
        : unit :=
        match function_parameter with
        | (_path, tpath, service) =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "- " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " /" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))))
              "- %s /%s" % string)
            (Tezos_base__TzPervasives.RPC_service.string_of_meth (meth service))
            (Tezos_base__TzPervasives.String.concat "/" % string tpath);
          match description service with
          | None | Some "" % string => tt
          | Some description => display_paragraph ppf description
          end
        end in
      let display_services {J K : Type}
        (ppf : Stdlib.Format.formatter) (function_parameter :
        J * (list string) *
          (Tezos_base__TzPervasives.RPC_service.MethMap.t
            (Tezos_base__TzPervasives.RPC_description.service K))) : unit :=
        match function_parameter with
        | (_path, tpath, services) =>
          Stdlib.Format.pp_print_list None
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | (_, s) => display_service ppf (_path, tpath, s)
                end) ppf
            (Tezos_base__TzPervasives.RPC_service.MethMap.bindings services)
        end in
      let fix display {J : Type}
        (ppf : Stdlib.Format.formatter) (function_parameter :
        (list Resto.StringMap.key) * (list Resto.StringMap.key) *
          (Tezos_base__TzPervasives.RPC_description.directory J)) : unit :=
        match function_parameter with
        | (path, tpath, tree) =>
          match tree with
          | Dynamic description =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "- /" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " <dynamic>" % string
                      CamlinternalFormatBasics.End_of_format)))
                "- /%s <dynamic>" % string)
              (Tezos_base__TzPervasives.String.concat "/" % string tpath);
            match description with
            | None | Some "" % string => tt
            | Some description => display_paragraph ppf description
            end
          | Empty => tt
          | Static {| services := services; subdirs := None |} =>
            display_services ppf (path, tpath, services)
          |
            Static {|
              services := services; subdirs := Some (Suffixes subdirs) |} =>
            match
              ((Tezos_base__TzPervasives.RPC_service.MethMap.cardinal services),
                (Resto.StringMap.bindings subdirs)) with
            | (0, []) => tt
            | (0, cons (n, solo) []) =>
              display ppf
                ((OCaml.Stdlib.app path (cons n [])),
                  (OCaml.Stdlib.app tpath (cons n [])), solo)
            | (0, cons (n, t) items) =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                display
                ((OCaml.Stdlib.app path (cons n [])),
                  (OCaml.Stdlib.app tpath (cons n [])), t);
              Tezos_base__TzPervasives.List.iter
                (fun function_parameter =>
                  match function_parameter with
                  | (n, t) =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        "@,%a" % string) display
                      ((OCaml.Stdlib.app path (cons n [])),
                        (OCaml.Stdlib.app tpath (cons n [])), t)
                  end) items
            | (_, items) =>
              display_services ppf (path, tpath, services);
              Tezos_base__TzPervasives.List.iter
                (fun function_parameter =>
                  match function_parameter with
                  | (n, t) =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        "@,%a" % string) display
                      ((OCaml.Stdlib.app path (cons n [])),
                        (OCaml.Stdlib.app tpath (cons n [])), t)
                  end) items
            end
          | Static {| services := services; subdirs := Some (Arg arg solo) |} =>
            collect arg;
            display_services ppf (path, tpath, services);
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  CamlinternalFormatBasics.End_of_format) "@," % string);
            let name :=
              Stdlib.Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Char_literal "<" % char
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal ">" % char
                        CamlinternalFormatBasics.End_of_format)))
                  "<%s>" % string) (RPC_arg.name arg) in
            display ppf
              ((OCaml.Stdlib.app path (cons name [])),
                (OCaml.Stdlib.app tpath (cons name [])), solo)
          end
        end
      with display_list {J : Type} (tpath : list Resto.StringMap.key)
        : Stdlib.Format.formatter ->
          (list
            (Resto.StringMap.key *
              (Tezos_base__TzPervasives.RPC_description.directory J))) -> unit :=
        Stdlib.Format.pp_print_list None
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              | (n, t) =>
                display ppf
                  ((cons n []), (OCaml.Stdlib.app tpath (cons n [])), t)
              end) in
      Lwt.Infix.op_gt_gt_eq
        (send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Available services:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))))))
            "@ @[<v 2>Available services:@ @ %a@]@." % string) display
          (args, args, tree))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            if nequiv_decb (Stdlib.op_exclamation collected_args) [] then
              Lwt.Infix.op_gt_gt_eq
                (send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Dynamic parameter description:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format))))))))
                    "@,@[<v 2>Dynamic parameter description:@ @ %a@]@." % string)
                  (Stdlib.Format.pp_print_list None display_arg)
                  (Stdlib.op_exclamation collected_args))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            else
              Tezos_base__TzPervasives.return_unit
          end)).

Definition schema {F G I a b i o p q : Type}
  (meth : Tezos_base__TzPervasives.RPC_service.MethMap.key) (url : string)
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let args := Tezos_base__TzPervasives.String.split "/" % char None None url in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.RPC_description.describe cctxt (Some false) args)
    (fun function_parameter =>
      match function_parameter with
      | Static {| services := services |} =>
        match
          Tezos_base__TzPervasives.RPC_service.MethMap.find_opt meth services
          with
        | None =>
          Lwt.Infix.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No service found at this URL (but this is a valid prefix)
" %
                    string
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format))
                "No service found at this URL (but this is a valid prefix)
%!" %
                  string))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        | Some {| input := Some input; output := output |} =>
          let json := variant in
          Lwt.Infix.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              (Json_repr.pp None None Json_repr.Ezjsonm) json)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        | Some {| input := None; output := output |} =>
          let json := variant in
          Lwt.Infix.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              (Json_repr.pp None None Json_repr.Ezjsonm) json)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        end
      | _ =>
        Lwt.Infix.op_gt_gt_eq
          (send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "No service found at this URL (but this is a valid prefix)
" %
                  string
                (CamlinternalFormatBasics.Flush
                  CamlinternalFormatBasics.End_of_format))
              "No service found at this URL (but this is a valid prefix)
%!" %
                string))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition format {E F I a b i o p q : Type}
  (binary : bool) (meth : Tezos_base__TzPervasives.RPC_service.MethMap.key)
  (url : string)
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) *
        ((Tezos_rpc.RPC_service.meth ->
          (option Tezos_data_encoding.Data_encoding.json) ->
            Uri.t ->
              Lwt.t
                (Tezos_rpc.RPC_context.rest_result
                  Tezos_data_encoding.Data_encoding.json
                  (option Tezos_data_encoding.Data_encoding.json))) *
          (Uri.t *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                (a * b)) *
                (((string ->
                  (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                    * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a
                      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
                        (a)) *
                        ((((Tezos_client_base.Client_context.lwt_format a unit)
                          -> a) * (a)) * I))))))))))) * I)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let args := Tezos_base__TzPervasives.String.split "/" % char None None url in
  let pp :=
    if binary then
      fun ppf =>
        fun function_parameter =>
          match function_parameter with
          | (_, schema) =>
            Tezos_base__TzPervasives.Data_encoding.Binary_schema.pp ppf schema
          end
    else
      fun ppf =>
        fun function_parameter =>
          match function_parameter with
          | (schema, _) => Json_schema.pp ppf schema
          end in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.RPC_description.describe cctxt (Some false) args)
    (fun function_parameter =>
      match function_parameter with
      | Static {| services := services |} =>
        match
          Tezos_base__TzPervasives.RPC_service.MethMap.find_opt meth services
          with
        | None =>
          Lwt.Infix.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No service found at this URL (but this is a valid prefix)
" %
                    string
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format))
                "No service found at this URL (but this is a valid prefix)
%!" %
                  string))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        | Some {| input := Some input; output := output |} =>
          Lwt.Infix.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 0>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Input format:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "Output format:" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format))))))))))))))
                "@[<v 0>@[<v 2>Input format:@,%a@]@,@[<v 2>Output format:@,%a@]@,@]"
                  % string) pp input pp output)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        | Some {| input := None; output := output |} =>
          Lwt.Infix.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 0>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Output format:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))))
                "@[<v 0>@[<v 2>Output format:@,%a@]@,@]" % string) pp output)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        end
      | _ =>
        Lwt.Infix.op_gt_gt_eq
          (send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "No service found at this URL (but this is a valid prefix)
" %
                  string
                (CamlinternalFormatBasics.Flush
                  CamlinternalFormatBasics.End_of_format))
              "No service found at this URL (but this is a valid prefix)
%!" %
                string))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition fill_in (op_star_o_p_t_star : option bool)
  : Json_schema.schema ->
    Lwt.t
      (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
  let show_optionals :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun schema =>
    match kind (Json_schema.root schema) with
    | Null => Lwt.return_ok variant
    | Any | Object {| properties := [] |} => Lwt.return_ok variant
    | _ => editor_fill_in (Some show_optionals) schema
    end.

Definition display_answer {F G I a b i o p q : Type}
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (function_parameter : variant)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | Ok json =>
    Lwt.Infix.op_gt_gt_eq
      (send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) (Json_repr.pp None None Json_repr.Ezjsonm) json)
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives.return_unit
        end)
  | Not_found _ =>
    Lwt.Infix.op_gt_gt_eq
      (send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "No service found at this URL
" % string
            (CamlinternalFormatBasics.Flush
              CamlinternalFormatBasics.End_of_format))
          "No service found at this URL
%!" % string))
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives.return_unit
        end)
  | Error (Some json) =>
    Lwt.Infix.op_gt_gt_eq
      (send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String_literal "Command failed :" % string
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))))))
          "@[<v 2>Command failed :@[ %a@]@]@." % string)
        (Stdlib.Format.pp_print_list None
          Tezos_base__TzPervasives.Error_monad.pp)
        (Tezos_base__TzPervasives.Data_encoding.Json.destruct
          (Tezos_base__TzPervasives.Data_encoding.list None
            Tezos_base__TzPervasives.Error_monad.error_encoding) json))
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives.return_unit
        end)
  | Error None | Unauthorized _ | Forbidden _ | Conflict _ =>
    Lwt.Infix.op_gt_gt_eq
      (send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Unexpected server answer
" % string
            (CamlinternalFormatBasics.Flush
              CamlinternalFormatBasics.End_of_format))
          "Unexpected server answer
%!" % string))
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives.return_unit
        end)
  end.

Definition call {F G I a b i o p q : Type}
  (meth : Tezos_base__TzPervasives.RPC_service.MethMap.key) (raw_url : string)
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let uri := Uri.of_string raw_url in
  let args := Tezos_base__TzPervasives.String.split_path (Uri.path uri) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.RPC_description.describe cctxt (Some false) args)
    (fun function_parameter =>
      match function_parameter with
      | Static {| services := services |} =>
        match
          Tezos_base__TzPervasives.RPC_service.MethMap.find_opt meth services
          with
        | None =>
          Lwt.Infix.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No service found at this URL with this method (but this is a valid prefix)
"
                    % string
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format))
                "No service found at this URL with this method (but this is a valid prefix)
%!"
                  % string))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        | Some {| input := None |} =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question (send meth None uri)
            (display_answer cctxt)
        | Some {| input := Some input |} =>
          Lwt.Infix.op_gt_gt_eq (fill_in (Some false) (fst input))
            (fun function_parameter =>
              match function_parameter with
              | inr msg =>
                Lwt.Infix.op_gt_gt_eq
                  (send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format) "%s" % string)
                    msg)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives.return_unit
                    end)
              | inl json =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (send meth (Some json) uri) (display_answer cctxt)
              end)
        end
      | _ =>
        Lwt.Infix.op_gt_gt_eq
          (send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "No service found at this URL
" % string
                (CamlinternalFormatBasics.Flush
                  CamlinternalFormatBasics.End_of_format))
              "No service found at this URL
%!" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition call_with_json {F G I a b i o p q : Type}
  (meth : Tezos_rpc.RPC_service.meth) (raw_url : string) (json : string)
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let uri := Uri.of_string raw_url in
  match Tezos_base__TzPervasives.Data_encoding.Json.from_string json with
  | inr err =>
    send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to parse the provided json: " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              (CamlinternalFormatBasics.Flush
                CamlinternalFormatBasics.End_of_format))))
        "Failed to parse the provided json: %s
%!" % string) err
  | inl body =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question (send meth (Some body) uri)
      (display_answer cctxt)
  end.

Definition call_with_file_or_json {F G I a b i o p q : Type}
  (meth : Tezos_rpc.RPC_service.meth) (url : string) (maybe_file : string)
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match
      Tezos_base__TzPervasives.TzString.split ":" % char None (Some 1)
        maybe_file with
    | cons "file" % string (cons filename []) =>
      Lwt.catch
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Lwt.Infix.op_gt_gt_eq
              (Lwt_io.with_file None None None Input filename
                (let arg := Lwt_io.read in
                fun eta => arg None eta))
              (fun content => Tezos_base__TzPervasives._return content)
          end)
        (fun exn =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "cannot read file (" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))
              "cannot read file (%s)" % string) (Stdlib.Printexc.to_string exn))
    | _ => Tezos_base__TzPervasives._return maybe_file
    end (fun json => call_with_json meth url json cctxt).

Definition meth_params {A B : Type} (op_star_o_p_t_star : option string)
  : (option string) ->
    (Tezos_base__TzPervasives.Clic.params A B) ->
      Tezos_base__TzPervasives.Clic.params (variant -> A) B :=
  let name :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "HTTP method" % string
    end in
  fun op_star_o_p_t_star =>
    let desc :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => "" % string
      end in
    fun params =>
      Tezos_base__TzPervasives.Clic.param name desc
        (Tezos_base__TzPervasives.Clic.parameter
          (Some
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                apply Tezos_base__TzPervasives._return
                  (apply
                    (Tezos_base__TzPervasives.List.map
                      Tezos_base__TzPervasives.String.lowercase_ascii)
                    (apply
                      (Tezos_base__TzPervasives.List.map Resto.string_of_meth)
                      (cons variant
                        (cons variant
                          (cons variant (cons variant (cons variant [])))))))
              end))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              fun name =>
                match
                  Resto.meth_of_string
                    (Tezos_base__TzPervasives.String.uppercase_ascii name) with
                | None =>
                  Tezos_base__TzPervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Unknown HTTP method: " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.End_of_format))
                      "Unknown HTTP method: %s" % string) name
                | Some meth => Tezos_base__TzPervasives._return meth
                end
            end)) params.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "rpc" % string;
    Clic.title := "Commands for the low level RPC layer" % string |}.

Definition commands {F G I a b i o p q : Type}
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  cons
    (Tezos_base__TzPervasives.Clic.command (Some group)
      "List RPCs under a given URL prefix.
Some parts of the RPC service hierarchy depend on parameters,
they are marked by a suffix `<dynamic>`.
You can list these sub-hierarchies by providing a concrete URL prefix whose arguments are set to a valid value."
        % string Tezos_base__TzPervasives.Clic.no_options
      (apply
        (Tezos_base__TzPervasives.Clic.prefixes
          (cons "rpc" % string (cons "list" % string [])))
        (apply
          (Tezos_base__TzPervasives.Clic.string "url" % string
            "the URL prefix" % string) Tezos_base__TzPervasives.Clic.stop))
      (fun function_parameter =>
        match function_parameter with
        | tt => list
        end))
    (cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Alias to `rpc list /`." % string
        Tezos_base__TzPervasives.Clic.no_options
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "rpc" % string (cons "list" % string [])))
          Tezos_base__TzPervasives.Clic.stop)
        (fun function_parameter =>
          match function_parameter with
          | tt => list "/" % string
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Get the input and output JSON schemas of an RPC." % string
          Tezos_base__TzPervasives.Clic.no_options
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "rpc" % string (cons "schema" % string [])))
            (apply
              (let arg := meth_params in
              fun eta => arg None None eta)
              (apply
                (Tezos_base__TzPervasives.Clic.string "url" % string
                  "the RPC url" % string) Tezos_base__TzPervasives.Clic.stop)))
          (fun function_parameter =>
            match function_parameter with
            | tt => schema
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Get the humanoid readable input and output formats of an RPC." %
              string
            (Tezos_base__TzPervasives.Clic.args1
              (Tezos_base__TzPervasives.Clic.switch "Binary format" % string
                (Some "b" % char) "binary" % string tt))
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "rpc" % string (cons "format" % string [])))
              (apply
                (let arg := meth_params in
                fun eta => arg None None eta)
                (apply
                  (Tezos_base__TzPervasives.Clic.string "url" % string
                    "the RPC URL" % string) Tezos_base__TzPervasives.Clic.stop)))
            format)
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Call an RPC with the GET method." % string
              Tezos_base__TzPervasives.Clic.no_options
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "rpc" % string (cons "get" % string [])))
                (apply
                  (Tezos_base__TzPervasives.Clic.string "url" % string
                    "the RPC URL" % string) Tezos_base__TzPervasives.Clic.stop))
              (fun function_parameter =>
                match function_parameter with
                | tt => call variant
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Call an RPC with the POST method.
It invokes $EDITOR if input data is needed."
                  % string Tezos_base__TzPervasives.Clic.no_options
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "rpc" % string (cons "post" % string [])))
                  (apply
                    (Tezos_base__TzPervasives.Clic.string "url" % string
                      "the RPC URL" % string) Tezos_base__TzPervasives.Clic.stop))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => call variant
                  end))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some group)
                  "Call an RPC with the POST method,  providing input data via the command line."
                    % string Tezos_base__TzPervasives.Clic.no_options
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "rpc" % string (cons "post" % string [])))
                    (apply
                      (Tezos_base__TzPervasives.Clic.string "url" % string
                        "the RPC URL" % string)
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefix "with" % string)
                        (apply
                          (Tezos_base__TzPervasives.Clic.string "input" % string
                            "the raw JSON input to the RPC
For instance, use `{}` to send the empty document.
Alternatively, use `file:path` to read the JSON data from a file."
                              % string) Tezos_base__TzPervasives.Clic.stop))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => call_with_file_or_json variant
                    end))
                (cons
                  (Tezos_base__TzPervasives.Clic.command (Some group)
                    "Call an RPC with the PUT method.
It invokes $EDITOR if input data is needed."
                      % string Tezos_base__TzPervasives.Clic.no_options
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "rpc" % string (cons "put" % string [])))
                      (apply
                        (Tezos_base__TzPervasives.Clic.string "url" % string
                          "the RPC URL" % string)
                        Tezos_base__TzPervasives.Clic.stop))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => call variant
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Clic.command (Some group)
                      "Call an RPC with the PUT method,  providing input data via the command line."
                        % string Tezos_base__TzPervasives.Clic.no_options
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "rpc" % string (cons "put" % string [])))
                        (apply
                          (Tezos_base__TzPervasives.Clic.string "url" % string
                            "the RPC URL" % string)
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefix
                              "with" % string)
                            (apply
                              (Tezos_base__TzPervasives.Clic.string
                                "input" % string
                                "the raw JSON input to the RPC
For instance, use `{}` to send the empty document.
Alternatively, use `file:path` to read the JSON data from a file."
                                  % string) Tezos_base__TzPervasives.Clic.stop))))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => call_with_file_or_json variant
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Clic.command (Some group)
                        "Call an RPC with the DELETE method." % string
                        Tezos_base__TzPervasives.Clic.no_options
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "rpc" % string (cons "delete" % string [])))
                          (apply
                            (Tezos_base__TzPervasives.Clic.string "url" % string
                              "the RPC URL" % string)
                            Tezos_base__TzPervasives.Clic.stop))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => call variant
                          end)) []))))))))).
src/bin_client/client_rpc_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : Client_commands.command list
src/bin_client/client_rpc_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands : list Tezos_client_commands.Client_commands.command.
src/bin_client/main_admin.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "admin-client.main"
end)

let select_commands _ _ =
  return
    (List.flatten
       [ Client_report_commands.commands ();
         Client_admin_commands.commands ();
         Client_p2p_commands.commands ();
         Client_protocols_commands.commands ();
         Client_rpc_commands.commands;
         Client_event_logging_commands.commands () ])

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/bin_client/main_admin.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition select_commands {A B : Type} (function_parameter : A)
  : B ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full))) :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        Tezos_base__TzPervasives._return
          (Tezos_base__TzPervasives.List.flatten
            (cons (Tezos_client_commands.Client_report_commands.commands tt)
              (cons (Tezos_client_commands.Client_admin_commands.commands tt)
                (cons (Tezos_client_commands.Client_p2p_commands.commands tt)
                  (cons (Client_protocols_commands.commands tt)
                    (cons Client_rpc_commands.commands
                      (cons
                        (Tezos_client_commands.Client_event_logging_commands.commands
                          tt) [])))))))
      end
  end.
src/bin_client/main_client.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "client.main"
end)

open Client_config

let disable_disclaimer =
  match Sys.getenv_opt "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" with
  | Some ("yes" | "y" | "YES" | "Y") ->
      true
  | _ ->
      false

let zeronet () =
  if not disable_disclaimer then
    Format.eprintf
      "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
       @,\
      \               This is @{<warning>NOT@} the Tezos Mainnet.@,\
       @,\
      \    The node you are connecting to claims to be running on the@,\
      \               @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@,\
      \         Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
       Zeronet is a testing network, with free tokens and frequent resets.@]@\n\
       @."

let alphanet () =
  if not disable_disclaimer then
    Format.eprintf
      "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
       @,\
      \               This is @{<warning>NOT@} the Tezos Mainnet.@,\
       @,\
      \   The node you are connecting to claims to be running on the@,\
      \             @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@,\
      \        Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
      \        Alphanet is a testing network, with free tokens.@]@\n\
       @."

let mainnet () =
  if not disable_disclaimer then
    Format.eprintf
      "@[<v 2>@{<warning>@{<title>Disclaimer@}@}@,\
       The  Tezos  network  is  a  new  blockchain technology.@,\
       Users are  solely responsible  for any risks associated@,\
       with usage of the Tezos network.  Users should do their@,\
       own  research to determine  if Tezos is the appropriate@,\
       platform for their needs and should apply judgement and@,\
       care in their network interactions.@]@\n\
       @."

let sandbox () =
  if not disable_disclaimer then
    Format.eprintf
      "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
       @,\
      \ The node you are connecting to claims to be running in a@,\
      \                  @{<warning>Tezos TEST SANDBOX@}.@,\
      \    Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
       You should not see this message if you are not a developer.@]@\n\
       @."

let check_network ctxt =
  Shell_services.P2p.version ctxt
  >>= function
  | Error _ ->
      Lwt.return_none
  | Ok version ->
      let has_prefix prefix =
        String.has_prefix ~prefix (version.chain_name :> string)
      in
      if has_prefix "SANDBOXED" then (
        sandbox () ;
        Lwt.return_some `Sandbox )
      else if has_prefix "TEZOS_ZERONET" then (
        zeronet () ;
        Lwt.return_some `Zeronet )
      else if has_prefix "TEZOS_ALPHANET" then (
        alphanet () ;
        Lwt.return_some `Alphanet )
      else if has_prefix "TEZOS_BETANET" || has_prefix "TEZOS_MAINNET" then (
        mainnet () ;
        Lwt.return_some `Mainnet )
      else Lwt.return_none

let get_commands_for_version ctxt network chain block protocol =
  Shell_services.Blocks.protocols ctxt ~chain ~block ()
  >>= function
  | Ok {next_protocol = version; _} -> (
    match protocol with
    | None ->
        return
          (Some version, Client_commands.commands_for_version version network)
    | Some given_version ->
        if not (Protocol_hash.equal version given_version) then
          Format.eprintf
            "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
             The protocol provided via `--protocol` (%a)@,\
             is not the one retrieved from the node (%a).@]@\n\
             @."
            Protocol_hash.pp_short
            given_version
            Protocol_hash.pp_short
            version ;
        return
          ( Some version,
            Client_commands.commands_for_version given_version network ) )
  | Error errs -> (
    match protocol with
    | None ->
        Format.eprintf
          "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
           Failed to acquire the protocol version from the node@,\
           %a@]@\n\
           @."
          (Format.pp_print_list pp)
          errs ;
        return (None, [])
    | Some version ->
        return
          (Some version, Client_commands.commands_for_version version network)
    )

let select_commands ctxt {chain; block; protocol; _} =
  check_network ctxt
  >>= fun network ->
  get_commands_for_version ctxt network chain block protocol
  >>|? fun (_, commands_for_version) ->
  Client_rpc_commands.commands
  @ Tezos_signer_backends_unix.Ledger.commands ()
  @ Client_keys_commands.commands network
  @ Client_helpers_commands.commands ()
  @ commands_for_version

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/bin_client/main_client.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base_unix.Client_config.

Definition disable_disclaimer : bool :=
  match Stdlib.Sys.getenv_opt "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" % string
    with
  | Some ("yes" % string | "y" % string | "YES" % string | "Y" % string) => true
  | _ => false
  end.

Definition zeronet (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    if negb disable_disclaimer then
      Stdlib.Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<warning>" % string
                    CamlinternalFormatBasics.End_of_format) "<warning>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_tag
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<title>" % string
                      CamlinternalFormatBasics.End_of_format) "<title>" % string))
                (CamlinternalFormatBasics.String_literal "Warning" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "               This is " % string
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_tag
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<warning>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<warning>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "NOT" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_tag
                                  (CamlinternalFormatBasics.String_literal
                                    " the Tezos Mainnet." % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@," % string 0 0)
                                        (CamlinternalFormatBasics.String_literal
                                          "    The node you are connecting to claims to be running on the"
                                            % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@," % string 0 0)
                                            (CamlinternalFormatBasics.String_literal
                                              "               " % string
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_tag
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "<warning>" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "<warning>" % string))
                                                (CamlinternalFormatBasics.String_literal
                                                  "Tezos Zeronet DEVELOPMENT NETWORK"
                                                    % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_tag
                                                    (CamlinternalFormatBasics.Char_literal
                                                      "." % char
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@," % string 0 0)
                                                        (CamlinternalFormatBasics.String_literal
                                                          "         Do " %
                                                            string
                                                          (CamlinternalFormatBasics.Formatting_gen
                                                            (CamlinternalFormatBasics.Open_tag
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "<warning>" %
                                                                    string
                                                                  CamlinternalFormatBasics.End_of_format)
                                                                "<warning>" %
                                                                  string))
                                                            (CamlinternalFormatBasics.String_literal
                                                              "NOT" % string
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                CamlinternalFormatBasics.Close_tag
                                                                (CamlinternalFormatBasics.String_literal
                                                                  " use your fundraiser keys on this network."
                                                                    % string
                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                    (CamlinternalFormatBasics.Break
                                                                      "@," %
                                                                        string 0
                                                                      0)
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "Zeronet is a testing network, with free tokens and frequent resets."
                                                                        % string
                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                        CamlinternalFormatBasics.Close_box
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          CamlinternalFormatBasics.Force_newline
                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                            CamlinternalFormatBasics.Flush_newline
                                                                            CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))))))))))
          "@[<v 2>@{<warning>@{<title>Warning@}@}@,@,               This is @{<warning>NOT@} the Tezos Mainnet.@,@,    The node you are connecting to claims to be running on the@,               @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@,         Do @{<warning>NOT@} use your fundraiser keys on this network.@,Zeronet is a testing network, with free tokens and frequent resets.@]@
@."
            % string)
    else
      tt
  end.

Definition alphanet (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    if negb disable_disclaimer then
      Stdlib.Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<warning>" % string
                    CamlinternalFormatBasics.End_of_format) "<warning>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_tag
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<title>" % string
                      CamlinternalFormatBasics.End_of_format) "<title>" % string))
                (CamlinternalFormatBasics.String_literal "Warning" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "               This is " % string
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_tag
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<warning>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<warning>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "NOT" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_tag
                                  (CamlinternalFormatBasics.String_literal
                                    " the Tezos Mainnet." % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@," % string 0 0)
                                        (CamlinternalFormatBasics.String_literal
                                          "   The node you are connecting to claims to be running on the"
                                            % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@," % string 0 0)
                                            (CamlinternalFormatBasics.String_literal
                                              "             " % string
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_tag
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "<warning>" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "<warning>" % string))
                                                (CamlinternalFormatBasics.String_literal
                                                  "Tezos Alphanet DEVELOPMENT NETWORK."
                                                    % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_tag
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@," % string 0 0)
                                                      (CamlinternalFormatBasics.String_literal
                                                        "        Do " % string
                                                        (CamlinternalFormatBasics.Formatting_gen
                                                          (CamlinternalFormatBasics.Open_tag
                                                            (CamlinternalFormatBasics.Format
                                                              (CamlinternalFormatBasics.String_literal
                                                                "<warning>" %
                                                                  string
                                                                CamlinternalFormatBasics.End_of_format)
                                                              "<warning>" %
                                                                string))
                                                          (CamlinternalFormatBasics.String_literal
                                                            "NOT" % string
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Close_tag
                                                              (CamlinternalFormatBasics.String_literal
                                                                " use your fundraiser keys on this network."
                                                                  % string
                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                  (CamlinternalFormatBasics.Break
                                                                    "@," %
                                                                      string 0 0)
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "        Alphanet is a testing network, with free tokens."
                                                                      % string
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      CamlinternalFormatBasics.Close_box
                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                        CamlinternalFormatBasics.Force_newline
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          CamlinternalFormatBasics.Flush_newline
                                                                          CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))))))))
          "@[<v 2>@{<warning>@{<title>Warning@}@}@,@,               This is @{<warning>NOT@} the Tezos Mainnet.@,@,   The node you are connecting to claims to be running on the@,             @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@,        Do @{<warning>NOT@} use your fundraiser keys on this network.@,        Alphanet is a testing network, with free tokens.@]@
@."
            % string)
    else
      tt
  end.

Definition mainnet (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    if negb disable_disclaimer then
      Stdlib.Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<warning>" % string
                    CamlinternalFormatBasics.End_of_format) "<warning>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_tag
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<title>" % string
                      CamlinternalFormatBasics.End_of_format) "<title>" % string))
                (CamlinternalFormatBasics.String_literal "Disclaimer" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          "The  Tezos  network  is  a  new  blockchain technology."
                            % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "Users are  solely responsible  for any risks associated"
                                % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "with usage of the Tezos network.  Users should do their"
                                    % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "own  research to determine  if Tezos is the appropriate"
                                        % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@," % string 0 0)
                                        (CamlinternalFormatBasics.String_literal
                                          "platform for their needs and should apply judgement and"
                                            % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@," % string 0 0)
                                            (CamlinternalFormatBasics.String_literal
                                              "care in their network interactions."
                                                % string
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Force_newline
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    CamlinternalFormatBasics.End_of_format)))))))))))))))))))))
          "@[<v 2>@{<warning>@{<title>Disclaimer@}@}@,The  Tezos  network  is  a  new  blockchain technology.@,Users are  solely responsible  for any risks associated@,with usage of the Tezos network.  Users should do their@,own  research to determine  if Tezos is the appropriate@,platform for their needs and should apply judgement and@,care in their network interactions.@]@
@."
            % string)
    else
      tt
  end.

Definition sandbox (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    if negb disable_disclaimer then
      Stdlib.Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<warning>" % string
                    CamlinternalFormatBasics.End_of_format) "<warning>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_tag
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<title>" % string
                      CamlinternalFormatBasics.End_of_format) "<title>" % string))
                (CamlinternalFormatBasics.String_literal "Warning" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            " The node you are connecting to claims to be running in a"
                              % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "                  " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_tag
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<warning>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<warning>" % string))
                                  (CamlinternalFormatBasics.String_literal
                                    "Tezos TEST SANDBOX" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_tag
                                      (CamlinternalFormatBasics.Char_literal
                                        "." % char
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "    Do " % string
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_tag
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "<warning>" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "<warning>" % string))
                                              (CamlinternalFormatBasics.String_literal
                                                "NOT" % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_tag
                                                  (CamlinternalFormatBasics.String_literal
                                                    " use your fundraiser keys on this network."
                                                      % string
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@," % string 0 0)
                                                      (CamlinternalFormatBasics.String_literal
                                                        "You should not see this message if you are not a developer."
                                                          % string
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Close_box
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Force_newline
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Flush_newline
                                                              CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))
          "@[<v 2>@{<warning>@{<title>Warning@}@}@,@, The node you are connecting to claims to be running in a@,                  @{<warning>Tezos TEST SANDBOX@}.@,    Do @{<warning>NOT@} use your fundraiser keys on this network.@,You should not see this message if you are not a developer.@]@
@."
            % string)
    else
      tt
  end.

Definition check_network {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) : Lwt.t (option variant) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell_services.Shell_services.P2p.version ctxt)
    (fun function_parameter =>
      match function_parameter with
      | inr _ => Lwt.return_none
      | inl version =>
        let has_prefix (prefix : string) : bool :=
          Tezos_base__TzPervasives.String.has_prefix prefix (chain_name version)
          in
        if has_prefix "SANDBOXED" % string then
          sandbox tt;
          Lwt.return_some variant
        else
          if has_prefix "TEZOS_ZERONET" % string then
            zeronet tt;
            Lwt.return_some variant
          else
            if has_prefix "TEZOS_ALPHANET" % string then
              alphanet tt;
              Lwt.return_some variant
            else
              if
                orb (has_prefix "TEZOS_BETANET" % string)
                  (has_prefix "TEZOS_MAINNET" % string) then
                mainnet tt;
                Lwt.return_some variant
              else
                Lwt.return_none
      end).

Definition get_commands_for_version {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (network : option Tezos_client_commands.Client_commands.network)
  (chain : Tezos_shell_services__Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (protocol : option Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((option Tezos_base__TzPervasives.Protocol_hash.t) *
        (list Tezos_client_commands.Client_commands.command))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell_services.Shell_services.Blocks.protocols ctxt (Some chain)
      (Some block) tt)
    (fun function_parameter =>
      match function_parameter with
      | inl {| next_protocol := version |} =>
        match protocol with
        | None =>
          Tezos_base__TzPervasives._return
            ((Some version),
              (Tezos_client_commands.Client_commands.commands_for_version
                version network))
        | Some given_version =>
          if
            negb
              (Tezos_base__TzPervasives.Protocol_hash.equal version
                given_version) then
            Stdlib.Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_tag
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<warning>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<warning>" % string))
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_tag
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<title>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<title>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Warning" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_tag
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_tag
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "The protocol provided via `--protocol` (" %
                                  string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    ")" % char
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "is not the one retrieved from the node ("
                                          % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            ")." % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Force_newline
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Flush_newline
                                                  CamlinternalFormatBasics.End_of_format)))))))))))))))))
                "@[<v 2>@{<warning>@{<title>Warning@}@}@,The protocol provided via `--protocol` (%a)@,is not the one retrieved from the node (%a).@]@
@."
                  % string) Tezos_base__TzPervasives.Protocol_hash.pp_short
              given_version Tezos_base__TzPervasives.Protocol_hash.pp_short
              version
          else
            tt;
          Tezos_base__TzPervasives._return
            ((Some version),
              (Tezos_client_commands.Client_commands.commands_for_version
                given_version network))
        end
      | inr errs =>
        match protocol with
        | None =>
          Stdlib.Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_tag
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<warning>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<warning>" % string))
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_tag
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<title>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<title>" % string))
                    (CamlinternalFormatBasics.String_literal "Warning" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_tag
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_tag
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "Failed to acquire the protocol version from the node"
                                % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Force_newline
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Flush_newline
                                        CamlinternalFormatBasics.End_of_format)))))))))))))
              "@[<v 2>@{<warning>@{<title>Warning@}@}@,Failed to acquire the protocol version from the node@,%a@]@
@."
                % string)
            (Stdlib.Format.pp_print_list None Tezos_base__TzPervasives.pp) errs;
          Tezos_base__TzPervasives._return (None, [])
        | Some version =>
          Tezos_base__TzPervasives._return
            ((Some version),
              (Tezos_client_commands.Client_commands.commands_for_version
                version network))
        end
      end).

Definition select_commands {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (function_parameter : Tezos_client_base_unix.Client_config.cli_args)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_client_commands.Client_commands.command)) :=
  match function_parameter with
  | {| chain := chain; block := block; protocol := protocol |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq (check_network ctxt)
      (fun network =>
        Tezos_base__TzPervasives.op_gt_gt_pipe_question
          (get_commands_for_version ctxt network chain block protocol)
          (fun function_parameter =>
            match function_parameter with
            | (_, commands_for_version) =>
              OCaml.Stdlib.app Client_rpc_commands.commands
                (OCaml.Stdlib.app
                  (Tezos_signer_backends_unix.Ledger.commands tt)
                  (OCaml.Stdlib.app
                    (Tezos_client_commands.Client_keys_commands.commands network)
                    (OCaml.Stdlib.app
                      (Tezos_client_commands.Client_helpers_commands.commands tt)
                      commands_for_version)))
            end))
  end.
src/bin_client/test/proto_test_injection/main.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type block_header_data = MBytes.t

type block_header = {
  shell : Block_header.shell_header;
  protocol_data : block_header_data;
}

let block_header_data_encoding =
  Data_encoding.(obj1 (req "random_data" Variable.bytes))

type block_header_metadata = unit

let block_header_metadata_encoding = Data_encoding.unit

type operation_data = unit

let operation_data_encoding = Data_encoding.unit

type operation_receipt = unit

let operation_receipt_encoding = Data_encoding.unit

let operation_data_and_receipt_encoding =
  Data_encoding.conv
    (function ((), ()) -> ())
    (fun () -> ((), ()))
    Data_encoding.unit

type operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

let max_block_length = 42

let max_operation_data_length = 42

let validation_passes = []

let acceptable_passes _op = []

let compare_operations _ _ = 0

type validation_state = {context : Context.t; fitness : Int64.t}

let current_context {context} = return context

module Fitness = struct
  type error += Invalid_fitness

  type error += Invalid_fitness2

  let int64_to_bytes i =
    let b = MBytes.create 8 in
    MBytes.set_int64 b 0 i ; b

  let int64_of_bytes b =
    if Compare.Int.(MBytes.length b <> 8) then fail Invalid_fitness2
    else return (MBytes.get_int64 b 0)

  let from_int64 fitness = [int64_to_bytes fitness]

  let to_int64 = function
    | [fitness] ->
        int64_of_bytes fitness
    | [] ->
        return 0L
    | _ ->
        fail Invalid_fitness

  let get {fitness} = fitness
end

let begin_application ~chain_id:_ ~predecessor_context:context
    ~predecessor_timestamp:_ ~predecessor_fitness:_ (raw_block : block_header)
    =
  Fitness.to_int64 raw_block.shell.fitness
  >>=? fun fitness -> return {context; fitness}

let begin_partial_application ~chain_id ~ancestor_context
    ~predecessor_timestamp ~predecessor_fitness raw_block =
  begin_application
    ~chain_id
    ~predecessor_context:ancestor_context
    ~predecessor_timestamp
    ~predecessor_fitness
    raw_block

let begin_construction ~chain_id:_ ~predecessor_context:context
    ~predecessor_timestamp:_ ~predecessor_level:_
    ~predecessor_fitness:pred_fitness ~predecessor:_ ~timestamp:_
    ?protocol_data:_ () =
  Fitness.to_int64 pred_fitness
  >>=? fun pred_fitness ->
  let fitness = Int64.succ pred_fitness in
  return {context; fitness}

let apply_operation ctxt _ = return (ctxt, ())

let finalize_block ctxt =
  let fitness = Fitness.get ctxt in
  let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
  let fitness = Fitness.from_int64 fitness in
  return
    ( {
        Updater.message;
        context = ctxt.context;
        fitness;
        max_operations_ttl = 0;
        last_allowed_fork_level = 0l;
      },
      () )

let rpc_services = RPC_directory.empty

let init ctxt block_header =
  let fitness = block_header.Block_header.fitness in
  let message = None in
  return
    {
      Updater.message;
      context = ctxt;
      fitness;
      max_operations_ttl = 0;
      last_allowed_fork_level = 0l;
    }
src/bin_client/test/proto_test_injection/main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition block_header_data := Tezos_base__TzPervasives.MBytes.t.

Record block_header := {
  shell : Tezos_base__TzPervasives.Block_header.shell_header;
  protocol_data : block_header_data }.

Definition block_header_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
  Tezos_base__TzPervasives.Data_encoding.obj1
    (Tezos_base__TzPervasives.Data_encoding.req None None "random_data" % string
      Tezos_base__TzPervasives.Data_encoding.Variable.bytes).

Definition block_header_metadata := unit.

Definition block_header_metadata_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
  Tezos_base__TzPervasives.Data_encoding.unit.

Definition operation_data := unit.

Definition operation_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
  Tezos_base__TzPervasives.Data_encoding.unit.

Definition operation_receipt := unit.

Definition operation_receipt_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
  Tezos_base__TzPervasives.Data_encoding.unit.

Definition operation_data_and_receipt_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding (unit * unit) :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | (tt, tt) => tt
      end)
    (fun function_parameter =>
      match function_parameter with
      | tt => (tt, tt)
      end) None Tezos_base__TzPervasives.Data_encoding.unit.

Record operation := {
  shell : Tezos_base__TzPervasives.Operation.shell_header;
  protocol_data : operation_data }.

Definition max_block_length : Z := 42.

Definition max_operation_data_length : Z := 42.

Definition validation_passes {A : Type} : list A := [].

Definition acceptable_passes {A B : Type} (_op : A) : list B := [].

Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ => 0
      end
  end.

Definition current_context {A B : Type} (function_parameter : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  match function_parameter with
  | _ => Tezos_base__TzPervasives._return op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Module Fitness.
  Definition int64_to_bytes (i : int64) : Tezos_base__TzPervasives.MBytes.t :=
    let b := Tezos_base__TzPervasives.MBytes.create 8 in
    Tezos_base__TzPervasives.MBytes.set_int64 b 0 i;
    b.
  
  Definition int64_of_bytes (b : Tezos_base__TzPervasives.MBytes.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult int64) :=
    if
      Tezos_base__TzPervasives.Compare.Int.op_lt_gt
        (Tezos_base__TzPervasives.MBytes.length b) 8 then
      Tezos_base__TzPervasives.fail Invalid_fitness2
    else
      Tezos_base__TzPervasives._return
        (Tezos_base__TzPervasives.MBytes.get_int64 b 0).
  
  Definition from_int64 (fitness : int64)
    : list Tezos_base__TzPervasives.MBytes.t := cons (int64_to_bytes fitness) [].
  
  Definition to_int64
    (function_parameter : list Tezos_base__TzPervasives.MBytes.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult int64) :=
    match function_parameter with
    | cons fitness [] => int64_of_bytes fitness
    | [] => Tezos_base__TzPervasives._return 0
    | _ => Tezos_base__TzPervasives.fail Invalid_fitness
    end.
  
  Definition get {A B : Type} (function_parameter : A) : B :=
    match function_parameter with
    | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
    end.
End Fitness.

Definition begin_application {A B C D E : Type} (function_parameter : A)
  : B -> C -> D -> block_header -> Lwt.t (Tezos_base__TzPervasives.tzresult E) :=
  match function_parameter with
  | _ =>
    fun context =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ =>
              fun raw_block =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Fitness.to_int64 (fitness (shell raw_block)))
                  (fun fitness =>
                    Tezos_base__TzPervasives._return
                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
            end
        end
  end.

Definition begin_partial_application {A B C D E : Type}
  (chain_id : A) (ancestor_context : B) (predecessor_timestamp : C)
  (predecessor_fitness : D) (raw_block : block_header)
  : Lwt.t (Tezos_base__TzPervasives.tzresult E) :=
  begin_application chain_id ancestor_context predecessor_timestamp
    predecessor_fitness raw_block.

Definition begin_construction {A B C D E F G H : Type} (function_parameter : A)
  : B ->
    C ->
      D ->
        (list Tezos_base__TzPervasives.MBytes.t) ->
          E ->
            F ->
              (option G) -> unit -> Lwt.t (Tezos_base__TzPervasives.tzresult H) :=
  match function_parameter with
  | _ =>
    fun context =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ =>
              fun pred_fitness =>
                fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Fitness.to_int64 pred_fitness)
                                  (fun pred_fitness =>
                                    let fitness :=
                                      Stdlib.Int64.succ pred_fitness in
                                    Tezos_base__TzPervasives._return
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                              end
                          end
                      end
                  end
            end
        end
  end.

Definition apply_operation {A B : Type} (ctxt : A) (function_parameter : B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (A * unit)) :=
  match function_parameter with
  | _ => Tezos_base__TzPervasives._return (ctxt, tt)
  end.

Definition finalize_block {A B : Type} (ctxt : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (B * unit)) :=
  let fitness := Fitness.get ctxt in
  let message :=
    Some
      (Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "fitness <- " % string
            (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format)) "fitness <- %Ld" % string)
        fitness) in
  let fitness := Fitness.from_int64 fitness in
  Tezos_base__TzPervasives._return (op_star_t_y_p_e_minus_e_r_r_o_r_star, tt).

Definition rpc_services {A : Type}
  : Tezos_base__TzPervasives.RPC_directory.directory A :=
  Tezos_base__TzPervasives.RPC_directory.empty.

Definition init {A B : Type}
  (ctxt : A) (block_header : Tezos_base__TzPervasives.Block_header.shell_header)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  let fitness := Block_header.fitness block_header in
  let message := None in
  Tezos_base__TzPervasives._return op_star_t_y_p_e_minus_e_r_r_o_r_star.
src/bin_codec/codec.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let commands = Commands.commands ()

let home = try Sys.getenv "HOME" with Not_found -> "/tmp"

let default_base_dir = Filename.concat home ".tezos-client"

let base_dir_arg =
  let open Clic in
  arg
    ~long:"base-dir"
    ~short:'d'
    ~placeholder:"path"
    ~doc:
      ( "data directory\n\
         The directory where the Tezos codec will output logs.\n\
         By default: '" ^ default_base_dir ^ "'." )
    (parameter (fun _ctxt x -> return x))

let global_options = Clic.args1 base_dir_arg

let parse_config_args argv =
  (* The context used during argument parsing. We switch to a real context
     that is created based on some of the parsed arguments. *)
  let ctxt = Client_context.null_printer in
  Clic.parse_global_options global_options ctxt argv
  >>=? fun (base_dir, argv) ->
  ( match base_dir with
  | None ->
      let base_dir = default_base_dir in
      ( if Sys.file_exists base_dir then Lwt.return_unit
      else Lwt_utils_unix.create_dir base_dir )
      >>= fun () -> return base_dir
  | Some dir ->
      if not (Sys.file_exists dir) then
        failwith
          "Specified -base-dir does not exist. Please create the directory \
           and try again."
      else if not (Sys.is_directory dir) then
        failwith "Specified -base-dir must be a directory"
      else return dir )
  >>=? fun base_dir -> return (base_dir, argv)

(* Main (lwt) entry *)
let main commands =
  let executable_name = Filename.basename Sys.executable_name in
  let run () =
    let (argv, autocomplete) =
      (* for shell aliases *)
      let rec move_autocomplete_token_upfront acc = function
        | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args ->
            let args = List.rev acc @ args in
            (args, Some (prev_arg, cur_arg, script))
        | x :: rest ->
            move_autocomplete_token_upfront (x :: acc) rest
        | [] ->
            (List.rev acc, None)
      in
      match Array.to_list Sys.argv with
      | _ :: args ->
          move_autocomplete_token_upfront [] args
      | [] ->
          ([], None)
    in
    Random.self_init () ;
    ignore
      Clic.(
        setup_formatter
          Format.std_formatter
          (if Unix.isatty Unix.stdout then Ansi else Plain)
          Short) ;
    ignore
      Clic.(
        setup_formatter
          Format.err_formatter
          (if Unix.isatty Unix.stderr then Ansi else Plain)
          Short) ;
    Internal_event_unix.init ()
    >>= fun () ->
    parse_config_args argv
    >>=? fun (base_dir, argv) ->
    let ctxt = new Client_context_unix.unix_logger ~base_dir in
    let commands =
      Clic.add_manual
        ~executable_name
        ~global_options
        (if Unix.isatty Unix.stdout then Clic.Ansi else Clic.Plain)
        Format.std_formatter
        commands
    in
    match autocomplete with
    | Some (prev_arg, cur_arg, script) ->
        Clic.autocompletion
          ~script
          ~cur_arg
          ~prev_arg
          ~args:argv
          ~global_options
          commands
          ctxt
        >>=? fun completions ->
        List.iter print_endline completions ;
        return_unit
    | None ->
        Clic.dispatch commands ctxt argv
  in
  Pervasives.exit
    (Lwt_main.run
       ( Lwt.catch run (function
             | Failure msg ->
                 failwith "%s" msg
             | exn ->
                 failwith "%s" (Printexc.to_string exn))
       >>= (function
             | Ok () ->
                 Lwt.return 0
             | Error [Clic.Help command] ->
                 Clic.usage
                   Format.std_formatter
                   ~executable_name
                   ~global_options
                   (match command with None -> [] | Some c -> [c]) ;
                 Lwt.return 0
             | Error errs ->
                 Clic.pp_cli_errors
                   Format.err_formatter
                   ~executable_name
                   ~global_options
                   ~default:Error_monad.pp
                   errs ;
                 Lwt.return 1)
       >>= fun retcode ->
       Format.pp_print_flush Format.err_formatter () ;
       Format.pp_print_flush Format.std_formatter () ;
       Lwt.return retcode ))

let () = main commands
src/bin_codec/codec.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition commands
  : list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer) :=
  Commands.commands tt.

Definition home : string := try.

Definition default_base_dir : string :=
  Stdlib.Filename.concat home ".tezos-client" % string.

Definition base_dir_arg
  : Tezos_clic.Clic.arg (option string) Tezos_client_base.Client_context.printer :=
  Tezos_clic.Clic.arg
    (String.append
      "data directory
The directory where the Tezos codec will output logs.
By default: '"
        % string (String.append default_base_dir "'." % string))
    (Some "d" % char) "base-dir" % string "path" % string
    (Tezos_clic.Clic.parameter None
      (fun _ctxt => fun x => Tezos_base__TzPervasives._return x)).

Definition global_options
  : Tezos_clic.Clic.options (option string)
    Tezos_client_base.Client_context.printer :=
  Tezos_clic.Clic.args1 base_dir_arg.

Definition parse_config_args (argv : list string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (string * (list string))) :=
  let ctxt := Tezos_client_base.Client_context.null_printer in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_clic.Clic.parse_global_options global_options ctxt argv)
    (fun function_parameter =>
      match function_parameter with
      | (base_dir, argv) =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          match base_dir with
          | None =>
            let base_dir := default_base_dir in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (if Stdlib.Sys.file_exists base_dir then
                Lwt.return_unit
              else
                Tezos_stdlib_unix.Lwt_utils_unix.create_dir None base_dir)
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives._return base_dir
                end)
          | Some dir =>
            if negb (Stdlib.Sys.file_exists dir) then
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Specified -base-dir does not exist. Please create the directory and try again."
                      % string CamlinternalFormatBasics.End_of_format)
                  "Specified -base-dir does not exist. Please create the directory and try again."
                    % string)
            else
              if negb (Stdlib.Sys.is_directory dir) then
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Specified -base-dir must be a directory" % string
                      CamlinternalFormatBasics.End_of_format)
                    "Specified -base-dir must be a directory" % string)
              else
                Tezos_base__TzPervasives._return dir
          end
          (fun base_dir => Tezos_base__TzPervasives._return (base_dir, argv))
      end).

Definition main {A : Type}
  (commands :
    list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer))
  : A :=
  let executable_name := Stdlib.Filename.basename Stdlib.Sys.executable_name in
  let run (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    match function_parameter with
    | tt =>
      match
        let fix move_autocomplete_token_upfront
          (acc : list string) (function_parameter : list string)
          : (list string) * (option (string * string * string)) :=
          match function_parameter with
          |
            cons "bash_autocomplete" % string
              (cons prev_arg (cons cur_arg (cons script args))) =>
            let args :=
              OCaml.Stdlib.app (Tezos_base__TzPervasives.List.rev acc) args in
            (args, (Some (prev_arg, cur_arg, script)))
          | cons x rest => move_autocomplete_token_upfront (cons x acc) rest
          | [] => ((Tezos_base__TzPervasives.List.rev acc), None)
          end in
        match Stdlib.Array.to_list Stdlib.Sys.argv with
        | cons _ args => move_autocomplete_token_upfront [] args
        | [] => ([], None)
        end with
      | (argv, autocomplete) =>
        Stdlib.Random.self_init tt;
        OCaml.Stdlib.ignore
          (Tezos_clic.Clic.setup_formatter Stdlib.Format.std_formatter
            (if Unix.isatty Unix.stdout then
              Ansi
            else
              Plain) Short);
        OCaml.Stdlib.ignore
          (Tezos_clic.Clic.setup_formatter Stdlib.Format.err_formatter
            (if Unix.isatty Unix.stderr then
              Ansi
            else
              Plain) Short);
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_stdlib_unix.Internal_event_unix.init None None tt)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (parse_config_args argv)
                (fun function_parameter =>
                  match function_parameter with
                  | (base_dir, argv) =>
                    let ctxt := new base_dir in
                    let commands :=
                      Tezos_clic.Clic.add_manual executable_name global_options
                        (if Unix.isatty Unix.stdout then
                          Clic.Ansi
                        else
                          Clic.Plain) Stdlib.Format.std_formatter commands in
                    match autocomplete with
                    | Some (prev_arg, cur_arg, script) =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_clic.Clic.autocompletion script cur_arg prev_arg
                          argv global_options commands ctxt)
                        (fun completions =>
                          Tezos_base__TzPervasives.List.iter
                            OCaml.Stdlib.print_endline completions;
                          Tezos_base__TzPervasives.return_unit)
                    | None => Tezos_clic.Clic.dispatch commands ctxt argv
                    end
                  end)
            end)
      end
    end in
  Stdlib.Pervasives.exit
    (Lwt_main.run
      (Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_base__TzPervasives.op_gt_gt_eq
          (Lwt.catch run
            (fun function_parameter =>
              match function_parameter with
              | OCaml.Failure msg =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format) "%s" % string) msg
              | exn =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format) "%s" % string)
                  (Stdlib.Printexc.to_string exn)
              end))
          (fun function_parameter =>
            match function_parameter with
            | inl tt => Lwt._return 0
            | inr (cons (Clic.Help command) []) =>
              Tezos_clic.Clic.usage Stdlib.Format.std_formatter executable_name
                global_options
                match command with
                | None => []
                | Some c => cons c []
                end;
              Lwt._return 0
            | inr errs =>
              Tezos_clic.Clic.pp_cli_errors Stdlib.Format.err_formatter
                executable_name global_options
                Tezos_base__TzPervasives.Error_monad.pp errs;
              Lwt._return 1
            end))
        (fun retcode =>
          Stdlib.Format.pp_print_flush Stdlib.Format.err_formatter tt;
          Stdlib.Format.pp_print_flush Stdlib.Format.std_formatter tt;
          Lwt._return retcode))).
src/bin_codec/commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix
open Clic

let group = {name = "encoding"; title = "Commands to handle encodings"}

let id_parameter =
  parameter (fun (cctxt : #Client_context.printer) id ->
      match Data_encoding.Registration.find id with
      | Some record ->
          return record
      | None ->
          cctxt#error "Unkown encoding id: %s" id)

let json_parameter =
  parameter (fun (cctxt : #Client_context.printer) file_or_data ->
      Lwt_unix.file_exists file_or_data
      >>= (function
            | true ->
                Tezos_stdlib_unix.Lwt_utils_unix.read_file file_or_data
            | false ->
                Lwt.return file_or_data)
      >>= fun data ->
      match Json.from_string data with
      | Ok json ->
          return json
      | Error err ->
          cctxt#error "%s" err)

let bytes_parameter = parameter (fun _ hex -> return (Hex.to_bytes (`Hex hex)))

let commands () =
  [ command
      ~group
      ~desc:"List the registered encoding in Tezos."
      no_options
      (fixed ["list"; "encodings"])
      (fun () (cctxt : #Client_context.printer) ->
        let bindings =
          Data_encoding.Registration.list ()
          |> List.map (fun (id, elem) ->
                 (id, Data_encoding.Registration.description elem))
        in
        cctxt#message
          "@[<v>%a@]@."
          (Format.pp_print_list
             ~pp_sep:Format.pp_print_cut
             (fun ppf (id, desc) ->
               let desc =
                 Option.unopt ~default:"No description available." desc
               in
               Format.fprintf
                 ppf
                 "@[<v 2>%s:@ @[%a@]@]"
                 id
                 Format.pp_print_text
                 desc))
          bindings
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Dump a json description of all registered encodings."
      ( args1
      @@ switch
           ~doc:
             "Output json descriptions without extraneous whitespace characters"
           ~long:"compact"
           () )
      (fixed ["dump"; "encodings"])
      (fun minify (cctxt : #Client_context.printer) ->
        cctxt#message
          "%s"
          (Json.to_string
             ~minify
             (`A
               ( Registration.list ()
               |> List.map (fun (id, enc) ->
                      `O
                        [ ("id", `String id);
                          ( "json",
                            Json.construct
                              Json.schema_encoding
                              (Registration.json_schema enc) );
                          ( "binary",
                            Json.construct
                              Binary_schema.encoding
                              (Registration.binary_schema enc) ) ]) )))
        >>= fun () -> return_unit);
    (* JSON -> Binary *)
    command
      ~group
      ~desc:
        "Encode the given JSON data into binary using the provided encoding \
         identifier."
      no_options
      ( prefix "encode"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefix "from"
      @@ param ~name:"json" ~desc:"JSON file or data" json_parameter
      @@ stop )
      (fun () registered_encoding json (cctxt : #Client_context.printer) ->
        match
          Data_encoding.Registration.bytes_of_json registered_encoding json
        with
        | exception exn ->
            cctxt#error "%a" (fun ppf exn -> Json.print_error ppf exn) exn
        | None ->
            cctxt#error
              "Impossible to the JSON convert to binary.@,\
               This error should not happen."
        | Some bytes ->
            cctxt#message "%a" Hex.pp (Hex.of_bytes bytes)
            >>= fun () -> return_unit);
    (* Binary -> JSON *)
    command
      ~group
      ~desc:
        "Decode the binary encoded data into JSON using the provided encoding \
         identifier."
      no_options
      ( prefix "decode"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefix "from"
      @@ param ~name:"hex" ~desc:"Binary encoded data" bytes_parameter
      @@ stop )
      (fun () registered_encoding bytes (cctxt : #Client_context.printer) ->
        match
          Data_encoding.Registration.json_of_bytes registered_encoding bytes
        with
        | None ->
            cctxt#error "Cannot parse the binary with the given encoding"
        | Some bytes ->
            cctxt#message "%a" Json.pp bytes >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Display the binary encoded data using the provided encoding \
         identifier."
      no_options
      ( prefix "display"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefixes ["from"; "binary"]
      @@ param ~name:"hex" ~desc:"Binary encoded data" bytes_parameter
      @@ stop )
      (fun () registered_encoding bytes (cctxt : #Client_context.printer) ->
        let pp_bytes fmt bytes =
          Data_encoding.Registration.binary_pretty_printer
            registered_encoding
            fmt
            bytes
        in
        cctxt#message "%a" pp_bytes bytes >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Display the JSON encoded data using the provided encoding identifier."
      no_options
      ( prefix "display"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefixes ["from"; "json"]
      @@ param ~name:"json" ~desc:"JSON file or data" json_parameter
      @@ stop )
      (fun () registered_encoding json (cctxt : #Client_context.printer) ->
        let pp_json fmt json =
          Data_encoding.Registration.json_pretty_printer
            registered_encoding
            fmt
            json
        in
        cctxt#message "%a" pp_json json >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Describe the binary schema associated to the provided encoding \
         identifier."
      no_options
      ( prefix "describe"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefixes ["binary"; "schema"]
      @@ stop )
      (fun () registered_encoding (cctxt : #Client_context.printer) ->
        let schema =
          Data_encoding.Registration.binary_schema registered_encoding
        in
        cctxt#message "%a" Binary_schema.pp schema >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Describe the JSON schema associated to the provided encoding \
         identifier."
      no_options
      ( prefix "describe"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefixes ["json"; "schema"]
      @@ stop )
      (fun () registered_encoding cctxt ->
        let schema =
          Data_encoding.Registration.json_schema registered_encoding
        in
        cctxt#message "%a" Json_schema.pp schema >>= fun () -> return_unit) ]
src/bin_codec/commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Import Tezos_clic.Clic.

Definition group : Tezos_clic.Clic.group :=
  {| name := "encoding" % string;
    title := "Commands to handle encodings" % string |}.

Definition id_parameter {C a b : Type}
  : Tezos_clic.Clic.parameter
    Tezos_base__TzPervasives.Data_encoding.Registration.t
    (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) :=
  Tezos_clic.Clic.parameter None
    (fun cctxt =>
      fun id =>
        match Tezos_base__TzPervasives.Data_encoding.Registration.find id with
        | Some record => Tezos_base__TzPervasives._return record
        | None =>
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Unkown encoding id: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))
              "Unkown encoding id: %s" % string) id
        end).

Definition json_parameter {C a b : Type}
  : Tezos_clic.Clic.parameter Tezos_data_encoding.Json.json
    (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) :=
  Tezos_clic.Clic.parameter None
    (fun cctxt =>
      fun file_or_data =>
        Lwt.Infix.op_gt_gt_eq
          (Lwt.Infix.op_gt_gt_eq (Lwt_unix.file_exists file_or_data)
            (fun function_parameter =>
              match function_parameter with
              | true => Tezos_stdlib_unix.Lwt_utils_unix.read_file file_or_data
              | false => Lwt._return file_or_data
              end))
          (fun data =>
            match Tezos_data_encoding.Json.from_string data with
            | inl json => Tezos_base__TzPervasives._return json
            | inr err =>
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format) "%s" % string) err
            end)).

Definition bytes_parameter {C a b : Type}
  : Tezos_clic.Clic.parameter string
    (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) :=
  Tezos_clic.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ => fun hex => Tezos_base__TzPervasives._return (Hex.to_bytes variant)
      end).

Definition commands {C a b : Type} (function_parameter : unit)
  : list
    (Tezos_clic.Clic.command
      (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (((string ->
                (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
                * C))))) * C)) :=
  match function_parameter with
  | tt =>
    cons
      (Tezos_clic.Clic.command (Some group)
        "List the registered encoding in Tezos." % string
        Tezos_clic.Clic.no_options
        (Tezos_clic.Clic.fixed
          (cons "list" % string (cons "encodings" % string [])))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun cctxt =>
              let bindings :=
                OCaml.Stdlib.reverse_apply
                  (Tezos_base__TzPervasives.Data_encoding.Registration.list tt)
                  (Tezos_base__TzPervasives.List.map
                    (fun function_parameter =>
                      match function_parameter with
                      | (id, elem) =>
                        (id,
                          (Tezos_base__TzPervasives.Data_encoding.Registration.description
                            elem))
                      end)) in
              Lwt.Infix.op_gt_gt_eq
                (send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v>" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))
                    "@[<v>%a@]@." % string)
                  (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_cut)
                    (fun ppf =>
                      fun function_parameter =>
                        match function_parameter with
                        | (id, desc) =>
                          let desc :=
                            Tezos_base__TzPervasives.Option.unopt
                              "No description available." % string desc in
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Char_literal
                                    ":" % char
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            CamlinternalFormatBasics.End_of_format
                                            "" % string))
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format))))))))
                              "@[<v 2>%s:@ @[%a@]@]" % string) id
                            Stdlib.Format.pp_print_text desc
                        end)) bindings)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
          end))
      (cons
        (Tezos_clic.Clic.command (Some group)
          "Dump a json description of all registered encodings." % string
          (apply Tezos_clic.Clic.args1
            (Tezos_clic.Clic.switch
              "Output json descriptions without extraneous whitespace characters"
                % string None "compact" % string tt))
          (Tezos_clic.Clic.fixed
            (cons "dump" % string (cons "encodings" % string [])))
          (fun minify =>
            fun cctxt =>
              Lwt.Infix.op_gt_gt_eq
                (send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format) "%s" % string)
                  (Tezos_data_encoding.Json.to_string None (Some minify) variant))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)))
        (cons
          (Tezos_clic.Clic.command (Some group)
            "Encode the given JSON data into binary using the provided encoding identifier."
              % string Tezos_clic.Clic.no_options
            (apply (Tezos_clic.Clic.prefix "encode" % string)
              (apply
                (Tezos_clic.Clic.param "id" % string
                  "Encoding identifier" % string id_parameter)
                (apply (Tezos_clic.Clic.prefix "from" % string)
                  (apply
                    (Tezos_clic.Clic.param "json" % string
                      "JSON file or data" % string json_parameter)
                    Tezos_clic.Clic.stop))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun registered_encoding =>
                  fun json =>
                    fun cctxt =>
                      match
                        Tezos_base__TzPervasives.Data_encoding.Registration.bytes_of_json
                          registered_encoding json with
                      | None =>
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Impossible to the JSON convert to binary." %
                                string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "This error should not happen." % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Impossible to the JSON convert to binary.@,This error should not happen."
                              % string)
                      | Some bytes =>
                        Lwt.Infix.op_gt_gt_eq
                          (send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format)
                              "%a" % string) Hex.pp (Hex.of_bytes None string))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_unit
                            end)
                      end
              end))
          (cons
            (Tezos_clic.Clic.command (Some group)
              "Decode the binary encoded data into JSON using the provided encoding identifier."
                % string Tezos_clic.Clic.no_options
              (apply (Tezos_clic.Clic.prefix "decode" % string)
                (apply
                  (Tezos_clic.Clic.param "id" % string
                    "Encoding identifier" % string id_parameter)
                  (apply (Tezos_clic.Clic.prefix "from" % string)
                    (apply
                      (Tezos_clic.Clic.param "hex" % string
                        "Binary encoded data" % string bytes_parameter)
                      Tezos_clic.Clic.stop))))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun registered_encoding =>
                    fun bytes =>
                      fun cctxt =>
                        match
                          Tezos_base__TzPervasives.Data_encoding.Registration.json_of_bytes
                            registered_encoding string with
                        | None =>
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Cannot parse the binary with the given encoding"
                                  % string
                                CamlinternalFormatBasics.End_of_format)
                              "Cannot parse the binary with the given encoding"
                                % string)
                        | Some bytes =>
                          Lwt.Infix.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)
                                "%a" % string) Tezos_data_encoding.Json.pp
                              string)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        end
                end))
            (cons
              (Tezos_clic.Clic.command (Some group)
                "Display the binary encoded data using the provided encoding identifier."
                  % string Tezos_clic.Clic.no_options
                (apply (Tezos_clic.Clic.prefix "display" % string)
                  (apply
                    (Tezos_clic.Clic.param "id" % string
                      "Encoding identifier" % string id_parameter)
                    (apply
                      (Tezos_clic.Clic.prefixes
                        (cons "from" % string (cons "binary" % string [])))
                      (apply
                        (Tezos_clic.Clic.param "hex" % string
                          "Binary encoded data" % string bytes_parameter)
                        Tezos_clic.Clic.stop))))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    fun registered_encoding =>
                      fun bytes =>
                        fun cctxt =>
                          let pp_bytes
                            (fmt : Stdlib.Format.formatter) (bytes :
                            Stdlib.Bytes.t) : unit :=
                            Tezos_base__TzPervasives.Data_encoding.Registration.binary_pretty_printer
                              registered_encoding fmt string in
                          Lwt.Infix.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)
                                "%a" % string) pp_bytes string)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                  end))
              (cons
                (Tezos_clic.Clic.command (Some group)
                  "Display the JSON encoded data using the provided encoding identifier."
                    % string Tezos_clic.Clic.no_options
                  (apply (Tezos_clic.Clic.prefix "display" % string)
                    (apply
                      (Tezos_clic.Clic.param "id" % string
                        "Encoding identifier" % string id_parameter)
                      (apply
                        (Tezos_clic.Clic.prefixes
                          (cons "from" % string (cons "json" % string [])))
                        (apply
                          (Tezos_clic.Clic.param "json" % string
                            "JSON file or data" % string json_parameter)
                          Tezos_clic.Clic.stop))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      fun registered_encoding =>
                        fun json =>
                          fun cctxt =>
                            let pp_json
                              (fmt : Stdlib.Format.formatter) (json :
                              Tezos_data_encoding.Json.t) : unit :=
                              Tezos_base__TzPervasives.Data_encoding.Registration.json_pretty_printer
                                registered_encoding fmt json in
                            Lwt.Infix.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format)
                                  "%a" % string) pp_json json)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_unit
                                end)
                    end))
                (cons
                  (Tezos_clic.Clic.command (Some group)
                    "Describe the binary schema associated to the provided encoding identifier."
                      % string Tezos_clic.Clic.no_options
                    (apply (Tezos_clic.Clic.prefix "describe" % string)
                      (apply
                        (Tezos_clic.Clic.param "id" % string
                          "Encoding identifier" % string id_parameter)
                        (apply
                          (Tezos_clic.Clic.prefixes
                            (cons "binary" % string (cons "schema" % string [])))
                          Tezos_clic.Clic.stop)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        fun registered_encoding =>
                          fun cctxt =>
                            let schema :=
                              Tezos_base__TzPervasives.Data_encoding.Registration.binary_schema
                                registered_encoding in
                            Lwt.Infix.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format)
                                  "%a" % string)
                                Tezos_data_encoding.Binary_schema.pp schema)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_unit
                                end)
                      end))
                  (cons
                    (Tezos_clic.Clic.command (Some group)
                      "Describe the JSON schema associated to the provided encoding identifier."
                        % string Tezos_clic.Clic.no_options
                      (apply (Tezos_clic.Clic.prefix "describe" % string)
                        (apply
                          (Tezos_clic.Clic.param "id" % string
                            "Encoding identifier" % string id_parameter)
                          (apply
                            (Tezos_clic.Clic.prefixes
                              (cons "json" % string (cons "schema" % string [])))
                            Tezos_clic.Clic.stop)))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          fun registered_encoding =>
                            fun cctxt =>
                              let schema :=
                                Tezos_base__TzPervasives.Data_encoding.Registration.json_schema
                                  registered_encoding in
                              Lwt.Infix.op_gt_gt_eq
                                (send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format)
                                    "%a" % string) Json_schema.pp schema)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                        end)) [])))))))
  end.
src/bin_codec/commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> Client_context.printer Clic.command list
src/bin_codec/commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands :
unit -> list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer).
src/bin_node/genesis_chain.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018-2019 Nomadic Labs. <nomadic@tezcore.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let genesis : State.Chain.genesis =
  {
    time = Time.Protocol.of_notation_exn "2018-06-30T16:07:32Z";
    block =
      Block_hash.of_b58check_exn
        "BLockGenesisGenesisGenesisGenesisGenesisf79b5d1CoW2";
    protocol =
      Protocol_hash.of_b58check_exn
        "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im";
  }
src/bin_node/genesis_chain.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition genesis : Tezos_shell.State.Chain.genesis :=
  {|
    time :=
      Tezos_base__TzPervasives.Time.Protocol.of_notation_exn
        "2018-06-30T16:07:32Z" % string;
    block :=
      Tezos_base__TzPervasives.Block_hash.of_b58check_exn
        "BLockGenesisGenesisGenesisGenesisGenesisf79b5d1CoW2" % string;
    protocol :=
      Tezos_base__TzPervasives.Protocol_hash.of_b58check_exn
        "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" % string |}.
src/bin_node/genesis_chain.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018-2019 Nomadic Labs. <nomadic@tezcore.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val genesis : State.Chain.genesis
src/bin_node/genesis_chain.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter genesis : Tezos_shell.State.Chain.genesis.
src/bin_node/main.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  let log s = Node_logging.fatal_error "%s" s in
  Lwt_exit.exit_on ~log Sys.sigint ;
  Lwt_exit.exit_on ~log Sys.sigterm

let () =
  if Filename.basename Sys.argv.(0) = Updater.compiler_name then (
    try
      Tezos_protocol_compiler.Compiler.main
        Tezos_protocol_compiler_native.Native.driver ;
      Pervasives.exit 0
    with exn ->
      Format.eprintf "%a\n%!" Opterrors.report_error exn ;
      Pervasives.exit 1 )

let () =
  if Filename.basename Sys.argv.(0) = "tezos-validator" then (
    try Pervasives.exit (Lwt_main.run @@ Validator.main ())
    with exn ->
      Format.eprintf "%a\n%!" Opterrors.report_error exn ;
      Pervasives.exit 1 )

let term =
  let open Cmdliner.Term in
  ret (const (`Help (`Pager, None)))

let description =
  [ `S "DESCRIPTION";
    `P "Entry point for initializing, configuring and running a Tezos node.";
    `P Node_identity_command.Manpage.command_description;
    `P Node_run_command.Manpage.command_description;
    `P Node_config_command.Manpage.command_description;
    `P Node_snapshot_command.Manpage.command_description ]

let man = description @ Node_run_command.Manpage.examples

let info =
  let version =
    Tezos_version.Current_git_info.abbreviated_commit_hash ^ " ("
    ^ Tezos_version.Current_git_info.committer_date ^ ")"
  in
  Cmdliner.Term.info ~doc:"The Tezos node" ~man ~version "tezos-node"

let commands =
  [ Node_run_command.cmd;
    Node_config_command.cmd;
    Node_identity_command.cmd;
    Node_snapshot_command.cmd ]

let () =
  Random.self_init () ;
  match Cmdliner.Term.eval_choice (term, info) commands with
  | `Error _ ->
      exit 1
  | `Help ->
      exit 0
  | `Version ->
      exit 1
  | `Ok () ->
      exit 0
src/bin_node/main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition term {A : Type} : Cmdliner.Term.t A :=
  Cmdliner.Term.ret (Cmdliner.Term.const variant).

Definition description : list variant :=
  cons variant
    (cons variant (cons variant (cons variant (cons variant (cons variant []))))).

Definition man : list Cmdliner.Manpage.block :=
  OCaml.Stdlib.app description Node_run_command.Manpage.examples.

Definition info : Cmdliner.Term.info :=
  let version :=
    String.append Tezos_version.Current_git_info.abbreviated_commit_hash
      (String.append " (" % string
        (String.append Tezos_version.Current_git_info.committer_date
          ")" % string)) in
  Cmdliner.Term.info None (Some man) None None None None
    (Some "The Tezos node" % string) (Some version) "tezos-node" % string.

Definition commands : list ((Cmdliner.Term.t unit) * Cmdliner.Term.info) :=
  cons Node_run_command.cmd
    (cons Node_config_command.cmd
      (cons Node_identity_command.cmd (cons Node_snapshot_command.cmd []))).
src/bin_node/node_config_command.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Commands *)

let show (args : Node_shared_arg.t) =
  if not @@ Sys.file_exists args.config_file then
    Format.eprintf
      "\n\
       Warning: no config file at %s,\n\
      \         displaying the default configuration.\n\
       @."
      args.config_file ;
  Node_shared_arg.read_and_patch_config_file args
  >>=? fun cfg ->
  Node_config_file.check cfg
  >>= fun () ->
  print_endline @@ Node_config_file.to_string cfg ;
  return_unit

let reset (args : Node_shared_arg.t) =
  if Sys.file_exists args.config_file then
    Format.eprintf
      "Ignoring previous configuration file: %s.@."
      args.config_file ;
  Node_shared_arg.read_and_patch_config_file args
  >>=? fun cfg ->
  Node_config_file.check cfg
  >>= fun () -> Node_config_file.write args.config_file cfg

let init (args : Node_shared_arg.t) =
  if Sys.file_exists args.config_file then
    failwith "Pre-existing config file at %s, use `reset`." args.config_file
  else
    Node_shared_arg.read_and_patch_config_file args
    >>=? fun cfg ->
    Node_config_file.check cfg
    >>= fun () -> Node_config_file.write args.config_file cfg

let update (args : Node_shared_arg.t) =
  if not (Sys.file_exists args.config_file) then
    failwith
      "Missing configuration file at %s. Use `%s config init [options]` to \
       generate a new file"
      args.config_file
      Sys.argv.(0)
  else
    Node_shared_arg.read_and_patch_config_file args
    >>=? fun cfg ->
    Node_config_file.check cfg
    >>= fun () -> Node_config_file.write args.config_file cfg

(** Main *)

module Term = struct
  type subcommand = Show | Reset | Init | Update

  let process subcommand args =
    let res =
      match subcommand with
      | Show ->
          show args
      | Reset ->
          reset args
      | Init ->
          init args
      | Update ->
          update args
    in
    match Lwt_main.run res with
    | Ok () ->
        `Ok ()
    | Error err ->
        `Error (false, Format.asprintf "%a" pp_print_error err)

  let subcommand_arg =
    let parser = function
      | "show" ->
          `Ok Show
      | "reset" ->
          `Ok Reset
      | "init" ->
          `Ok Init
      | "update" ->
          `Ok Update
      | s ->
          `Error ("invalid argument: " ^ s)
    and printer ppf = function
      | Show ->
          Format.fprintf ppf "show"
      | Reset ->
          Format.fprintf ppf "reset"
      | Init ->
          Format.fprintf ppf "init"
      | Update ->
          Format.fprintf ppf "update"
    in
    let open Cmdliner.Arg in
    let doc =
      "Operation to perform. Possible values: $(b,show), $(b,reset), \
       $(b,init), $(b,update)."
    in
    value & pos 0 (parser, printer) Show & info [] ~docv:"OPERATION" ~doc

  let term =
    let open Cmdliner.Term in
    ret (const process $ subcommand_arg $ Node_shared_arg.Term.args)
end

module Manpage = struct
  let command_description =
    "The $(b,config) command is meant to inspect and amend the configuration \
     of the Tezos node. This command is complementary to manually editing the \
     tezos node configuration file. Its arguments are a subset of the \
     $(i,run) command ones."

  let description =
    [ `S "DESCRIPTION";
      `P (command_description ^ " Several operations are possible: ");
      `P
        "$(b,show) reads, parses and displays Tezos current config file. Use \
         this command to see exactly what config file will be used by Tezos. \
         If additional command-line arguments are provided, the displayed \
         configuration will be amended accordingly. This is the default \
         operation.";
      `P
        "$(b,reset) will overwrite the current configuration file with a \
         factory default one. If additional command-line arguments are \
         provided, they will amend the generated file. It assumes that a \
         configuration file already exists and will abort otherwise.";
      `P
        "$(b,init) is like reset but assumes that no configuration file is \
         present and will abort otherwise.";
      `P
        "$(b,update) is the main option to edit the configuration file of \
         Tezos. It will parse command line arguments and add or replace \
         corresponding entries in the Tezos configuration file." ]

  let options =
    let schema = Data_encoding.Json.schema Node_config_file.encoding in
    let schema = Format.asprintf "@[%a@]" Json_schema.pp schema in
    let schema = String.concat "\\$" (String.split '$' schema) in
    [`S "OPTIONS"; `P "All options available in the config file"; `Pre schema]

  let man =
    description @ Node_shared_arg.Manpage.args @ options
    @ Node_shared_arg.Manpage.bugs

  let info = Cmdliner.Term.info ~doc:"Manage node configuration" ~man "config"
end

let cmd = (Term.term, Manpage.info)
src/bin_node/node_config_command.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition show (args : Node_shared_arg.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if apply negb (Stdlib.Sys.file_exists (config_file args)) then
    Stdlib.Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "
Warning: no config file at " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal
              ",
         displaying the default configuration.
" % string
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Flush_newline
                CamlinternalFormatBasics.End_of_format))))
        "
Warning: no config file at %s,
         displaying the default configuration.
@."
          % string) (config_file args)
  else
    tt;
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Node_shared_arg.read_and_patch_config_file None args)
    (fun cfg =>
      Tezos_base__TzPervasives.op_gt_gt_eq (Node_config_file.check cfg)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            apply OCaml.Stdlib.print_endline (Node_config_file.to_string cfg);
            Tezos_base__TzPervasives.return_unit
          end)).

Definition reset (args : Node_shared_arg.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Stdlib.Sys.file_exists (config_file args) then
    Stdlib.Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Ignoring previous configuration file: " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "." % char
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Flush_newline
                CamlinternalFormatBasics.End_of_format))))
        "Ignoring previous configuration file: %s.@." % string)
      (config_file args)
  else
    tt;
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Node_shared_arg.read_and_patch_config_file None args)
    (fun cfg =>
      Tezos_base__TzPervasives.op_gt_gt_eq (Node_config_file.check cfg)
        (fun function_parameter =>
          match function_parameter with
          | tt => Node_config_file.write (config_file args) cfg
          end)).

Definition init (args : Node_shared_arg.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Stdlib.Sys.file_exists (config_file args) then
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Pre-existing config file at " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal ", use `reset`." % string
              CamlinternalFormatBasics.End_of_format)))
        "Pre-existing config file at %s, use `reset`." % string)
      (config_file args)
  else
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Node_shared_arg.read_and_patch_config_file None args)
      (fun cfg =>
        Tezos_base__TzPervasives.op_gt_gt_eq (Node_config_file.check cfg)
          (fun function_parameter =>
            match function_parameter with
            | tt => Node_config_file.write (config_file args) cfg
            end)).

Definition update (args : Node_shared_arg.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if negb (Stdlib.Sys.file_exists (config_file args)) then
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Missing configuration file at " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal ". Use `" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal
                  " config init [options]` to generate a new file" % string
                  CamlinternalFormatBasics.End_of_format)))))
        "Missing configuration file at %s. Use `%s config init [options]` to generate a new file"
          % string) (config_file args) (Stdlib.Array.get Stdlib.Sys.argv 0)
  else
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Node_shared_arg.read_and_patch_config_file None args)
      (fun cfg =>
        Tezos_base__TzPervasives.op_gt_gt_eq (Node_config_file.check cfg)
          (fun function_parameter =>
            match function_parameter with
            | tt => Node_config_file.write (config_file args) cfg
            end)).

Module Term.
  Inductive subcommand : Type :=
  | Show : subcommand
  | Reset : subcommand
  | Init : subcommand
  | Update : subcommand.
  
  Definition process (subcommand : subcommand) (args : Node_shared_arg.t)
    : variant :=
    let res :=
      match subcommand with
      | Show => show args
      | Reset => reset args
      | Init => init args
      | Update => update args
      end in
    match Lwt_main.run res with
    | inl tt => variant
    | inr err => variant
    end.
  
  Definition subcommand_arg : Cmdliner.Term.t subcommand :=
    let parser (function_parameter : string) : variant :=
      match function_parameter with
      | "show" % string => variant
      | "reset" % string => variant
      | "init" % string => variant
      | "update" % string => variant
      | s => variant
      end
    with printer
      (ppf : Stdlib.Format.formatter) (function_parameter : subcommand)
      : unit :=
      match function_parameter with
      | Show =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "show" % string
              CamlinternalFormatBasics.End_of_format) "show" % string)
      | Reset =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "reset" % string
              CamlinternalFormatBasics.End_of_format) "reset" % string)
      | Init =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "init" % string
              CamlinternalFormatBasics.End_of_format) "init" % string)
      | Update =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "update" % string
              CamlinternalFormatBasics.End_of_format) "update" % string)
      end in
    let doc :=
      "Operation to perform. Possible values: $(b,show), $(b,reset), $(b,init), $(b,update)."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and (Cmdliner.Arg.pos None 0 (parser, printer) Show)
        (Cmdliner.Arg.info None (Some "OPERATION" % string) (Some doc) None [])).
  
  Definition term : Cmdliner.Term.t unit :=
    Cmdliner.Term.ret
      (Cmdliner.Term.op_dollar
        (Cmdliner.Term.op_dollar (Cmdliner.Term.const process) subcommand_arg)
        Node_shared_arg.Term.args).
End Term.

Module Manpage.
  Definition command_description : string :=
    "The $(b,config) command is meant to inspect and amend the configuration of the Tezos node. This command is complementary to manually editing the tezos node configuration file. Its arguments are a subset of the $(i,run) command ones."
      % string.
  
  Definition description : list variant :=
    cons variant
      (cons variant
        (cons variant (cons variant (cons variant (cons variant []))))).
  
  Definition options : list variant :=
    let schema :=
      Tezos_base__TzPervasives.Data_encoding.Json.schema None
        Node_config_file.encoding in
    let schema :=
      Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                CamlinternalFormatBasics.End_of_format "" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format))) "@[%a@]" % string)
        Json_schema.pp schema in
    let schema :=
      Tezos_base__TzPervasives.String.concat "\$" % string
        (Tezos_base__TzPervasives.String.split "$" % char None None schema) in
    cons variant (cons variant (cons variant [])).
  
  Definition man : list Cmdliner.Manpage.block :=
    OCaml.Stdlib.app description
      (OCaml.Stdlib.app Node_shared_arg.Manpage.args
        (OCaml.Stdlib.app options Node_shared_arg.Manpage.bugs)).
  
  Definition info : Cmdliner.Term.info :=
    Cmdliner.Term.info None (Some man) None None None None
      (Some "Manage node configuration" % string) None "config" % string.
End Manpage.

Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
  (Term.term, Manpage.info).
src/bin_node/node_config_command.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val cmd : unit Cmdliner.Term.t * Cmdliner.Term.info

module Manpage : sig
  val command_description : string
end
src/bin_node/node_config_command.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info.

Module Manpage.
  Parameter command_description : string.
End Manpage.
src/bin_node/node_config_file.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

let ( // ) = Filename.concat

let home = try Sys.getenv "HOME" with Not_found -> "/root"

let default_data_dir = home // ".tezos-node"

let default_rpc_port = 8732

let default_p2p_port = 9732

let default_discovery_port = 10732

type t = {
  data_dir : string;
  p2p : p2p;
  rpc : rpc;
  log : Lwt_log_sink_unix.cfg;
  internal_events : Internal_event_unix.Configuration.t;
  shell : shell;
}

and p2p = {
  expected_pow : float;
  bootstrap_peers : string list;
  listen_addr : string option;
  discovery_addr : string option;
  private_mode : bool;
  limits : P2p.limits;
  disable_mempool : bool;
  disable_testchain : bool;
  greylisting_config : P2p_point_state.Info.greylisting_config;
}

and rpc = {
  listen_addrs : string list;
  cors_origins : string list;
  cors_headers : string list;
  tls : tls option;
}

and tls = {cert : string; key : string}

and shell = {
  block_validator_limits : Node.block_validator_limits;
  prevalidator_limits : Node.prevalidator_limits;
  peer_validator_limits : Node.peer_validator_limits;
  chain_validator_limits : Node.chain_validator_limits;
  history_mode : History_mode.t option;
}

let default_p2p_limits : P2p.limits =
  {
    connection_timeout = Time.System.Span.of_seconds_exn 10.;
    authentication_timeout = Time.System.Span.of_seconds_exn 5.;
    greylist_timeout = Time.System.Span.of_seconds_exn 86400. (* one day *);
    maintenance_idle_time =
      Time.System.Span.of_seconds_exn 120. (* two minutes *);
    min_connections = 10;
    expected_connections = 50;
    max_connections = 100;
    backlog = 20;
    max_incoming_connections = 20;
    max_download_speed = None;
    max_upload_speed = None;
    read_buffer_size = 1 lsl 14;
    read_queue_size = None;
    write_queue_size = None;
    incoming_app_message_queue_size = None;
    incoming_message_queue_size = None;
    outgoing_message_queue_size = None;
    known_points_history_size = 500;
    known_peer_ids_history_size = 500;
    max_known_points = Some (400, 300);
    max_known_peer_ids = Some (400, 300);
    swap_linger = Time.System.Span.of_seconds_exn 30.;
    binary_chunks_size = None;
  }

let default_p2p =
  {
    expected_pow = 26.;
    bootstrap_peers = [];
    listen_addr = Some ("[::]:" ^ string_of_int default_p2p_port);
    discovery_addr = None;
    private_mode = false;
    limits = default_p2p_limits;
    disable_mempool = false;
    disable_testchain = false;
    greylisting_config = P2p_point_state.Info.default_greylisting_config;
  }

let default_rpc =
  {listen_addrs = []; cors_origins = []; cors_headers = []; tls = None}

let default_shell =
  {
    block_validator_limits = Node.default_block_validator_limits;
    prevalidator_limits = Node.default_prevalidator_limits;
    peer_validator_limits = Node.default_peer_validator_limits;
    chain_validator_limits = Node.default_chain_validator_limits;
    history_mode = None;
  }

let default_config =
  {
    data_dir = default_data_dir;
    p2p = default_p2p;
    rpc = default_rpc;
    log = Lwt_log_sink_unix.default_cfg;
    internal_events = Internal_event_unix.Configuration.default;
    shell = default_shell;
  }

let limit : P2p.limits Data_encoding.t =
  let open Data_encoding in
  conv
    (fun { P2p.connection_timeout;
           authentication_timeout;
           greylist_timeout;
           maintenance_idle_time;
           min_connections;
           expected_connections;
           max_connections;
           backlog;
           max_incoming_connections;
           max_download_speed;
           max_upload_speed;
           read_buffer_size;
           read_queue_size;
           write_queue_size;
           incoming_app_message_queue_size;
           incoming_message_queue_size;
           outgoing_message_queue_size;
           known_points_history_size;
           known_peer_ids_history_size;
           max_known_points;
           max_known_peer_ids;
           swap_linger;
           binary_chunks_size } ->
      ( ( ( connection_timeout,
            authentication_timeout,
            min_connections,
            expected_connections,
            max_connections,
            backlog,
            max_incoming_connections,
            max_download_speed,
            max_upload_speed,
            swap_linger ),
          ( binary_chunks_size,
            read_buffer_size,
            read_queue_size,
            write_queue_size,
            incoming_app_message_queue_size,
            incoming_message_queue_size,
            outgoing_message_queue_size,
            known_points_history_size,
            known_peer_ids_history_size,
            max_known_points ) ),
        (max_known_peer_ids, greylist_timeout, maintenance_idle_time) ))
    (fun ( ( ( connection_timeout,
               authentication_timeout,
               min_connections,
               expected_connections,
               max_connections,
               backlog,
               max_incoming_connections,
               max_download_speed,
               max_upload_speed,
               swap_linger ),
             ( binary_chunks_size,
               read_buffer_size,
               read_queue_size,
               write_queue_size,
               incoming_app_message_queue_size,
               incoming_message_queue_size,
               outgoing_message_queue_size,
               known_points_history_size,
               known_peer_ids_history_size,
               max_known_points ) ),
           (max_known_peer_ids, greylist_timeout, maintenance_idle_time) ) ->
      {
        connection_timeout;
        authentication_timeout;
        greylist_timeout;
        maintenance_idle_time;
        min_connections;
        expected_connections;
        max_connections;
        backlog;
        max_incoming_connections;
        max_download_speed;
        max_upload_speed;
        read_buffer_size;
        read_queue_size;
        write_queue_size;
        incoming_app_message_queue_size;
        incoming_message_queue_size;
        outgoing_message_queue_size;
        known_points_history_size;
        known_peer_ids_history_size;
        max_known_points;
        max_known_peer_ids;
        swap_linger;
        binary_chunks_size;
      })
    (merge_objs
       (merge_objs
          (obj10
             (dft
                "connection-timeout"
                ~description:
                  "Delay acceptable when initiating a connection to a new \
                   peer, in seconds."
                Time.System.Span.encoding
                default_p2p_limits.authentication_timeout)
             (dft
                "authentication-timeout"
                ~description:
                  "Delay granted to a peer to perform authentication, in \
                   seconds."
                Time.System.Span.encoding
                default_p2p_limits.authentication_timeout)
             (dft
                "min-connections"
                ~description:
                  "Strict minimum number of connections (triggers an urgent \
                   maintenance)."
                uint16
                default_p2p_limits.min_connections)
             (dft
                "expected-connections"
                ~description:
                  "Targeted number of connections to reach when bootstrapping \
                   / maintaining."
                uint16
                default_p2p_limits.expected_connections)
             (dft
                "max-connections"
                ~description:
                  "Maximum number of connections (exceeding peers are \
                   disconnected)."
                uint16
                default_p2p_limits.max_connections)
             (dft
                "backlog"
                ~description:
                  "Number above which pending incoming connections are \
                   immediately rejected."
                uint8
                default_p2p_limits.backlog)
             (dft
                "max-incoming-connections"
                ~description:
                  "Number above which pending incoming connections are \
                   immediately rejected."
                uint8
                default_p2p_limits.max_incoming_connections)
             (opt
                "max-download-speed"
                ~description:"Max download speeds in KiB/s."
                int31)
             (opt
                "max-upload-speed"
                ~description:"Max upload speeds in KiB/s."
                int31)
             (dft
                "swap-linger"
                Time.System.Span.encoding
                default_p2p_limits.swap_linger))
          (obj10
             (opt "binary-chunks-size" uint8)
             (dft
                "read-buffer-size"
                ~description:"Size of the buffer passed to read(2)."
                int31
                default_p2p_limits.read_buffer_size)
             (opt "read-queue-size" int31)
             (opt "write-queue-size" int31)
             (opt "incoming-app-message-queue-size" int31)
             (opt "incoming-message-queue-size" int31)
             (opt "outgoing-message-queue-size" int31)
             (dft
                "known_points_history_size"
                uint16
                default_p2p_limits.known_points_history_size)
             (dft
                "known_peer_ids_history_size"
                uint16
                default_p2p_limits.known_points_history_size)
             (opt "max_known_points" (tup2 uint16 uint16))))
       (obj3
          (opt "max_known_peer_ids" (tup2 uint16 uint16))
          (dft
             "greylist-timeout"
             ~description:"GC delay for the greylists tables, in seconds."
             Time.System.Span.encoding
             default_p2p_limits.greylist_timeout)
          (dft
             "maintenance-idle-time"
             ~description:
               "How long to wait at most, in seconds, before running a \
                maintenance loop."
             Time.System.Span.encoding
             default_p2p_limits.maintenance_idle_time)))

let p2p =
  let open Data_encoding in
  conv
    (fun { expected_pow;
           bootstrap_peers;
           listen_addr;
           discovery_addr;
           private_mode;
           limits;
           disable_mempool;
           disable_testchain;
           greylisting_config } ->
      ( expected_pow,
        bootstrap_peers,
        listen_addr,
        discovery_addr,
        private_mode,
        limits,
        disable_mempool,
        disable_testchain,
        greylisting_config ))
    (fun ( expected_pow,
           bootstrap_peers,
           listen_addr,
           discovery_addr,
           private_mode,
           limits,
           disable_mempool,
           disable_testchain,
           greylisting_config ) ->
      {
        expected_pow;
        bootstrap_peers;
        listen_addr;
        discovery_addr;
        private_mode;
        limits;
        disable_mempool;
        disable_testchain;
        greylisting_config;
      })
    (obj9
       (dft
          "expected-proof-of-work"
          ~description:
            "Floating point number between 0 and 256 that represents a \
             difficulty, 24 signifies for example that at least 24 leading \
             zeroes are expected in the hash."
          float
          default_p2p.expected_pow)
       (dft
          "bootstrap-peers"
          ~description:
            "List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. If \
             the port is not specified, default port 9732 will be assumed."
          (list string)
          default_p2p.bootstrap_peers)
       (opt
          "listen-addr"
          ~description:
            "Host to listen to. If the port is not specified, the default \
             port 8732 will be assumed."
          string)
       (dft
          "discovery-addr"
          ~description:
            "Host for local peer discovery. If the port is not specified, the \
             default port 10732 will be assumed."
          (option string)
          default_p2p.discovery_addr)
       (dft
          "private-mode"
          ~description:
            "Specify if the node is in private mode or not. A node in private \
             mode rejects incoming connections from untrusted peers and only \
             opens outgoing connections to peers listed in 'bootstrap-peers' \
             or provided with '--peer' option. Moreover, these peers will \
             keep the identity and the address of the private node secret."
          bool
          false)
       (dft "limits" ~description:"Network limits" limit default_p2p_limits)
       (dft
          "disable_mempool"
          ~description:
            "If set to [true], the node will not participate in the \
             propagation of pending operations (mempool). Default value is \
             [false]. It can be used to decrease the memory and computation \
             footprints of the node."
          bool
          false)
       (dft
          "disable_testchain"
          ~description:
            "If set to [true], the node will not spawn a testchain during the \
             protocol's testing voting period. Default value is [false]. It \
             may be used used to decrease the node storage usage and \
             computation by droping the validation of the test network blocks."
          bool
          false)
       (let open P2p_point_state.Info in
       dft
         "greylisting_config"
         ~description:"The greylisting policy."
         greylisting_config_encoding
         default_greylisting_config))

let rpc : rpc Data_encoding.t =
  let open Data_encoding in
  conv
    (fun {cors_origins; cors_headers; listen_addrs; tls} ->
      let (cert, key) =
        match tls with
        | None ->
            (None, None)
        | Some {cert; key} ->
            (Some cert, Some key)
      in
      (Some listen_addrs, None, cors_origins, cors_headers, cert, key))
    (fun ( listen_addrs,
           legacy_listen_addr,
           cors_origins,
           cors_headers,
           cert,
           key ) ->
      let tls =
        match (cert, key) with
        | (None, _) | (_, None) ->
            None
        | (Some cert, Some key) ->
            Some {cert; key}
      in
      let listen_addrs =
        match (listen_addrs, legacy_listen_addr) with
        | (Some addrs, None) ->
            addrs
        | (None, Some addr) ->
            [addr]
        | (None, None) ->
            default_rpc.listen_addrs
        | (Some _, Some _) ->
            Pervasives.failwith
              "Config file: Use only \"listen-addrs\" and not (legacy) \
               \"listen-addr\"."
      in
      {listen_addrs; cors_origins; cors_headers; tls})
    (obj6
       (opt
          "listen-addrs"
          ~description:
            "Hosts to listen to. If the port is not specified, the default \
             port 8732 will be assumed."
          (list string))
       (opt "listen-addr" ~description:"Legacy value: Host to listen to" string)
       (dft
          "cors-origin"
          ~description:
            "Cross Origin Resource Sharing parameters, see \
             https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
          (list string)
          default_rpc.cors_origins)
       (dft
          "cors-headers"
          ~description:
            "Cross Origin Resource Sharing parameters, see \
             https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
          (list string)
          default_rpc.cors_headers)
       (opt
          "crt"
          ~description:"Certificate file (necessary when TLS is used)."
          string)
       (opt "key" ~description:"Key file (necessary when TLS is used)." string))

let worker_limits_encoding default_size default_level =
  let open Data_encoding in
  conv
    (fun {Worker_types.backlog_size; backlog_level} ->
      (backlog_size, backlog_level))
    (fun (backlog_size, backlog_level) -> {backlog_size; backlog_level})
    (obj2
       (dft "worker_backlog_size" uint16 default_size)
       (dft "worker_backlog_level" Internal_event.Level.encoding default_level))

let timeout_encoding = Time.System.Span.encoding

let block_validator_limits_encoding =
  let open Data_encoding in
  conv
    (fun {Node.protocol_timeout; worker_limits} ->
      (protocol_timeout, worker_limits))
    (fun (protocol_timeout, worker_limits) ->
      {protocol_timeout; worker_limits})
    (merge_objs
       (obj1
          (dft
             "protocol_request_timeout"
             timeout_encoding
             default_shell.block_validator_limits.protocol_timeout))
       (worker_limits_encoding
          default_shell.block_validator_limits.worker_limits.backlog_size
          default_shell.block_validator_limits.worker_limits.backlog_level))

let prevalidator_limits_encoding =
  let open Data_encoding in
  conv
    (fun { Node.operation_timeout;
           max_refused_operations;
           operations_batch_size;
           worker_limits } ->
      ( (operation_timeout, max_refused_operations, operations_batch_size),
        worker_limits ))
    (fun ( (operation_timeout, max_refused_operations, operations_batch_size),
           worker_limits ) ->
      {
        operation_timeout;
        max_refused_operations;
        operations_batch_size;
        worker_limits;
      })
    (merge_objs
       (obj3
          (dft
             "operations_request_timeout"
             timeout_encoding
             default_shell.prevalidator_limits.operation_timeout)
          (dft
             "max_refused_operations"
             uint16
             default_shell.prevalidator_limits.max_refused_operations)
          (dft
             "operations_batch_size"
             int31
             default_shell.prevalidator_limits.operations_batch_size))
       (worker_limits_encoding
          default_shell.prevalidator_limits.worker_limits.backlog_size
          default_shell.prevalidator_limits.worker_limits.backlog_level))

let peer_validator_limits_encoding =
  let open Data_encoding in
  let default_limits = default_shell.peer_validator_limits in
  conv
    (fun { Node.block_header_timeout;
           block_operations_timeout;
           protocol_timeout;
           new_head_request_timeout;
           worker_limits } ->
      ( ( block_header_timeout,
          block_operations_timeout,
          protocol_timeout,
          new_head_request_timeout ),
        worker_limits ))
    (fun ( ( block_header_timeout,
             block_operations_timeout,
             protocol_timeout,
             new_head_request_timeout ),
           worker_limits ) ->
      {
        block_header_timeout;
        block_operations_timeout;
        protocol_timeout;
        new_head_request_timeout;
        worker_limits;
      })
    (merge_objs
       (obj4
          (dft
             "block_header_request_timeout"
             timeout_encoding
             default_limits.block_header_timeout)
          (dft
             "block_operations_request_timeout"
             timeout_encoding
             default_limits.block_operations_timeout)
          (dft
             "protocol_request_timeout"
             timeout_encoding
             default_limits.protocol_timeout)
          (dft
             "new_head_request_timeout"
             timeout_encoding
             default_limits.new_head_request_timeout))
       (worker_limits_encoding
          default_limits.worker_limits.backlog_size
          default_limits.worker_limits.backlog_level))

let chain_validator_limits_encoding =
  let open Data_encoding in
  conv
    (fun {Node.bootstrap_threshold; worker_limits} ->
      (bootstrap_threshold, worker_limits))
    (fun (bootstrap_threshold, worker_limits) ->
      {bootstrap_threshold; worker_limits})
    (merge_objs
       (obj1
          (dft
             "bootstrap_threshold"
             ~description:
               "Set the number of peers with whom a chain synchronization \
                must be completed to bootstrap the node."
             uint8
             default_shell.chain_validator_limits.bootstrap_threshold))
       (worker_limits_encoding
          default_shell.chain_validator_limits.worker_limits.backlog_size
          default_shell.chain_validator_limits.worker_limits.backlog_level))

let shell =
  let open Data_encoding in
  conv
    (fun { peer_validator_limits;
           block_validator_limits;
           prevalidator_limits;
           chain_validator_limits;
           history_mode } ->
      ( peer_validator_limits,
        block_validator_limits,
        prevalidator_limits,
        chain_validator_limits,
        history_mode ))
    (fun ( peer_validator_limits,
           block_validator_limits,
           prevalidator_limits,
           chain_validator_limits,
           history_mode ) ->
      {
        peer_validator_limits;
        block_validator_limits;
        prevalidator_limits;
        chain_validator_limits;
        history_mode;
      })
    (obj5
       (dft
          "peer_validator"
          peer_validator_limits_encoding
          default_shell.peer_validator_limits)
       (dft
          "block_validator"
          block_validator_limits_encoding
          default_shell.block_validator_limits)
       (dft
          "prevalidator"
          prevalidator_limits_encoding
          default_shell.prevalidator_limits)
       (dft
          "chain_validator"
          chain_validator_limits_encoding
          default_shell.chain_validator_limits)
       (opt "history_mode" History_mode.encoding))

let encoding =
  let open Data_encoding in
  conv
    (fun {data_dir; rpc; p2p; log; internal_events; shell} ->
      (data_dir, rpc, p2p, log, internal_events, shell))
    (fun (data_dir, rpc, p2p, log, internal_events, shell) ->
      {data_dir; rpc; p2p; log; internal_events; shell})
    (obj6
       (dft
          "data-dir"
          ~description:"Location of the data dir on disk."
          string
          default_data_dir)
       (dft
          "rpc"
          ~description:"Configuration of rpc parameters"
          rpc
          default_rpc)
       (req "p2p" ~description:"Configuration of network parameters" p2p)
       (dft
          "log"
          ~description:
            "Configuration of the Lwt-log sink (part of the logging framework)"
          Lwt_log_sink_unix.cfg_encoding
          Lwt_log_sink_unix.default_cfg)
       (dft
          "internal-events"
          ~description:"Configuration of the structured logging framework"
          Internal_event_unix.Configuration.encoding
          Internal_event_unix.Configuration.default)
       (dft
          "shell"
          ~description:"Configuration of network parameters"
          shell
          default_shell))

let read fp =
  if Sys.file_exists fp then
    Lwt_utils_unix.Json.read_file fp
    >>=? fun json ->
    try return (Data_encoding.Json.destruct encoding json)
    with exn -> fail (Exn exn)
  else return default_config

let write fp cfg =
  Node_data_version.ensure_data_dir (Filename.dirname fp)
  >>=? fun () ->
  Lwt_utils_unix.Json.write_file fp (Data_encoding.Json.construct encoding cfg)

let to_string cfg =
  Data_encoding.Json.to_string (Data_encoding.Json.construct encoding cfg)

let update ?data_dir ?min_connections ?expected_connections ?max_connections
    ?max_download_speed ?max_upload_speed ?binary_chunks_size ?peer_table_size
    ?expected_pow ?bootstrap_peers ?listen_addr ?discovery_addr
    ?(rpc_listen_addrs = []) ?(private_mode = false) ?(disable_mempool = false)
    ?(disable_testchain = false) ?(cors_origins = []) ?(cors_headers = [])
    ?rpc_tls ?log_output ?bootstrap_threshold ?history_mode cfg =
  let data_dir = Option.unopt ~default:cfg.data_dir data_dir in
  Node_data_version.ensure_data_dir data_dir
  >>=? fun () ->
  let peer_table_size =
    Option.map peer_table_size ~f:(fun i -> (i, i / 4 * 3))
  in
  let unopt_list ~default = function [] -> default | l -> l in
  let limits : P2p.limits =
    {
      cfg.p2p.limits with
      min_connections =
        Option.unopt ~default:cfg.p2p.limits.min_connections min_connections;
      expected_connections =
        Option.unopt
          ~default:cfg.p2p.limits.expected_connections
          expected_connections;
      max_connections =
        Option.unopt ~default:cfg.p2p.limits.max_connections max_connections;
      max_download_speed =
        Option.first_some max_download_speed cfg.p2p.limits.max_download_speed;
      max_upload_speed =
        Option.first_some max_upload_speed cfg.p2p.limits.max_upload_speed;
      max_known_points =
        Option.first_some peer_table_size cfg.p2p.limits.max_known_points;
      max_known_peer_ids =
        Option.first_some peer_table_size cfg.p2p.limits.max_known_peer_ids;
      binary_chunks_size = Option.map ~f:(fun x -> x lsl 10) binary_chunks_size;
    }
  in
  let p2p : p2p =
    {
      expected_pow = Option.unopt ~default:cfg.p2p.expected_pow expected_pow;
      bootstrap_peers =
        Option.unopt ~default:cfg.p2p.bootstrap_peers bootstrap_peers;
      listen_addr = Option.first_some listen_addr cfg.p2p.listen_addr;
      discovery_addr = Option.first_some discovery_addr cfg.p2p.discovery_addr;
      private_mode = cfg.p2p.private_mode || private_mode;
      limits;
      disable_mempool = cfg.p2p.disable_mempool || disable_mempool;
      disable_testchain = cfg.p2p.disable_testchain || disable_testchain;
      greylisting_config = cfg.p2p.greylisting_config;
    }
  and rpc : rpc =
    {
      listen_addrs = unopt_list ~default:cfg.rpc.listen_addrs rpc_listen_addrs;
      cors_origins = unopt_list ~default:cfg.rpc.cors_origins cors_origins;
      cors_headers = unopt_list ~default:cfg.rpc.cors_headers cors_headers;
      tls = Option.first_some rpc_tls cfg.rpc.tls;
    }
  and log : Lwt_log_sink_unix.cfg =
    {cfg.log with output = Option.unopt ~default:cfg.log.output log_output}
  and shell : shell =
    {
      peer_validator_limits = cfg.shell.peer_validator_limits;
      block_validator_limits = cfg.shell.block_validator_limits;
      prevalidator_limits = cfg.shell.prevalidator_limits;
      chain_validator_limits =
        Option.unopt_map
          ~default:cfg.shell.chain_validator_limits
          ~f:(fun bootstrap_threshold ->
            {cfg.shell.chain_validator_limits with bootstrap_threshold})
          bootstrap_threshold;
      history_mode = Option.first_some history_mode cfg.shell.history_mode;
    }
  in
  let internal_events = cfg.internal_events in
  return {data_dir; p2p; rpc; log; internal_events; shell}

let resolve_addr ~default_addr ?default_port ?(passive = false) peer =
  let (addr, port) = P2p_point.Id.parse_addr_port peer in
  let node = if addr = "" || addr = "_" then default_addr else addr
  and service =
    match (port, default_port) with
    | ("", None) ->
        invalid_arg ""
    | ("", Some default_port) ->
        string_of_int default_port
    | (port, _) ->
        port
  in
  Lwt_utils_unix.getaddrinfo ~passive ~node ~service

let resolve_addrs ~default_addr ?default_port ?passive peers =
  Lwt_list.fold_left_s
    (fun a peer ->
      resolve_addr ~default_addr ?default_port ?passive peer
      >>= fun points -> Lwt.return (List.rev_append points a))
    []
    peers

let resolve_discovery_addrs discovery_addr =
  resolve_addr
    ~default_addr:Ipaddr.V4.(to_string broadcast)
    ~default_port:default_discovery_port
    ~passive:true
    discovery_addr
  >>= fun addrs ->
  let rec to_ipv4 acc = function
    | [] ->
        Lwt.return (List.rev acc)
    | (ip, port) :: xs -> (
      match Ipaddr.v4_of_v6 ip with
      | Some v ->
          to_ipv4 ((v, port) :: acc) xs
      | None ->
          Format.eprintf
            "Warning: failed to convert %S to an ipv4 address@."
            (Ipaddr.V6.to_string ip) ;
          to_ipv4 acc xs )
  in
  to_ipv4 [] addrs

let resolve_listening_addrs listen_addr =
  resolve_addr
    ~default_addr:"::"
    ~default_port:default_p2p_port
    ~passive:true
    listen_addr

let resolve_rpc_listening_addrs listen_addr =
  resolve_addr
    ~default_addr:"::"
    ~default_port:default_rpc_port
    ~passive:true
    listen_addr

let resolve_bootstrap_addrs peers =
  resolve_addrs ~default_addr:"::" ~default_port:default_p2p_port peers

let check_listening_addrs config =
  match config.p2p.listen_addr with
  | None ->
      Lwt.return_unit
  | Some addr ->
      Lwt.catch
        (fun () ->
          resolve_listening_addrs addr
          >>= function
          | [] ->
              Format.eprintf "Warning: failed to resolve %S\n@." addr ;
              Lwt.return_unit
          | _ :: _ ->
              Lwt.return_unit)
        (function
          | Invalid_argument msg ->
              Format.eprintf "Warning: failed to parse %S:   %s\n@." addr msg ;
              Lwt.return_unit
          | exn ->
              Lwt.fail exn)

let check_discovery_addr config =
  match config.p2p.discovery_addr with
  | None ->
      Lwt.return_unit
  | Some addr ->
      Lwt.catch
        (fun () ->
          resolve_discovery_addrs addr
          >>= function
          | [] ->
              Format.eprintf "Warning: failed to resolve %S\n@." addr ;
              Lwt.return_unit
          | _ :: _ ->
              Lwt.return_unit)
        (function
          | Invalid_argument msg ->
              Format.eprintf "Warning: failed to parse %S:   %s\n@." addr msg ;
              Lwt.return_unit
          | exn ->
              Lwt.fail exn)

let check_rpc_listening_addr config =
  Lwt_list.iter_p
    (fun addr ->
      Lwt.catch
        (fun () ->
          resolve_rpc_listening_addrs addr
          >>= function
          | [] ->
              Format.eprintf "Warning: failed to resolve %S\n@." addr ;
              Lwt.return_unit
          | _ :: _ ->
              Lwt.return_unit)
        (function
          | Invalid_argument msg ->
              Format.eprintf "Warning: failed to parse %S:   %s\n@." addr msg ;
              Lwt.return_unit
          | exn ->
              Lwt.fail exn))
    config.rpc.listen_addrs

let check_bootstrap_peer addr =
  Lwt.catch
    (fun () ->
      resolve_bootstrap_addrs [addr]
      >>= function
      | [] ->
          Format.eprintf "Warning: cannot resolve %S\n@." addr ;
          Lwt.return_unit
      | _ :: _ ->
          Lwt.return_unit)
    (function
      | Invalid_argument msg ->
          Format.eprintf "Warning: failed to parse %S:   %s\n@." addr msg ;
          Lwt.return_unit
      | exn ->
          Lwt.fail exn)

let check_bootstrap_peers config =
  Lwt_list.iter_p check_bootstrap_peer config.p2p.bootstrap_peers

let fail fmt = Format.kasprintf (fun s -> prerr_endline s ; exit 1) fmt

let check_connections config =
  if config.p2p.limits.min_connections > config.p2p.limits.expected_connections
  then
    fail
      "Error: The minumum number of connections is greater than the expected \
       number of connections"
      config.p2p.limits.min_connections
      config.p2p.limits.expected_connections ;
  if config.p2p.limits.expected_connections > config.p2p.limits.max_connections
  then
    fail
      "Error: The expected number of connections is greater than the maximum \
       number of connections"
      config.p2p.limits.expected_connections
      config.p2p.limits.max_connections ;
  ( match config.p2p.limits.max_known_peer_ids with
  | None ->
      ()
  | Some (max_known_peer_ids, target_known_peer_ids) ->
      if target_known_peer_ids > max_known_peer_ids then
        fail
          "Error: The target number of known peer ids is greater than the \
           maximum number of known peer ids."
          target_known_peer_ids
          max_known_peer_ids ;
      if config.p2p.limits.max_connections > target_known_peer_ids then
        fail
          "Error: The target number of known peer ids is lower than the \
           maximum number of connections."
          target_known_peer_ids
          max_known_peer_ids ) ;
  match config.p2p.limits.max_known_points with
  | None ->
      ()
  | Some (max_known_points, target_known_points) ->
      if target_known_points > max_known_points then
        fail
          "Error: The target number of known points is greater than the \
           maximum number of known points."
          target_known_points
          max_known_points ;
      if config.p2p.limits.max_connections > target_known_points then
        fail
          "Error: The target number of known points is lower than the maximum \
           number of connections."
          target_known_points
          max_known_points

let check config =
  check_listening_addrs config
  >>= fun () ->
  check_rpc_listening_addr config
  >>= fun () ->
  check_discovery_addr config
  >>= fun () ->
  check_bootstrap_peers config
  >>= fun () -> check_connections config ; Lwt.return_unit
src/bin_node/node_config_file.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition home : string := try.

Definition default_data_dir : string := op_div_div home ".tezos-node" % string.

Definition default_rpc_port : Z := 8732.

Definition default_p2p_port : Z := 9732.

Definition default_discovery_port : Z := 10732.

.

Definition default_p2p_limits : Tezos_p2p.P2p.limits :=
  {|
    connection_timeout :=
      Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 10;
    authentication_timeout :=
      Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 5;
    greylist_timeout :=
      Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 86400;
    maintenance_idle_time :=
      Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 120;
    min_connections := 10; expected_connections := 50; max_connections := 100;
    backlog := 20; max_incoming_connections := 20; max_download_speed := None;
    max_upload_speed := None; read_buffer_size := Z.shiftl 1 14;
    read_queue_size := None; write_queue_size := None;
    incoming_app_message_queue_size := None;
    incoming_message_queue_size := None; outgoing_message_queue_size := None;
    known_peer_ids_history_size := 500; known_points_history_size := 500;
    max_known_peer_ids := Some (400, 300); max_known_points := Some (400, 300);
    swap_linger := Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 30;
    binary_chunks_size := None |}.

Definition default_p2p : p2p :=
  {| expected_pow := 26; bootstrap_peers := [];
    listen_addr :=
      Some
        (String.append "[::]:" % string
          (OCaml.Stdlib.string_of_int default_p2p_port));
    discovery_addr := None; private_mode := false; limits := default_p2p_limits;
    disable_mempool := false; disable_testchain := false;
    greylisting_config :=
      Tezos_p2p.P2p_point_state.Info.default_greylisting_config |}.

Definition default_rpc : rpc :=
  {| listen_addrs := []; cors_origins := []; cors_headers := []; tls := None |}.

Definition default_shell : shell :=
  {| block_validator_limits := Tezos_shell.Node.default_block_validator_limits;
    prevalidator_limits := Tezos_shell.Node.default_prevalidator_limits;
    peer_validator_limits := Tezos_shell.Node.default_peer_validator_limits;
    chain_validator_limits := Tezos_shell.Node.default_chain_validator_limits;
    history_mode := None |}.

Definition default_config : t :=
  {| data_dir := default_data_dir; p2p := default_p2p; rpc := default_rpc;
    log := Tezos_stdlib_unix.Lwt_log_sink_unix.default_cfg;
    internal_events :=
      Tezos_stdlib_unix.Internal_event_unix.Configuration.default;
    shell := default_shell |}.

Definition limit
  : Tezos_base__TzPervasives.Data_encoding.t Tezos_p2p.P2p.limits :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        P2p.connection_timeout := connection_timeout;
          P2p.authentication_timeout := authentication_timeout;
          P2p.greylist_timeout := greylist_timeout;
          P2p.maintenance_idle_time := maintenance_idle_time;
          P2p.min_connections := min_connections;
          P2p.expected_connections := expected_connections;
          P2p.max_connections := max_connections;
          P2p.backlog := backlog;
          P2p.max_incoming_connections := max_incoming_connections;
          P2p.max_download_speed := max_download_speed;
          P2p.max_upload_speed := max_upload_speed;
          P2p.read_buffer_size := read_buffer_size;
          P2p.read_queue_size := read_queue_size;
          P2p.write_queue_size := write_queue_size;
          P2p.incoming_app_message_queue_size := incoming_app_message_queue_size;
          P2p.incoming_message_queue_size := incoming_message_queue_size;
          P2p.outgoing_message_queue_size := outgoing_message_queue_size;
          P2p.known_peer_ids_history_size := known_peer_ids_history_size;
          P2p.known_points_history_size := known_points_history_size;
          P2p.max_known_peer_ids := max_known_peer_ids;
          P2p.max_known_points := max_known_points;
          P2p.swap_linger := swap_linger;
          P2p.binary_chunks_size := binary_chunks_size
          |} =>
        (((connection_timeout, authentication_timeout, min_connections,
          expected_connections, max_connections, backlog,
          max_incoming_connections, max_download_speed, max_upload_speed,
          swap_linger),
          (binary_chunks_size, read_buffer_size, read_queue_size,
            write_queue_size, incoming_app_message_queue_size,
            incoming_message_queue_size, outgoing_message_queue_size,
            known_points_history_size, known_peer_ids_history_size,
            max_known_points)),
          (max_known_peer_ids, greylist_timeout, maintenance_idle_time))
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        (((connection_timeout, authentication_timeout, min_connections,
          expected_connections, max_connections, backlog,
          max_incoming_connections, max_download_speed, max_upload_speed,
          swap_linger),
          (binary_chunks_size, read_buffer_size, read_queue_size,
            write_queue_size, incoming_app_message_queue_size,
            incoming_message_queue_size, outgoing_message_queue_size,
            known_points_history_size, known_peer_ids_history_size,
            max_known_points)),
          (max_known_peer_ids, greylist_timeout, maintenance_idle_time)) =>
        {| connection_timeout := connection_timeout;
          authentication_timeout := authentication_timeout;
          greylist_timeout := greylist_timeout;
          maintenance_idle_time := maintenance_idle_time;
          min_connections := min_connections;
          expected_connections := expected_connections;
          max_connections := max_connections; backlog := backlog;
          max_incoming_connections := max_incoming_connections;
          max_download_speed := max_download_speed;
          max_upload_speed := max_upload_speed;
          read_buffer_size := read_buffer_size;
          read_queue_size := read_queue_size;
          write_queue_size := write_queue_size;
          incoming_app_message_queue_size := incoming_app_message_queue_size;
          incoming_message_queue_size := incoming_message_queue_size;
          outgoing_message_queue_size := outgoing_message_queue_size;
          known_peer_ids_history_size := known_peer_ids_history_size;
          known_points_history_size := known_points_history_size;
          max_known_peer_ids := max_known_peer_ids;
          max_known_points := max_known_points; swap_linger := swap_linger;
          binary_chunks_size := binary_chunks_size |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.merge_objs
      (Tezos_base__TzPervasives.Data_encoding.merge_objs
        (Tezos_base__TzPervasives.Data_encoding.obj10
          (Tezos_base__TzPervasives.Data_encoding.dft None
            (Some
              "Delay acceptable when initiating a connection to a new peer, in seconds."
                % string) "connection-timeout" % string
            Tezos_base__TzPervasives.Time.System.Span.encoding
            (authentication_timeout default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.dft None
            (Some
              "Delay granted to a peer to perform authentication, in seconds." %
                string) "authentication-timeout" % string
            Tezos_base__TzPervasives.Time.System.Span.encoding
            (authentication_timeout default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.dft None
            (Some
              "Strict minimum number of connections (triggers an urgent maintenance)."
                % string) "min-connections" % string
            Tezos_base__TzPervasives.Data_encoding.uint16
            (min_connections default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.dft None
            (Some
              "Targeted number of connections to reach when bootstrapping / maintaining."
                % string) "expected-connections" % string
            Tezos_base__TzPervasives.Data_encoding.uint16
            (expected_connections default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.dft None
            (Some
              "Maximum number of connections (exceeding peers are disconnected)."
                % string) "max-connections" % string
            Tezos_base__TzPervasives.Data_encoding.uint16
            (max_connections default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.dft None
            (Some
              "Number above which pending incoming connections are immediately rejected."
                % string) "backlog" % string
            Tezos_base__TzPervasives.Data_encoding.uint8
            (backlog default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.dft None
            (Some
              "Number above which pending incoming connections are immediately rejected."
                % string) "max-incoming-connections" % string
            Tezos_base__TzPervasives.Data_encoding.uint8
            (max_incoming_connections default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.opt None
            (Some "Max download speeds in KiB/s." % string)
            "max-download-speed" % string
            Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.opt None
            (Some "Max upload speeds in KiB/s." % string)
            "max-upload-speed" % string
            Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.dft None None
            "swap-linger" % string
            Tezos_base__TzPervasives.Time.System.Span.encoding
            (swap_linger default_p2p_limits)))
        (Tezos_base__TzPervasives.Data_encoding.obj10
          (Tezos_base__TzPervasives.Data_encoding.opt None None
            "binary-chunks-size" % string
            Tezos_base__TzPervasives.Data_encoding.uint8)
          (Tezos_base__TzPervasives.Data_encoding.dft None
            (Some "Size of the buffer passed to read(2)." % string)
            "read-buffer-size" % string
            Tezos_base__TzPervasives.Data_encoding.int31
            (read_buffer_size default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.opt None None
            "read-queue-size" % string
            Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.opt None None
            "write-queue-size" % string
            Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.opt None None
            "incoming-app-message-queue-size" % string
            Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.opt None None
            "incoming-message-queue-size" % string
            Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.opt None None
            "outgoing-message-queue-size" % string
            Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.dft None None
            "known_points_history_size" % string
            Tezos_base__TzPervasives.Data_encoding.uint16
            (known_points_history_size default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.dft None None
            "known_peer_ids_history_size" % string
            Tezos_base__TzPervasives.Data_encoding.uint16
            (known_points_history_size default_p2p_limits))
          (Tezos_base__TzPervasives.Data_encoding.opt None None
            "max_known_points" % string
            (Tezos_base__TzPervasives.Data_encoding.tup2
              Tezos_base__TzPervasives.Data_encoding.uint16
              Tezos_base__TzPervasives.Data_encoding.uint16))))
      (Tezos_base__TzPervasives.Data_encoding.obj3
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "max_known_peer_ids" % string
          (Tezos_base__TzPervasives.Data_encoding.tup2
            Tezos_base__TzPervasives.Data_encoding.uint16
            Tezos_base__TzPervasives.Data_encoding.uint16))
        (Tezos_base__TzPervasives.Data_encoding.dft None
          (Some "GC delay for the greylists tables, in seconds." % string)
          "greylist-timeout" % string
          Tezos_base__TzPervasives.Time.System.Span.encoding
          (greylist_timeout default_p2p_limits))
        (Tezos_base__TzPervasives.Data_encoding.dft None
          (Some
            "How long to wait at most, in seconds, before running a maintenance loop."
              % string) "maintenance-idle-time" % string
          Tezos_base__TzPervasives.Time.System.Span.encoding
          (maintenance_idle_time default_p2p_limits)))).

Definition p2p : Tezos_base__TzPervasives.Data_encoding.encoding p2p :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        expected_pow := expected_pow;
          bootstrap_peers := bootstrap_peers;
          listen_addr := listen_addr;
          discovery_addr := discovery_addr;
          private_mode := private_mode;
          limits := limits;
          disable_mempool := disable_mempool;
          disable_testchain := disable_testchain;
          greylisting_config := greylisting_config
          |} =>
        (expected_pow, bootstrap_peers, listen_addr, discovery_addr,
          private_mode, limits, disable_mempool, disable_testchain,
          greylisting_config)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        (expected_pow, bootstrap_peers, listen_addr, discovery_addr,
          private_mode, limits, disable_mempool, disable_testchain,
          greylisting_config) =>
        {| expected_pow := expected_pow; bootstrap_peers := bootstrap_peers;
          listen_addr := listen_addr; discovery_addr := discovery_addr;
          private_mode := private_mode; limits := limits;
          disable_mempool := disable_mempool;
          disable_testchain := disable_testchain;
          greylisting_config := greylisting_config |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj9
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "Floating point number between 0 and 256 that represents a difficulty, 24 signifies for example that at least 24 leading zeroes are expected in the hash."
            % string) "expected-proof-of-work" % string
        Tezos_base__TzPervasives.Data_encoding.float (expected_pow default_p2p))
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. If the port is not specified, default port 9732 will be assumed."
            % string) "bootstrap-peers" % string
        (Tezos_base__TzPervasives.Data_encoding.list None
          Tezos_base__TzPervasives.Data_encoding.string)
        (bootstrap_peers default_p2p))
      (Tezos_base__TzPervasives.Data_encoding.opt None
        (Some
          "Host to listen to. If the port is not specified, the default port 8732 will be assumed."
            % string) "listen-addr" % string
        Tezos_base__TzPervasives.Data_encoding.string)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "Host for local peer discovery. If the port is not specified, the default port 10732 will be assumed."
            % string) "discovery-addr" % string
        (Tezos_base__TzPervasives.Data_encoding.option
          Tezos_base__TzPervasives.Data_encoding.string)
        (discovery_addr default_p2p))
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "Specify if the node is in private mode or not. A node in private mode rejects incoming connections from untrusted peers and only opens outgoing connections to peers listed in 'bootstrap-peers' or provided with '--peer' option. Moreover, these peers will keep the identity and the address of the private node secret."
            % string) "private-mode" % string
        Tezos_base__TzPervasives.Data_encoding.bool false)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some "Network limits" % string) "limits" % string limit
        default_p2p_limits)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "If set to [true], the node will not participate in the propagation of pending operations (mempool). Default value is [false]. It can be used to decrease the memory and computation footprints of the node."
            % string) "disable_mempool" % string
        Tezos_base__TzPervasives.Data_encoding.bool false)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "If set to [true], the node will not spawn a testchain during the protocol's testing voting period. Default value is [false]. It may be used used to decrease the node storage usage and computation by droping the validation of the test network blocks."
            % string) "disable_testchain" % string
        Tezos_base__TzPervasives.Data_encoding.bool false)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some "The greylisting policy." % string) "greylisting_config" % string
        Tezos_p2p.P2p_point_state.Info.greylisting_config_encoding
        Tezos_p2p.P2p_point_state.Info.default_greylisting_config)).

Definition rpc : Tezos_base__TzPervasives.Data_encoding.t rpc :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        listen_addrs := listen_addrs;
          cors_origins := cors_origins;
          cors_headers := cors_headers;
          tls := tls
          |} =>
        match
          match tls with
          | None => (None, None)
          | Some {| cert := cert; key := key |} => ((Some cert), (Some key))
          end with
        | (cert, key) =>
          ((Some listen_addrs), None, cors_origins, cors_headers, cert, key)
        end
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        (listen_addrs, legacy_listen_addr, cors_origins, cors_headers, cert, key)
        =>
        let tls :=
          match (cert, key) with
          | (None, _) | (_, None) => None
          | (Some cert, Some key) => Some {| cert := cert; key := key |}
          end in
        let listen_addrs :=
          match (listen_addrs, legacy_listen_addr) with
          | (Some addrs, None) => addrs
          | (None, Some addr) => cons addr []
          | (None, None) => listen_addrs default_rpc
          | (Some _, Some _) =>
            Stdlib.Pervasives.failwith
              "Config file: Use only ""listen-addrs"" and not (legacy) ""listen-addr""."
                % string
          end in
        {| listen_addrs := listen_addrs; cors_origins := cors_origins;
          cors_headers := cors_headers; tls := tls |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj6
      (Tezos_base__TzPervasives.Data_encoding.opt None
        (Some
          "Hosts to listen to. If the port is not specified, the default port 8732 will be assumed."
            % string) "listen-addrs" % string
        (Tezos_base__TzPervasives.Data_encoding.list None
          Tezos_base__TzPervasives.Data_encoding.string))
      (Tezos_base__TzPervasives.Data_encoding.opt None
        (Some "Legacy value: Host to listen to" % string) "listen-addr" % string
        Tezos_base__TzPervasives.Data_encoding.string)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "Cross Origin Resource Sharing parameters, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
            % string) "cors-origin" % string
        (Tezos_base__TzPervasives.Data_encoding.list None
          Tezos_base__TzPervasives.Data_encoding.string)
        (cors_origins default_rpc))
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "Cross Origin Resource Sharing parameters, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
            % string) "cors-headers" % string
        (Tezos_base__TzPervasives.Data_encoding.list None
          Tezos_base__TzPervasives.Data_encoding.string)
        (cors_headers default_rpc))
      (Tezos_base__TzPervasives.Data_encoding.opt None
        (Some "Certificate file (necessary when TLS is used)." % string)
        "crt" % string Tezos_base__TzPervasives.Data_encoding.string)
      (Tezos_base__TzPervasives.Data_encoding.opt None
        (Some "Key file (necessary when TLS is used)." % string) "key" % string
        Tezos_base__TzPervasives.Data_encoding.string)).

Definition worker_limits_encoding
  (default_size : Z)
  (default_level : Tezos_base__TzPervasives.Internal_event.Level.t)
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell_services.Worker_types.limits :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        Worker_types.backlog_size := backlog_size;
          Worker_types.backlog_level := backlog_level
          |} => (backlog_size, backlog_level)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (backlog_size, backlog_level) =>
        {| backlog_size := backlog_size; backlog_level := backlog_level |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj2
      (Tezos_base__TzPervasives.Data_encoding.dft None None
        "worker_backlog_size" % string
        Tezos_base__TzPervasives.Data_encoding.uint16 default_size)
      (Tezos_base__TzPervasives.Data_encoding.dft None None
        "worker_backlog_level" % string
        Tezos_base__TzPervasives.Internal_event.Level.encoding default_level)).

Definition timeout_encoding
  : Tezos_data_encoding.Data_encoding.t
    Tezos_base__TzPervasives.Time.System.Span.t :=
  Tezos_base__TzPervasives.Time.System.Span.encoding.

Definition block_validator_limits_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell.Node.block_validator_limits :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        Node.protocol_timeout := protocol_timeout;
          Node.worker_limits := worker_limits
          |} => (protocol_timeout, worker_limits)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (protocol_timeout, worker_limits) =>
        {| protocol_timeout := protocol_timeout; worker_limits := worker_limits
          |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.merge_objs
      (Tezos_base__TzPervasives.Data_encoding.obj1
        (Tezos_base__TzPervasives.Data_encoding.dft None None
          "protocol_request_timeout" % string timeout_encoding
          (protocol_timeout (block_validator_limits default_shell))))
      (worker_limits_encoding
        (backlog_size (worker_limits (block_validator_limits default_shell)))
        (backlog_level (worker_limits (block_validator_limits default_shell))))).

Definition prevalidator_limits_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell.Node.prevalidator_limits :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        Node.max_refused_operations := max_refused_operations;
          Node.operation_timeout := operation_timeout;
          Node.worker_limits := worker_limits;
          Node.operations_batch_size := operations_batch_size
          |} =>
        ((operation_timeout, max_refused_operations, operations_batch_size),
          worker_limits)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        ((operation_timeout, max_refused_operations, operations_batch_size),
          worker_limits) =>
        {| max_refused_operations := max_refused_operations;
          operation_timeout := operation_timeout;
          worker_limits := worker_limits;
          operations_batch_size := operations_batch_size |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.merge_objs
      (Tezos_base__TzPervasives.Data_encoding.obj3
        (Tezos_base__TzPervasives.Data_encoding.dft None None
          "operations_request_timeout" % string timeout_encoding
          (operation_timeout (prevalidator_limits default_shell)))
        (Tezos_base__TzPervasives.Data_encoding.dft None None
          "max_refused_operations" % string
          Tezos_base__TzPervasives.Data_encoding.uint16
          (max_refused_operations (prevalidator_limits default_shell)))
        (Tezos_base__TzPervasives.Data_encoding.dft None None
          "operations_batch_size" % string
          Tezos_base__TzPervasives.Data_encoding.int31
          (operations_batch_size (prevalidator_limits default_shell))))
      (worker_limits_encoding
        (backlog_size (worker_limits (prevalidator_limits default_shell)))
        (backlog_level (worker_limits (prevalidator_limits default_shell))))).

Definition peer_validator_limits_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell.Node.peer_validator_limits :=
  let default_limits := peer_validator_limits default_shell in
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        Node.new_head_request_timeout := new_head_request_timeout;
          Node.block_header_timeout := block_header_timeout;
          Node.block_operations_timeout := block_operations_timeout;
          Node.protocol_timeout := protocol_timeout;
          Node.worker_limits := worker_limits
          |} =>
        ((block_header_timeout, block_operations_timeout, protocol_timeout,
          new_head_request_timeout), worker_limits)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        ((block_header_timeout, block_operations_timeout, protocol_timeout,
          new_head_request_timeout), worker_limits) =>
        {| new_head_request_timeout := new_head_request_timeout;
          block_header_timeout := block_header_timeout;
          block_operations_timeout := block_operations_timeout;
          protocol_timeout := protocol_timeout; worker_limits := worker_limits
          |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.merge_objs
      (Tezos_base__TzPervasives.Data_encoding.obj4
        (Tezos_base__TzPervasives.Data_encoding.dft None None
          "block_header_request_timeout" % string timeout_encoding
          (block_header_timeout default_limits))
        (Tezos_base__TzPervasives.Data_encoding.dft None None
          "block_operations_request_timeout" % string timeout_encoding
          (block_operations_timeout default_limits))
        (Tezos_base__TzPervasives.Data_encoding.dft None None
          "protocol_request_timeout" % string timeout_encoding
          (protocol_timeout default_limits))
        (Tezos_base__TzPervasives.Data_encoding.dft None None
          "new_head_request_timeout" % string timeout_encoding
          (new_head_request_timeout default_limits)))
      (worker_limits_encoding (backlog_size (worker_limits default_limits))
        (backlog_level (worker_limits default_limits)))).

Definition chain_validator_limits_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell.Node.chain_validator_limits :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        Node.bootstrap_threshold := bootstrap_threshold;
          Node.worker_limits := worker_limits
          |} => (bootstrap_threshold, worker_limits)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (bootstrap_threshold, worker_limits) =>
        {| bootstrap_threshold := bootstrap_threshold;
          worker_limits := worker_limits |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.merge_objs
      (Tezos_base__TzPervasives.Data_encoding.obj1
        (Tezos_base__TzPervasives.Data_encoding.dft None
          (Some
            "Set the number of peers with whom a chain synchronization must be completed to bootstrap the node."
              % string) "bootstrap_threshold" % string
          Tezos_base__TzPervasives.Data_encoding.uint8
          (bootstrap_threshold (chain_validator_limits default_shell))))
      (worker_limits_encoding
        (backlog_size (worker_limits (chain_validator_limits default_shell)))
        (backlog_level (worker_limits (chain_validator_limits default_shell))))).

Definition shell : Tezos_base__TzPervasives.Data_encoding.encoding shell :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        block_validator_limits := block_validator_limits;
          prevalidator_limits := prevalidator_limits;
          peer_validator_limits := peer_validator_limits;
          chain_validator_limits := chain_validator_limits;
          history_mode := history_mode
          |} =>
        (peer_validator_limits, block_validator_limits, prevalidator_limits,
          chain_validator_limits, history_mode)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        (peer_validator_limits, block_validator_limits, prevalidator_limits,
          chain_validator_limits, history_mode) =>
        {| block_validator_limits := block_validator_limits;
          prevalidator_limits := prevalidator_limits;
          peer_validator_limits := peer_validator_limits;
          chain_validator_limits := chain_validator_limits;
          history_mode := history_mode |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj5
      (Tezos_base__TzPervasives.Data_encoding.dft None None
        "peer_validator" % string peer_validator_limits_encoding
        (peer_validator_limits default_shell))
      (Tezos_base__TzPervasives.Data_encoding.dft None None
        "block_validator" % string block_validator_limits_encoding
        (block_validator_limits default_shell))
      (Tezos_base__TzPervasives.Data_encoding.dft None None
        "prevalidator" % string prevalidator_limits_encoding
        (prevalidator_limits default_shell))
      (Tezos_base__TzPervasives.Data_encoding.dft None None
        "chain_validator" % string chain_validator_limits_encoding
        (chain_validator_limits default_shell))
      (Tezos_base__TzPervasives.Data_encoding.opt None None
        "history_mode" % string Tezos_shell_services.History_mode.encoding)).

Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        data_dir := data_dir;
          p2p := p2p;
          rpc := rpc;
          log := log;
          internal_events := internal_events;
          shell := shell
          |} => (data_dir, rpc, p2p, log, internal_events, shell)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (data_dir, rpc, p2p, log, internal_events, shell) =>
        {| data_dir := data_dir; p2p := p2p; rpc := rpc; log := log;
          internal_events := internal_events; shell := shell |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj6
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some "Location of the data dir on disk." % string) "data-dir" % string
        Tezos_base__TzPervasives.Data_encoding.string default_data_dir)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some "Configuration of rpc parameters" % string) "rpc" % string rpc
        default_rpc)
      (Tezos_base__TzPervasives.Data_encoding.req None
        (Some "Configuration of network parameters" % string) "p2p" % string p2p)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some
          "Configuration of the Lwt-log sink (part of the logging framework)" %
            string) "log" % string
        Tezos_stdlib_unix.Lwt_log_sink_unix.cfg_encoding
        Tezos_stdlib_unix.Lwt_log_sink_unix.default_cfg)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some "Configuration of the structured logging framework" % string)
        "internal-events" % string
        Tezos_stdlib_unix.Internal_event_unix.Configuration.encoding
        Tezos_stdlib_unix.Internal_event_unix.Configuration.default)
      (Tezos_base__TzPervasives.Data_encoding.dft None
        (Some "Configuration of network parameters" % string) "shell" % string
        shell default_shell)).

Definition read (fp : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  if Stdlib.Sys.file_exists fp then
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file fp) (fun json => try)
  else
    Tezos_base__TzPervasives._return default_config.

Definition write (fp : string) (cfg : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Node_data_version.ensure_data_dir None (Stdlib.Filename.dirname fp))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file fp
          (Tezos_base__TzPervasives.Data_encoding.Json.construct encoding cfg)
      end).

Definition to_string (cfg : t) : string :=
  Tezos_base__TzPervasives.Data_encoding.Json.to_string None None
    (Tezos_base__TzPervasives.Data_encoding.Json.construct encoding cfg).

Definition update
  (data_dir : option string) (min_connections : option Z)
  (expected_connections : option Z) (max_connections : option Z)
  (max_download_speed : option Z) (max_upload_speed : option Z)
  (binary_chunks_size : option Z) (peer_table_size : option Z)
  (expected_pow : option float) (bootstrap_peers : option (list string))
  (listen_addr : option string) (discovery_addr : option string)
  (op_star_o_p_t_star : option (list string))
  : (option bool) ->
    (option bool) ->
      (option bool) ->
        (option (list string)) ->
          (option (list string)) ->
            (option tls) ->
              (option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t) ->
                (option Z) ->
                  (option Tezos_shell_services.History_mode.t) ->
                    t -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let rpc_listen_addrs :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun op_star_o_p_t_star =>
    let private_mode :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun op_star_o_p_t_star =>
      let disable_mempool :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => false
        end in
      fun op_star_o_p_t_star =>
        let disable_testchain :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => false
          end in
        fun op_star_o_p_t_star =>
          let cors_origins :=
            match op_star_o_p_t_star with
            | Some op_star_s_t_h_star => op_star_s_t_h_star
            | None => []
            end in
          fun op_star_o_p_t_star =>
            let cors_headers :=
              match op_star_o_p_t_star with
              | Some op_star_s_t_h_star => op_star_s_t_h_star
              | None => []
              end in
            fun rpc_tls =>
              fun log_output =>
                fun bootstrap_threshold =>
                  fun history_mode =>
                    fun cfg =>
                      let data_dir :=
                        Tezos_base__TzPervasives.Option.unopt (data_dir cfg)
                          data_dir in
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Node_data_version.ensure_data_dir None data_dir)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            let peer_table_size :=
                              Tezos_base__TzPervasives.Option.map
                                (fun i => (i, (Z.mul (Z.div i 4) 3)))
                                peer_table_size in
                            let unopt_list {A : Type}
                              (default : list A) (function_parameter : list A)
                              : list A :=
                              match function_parameter with
                              | [] => default
                              | l => l
                              end in
                            let limits := record in
                            let p2p : p2p :=
                              {|
                                expected_pow :=
                                  Tezos_base__TzPervasives.Option.unopt
                                    (expected_pow (p2p cfg)) expected_pow;
                                bootstrap_peers :=
                                  Tezos_base__TzPervasives.Option.unopt
                                    (bootstrap_peers (p2p cfg)) bootstrap_peers;
                                listen_addr :=
                                  Tezos_base__TzPervasives.Option.first_some
                                    listen_addr (listen_addr (p2p cfg));
                                discovery_addr :=
                                  Tezos_base__TzPervasives.Option.first_some
                                    discovery_addr (discovery_addr (p2p cfg));
                                private_mode :=
                                  orb (private_mode (p2p cfg)) private_mode;
                                limits := limits;
                                disable_mempool :=
                                  orb (disable_mempool (p2p cfg))
                                    disable_mempool;
                                disable_testchain :=
                                  orb (disable_testchain (p2p cfg))
                                    disable_testchain;
                                greylisting_config :=
                                  greylisting_config (p2p cfg) |}
                            with rpc : rpc :=
                              {|
                                listen_addrs :=
                                  unopt_list (listen_addrs (rpc cfg))
                                    rpc_listen_addrs;
                                cors_origins :=
                                  unopt_list (cors_origins (rpc cfg))
                                    cors_origins;
                                cors_headers :=
                                  unopt_list (cors_headers (rpc cfg))
                                    cors_headers;
                                tls :=
                                  Tezos_base__TzPervasives.Option.first_some
                                    rpc_tls (tls (rpc cfg)) |}
                            with log
                              : Tezos_stdlib_unix.Lwt_log_sink_unix.cfg :=
                              record
                            with shell : shell :=
                              {|
                                block_validator_limits :=
                                  block_validator_limits (shell cfg);
                                prevalidator_limits :=
                                  prevalidator_limits (shell cfg);
                                peer_validator_limits :=
                                  peer_validator_limits (shell cfg);
                                chain_validator_limits :=
                                  Tezos_base__TzPervasives.Option.unopt_map
                                    (fun bootstrap_threshold => record)
                                    (chain_validator_limits (shell cfg))
                                    bootstrap_threshold;
                                history_mode :=
                                  Tezos_base__TzPervasives.Option.first_some
                                    history_mode (history_mode (shell cfg)) |}
                              in
                            let internal_events := internal_events cfg in
                            Tezos_base__TzPervasives._return
                              {| data_dir := data_dir; p2p := p2p; rpc := rpc;
                                log := log; internal_events := internal_events;
                                shell := shell |}
                          end).

Definition resolve_addr
  (default_addr : string) (default_port : option Z)
  (op_star_o_p_t_star : option bool)
  : string -> Lwt.t (list (Ipaddr.V6.t * Z)) :=
  let passive :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun peer =>
    match Tezos_base__TzPervasives.P2p_point.Id.parse_addr_port peer with
    | (addr, port) =>
      let node : string :=
        if orb (equiv_decb addr "" % string) (equiv_decb addr "_" % string) then
          default_addr
        else
          addr
      with service : string :=
        match (port, default_port) with
        | ("" % string, None) => OCaml.Stdlib.invalid_arg "" % string
        | ("" % string, Some default_port) =>
          OCaml.Stdlib.string_of_int default_port
        | (port, _) => port
        end in
      Tezos_stdlib_unix.Lwt_utils_unix.getaddrinfo passive node service
    end.

Definition resolve_addrs
  (default_addr : string) (default_port : option Z) (passive : option bool)
  (peers : list string) : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  Lwt_list.fold_left_s
    (fun a =>
      fun peer =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (resolve_addr default_addr default_port passive peer)
          (fun points =>
            Lwt._return (Tezos_base__TzPervasives.List.rev_append points a))) []
    peers.

Definition resolve_discovery_addrs (discovery_addr : string)
  : Lwt.t (list (Ipaddr.V4.t * Z)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (resolve_addr (Ipaddr.V4.to_string Ipaddr.V4.broadcast)
      (Some default_discovery_port) (Some true) discovery_addr)
    (fun addrs =>
      let fix to_ipv4 {A : Type}
        (acc : list (Ipaddr.V4.t * A)) (function_parameter :
        list (Ipaddr.V6.t * A)) : Lwt.t (list (Ipaddr.V4.t * A)) :=
        match function_parameter with
        | [] => Lwt._return (Tezos_base__TzPervasives.List.rev acc)
        | cons (ip, port) xs =>
          match Ipaddr.v4_of_v6 ip with
          | Some v => to_ipv4 (cons (v, port) acc) xs
          | None =>
            Stdlib.Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Warning: failed to convert " % string
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " to an ipv4 address" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Flush_newline
                        CamlinternalFormatBasics.End_of_format))))
                "Warning: failed to convert %S to an ipv4 address@." % string)
              (Ipaddr.V6.to_string ip);
            to_ipv4 acc xs
          end
        end in
      to_ipv4 [] addrs).

Definition resolve_listening_addrs (listen_addr : string)
  : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  resolve_addr "::" % string (Some default_p2p_port) (Some true) listen_addr.

Definition resolve_rpc_listening_addrs (listen_addr : string)
  : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  resolve_addr "::" % string (Some default_rpc_port) (Some true) listen_addr.

Definition resolve_bootstrap_addrs (peers : list string)
  : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  resolve_addrs "::" % string (Some default_p2p_port) None peers.

Definition check_listening_addrs (config : t) : Lwt.t unit :=
  match listen_addr (p2p config) with
  | None => Lwt.return_unit
  | Some addr =>
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq (resolve_listening_addrs addr)
            (fun function_parameter =>
              match function_parameter with
              | [] =>
                Stdlib.Format.eprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Warning: failed to resolve " % string
                      (CamlinternalFormatBasics.Caml_string
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))
                    "Warning: failed to resolve %S
@." % string) addr;
                Lwt.return_unit
              | cons _ _ => Lwt.return_unit
              end)
        end)
      (fun function_parameter =>
        match function_parameter with
        | OCaml.Invalid_argument msg =>
          Stdlib.Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Warning: failed to parse " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal ":   " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))))
              "Warning: failed to parse %S:   %s
@." % string) addr msg;
          Lwt.return_unit
        | exn => Lwt.fail exn
        end)
  end.

Definition check_discovery_addr (config : t) : Lwt.t unit :=
  match discovery_addr (p2p config) with
  | None => Lwt.return_unit
  | Some addr =>
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq (resolve_discovery_addrs addr)
            (fun function_parameter =>
              match function_parameter with
              | [] =>
                Stdlib.Format.eprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Warning: failed to resolve " % string
                      (CamlinternalFormatBasics.Caml_string
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))
                    "Warning: failed to resolve %S
@." % string) addr;
                Lwt.return_unit
              | cons _ _ => Lwt.return_unit
              end)
        end)
      (fun function_parameter =>
        match function_parameter with
        | OCaml.Invalid_argument msg =>
          Stdlib.Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Warning: failed to parse " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal ":   " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))))
              "Warning: failed to parse %S:   %s
@." % string) addr msg;
          Lwt.return_unit
        | exn => Lwt.fail exn
        end)
  end.

Definition check_rpc_listening_addr (config : t) : Lwt.t unit :=
  Lwt_list.iter_p
    (fun addr =>
      Lwt.catch
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (resolve_rpc_listening_addrs addr)
              (fun function_parameter =>
                match function_parameter with
                | [] =>
                  Stdlib.Format.eprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Warning: failed to resolve " % string
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal "010" % char
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              CamlinternalFormatBasics.End_of_format))))
                      "Warning: failed to resolve %S
@." % string) addr;
                  Lwt.return_unit
                | cons _ _ => Lwt.return_unit
                end)
          end)
        (fun function_parameter =>
          match function_parameter with
          | OCaml.Invalid_argument msg =>
            Stdlib.Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Warning: failed to parse " % string
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal ":   " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))))
                "Warning: failed to parse %S:   %s
@." % string) addr msg;
            Lwt.return_unit
          | exn => Lwt.fail exn
          end)) (listen_addrs (rpc config)).

Definition check_bootstrap_peer (addr : string) : Lwt.t unit :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (resolve_bootstrap_addrs (cons addr []))
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              Stdlib.Format.eprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Warning: cannot resolve " % string
                    (CamlinternalFormatBasics.Caml_string
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))
                  "Warning: cannot resolve %S
@." % string) addr;
              Lwt.return_unit
            | cons _ _ => Lwt.return_unit
            end)
      end)
    (fun function_parameter =>
      match function_parameter with
      | OCaml.Invalid_argument msg =>
        Stdlib.Format.eprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Warning: failed to parse " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal ":   " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal "010" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Flush_newline
                        CamlinternalFormatBasics.End_of_format))))))
            "Warning: failed to parse %S:   %s
@." % string) addr msg;
        Lwt.return_unit
      | exn => Lwt.fail exn
      end).

Definition check_bootstrap_peers (config : t) : Lwt.t unit :=
  Lwt_list.iter_p check_bootstrap_peer (bootstrap_peers (p2p config)).

Definition fail {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Stdlib.Format.kasprintf
    (fun s =>
      OCaml.Stdlib.prerr_endline s;
      Stdlib.exit 1) fmt.

Definition check_connections (config : t) : unit :=
  if
    OCaml.Stdlib.gt (min_connections (limits (p2p config)))
      (expected_connections (limits (p2p config))) then
    fail
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Error: The minumum number of connections is greater than the expected number of connections"
            % string CamlinternalFormatBasics.End_of_format)
        "Error: The minumum number of connections is greater than the expected number of connections"
          % string) (min_connections (limits (p2p config)))
      (expected_connections (limits (p2p config)))
  else
    tt;
  if
    OCaml.Stdlib.gt (expected_connections (limits (p2p config)))
      (max_connections (limits (p2p config))) then
    fail
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Error: The expected number of connections is greater than the maximum number of connections"
            % string CamlinternalFormatBasics.End_of_format)
        "Error: The expected number of connections is greater than the maximum number of connections"
          % string) (expected_connections (limits (p2p config)))
      (max_connections (limits (p2p config)))
  else
    tt;
  match max_known_peer_ids (limits (p2p config)) with
  | None => tt
  | Some (max_known_peer_ids, target_known_peer_ids) =>
    if OCaml.Stdlib.gt target_known_peer_ids max_known_peer_ids then
      fail
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Error: The target number of known peer ids is greater than the maximum number of known peer ids."
              % string CamlinternalFormatBasics.End_of_format)
          "Error: The target number of known peer ids is greater than the maximum number of known peer ids."
            % string) target_known_peer_ids max_known_peer_ids
    else
      tt;
    if
      OCaml.Stdlib.gt (max_connections (limits (p2p config)))
        target_known_peer_ids then
      fail
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Error: The target number of known peer ids is lower than the maximum number of connections."
              % string CamlinternalFormatBasics.End_of_format)
          "Error: The target number of known peer ids is lower than the maximum number of connections."
            % string) target_known_peer_ids max_known_peer_ids
    else
      tt
  end;
  match max_known_points (limits (p2p config)) with
  | None => tt
  | Some (max_known_points, target_known_points) =>
    if OCaml.Stdlib.gt target_known_points max_known_points then
      fail
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Error: The target number of known points is greater than the maximum number of known points."
              % string CamlinternalFormatBasics.End_of_format)
          "Error: The target number of known points is greater than the maximum number of known points."
            % string) target_known_points max_known_points
    else
      tt;
    if
      OCaml.Stdlib.gt (max_connections (limits (p2p config)))
        target_known_points then
      fail
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Error: The target number of known points is lower than the maximum number of connections."
              % string CamlinternalFormatBasics.End_of_format)
          "Error: The target number of known points is lower than the maximum number of connections."
            % string) target_known_points max_known_points
    else
      tt
  end.

Definition check (config : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq (check_listening_addrs config)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq (check_rpc_listening_addr config)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq (check_discovery_addr config)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (check_bootstrap_peers config)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          check_connections config;
                          Lwt.return_unit
                        end)
                  end)
            end)
      end).
src/bin_node/node_config_file.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

type t = {
  data_dir : string;
  p2p : p2p;
  rpc : rpc;
  log : Lwt_log_sink_unix.cfg;
  internal_events : Internal_event_unix.Configuration.t;
  shell : shell;
}

and p2p = {
  expected_pow : float;
  bootstrap_peers : string list;
  listen_addr : string option;
  discovery_addr : string option;
  private_mode : bool;
  limits : P2p.limits;
  disable_mempool : bool;
  disable_testchain : bool;
  greylisting_config : P2p_point_state.Info.greylisting_config;
}

and rpc = {
  listen_addrs : string list;
  cors_origins : string list;
  cors_headers : string list;
  tls : tls option;
}

and tls = {cert : string; key : string}

and shell = {
  block_validator_limits : Node.block_validator_limits;
  prevalidator_limits : Node.prevalidator_limits;
  peer_validator_limits : Node.peer_validator_limits;
  chain_validator_limits : Node.chain_validator_limits;
  history_mode : History_mode.t option;
}

val default_data_dir : string

val default_p2p_port : int

val default_rpc_port : int

val default_p2p : p2p

val default_config : t

val update :
  ?data_dir:string ->
  ?min_connections:int ->
  ?expected_connections:int ->
  ?max_connections:int ->
  ?max_download_speed:int ->
  ?max_upload_speed:int ->
  ?binary_chunks_size:int ->
  ?peer_table_size:int ->
  ?expected_pow:float ->
  ?bootstrap_peers:string list ->
  ?listen_addr:string ->
  ?discovery_addr:string ->
  ?rpc_listen_addrs:string list ->
  ?private_mode:bool ->
  ?disable_mempool:bool ->
  ?disable_testchain:bool ->
  ?cors_origins:string list ->
  ?cors_headers:string list ->
  ?rpc_tls:tls ->
  ?log_output:Lwt_log_sink_unix.Output.t ->
  ?bootstrap_threshold:int ->
  ?history_mode:History_mode.t ->
  t ->
  t tzresult Lwt.t

val to_string : t -> string

val read : string -> t tzresult Lwt.t

val write : string -> t -> unit tzresult Lwt.t

val resolve_listening_addrs : string -> (P2p_addr.t * int) list Lwt.t

val resolve_discovery_addrs : string -> (Ipaddr.V4.t * int) list Lwt.t

val resolve_rpc_listening_addrs : string -> (P2p_addr.t * int) list Lwt.t

val resolve_bootstrap_addrs : string list -> (P2p_addr.t * int) list Lwt.t

val encoding : t Data_encoding.t

val check : t -> unit Lwt.t
src/bin_node/node_config_file.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

attribute

.

Parameter default_data_dir : string.

Parameter default_p2p_port : Z.

Parameter default_rpc_port : Z.

Parameter default_p2p : p2p.

Parameter default_config : t.

Parameter update :
(option string) ->
  (option Z) ->
    (option Z) ->
      (option Z) ->
        (option Z) ->
          (option Z) ->
            (option Z) ->
              (option Z) ->
                (option float) ->
                  (option (list string)) ->
                    (option string) ->
                      (option string) ->
                        (option (list string)) ->
                          (option bool) ->
                            (option bool) ->
                              (option bool) ->
                                (option (list string)) ->
                                  (option (list string)) ->
                                    (option tls) ->
                                      (option
                                        Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t)
                                        ->
                                        (option Z) ->
                                          (option
                                            Tezos_shell_services.History_mode.t)
                                            ->
                                            t ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  t).

Parameter to_string : t -> string.

Parameter read : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter write : string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter resolve_listening_addrs :
string -> Lwt.t (list (Tezos_base__TzPervasives.P2p_addr.t * Z)).

Parameter resolve_discovery_addrs : string -> Lwt.t (list (Ipaddr.V4.t * Z)).

Parameter resolve_rpc_listening_addrs :
string -> Lwt.t (list (Tezos_base__TzPervasives.P2p_addr.t * Z)).

Parameter resolve_bootstrap_addrs :
(list string) -> Lwt.t (list (Tezos_base__TzPervasives.P2p_addr.t * Z)).

Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.

Parameter check : t -> Lwt.t unit.
src/bin_node/node_data_version.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

type t = string

(* Data_version hitory:
 *  - 0.0.1 : original storage
 *  - 0.0.2 : never released
 *  - 0.0.3 : store upgrade (introducing history mode)
 *  - 0.0.4 : context upgrade (switching from LMDB to IRMIN v2) *)
let data_version = "0.0.4"

(* List of upgrade functions from each still supported previous
   version to the current [data_version] above. If this list grows too
   much, an idea would be to have triples (version, version,
   converter), and to sequence them dynamically instead of
   statically. *)
let upgradable_data_version = []

let store_dir data_dir = data_dir // "store"

let context_dir data_dir = data_dir // "context"

let protocol_dir data_dir = data_dir // "protocol"

let lock_file data_dir = data_dir // "lock"

let default_identity_file_name = "identity.json"

let default_peers_file_name = "peers.json"

let default_config_file_name = "config.json"

let version_file_name = "version.json"

let version_encoding = Data_encoding.(obj1 (req "version" string))

type error += Invalid_data_dir_version of t * t

type error += Invalid_data_dir of string

type error += No_data_dir_version_file of string

type error += Could_not_read_data_dir_version of string

type error += Data_dir_needs_upgrade of {expected : t; actual : t}

let () =
  register_error_kind
    `Permanent
    ~id:"invalidDataDir"
    ~title:"Invalid data directory"
    ~description:"The data directory cannot be accessed or created"
    ~pp:(fun ppf path ->
      Format.fprintf ppf "Invalid data directory '%s'." path)
    Data_encoding.(obj1 (req "datadir_path" string))
    (function Invalid_data_dir path -> Some path | _ -> None)
    (fun path -> Invalid_data_dir path) ;
  register_error_kind
    `Permanent
    ~id:"invalidDataDirVersion"
    ~title:"Invalid data directory version"
    ~description:"The data directory version was not the one that was expected"
    ~pp:(fun ppf (exp, got) ->
      Format.fprintf
        ppf
        "Invalid data directory version '%s' (expected '%s')."
        got
        exp)
    Data_encoding.(
      obj2 (req "expected_version" string) (req "actual_version" string))
    (function
      | Invalid_data_dir_version (expected, actual) ->
          Some (expected, actual)
      | _ ->
          None)
    (fun (expected, actual) -> Invalid_data_dir_version (expected, actual)) ;
  register_error_kind
    `Permanent
    ~id:"couldNotReadDataDirVersion"
    ~title:"Could not read data directory version file"
    ~description:"Data directory version file was invalid."
    Data_encoding.(obj1 (req "version_path" string))
    ~pp:(fun ppf path ->
      Format.fprintf
        ppf
        "Tried to read version file at '%s',  but the file could not be parsed."
        path)
    (function Could_not_read_data_dir_version path -> Some path | _ -> None)
    (fun path -> Could_not_read_data_dir_version path) ;
  register_error_kind
    `Permanent
    ~id:"noDataDirVersionFile"
    ~title:"Data directory version file does not exist"
    ~description:"Data directory version file does not exist"
    Data_encoding.(obj1 (req "version_path" string))
    ~pp:(fun ppf path ->
      Format.fprintf
        ppf
        "Expected to find data directory version file at '%s',  but the file \
         does not exist."
        path)
    (function No_data_dir_version_file path -> Some path | _ -> None)
    (fun path -> No_data_dir_version_file path) ;
  register_error_kind
    `Permanent
    ~id:"dataDirNeedsUpgrade"
    ~title:"The data directory needs to be upgraded"
    ~description:"The data directory needs to be upgraded"
    ~pp:(fun ppf (exp, got) ->
      Format.fprintf
        ppf
        "The data directory version is too old.@,\
         Found '%s', expected '%s'.@,\
         It needs to be upgraded with `tezos-node upgrade_storage`."
        got
        exp)
    Data_encoding.(
      obj2 (req "expected_version" string) (req "actual_version" string))
    (function
      | Data_dir_needs_upgrade {expected; actual} ->
          Some (expected, actual)
      | _ ->
          None)
    (fun (expected, actual) -> Data_dir_needs_upgrade {expected; actual})

let version_file data_dir = Filename.concat data_dir version_file_name

let check_data_dir_version data_dir =
  let version_file = version_file data_dir in
  Lwt_unix.file_exists version_file
  >>= fun ex ->
  fail_unless ex (No_data_dir_version_file version_file)
  >>=? fun () ->
  Lwt_utils_unix.Json.read_file version_file
  |> trace (Could_not_read_data_dir_version version_file)
  >>=? fun json ->
  ( try return (Data_encoding.Json.destruct version_encoding json)
    with
    | Data_encoding.Json.Cannot_destruct _
    | Data_encoding.Json.Unexpected _
    | Data_encoding.Json.No_case_matched _
    | Data_encoding.Json.Bad_array_size _
    | Data_encoding.Json.Missing_field _
    | Data_encoding.Json.Unexpected_field _
    ->
      fail (Could_not_read_data_dir_version version_file) )
  >>=? fun version ->
  if String.equal version data_version then return_none
  else
    match
      List.find_opt
        (fun (v, _) -> String.equal v version)
        upgradable_data_version
    with
    | Some f ->
        return_some f
    | None ->
        fail (Invalid_data_dir_version (data_version, version))

let write_version data_dir =
  Lwt_utils_unix.Json.write_file
    (version_file data_dir)
    (Data_encoding.Json.construct version_encoding data_version)

let ensure_data_dir bare data_dir =
  let write_version () = write_version data_dir >>=? fun () -> return_none in
  Lwt.catch
    (fun () ->
      Lwt_unix.file_exists data_dir
      >>= function
      | true -> (
          Lwt_stream.to_list (Lwt_unix.files_of_directory data_dir)
          >|= List.filter (fun s ->
                  s <> "." && s <> ".." && s <> version_file_name
                  && s <> default_identity_file_name
                  && s <> default_config_file_name
                  && s <> default_peers_file_name)
          >>= function
          | [] ->
              write_version ()
          | files when bare ->
              let to_delete =
                Format.asprintf
                  "@[<v>%a@]"
                  (Format.pp_print_list
                     ~pp_sep:Format.pp_print_cut
                     Format.pp_print_string)
                  files
              in
              fail
                (Invalid_data_dir
                   (Format.asprintf
                      "Please provide a clean directory by deleting:@ %s"
                      to_delete))
          | _ ->
              check_data_dir_version data_dir )
      | false ->
          Lwt_utils_unix.create_dir ~perm:0o700 data_dir
          >>= fun () -> write_version ())
    (function
      | Unix.Unix_error _ ->
          fail (Invalid_data_dir data_dir)
      | exc ->
          raise exc)

let ensure_data_dir ?(bare = false) data_dir =
  ensure_data_dir bare data_dir
  >>=? function
  | None ->
      return_unit
  | Some (version, _) ->
      fail (Data_dir_needs_upgrade {expected = data_version; actual = version})
src/bin_node/node_data_version.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition t := string.

Definition data_version : string := "0.0.4" % string.

Definition upgradable_data_version {A : Type} : list A := [].

Definition store_dir (data_dir : string) : string :=
  op_div_div data_dir "store" % string.

Definition context_dir (data_dir : string) : string :=
  op_div_div data_dir "context" % string.

Definition protocol_dir (data_dir : string) : string :=
  op_div_div data_dir "protocol" % string.

Definition lock_file (data_dir : string) : string :=
  op_div_div data_dir "lock" % string.

Definition default_identity_file_name : string := "identity.json" % string.

Definition default_peers_file_name : string := "peers.json" % string.

Definition default_config_file_name : string := "config.json" % string.

Definition version_file_name : string := "version.json" % string.

Definition version_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding string :=
  Tezos_base__TzPervasives.Data_encoding.obj1
    (Tezos_base__TzPervasives.Data_encoding.req None None "version" % string
      Tezos_base__TzPervasives.Data_encoding.string).

Definition version_file (data_dir : string) : string :=
  Stdlib.Filename.concat data_dir version_file_name.

Definition check_data_dir_version {A : Type} (data_dir : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option (Tezos_base__TzPervasives.String.t * A))) :=
  let version_file := version_file data_dir in
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.file_exists version_file)
    (fun ex =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_base__TzPervasives.fail_unless ex
          (No_data_dir_version_file version_file))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (OCaml.Stdlib.reverse_apply
                (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file version_file)
                (Tezos_base__TzPervasives.trace
                  (Could_not_read_data_dir_version version_file)))
              (fun json =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question try
                  (fun version =>
                    if
                      Tezos_base__TzPervasives.String.equal version data_version
                      then
                      Tezos_base__TzPervasives.return_none
                    else
                      match
                        Tezos_base__TzPervasives.List.find_opt
                          (fun function_parameter =>
                            match function_parameter with
                            | (v, _) =>
                              Tezos_base__TzPervasives.String.equal v version
                            end) upgradable_data_version with
                      | Some f => Tezos_base__TzPervasives.return_some f
                      | None =>
                        Tezos_base__TzPervasives.fail
                          (Invalid_data_dir_version data_version version)
                      end))
          end)).

Definition write_version (data_dir : string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file (version_file data_dir)
    (Tezos_base__TzPervasives.Data_encoding.Json.construct version_encoding
      data_version).

Definition ensure_data_dir {A : Type} (bare : bool) (data_dir : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option (Tezos_base__TzPervasives.String.t * A))) :=
  let write_version {B : Type} (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (option B)) :=
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question (write_version data_dir)
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_base__TzPervasives.return_none
          end)
    end in
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.file_exists data_dir)
          (fun function_parameter =>
            match function_parameter with
            | true =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_base__TzPervasives.op_gt_pipe_eq
                  (Lwt_stream.to_list (Lwt_unix.files_of_directory data_dir))
                  (Tezos_base__TzPervasives.List.filter
                    (fun s =>
                      andb (nequiv_decb s "." % string)
                        (andb (nequiv_decb s ".." % string)
                          (andb (nequiv_decb s version_file_name)
                            (andb (nequiv_decb s default_identity_file_name)
                              (andb (nequiv_decb s default_config_file_name)
                                (nequiv_decb s default_peers_file_name))))))))
                (fun function_parameter =>
                  match function_parameter with
                  | [] => write_version tt
                  | files =>
                    let to_delete :=
                      Stdlib.Format.asprintf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_box
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<v>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<v>" % string))
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))
                          "@[<v>%a@]" % string)
                        (Stdlib.Format.pp_print_list
                          (Some Stdlib.Format.pp_print_cut)
                          Stdlib.Format.pp_print_string) files in
                    Tezos_base__TzPervasives.fail
                      (Invalid_data_dir
                        (Stdlib.Format.asprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Please provide a clean directory by deleting:" %
                                string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.End_of_format)))
                            "Please provide a clean directory by deleting:@ %s"
                              % string) to_delete))
                  | _ => check_data_dir_version data_dir
                  end)
            | false =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_stdlib_unix.Lwt_utils_unix.create_dir (Some 448) data_dir)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => write_version tt
                  end)
            end)
      end)
    (fun function_parameter =>
      match function_parameter with
      | Unix.Unix_error _ _ _ =>
        Tezos_base__TzPervasives.fail (Invalid_data_dir data_dir)
      | exc => Stdlib.raise exc
      end).

Definition ensure_data_dir (op_star_o_p_t_star : option bool)
  : string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let bare :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun data_dir =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (ensure_data_dir bare data_dir)
      (fun function_parameter =>
        match function_parameter with
        | None => Tezos_base__TzPervasives.return_unit
        | Some (version, _) =>
          Tezos_base__TzPervasives.fail
            (Data_dir_needs_upgrade
              {| expected := data_version; actual := version |})
        end).
src/bin_node/node_data_version.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The abstract type for data versions. *)
type t

(** Errors related to checks related to the data dir. *)

type error += Invalid_data_dir_version of t * t

type error += Could_not_read_data_dir_version of string

(** The current data version. *)

val data_version : t

(** Default file names to store the informations about the node's network
    identity, peers and configuration. *)

val default_identity_file_name : string

val default_config_file_name : string

val default_peers_file_name : string

(** [ensure_data_dir ~bare dir] performs a sanity check on [dir]. This check
    returns successfully if either:
    - [bare] is [false] (default) and [dir] contains a file that indicates the
      data serialization format equal to [data_version], or
    - [bare] is [true] and [dir] is empty (except for an [identity.json] file).
*)

val ensure_data_dir : ?bare:bool -> string -> unit tzresult Lwt.t

(** [store_dir dir] is a directory within [dir] that the node uses for its
    store. In order for [store_dir dir] to be valid, [dir] must be a valid
    directory name. *)

val store_dir : string -> string

(** [context_dir dir] is a directory within [dir] that the node uses for its
    context. In order for [context_dir dir] to be valid, [dir] must be a valid
    directory name. *)

val context_dir : string -> string

(** [protocol_dir dir] is a directory within [dir] that the node uses for its
    protocol. In order for [protocol_dir dir] to be valid, [dir] must be a valid
    directory name. *)

val protocol_dir : string -> string

(** [lock_file dir] is a file within [dir] that the node uses for its lock. In
    order for [lock_file dir] to be valid, [dir] must be a valid directory name.
*)

val lock_file : string -> string
src/bin_node/node_data_version.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

extensible_type

extensible_type

Parameter data_version : t.

Parameter default_identity_file_name : string.

Parameter default_config_file_name : string.

Parameter default_peers_file_name : string.

Parameter ensure_data_dir :
(option bool) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter store_dir : string -> string.

Parameter context_dir : string -> string.

Parameter protocol_dir : string -> string.

Parameter lock_file : string -> string.
src/bin_node/node_identity_command.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

(** Commands *)

let identity_file data_dir =
  data_dir // Node_data_version.default_identity_file_name

let show {Node_config_file.data_dir; _} =
  Node_identity_file.read (identity_file data_dir)
  >>=? fun id ->
  Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ;
  return_unit

let generate_with_animation ppf target =
  let duration = 1200 / Animation.number_of_frames in
  Animation.make_with_animation
    ppf
    ~make:(fun count ->
      try Ok (P2p_identity.generate_with_bound ~max:count target)
      with Not_found -> Error count)
    ~on_retry:(fun time count ->
      let ms = int_of_float (Mtime.Span.to_ms time) in
      if ms <= 1 then max 10 (count * 10) else count * duration / ms)
    10000

let generate {Node_config_file.data_dir; p2p; _} =
  let identity_file = identity_file data_dir in
  if Sys.file_exists identity_file then
    fail (Node_identity_file.Existent_identity_file identity_file)
  else
    let target = Crypto_box.make_target p2p.expected_pow in
    Format.eprintf
      "Generating a new identity... (level: %.2f) "
      p2p.expected_pow ;
    let id = generate_with_animation Format.err_formatter target in
    Node_identity_file.write identity_file id
    >>=? fun () ->
    Format.eprintf
      "Stored the new identity (%a) into '%s'.@."
      P2p_peer.Id.pp
      id.peer_id
      identity_file ;
    return_unit

let check {Node_config_file.data_dir; p2p = {expected_pow; _}; _} =
  Node_identity_file.read ~expected_pow (identity_file data_dir)
  >>=? fun id ->
  Format.printf
    "Peer_id: %a. Proof of work is higher than %.2f.@."
    P2p_peer.Id.pp
    id.peer_id
    expected_pow ;
  return_unit

(** Main *)

module Term = struct
  type subcommand = Show | Generate | Check

  let process subcommand data_dir config_file expected_pow =
    let res =
      ( match (data_dir, config_file) with
      | (None, None) ->
          let default_config =
            Node_config_file.default_data_dir
            // Node_data_version.default_config_file_name
          in
          if Sys.file_exists default_config then
            Node_config_file.read default_config
          else return Node_config_file.default_config
      | (None, Some config_file) ->
          Node_config_file.read config_file
      | (Some data_dir, None) ->
          Node_config_file.read
            (data_dir // Node_data_version.default_config_file_name)
          >>=? fun cfg -> return {cfg with data_dir}
      | (Some data_dir, Some config_file) ->
          Node_config_file.read config_file
          >>=? fun cfg -> return {cfg with data_dir} )
      >>=? fun cfg ->
      Node_config_file.update ?expected_pow cfg
      >>=? fun cfg ->
      match subcommand with
      | Show ->
          show cfg
      | Generate ->
          generate cfg
      | Check ->
          check cfg
    in
    match Lwt_main.run res with
    | Ok () ->
        `Ok ()
    | Error err ->
        `Error (false, Format.asprintf "%a" pp_print_error err)

  let subcommand_arg =
    let parser = function
      | "show" ->
          `Ok Show
      | "generate" ->
          `Ok Generate
      | "check" ->
          `Ok Check
      | s ->
          `Error ("invalid argument: " ^ s)
    and printer fmt = function
      | Show ->
          Format.fprintf fmt "show"
      | Generate ->
          Format.fprintf fmt "generate"
      | Check ->
          Format.fprintf fmt "check"
    in
    let doc =
      "Operation to perform. Possible values: $(b,show), $(b,generate), \
       $(b,check)."
    in
    let open Cmdliner.Arg in
    value & pos 0 (parser, printer) Show & info [] ~docv:"OPERATION" ~doc

  let expected_pow =
    let open Cmdliner in
    let doc =
      "Expected amount of proof-of-work for the node identity. The optional \
       parameter should be a float between 0 and 256, where\n\
      \       0 disables the proof-of-work mechanism."
    in
    Arg.(value & pos 1 (some float) None & info [] ~docv:"DIFFICULTY" ~doc)

  let term =
    Cmdliner.Term.(
      ret
        ( const process $ subcommand_arg $ Node_shared_arg.Term.data_dir
        $ Node_shared_arg.Term.config_file $ expected_pow ))
end

module Manpage = struct
  let command_description =
    "The $(b,identity) command is meant to create and manage node identities. \
     An $(i,identity) uniquely identifies a peer on the network and consists \
     of a cryptographic key pair as well as a proof-of-work stamp that \
     certifies that enough CPU time has been dedicated to produce the \
     identity, to avoid sybil attacks. An identity with enough proof-of-work \
     is required to participate in the Tezos network, therefore this command \
     is necessary to launch Tezos the first time."

  let description =
    [ `S "DESCRIPTION";
      `P (command_description ^ " Several options are possible:");
      `P
        "$(b,show) reads, parses and displays the current identity of the \
         node. Use this command to see what identity will be used by Tezos. \
         This is the default operation.";
      `P
        "$(b,generate [difficulty]) generates an identity whose proof of work \
         stamp difficulty is at least equal to $(i,difficulty). The value \
         provided must be a floating point number between 0 and 256. It \
         roughly reflects the numbers of expected leading zeroes in the hash \
         of the identity data-structure. Therefore, a value of 0 means no \
         proof-of-work, and the difficulty doubles for each increment of 1 in \
         the difficulty value.";
      `P
        "$(b,check [difficulty]) checks that an identity is valid and that \
         its proof of work stamp difficulty is at least equal to \
         $(i,difficulty)." ]

  let man = description @ (* [ `S misc_docs ] @ *)
                          Node_shared_arg.Manpage.bugs

  let info = Cmdliner.Term.info ~doc:"Manage node identities" ~man "identity"
end

let cmd = (Term.term, Manpage.info)
src/bin_node/node_identity_command.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition identity_file (data_dir : string) : string :=
  op_div_div data_dir Node_data_version.default_identity_file_name.

Definition show (function_parameter : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| Node_config_file.data_dir := data_dir |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Node_identity_file.read None (identity_file data_dir))
      (fun id =>
        Stdlib.Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Peer_id: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Flush_newline
                    CamlinternalFormatBasics.End_of_format))))
            "Peer_id: %a.@." % string) Tezos_base__TzPervasives.P2p_peer.Id.pp
          (peer_id id);
        Tezos_base__TzPervasives.return_unit)
  end.

Definition generate_with_animation
  (ppf : Stdlib.Format.formatter) (target : Tezos_crypto.Crypto_box.target)
  : Tezos_base__TzPervasives.P2p_identity.t :=
  let duration := Z.div 1200 Tezos_stdlib_unix.Animation.number_of_frames in
  Tezos_stdlib_unix.Animation.make_with_animation ppf (fun count => try)
    (fun time =>
      fun count =>
        let ms := Stdlib.int_of_float (Mtime.Span.to_ms time) in
        if OCaml.Stdlib.le ms 1 then
          OCaml.Stdlib.max 10 (Z.mul count 10)
        else
          Z.div (Z.mul count duration) ms) 10000.

Definition generate (function_parameter : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| Node_config_file.data_dir := data_dir; Node_config_file.p2p := p2p |} =>
    let identity_file := identity_file data_dir in
    if Stdlib.Sys.file_exists identity_file then
      Tezos_base__TzPervasives.fail
        (Node_identity_file.Existent_identity_file identity_file)
    else
      let target :=
        Tezos_base__TzPervasives.Crypto_box.make_target (expected_pow p2p) in
      Stdlib.Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Generating a new identity... (level: " % string
            (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Lit_precision 2)
              (CamlinternalFormatBasics.String_literal ") " % string
                CamlinternalFormatBasics.End_of_format)))
          "Generating a new identity... (level: %.2f) " % string)
        (expected_pow p2p);
      let id := generate_with_animation Stdlib.Format.err_formatter target in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Node_identity_file.write identity_file id)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Stdlib.Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Stored the new identity (" % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ") into '" % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal "'." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))))
                "Stored the new identity (%a) into '%s'.@." % string)
              Tezos_base__TzPervasives.P2p_peer.Id.pp (peer_id id) identity_file;
            Tezos_base__TzPervasives.return_unit
          end)
  end.

Definition check (function_parameter : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {|
    Node_config_file.data_dir := data_dir;
      Node_config_file.p2p := {| expected_pow := expected_pow |}
      |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Node_identity_file.read (Some expected_pow) (identity_file data_dir))
      (fun id =>
        Stdlib.Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Peer_id: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  ". Proof of work is higher than " % string
                  (CamlinternalFormatBasics.Float
                    CamlinternalFormatBasics.Float_f
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Lit_precision 2)
                    (CamlinternalFormatBasics.Char_literal "." % char
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Flush_newline
                        CamlinternalFormatBasics.End_of_format))))))
            "Peer_id: %a. Proof of work is higher than %.2f.@." % string)
          Tezos_base__TzPervasives.P2p_peer.Id.pp (peer_id id) expected_pow;
        Tezos_base__TzPervasives.return_unit)
  end.

Module Term.
  Inductive subcommand : Type :=
  | Show : subcommand
  | Generate : subcommand
  | Check : subcommand.
  
  Definition process
    (subcommand : subcommand) (data_dir : option string)
    (config_file : option string) (expected_pow : option float) : variant :=
    let res :=
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        match (data_dir, config_file) with
        | (None, None) =>
          let default_config :=
            op_div_div Node_config_file.default_data_dir
              Node_data_version.default_config_file_name in
          if Stdlib.Sys.file_exists default_config then
            Node_config_file.read default_config
          else
            Tezos_base__TzPervasives._return Node_config_file.default_config
        | (None, Some config_file) => Node_config_file.read config_file
        | (Some data_dir, None) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Node_config_file.read
              (op_div_div data_dir Node_data_version.default_config_file_name))
            (fun cfg => Tezos_base__TzPervasives._return record)
        | (Some data_dir, Some config_file) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Node_config_file.read config_file)
            (fun cfg => Tezos_base__TzPervasives._return record)
        end
        (fun cfg =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Node_config_file.update None None None None None None None None
              expected_pow None None None None None None None None None None
              None None None cfg)
            (fun cfg =>
              match subcommand with
              | Show => show cfg
              | Generate => generate cfg
              | Check => check cfg
              end)) in
    match Lwt_main.run res with
    | inl tt => variant
    | inr err => variant
    end.
  
  Definition subcommand_arg : Cmdliner.Term.t subcommand :=
    let parser (function_parameter : string) : variant :=
      match function_parameter with
      | "show" % string => variant
      | "generate" % string => variant
      | "check" % string => variant
      | s => variant
      end
    with printer
      (fmt : Stdlib.Format.formatter) (function_parameter : subcommand)
      : unit :=
      match function_parameter with
      | Show =>
        Stdlib.Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "show" % string
              CamlinternalFormatBasics.End_of_format) "show" % string)
      | Generate =>
        Stdlib.Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "generate" % string
              CamlinternalFormatBasics.End_of_format) "generate" % string)
      | Check =>
        Stdlib.Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "check" % string
              CamlinternalFormatBasics.End_of_format) "check" % string)
      end in
    let doc :=
      "Operation to perform. Possible values: $(b,show), $(b,generate), $(b,check)."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and (Cmdliner.Arg.pos None 0 (parser, printer) Show)
        (Cmdliner.Arg.info None (Some "OPERATION" % string) (Some doc) None [])).
  
  Definition expected_pow : Cmdliner.Term.t (option float) :=
    let doc :=
      "Expected amount of proof-of-work for the node identity. The optional parameter should be a float between 0 and 256, where
       0 disables the proof-of-work mechanism."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.pos None 1 (Cmdliner.Arg.some None Cmdliner.Arg.float)
          None)
        (Cmdliner.Arg.info None (Some "DIFFICULTY" % string) (Some doc) None [])).
  
  Definition term : Cmdliner.Term.t unit :=
    Cmdliner.Term.ret
      (Cmdliner.Term.op_dollar
        (Cmdliner.Term.op_dollar
          (Cmdliner.Term.op_dollar
            (Cmdliner.Term.op_dollar (Cmdliner.Term.const process)
              subcommand_arg) Node_shared_arg.Term.data_dir)
          Node_shared_arg.Term.config_file) expected_pow).
End Term.

Module Manpage.
  Definition command_description : string :=
    "The $(b,identity) command is meant to create and manage node identities. An $(i,identity) uniquely identifies a peer on the network and consists of a cryptographic key pair as well as a proof-of-work stamp that certifies that enough CPU time has been dedicated to produce the identity, to avoid sybil attacks. An identity with enough proof-of-work is required to participate in the Tezos network, therefore this command is necessary to launch Tezos the first time."
      % string.
  
  Definition description : list variant :=
    cons variant (cons variant (cons variant (cons variant (cons variant [])))).
  
  Definition man : list Cmdliner.Manpage.block :=
    OCaml.Stdlib.app description Node_shared_arg.Manpage.bugs.
  
  Definition info : Cmdliner.Term.info :=
    Cmdliner.Term.info None (Some man) None None None None
      (Some "Manage node identities" % string) None "identity" % string.
End Manpage.

Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
  (Term.term, Manpage.info).
src/bin_node/node_identity_command.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val cmd : unit Cmdliner.Term.t * Cmdliner.Term.info

module Manpage : sig
  val command_description : string
end
src/bin_node/node_identity_command.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info.

Module Manpage.
  Parameter command_description : string.
End Manpage.
src/bin_node/node_identity_file.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += No_identity_file of string

type error += Insufficient_proof_of_work of {expected : float}

type error +=
  | Identity_mismatch of {
      filename : string;
      peer_id : Crypto_box.Public_key_hash.t;
    }

type error +=
  | Identity_keys_mismatch of {
      filename : string;
      expected_key : Crypto_box.public_key;
    }

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.no_file"
    ~title:"No identity file"
    ~description:"The node identity file cannot be found"
    ~pp:(fun ppf file ->
      Format.fprintf
        ppf
        "Cannot read the identity file: `%s`. See `%s identity --help` on how \
         to generate an identity."
        file
        Sys.argv.(0))
    Data_encoding.(obj1 (req "file" string))
    (function No_identity_file file -> Some file | _ -> None)
    (fun file -> No_identity_file file)

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.insufficient_proof_of_work"
    ~title:"Insufficient proof of work"
    ~description:
      "The proof of work embeded by the current identity is not sufficient"
    ~pp:(fun ppf expected ->
      Format.fprintf
        ppf
        "The current identity does not embed a sufficient stamp of \
         proof-of-work. (expected level: %.2f). See `%s identity --help` on \
         how to generate a new identity."
        expected
        Sys.argv.(0))
    Data_encoding.(obj1 (req "expected" float))
    (function
      | Insufficient_proof_of_work {expected} -> Some expected | _ -> None)
    (fun expected -> Insufficient_proof_of_work {expected})

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.identity_mismatch"
    ~title:"Identity mismatch"
    ~description:
      "The identity (public key hash) does not match the keys provided with it"
    ~pp:(fun ppf (file, public_key_hash) ->
      Format.fprintf
        ppf
        "The current identity (public key hash) does not match the keys in %s.\n\
        \           Expected identity %a."
        file
        Crypto_box.Public_key_hash.pp
        public_key_hash)
    Data_encoding.(
      obj2
        (req "file" string)
        (req "public_key_hash" Crypto_box.Public_key_hash.encoding))
    (function
      | Identity_mismatch {filename; peer_id} ->
          Some (filename, peer_id)
      | _ ->
          None)
    (fun (filename, peer_id) -> Identity_mismatch {filename; peer_id})

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.identity_keys_mismatch"
    ~title:"Identity keys mismatch"
    ~description:
      "The current identity file has non-matching keys (secret key/ public \
       key pair is not valid)"
    ~pp:(fun ppf (file, public_key) ->
      Format.fprintf
        ppf
        "The current identity file %s has non-matching keys (secret key/ \
         public key pair is not valid).\n\
        \           Expected public key %a."
        file
        Crypto_box.pp_pk
        public_key)
    Data_encoding.(
      obj2
        (req "file" string)
        (req "public_key" Crypto_box.public_key_encoding))
    (function
      | Identity_keys_mismatch {filename; expected_key} ->
          Some (filename, expected_key)
      | _ ->
          None)
    (fun (filename, expected_key) ->
      Identity_keys_mismatch {filename; expected_key})

let read ?expected_pow filename =
  Lwt_unix.file_exists filename
  >>= function
  | false ->
      fail (No_identity_file filename)
  | true -> (
      Lwt_utils_unix.Json.read_file filename
      >>=? fun json ->
      let id = Data_encoding.Json.destruct P2p_identity.encoding json in
      let pkh = Crypto_box.hash id.public_key in
      (* check public_key hash *)
      if not (Crypto_box.Public_key_hash.equal pkh id.peer_id) then
        fail (Identity_mismatch {filename; peer_id = pkh})
        (* check public/private keys correspondance *)
      else if not Crypto_box.(equal (neuterize id.secret_key) id.public_key)
      then
        fail (Identity_keys_mismatch {filename; expected_key = id.public_key})
      else
        (* check PoW level *)
        match expected_pow with
        | None ->
            return id
        | Some expected ->
            let target = Crypto_box.make_target expected in
            if
              not
                (Crypto_box.check_proof_of_work
                   id.public_key
                   id.proof_of_work_stamp
                   target)
            then fail (Insufficient_proof_of_work {expected})
            else return id )

type error += Existent_identity_file of string

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.existent_file"
    ~title:"Cannot overwrite identity file"
    ~description:"Cannot implicitely overwrite the current identity file"
    ~pp:(fun ppf file ->
      Format.fprintf
        ppf
        "Cannot implicitely overwrite the current identity file: '%s'. See \
         `%s identity --help` on how to generate a new identity."
        file
        Sys.argv.(0))
    Data_encoding.(obj1 (req "file" string))
    (function Existent_identity_file file -> Some file | _ -> None)
    (fun file -> Existent_identity_file file)

let write file identity =
  if Sys.file_exists file then fail (Existent_identity_file file)
  else
    Node_data_version.ensure_data_dir (Filename.dirname file)
    >>=? fun () ->
    Lwt_utils_unix.Json.write_file
      file
      (Data_encoding.Json.construct P2p_identity.encoding identity)
src/bin_node/node_identity_file.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition read (expected_pow : option float) (filename : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.P2p_identity.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.file_exists filename)
    (fun function_parameter =>
      match function_parameter with
      | false => Tezos_base__TzPervasives.fail (No_identity_file filename)
      | true =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file filename)
          (fun json =>
            let id :=
              Tezos_base__TzPervasives.Data_encoding.Json.destruct
                Tezos_base__TzPervasives.P2p_identity.encoding json in
            let pkh := Tezos_base__TzPervasives.Crypto_box.hash (public_key id)
              in
            if
              negb
                (Tezos_base__TzPervasives.Crypto_box.Public_key_hash.equal pkh
                  (peer_id id)) then
              Tezos_base__TzPervasives.fail
                (Identity_mismatch {| filename := filename; peer_id := pkh |})
            else
              if
                negb
                  (Tezos_base__TzPervasives.Crypto_box.equal
                    (Tezos_base__TzPervasives.Crypto_box.neuterize
                      (secret_key id)) (public_key id)) then
                Tezos_base__TzPervasives.fail
                  (Identity_keys_mismatch
                    {| filename := filename; expected_key := public_key id |})
              else
                match expected_pow with
                | None => Tezos_base__TzPervasives._return id
                | Some expected =>
                  let target :=
                    Tezos_base__TzPervasives.Crypto_box.make_target expected in
                  if
                    negb
                      (Tezos_base__TzPervasives.Crypto_box.check_proof_of_work
                        (public_key id) (proof_of_work_stamp id) target) then
                    Tezos_base__TzPervasives.fail
                      (Insufficient_proof_of_work {| expected := expected |})
                  else
                    Tezos_base__TzPervasives._return id
                end)
      end).

Definition write
  (file : string) (identity : Tezos_base__TzPervasives.P2p_identity.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Stdlib.Sys.file_exists file then
    Tezos_base__TzPervasives.fail (Existent_identity_file file)
  else
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Node_data_version.ensure_data_dir None (Stdlib.Filename.dirname file))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file file
            (Tezos_base__TzPervasives.Data_encoding.Json.construct
              Tezos_base__TzPervasives.P2p_identity.encoding identity)
        end).
src/bin_node/node_identity_file.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += No_identity_file of string

type error += Insufficient_proof_of_work of {expected : float}

val read : ?expected_pow:float -> string -> P2p_identity.t tzresult Lwt.t

type error += Existent_identity_file of string

val write : string -> P2p_identity.t -> unit tzresult Lwt.t
src/bin_node/node_identity_file.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

extensible_type

Parameter read :
(option float) ->
  string ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.P2p_identity.t).

extensible_type

Parameter write :
string ->
  Tezos_base__TzPervasives.P2p_identity.t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/bin_node/node_logging.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "node.main"
end)
src/bin_node/node_logging.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/bin_node/node_logging.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.LOG
src/bin_node/node_logging.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/bin_node/node_run_command.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Node_logging
open Genesis_chain

type error += Non_private_sandbox of P2p_addr.t

type error += RPC_Port_already_in_use of P2p_point.Id.t list

let () =
  register_error_kind
    `Permanent
    ~id:"main.run.non_private_sandbox"
    ~title:"Forbidden public sandbox"
    ~description:"A sandboxed node should not listen on a public address."
    ~pp:(fun ppf addr ->
      Format.fprintf
        ppf
        "The node is configured to listen on a public address (%a), while \
         only 'private' networks are authorised with `--sandbox`.\n\
        \           See `%s run --help` on how to change the listening address."
        Ipaddr.V6.pp
        addr
        Sys.argv.(0))
    Data_encoding.(obj1 (req "addr" P2p_addr.encoding))
    (function Non_private_sandbox addr -> Some addr | _ -> None)
    (fun addr -> Non_private_sandbox addr) ;
  register_error_kind
    `Permanent
    ~id:"main.run.port_already_in_use"
    ~title:"Cannot start node: RPC port already in use"
    ~description:"Another tezos node is probably running on the same RPC port."
    ~pp:(fun ppf addrlist ->
      Format.fprintf
        ppf
        "Another tezos node is probably running on one of these addresses \
         (%a). Please choose another RPC port."
        (Format.pp_print_list P2p_point.Id.pp)
        addrlist)
    Data_encoding.(obj1 (req "addrlist" (list P2p_point.Id.encoding)))
    (function RPC_Port_already_in_use addrlist -> Some addrlist | _ -> None)
    (fun addrlist -> RPC_Port_already_in_use addrlist)

let ( // ) = Filename.concat

let init_node ?sandbox ?checkpoint ~singleprocess (config : Node_config_file.t)
    =
  ( match sandbox with
  | None ->
      Lwt.return_none
  | Some sandbox_param -> (
    match sandbox_param with
    | None ->
        Lwt.return_none
    | Some file -> (
        Lwt_utils_unix.Json.read_file file
        >>= function
        | Error err ->
            lwt_warn "Cannot parse sandbox parameters: %s" file
            >>= fun () ->
            lwt_debug "%a" pp_print_error err >>= fun () -> Lwt.return_none
        | Ok json ->
            Lwt.return_some json ) ) )
  >>= fun sandbox_param ->
  (* TODO "WARN" when pow is below our expectation. *)
  ( match config.p2p.discovery_addr with
  | None ->
      lwt_log_notice "No local peer discovery."
      >>= fun () -> return (None, None)
  | Some addr -> (
      Node_config_file.resolve_discovery_addrs addr
      >>= function
      | [] ->
          failwith "Cannot resolve P2P discovery address: %S" addr
      | (addr, port) :: _ ->
          return (Some addr, Some port) ) )
  >>=? fun (discovery_addr, discovery_port) ->
  ( match config.p2p.listen_addr with
  | None ->
      lwt_log_notice "Not listening to P2P calls."
      >>= fun () -> return (None, None)
  | Some addr -> (
      Node_config_file.resolve_listening_addrs addr
      >>= function
      | [] ->
          failwith "Cannot resolve P2P listening address: %S" addr
      | (addr, port) :: _ ->
          return (Some addr, Some port) ) )
  >>=? fun (listening_addr, listening_port) ->
  ( match (listening_addr, sandbox) with
  | (Some addr, Some _) when Ipaddr.V6.(compare addr unspecified) = 0 ->
      return_none
  | (Some addr, Some _) when not (Ipaddr.V6.is_private addr) ->
      fail (Non_private_sandbox addr)
  | (None, Some _) ->
      return_none
  | _ ->
      Node_config_file.resolve_bootstrap_addrs config.p2p.bootstrap_peers
      >>= fun trusted_points ->
      Node_identity_file.read
        (config.data_dir // Node_data_version.default_identity_file_name)
      >>=? fun identity ->
      lwt_log_notice "Peer's global id: %a" P2p_peer.Id.pp identity.peer_id
      >>= fun () ->
      let p2p_config : P2p.config =
        {
          listening_addr;
          listening_port;
          discovery_addr;
          discovery_port;
          trusted_points;
          peers_file =
            config.data_dir // Node_data_version.default_peers_file_name;
          private_mode = config.p2p.private_mode;
          greylisting_config = config.p2p.greylisting_config;
          identity;
          proof_of_work_target = Crypto_box.make_target config.p2p.expected_pow;
          disable_mempool = config.p2p.disable_mempool;
          trust_discovered_peers = sandbox_param <> None;
          disable_testchain = config.p2p.disable_testchain;
        }
      in
      return_some (p2p_config, config.p2p.limits) )
  >>=? fun p2p_config ->
  let sandbox_parameters = sandbox_param in
  let sandbox_param =
    Option.map ~f:(fun p -> ("sandbox_parameter", p)) sandbox_param
  in
  let node_config : Node.config =
    {
      genesis;
      patch_context = Some (Patch_context.patch_context sandbox_param);
      store_root = Node_data_version.store_dir config.data_dir;
      context_root = Node_data_version.context_dir config.data_dir;
      protocol_root = Node_data_version.protocol_dir config.data_dir;
      p2p = p2p_config;
      checkpoint;
    }
  in
  Node.create
    ~sandboxed:(sandbox <> None)
    ?sandbox_parameters
    ~singleprocess
    node_config
    config.shell.peer_validator_limits
    config.shell.block_validator_limits
    config.shell.prevalidator_limits
    config.shell.chain_validator_limits
    config.shell.history_mode

(* Add default accepted CORS headers *)
let sanitize_cors_headers ~default headers =
  List.map String.lowercase_ascii headers
  |> String.Set.of_list
  |> String.Set.(union (of_list default))
  |> String.Set.elements

let launch_rpc_server (rpc_config : Node_config_file.rpc) node (addr, port) =
  let host = Ipaddr.V6.to_string addr in
  let dir = Node.build_rpc_directory node in
  let mode =
    match rpc_config.tls with
    | None ->
        `TCP (`Port port)
    | Some {cert; key} ->
        `TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
  in
  lwt_log_notice
    "Starting a RPC server listening on %s:%d%s."
    host
    port
    (if rpc_config.tls = None then "" else " (TLS enabled)")
  >>= fun () ->
  let cors_headers =
    sanitize_cors_headers ~default:["Content-Type"] rpc_config.cors_headers
  in
  Lwt.catch
    (fun () ->
      RPC_server.launch
        ~host
        mode
        dir
        ~media_types:Media_type.all_media_types
        ~cors:
          {
            allowed_origins = rpc_config.cors_origins;
            allowed_headers = cors_headers;
          }
      >>= return)
    (function
      | Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
          fail (RPC_Port_already_in_use [(addr, port)])
      | exn ->
          Lwt.return (error_exn exn))

let init_rpc (rpc_config : Node_config_file.rpc) node =
  fold_right_s
    (fun addr acc ->
      Node_config_file.resolve_rpc_listening_addrs addr
      >>= function
      | [] ->
          failwith "Cannot resolve listening address: %S" addr
      | addrs ->
          fold_right_s
            (fun x a ->
              launch_rpc_server rpc_config node x >>=? fun o -> return (o :: a))
            addrs
            acc)
    rpc_config.listen_addrs
    []

let run ?verbosity ?sandbox ?checkpoint ~singleprocess
    (config : Node_config_file.t) =
  Node_data_version.ensure_data_dir config.data_dir
  >>=? fun () ->
  Lwt_lock_file.create
    ~unlink_on_exit:true
    (Node_data_version.lock_file config.data_dir)
  >>=? fun () ->
  (* Main loop *)
  let log_cfg =
    match verbosity with
    | None ->
        config.log
    | Some default_level ->
        {config.log with default_level}
  in
  Internal_event_unix.init
    ~lwt_log_sink:log_cfg
    ~configuration:config.internal_events
    ()
  >>= fun () ->
  Updater.init (Node_data_version.protocol_dir config.data_dir) ;
  lwt_log_notice "Starting the Tezos node..."
  >>= fun () ->
  init_node ?sandbox ?checkpoint ~singleprocess config
  >>= (function
        | Ok node ->
            return node
        | Error
            (State.Incorrect_history_mode_switch {previous_mode; next_mode}
            :: _) ->
            failwith
              "@[Cannot switch from history mode '%a' to '%a'. Import a \
               context from a corresponding snapshot or re-synchronize a node \
               with an empty tezos node directory.@]"
              History_mode.pp
              previous_mode
              History_mode.pp
              next_mode
        | Error _ as err ->
            Lwt.return err)
  >>=? fun node ->
  init_rpc config.rpc node
  >>=? fun rpc ->
  lwt_log_notice "The Tezos node is now running!"
  >>= fun () ->
  Lwt_exit.(
    wrap_promise @@ retcode_of_unit_result_lwt @@ Lwt_utils.never_ending ())
  >>= fun retcode ->
  (* Clean-shutdown code *)
  Lwt_exit.termination_thread
  >>= fun x ->
  lwt_log_notice "Shutting down the Tezos node..."
  >>= fun () ->
  Node.shutdown node
  >>= fun () ->
  lwt_log_notice "Shutting down the RPC server..."
  >>= fun () ->
  Lwt_list.iter_p RPC_server.shutdown rpc
  >>= fun () ->
  lwt_log_notice "BYE (%d)" x
  >>= fun () -> Internal_event_unix.close () >>= fun () -> return retcode

let process sandbox verbosity checkpoint singleprocess args =
  let verbosity =
    let open Internal_event in
    match verbosity with [] -> None | [_] -> Some Info | _ -> Some Debug
  in
  let run =
    Node_shared_arg.read_and_patch_config_file
      ~ignore_bootstrap_peers:
        (match sandbox with Some _ -> true | None -> false)
      args
    >>=? fun config ->
    ( match sandbox with
    | Some _ ->
        if config.data_dir = Node_config_file.default_data_dir then
          failwith "Cannot use default data directory while in sandbox mode"
        else return_unit
    | None ->
        return_unit )
    >>=? fun () ->
    ( match checkpoint with
    | None ->
        return_none
    | Some s -> (
      match Block_header.of_b58check s with
      | Some b ->
          return_some b
      | None ->
          failwith
            "Failed to parse the provided checkpoint (Base58Check-encoded)." )
    )
    >>=? fun checkpoint ->
    Lwt_lock_file.is_locked (Node_data_version.lock_file config.data_dir)
    >>=? function
    | false ->
        Lwt.catch
          (fun () -> run ?sandbox ?verbosity ?checkpoint ~singleprocess config)
          (function
            | Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
                Lwt_list.fold_right_s
                  (fun addr acc ->
                    Node_config_file.resolve_rpc_listening_addrs addr
                    >>= fun x -> Lwt.return (x @ acc))
                  config.rpc.listen_addrs
                  []
                >>= fun addrlist -> fail (RPC_Port_already_in_use addrlist)
            | exn ->
                Lwt.return (error_exn exn))
    | true ->
        failwith "Data directory is locked by another process"
  in
  match Lwt_main.run run with
  | Ok (0 | 2) ->
      (* 2 means that we exit by a signal that was handled *)
      `Ok ()
  | Ok _ ->
      `Error (false, "")
  | Error err ->
      `Error (false, Format.asprintf "%a" pp_print_error err)

module Term = struct
  let verbosity =
    let open Cmdliner in
    let doc =
      "Increase log level. Using $(b,-v) is equivalent to using \
       $(b,TEZOS_LOG='* -> info'), and $(b,-vv) is equivalent to using \
       $(b,TEZOS_LOG='* -> debug')."
    in
    Arg.(
      value & flag_all
      & info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["v"])

  let sandbox =
    let open Cmdliner in
    let doc =
      "Run the daemon in sandbox mode. P2P to non-localhost addresses are \
       disabled, and constants of the economic protocol can be altered with \
       an optional JSON file. $(b,IMPORTANT): Using sandbox mode affects the \
       node state and subsequent runs of Tezos node must also use sandbox \
       mode. In order to run the node in normal mode afterwards, a full reset \
       must be performed (by removing the node's data directory)."
    in
    Arg.(
      value
      & opt ~vopt:(Some None) (some (some string)) None
      & info
          ~docs:Node_shared_arg.Manpage.misc_section
          ~doc
          ~docv:"FILE.json"
          ["sandbox"])

  let checkpoint =
    let open Cmdliner in
    let doc =
      "When asked to take a block hash as a checkpoint, the daemon will only \
       accept the chains that contains that block and those that might reach \
       it."
    in
    Arg.(
      value
      & opt (some string) None
      & info
          ~docs:Node_shared_arg.Manpage.misc_section
          ~doc
          ~docv:"<level>,<block_hash>"
          ["checkpoint"])

  let singleprocess =
    let open Cmdliner in
    let doc =
      "When enabled, it deactivates block validation using an external \
       process. Thus, the validation procedure is done in the same process as \
       the node and might not be responding when doing extensive I/Os."
    in
    Arg.(
      value & flag
      & info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["singleprocess"])

  let term =
    Cmdliner.Term.(
      ret
        ( const process $ sandbox $ verbosity $ checkpoint $ singleprocess
        $ Node_shared_arg.Term.args ))
end

module Manpage = struct
  let command_description =
    "The $(b,run) command is meant to run the Tezos node. Most of its command \
     line arguments corresponds to config file entries, and will have \
     priority over the latter if used."

  let description = [`S "DESCRIPTION"; `P command_description]

  let debug =
    let log_sections =
      String.concat " " (List.rev !Internal_event.Legacy_logging.sections)
    in
    [ `S "DEBUG";
      `P
        ( "The environment variable $(b,TEZOS_LOG) is used to fine-tune what \
           is going to be logged. The syntax is \
           $(b,TEZOS_LOG='<section> -> <level> [ ; ...]') where section is \
           one of $(i," ^ log_sections
        ^ ") and level is one of $(i,fatal), $(i,error), $(i,warn), \
           $(i,notice), $(i,info) or $(i,debug). A $(b,*) can be used as a \
           wildcard in sections, i.e. $(b, client* -> debug). The rules are \
           matched left to right, therefore the leftmost rule is highest \
           priority ." ) ]

  let examples =
    [ `S "EXAMPLES";
      `I
        ( "$(b,Run in sandbox mode listening to RPC commands at localhost \
           port 8732)",
          "$(mname) run --sandbox --data-dir /custom/data/dir --rpc-addr \
           localhost:8732" );
      `I ("$(b,Run a node that accepts network connections)", "$(mname) run")
    ]

  let man =
    description @ Node_shared_arg.Manpage.args @ debug @ examples
    @ Node_shared_arg.Manpage.bugs

  let info = Cmdliner.Term.info ~doc:"Run the Tezos node" ~man "run"
end

let cmd = (Term.term, Manpage.info)
src/bin_node/node_run_command.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Node_logging.

Import Genesis_chain.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition init_node
  (sandbox : option (option string))
  (checkpoint : option Tezos_base__TzPervasives.Block_header.t)
  (singleprocess : bool) (config : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.Node.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    match sandbox with
    | None => Lwt.return_none
    | Some sandbox_param =>
      match sandbox_param with
      | None => Lwt.return_none
      | Some file =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file)
          (fun function_parameter =>
            match function_parameter with
            | inr err =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Node_logging.lwt_warn
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Cannot parse sandbox parameters: " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "Cannot parse sandbox parameters: %s" % string) file)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Node_logging.lwt_debug
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)
                          "%a" % string) Tezos_base__TzPervasives.pp_print_error
                        err)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Lwt.return_none
                        end)
                  end)
            | inl json => Lwt.return_some json
            end)
      end
    end
    (fun sandbox_param =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        match discovery_addr (p2p config) with
        | None =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Node_logging.lwt_log_notice
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No local peer discovery." % string
                  CamlinternalFormatBasics.End_of_format)
                "No local peer discovery." % string))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives._return (None, None)
              end)
        | Some addr =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Node_config_file.resolve_discovery_addrs addr)
            (fun function_parameter =>
              match function_parameter with
              | [] =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Cannot resolve P2P discovery address: " % string
                      (CamlinternalFormatBasics.Caml_string
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "Cannot resolve P2P discovery address: %S" % string) addr
              | cons (addr, port) _ =>
                Tezos_base__TzPervasives._return ((Some addr), (Some port))
              end)
        end
        (fun function_parameter =>
          match function_parameter with
          | (discovery_addr, discovery_port) =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              match listen_addr (p2p config) with
              | None =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Node_logging.lwt_log_notice
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Not listening to P2P calls." % string
                        CamlinternalFormatBasics.End_of_format)
                      "Not listening to P2P calls." % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives._return (None, None)
                    end)
              | Some addr =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Node_config_file.resolve_listening_addrs addr)
                  (fun function_parameter =>
                    match function_parameter with
                    | [] =>
                      Tezos_base__TzPervasives.failwith
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Cannot resolve P2P listening address: " % string
                            (CamlinternalFormatBasics.Caml_string
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))
                          "Cannot resolve P2P listening address: %S" % string)
                        addr
                    | cons (addr, port) _ =>
                      Tezos_base__TzPervasives._return
                        ((Some addr), (Some port))
                    end)
              end
              (fun function_parameter =>
                match function_parameter with
                | (listening_addr, listening_port) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    match (listening_addr, sandbox) with
                    | (None, Some _) => Tezos_base__TzPervasives.return_none
                    | _ =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Node_config_file.resolve_bootstrap_addrs
                          (bootstrap_peers (p2p config)))
                        (fun trusted_points =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Node_identity_file.read None
                              (op_div_div (data_dir config)
                                Node_data_version.default_identity_file_name))
                            (fun identity =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Node_logging.lwt_log_notice
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Peer's global id: " % string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))
                                    "Peer's global id: %a" % string)
                                  Tezos_base__TzPervasives.P2p_peer.Id.pp
                                  (peer_id identity))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    let p2p_config :=
                                      {| listening_port := listening_port;
                                        listening_addr := listening_addr;
                                        discovery_port := discovery_port;
                                        discovery_addr := discovery_addr;
                                        trusted_points := trusted_points;
                                        peers_file :=
                                          op_div_div (data_dir config)
                                            Node_data_version.default_peers_file_name;
                                        private_mode :=
                                          private_mode (p2p config);
                                        identity := identity;
                                        proof_of_work_target :=
                                          Tezos_base__TzPervasives.Crypto_box.make_target
                                            (expected_pow (p2p config));
                                        disable_mempool :=
                                          disable_mempool (p2p config);
                                        trust_discovered_peers :=
                                          nequiv_decb sandbox_param None;
                                        disable_testchain :=
                                          disable_testchain (p2p config);
                                        greylisting_config :=
                                          greylisting_config (p2p config) |} in
                                    Tezos_base__TzPervasives.return_some
                                      (p2p_config, (limits (p2p config)))
                                  end)))
                    end
                    (fun p2p_config =>
                      let sandbox_parameters := sandbox_param in
                      let sandbox_param :=
                        Tezos_base__TzPervasives.Option.map
                          (fun p => ("sandbox_parameter" % string, p))
                          sandbox_param in
                      let node_config :=
                        {| genesis := Genesis_chain.genesis;
                          store_root :=
                            Node_data_version.store_dir (data_dir config);
                          context_root :=
                            Node_data_version.context_dir (data_dir config);
                          protocol_root :=
                            Node_data_version.protocol_dir (data_dir config);
                          patch_context :=
                            Some (Patch_context.patch_context sandbox_param);
                          p2p := p2p_config; checkpoint := checkpoint |} in
                      Tezos_shell.Node.create (Some (nequiv_decb sandbox None))
                        sandbox_parameters singleprocess node_config
                        (peer_validator_limits (shell config))
                        (block_validator_limits (shell config))
                        (prevalidator_limits (shell config))
                        (chain_validator_limits (shell config))
                        (history_mode (shell config)))
                end)
          end)).

Definition sanitize_cors_headers
  (default : list Tezos_base__TzPervasives.String.Set.elt)
  (headers : list string) : list Tezos_base__TzPervasives.String.Set.elt :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (Tezos_base__TzPervasives.List.map
          Tezos_base__TzPervasives.String.lowercase_ascii headers)
        Tezos_base__TzPervasives.String.Set.of_list)
      (Tezos_base__TzPervasives.String.Set.union
        (Tezos_base__TzPervasives.String.Set.of_list default)))
    Tezos_base__TzPervasives.String.Set.elements.

Definition launch_rpc_server
  (rpc_config : Node_config_file.rpc) (node : Tezos_shell.Node.t)
  (function_parameter : Ipaddr.V6.t * Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_rpc_http_server.RPC_server.server) :=
  match function_parameter with
  | (addr, port) =>
    let host := Ipaddr.V6.to_string addr in
    let dir := Tezos_shell.Node.build_rpc_directory node in
    let mode :=
      match tls rpc_config with
      | None => variant
      | Some {| cert := cert; key := key |} => variant
      end in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Node_logging.lwt_log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Starting a RPC server listening on " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal "." % char
                      CamlinternalFormatBasics.End_of_format))))))
          "Starting a RPC server listening on %s:%d%s." % string) host port
        (if equiv_decb (tls rpc_config) None then
          "" % string
        else
          " (TLS enabled)" % string))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let cors_headers :=
            sanitize_cors_headers (cons "Content-Type" % string [])
              (cors_headers rpc_config) in
          Lwt.catch
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_rpc_http_server.RPC_server.launch (Some host)
                    (Some
                      {| allowed_headers := cors_headers;
                        allowed_origins := cors_origins rpc_config |})
                    Tezos_rpc_http.Media_type.all_media_types mode dir)
                  Tezos_base__TzPervasives._return
              end)
            (fun function_parameter =>
              match function_parameter with
              | Unix.Unix_error Unix.EADDRINUSE "bind" % string "" % string =>
                Tezos_base__TzPervasives.fail
                  (RPC_Port_already_in_use (cons (addr, port) []))
              | exn => Lwt._return (Tezos_base__TzPervasives.error_exn exn)
              end)
        end)
  end.

Definition init_rpc
  (rpc_config : Node_config_file.rpc) (node : Tezos_shell.Node.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_rpc_http_server.RPC_server.server)) :=
  Tezos_base__TzPervasives.fold_right_s
    (fun addr =>
      fun acc =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Node_config_file.resolve_rpc_listening_addrs addr)
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Cannot resolve listening address: " % string
                    (CamlinternalFormatBasics.Caml_string
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "Cannot resolve listening address: %S" % string) addr
            | addrs =>
              Tezos_base__TzPervasives.fold_right_s
                (fun x =>
                  fun a =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (launch_rpc_server rpc_config node x)
                      (fun o => Tezos_base__TzPervasives._return (cons o a)))
                addrs acc
            end)) (listen_addrs rpc_config) [].

Definition run
  (verbosity : option Tezos_event_logging.Internal_event.level)
  (sandbox : option (option string))
  (checkpoint : option Tezos_base__TzPervasives.Block_header.t)
  (singleprocess : bool) (config : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Node_data_version.ensure_data_dir None (data_dir config))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_stdlib_unix.Lwt_lock_file.create None (Some true)
            (Node_data_version.lock_file (data_dir config)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let log_cfg :=
                match verbosity with
                | None => log config
                | Some default_level => record
                end in
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_stdlib_unix.Internal_event_unix.init (Some log_cfg)
                  (Some (internal_events config)) tt)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_updater.Updater.init
                      (Node_data_version.protocol_dir (data_dir config));
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Node_logging.lwt_log_notice
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Starting the Tezos node..." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Starting the Tezos node..." % string))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_base__TzPervasives.op_gt_gt_eq
                              (init_node sandbox checkpoint singleprocess config)
                              (fun function_parameter =>
                                match function_parameter with
                                | inl node =>
                                  Tezos_base__TzPervasives._return node
                                |
                                  inr
                                    (cons
                                      (State.Incorrect_history_mode_switch {|
                                        previous_mode := previous_mode;
                                          next_mode := next_mode
                                          |}) _) =>
                                  Tezos_base__TzPervasives.failwith
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            CamlinternalFormatBasics.End_of_format
                                            "" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Cannot switch from history mode '" %
                                            string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              "' to '" % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  "'. Import a context from a corresponding snapshot or re-synchronize a node with an empty tezos node directory."
                                                    % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    CamlinternalFormatBasics.End_of_format)))))))
                                      "@[Cannot switch from history mode '%a' to '%a'. Import a context from a corresponding snapshot or re-synchronize a node with an empty tezos node directory.@]"
                                        % string)
                                    Tezos_shell_services.History_mode.pp
                                    previous_mode
                                    Tezos_shell_services.History_mode.pp
                                    next_mode
                                | (inr _) as err => Lwt._return err
                                end))
                            (fun node =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (init_rpc (rpc config) node)
                                (fun rpc =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Node_logging.lwt_log_notice
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "The Tezos node is now running!" %
                                            string
                                          CamlinternalFormatBasics.End_of_format)
                                        "The Tezos node is now running!" %
                                          string))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (apply
                                            Tezos_stdlib_unix.Lwt_exit.wrap_promise
                                            (apply
                                              Tezos_stdlib_unix.Lwt_exit.retcode_of_unit_result_lwt
                                              (Tezos_base__TzPervasives.Lwt_utils.never_ending
                                                tt)))
                                          (fun retcode =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              Tezos_stdlib_unix.Lwt_exit.termination_thread
                                              (fun x =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                  (Node_logging.lwt_log_notice
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "Shutting down the Tezos node..."
                                                          % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "Shutting down the Tezos node..."
                                                        % string))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (Tezos_shell.Node.shutdown
                                                          node)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                              (Node_logging.lwt_log_notice
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "Shutting down the RPC server..."
                                                                      % string
                                                                    CamlinternalFormatBasics.End_of_format)
                                                                  "Shutting down the RPC server..."
                                                                    % string))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                                    (Lwt_list.iter_p
                                                                      Tezos_rpc_http_server.RPC_server.shutdown
                                                                      rpc)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | tt =>
                                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                                          (Node_logging.lwt_log_notice
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "BYE ("
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Int
                                                                                  CamlinternalFormatBasics.Int_d
                                                                                  CamlinternalFormatBasics.No_padding
                                                                                  CamlinternalFormatBasics.No_precision
                                                                                  (CamlinternalFormatBasics.Char_literal
                                                                                    ")"
                                                                                      %
                                                                                      char
                                                                                    CamlinternalFormatBasics.End_of_format)))
                                                                              "BYE (%d)"
                                                                                %
                                                                                string)
                                                                            x)
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            | tt
                                                                              =>
                                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                (Tezos_stdlib_unix.Internal_event_unix.close
                                                                                  tt)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    tt
                                                                                    =>
                                                                                    Tezos_base__TzPervasives._return
                                                                                      retcode
                                                                                  end)
                                                                            end)
                                                                      end)
                                                                end)
                                                          end)
                                                    end)))
                                      end)))
                        end)
                  end)
            end)
      end).

Definition process {A : Type}
  (sandbox : option (option string)) (verbosity : list A)
  (checkpoint : option string) (singleprocess : bool) (args : Node_shared_arg.t)
  : variant :=
  let verbosity :=
    match verbosity with
    | [] => None
    | cons _ [] => Some Info
    | _ => Some Debug
    end in
  let run :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Node_shared_arg.read_and_patch_config_file
        (Some
          match sandbox with
          | Some _ => true
          | None => false
          end) args)
      (fun config =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          match sandbox with
          | Some _ =>
            if equiv_decb (data_dir config) Node_config_file.default_data_dir
              then
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Cannot use default data directory while in sandbox mode" %
                      string CamlinternalFormatBasics.End_of_format)
                  "Cannot use default data directory while in sandbox mode" %
                    string)
            else
              Tezos_base__TzPervasives.return_unit
          | None => Tezos_base__TzPervasives.return_unit
          end
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                match checkpoint with
                | None => Tezos_base__TzPervasives.return_none
                | Some s =>
                  match Tezos_base__TzPervasives.Block_header.of_b58check s with
                  | Some b => Tezos_base__TzPervasives.return_some b
                  | None =>
                    Tezos_base__TzPervasives.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Failed to parse the provided checkpoint (Base58Check-encoded)."
                            % string CamlinternalFormatBasics.End_of_format)
                        "Failed to parse the provided checkpoint (Base58Check-encoded)."
                          % string)
                  end
                end
                (fun checkpoint =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_stdlib_unix.Lwt_lock_file.is_locked
                      (Node_data_version.lock_file (data_dir config)))
                    (fun function_parameter =>
                      match function_parameter with
                      | false =>
                        Lwt.catch
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              run verbosity sandbox checkpoint singleprocess
                                config
                            end)
                          (fun function_parameter =>
                            match function_parameter with
                            |
                              Unix.Unix_error Unix.EADDRINUSE "bind" % string
                                "" % string =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Lwt_list.fold_right_s
                                  (fun addr =>
                                    fun acc =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Node_config_file.resolve_rpc_listening_addrs
                                          addr)
                                        (fun x =>
                                          Lwt._return (OCaml.Stdlib.app x acc)))
                                  (listen_addrs (rpc config)) [])
                                (fun addrlist =>
                                  Tezos_base__TzPervasives.fail
                                    (RPC_Port_already_in_use addrlist))
                            | exn =>
                              Lwt._return
                                (Tezos_base__TzPervasives.error_exn exn)
                            end)
                      | true =>
                        Tezos_base__TzPervasives.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Data directory is locked by another process" %
                                string CamlinternalFormatBasics.End_of_format)
                            "Data directory is locked by another process" %
                              string)
                      end))
            end)) in
  match Lwt_main.run run with
  | inl (0 | 2) => variant
  | inl _ => variant
  | inr err => variant
  end.

Module Term.
  Definition verbosity : Cmdliner.Term.t (list bool) :=
    let doc :=
      "Increase log level. Using $(b,-v) is equivalent to using $(b,TEZOS_LOG='* -> info'), and $(b,-vv) is equivalent to using $(b,TEZOS_LOG='* -> debug')."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and Cmdliner.Arg.flag_all
        (Cmdliner.Arg.info (Some Node_shared_arg.Manpage.misc_section) None
          (Some doc) None (cons "v" % string []))).
  
  Definition sandbox : Cmdliner.Term.t (option (option string)) :=
    let doc :=
      "Run the daemon in sandbox mode. P2P to non-localhost addresses are disabled, and constants of the economic protocol can be altered with an optional JSON file. $(b,IMPORTANT): Using sandbox mode affects the node state and subsequent runs of Tezos node must also use sandbox mode. In order to run the node in normal mode afterwards, a full reset must be performed (by removing the node's data directory)."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt (Some (Some None))
          (Cmdliner.Arg.some None (Cmdliner.Arg.some None Cmdliner.Arg.string))
          None)
        (Cmdliner.Arg.info (Some Node_shared_arg.Manpage.misc_section)
          (Some "FILE.json" % string) (Some doc) None
          (cons "sandbox" % string []))).
  
  Definition checkpoint : Cmdliner.Term.t (option string) :=
    let doc :=
      "When asked to take a block hash as a checkpoint, the daemon will only accept the chains that contains that block and those that might reach it."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.string) None)
        (Cmdliner.Arg.info (Some Node_shared_arg.Manpage.misc_section)
          (Some "<level>,<block_hash>" % string) (Some doc) None
          (cons "checkpoint" % string []))).
  
  Definition singleprocess : Cmdliner.Term.t bool :=
    let doc :=
      "When enabled, it deactivates block validation using an external process. Thus, the validation procedure is done in the same process as the node and might not be responding when doing extensive I/Os."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and Cmdliner.Arg.flag
        (Cmdliner.Arg.info (Some Node_shared_arg.Manpage.misc_section) None
          (Some doc) None (cons "singleprocess" % string []))).
  
  Definition term : Cmdliner.Term.t unit :=
    Cmdliner.Term.ret
      (Cmdliner.Term.op_dollar
        (Cmdliner.Term.op_dollar
          (Cmdliner.Term.op_dollar
            (Cmdliner.Term.op_dollar
              (Cmdliner.Term.op_dollar (Cmdliner.Term.const process) sandbox)
              verbosity) checkpoint) singleprocess) Node_shared_arg.Term.args).
End Term.

Module Manpage.
  Definition command_description : string :=
    "The $(b,run) command is meant to run the Tezos node. Most of its command line arguments corresponds to config file entries, and will have priority over the latter if used."
      % string.
  
  Definition description : list variant := cons variant (cons variant []).
  
  Definition debug : list variant :=
    let log_sections :=
      Tezos_base__TzPervasives.String.concat " " % string
        (Tezos_base__TzPervasives.List.rev
          (Stdlib.op_exclamation
            Tezos_base__TzPervasives.Internal_event.Legacy_logging.sections)) in
    cons variant (cons variant []).
  
  Definition examples : list variant :=
    cons variant (cons variant (cons variant [])).
  
  Definition man : list Cmdliner.Manpage.block :=
    OCaml.Stdlib.app description
      (OCaml.Stdlib.app Node_shared_arg.Manpage.args
        (OCaml.Stdlib.app debug
          (OCaml.Stdlib.app examples Node_shared_arg.Manpage.bugs))).
  
  Definition info : Cmdliner.Term.info :=
    Cmdliner.Term.info None (Some man) None None None None
      (Some "Run the Tezos node" % string) None "run" % string.
End Manpage.

Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
  (Term.term, Manpage.info).
src/bin_node/node_run_command.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val cmd : unit Cmdliner.Term.t * Cmdliner.Term.info

module Manpage : sig
  val command_description : string

  val examples : Cmdliner.Manpage.block list
end
src/bin_node/node_run_command.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info.

Module Manpage.
  Parameter command_description : string.
  
  Parameter examples : list Cmdliner.Manpage.block.
End Manpage.
src/bin_node/node_shared_arg.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Cmdliner
open Node_logging

let ( // ) = Filename.concat

type t = {
  data_dir : string option;
  config_file : string;
  min_connections : int option;
  expected_connections : int option;
  max_connections : int option;
  max_download_speed : int option;
  max_upload_speed : int option;
  binary_chunks_size : int option;
  peer_table_size : int option;
  expected_pow : float option;
  peers : string list;
  no_bootstrap_peers : bool;
  listen_addr : string option;
  discovery_addr : string option;
  rpc_listen_addrs : string list;
  private_mode : bool;
  disable_mempool : bool;
  disable_testchain : bool;
  cors_origins : string list;
  cors_headers : string list;
  rpc_tls : Node_config_file.tls option;
  log_output : Lwt_log_sink_unix.Output.t option;
  bootstrap_threshold : int option;
  history_mode : History_mode.t option;
}

let wrap data_dir config_file connections max_download_speed max_upload_speed
    binary_chunks_size peer_table_size listen_addr discovery_addr peers
    no_bootstrap_peers bootstrap_threshold private_mode disable_mempool
    disable_testchain expected_pow rpc_listen_addrs rpc_tls cors_origins
    cors_headers log_output history_mode =
  let actual_data_dir =
    Option.unopt ~default:Node_config_file.default_data_dir data_dir
  in
  let config_file =
    Option.unopt
      ~default:(actual_data_dir // Node_data_version.default_config_file_name)
      config_file
  in
  let rpc_tls =
    Option.map ~f:(fun (cert, key) -> {Node_config_file.cert; key}) rpc_tls
  in
  (* when `--connections` is used,
     override all the bounds defined in the configuration file. *)
  let ( bootstrap_threshold,
        min_connections,
        expected_connections,
        max_connections,
        peer_table_size ) =
    match connections with
    | None ->
        (bootstrap_threshold, None, None, None, peer_table_size)
    | Some x -> (
        let peer_table_size =
          match peer_table_size with
          | None ->
              Some (8 * x)
          | Some _ ->
              peer_table_size
        in
        match bootstrap_threshold with
        | None ->
            ( Some (min (x / 4) 2),
              Some (x / 2),
              Some x,
              Some (3 * x / 2),
              peer_table_size )
        | Some bs ->
            (Some bs, Some (x / 2), Some x, Some (3 * x / 2), peer_table_size)
        )
  in
  {
    data_dir;
    config_file;
    min_connections;
    expected_connections;
    max_connections;
    max_download_speed;
    max_upload_speed;
    binary_chunks_size;
    expected_pow;
    peers;
    no_bootstrap_peers;
    listen_addr;
    discovery_addr;
    rpc_listen_addrs;
    private_mode;
    disable_mempool;
    disable_testchain;
    cors_origins;
    cors_headers;
    rpc_tls;
    log_output;
    peer_table_size;
    bootstrap_threshold;
    history_mode;
  }

module Manpage = struct
  let misc_section = "MISC OPTIONS"

  let p2p_section = "P2P OPTIONS"

  let rpc_section = "RPC OPTIONS"

  let args = [`S p2p_section; `S rpc_section; `S misc_section]

  let bugs =
    [ `S "BUGS";
      `P "Check bug reports at https://gitlab.com/tezos/tezos/issues." ]
end

module Term = struct
  let log_output_converter =
    ( (fun s ->
        match Lwt_log_sink_unix.Output.of_string s with
        | Some res ->
            `Ok res
        | None ->
            `Error s),
      Lwt_log_sink_unix.Output.pp )

  let history_mode_converter =
    let open History_mode in
    ( (function
      | "archive" ->
          `Ok Archive
      | "full" ->
          `Ok Full
      | "experimental-rolling" ->
          `Ok Rolling
      | s ->
          `Error s),
      pp )

  (* misc args *)

  let docs = Manpage.misc_section

  let history_mode =
    let doc =
      "Set the mode for the chain's data history storage. Possible values are \
       $(i,archive), $(i,full) (default), $(i,experimental-rolling). Archive \
       mode retains all data since the genesis block. Full mode only \
       maintains block headers and operations allowing replaying the chain \
       since the genesis if wanted. (Experimental-)Rolling mode retains only \
       the most recent data (i.e. from the 5 last cycles) and deletes the \
       rest."
    in
    Arg.(
      value
      & opt (some history_mode_converter) None
      & info ~docs ~doc ~docv:"<mode>" ["history-mode"])

  let log_output =
    let doc =
      "Log output. Either $(i,stdout), $(i,stderr), $(i,syslog:<facility>) or \
       a file path."
    in
    Arg.(
      value
      & opt (some log_output_converter) None
      & info ~docs ~docv:"OUTPUT" ~doc ["log-output"])

  let data_dir =
    let doc = "The directory where the Tezos node will store all its data." in
    Arg.(
      value & opt (some string) None & info ~docs ~doc ~docv:"DIR" ["data-dir"])

  let config_file =
    let doc = "The main configuration file." in
    Arg.(
      value
      & opt (some string) None
      & info ~docs ~doc ~docv:"FILE" ["config-file"])

  (* P2p args *)

  let docs = Manpage.p2p_section

  let connections =
    let doc =
      "Sets min_connections, expected_connections, max_connections to NUM / \
       2, NUM, (3 * NUM) / 2, respectively. Sets peer_table_size to 8 * NUM \
       unless it is already defined in the configuration file. Sets \
       bootstrap_threshold to min(NUM / 4, 2) unless it is already defined in \
       the configuration file."
    in
    Arg.(
      value & opt (some int) None & info ~docs ~doc ~docv:"NUM" ["connections"])

  let max_download_speed =
    let doc = "The maximum number of bytes read per second." in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["max-download-speed"])

  let max_upload_speed =
    let doc = "The maximum number of bytes sent per second." in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["max-upload-speed"])

  let binary_chunks_size =
    let doc =
      "Size limit (in kB) of binary blocks that are sent to other peers."
    in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["binary-chunks-size"])

  let peer_table_size =
    let doc =
      "Maximum size of internal peer tables, used to store metadata/logs \
       about a peer or about a to-be-authenticated host:port couple."
    in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["peer-table-size"])

  let listen_addr =
    let doc =
      "The TCP address and port at which this instance can be reached."
    in
    Arg.(
      value
      & opt (some string) None
      & info ~docs ~doc ~docv:"ADDR:PORT" ["net-addr"])

  let discovery_addr =
    let doc = "The UDP address and port used for local peer discovery." in
    Arg.(
      value
      & opt (some string) None
      & info ~docs ~doc ~docv:"ADDR:PORT" ["discovery-addr"])

  let no_bootstrap_peers =
    let doc =
      "Ignore the peers found in the config file (or the hard-coded bootstrap \
       peers in the absence of config file)."
    in
    Arg.(value & flag & info ~docs ~doc ["no-bootstrap-peers"])

  let bootstrap_threshold =
    let doc =
      "Set the number of peers with whom a chain synchronization must be \
       completed to bootstrap the node"
    in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["bootstrap-threshold"])

  let peers =
    let doc =
      "A peer to bootstrap the network from. Can be used several times to add \
       several peers."
    in
    Arg.(
      value & opt_all string [] & info ~docs ~doc ~docv:"ADDR:PORT" ["peer"])

  let expected_pow =
    let doc = "Expected level of proof-of-work for peers identity." in
    Arg.(
      value
      & opt (some float) None
      & info ~docs ~doc ~docv:"FLOAT" ["expected-pow"])

  let private_mode =
    let doc =
      "Only open outgoing/accept incoming connections to/from peers listed in \
       'bootstrap-peers' or provided with '--peer' option."
    in
    Arg.(value & flag & info ~docs ~doc ["private-mode"])

  let disable_mempool =
    let doc =
      "If set to [true], the node will not participate in the propagation of \
       pending operations (mempool). Default value is [false]. It can be used \
       to decrease the memory and computation footprints of the node."
    in
    Arg.(value & flag & info ~docs ~doc ["disable-mempool"])

  let disable_testchain =
    let doc =
      "If set to [true], the node will not spawn a testchain during the \
       protocol's testing voting period. Default value is [false]. It may be \
       used used to decrease the node storage usage and computation by \
       droping the validation of the test network blocks."
    in
    Arg.(value & flag & info ~docs ~doc ["disable-testchain"])

  (* rpc args *)
  let docs = Manpage.rpc_section

  let rpc_listen_addrs =
    let doc =
      "The TCP socket address at which this RPC server instance can be reached."
    in
    Arg.(
      value & opt_all string [] & info ~docs ~doc ~docv:"ADDR:PORT" ["rpc-addr"])

  let rpc_tls =
    let doc =
      "Enable TLS for this RPC server with the provided certificate and key."
    in
    Arg.(
      value
      & opt (some (pair string string)) None
      & info ~docs ~doc ~docv:"crt,key" ["rpc-tls"])

  let cors_origins =
    let doc =
      "CORS origin allowed by the RPC server via Access-Control-Allow-Origin; \
       may be used multiple times"
    in
    Arg.(
      value & opt_all string [] & info ~docs ~doc ~docv:"ORIGIN" ["cors-origin"])

  let cors_headers =
    let doc =
      "Header reported by Access-Control-Allow-Headers reported during CORS \
       preflighting; may be used multiple times"
    in
    Arg.(
      value & opt_all string [] & info ~docs ~doc ~docv:"HEADER" ["cors-header"])

  (* Args. *)

  let args =
    let open Term in
    const wrap $ data_dir $ config_file $ connections $ max_download_speed
    $ max_upload_speed $ binary_chunks_size $ peer_table_size $ listen_addr
    $ discovery_addr $ peers $ no_bootstrap_peers $ bootstrap_threshold
    $ private_mode $ disable_mempool $ disable_testchain $ expected_pow
    $ rpc_listen_addrs $ rpc_tls $ cors_origins $ cors_headers $ log_output
    $ history_mode
end

let read_config_file args =
  if Sys.file_exists args.config_file then
    Node_config_file.read args.config_file
  else return Node_config_file.default_config

let read_data_dir args =
  read_config_file args
  >>=? fun cfg ->
  let {data_dir; _} = args in
  let data_dir = Option.unopt ~default:cfg.data_dir data_dir in
  return data_dir

let read_and_patch_config_file ?(ignore_bootstrap_peers = false) args =
  read_config_file args
  >>=? fun cfg ->
  let { data_dir;
        min_connections;
        expected_connections;
        max_connections;
        max_download_speed;
        max_upload_speed;
        binary_chunks_size;
        peer_table_size;
        expected_pow;
        peers;
        no_bootstrap_peers;
        listen_addr;
        private_mode;
        discovery_addr;
        disable_mempool;
        disable_testchain;
        rpc_listen_addrs;
        rpc_tls;
        cors_origins;
        cors_headers;
        log_output;
        bootstrap_threshold;
        history_mode;
        config_file = _ } =
    args
  in
  let bootstrap_peers =
    if no_bootstrap_peers || ignore_bootstrap_peers then (
      log_info "Ignoring bootstrap peers" ;
      peers )
    else cfg.p2p.bootstrap_peers @ peers
  in
  Node_config_file.update
    ?data_dir
    ?min_connections
    ?expected_connections
    ?max_connections
    ?max_download_speed
    ?max_upload_speed
    ?binary_chunks_size
    ?peer_table_size
    ?expected_pow
    ~bootstrap_peers
    ?listen_addr
    ?discovery_addr
    ~rpc_listen_addrs
    ~private_mode
    ~disable_mempool
    ~disable_testchain
    ~cors_origins
    ~cors_headers
    ?rpc_tls
    ?log_output
    ?bootstrap_threshold
    ?history_mode
    cfg
src/bin_node/node_shared_arg.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Cmdliner.

Import Node_logging.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Record t := {
  data_dir : option string;
  config_file : string;
  min_connections : option Z;
  expected_connections : option Z;
  max_connections : option Z;
  max_download_speed : option Z;
  max_upload_speed : option Z;
  binary_chunks_size : option Z;
  peer_table_size : option Z;
  expected_pow : option float;
  peers : list string;
  no_bootstrap_peers : bool;
  listen_addr : option string;
  discovery_addr : option string;
  rpc_listen_addrs : list string;
  private_mode : bool;
  disable_mempool : bool;
  disable_testchain : bool;
  cors_origins : list string;
  cors_headers : list string;
  rpc_tls : option Node_config_file.tls;
  log_output : option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t;
  bootstrap_threshold : option Z;
  history_mode : option Tezos_shell_services.History_mode.t }.

Definition wrap
  (data_dir : option string) (config_file : option string)
  (connections : option Z) (max_download_speed : option Z)
  (max_upload_speed : option Z) (binary_chunks_size : option Z)
  (peer_table_size : option Z) (listen_addr : option string)
  (discovery_addr : option string) (peers : list string)
  (no_bootstrap_peers : bool) (bootstrap_threshold : option Z)
  (private_mode : bool) (disable_mempool : bool) (disable_testchain : bool)
  (expected_pow : option float) (rpc_listen_addrs : list string)
  (rpc_tls : option (string * string)) (cors_origins : list string)
  (cors_headers : list string)
  (log_output : option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t)
  (history_mode : option Tezos_shell_services.History_mode.t) : t :=
  let actual_data_dir :=
    Tezos_base__TzPervasives.Option.unopt Node_config_file.default_data_dir
      data_dir in
  let config_file :=
    Tezos_base__TzPervasives.Option.unopt
      (op_div_div actual_data_dir Node_data_version.default_config_file_name)
      config_file in
  let rpc_tls :=
    Tezos_base__TzPervasives.Option.map
      (fun function_parameter =>
        match function_parameter with
        | (cert, key) =>
          {| Node_config_file.cert := cert; Node_config_file.key := key |}
        end) rpc_tls in
  match
    match connections with
    | None => (bootstrap_threshold, None, None, None, peer_table_size)
    | Some x =>
      let peer_table_size :=
        match peer_table_size with
        | None => Some (Z.mul 8 x)
        | Some _ => peer_table_size
        end in
      match bootstrap_threshold with
      | None =>
        ((Some (OCaml.Stdlib.min (Z.div x 4) 2)), (Some (Z.div x 2)), (Some x),
          (Some (Z.div (Z.mul 3 x) 2)), peer_table_size)
      | Some bs =>
        ((Some bs), (Some (Z.div x 2)), (Some x), (Some (Z.div (Z.mul 3 x) 2)),
          peer_table_size)
      end
    end with
  |
    (bootstrap_threshold, min_connections, expected_connections,
      max_connections, peer_table_size) =>
    {| data_dir := data_dir; config_file := config_file;
      min_connections := min_connections;
      expected_connections := expected_connections;
      max_connections := max_connections;
      max_download_speed := max_download_speed;
      max_upload_speed := max_upload_speed;
      binary_chunks_size := binary_chunks_size;
      peer_table_size := peer_table_size; expected_pow := expected_pow;
      peers := peers; no_bootstrap_peers := no_bootstrap_peers;
      listen_addr := listen_addr; discovery_addr := discovery_addr;
      rpc_listen_addrs := rpc_listen_addrs; private_mode := private_mode;
      disable_mempool := disable_mempool;
      disable_testchain := disable_testchain; cors_origins := cors_origins;
      cors_headers := cors_headers; rpc_tls := rpc_tls;
      log_output := log_output; bootstrap_threshold := bootstrap_threshold;
      history_mode := history_mode |}
  end.

Module Manpage.
  Definition misc_section : string := "MISC OPTIONS" % string.
  
  Definition p2p_section : string := "P2P OPTIONS" % string.
  
  Definition rpc_section : string := "RPC OPTIONS" % string.
  
  Definition args : list variant :=
    cons variant (cons variant (cons variant [])).
  
  Definition bugs : list variant := cons variant (cons variant []).
End Manpage.

Module Term.
  Definition log_output_converter
    : (string -> variant) *
      (Stdlib.Format.formatter ->
        Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t -> unit) :=
    ((fun s =>
      match Tezos_stdlib_unix.Lwt_log_sink_unix.Output.of_string s with
      | Some res => variant
      | None => variant
      end), Tezos_stdlib_unix.Lwt_log_sink_unix.Output.pp).
  
  Definition history_mode_converter
    : (string -> variant) *
      (Stdlib.Format.formatter -> Tezos_shell_services.History_mode.t -> unit) :=
    ((fun function_parameter =>
      match function_parameter with
      | "archive" % string => variant
      | "full" % string => variant
      | "experimental-rolling" % string => variant
      | s => variant
      end), Tezos_shell_services.History_mode.pp).
  
  Definition docs : string := Manpage.misc_section.
  
  Definition history_mode
    : Cmdliner.Term.t (option Tezos_shell_services.History_mode.t) :=
    let doc :=
      "Set the mode for the chain's data history storage. Possible values are $(i,archive), $(i,full) (default), $(i,experimental-rolling). Archive mode retains all data since the genesis block. Full mode only maintains block headers and operations allowing replaying the chain since the genesis if wanted. (Experimental-)Rolling mode retains only the most recent data (i.e. from the 5 last cycles) and deletes the rest."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None history_mode_converter)
          None)
        (Cmdliner.Arg.info (Some docs) (Some "<mode>" % string) (Some doc) None
          (cons "history-mode" % string []))).
  
  Definition log_output
    : Cmdliner.Term.t (option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t) :=
    let doc :=
      "Log output. Either $(i,stdout), $(i,stderr), $(i,syslog:<facility>) or a file path."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None log_output_converter)
          None)
        (Cmdliner.Arg.info (Some docs) (Some "OUTPUT" % string) (Some doc) None
          (cons "log-output" % string []))).
  
  Definition data_dir : Cmdliner.Term.t (option string) :=
    let doc :=
      "The directory where the Tezos node will store all its data." % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.string) None)
        (Cmdliner.Arg.info (Some docs) (Some "DIR" % string) (Some doc) None
          (cons "data-dir" % string []))).
  
  Definition config_file : Cmdliner.Term.t (option string) :=
    let doc := "The main configuration file." % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.string) None)
        (Cmdliner.Arg.info (Some docs) (Some "FILE" % string) (Some doc) None
          (cons "config-file" % string []))).
  
  Definition docs : string := Manpage.p2p_section.
  
  Definition connections : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Sets min_connections, expected_connections, max_connections to NUM / 2, NUM, (3 * NUM) / 2, respectively. Sets peer_table_size to 8 * NUM unless it is already defined in the configuration file. Sets bootstrap_threshold to min(NUM / 4, 2) unless it is already defined in the configuration file."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.int) None)
        (Cmdliner.Arg.info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "connections" % string []))).
  
  Definition max_download_speed : Cmdliner.Term.t (option Z) :=
    let doc := "The maximum number of bytes read per second." % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.int) None)
        (Cmdliner.Arg.info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "max-download-speed" % string []))).
  
  Definition max_upload_speed : Cmdliner.Term.t (option Z) :=
    let doc := "The maximum number of bytes sent per second." % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.int) None)
        (Cmdliner.Arg.info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "max-upload-speed" % string []))).
  
  Definition binary_chunks_size : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Size limit (in kB) of binary blocks that are sent to other peers." %
        string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.int) None)
        (Cmdliner.Arg.info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "binary-chunks-size" % string []))).
  
  Definition peer_table_size : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Maximum size of internal peer tables, used to store metadata/logs about a peer or about a to-be-authenticated host:port couple."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.int) None)
        (Cmdliner.Arg.info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "peer-table-size" % string []))).
  
  Definition listen_addr : Cmdliner.Term.t (option string) :=
    let doc :=
      "The TCP address and port at which this instance can be reached." % string
      in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.string) None)
        (Cmdliner.Arg.info (Some docs) (Some "ADDR:PORT" % string) (Some doc)
          None (cons "net-addr" % string []))).
  
  Definition discovery_addr : Cmdliner.Term.t (option string) :=
    let doc :=
      "The UDP address and port used for local peer discovery." % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.string) None)
        (Cmdliner.Arg.info (Some docs) (Some "ADDR:PORT" % string) (Some doc)
          None (cons "discovery-addr" % string []))).
  
  Definition no_bootstrap_peers : Cmdliner.Term.t bool :=
    let doc :=
      "Ignore the peers found in the config file (or the hard-coded bootstrap peers in the absence of config file)."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and Cmdliner.Arg.flag
        (Cmdliner.Arg.info (Some docs) None (Some doc) None
          (cons "no-bootstrap-peers" % string []))).
  
  Definition bootstrap_threshold : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Set the number of peers with whom a chain synchronization must be completed to bootstrap the node"
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.int) None)
        (Cmdliner.Arg.info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "bootstrap-threshold" % string []))).
  
  Definition peers : Cmdliner.Term.t (list string) :=
    let doc :=
      "A peer to bootstrap the network from. Can be used several times to add several peers."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and (Cmdliner.Arg.opt_all None Cmdliner.Arg.string [])
        (Cmdliner.Arg.info (Some docs) (Some "ADDR:PORT" % string) (Some doc)
          None (cons "peer" % string []))).
  
  Definition expected_pow : Cmdliner.Term.t (option float) :=
    let doc := "Expected level of proof-of-work for peers identity." % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.float) None)
        (Cmdliner.Arg.info (Some docs) (Some "FLOAT" % string) (Some doc) None
          (cons "expected-pow" % string []))).
  
  Definition private_mode : Cmdliner.Term.t bool :=
    let doc :=
      "Only open outgoing/accept incoming connections to/from peers listed in 'bootstrap-peers' or provided with '--peer' option."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and Cmdliner.Arg.flag
        (Cmdliner.Arg.info (Some docs) None (Some doc) None
          (cons "private-mode" % string []))).
  
  Definition disable_mempool : Cmdliner.Term.t bool :=
    let doc :=
      "If set to [true], the node will not participate in the propagation of pending operations (mempool). Default value is [false]. It can be used to decrease the memory and computation footprints of the node."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and Cmdliner.Arg.flag
        (Cmdliner.Arg.info (Some docs) None (Some doc) None
          (cons "disable-mempool" % string []))).
  
  Definition disable_testchain : Cmdliner.Term.t bool :=
    let doc :=
      "If set to [true], the node will not spawn a testchain during the protocol's testing voting period. Default value is [false]. It may be used used to decrease the node storage usage and computation by droping the validation of the test network blocks."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and Cmdliner.Arg.flag
        (Cmdliner.Arg.info (Some docs) None (Some doc) None
          (cons "disable-testchain" % string []))).
  
  Definition docs : string := Manpage.rpc_section.
  
  Definition rpc_listen_addrs : Cmdliner.Term.t (list string) :=
    let doc :=
      "The TCP socket address at which this RPC server instance can be reached."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and (Cmdliner.Arg.opt_all None Cmdliner.Arg.string [])
        (Cmdliner.Arg.info (Some docs) (Some "ADDR:PORT" % string) (Some doc)
          None (cons "rpc-addr" % string []))).
  
  Definition rpc_tls : Cmdliner.Term.t (option (string * string)) :=
    let doc :=
      "Enable TLS for this RPC server with the provided certificate and key." %
        string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None
          (Cmdliner.Arg.some None
            (Cmdliner.Arg.pair None Cmdliner.Arg.string Cmdliner.Arg.string))
          None)
        (Cmdliner.Arg.info (Some docs) (Some "crt,key" % string) (Some doc) None
          (cons "rpc-tls" % string []))).
  
  Definition cors_origins : Cmdliner.Term.t (list string) :=
    let doc :=
      "CORS origin allowed by the RPC server via Access-Control-Allow-Origin; may be used multiple times"
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and (Cmdliner.Arg.opt_all None Cmdliner.Arg.string [])
        (Cmdliner.Arg.info (Some docs) (Some "ORIGIN" % string) (Some doc) None
          (cons "cors-origin" % string []))).
  
  Definition cors_headers : Cmdliner.Term.t (list string) :=
    let doc :=
      "Header reported by Access-Control-Allow-Headers reported during CORS preflighting; may be used multiple times"
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and (Cmdliner.Arg.opt_all None Cmdliner.Arg.string [])
        (Cmdliner.Arg.info (Some docs) (Some "HEADER" % string) (Some doc) None
          (cons "cors-header" % string []))).
  
  Definition args : Cmdliner.Term.t t :=
    Cmdliner.Term.op_dollar
      (Cmdliner.Term.op_dollar
        (Cmdliner.Term.op_dollar
          (Cmdliner.Term.op_dollar
            (Cmdliner.Term.op_dollar
              (Cmdliner.Term.op_dollar
                (Cmdliner.Term.op_dollar
                  (Cmdliner.Term.op_dollar
                    (Cmdliner.Term.op_dollar
                      (Cmdliner.Term.op_dollar
                        (Cmdliner.Term.op_dollar
                          (Cmdliner.Term.op_dollar
                            (Cmdliner.Term.op_dollar
                              (Cmdliner.Term.op_dollar
                                (Cmdliner.Term.op_dollar
                                  (Cmdliner.Term.op_dollar
                                    (Cmdliner.Term.op_dollar
                                      (Cmdliner.Term.op_dollar
                                        (Cmdliner.Term.op_dollar
                                          (Cmdliner.Term.op_dollar
                                            (Cmdliner.Term.op_dollar
                                              (Cmdliner.Term.op_dollar
                                                (Cmdliner.Term.const wrap)
                                                data_dir) config_file)
                                            connections) max_download_speed)
                                        max_upload_speed) binary_chunks_size)
                                    peer_table_size) listen_addr) discovery_addr)
                              peers) no_bootstrap_peers) bootstrap_threshold)
                        private_mode) disable_mempool) disable_testchain)
                  expected_pow) rpc_listen_addrs) rpc_tls) cors_origins)
          cors_headers) log_output) history_mode.
End Term.

Definition read_config_file (args : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Node_config_file.t) :=
  if Stdlib.Sys.file_exists (config_file args) then
    Node_config_file.read (config_file args)
  else
    Tezos_base__TzPervasives._return Node_config_file.default_config.

Definition read_data_dir (args : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (read_config_file args)
    (fun cfg =>
      match args with
      | {| data_dir := data_dir |} =>
        let data_dir :=
          Tezos_base__TzPervasives.Option.unopt (data_dir cfg) data_dir in
        Tezos_base__TzPervasives._return data_dir
      end).

Definition read_and_patch_config_file (op_star_o_p_t_star : option bool)
  : t -> Lwt.t (Tezos_base__TzPervasives.tzresult Node_config_file.t) :=
  let ignore_bootstrap_peers :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun args =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question (read_config_file args)
      (fun cfg =>
        match args with
        | {|
          data_dir := data_dir;
            config_file := _;
            min_connections := min_connections;
            expected_connections := expected_connections;
            max_connections := max_connections;
            max_download_speed := max_download_speed;
            max_upload_speed := max_upload_speed;
            binary_chunks_size := binary_chunks_size;
            peer_table_size := peer_table_size;
            expected_pow := expected_pow;
            peers := peers;
            no_bootstrap_peers := no_bootstrap_peers;
            listen_addr := listen_addr;
            discovery_addr := discovery_addr;
            rpc_listen_addrs := rpc_listen_addrs;
            private_mode := private_mode;
            disable_mempool := disable_mempool;
            disable_testchain := disable_testchain;
            cors_origins := cors_origins;
            cors_headers := cors_headers;
            rpc_tls := rpc_tls;
            log_output := log_output;
            bootstrap_threshold := bootstrap_threshold;
            history_mode := history_mode
            |} =>
          let bootstrap_peers :=
            if orb no_bootstrap_peers ignore_bootstrap_peers then
              Node_logging.log_info
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Ignoring bootstrap peers" % string
                    CamlinternalFormatBasics.End_of_format)
                  "Ignoring bootstrap peers" % string);
              peers
            else
              OCaml.Stdlib.app (bootstrap_peers (p2p cfg)) peers in
          Node_config_file.update data_dir min_connections expected_connections
            max_connections max_download_speed max_upload_speed
            binary_chunks_size peer_table_size expected_pow
            (Some bootstrap_peers) listen_addr discovery_addr
            (Some rpc_listen_addrs) (Some private_mode) (Some disable_mempool)
            (Some disable_testchain) (Some cors_origins) (Some cors_headers)
            rpc_tls log_output bootstrap_threshold history_mode cfg
        end).
src/bin_node/node_shared_arg.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  data_dir : string option;
  config_file : string;
  min_connections : int option;
  expected_connections : int option;
  max_connections : int option;
  max_download_speed : int option;
  max_upload_speed : int option;
  binary_chunks_size : int option;
  peer_table_size : int option;
  expected_pow : float option;
  peers : string list;
  no_bootstrap_peers : bool;
  listen_addr : string option;
  discovery_addr : string option;
  rpc_listen_addrs : string list;
  private_mode : bool;
  disable_mempool : bool;
  disable_testchain : bool;
  cors_origins : string list;
  cors_headers : string list;
  rpc_tls : Node_config_file.tls option;
  log_output : Lwt_log_sink_unix.Output.t option;
  bootstrap_threshold : int option;
  history_mode : History_mode.t option;
}

module Term : sig
  val args : t Cmdliner.Term.t

  val data_dir : string option Cmdliner.Term.t

  val config_file : string option Cmdliner.Term.t
end

val read_data_dir : t -> string tzresult Lwt.t

val read_and_patch_config_file :
  ?ignore_bootstrap_peers:bool -> t -> Node_config_file.t tzresult Lwt.t

module Manpage : sig
  val misc_section : string

  val args : Cmdliner.Manpage.block list

  val bugs : Cmdliner.Manpage.block list
end
src/bin_node/node_shared_arg.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  data_dir : option string;
  config_file : string;
  min_connections : option Z;
  expected_connections : option Z;
  max_connections : option Z;
  max_download_speed : option Z;
  max_upload_speed : option Z;
  binary_chunks_size : option Z;
  peer_table_size : option Z;
  expected_pow : option float;
  peers : list string;
  no_bootstrap_peers : bool;
  listen_addr : option string;
  discovery_addr : option string;
  rpc_listen_addrs : list string;
  private_mode : bool;
  disable_mempool : bool;
  disable_testchain : bool;
  cors_origins : list string;
  cors_headers : list string;
  rpc_tls : option Node_config_file.tls;
  log_output : option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t;
  bootstrap_threshold : option Z;
  history_mode : option Tezos_shell_services.History_mode.t }.

Module Term.
  Parameter args : Cmdliner.Term.t t.
  
  Parameter data_dir : Cmdliner.Term.t (option string).
  
  Parameter config_file : Cmdliner.Term.t (option string).
End Term.

Parameter read_data_dir : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string).

Parameter read_and_patch_config_file :
(option bool) ->
  t -> Lwt.t (Tezos_base__TzPervasives.tzresult Node_config_file.t).

Module Manpage.
  Parameter misc_section : string.
  
  Parameter args : list Cmdliner.Manpage.block.
  
  Parameter bugs : list Cmdliner.Manpage.block.
End Manpage.
src/bin_node/node_snapshot_command.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Node_logging

let ( // ) = Filename.concat

let context_dir data_dir = data_dir // "context"

let store_dir data_dir = data_dir // "store"

(** Main *)

module Term = struct
  type subcommand = Export | Import

  let dir_cleaner data_dir =
    lwt_log_notice "Cleaning directory %s because of failure" data_dir
    >>= fun () ->
    Lwt_utils_unix.remove_dir @@ store_dir data_dir
    >>= fun () -> Lwt_utils_unix.remove_dir @@ context_dir data_dir

  let process subcommand args snapshot_file block export_rolling =
    let run =
      Internal_event_unix.init ()
      >>= fun () ->
      Node_shared_arg.read_data_dir args
      >>=? fun data_dir ->
      let genesis = Genesis_chain.genesis in
      match subcommand with
      | Export ->
          Node_data_version.ensure_data_dir data_dir
          >>=? fun () ->
          let context_root = context_dir data_dir in
          let store_root = store_dir data_dir in
          Store.init store_root
          >>=? fun store ->
          Context.init ~readonly:true context_root
          >>= fun context_index ->
          Snapshots.export
            ~export_rolling
            ~context_index
            ~store
            ~genesis:genesis.block
            snapshot_file
            block
          >>=? fun () -> Store.close store |> return
      | Import ->
          Node_data_version.ensure_data_dir ~bare:true data_dir
          >>=? fun () ->
          Lwt_lock_file.create
            ~unlink_on_exit:true
            (Node_data_version.lock_file data_dir)
          >>=? fun () ->
          Snapshots.import
            ~data_dir
            ~dir_cleaner
            ~genesis
            ~patch_context:Patch_context.patch_context
            snapshot_file
            block
    in
    match Lwt_main.run run with
    | Ok () ->
        `Ok ()
    | Error err ->
        `Error (false, Format.asprintf "%a" pp_print_error err)

  let subcommand_arg =
    let parser = function
      | "export" ->
          `Ok Export
      | "import" ->
          `Ok Import
      | s ->
          `Error ("invalid argument: " ^ s)
    and printer ppf = function
      | Export ->
          Format.fprintf ppf "export"
      | Import ->
          Format.fprintf ppf "import"
    in
    let open Cmdliner.Arg in
    let doc =
      "Operation to perform. Possible values: $(b,export), $(b,import)."
    in
    required
    & pos 0 (some (parser, printer)) None
    & info [] ~docv:"OPERATION" ~doc

  let file_arg =
    let open Cmdliner.Arg in
    required & pos 1 (some string) None & info [] ~docv:"FILE"

  let blocks =
    let open Cmdliner.Arg in
    let doc = "Block hash of the block to export/import." in
    value & opt (some string) None & info ~docv:"<block_hash>" ~doc ["block"]

  let export_rolling =
    let open Cmdliner in
    let doc =
      "Force export command to dump a minimal snapshot based on the rolling \
       mode."
    in
    Arg.(
      value & flag
      & info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["rolling"])

  let term =
    let open Cmdliner.Term in
    ret
      ( const process $ subcommand_arg $ Node_shared_arg.Term.args $ file_arg
      $ blocks $ export_rolling )
end

module Manpage = struct
  let command_description =
    "The $(b,snapshot) command is meant to export and import snapshots files."

  let description =
    [ `S "DESCRIPTION";
      `P (command_description ^ " Several operations are possible: ");
      `P
        "$(b,export) allows to export a snapshot of the current node state \
         into a file.";
      `P "$(b,import) allows to import a snapshot from a given file." ]

  let options = [`S "OPTIONS"]

  let examples =
    [ `S "EXAMPLES";
      `I
        ( "$(b,Export a snapshot using the rolling mode)",
          "$(mname) snapshot export latest.rolling --rolling" );
      `I
        ( "$(b,Import a snapshot located in file.full)",
          "$(mname) snapshot import file.full" ) ]

  let man = description @ options @ examples @ Node_shared_arg.Manpage.bugs

  let info = Cmdliner.Term.info ~doc:"Manage snapshots" ~man "snapshot"
end

let cmd = (Term.term, Manpage.info)
src/bin_node/node_snapshot_command.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Node_logging.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition context_dir (data_dir : string) : string :=
  op_div_div data_dir "context" % string.

Definition store_dir (data_dir : string) : string :=
  op_div_div data_dir "store" % string.

Module Term.
  Inductive subcommand : Type :=
  | Export : subcommand
  | Import : subcommand.
  
  Definition dir_cleaner (data_dir : string) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Node_logging.lwt_log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cleaning directory " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " because of failure" % string
                CamlinternalFormatBasics.End_of_format)))
          "Cleaning directory %s because of failure" % string) data_dir)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (apply Tezos_stdlib_unix.Lwt_utils_unix.remove_dir
              (store_dir data_dir))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                apply Tezos_stdlib_unix.Lwt_utils_unix.remove_dir
                  (context_dir data_dir)
              end)
        end).
  
  Definition process
    (subcommand : subcommand) (args : Node_shared_arg.t)
    (snapshot_file : string) (block : option string) (export_rolling : bool)
    : variant :=
    let run :=
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_stdlib_unix.Internal_event_unix.init None None tt)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Node_shared_arg.read_data_dir args)
              (fun data_dir =>
                let genesis := Genesis_chain.genesis in
                match subcommand with
                | Export =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Node_data_version.ensure_data_dir None data_dir)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        let context_root := context_dir data_dir in
                        let store_root := store_dir data_dir in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_shell.Store.init None None store_root)
                          (fun store =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_storage.Context.init None None (Some true)
                                context_root)
                              (fun context_index =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_shell.Snapshots.export
                                    (Some export_rolling) context_index store
                                    (block genesis) snapshot_file block)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      OCaml.Stdlib.reverse_apply
                                        (Tezos_shell.Store.close store)
                                        Tezos_base__TzPervasives._return
                                    end)))
                      end)
                | Import =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Node_data_version.ensure_data_dir (Some true) data_dir)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_stdlib_unix.Lwt_lock_file.create None
                            (Some true) (Node_data_version.lock_file data_dir))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_shell.Snapshots.import data_dir dir_cleaner
                                Patch_context.patch_context genesis
                                snapshot_file block
                            end)
                      end)
                end)
          end) in
    match Lwt_main.run run with
    | inl tt => variant
    | inr err => variant
    end.
  
  Definition subcommand_arg : Cmdliner.Term.t subcommand :=
    let parser (function_parameter : string) : variant :=
      match function_parameter with
      | "export" % string => variant
      | "import" % string => variant
      | s => variant
      end
    with printer
      (ppf : Stdlib.Format.formatter) (function_parameter : subcommand)
      : unit :=
      match function_parameter with
      | Export =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "export" % string
              CamlinternalFormatBasics.End_of_format) "export" % string)
      | Import =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "import" % string
              CamlinternalFormatBasics.End_of_format) "import" % string)
      end in
    let doc :=
      "Operation to perform. Possible values: $(b,export), $(b,import)." %
        string in
    Cmdliner.Arg.op_and Cmdliner.Arg.required
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.pos None 0 (Cmdliner.Arg.some None (parser, printer)) None)
        (Cmdliner.Arg.info None (Some "OPERATION" % string) (Some doc) None [])).
  
  Definition file_arg : Cmdliner.Term.t string :=
    Cmdliner.Arg.op_and Cmdliner.Arg.required
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.pos None 1 (Cmdliner.Arg.some None Cmdliner.Arg.string)
          None) (Cmdliner.Arg.info None (Some "FILE" % string) None None [])).
  
  Definition blocks : Cmdliner.Term.t (option string) :=
    let doc := "Block hash of the block to export/import." % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and
        (Cmdliner.Arg.opt None (Cmdliner.Arg.some None Cmdliner.Arg.string) None)
        (Cmdliner.Arg.info None (Some "<block_hash>" % string) (Some doc) None
          (cons "block" % string []))).
  
  Definition export_rolling : Cmdliner.Term.t bool :=
    let doc :=
      "Force export command to dump a minimal snapshot based on the rolling mode."
        % string in
    Cmdliner.Arg.op_and Cmdliner.Arg.value
      (Cmdliner.Arg.op_and Cmdliner.Arg.flag
        (Cmdliner.Arg.info (Some Node_shared_arg.Manpage.misc_section) None
          (Some doc) None (cons "rolling" % string []))).
  
  Definition term : Cmdliner.Term.t unit :=
    Cmdliner.Term.ret
      (Cmdliner.Term.op_dollar
        (Cmdliner.Term.op_dollar
          (Cmdliner.Term.op_dollar
            (Cmdliner.Term.op_dollar
              (Cmdliner.Term.op_dollar (Cmdliner.Term.const process)
                subcommand_arg) Node_shared_arg.Term.args) file_arg) blocks)
        export_rolling).
End Term.

Module Manpage.
  Definition command_description : string :=
    "The $(b,snapshot) command is meant to export and import snapshots files." %
      string.
  
  Definition description : list variant :=
    cons variant (cons variant (cons variant (cons variant []))).
  
  Definition options : list variant := cons variant [].
  
  Definition examples : list variant :=
    cons variant (cons variant (cons variant [])).
  
  Definition man : list Cmdliner.Manpage.block :=
    OCaml.Stdlib.app description
      (OCaml.Stdlib.app options
        (OCaml.Stdlib.app examples Node_shared_arg.Manpage.bugs)).
  
  Definition info : Cmdliner.Term.info :=
    Cmdliner.Term.info None (Some man) None None None None
      (Some "Manage snapshots" % string) None "snapshot" % string.
End Manpage.

Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
  (Term.term, Manpage.info).
src/bin_node/node_snapshot_command.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val cmd : unit Cmdliner.Term.t * Cmdliner.Term.info

module Manpage : sig
  val command_description : string
end
src/bin_node/node_snapshot_command.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info.

Module Manpage.
  Parameter command_description : string.
End Manpage.
src/bin_node/patch_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Genesis_chain

let patch_context key_json ctxt =
  ( match key_json with
  | None ->
      Lwt.return ctxt
  | Some (key, json) ->
      Tezos_storage.Context.set
        ctxt
        [key]
        (Data_encoding.Binary.to_bytes_exn Data_encoding.json json) )
  >>= fun ctxt ->
  (* TODO: this code seems to be shared with validator.ml, function run:
     can we share it? *)
  match Registered_protocol.get genesis.protocol with
  | None ->
      assert false (* FIXME error *)
  | Some proto -> (
      let module Proto = (val proto) in
      let ctxt = Shell_context.wrap_disk_context ctxt in
      Proto.init
        ctxt
        {
          level = 0l;
          proto_level = 0;
          predecessor = genesis.block;
          timestamp = genesis.time;
          validation_passes = 0;
          operations_hash = Operation_list_list_hash.empty;
          fitness = [];
          context = Context_hash.zero;
        }
      >>= function
      | Error _ ->
          assert false (* FIXME error *)
      | Ok {context; _} ->
          let context = Shell_context.unwrap_disk_context context in
          Lwt.return context )
src/bin_node/patch_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Genesis_chain.

Definition patch_context
  (key_json : option (string * Tezos_base__TzPervasives.Data_encoding.json))
  (ctxt : Tezos_storage.Context.context) : Lwt.t Tezos_storage.Context.t :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    match key_json with
    | None => Lwt._return ctxt
    | Some (key, json) =>
      Tezos_storage.Context.set ctxt (cons key [])
        (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_base__TzPervasives.Data_encoding.json json)
    end
    (fun ctxt =>
      match
        Tezos_protocol_updater.Registered_protocol.get
          (protocol Genesis_chain.genesis) with
      | None => false
      | Some proto =>
        let Proto := projT2 proto in
        let ctxt := Tezos_shell_context.Shell_context.wrap_disk_context ctxt in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Proto.(Tezos_protocol_updater__Registered_protocol.T.init) ctxt
            {| level := 0; proto_level := 0;
              predecessor := block Genesis_chain.genesis;
              timestamp := time Genesis_chain.genesis; validation_passes := 0;
              operations_hash :=
                Tezos_base__TzPervasives.Operation_list_list_hash.empty;
              fitness := [];
              context := Tezos_base__TzPervasives.Context_hash.zero |})
          (fun function_parameter =>
            match function_parameter with
            | inr _ => false
            | inl {| context := context |} =>
              let context :=
                Tezos_shell_context.Shell_context.unwrap_disk_context context in
              Lwt._return context
            end)
      end).
src/bin_node/patch_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val patch_context :
  (string * Data_encoding.json) option -> Context.t -> Context.t Lwt.t
src/bin_node/patch_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter patch_context :
(option (string * Tezos_base__TzPervasives.Data_encoding.json)) ->
  Tezos_storage.Context.t -> Lwt.t Tezos_storage.Context.t.
src/bin_sandbox/command_accusations.ml 
open Flextesa
open Internal_pervasives
open Console

let default_attempts = 35

let little_mesh_with_bakers ?base_port ?generate_kiln_config state ~protocol
    ~starting_level ~node_exec ~client_exec ~bakers () =
  Helpers.clear_root state
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ready to start"; af "Root path deleted."]
  >>= fun () ->
  let block_interval = 1 in
  let (protocol, baker_list) =
    let d = protocol in
    let open Tezos_protocol in
    let bakers = List.take d.bootstrap_accounts bakers in
    ( {
        d with
        time_between_blocks = [block_interval; 0];
        bootstrap_accounts =
          List.map d.bootstrap_accounts ~f:(fun (n, v) ->
              if List.exists bakers ~f:(fun baker -> n = fst baker) then (n, v)
              else (n, 1_000L));
      },
      bakers )
  in
  let net_size = 3 in
  let topology = Test_scenario.Topology.(mesh "Simple" net_size) in
  let all_nodes =
    Test_scenario.Topology.build ~protocol ~exec:node_exec topology ?base_port
  in
  Helpers.dump_connections state all_nodes
  >>= fun () ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes:all_nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]) ;
  Test_scenario.Network.(start_up state ~client_exec (make all_nodes))
  >>= fun () ->
  let baker nth_node =
    let nth_baker = nth_node mod List.length baker_list in
    let key_name = sprintf "b%d" nth_baker in
    let node = List.nth_exn all_nodes nth_node in
    let client = Tezos_client.of_node node ~exec:client_exec in
    let baker_account = List.nth_exn baker_list nth_baker in
    let bak =
      Tezos_client.Keyed.make
        client
        ~key_name
        ~secret_key:(Tezos_protocol.Account.private_key (fst baker_account))
    in
    Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak)
  in
  baker 0
  >>= fun (client_0, baker_0) ->
  baker 1
  >>= fun (client_1, baker_1) ->
  baker 2
  >>= fun (client_2, baker_2) ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      arbitrary_commands_for_each_and_all_clients
        state
        ~clients:[client_0; client_1; client_2]) ;
  Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config ->
      Tezos_client.rpc
        state
        ~client:client_0
        `Get
        ~path:"/chains/main/chain_id"
      >>= fun chain_id_json ->
      let network_id =
        match chain_id_json with `String s -> s | _ -> assert false
      in
      Kiln.Configuration_directory.generate
        state
        kiln_config
        ~peers:
          (List.map all_nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port))
        ~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol)
        ~nodes:
          (List.map all_nodes ~f:(fun {Tezos_node.rpc_port; _} ->
               sprintf "http://localhost:%d" rpc_port))
        ~bakers:
          (List.map
             protocol.Tezos_protocol.bootstrap_accounts
             ~f:(fun (account, _) ->
               Tezos_protocol.Account.(name account, pubkey_hash account)))
        ~network_string:network_id
        ~node_exec
        ~client_exec
      >>= fun () ->
      return EF.(wf "Kiln was configured at `%s`" kiln_config.path))
  >>= fun _ ->
  let bake msg baker = Tezos_client.Keyed.bake state baker msg in
  List.fold
    (List.init (starting_level - 1) ~f:(fun n -> n))
    ~init:(return ()) (* We are already at level 1, we bake 7 times: *)
    ~f:(fun pm n ->
      pm
      >>= fun () ->
      bake
        (sprintf "first bakes: [%d/%d]" (n + 1) (starting_level - 1))
        baker_0)
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to starting_level)
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "Clients ready";
        af "Node 0 baked %d times." (starting_level - 1);
        af "All nodes should be at level %d." starting_level ]
  >>= fun () ->
  return (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2)

let wait_for_operation_in_mempools state ~nodes:all_nodes ~kind ~client_exec
    how =
  let (init, combine) =
    match how with `At_least_one -> (false, ( || )) | `All -> (true, ( && ))
  in
  Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ ->
      List.fold ~init:(return init) all_nodes ~f:(fun prev_m node ->
          prev_m
          >>= fun prev ->
          let client = Tezos_client.of_node node ~exec:client_exec in
          Tezos_client.mempool_has_operation state ~client ~kind
          >>= fun client_result -> return (combine client_result prev))
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf "Waiting for %S to show up in the mempool" kind)))

let simple_double_baking ~starting_level ?generate_kiln_config ~state ~protocol
    ~base_port node_exec client_exec () =
  little_mesh_with_bakers
    ~bakers:1
    ~protocol
    state
    ~node_exec
    ~client_exec
    ()
    ~base_port
    ~starting_level
    ?generate_kiln_config
  >>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) ->
  let kill_nth nth = List.nth_exn all_nodes nth |> Helpers.kill_node state in
  let restart_nth nth =
    List.nth_exn all_nodes nth |> Helpers.restart_node ~client_exec state
  in
  let number_of_lonely_bakes = 1 in
  kill_nth 1
  >>= fun () ->
  kill_nth 2
  >>= fun () ->
  Loop.n_times (number_of_lonely_bakes - 1) (fun _ ->
      Tezos_client.Keyed.bake state baker_0 "Bake-on-0")
  >>= fun () ->
  (* Bake one block less and inject an operation to generate a different
     block's hash *)
  Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_0 "Bake-on-0"
  >>= fun () ->
  Tezos_client.get_block_header state ~client:client_0 `Head
  >>= fun baking_0_header ->
  (* This baking will have better fitness so other nodes will have to fetch it. *)
  Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
  >>= fun () ->
  System.sleep 1.
  >>= fun () ->
  kill_nth 0
  >>= fun () ->
  restart_nth 1
  >>= fun () ->
  restart_nth 2
  >>= fun () ->
  Loop.n_times number_of_lonely_bakes (fun _ ->
      Tezos_client.Keyed.bake state baker_1 "Bake-on-1")
  >>= fun () ->
  Tezos_client.get_block_header state ~client:client_1 `Head
  >>= fun baking_1_header ->
  restart_nth 0
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_0 "Bake-on-0"
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`At_least (starting_level + number_of_lonely_bakes + 1))
  >>= fun () ->
  Tezos_client.rpc
    state
    ~client:client_1
    `Get
    ~path:"/chains/main/blocks/head/hash"
  >>= fun head_hash_json ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "About to forge";
        ef_json "Baking 0" baking_0_header;
        ef_json "Baking 1" baking_1_header;
        ef_json "Head hash" head_hash_json ]
  >>= fun () ->
  Tezos_client.Keyed.forge_and_inject
    state
    baker_1
    ~json:
      (let clean header =
         let open Jqo in
         remove_field header ~name:"hash"
         |> remove_field ~name:"chain_id"
         |> remove_field ~name:"protocol"
       in
       `O
         [ ("branch", head_hash_json);
           ( "contents",
             `A
               [ `O
                   [ ("kind", `String "double_baking_evidence");
                     ("bh1", clean baking_0_header);
                     ("bh2", clean baking_1_header) ] ] ) ])
  >>= fun result ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "Waiting for accuser to notice double baking";
        ef_json "Result of injection" result;
        af
          "All nodes reaching level %d"
          (starting_level + number_of_lonely_bakes + 1) ]
  >>= fun () ->
  wait_for_operation_in_mempools
    state
    ~nodes:all_nodes
    ~kind:"double_baking_evidence"
    ~client_exec
    `All
  >>= fun () ->
  Tezos_client.Keyed.bake
    state
    baker_2
    (sprintf "all at lvl %d" (starting_level + number_of_lonely_bakes + 1))
  >>= fun () ->
  let last_level = starting_level + number_of_lonely_bakes + 2 in
  Interactive_test.Pauser.generic
    state
    EF.[af "Just baked what's the level? Vs %d" last_level]
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to last_level)
  >>= fun () ->
  Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
      Tezos_client.block_has_operation
        state
        ~client:client_2
        ~level:last_level
        ~kind:"double_baking_evidence"
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf
                 "Waiting for accusation to show up in block %d"
                 last_level)))
  >>= fun () -> say state EF.(af "Test done.")

let find_endorsement_in_mempool state ~client =
  Helpers.wait_for state ~attempts:4 ~seconds:2. (fun _ ->
      Tezos_client.find_applied_in_mempool state ~client ~f:(fun o ->
          Jqo.field o ~k:"contents"
          |> Jqo.list_exists ~f:(fun op ->
                 (* Dbg.e EF.(ef_json "op" op) ; *)
                 Jqo.field op ~k:"kind" = `String "endorsement"))
      >>= function
      | None ->
          return (`Not_done (sprintf "No endorsement so far"))
      | Some e ->
          return (`Done e))

let simple_double_endorsement ~starting_level ?generate_kiln_config ~state
    ~protocol ~base_port node_exec client_exec () =
  little_mesh_with_bakers
    ~bakers:2
    ~protocol
    state
    ~node_exec
    ~client_exec
    ()
    ~starting_level
    ~base_port
    ?generate_kiln_config
  >>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) ->
  (* 2 bakers ⇒ baker_0 and baker_2 are for the same key on ≠ nodes *)
  assert (
    Tezos_client.Keyed.(
      baker_0.key_name = baker_2.key_name
      && baker_0.secret_key = baker_2.secret_key) ) ;
  let node_0 = List.nth_exn all_nodes 0 in
  let node_1 = List.nth_exn all_nodes 1 in
  let node_2 = List.nth_exn all_nodes 2 in
  let baker_1_n0 =
    let open Tezos_client.Keyed in
    let {key_name; secret_key; _} = baker_1 in
    make client_0 ~key_name ~secret_key
  in
  Tezos_client.Keyed.initialize state baker_1_n0
  >>= fun _ ->
  Helpers.kill_node state node_1
  >>= fun () ->
  Helpers.kill_node state node_2
  >>= fun () ->
  (* Inject an operation to generate a different block's hash *)
  Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_0 "baker-0 baking with node 0"
  >>= fun () ->
  Tezos_client.Keyed.endorse state baker_0 "baker-0 endorsing with node 0"
  >>= fun () ->
  find_endorsement_in_mempool state ~client:client_0
  >>= fun endorsement_0 ->
  Tezos_client.Keyed.endorse state baker_1_n0 "baker-1 endorsing with node 0"
  >>= fun () ->
  Helpers.kill_node state node_0
  >>= fun () ->
  Helpers.restart_node state node_2 ~client_exec
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_2 "baker-0 baking with node 2"
  >>= fun () ->
  Tezos_client.Keyed.endorse state baker_2 "baker-0 endorsing with node 2"
  >>= fun () ->
  find_endorsement_in_mempool state ~client:client_2
  >>= fun endorsement_1 ->
  say
    state
    EF.(
      list
        [ ef_json "Endorsement 0:" endorsement_0;
          ef_json "Endorsement 1:" endorsement_1 ])
  >>= fun () ->
  Helpers.restart_node state node_1 ~client_exec
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    [node_1; node_2]
    (`Equal_to (starting_level + 1))
  >>= fun () ->
  Helpers.restart_node state node_0 ~client_exec
  >>= fun () ->
  (* TODO: understand why this kick in the butt is necessary for node
     2 (seems like the node was not getting to level starting+2 without
     this). *)
  Helpers.kill_node state node_2
  >>= fun () ->
  Helpers.restart_node state node_2 ~client_exec
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to (starting_level + 1))
  >>= fun () ->
  Tezos_client.rpc
    state
    ~client:client_1
    `Get
    ~path:"/chains/main/blocks/head/hash"
  >>= fun head_hash_json ->
  let double_endorsement =
    let transform_endorsement endorsement =
      let branch = Jqo.field ~k:"branch" endorsement in
      let signature = Jqo.field ~k:"signature" endorsement in
      let contents =
        match Jqo.field ~k:"contents" endorsement with
        | `A [one] ->
            one
        | _ ->
            assert false
      in
      `O
        [("branch", branch); ("operations", contents); ("signature", signature)]
    in
    let inlined_endorsement_1 = transform_endorsement endorsement_0 in
    let inlined_endorsement_2 = transform_endorsement endorsement_1 in
    `O
      [ ("branch", head_hash_json);
        ( "contents",
          `A
            [ `O
                [ ("kind", `String "double_endorsement_evidence");
                  ("op1", inlined_endorsement_1);
                  ("op2", inlined_endorsement_2) ] ] ) ]
  in
  Interactive_test.Pauser.generic
    state
    EF.[ef_json "About to forge" double_endorsement]
  >>= fun () ->
  Tezos_client.Keyed.forge_and_inject state baker_1 ~json:double_endorsement
  >>= fun result ->
  Interactive_test.Pauser.generic
    state
    EF.[ef_json "Result of injection" result]
  >>= fun () ->
  wait_for_operation_in_mempools
    state
    ~nodes:[node_1]
    ~kind:"double_endorsement_evidence"
    ~client_exec
    `All
  >>= fun () ->
  let last_level = starting_level + 2 in
  Tezos_client.Keyed.bake state baker_1 (sprintf "level %d" last_level)
  >>= fun () ->
  Tezos_client.Keyed.endorse
    state
    baker_1
    (sprintf "endorse level %d" last_level)
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to last_level)
  >>= fun () ->
  Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
      (* We check that client-2 sees the evidence from baker-1 *)
      Tezos_client.block_has_operation
        state
        ~client:client_2
        ~level:last_level
        ~kind:"double_endorsement_evidence"
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf
                 "Waiting for accusation to show up in block %d"
                 last_level)))
  >>= fun () -> say state EF.(af "Test done.")

let with_accusers ~state ~protocol ~base_port node_exec accuser_exec
    client_exec () =
  Helpers.clear_root state
  >>= fun () ->
  let block_interval = 2 in
  let (protocol, baker_0_account) =
    let d = protocol in
    let open Tezos_protocol in
    let baker = List.hd_exn d.bootstrap_accounts in
    ( {
        d with
        time_between_blocks = [block_interval; block_interval * 2];
        bootstrap_accounts =
          List.map d.bootstrap_accounts ~f:(fun (n, v) ->
              if n = fst baker then (n, v) else (n, 1_000L));
      },
      baker )
  in
  let topology =
    Test_scenario.Topology.(
      net_in_the_middle "AT-" (mesh "Mid" 3) (mesh "Main" 4) (mesh "Acc" 4))
  in
  let (mesh_nodes, intermediary_nodes, accuser_nodes) =
    Test_scenario.Topology.build ~protocol ~exec:node_exec topology ~base_port
  in
  let all_nodes = mesh_nodes @ intermediary_nodes @ accuser_nodes in
  Helpers.dump_connections state all_nodes
  >>= fun () ->
  Test_scenario.Network.(start_up state ~client_exec (make all_nodes))
  >>= fun () ->
  let start_accuser nod =
    let client = Tezos_client.of_node nod ~exec:client_exec in
    let acc = Tezos_daemon.accuser_of_node ~exec:accuser_exec ~client nod in
    Running_processes.start state (Tezos_daemon.process acc ~state)
    >>= fun _ -> return ()
  in
  List_sequential.iter accuser_nodes ~f:start_accuser
  >>= fun () ->
  let key_name = "b0" in
  let baker nth =
    let node = List.nth_exn all_nodes nth in
    let client = Tezos_client.of_node node ~exec:client_exec in
    let bak =
      Tezos_client.Keyed.make
        client
        ~key_name
        ~secret_key:(Tezos_protocol.Account.private_key (fst baker_0_account))
    in
    Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak)
  in
  baker 0
  >>= fun (client_0, baker_0) ->
  baker 1
  >>= fun (client_1, baker_1) ->
  baker 2
  >>= fun (client_2, baker_2) ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes:all_nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~clients:[client_0; client_1; client_2]) ;
  let pause ?force msgs = Interactive_test.Pauser.generic state ?force msgs in
  let starting_level = 10 in
  List.fold
    (List.init (starting_level - 1) ~f:(fun n -> n))
    ~init:(return ()) (* We are already at level 1, we bake 7 times: *)
    ~f:(fun pm n ->
      pm
      >>= fun () ->
      Tezos_client.Keyed.bake
        state
        baker_0
        (sprintf "first bakes: [%d/%d]" (n + 1) (starting_level - 1)))
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to starting_level)
  >>= fun () ->
  pause
    EF.
      [ af "Two clients ready";
        af "Node 0 baked %d times." (starting_level - 1);
        af "All nodes should be at level %d." starting_level ]
  >>= fun () ->
  let transfer _msg client =
    let dest =
      List.random_element_exn protocol.Tezos_protocol.bootstrap_accounts
      |> fst |> Tezos_protocol.Account.pubkey_hash
    in
    Tezos_client.successful_client_cmd
      state
      ~client
      [ "--wait";
        "none";
        "transfer";
        "1";
        "from";
        key_name;
        "to";
        dest;
        "--fee";
        "0.05" ]
    >>= fun res ->
    say
      state
      EF.(
        desc
          (af "Successful transfer (%s):" client.Tezos_client.id)
          (ocaml_string_list res#out))
  in
  List_sequential.iter intermediary_nodes ~f:(fun x ->
      Helpers.kill_node state x)
  >>= fun () ->
  let kill_all_but nodes iths =
    List_sequential.iteri nodes ~f:(fun ith n ->
        if List.mem iths ith ~equal:Int.equal then return ()
        else Helpers.kill_node state n)
  in
  let kill_nth_node nodes nth =
    Helpers.kill_node
      state
      (Option.value_exn ~message:"kill_nth_node" (List.nth nodes nth))
  in
  let restart_nth_node nodes nth =
    Helpers.restart_node
      state
      ~client_exec
      (Option.value_exn ~message:"restart_nth_node" (List.nth nodes nth))
  in
  let get_block_header ~client block =
    let path =
      sprintf
        "/chains/main/blocks/%s/header"
        (match block with `Head -> "head" | `Level i -> Int.to_string i)
    in
    Tezos_client.rpc state ~client `Get ~path
  in
  kill_all_but mesh_nodes [0]
  >>= fun () ->
  let number_of_lonely_bakes = 1 in
  pause EF.[af "Node 0 is the only one alive"]
  >>= fun () ->
  transfer "node0 only alive" client_0
  >>= fun () ->
  Loop.n_times number_of_lonely_bakes (fun n ->
      Tezos_client.Keyed.bake state baker_0 (sprintf "n0 only alive: %d" n))
  >>= fun () ->
  get_block_header ~client:client_0 `Head
  >>= fun _baking_0_header ->
  Tezos_client.Keyed.endorse state baker_0 "self-endorsing"
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_0 "baking self-endorsement"
  >>= fun () ->
  kill_nth_node mesh_nodes 0
  >>= fun () ->
  restart_nth_node mesh_nodes 1
  >>= fun () ->
  transfer "node1 only one alive" client_1
  >>= fun () ->
  Loop.n_times number_of_lonely_bakes (fun _ ->
      Tezos_client.Keyed.bake state baker_1 "after transfer")
  >>= fun () ->
  get_block_header ~client:client_1 `Head
  >>= fun _baking_1_header ->
  kill_nth_node mesh_nodes 1
  >>= fun () ->
  pause
    EF.
      [ af "Node 0 was killed";
        af "Node 1 was restarted";
        af "Node 1 transfered";
        af "Node 1 baked";
        af "Node 1 was killed" ]
  >>= fun () ->
  List.fold ~init:(return ()) intermediary_nodes ~f:(fun prev x ->
      prev >>= fun () -> Helpers.restart_node state ~client_exec x)
  >>= fun () ->
  let node_0 = List.nth_exn mesh_nodes 0 in
  let except_0 l = List.filter l ~f:Tezos_node.(fun n -> n.id <> node_0.id) in
  List_sequential.iter
    (except_0 mesh_nodes)
    ~f:(Helpers.restart_node state ~client_exec)
  >>= fun () ->
  pause EF.[af "All nodes restarted Except 0"]
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    (except_0 all_nodes)
    (`At_least (starting_level + number_of_lonely_bakes))
  >>= fun () ->
  Helpers.restart_node state ~client_exec node_0
  >>= fun () ->
  pause EF.[af "Restarted 0"]
  >>= fun () ->
  Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ ->
      List.fold ~init:(return false) accuser_nodes ~f:(fun prev_m node ->
          prev_m
          >>= fun prev ->
          let client = Tezos_client.of_node node ~exec:client_exec in
          Tezos_client.mempool_has_operation
            state
            ~client
            ~kind:"double_baking_evidence"
          >>= fun client_result -> return (client_result || prev))
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf "Waiting for accusation to show up in the mempool")))
  >>= fun () ->
  Tezos_client.Keyed.bake
    state
    baker_2
    (sprintf "all at lvl %d" (starting_level + number_of_lonely_bakes + 1))
  >>= fun () ->
  Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
      let level = starting_level + number_of_lonely_bakes + 2 in
      Tezos_client.block_has_operation
        state
        ~client:client_2
        ~level
        ~kind:"double_baking_evidence"
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf "Waiting for accusation to show up in block %d" level)))
  >>= fun () ->
  pause
    EF.
      [ af "One more baking (level should include accusation)";
        af
          "All nodes reaching level %d"
          (starting_level + number_of_lonely_bakes + 2) ]
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_1 "a couple more"
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`At_least (starting_level + number_of_lonely_bakes + 1))

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  let pf fmt = ksprintf (fun s -> `P s) fmt in
  let tests =
    let test variant name title man = (variant, name, title, man) in
    [ test
        `With_accusers
        "with-accusers"
        "Network With Accusers"
        (pf
           "This test builds a network with 3 interconnected meshes: Main, \
            Intermediate, and Accuser.");
      test
        `Simple_double_baking
        "simple-double-baking"
        "Simple Network With Manual Double Baking Accusation"
        (pf
           "This test builds a very simple 3-piece network, makes a baker \
            double bake and $(i,manually) inserts a double-baking accusation.");
      test
        `Simple_double_endorsing
        "simple-double-endorsing"
        "Simple Network With Manual Double Endorsing Accusation"
        (pf
           "This test builds a very simple 3-piece network, makes a baker \
            double endorse and $(i,manually) inserts a double-baking \
            accusation.") ]
  in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun test
             base_port
             (`Starting_level starting_level)
             bnod
             bcli
             accex
             generate_kiln_config
             protocol
             state
             ->
          let checks () =
            let acc = if test = `With_accusers then [accex] else [] in
            Helpers.System_dependencies.precheck
              state
              `Or_fail
              ~executables:(acc @ [bnod; bcli])
          in
          let actual_test () =
            match test with
            | `With_accusers ->
                checks ()
                >>= fun () ->
                with_accusers ~state bnod accex bcli ~base_port () ~protocol
            | `Simple_double_baking ->
                checks ()
                >>= fun () ->
                simple_double_baking
                  ~state
                  bnod
                  bcli
                  ~base_port
                  ?generate_kiln_config
                  ~starting_level
                  ~protocol
                  ()
            | `Simple_double_endorsing ->
                checks ()
                >>= fun () ->
                simple_double_endorsement
                  ~state
                  bnod
                  bcli
                  ~base_port
                  ?generate_kiln_config
                  ~starting_level
                  ~protocol
                  ()
          in
          (state, Interactive_test.Pauser.run_test ~pp_error state actual_test))
    $ Arg.(
        required
          (pos
             0
             (some (enum (List.map tests ~f:(fun (v, n, _, _) -> (n, v)))))
             None
             (info [] ~docv:"TEST-NAME" ~doc:"Choose which test to run.")))
    $ Arg.(
        value & opt int 30_000
        & info ["base-port"] ~doc:"Base port number to build upon.")
    $ Arg.(
        pure (fun l -> `Starting_level l)
        $ value
            (opt
               int
               5
               (info
                  ["starting-level"]
                  ~doc:
                    "Initial block-level to reach before actually starting \
                     the test.")))
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Tezos_executable.cli_term `Accuser "tezos"
    $ Kiln.Configuration_directory.cli_term ()
    $ Tezos_protocol.cli_term ()
    $ Test_command_line.cli_state ~name:"accusing" () )
    (let doc = "Sandbox networks which record double-bakings." in
     let man : Manpage.block list =
       [ `S "ACCUSATION TESTS";
         pf
           "This command provides %d tests which use network sandboxes to \
            make double-bakings and double-endorsements happen."
           (List.length tests);
         `Blocks
           (List.map tests ~f:(fun (_, n, tit, m) ->
                `Blocks [pf "* $(b,`%s`): $(i,%s)." n tit; `Noblank; m])) ]
     in
     info ~man ~doc "accusations")
src/bin_sandbox/command_accusations.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition default_attempts : Z := 35.

Definition little_mesh_with_bakers {A B C D E F G H : Type}
  (base_port : option A) (generate_kiln_config : option B) (state : C)
  (protocol : D) (starting_level : Z) (node_exec : E) (client_exec : F)
  (bakers : G) (function_parameter : unit) : H :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star state
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let block_interval := 1 in
                match
                  let d := protocol in
                  op_star_t_y_p_e_minus_e_r_r_o_r_star with
                | (protocol, baker_list) =>
                  let net_size := 3 in
                  let topology := op_star_t_y_p_e_minus_e_r_r_o_r_star in
                  let all_nodes :=
                    op_star_t_y_p_e_minus_e_r_r_o_r_star protocol node_exec
                      topology base_port in
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state all_nodes)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star state
                          op_star_t_y_p_e_minus_e_r_r_o_r_star;
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              let baker {I : Type} (nth_node : Z) : I :=
                                let nth_baker :=
                                  Z.modulo nth_node
                                    (OCaml.List.length baker_list) in
                                let key_name :=
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    "b%d" % string nth_baker in
                                let node :=
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star all_nodes
                                    nth_node in
                                let client :=
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star node
                                    client_exec in
                                let baker_account :=
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    baker_list nth_baker in
                                let bak :=
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star client
                                    key_name
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (fst baker_account)) in
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                    bak)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (client, bak)
                                    end) in
                              op_star_t_y_p_e_minus_e_r_r_o_r_star (baker 0)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (client_0, baker_0) =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (baker 1)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (client_1, baker_1) =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (baker 2)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | (client_2, baker_2) =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  state
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star;
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    generate_kiln_config
                                                    (fun kiln_config =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          state client_0 variant
                                                          "/chains/main/chain_id"
                                                            % string)
                                                        (fun chain_id_json =>
                                                          let network_id :=
                                                            match chain_id_json
                                                              with
                                                            | String s => s
                                                            | _ => false
                                                            end in
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              state kiln_config
                                                              (List.map
                                                                all_nodes
                                                                expected_argument
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | _ =>
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  end))
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                state protocol)
                                                              (List.map
                                                                all_nodes
                                                                expected_argument
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | _ =>
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      "http://localhost:%d"
                                                                        % string
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  end))
                                                              (List.map
                                                                (Tezos_protocol.bootstrap_accounts
                                                                  protocol)
                                                                expected_argument
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | (account, _)
                                                                    =>
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  end))
                                                              network_id
                                                              node_exec
                                                              client_exec)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              end))))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | _ =>
                                                      let bake {I J K : Type}
                                                        (msg : I) (baker : J)
                                                        : K :=
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          state baker msg in
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (Stdlib.List.init
                                                            (Z.sub
                                                              starting_level 1)
                                                            expected_argument
                                                            (fun n => n))
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            tt)
                                                          (fun pm =>
                                                            fun n =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                pm
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    bake
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        "first bakes: [%d/%d]"
                                                                          %
                                                                          string
                                                                        (Z.add n
                                                                          1)
                                                                        (Z.sub
                                                                          starting_level
                                                                          1))
                                                                      baker_0
                                                                  end)))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                state
                                                                default_attempts
                                                                8 all_nodes
                                                                variant)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      state
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | tt =>
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          (all_nodes,
                                                                            client_0,
                                                                            baker_0,
                                                                            client_1,
                                                                            baker_1,
                                                                            client_2,
                                                                            baker_2)
                                                                      end)
                                                                end)
                                                          end)
                                                    end)
                                              end)
                                        end)
                                  end)
                            end)
                      end)
                end
              end)
        end)
  end.

Definition wait_for_operation_in_mempools {A B C D E : Type}
  (state : A) (all_nodes : B) (kind : C) (client_exec : D) (how : variant)
  : E :=
  match
    match how with
    | At_least_one => (false, orb)
    | All => (true, andb)
    end with
  | (init, combine) =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star state default_attempts 8
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star init) all_nodes
              (fun prev_m =>
                fun node =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star prev_m
                    (fun prev =>
                      let client :=
                        op_star_t_y_p_e_minus_e_r_r_o_r_star node client_exec in
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star state client kind)
                        (fun client_result =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (combine client_result prev)))))
            (fun function_parameter =>
              match function_parameter with
              | true => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
              | false => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
              end)
        end)
  end.

Definition simple_double_baking {A B C D E F G : Type}
  (starting_level : Z) (generate_kiln_config : option A) (state : B)
  (protocol : C) (base_port : D) (node_exec : E) (client_exec : F)
  (function_parameter : unit) : G :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (little_mesh_with_bakers (Some base_port) generate_kiln_config state
        protocol starting_level node_exec client_exec 1 tt)
      (fun function_parameter =>
        match function_parameter with
        | (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2)
          =>
          let kill_nth {H I : Type} (nth : H) : I :=
            OCaml.Stdlib.reverse_apply
              (op_star_t_y_p_e_minus_e_r_r_o_r_star all_nodes nth)
              (op_star_t_y_p_e_minus_e_r_r_o_r_star state) in
          let restart_nth {H I : Type} (nth : H) : I :=
            OCaml.Stdlib.reverse_apply
              (op_star_t_y_p_e_minus_e_r_r_o_r_star all_nodes nth)
              (op_star_t_y_p_e_minus_e_r_r_o_r_star client_exec state) in
          let number_of_lonely_bakes := 1 in
          op_star_t_y_p_e_minus_e_r_r_o_r_star (kill_nth 1)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star (kill_nth 2)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (Z.sub number_of_lonely_bakes 1)
                          (fun function_parameter =>
                            match function_parameter with
                            | _ =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star state baker_0
                                "Bake-on-0" % string
                            end))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                baker_0 "endorsing lonely bake-on-0" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                      baker_0 "Bake-on-0" % string)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            state client_0 variant)
                                          (fun baking_0_header =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                state baker_0
                                                "endorsing lonely bake-on-0" %
                                                  string)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      1)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (kill_nth 0)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (restart_nth 1)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (restart_nth
                                                                        2)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              number_of_lonely_bakes
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  _
                                                                                  =>
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    state
                                                                                    baker_1
                                                                                    "Bake-on-1"
                                                                                      %
                                                                                      string
                                                                                end))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    state
                                                                                    client_1
                                                                                    variant)
                                                                                  (fun
                                                                                    baking_1_header
                                                                                    =>
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      (restart_nth
                                                                                        0)
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          tt
                                                                                          =>
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              state
                                                                                              baker_0
                                                                                              "Bake-on-0"
                                                                                                %
                                                                                                string)
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                tt
                                                                                                =>
                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    state
                                                                                                    default_attempts
                                                                                                    8
                                                                                                    all_nodes
                                                                                                    variant)
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    match
                                                                                                      function_parameter
                                                                                                      with
                                                                                                    |
                                                                                                      tt
                                                                                                      =>
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          state
                                                                                                          client_1
                                                                                                          variant
                                                                                                          "/chains/main/blocks/head/hash"
                                                                                                            %
                                                                                                            string)
                                                                                                        (fun
                                                                                                          head_hash_json
                                                                                                          =>
                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              state
                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              match
                                                                                                                function_parameter
                                                                                                                with
                                                                                                              |
                                                                                                                tt
                                                                                                                =>
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    state
                                                                                                                    baker_1
                                                                                                                    (let
                                                                                                                      clean
                                                                                                                      {H
                                                                                                                      I
                                                                                                                      :
                                                                                                                      Type}
                                                                                                                      (header
                                                                                                                      :
                                                                                                                      H)
                                                                                                                      : I :=
                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      in
                                                                                                                    variant))
                                                                                                                  (fun
                                                                                                                    result
                                                                                                                    =>
                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                        state
                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                      (fun
                                                                                                                        function_parameter
                                                                                                                        =>
                                                                                                                        match
                                                                                                                          function_parameter
                                                                                                                          with
                                                                                                                        |
                                                                                                                          tt
                                                                                                                          =>
                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                            (wait_for_operation_in_mempools
                                                                                                                              state
                                                                                                                              all_nodes
                                                                                                                              "double_baking_evidence"
                                                                                                                                %
                                                                                                                                string
                                                                                                                              client_exec
                                                                                                                              variant)
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              match
                                                                                                                                function_parameter
                                                                                                                                with
                                                                                                                              |
                                                                                                                                tt
                                                                                                                                =>
                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    state
                                                                                                                                    baker_2
                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      "all at lvl %d"
                                                                                                                                        %
                                                                                                                                        string
                                                                                                                                      (Z.add
                                                                                                                                        (Z.add
                                                                                                                                          starting_level
                                                                                                                                          number_of_lonely_bakes)
                                                                                                                                        1)))
                                                                                                                                  (fun
                                                                                                                                    function_parameter
                                                                                                                                    =>
                                                                                                                                    match
                                                                                                                                      function_parameter
                                                                                                                                      with
                                                                                                                                    |
                                                                                                                                      tt
                                                                                                                                      =>
                                                                                                                                      let
                                                                                                                                        last_level :=
                                                                                                                                        Z.add
                                                                                                                                          (Z.add
                                                                                                                                            starting_level
                                                                                                                                            number_of_lonely_bakes)
                                                                                                                                          2
                                                                                                                                        in
                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          state
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          match
                                                                                                                                            function_parameter
                                                                                                                                            with
                                                                                                                                          |
                                                                                                                                            tt
                                                                                                                                            =>
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                state
                                                                                                                                                default_attempts
                                                                                                                                                8
                                                                                                                                                all_nodes
                                                                                                                                                variant)
                                                                                                                                              (fun
                                                                                                                                                function_parameter
                                                                                                                                                =>
                                                                                                                                                match
                                                                                                                                                  function_parameter
                                                                                                                                                  with
                                                                                                                                                |
                                                                                                                                                  tt
                                                                                                                                                  =>
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      state
                                                                                                                                                      10
                                                                                                                                                      4
                                                                                                                                                      (fun
                                                                                                                                                        function_parameter
                                                                                                                                                        =>
                                                                                                                                                        match
                                                                                                                                                          function_parameter
                                                                                                                                                          with
                                                                                                                                                        |
                                                                                                                                                          _
                                                                                                                                                          =>
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                              state
                                                                                                                                                              client_2
                                                                                                                                                              last_level
                                                                                                                                                              "double_baking_evidence"
                                                                                                                                                                %
                                                                                                                                                                string)
                                                                                                                                                            (fun
                                                                                                                                                              function_parameter
                                                                                                                                                              =>
                                                                                                                                                              match
                                                                                                                                                                function_parameter
                                                                                                                                                                with
                                                                                                                                                              |
                                                                                                                                                                true
                                                                                                                                                                =>
                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  variant
                                                                                                                                                              |
                                                                                                                                                                false
                                                                                                                                                                =>
                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  variant
                                                                                                                                                              end)
                                                                                                                                                        end))
                                                                                                                                                    (fun
                                                                                                                                                      function_parameter
                                                                                                                                                      =>
                                                                                                                                                      match
                                                                                                                                                        function_parameter
                                                                                                                                                        with
                                                                                                                                                      |
                                                                                                                                                        tt
                                                                                                                                                        =>
                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                          state
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      end)
                                                                                                                                                end)
                                                                                                                                          end)
                                                                                                                                    end)
                                                                                                                              end)
                                                                                                                        end))
                                                                                                              end))
                                                                                                    end)
                                                                                              end)
                                                                                        end))
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end)
                                                end))
                                      end)
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition find_endorsement_in_mempool {A B C : Type} (state : A) (client : B)
  : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star state 4 2
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
            (fun o =>
              OCaml.Stdlib.reverse_apply
                (op_star_t_y_p_e_minus_e_r_r_o_r_star o "contents" % string)
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (fun op =>
                    equiv_decb
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star op "kind" % string)
                      variant))))
          (fun function_parameter =>
            match function_parameter with
            | None => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
            | Some e => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
            end)
      end).

Definition simple_double_endorsement {A B C D E F G : Type}
  (starting_level : Z) (generate_kiln_config : option A) (state : B)
  (protocol : C) (base_port : D) (node_exec : E) (client_exec : F)
  (function_parameter : unit) : G :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (little_mesh_with_bakers (Some base_port) generate_kiln_config state
        protocol starting_level node_exec client_exec 2 tt)
      (fun function_parameter =>
        match function_parameter with
        | (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2)
          =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star;
          let node_0 := op_star_t_y_p_e_minus_e_r_r_o_r_star all_nodes 0 in
          let node_1 := op_star_t_y_p_e_minus_e_r_r_o_r_star all_nodes 1 in
          let node_2 := op_star_t_y_p_e_minus_e_r_r_o_r_star all_nodes 2 in
          let baker_1_n0 := op_star_t_y_p_e_minus_e_r_r_o_r_star in
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star state baker_1_n0)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state node_1)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star state node_2)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                baker_0 "endorsing lonely bake-on-0" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                      baker_0
                                      "baker-0 baking with node 0" % string)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            state baker_0
                                            "baker-0 endorsing with node 0" %
                                              string)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (find_endorsement_in_mempool
                                                  state client_0)
                                                (fun endorsement_0 =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      state baker_1_n0
                                                      "baker-1 endorsing with node 0"
                                                        % string)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            state node_0)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  state node_2
                                                                  client_exec)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        state
                                                                        baker_2
                                                                        "baker-0 baking with node 2"
                                                                          %
                                                                          string)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              state
                                                                              baker_2
                                                                              "baker-0 endorsing with node 2"
                                                                                %
                                                                                string)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (find_endorsement_in_mempool
                                                                                    state
                                                                                    client_2)
                                                                                  (fun
                                                                                    endorsement_1
                                                                                    =>
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        state
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          tt
                                                                                          =>
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              state
                                                                                              node_1
                                                                                              client_exec)
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                tt
                                                                                                =>
                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    state
                                                                                                    default_attempts
                                                                                                    8
                                                                                                    (cons
                                                                                                      node_1
                                                                                                      (cons
                                                                                                        node_2
                                                                                                        []))
                                                                                                    variant)
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    match
                                                                                                      function_parameter
                                                                                                      with
                                                                                                    |
                                                                                                      tt
                                                                                                      =>
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          state
                                                                                                          node_0
                                                                                                          client_exec)
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          match
                                                                                                            function_parameter
                                                                                                            with
                                                                                                          |
                                                                                                            tt
                                                                                                            =>
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                state
                                                                                                                node_2)
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                match
                                                                                                                  function_parameter
                                                                                                                  with
                                                                                                                |
                                                                                                                  tt
                                                                                                                  =>
                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      state
                                                                                                                      node_2
                                                                                                                      client_exec)
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      match
                                                                                                                        function_parameter
                                                                                                                        with
                                                                                                                      |
                                                                                                                        tt
                                                                                                                        =>
                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                            state
                                                                                                                            default_attempts
                                                                                                                            8
                                                                                                                            all_nodes
                                                                                                                            variant)
                                                                                                                          (fun
                                                                                                                            function_parameter
                                                                                                                            =>
                                                                                                                            match
                                                                                                                              function_parameter
                                                                                                                              with
                                                                                                                            |
                                                                                                                              tt
                                                                                                                              =>
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  state
                                                                                                                                  client_1
                                                                                                                                  variant
                                                                                                                                  "/chains/main/blocks/head/hash"
                                                                                                                                    %
                                                                                                                                    string)
                                                                                                                                (fun
                                                                                                                                  head_hash_json
                                                                                                                                  =>
                                                                                                                                  let
                                                                                                                                    double_endorsement :=
                                                                                                                                    let
                                                                                                                                      transform_endorsement
                                                                                                                                      {H
                                                                                                                                      :
                                                                                                                                      Type}
                                                                                                                                      (endorsement
                                                                                                                                      :
                                                                                                                                      H)
                                                                                                                                      : variant :=
                                                                                                                                      let
                                                                                                                                        branch :=
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          "branch"
                                                                                                                                            %
                                                                                                                                            string
                                                                                                                                          endorsement
                                                                                                                                        in
                                                                                                                                      let
                                                                                                                                        signature :=
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          "signature"
                                                                                                                                            %
                                                                                                                                            string
                                                                                                                                          endorsement
                                                                                                                                        in
                                                                                                                                      let
                                                                                                                                        contents :=
                                                                                                                                        match
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            "contents"
                                                                                                                                              %
                                                                                                                                              string
                                                                                                                                            endorsement
                                                                                                                                          with
                                                                                                                                        |
                                                                                                                                          A
                                                                                                                                            (cons
                                                                                                                                              one
                                                                                                                                              [])
                                                                                                                                          =>
                                                                                                                                          one
                                                                                                                                        |
                                                                                                                                          _
                                                                                                                                          =>
                                                                                                                                          false
                                                                                                                                        end
                                                                                                                                        in
                                                                                                                                      variant
                                                                                                                                      in
                                                                                                                                    let
                                                                                                                                      inlined_endorsement_1 :=
                                                                                                                                      transform_endorsement
                                                                                                                                        endorsement_0
                                                                                                                                      in
                                                                                                                                    let
                                                                                                                                      inlined_endorsement_2 :=
                                                                                                                                      transform_endorsement
                                                                                                                                        endorsement_1
                                                                                                                                      in
                                                                                                                                    variant
                                                                                                                                    in
                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      state
                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      match
                                                                                                                                        function_parameter
                                                                                                                                        with
                                                                                                                                      |
                                                                                                                                        tt
                                                                                                                                        =>
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            state
                                                                                                                                            baker_1
                                                                                                                                            double_endorsement)
                                                                                                                                          (fun
                                                                                                                                            result
                                                                                                                                            =>
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                state
                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                              (fun
                                                                                                                                                function_parameter
                                                                                                                                                =>
                                                                                                                                                match
                                                                                                                                                  function_parameter
                                                                                                                                                  with
                                                                                                                                                |
                                                                                                                                                  tt
                                                                                                                                                  =>
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                    (wait_for_operation_in_mempools
                                                                                                                                                      state
                                                                                                                                                      (cons
                                                                                                                                                        node_1
                                                                                                                                                        [])
                                                                                                                                                      "double_endorsement_evidence"
                                                                                                                                                        %
                                                                                                                                                        string
                                                                                                                                                      client_exec
                                                                                                                                                      variant)
                                                                                                                                                    (fun
                                                                                                                                                      function_parameter
                                                                                                                                                      =>
                                                                                                                                                      match
                                                                                                                                                        function_parameter
                                                                                                                                                        with
                                                                                                                                                      |
                                                                                                                                                        tt
                                                                                                                                                        =>
                                                                                                                                                        let
                                                                                                                                                          last_level :=
                                                                                                                                                          Z.add
                                                                                                                                                            starting_level
                                                                                                                                                            2
                                                                                                                                                          in
                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                            state
                                                                                                                                                            baker_1
                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                              "level %d"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              last_level))
                                                                                                                                                          (fun
                                                                                                                                                            function_parameter
                                                                                                                                                            =>
                                                                                                                                                            match
                                                                                                                                                              function_parameter
                                                                                                                                                              with
                                                                                                                                                            |
                                                                                                                                                              tt
                                                                                                                                                              =>
                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  state
                                                                                                                                                                  baker_1
                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                    "endorse level %d"
                                                                                                                                                                      %
                                                                                                                                                                      string
                                                                                                                                                                    last_level))
                                                                                                                                                                (fun
                                                                                                                                                                  function_parameter
                                                                                                                                                                  =>
                                                                                                                                                                  match
                                                                                                                                                                    function_parameter
                                                                                                                                                                    with
                                                                                                                                                                  |
                                                                                                                                                                    tt
                                                                                                                                                                    =>
                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                        state
                                                                                                                                                                        default_attempts
                                                                                                                                                                        8
                                                                                                                                                                        all_nodes
                                                                                                                                                                        variant)
                                                                                                                                                                      (fun
                                                                                                                                                                        function_parameter
                                                                                                                                                                        =>
                                                                                                                                                                        match
                                                                                                                                                                          function_parameter
                                                                                                                                                                          with
                                                                                                                                                                        |
                                                                                                                                                                          tt
                                                                                                                                                                          =>
                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                              state
                                                                                                                                                                              10
                                                                                                                                                                              4
                                                                                                                                                                              (fun
                                                                                                                                                                                function_parameter
                                                                                                                                                                                =>
                                                                                                                                                                                match
                                                                                                                                                                                  function_parameter
                                                                                                                                                                                  with
                                                                                                                                                                                |
                                                                                                                                                                                  _
                                                                                                                                                                                  =>
                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                      state
                                                                                                                                                                                      client_2
                                                                                                                                                                                      last_level
                                                                                                                                                                                      "double_endorsement_evidence"
                                                                                                                                                                                        %
                                                                                                                                                                                        string)
                                                                                                                                                                                    (fun
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      =>
                                                                                                                                                                                      match
                                                                                                                                                                                        function_parameter
                                                                                                                                                                                        with
                                                                                                                                                                                      |
                                                                                                                                                                                        true
                                                                                                                                                                                        =>
                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                          variant
                                                                                                                                                                                      |
                                                                                                                                                                                        false
                                                                                                                                                                                        =>
                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                          variant
                                                                                                                                                                                      end)
                                                                                                                                                                                end))
                                                                                                                                                                            (fun
                                                                                                                                                                              function_parameter
                                                                                                                                                                              =>
                                                                                                                                                                              match
                                                                                                                                                                                function_parameter
                                                                                                                                                                                with
                                                                                                                                                                              |
                                                                                                                                                                                tt
                                                                                                                                                                                =>
                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                  state
                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                              end)
                                                                                                                                                                        end)
                                                                                                                                                                  end)
                                                                                                                                                            end)
                                                                                                                                                      end)
                                                                                                                                                end))
                                                                                                                                      end))
                                                                                                                            end)
                                                                                                                      end)
                                                                                                                end)
                                                                                                          end)
                                                                                                    end)
                                                                                              end)
                                                                                        end))
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end))
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition with_accusers {A B C D E F G : Type}
  (state : A) (protocol : B) (base_port : C) (node_exec : D) (accuser_exec : E)
  (client_exec : F) (function_parameter : unit) : G :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let block_interval := 2 in
          match
            let d := protocol in
            op_star_t_y_p_e_minus_e_r_r_o_r_star with
          | (protocol, baker_0_account) =>
            let topology := op_star_t_y_p_e_minus_e_r_r_o_r_star in
            match
              op_star_t_y_p_e_minus_e_r_r_o_r_star protocol node_exec topology
                base_port with
            | (mesh_nodes, intermediary_nodes, accuser_nodes) =>
              let all_nodes :=
                OCaml.Stdlib.app mesh_nodes
                  (OCaml.Stdlib.app intermediary_nodes accuser_nodes) in
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star state all_nodes)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let start_accuser {H I : Type} (nod : H) : I :=
                            let client :=
                              op_star_t_y_p_e_minus_e_r_r_o_r_star nod
                                client_exec in
                            let acc :=
                              op_star_t_y_p_e_minus_e_r_r_o_r_star accuser_exec
                                client nod in
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star acc state))
                              (fun function_parameter =>
                                match function_parameter with
                                | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star tt
                                end) in
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star accuser_nodes
                              start_accuser)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                let key_name := "b0" % string in
                                let baker {H I : Type} (nth : H) : I :=
                                  let node :=
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      all_nodes nth in
                                  let client :=
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star node
                                      client_exec in
                                  let bak :=
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star client
                                      key_name
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (fst baker_0_account)) in
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                      bak)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | _ =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (client, bak)
                                      end) in
                                op_star_t_y_p_e_minus_e_r_r_o_r_star (baker 0)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (client_0, baker_0) =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (baker 1)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (client_1, baker_1) =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (baker 2)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (client_2, baker_2) =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    state
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star;
                                                  let pause {H I J : Type}
                                                    (force : option H) (msgs :
                                                    I) : J :=
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      state force msgs in
                                                  let starting_level := 10 in
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (Stdlib.List.init
                                                        (Z.sub starting_level 1)
                                                        expected_argument
                                                        (fun n => n))
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        tt)
                                                      (fun pm =>
                                                        fun n =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            pm
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  state baker_0
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    "first bakes: [%d/%d]"
                                                                      % string
                                                                    (Z.add n 1)
                                                                    (Z.sub
                                                                      starting_level
                                                                      1))
                                                              end)))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            state
                                                            default_attempts 8
                                                            all_nodes variant)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (pause None
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    let transfer
                                                                      {H I J :
                                                                      Type}
                                                                      (_msg : H)
                                                                      (client :
                                                                      I) : J :=
                                                                      let
                                                                        dest :=
                                                                        OCaml.Stdlib.reverse_apply
                                                                          (OCaml.Stdlib.reverse_apply
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              (Tezos_protocol.bootstrap_accounts
                                                                                protocol))
                                                                            fst)
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        in
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          state
                                                                          client
                                                                          (cons
                                                                            "--wait"
                                                                              %
                                                                              string
                                                                            (cons
                                                                              "none"
                                                                                %
                                                                                string
                                                                              (cons
                                                                                "transfer"
                                                                                  %
                                                                                  string
                                                                                (cons
                                                                                  "1"
                                                                                    %
                                                                                    string
                                                                                  (cons
                                                                                    "from"
                                                                                      %
                                                                                      string
                                                                                    (cons
                                                                                      key_name
                                                                                      (cons
                                                                                        "to"
                                                                                          %
                                                                                          string
                                                                                        (cons
                                                                                          dest
                                                                                          (cons
                                                                                            "--fee"
                                                                                              %
                                                                                              string
                                                                                            (cons
                                                                                              "0.05"
                                                                                                %
                                                                                                string
                                                                                              [])))))))))))
                                                                        (fun res
                                                                          =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            state
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                      in
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        intermediary_nodes
                                                                        (fun x
                                                                          =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            state
                                                                            x))
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          let
                                                                            kill_all_but
                                                                            {H I
                                                                            J :
                                                                            Type}
                                                                            (nodes
                                                                            : H)
                                                                            (iths
                                                                            : I)
                                                                            : J :=
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              nodes
                                                                              (fun
                                                                                ith
                                                                                =>
                                                                                fun
                                                                                  n
                                                                                  =>
                                                                                  if
                                                                                    Stdlib.List.mem
                                                                                      iths
                                                                                      ith
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    then
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      tt
                                                                                  else
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      state
                                                                                      n)
                                                                            in
                                                                          let
                                                                            kill_nth_node
                                                                            {H I
                                                                            :
                                                                            Type}
                                                                            (nodes
                                                                            :
                                                                            list
                                                                              H)
                                                                            (nth
                                                                            : Z)
                                                                            : I :=
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              state
                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                "kill_nth_node"
                                                                                  %
                                                                                  string
                                                                                (Stdlib.List.nth
                                                                                  nodes
                                                                                  nth))
                                                                            in
                                                                          let
                                                                            restart_nth_node
                                                                            {H I
                                                                            :
                                                                            Type}
                                                                            (nodes
                                                                            :
                                                                            list
                                                                              H)
                                                                            (nth
                                                                            : Z)
                                                                            : I :=
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              state
                                                                              client_exec
                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                "restart_nth_node"
                                                                                  %
                                                                                  string
                                                                                (Stdlib.List.nth
                                                                                  nodes
                                                                                  nth))
                                                                            in
                                                                          let
                                                                            get_block_header
                                                                            {H I
                                                                            :
                                                                            Type}
                                                                            (client
                                                                            : H)
                                                                            (block
                                                                            :
                                                                            variant)
                                                                            : I :=
                                                                            let
                                                                              path :=
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                "/chains/main/blocks/%s/header"
                                                                                  %
                                                                                  string
                                                                                match
                                                                                  block
                                                                                  with
                                                                                |
                                                                                  Head
                                                                                  =>
                                                                                  "head"
                                                                                    %
                                                                                    string
                                                                                |
                                                                                  Level
                                                                                    i
                                                                                  =>
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    i
                                                                                end
                                                                              in
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              state
                                                                              client
                                                                              variant
                                                                              path
                                                                            in
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (kill_all_but
                                                                              mesh_nodes
                                                                              (cons
                                                                                0
                                                                                []))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                let
                                                                                  number_of_lonely_bakes :=
                                                                                  1
                                                                                  in
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (pause
                                                                                    None
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (transfer
                                                                                          "node0 only alive"
                                                                                            %
                                                                                            string
                                                                                          client_0)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            tt
                                                                                            =>
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                number_of_lonely_bakes
                                                                                                (fun
                                                                                                  n
                                                                                                  =>
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    state
                                                                                                    baker_0
                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      "n0 only alive: %d"
                                                                                                        %
                                                                                                        string
                                                                                                      n)))
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  tt
                                                                                                  =>
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (get_block_header
                                                                                                      client_0
                                                                                                      variant)
                                                                                                    (fun
                                                                                                      _baking_0_header
                                                                                                      =>
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          state
                                                                                                          baker_0
                                                                                                          "self-endorsing"
                                                                                                            %
                                                                                                            string)
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          match
                                                                                                            function_parameter
                                                                                                            with
                                                                                                          |
                                                                                                            tt
                                                                                                            =>
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                state
                                                                                                                baker_0
                                                                                                                "baking self-endorsement"
                                                                                                                  %
                                                                                                                  string)
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                match
                                                                                                                  function_parameter
                                                                                                                  with
                                                                                                                |
                                                                                                                  tt
                                                                                                                  =>
                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    (kill_nth_node
                                                                                                                      mesh_nodes
                                                                                                                      0)
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      match
                                                                                                                        function_parameter
                                                                                                                        with
                                                                                                                      |
                                                                                                                        tt
                                                                                                                        =>
                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                          (restart_nth_node
                                                                                                                            mesh_nodes
                                                                                                                            1)
                                                                                                                          (fun
                                                                                                                            function_parameter
                                                                                                                            =>
                                                                                                                            match
                                                                                                                              function_parameter
                                                                                                                              with
                                                                                                                            |
                                                                                                                              tt
                                                                                                                              =>
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                (transfer
                                                                                                                                  "node1 only one alive"
                                                                                                                                    %
                                                                                                                                    string
                                                                                                                                  client_1)
                                                                                                                                (fun
                                                                                                                                  function_parameter
                                                                                                                                  =>
                                                                                                                                  match
                                                                                                                                    function_parameter
                                                                                                                                    with
                                                                                                                                  |
                                                                                                                                    tt
                                                                                                                                    =>
                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                        number_of_lonely_bakes
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          match
                                                                                                                                            function_parameter
                                                                                                                                            with
                                                                                                                                          |
                                                                                                                                            _
                                                                                                                                            =>
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              state
                                                                                                                                              baker_1
                                                                                                                                              "after transfer"
                                                                                                                                                %
                                                                                                                                                string
                                                                                                                                          end))
                                                                                                                                      (fun
                                                                                                                                        function_parameter
                                                                                                                                        =>
                                                                                                                                        match
                                                                                                                                          function_parameter
                                                                                                                                          with
                                                                                                                                        |
                                                                                                                                          tt
                                                                                                                                          =>
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            (get_block_header
                                                                                                                                              client_1
                                                                                                                                              variant)
                                                                                                                                            (fun
                                                                                                                                              _baking_1_header
                                                                                                                                              =>
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                (kill_nth_node
                                                                                                                                                  mesh_nodes
                                                                                                                                                  1)
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  match
                                                                                                                                                    function_parameter
                                                                                                                                                    with
                                                                                                                                                  |
                                                                                                                                                    tt
                                                                                                                                                    =>
                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      (pause
                                                                                                                                                        None
                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                      (fun
                                                                                                                                                        function_parameter
                                                                                                                                                        =>
                                                                                                                                                        match
                                                                                                                                                          function_parameter
                                                                                                                                                          with
                                                                                                                                                        |
                                                                                                                                                          tt
                                                                                                                                                          =>
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                tt)
                                                                                                                                                              intermediary_nodes
                                                                                                                                                              (fun
                                                                                                                                                                prev
                                                                                                                                                                =>
                                                                                                                                                                fun
                                                                                                                                                                  x
                                                                                                                                                                  =>
                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                    prev
                                                                                                                                                                    (fun
                                                                                                                                                                      function_parameter
                                                                                                                                                                      =>
                                                                                                                                                                      match
                                                                                                                                                                        function_parameter
                                                                                                                                                                        with
                                                                                                                                                                      |
                                                                                                                                                                        tt
                                                                                                                                                                        =>
                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                          state
                                                                                                                                                                          client_exec
                                                                                                                                                                          x
                                                                                                                                                                      end)))
                                                                                                                                                            (fun
                                                                                                                                                              function_parameter
                                                                                                                                                              =>
                                                                                                                                                              match
                                                                                                                                                                function_parameter
                                                                                                                                                                with
                                                                                                                                                              |
                                                                                                                                                                tt
                                                                                                                                                                =>
                                                                                                                                                                let
                                                                                                                                                                  node_0 :=
                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                    mesh_nodes
                                                                                                                                                                    0
                                                                                                                                                                  in
                                                                                                                                                                let
                                                                                                                                                                  except_0
                                                                                                                                                                  {H
                                                                                                                                                                  :
                                                                                                                                                                  Type}
                                                                                                                                                                  (l
                                                                                                                                                                  :
                                                                                                                                                                  H
                                                                                                                                                                    ->
                                                                                                                                                                    bool)
                                                                                                                                                                  : (list
                                                                                                                                                                    H)
                                                                                                                                                                    ->
                                                                                                                                                                    list
                                                                                                                                                                      H :=
                                                                                                                                                                  Stdlib.List.filter
                                                                                                                                                                    l
                                                                                                                                                                    expected_argument
                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  in
                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                    (except_0
                                                                                                                                                                      mesh_nodes)
                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                      state
                                                                                                                                                                      client_exec))
                                                                                                                                                                  (fun
                                                                                                                                                                    function_parameter
                                                                                                                                                                    =>
                                                                                                                                                                    match
                                                                                                                                                                      function_parameter
                                                                                                                                                                      with
                                                                                                                                                                    |
                                                                                                                                                                      tt
                                                                                                                                                                      =>
                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                        (pause
                                                                                                                                                                          None
                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                        (fun
                                                                                                                                                                          function_parameter
                                                                                                                                                                          =>
                                                                                                                                                                          match
                                                                                                                                                                            function_parameter
                                                                                                                                                                            with
                                                                                                                                                                          |
                                                                                                                                                                            tt
                                                                                                                                                                            =>
                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                state
                                                                                                                                                                                default_attempts
                                                                                                                                                                                8
                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                variant)
                                                                                                                                                                              (fun
                                                                                                                                                                                function_parameter
                                                                                                                                                                                =>
                                                                                                                                                                                match
                                                                                                                                                                                  function_parameter
                                                                                                                                                                                  with
                                                                                                                                                                                |
                                                                                                                                                                                  tt
                                                                                                                                                                                  =>
                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                      state
                                                                                                                                                                                      client_exec
                                                                                                                                                                                      node_0)
                                                                                                                                                                                    (fun
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      =>
                                                                                                                                                                                      match
                                                                                                                                                                                        function_parameter
                                                                                                                                                                                        with
                                                                                                                                                                                      |
                                                                                                                                                                                        tt
                                                                                                                                                                                        =>
                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                          (pause
                                                                                                                                                                                            None
                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                          (fun
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            =>
                                                                                                                                                                                            match
                                                                                                                                                                                              function_parameter
                                                                                                                                                                                              with
                                                                                                                                                                                            |
                                                                                                                                                                                              tt
                                                                                                                                                                                              =>
                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                  state
                                                                                                                                                                                                  default_attempts
                                                                                                                                                                                                  8
                                                                                                                                                                                                  (fun
                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                    =>
                                                                                                                                                                                                    match
                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                      with
                                                                                                                                                                                                    |
                                                                                                                                                                                                      _
                                                                                                                                                                                                      =>
                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                            false)
                                                                                                                                                                                                          accuser_nodes
                                                                                                                                                                                                          (fun
                                                                                                                                                                                                            prev_m
                                                                                                                                                                                                            =>
                                                                                                                                                                                                            fun
                                                                                                                                                                                                              node
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                prev_m
                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                  prev
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  let
                                                                                                                                                                                                                    client :=
                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                      node
                                                                                                                                                                                                                      client_exec
                                                                                                                                                                                                                    in
                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                      state
                                                                                                                                                                                                                      client
                                                                                                                                                                                                                      "double_baking_evidence"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string)
                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                      client_result
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                        (orb
                                                                                                                                                                                                                          client_result
                                                                                                                                                                                                                          prev)))))
                                                                                                                                                                                                        (fun
                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                          =>
                                                                                                                                                                                                          match
                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                            with
                                                                                                                                                                                                          |
                                                                                                                                                                                                            true
                                                                                                                                                                                                            =>
                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                              variant
                                                                                                                                                                                                          |
                                                                                                                                                                                                            false
                                                                                                                                                                                                            =>
                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                              variant
                                                                                                                                                                                                          end)
                                                                                                                                                                                                    end))
                                                                                                                                                                                                (fun
                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                  =>
                                                                                                                                                                                                  match
                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                    with
                                                                                                                                                                                                  |
                                                                                                                                                                                                    tt
                                                                                                                                                                                                    =>
                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                        state
                                                                                                                                                                                                        baker_2
                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                          "all at lvl %d"
                                                                                                                                                                                                            %
                                                                                                                                                                                                            string
                                                                                                                                                                                                          (Z.add
                                                                                                                                                                                                            (Z.add
                                                                                                                                                                                                              starting_level
                                                                                                                                                                                                              number_of_lonely_bakes)
                                                                                                                                                                                                            1)))
                                                                                                                                                                                                      (fun
                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                        =>
                                                                                                                                                                                                        match
                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                          with
                                                                                                                                                                                                        |
                                                                                                                                                                                                          tt
                                                                                                                                                                                                          =>
                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                              state
                                                                                                                                                                                                              10
                                                                                                                                                                                                              4
                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                =>
                                                                                                                                                                                                                match
                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                  with
                                                                                                                                                                                                                |
                                                                                                                                                                                                                  _
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  let
                                                                                                                                                                                                                    level :=
                                                                                                                                                                                                                    Z.add
                                                                                                                                                                                                                      (Z.add
                                                                                                                                                                                                                        starting_level
                                                                                                                                                                                                                        number_of_lonely_bakes)
                                                                                                                                                                                                                      2
                                                                                                                                                                                                                    in
                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                      state
                                                                                                                                                                                                                      client_2
                                                                                                                                                                                                                      level
                                                                                                                                                                                                                      "double_baking_evidence"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string)
                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      match
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        with
                                                                                                                                                                                                                      |
                                                                                                                                                                                                                        true
                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                          variant
                                                                                                                                                                                                                      |
                                                                                                                                                                                                                        false
                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                          variant
                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                end))
                                                                                                                                                                                                            (fun
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              match
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                with
                                                                                                                                                                                                              |
                                                                                                                                                                                                                tt
                                                                                                                                                                                                                =>
                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                  (pause
                                                                                                                                                                                                                    None
                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                    match
                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                      with
                                                                                                                                                                                                                    |
                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                          state
                                                                                                                                                                                                                          baker_1
                                                                                                                                                                                                                          "a couple more"
                                                                                                                                                                                                                            %
                                                                                                                                                                                                                            string)
                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          match
                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                            with
                                                                                                                                                                                                                          |
                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                              state
                                                                                                                                                                                                                              default_attempts
                                                                                                                                                                                                                              8
                                                                                                                                                                                                                              all_nodes
                                                                                                                                                                                                                              variant
                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                    end)
                                                                                                                                                                                                              end)
                                                                                                                                                                                                        end)
                                                                                                                                                                                                  end)
                                                                                                                                                                                            end)
                                                                                                                                                                                      end)
                                                                                                                                                                                end)
                                                                                                                                                                          end)
                                                                                                                                                                    end)
                                                                                                                                                              end)
                                                                                                                                                        end)
                                                                                                                                                  end))
                                                                                                                                        end)
                                                                                                                                  end)
                                                                                                                            end)
                                                                                                                      end)
                                                                                                                end)
                                                                                                          end))
                                                                                                end)
                                                                                          end)
                                                                                    end)
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end)
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end
          end
        end)
  end.

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  match function_parameter with
  | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.
src/bin_sandbox/command_daemons_protocol_change.ml 
open Flextesa
open Internal_pervasives
open Console

let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt

let wait_for_voting_period ?level_within_period state ~client ~attempts period
    =
  let period_name = Tezos_protocol.Voting_period.to_string period in
  let message =
    sprintf
      "Waiting for voting period: `%s`%s"
      period_name
      (Option.value_map
         level_within_period
         ~default:""
         ~f:(sprintf " (and level-within-period ≥ %d)"))
  in
  Console.say state EF.(wf "%s" message)
  >>= fun () ->
  Helpers.wait_for state ~attempts ~seconds:10. (fun nth ->
      Asynchronous_result.map_option level_within_period ~f:(fun lvl ->
          Tezos_client.rpc
            state
            ~client
            `Get
            ~path:"/chains/main/blocks/head/metadata"
          >>= fun json ->
          try
            let voting_period_position =
              Jqo.field ~k:"level" json
              |> Jqo.field ~k:"voting_period_position"
              |> Jqo.get_int
            in
            return (voting_period_position >= lvl)
          with e ->
            failf
              "Cannot get level.voting_period_position: %s"
              (Printexc.to_string e))
      >>= fun lvl_ok ->
      Tezos_client.rpc
        state
        ~client
        `Get
        ~path:"/chains/main/blocks/head/votes/current_period_kind"
      >>= function
      | `String p when p = period_name && (lvl_ok = None || lvl_ok = Some true)
        ->
          return (`Done (nth - 1))
      | _ ->
          Tezos_client.successful_client_cmd
            state
            ~client
            ["show"; "voting"; "period"]
          >>= fun res ->
          Console.say
            state
            EF.(
              desc_list
                (wf "Voting period:")
                [markdown_verbatim (String.concat ~sep:"\n" res#out)])
          >>= fun () -> return (`Not_done message))

let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports
    ?generate_kiln_config ~node_exec ~client_exec ~first_baker_exec
    ~first_endorser_exec ~first_accuser_exec ~second_baker_exec
    ~second_endorser_exec ~second_accuser_exec ~admin_exec ~new_protocol_path
    ~extra_dummy_proposals_batch_size ~extra_dummy_proposals_batch_levels
    ~waiting_attempts test_variant () =
  Helpers.System_dependencies.precheck
    state
    `Or_fail
    ~protocol_paths:[new_protocol_path]
    ~executables:
      [ node_exec;
        client_exec;
        first_baker_exec;
        first_endorser_exec;
        first_accuser_exec;
        second_baker_exec;
        second_endorser_exec;
        second_accuser_exec ]
  >>= fun () ->
  Test_scenario.network_with_protocol
    ?external_peer_ports
    ~protocol
    ~size
    ~base_port
    state
    ~node_exec
    ~client_exec
  >>= fun (nodes, protocol) ->
  Tezos_client.rpc
    state
    ~client:(Tezos_client.of_node (List.hd_exn nodes) ~exec:client_exec)
    `Get
    ~path:"/chains/main/chain_id"
  >>= fun chain_id_json ->
  let network_id =
    match chain_id_json with `String s -> s | _ -> assert false
  in
  let accusers =
    List.concat_map nodes ~f:(fun node ->
        let client = Tezos_client.of_node node ~exec:client_exec in
        [ Tezos_daemon.accuser_of_node
            ~exec:first_accuser_exec
            ~client
            node
            ~name_tag:"first";
          Tezos_daemon.accuser_of_node
            ~exec:second_accuser_exec
            ~client
            node
            ~name_tag:"second" ])
  in
  List_sequential.iter accusers ~f:(fun acc ->
      Running_processes.start state (Tezos_daemon.process acc ~state)
      >>= fun _ -> return ())
  >>= fun () ->
  let keys_and_daemons =
    let pick_a_node_and_client idx =
      match List.nth nodes ((1 + idx) mod List.length nodes) with
      | Some node ->
          (node, Tezos_client.of_node node ~exec:client_exec)
      | None ->
          assert false
    in
    Tezos_protocol.bootstrap_accounts protocol
    |> List.filter_mapi ~f:(fun idx acc ->
           let (node, client) = pick_a_node_and_client idx in
           let key = Tezos_protocol.Account.name acc in
           if List.mem ~equal:String.equal no_daemons_for key then None
           else
             Some
               ( acc,
                 client,
                 [ Tezos_daemon.baker_of_node
                     ~exec:first_baker_exec
                     ~client
                     node
                     ~key
                     ~name_tag:"first";
                   Tezos_daemon.baker_of_node
                     ~exec:second_baker_exec
                     ~client
                     ~name_tag:"second"
                     node
                     ~key;
                   Tezos_daemon.endorser_of_node
                     ~exec:first_endorser_exec
                     ~name_tag:"first"
                     ~client
                     node
                     ~key;
                   Tezos_daemon.endorser_of_node
                     ~exec:second_endorser_exec
                     ~name_tag:"second"
                     ~client
                     node
                     ~key ] ))
  in
  List_sequential.iter keys_and_daemons ~f:(fun (acc, client, daemons) ->
      Tezos_client.bootstrapped ~state client
      >>= fun () ->
      let (key, priv) = Tezos_protocol.Account.(name acc, private_key acc) in
      Tezos_client.import_secret_key ~state client key priv
      >>= fun () ->
      say
        state
        EF.(
          desc_list
            (haf "Registration-as-delegate:")
            [ desc (af "Client:") (af "%S" client.Tezos_client.id);
              desc (af "Key:") (af "%S" key) ])
      >>= fun () ->
      Tezos_client.register_as_delegate ~state client key
      >>= fun () ->
      say
        state
        EF.(
          desc_list
            (haf "Starting daemons:")
            [ desc (af "Client:") (af "%S" client.Tezos_client.id);
              desc (af "Key:") (af "%S" key) ])
      >>= fun () ->
      List_sequential.iter daemons ~f:(fun daemon ->
          Running_processes.start state (Tezos_daemon.process daemon ~state)
          >>= fun _ -> return ()))
  >>= fun () ->
  let client_0 =
    Tezos_client.of_node (List.nth_exn nodes 0) ~exec:client_exec
  in
  let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes
      @ [secret_keys state ~protocol]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~make_admin
          ~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
  (* 
     For each node we try to see if the node knows about the protocol,
     if it does we're good, if not we inject it.
     This is because `inject` fails when the node already knows a protocol.
  *)
  List.fold ~init:(return None) nodes ~f:(fun prevm nod ->
      prevm
      >>= fun _ ->
      System.read_file state (new_protocol_path // "TEZOS_PROTOCOL")
      >>= fun protocol ->
      ( try return Jqo.(of_string protocol |> field ~k:"hash" |> get_string)
        with e ->
          failf
            "Cannot parse %s/TEZOS_PROTOCOL: %s"
            new_protocol_path
            (Printexc.to_string e) )
      >>= fun hash ->
      let client = Tezos_client.of_node ~exec:client_exec nod in
      Tezos_client.rpc state ~client `Get ~path:"/protocols"
      >>= fun protocols ->
      match protocols with
      | `A l
        when List.exists l ~f:(function `String h -> h = hash | _ -> false) ->
          Console.say
            state
            EF.(
              wf
                "Node `%s` already knows protocol `%s`."
                nod.Tezos_node.id
                hash)
          >>= fun () -> return (Some hash)
      | _ ->
          let admin = make_admin client in
          Tezos_admin_client.inject_protocol
            admin
            state
            ~path:new_protocol_path
          >>= fun (_, new_protocol_hash) ->
          ( if new_protocol_hash = hash then
            Console.say
              state
              EF.(
                wf
                  "Injected protocol `%s` in `%s`"
                  new_protocol_hash
                  nod.Tezos_node.id)
          else
            failf
              "Injecting protocol %s failed (≠ %s)"
              new_protocol_hash
              hash )
          >>= fun () -> return (Some hash))
  >>= fun prot_opt ->
  ( match prot_opt with
  | Some s ->
      return s
  | None ->
      failf "protocol injection problem?" )
  >>= fun new_protocol_hash ->
  Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config ->
      Kiln.Configuration_directory.generate
        state
        kiln_config
        ~peers:(List.map nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port))
        ~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol)
        ~nodes:
          (List.map nodes ~f:(fun {Tezos_node.rpc_port; _} ->
               sprintf "http://localhost:%d" rpc_port))
        ~bakers:
          (List.map
             protocol.Tezos_protocol.bootstrap_accounts
             ~f:(fun (account, _) ->
               Tezos_protocol.Account.(name account, pubkey_hash account)))
        ~network_string:network_id
        ~node_exec
        ~client_exec
        ~protocol_execs:
          [ ( protocol.Tezos_protocol.hash,
              first_baker_exec,
              first_endorser_exec );
            (new_protocol_hash, second_baker_exec, second_endorser_exec) ]
      >>= fun () ->
      let msg =
        EF.(
          desc
            (shout "Kiln-Configuration DONE")
            (wf "Kiln was configured at `%s`" kiln_config.path))
      in
      Console.say state msg >>= fun () -> return msg)
  >>= fun kiln_info_opt ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:waiting_attempts
    ~seconds:10.
    nodes
    (* TODO: wait for /chains/main/blocks/head/votes/listings to be
       non-empty instead of counting blocks *)
    (`At_least protocol.Tezos_protocol.blocks_per_voting_period)
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ wf "Test becomes interactive.";
        Option.value kiln_info_opt ~default:(wf "");
        wf "Please type `q` to start a voting/protocol-change period." ]
    ~force:true
  >>= fun () ->
  wait_for_voting_period
    state
    ~client:client_0
    ~attempts:waiting_attempts
    `Proposal
    ~level_within_period:3
  >>= fun _ ->
  let submit_prop acc client hash =
    Tezos_client.successful_client_cmd
      state
      ~client
      [ "submit";
        "proposals";
        "for";
        Tezos_protocol.Account.name acc;
        hash;
        "--force" ]
    >>= fun _ ->
    Console.sayf
      state
      Fmt.(
        fun ppf () ->
          pf ppf "%s voted for %s" (Tezos_protocol.Account.name acc) hash)
  in
  List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
      submit_prop acc client new_protocol_hash)
  >>= fun () ->
  let make_dummy_protocol_hashes t tag =
    List.map
      (List.init extra_dummy_proposals_batch_size ~f:(fun s ->
           sprintf "proto-%s-%d" tag s))
      ~f:(fun s ->
        (t, Tezos_crypto.Protocol_hash.(hash_string [s] |> to_b58check)))
  in
  let extra_dummy_protocols =
    List.bind extra_dummy_proposals_batch_levels ~f:(fun l ->
        make_dummy_protocol_hashes l (sprintf "%d" l))
  in
  Console.say
    state
    EF.(
      wf
        "Going to also vote for %s"
        (String.concat ~sep:", " (List.map extra_dummy_protocols ~f:snd)))
  >>= fun () ->
  List_sequential.iteri
    extra_dummy_protocols
    ~f:(fun nth (level, proto_hash) ->
      match List.nth keys_and_daemons (nth / 19) with
      | None ->
          failf "Too many dummy protocols Vs available voting power (%d)" nth
      | Some (acc, client, _) ->
          wait_for_voting_period
            state
            ~client:client_0
            ~attempts:waiting_attempts
            `Proposal
            ~level_within_period:level
          >>= fun _ -> submit_prop acc client proto_hash)
  >>= fun () ->
  wait_for_voting_period
    state
    ~client:client_0
    ~attempts:waiting_attempts
    `Testing_vote
  >>= fun _ ->
  List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
      Tezos_client.successful_client_cmd
        state
        ~client
        [ "submit";
          "ballot";
          "for";
          Tezos_protocol.Account.name acc;
          new_protocol_hash;
          "yea" ]
      >>= fun _ ->
      Console.sayf
        state
        Fmt.(
          fun ppf () ->
            pf
              ppf
              "%s voted Yea to test %s"
              (Tezos_protocol.Account.name acc)
              new_protocol_hash))
  >>= fun () ->
  wait_for_voting_period
    state
    ~client:client_0
    ~attempts:waiting_attempts
    `Promotion_vote
  >>= fun _ ->
  let protocol_switch_will_happen =
    match test_variant with
    | `Full_upgrade ->
        true
    | `Nay_for_promotion ->
        false
  in
  List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
      Tezos_client.successful_client_cmd
        state
        ~client
        [ "submit";
          "ballot";
          "for";
          Tezos_protocol.Account.name acc;
          new_protocol_hash;
          (if protocol_switch_will_happen then "yea" else "nay") ]
      >>= fun _ ->
      Console.sayf
        state
        Fmt.(
          fun ppf () ->
            pf
              ppf
              "%s voted Yea to promote %s"
              (Tezos_protocol.Account.name acc)
              new_protocol_hash))
  >>= fun () ->
  wait_for_voting_period
    state
    ~client:client_0
    ~attempts:waiting_attempts
    `Proposal
  >>= fun _ ->
  Tezos_client.successful_client_cmd
    state
    ~client:client_0
    ["show"; "voting"; "period"]
  >>= fun res ->
  let protocol_to_wait_for =
    if protocol_switch_will_happen then new_protocol_hash
    else protocol.Tezos_protocol.hash
  in
  Helpers.wait_for state ~attempts:waiting_attempts ~seconds:4. (fun _ ->
      Console.say state EF.(wf "Checking actual protocol transition")
      >>= fun () ->
      Tezos_client.rpc
        state
        ~client:client_0
        `Get
        ~path:"/chains/main/blocks/head/metadata"
      >>= fun json ->
      ( try Jqo.field ~k:"protocol" json |> Jqo.get_string |> return
        with e -> failf "Cannot parse metadata: %s" (Printexc.to_string e) )
      >>= fun proto_hash ->
      if proto_hash <> protocol_to_wait_for then
        return
          (`Not_done
            (sprintf
               "Protocol not done: %s Vs %s"
               proto_hash
               protocol_to_wait_for))
      else return (`Done ()))
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ wf
          "Test finished, protocol is now %s, things should keep baking."
          protocol_to_wait_for;
        markdown_verbatim (String.concat ~sep:"\n" res#out) ]
    ~force:true

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  let variants =
    [ ( "full-upgrade",
        `Full_upgrade,
        "Go through the whole voting process and do the protocol change." );
      ( "nay-for-promotion",
        `Nay_for_promotion,
        "Go through the whole voting process but vote Nay at the last period \
         and hence stay on the same protocol." ) ]
  in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun size
             base_port
             (`Attempts waiting_attempts)
             (`External_peers external_peer_ports)
             (`No_daemons_for no_daemons_for)
             protocol
             node_exec
             client_exec
             admin_exec
             first_baker_exec
             first_endorser_exec
             first_accuser_exec
             second_baker_exec
             second_endorser_exec
             second_accuser_exec
             (`Protocol_path new_protocol_path)
             (`Extra_dummy_proposals_batch_size
               extra_dummy_proposals_batch_size)
             (`Extra_dummy_proposals_batch_levels
               extra_dummy_proposals_batch_levels)
             generate_kiln_config
             test_variant
             state
             ->
          let actual_test =
            run
              state
              ~size
              ~base_port
              ~protocol
              ~node_exec
              ~client_exec
              ~first_baker_exec
              ~first_endorser_exec
              ~first_accuser_exec
              ~second_baker_exec
              ~second_endorser_exec
              ~second_accuser_exec
              ~admin_exec
              ?generate_kiln_config
              ~external_peer_ports
              ~no_daemons_for
              ~new_protocol_path
              test_variant
              ~waiting_attempts
              ~extra_dummy_proposals_batch_size
              ~extra_dummy_proposals_batch_levels
          in
          (state, Interactive_test.Pauser.run_test ~pp_error state actual_test))
    $ Arg.(
        value & opt int 5
        & info ["size"; "S"] ~doc:"Set the size of the network.")
    $ Arg.(
        value & opt int 20_000
        & info ["base-port"; "P"] ~doc:"Base port number to build upon.")
    $ Arg.(
        pure (fun n -> `Attempts n)
        $ value
            (opt
               int
               60
               (info
                  ["waiting-attempts"]
                  ~doc:
                    "Number of attempts done while waiting for voting periods")))
    $ Arg.(
        pure (fun l -> `External_peers l)
        $ value
            (opt_all
               int
               []
               (info
                  ["add-external-peer-port"]
                  ~docv:"PORT-NUMBER"
                  ~doc:"Add $(docv) to the peers of the network nodes.")))
    $ Arg.(
        pure (fun l -> `No_daemons_for l)
        $ value
            (opt_all
               string
               []
               (info
                  ["no-daemons-for"]
                  ~docv:"ACCOUNT-NAME"
                  ~doc:"Do not start daemons for $(docv).")))
    $ Tezos_protocol.cli_term ()
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Tezos_executable.cli_term `Admin "tezos"
    $ Tezos_executable.cli_term `Baker "first"
    $ Tezos_executable.cli_term `Endorser "first"
    $ Tezos_executable.cli_term `Accuser "first"
    $ Tezos_executable.cli_term `Baker "second"
    $ Tezos_executable.cli_term `Endorser "second"
    $ Tezos_executable.cli_term `Accuser "second"
    $ Arg.(
        pure (fun p -> `Protocol_path p)
        $ required
            (pos
               0
               (some string)
               None
               (info
                  []
                  ~doc:"The protocol to inject and vote on."
                  ~docv:"PROTOCOL-PATH")))
    $ Arg.(
        pure (fun l -> `Extra_dummy_proposals_batch_size l)
        $ value
            (opt
               int
               0
               (info
                  ["extra-dummy-proposals-batch-size"]
                  ~docv:"NUMBER"
                  ~doc:"Submit $(docv) extra proposals per batch.")))
    $ Arg.(
        pure (fun x -> `Extra_dummy_proposals_batch_levels x)
        $ value
            (opt
               (list ~sep:',' int)
               []
               (info
                  ["extra-dummy-proposals-batch-levels"]
                  ~docv:"NUMBER"
                  ~doc:
                    "Set the levels within the proposal period where batches \
                     of extra proposals appear, e.g. `3,5,7`.")))
    $ Kiln.Configuration_directory.cli_term ()
    $ Arg.(
        let doc =
          sprintf
            "Which variant of the test to run (one of {%s})"
            ( List.map ~f:(fun (n, _, _) -> n) variants
            |> String.concat ~sep:", " )
        in
        value
          (opt
             (enum (List.map variants ~f:(fun (n, v, _) -> (n, v))))
             `Full_upgrade
             (info ["test-variant"] ~doc)))
    $ Test_command_line.cli_state ~name:"daemons-upgrade" () )
    (let doc =
       "Vote and Protocol-upgrade with bakers, endorsers, and accusers."
     in
     let man : Manpage.block list =
       [ `S "DAEMONS-UPGRADE TEST";
         `P
           "This test builds and runs a sandbox network to do a full voting \
            round followed by a protocol change while all the daemons.";
         `P
           (sprintf
              "There are for now %d variants (see option `--test-variant`):"
              (List.length variants));
         `Blocks
           (List.concat_map variants ~f:(fun (n, _, desc) ->
                [`Noblank; `P (sprintf "* `%s`: %s" n desc)]));
         `P "The test is interactive-only:";
         `Blocks
           (List.concat_mapi
              ~f:(fun i s -> [`Noblank; `P (sprintf "%d) %s" (i + 1) s)])
              [ "It starts a sandbox assuming the protocol of the `--first-*` \
                 executables (use the `--protocol-hash` option to make sure \
                 it matches).";
                "An interactive pause is done to let the user play with the \
                 `first` protocol.";
                "Once the user quits the prompt (`q` or `quit` command), a \
                 full voting round happens with a single proposal: the one at \
                 `PROTOCOL-PATH` (which should be the one understood by the \
                 `--second-*` executables).";
                "Once the potential protocol switch has happened (and been \
                 verified), the test re-enters an interactive prompt to let \
                 the user play with the protocol (the first or second one, \
                 depending on the `--test-variant` option)." ]) ]
     in
     info "daemons-upgrade" ~man ~doc)
src/bin_sandbox/command_daemons_protocol_change.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition failf {A B : Type} (fmt : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (fun s => op_star_t_y_p_e_minus_e_r_r_o_r_star variant) fmt.

Definition wait_for_voting_period {A B C D E F : Type}
  (level_within_period : option A) (state : B) (client : C) (attempts : D)
  (period : E) : F :=
  let period_name := op_star_t_y_p_e_minus_e_r_r_o_r_star period in
  let message :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      "Waiting for voting period: `%s`%s" % string period_name
      (op_star_t_y_p_e_minus_e_r_r_o_r_star level_within_period "" % string
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          " (and level-within-period ≥ %d)" % string)) in
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
      op_star_t_y_p_e_minus_e_r_r_o_r_star)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star state attempts 10
          (fun nth =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star level_within_period
                (fun lvl =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state client variant
                      "/chains/main/blocks/head/metadata" % string)
                    (fun json => try)))
              (fun lvl_ok =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state client variant
                    "/chains/main/blocks/head/votes/current_period_kind" %
                      string)
                  (fun function_parameter =>
                    match function_parameter with
                    | String p => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
                    | _ =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
                          (cons "show" % string
                            (cons "voting" % string (cons "period" % string []))))
                        (fun res =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star variant
                              end))
                    end)))
      end).

Definition run {A B C D E F G H I J K L M : Type}
  (state : A) (protocol : B) (size : C) (base_port : D) (no_daemons_for : E)
  (external_peer_ports : option F) (generate_kiln_config : option G)
  (node_exec : H) (client_exec : H) (first_baker_exec : H)
  (first_endorser_exec : H) (first_accuser_exec : H) (second_baker_exec : H)
  (second_endorser_exec : H) (second_accuser_exec : H) (admin_exec : I)
  (new_protocol_path : J) (extra_dummy_proposals_batch_size : Z)
  (extra_dummy_proposals_batch_levels : K) (waiting_attempts : L)
  (test_variant : variant) (function_parameter : unit) : M :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state variant
        (cons new_protocol_path [])
        (cons node_exec
          (cons client_exec
            (cons first_baker_exec
              (cons first_endorser_exec
                (cons first_accuser_exec
                  (cons second_baker_exec
                    (cons second_endorser_exec (cons second_accuser_exec [])))))))))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star external_peer_ports protocol
              size base_port state node_exec client_exec)
            (fun function_parameter =>
              match function_parameter with
              | (nodes, protocol) =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star nodes) client_exec)
                    variant "/chains/main/chain_id" % string)
                  (fun chain_id_json =>
                    let network_id :=
                      match chain_id_json with
                      | String s => s
                      | _ => false
                      end in
                    let accusers :=
                      op_star_t_y_p_e_minus_e_r_r_o_r_star nodes
                        (fun node =>
                          let client :=
                            op_star_t_y_p_e_minus_e_r_r_o_r_star node
                              client_exec in
                          cons
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              first_accuser_exec client node "first" % string)
                            (cons
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                second_accuser_exec client node
                                "second" % string) [])) in
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star accusers
                        (fun acc =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star acc state))
                            (fun function_parameter =>
                              match function_parameter with
                              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star tt
                              end)))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let keys_and_daemons :=
                            let pick_a_node_and_client {N O : Type} (idx : Z)
                              : N * O :=
                              match
                                Stdlib.List.nth nodes
                                  (Z.modulo (Z.add 1 idx)
                                    (OCaml.List.length nodes)) with
                              | Some node =>
                                (node,
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star node
                                    client_exec))
                              | None => false
                              end in
                            OCaml.Stdlib.reverse_apply
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star protocol)
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (fun idx =>
                                  fun acc =>
                                    match pick_a_node_and_client idx with
                                    | (node, client) =>
                                      let key :=
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star acc
                                        in
                                      if
                                        Stdlib.List.mem no_daemons_for key
                                          Stdlib.String.equal then
                                        None
                                      else
                                        Some
                                          (acc, client,
                                            (cons
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                first_baker_exec client node key
                                                "first" % string)
                                              (cons
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  second_baker_exec client
                                                  "second" % string node key)
                                                (cons
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    first_endorser_exec
                                                    "first" % string client node
                                                    key)
                                                  (cons
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      second_endorser_exec
                                                      "second" % string client
                                                      node key) [])))))
                                    end)) in
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              keys_and_daemons
                              (fun function_parameter =>
                                match function_parameter with
                                | (acc, client, daemons) =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                      client)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        match
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          with
                                        | (key, priv) =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              state client key priv)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    state
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          state client key)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                state
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    daemons
                                                                    (fun daemon
                                                                      =>
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          state
                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            daemon
                                                                            state))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | _ =>
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              tt
                                                                          end))
                                                                end)
                                                          end)
                                                    end)
                                              end)
                                        end
                                      end)
                                end))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                let client_0 :=
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star nodes
                                      0) client_exec in
                                let make_admin :=
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    admin_exec in
                                op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star;
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star None)
                                    nodes
                                    (fun prevm =>
                                      fun nod =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          prevm
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  state
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    new_protocol_path
                                                    "TEZOS_PROTOCOL" % string))
                                                (fun protocol =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    try
                                                    (fun hash =>
                                                      let client :=
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          client_exec nod in
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          state client variant
                                                          "/protocols" % string)
                                                        (fun protocols =>
                                                          match protocols with
                                                          | _ =>
                                                            let admin :=
                                                              make_admin client
                                                              in
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                admin state
                                                                new_protocol_path)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                |
                                                                  (_,
                                                                    new_protocol_hash)
                                                                  =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    (if
                                                                      equiv_decb
                                                                        new_protocol_hash
                                                                        hash
                                                                      then
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        state
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    else
                                                                      failf
                                                                        "Injecting protocol %s failed (≠ %s)"
                                                                          %
                                                                          string
                                                                        new_protocol_hash
                                                                        hash)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | tt =>
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          (Some
                                                                            hash)
                                                                      end)
                                                                end)
                                                          end)))
                                            end)))
                                  (fun prot_opt =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      match prot_opt with
                                      | Some s =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star s
                                      | None =>
                                        failf
                                          "protocol injection problem?" % string
                                      end
                                      (fun new_protocol_hash =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            generate_kiln_config
                                            (fun kiln_config =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  state kiln_config
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    state protocol)
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (List.map
                                                    (Tezos_protocol.bootstrap_accounts
                                                      protocol)
                                                    expected_argument
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | (account, _) =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      end)) network_id node_exec
                                                  client_exec
                                                  (cons
                                                    ((Tezos_protocol.hash
                                                      protocol),
                                                      first_baker_exec,
                                                      first_endorser_exec)
                                                    (cons
                                                      (new_protocol_hash,
                                                        second_baker_exec,
                                                        second_endorser_exec) [])))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    let msg :=
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      in
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        state msg)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            msg
                                                        end)
                                                  end)))
                                          (fun kiln_info_opt =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                state waiting_attempts 10 nodes
                                                variant)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      state
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      true)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (wait_for_voting_period
                                                            (Some 3) state
                                                            client_0
                                                            waiting_attempts
                                                            variant)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | _ =>
                                                              let submit_prop
                                                                {N O P : Type}
                                                                (acc : N)
                                                                (client : O)
                                                                (hash : string)
                                                                : P :=
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    state client
                                                                    (cons
                                                                      "submit" %
                                                                        string
                                                                      (cons
                                                                        "proposals"
                                                                          %
                                                                          string
                                                                        (cons
                                                                          "for"
                                                                            %
                                                                            string
                                                                          (cons
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              acc)
                                                                            (cons
                                                                              hash
                                                                              (cons
                                                                                "--force"
                                                                                  %
                                                                                  string
                                                                                [])))))))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | _ =>
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        state
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    end) in
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  keys_and_daemons
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    |
                                                                      (acc,
                                                                        client,
                                                                        _) =>
                                                                      submit_prop
                                                                        acc
                                                                        client
                                                                        new_protocol_hash
                                                                    end))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    let
                                                                      make_dummy_protocol_hashes
                                                                      {N O P :
                                                                      Type}
                                                                      (t : N)
                                                                      (tag : O)
                                                                      : (list
                                                                        (Z -> P))
                                                                        ->
                                                                        list
                                                                          (list
                                                                            P) :=
                                                                      List.map
                                                                        (Stdlib.List.init
                                                                          extra_dummy_proposals_batch_size
                                                                          expected_argument
                                                                          (fun s
                                                                            =>
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              "proto-%s-%d"
                                                                                %
                                                                                string
                                                                              tag
                                                                              s))
                                                                        expected_argument
                                                                        (fun s
                                                                          =>
                                                                          (t,
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                                                      in
                                                                    let
                                                                      extra_dummy_protocols :=
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        extra_dummy_proposals_batch_levels
                                                                        (fun l
                                                                          =>
                                                                          make_dummy_protocol_hashes
                                                                            l
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              "%d"
                                                                                %
                                                                                string
                                                                              l))
                                                                      in
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        state
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              extra_dummy_protocols
                                                                              (fun
                                                                                nth
                                                                                =>
                                                                                fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    (level,
                                                                                      proto_hash)
                                                                                    =>
                                                                                    match
                                                                                      Stdlib.List.nth
                                                                                        keys_and_daemons
                                                                                        (Z.div
                                                                                          nth
                                                                                          19)
                                                                                      with
                                                                                    |
                                                                                      None
                                                                                      =>
                                                                                      failf
                                                                                        "Too many dummy protocols Vs available voting power (%d)"
                                                                                          %
                                                                                          string
                                                                                        nth
                                                                                    |
                                                                                      Some
                                                                                        (acc,
                                                                                          client,
                                                                                          _)
                                                                                      =>
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (wait_for_voting_period
                                                                                          (Some
                                                                                            level)
                                                                                          state
                                                                                          client_0
                                                                                          waiting_attempts
                                                                                          variant)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            _
                                                                                            =>
                                                                                            submit_prop
                                                                                              acc
                                                                                              client
                                                                                              proto_hash
                                                                                          end)
                                                                                    end
                                                                                  end))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (wait_for_voting_period
                                                                                    None
                                                                                    state
                                                                                    client_0
                                                                                    waiting_attempts
                                                                                    variant)
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      _
                                                                                      =>
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          keys_and_daemons
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            match
                                                                                              function_parameter
                                                                                              with
                                                                                            |
                                                                                              (acc,
                                                                                                client,
                                                                                                _)
                                                                                              =>
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  state
                                                                                                  client
                                                                                                  (cons
                                                                                                    "submit"
                                                                                                      %
                                                                                                      string
                                                                                                    (cons
                                                                                                      "ballot"
                                                                                                        %
                                                                                                        string
                                                                                                      (cons
                                                                                                        "for"
                                                                                                          %
                                                                                                          string
                                                                                                        (cons
                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            acc)
                                                                                                          (cons
                                                                                                            new_protocol_hash
                                                                                                            (cons
                                                                                                              "yea"
                                                                                                                %
                                                                                                                string
                                                                                                              [])))))))
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  match
                                                                                                    function_parameter
                                                                                                    with
                                                                                                  |
                                                                                                    _
                                                                                                    =>
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      state
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  end)
                                                                                            end))
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            tt
                                                                                            =>
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (wait_for_voting_period
                                                                                                None
                                                                                                state
                                                                                                client_0
                                                                                                waiting_attempts
                                                                                                variant)
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  _
                                                                                                  =>
                                                                                                  let
                                                                                                    protocol_switch_will_happen :=
                                                                                                    match
                                                                                                      test_variant
                                                                                                      with
                                                                                                    |
                                                                                                      Full_upgrade
                                                                                                      =>
                                                                                                      true
                                                                                                    |
                                                                                                      Nay_for_promotion
                                                                                                      =>
                                                                                                      false
                                                                                                    end
                                                                                                    in
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      keys_and_daemons
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        match
                                                                                                          function_parameter
                                                                                                          with
                                                                                                        |
                                                                                                          (acc,
                                                                                                            client,
                                                                                                            _)
                                                                                                          =>
                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              state
                                                                                                              client
                                                                                                              (cons
                                                                                                                "submit"
                                                                                                                  %
                                                                                                                  string
                                                                                                                (cons
                                                                                                                  "ballot"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  (cons
                                                                                                                    "for"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    (cons
                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                        acc)
                                                                                                                      (cons
                                                                                                                        new_protocol_hash
                                                                                                                        (cons
                                                                                                                          (if
                                                                                                                            protocol_switch_will_happen
                                                                                                                            then
                                                                                                                            "yea"
                                                                                                                              %
                                                                                                                              string
                                                                                                                          else
                                                                                                                            "nay"
                                                                                                                              %
                                                                                                                              string)
                                                                                                                          [])))))))
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              match
                                                                                                                function_parameter
                                                                                                                with
                                                                                                              |
                                                                                                                _
                                                                                                                =>
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                  state
                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              end)
                                                                                                        end))
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      match
                                                                                                        function_parameter
                                                                                                        with
                                                                                                      |
                                                                                                        tt
                                                                                                        =>
                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          (wait_for_voting_period
                                                                                                            None
                                                                                                            state
                                                                                                            client_0
                                                                                                            waiting_attempts
                                                                                                            variant)
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            match
                                                                                                              function_parameter
                                                                                                              with
                                                                                                            |
                                                                                                              _
                                                                                                              =>
                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                  state
                                                                                                                  client_0
                                                                                                                  (cons
                                                                                                                    "show"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    (cons
                                                                                                                      "voting"
                                                                                                                        %
                                                                                                                        string
                                                                                                                      (cons
                                                                                                                        "period"
                                                                                                                          %
                                                                                                                          string
                                                                                                                        []))))
                                                                                                                (fun
                                                                                                                  res
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    protocol_to_wait_for :=
                                                                                                                    if
                                                                                                                      protocol_switch_will_happen
                                                                                                                      then
                                                                                                                      new_protocol_hash
                                                                                                                    else
                                                                                                                      Tezos_protocol.hash
                                                                                                                        protocol
                                                                                                                    in
                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      state
                                                                                                                      waiting_attempts
                                                                                                                      4
                                                                                                                      (fun
                                                                                                                        function_parameter
                                                                                                                        =>
                                                                                                                        match
                                                                                                                          function_parameter
                                                                                                                          with
                                                                                                                        |
                                                                                                                          _
                                                                                                                          =>
                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              state
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              match
                                                                                                                                function_parameter
                                                                                                                                with
                                                                                                                              |
                                                                                                                                tt
                                                                                                                                =>
                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    state
                                                                                                                                    client_0
                                                                                                                                    variant
                                                                                                                                    "/chains/main/blocks/head/metadata"
                                                                                                                                      %
                                                                                                                                      string)
                                                                                                                                  (fun
                                                                                                                                    json
                                                                                                                                    =>
                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      try
                                                                                                                                      (fun
                                                                                                                                        proto_hash
                                                                                                                                        =>
                                                                                                                                        if
                                                                                                                                          nequiv_decb
                                                                                                                                            proto_hash
                                                                                                                                            protocol_to_wait_for
                                                                                                                                          then
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            variant
                                                                                                                                        else
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            variant))
                                                                                                                              end)
                                                                                                                        end))
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      match
                                                                                                                        function_parameter
                                                                                                                        with
                                                                                                                      |
                                                                                                                        tt
                                                                                                                        =>
                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                          state
                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                          true
                                                                                                                      end))
                                                                                                            end)
                                                                                                      end)
                                                                                                end)
                                                                                          end)
                                                                                    end)
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end)
                                                end))))
                              end)
                        end))
              end)
        end)
  end.

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  match function_parameter with
  | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.
src/bin_sandbox/command_ledger_baking.ml 
open Flextesa
open Internal_pervasives

let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt

let ledger_prompt_notice state ~ef ?(button = `Checkmark) () =
  let button_str =
    match button with
    | `Checkmark ->
        "✔"
    | `X ->
        "❌"
    | `Both ->
        "❌ and ✔ at the same time"
  in
  Console.say
    state
    EF.(
      desc
        (shout "Ledger-prompt")
        (list [ef; wf "Press %s on the ledger." button_str]))

let assert_failure state msg f () =
  Console.say state EF.(wf "Asserting %s" msg)
  >>= fun () ->
  Asynchronous_result.bind_on_error
    (f () >>= fun _ -> return `Worked)
    ~f:(fun ~result:_ _ -> return `Didn'tWork)
  >>= function `Worked -> failf "%s" msg | `Didn'tWork -> return ()

let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt

let assert_ a = if a then return () else failf "Assertion failed"

let assert_eq to_string ~expected ~actual =
  if expected = actual then return ()
  else
    failf
      "Assertion failed: expected %s but got %s"
      (to_string expected)
      (to_string actual)

let rec ask state ef =
  Console.say state EF.(list [ef; wf " (y/n)?"])
  >>= fun () ->
  System_error.catch Lwt_io.read_char Lwt_io.stdin
  >>= function
  | 'y' | 'Y' -> return true | 'n' | 'N' -> return false | _ -> ask state ef

let ask_assert state ef () = ask state ef >>= fun b -> assert_ b

let with_ledger_prompt state message expectation ~f =
  ledger_prompt_notice
    state
    ()
    ~button:(match expectation with `Succeeds -> `Checkmark | `Fails -> `X)
    ~ef:
      EF.(
        list
          [ message;
            wf "\n\n";
            wf
              ( match expectation with
              | `Succeeds ->
                  ">> ACCEPT THIS <<"
              | `Fails ->
                  ">> REJECT THIS <<" ) ])
  >>= fun () ->
  match expectation with
  | `Succeeds ->
      f () >>= fun _ -> Console.say state EF.(wf "> Got response: ACCEPTED")
  | `Fails ->
      assert_failure state "expected failure" f ()
      >>= fun () -> Console.say state EF.(wf "> Got response: REJECTED")

let with_ledger_test_reject_and_succeed state ef f =
  with_ledger_prompt state ef `Fails ~f
  >>= fun () -> with_ledger_prompt state ef `Succeeds ~f

let assert_hwms state ~client ~uri ~main ~test =
  Console.say
    state
    EF.(wf "Asserting main HWM = %d and test HWM = %d" main test)
  >>= fun () ->
  Tezos_client.Ledger.get_hwm state ~client ~uri
  >>= fun {main = main_actual; test = test_actual; _} ->
  assert_eq string_of_int ~actual:main_actual ~expected:main
  >>= fun () -> assert_eq string_of_int ~actual:test_actual ~expected:test

let get_chain_id state ~client =
  Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id"
  >>= (function
        | `String x ->
            return x
        | _ ->
            failf "Failed to parse chain_id JSON from node")
  >>= fun chain_id_string ->
  return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string)

let get_head_block_hash state ~client () =
  Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash"
  >>= function
  | `String x ->
      return x
  | _ ->
      failf "Failed to parse block hash JSON from node"

let forge_endorsement state ~client ~chain_id ~level () =
  get_head_block_hash state ~client ()
  >>= fun branch ->
  let json =
    `O
      [ ("branch", `String branch);
        ( "contents",
          `A
            [ `O
                [ ("kind", `String "endorsement");
                  ("level", `Float (float_of_int level)) ] ] ) ]
  in
  Tezos_client.rpc
    state
    ~client
    ~path:"/chains/main/blocks/head/helpers/forge/operations"
    (`Post (Ezjsonm.to_string json))
  >>= function
  | `String operation_bytes ->
      let endorsement_magic_byte = "02" in
      return
        ( endorsement_magic_byte
        ^ (chain_id |> Tezos_crypto.Chain_id.to_hex |> Hex.show)
        ^ operation_bytes )
  | _ ->
      failf "Failed to forge operation or parse result"

let forge_delegation state ~client ~src ~dest ?(fee = 0.00126) () =
  get_head_block_hash state ~client ()
  >>= fun branch ->
  let json =
    `O
      [ ("branch", `String branch);
        ( "contents",
          `A
            [ `O
                [ ("kind", `String "delegation");
                  ("source", `String src);
                  ( "fee",
                    `String (string_of_int (int_of_float (fee *. 1000000.))) );
                  ("counter", `String (string_of_int 30713));
                  ("gas_limit", `String (string_of_int 10100));
                  ("delegate", `String dest);
                  ("storage_limit", `String (string_of_int 277)) ] ] ) ]
  in
  Tezos_client.rpc
    state
    ~client
    ~path:"/chains/main/blocks/head/helpers/forge/operations"
    (`Post (Ezjsonm.to_string json))
  >>= function
  | `String operation_bytes ->
      let magic_byte = "03" in
      return (magic_byte ^ operation_bytes)
  | _ ->
      failf "Failed to forge operation or parse result"

let sign state ~client ~bytes () =
  Tezos_client.successful_client_cmd
    state
    ~client:client.Tezos_client.Keyed.client
    ["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name]
  >>= fun _ -> return ()

let originate_account_from state ~client ~account =
  let orig_account_name =
    Tezos_protocol.Account.name account ^ "-originated-account"
  in
  Tezos_client.successful_client_cmd
    state
    ~client
    [ "originate";
      "account";
      orig_account_name;
      "for";
      Tezos_protocol.Account.name account;
      "transferring";
      string_of_int 1000;
      "from";
      Tezos_protocol.Account.name account;
      "--burn-cap";
      string_of_float 0.257 ]
  >>= fun _ -> return orig_account_name

let setup_baking_ledger state uri ~client ~protocol =
  Console.say state EF.(wf "Setting up the ledger device %S" uri)
  >>= fun () ->
  let key_name = "ledgered" in
  let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in
  let assert_baking_key x () =
    let to_string = function Some x -> x | None -> "<none>" in
    Console.say
      state
      EF.(wf "Asserting that the authorized key is %s" (to_string x))
    >>= fun () ->
    Tezos_client.Ledger.get_authorized_key state ~client ~uri
    >>= fun auth_key -> assert_eq to_string ~expected:x ~actual:auth_key
  in
  Tezos_client.Ledger.deauthorize_baking state ~client ~uri
  (* TODO: The following assertion doesn't confirm anything if the ledger was already not authorized to bake. *)
  >>= assert_baking_key None
  >>= fun () ->
  Tezos_client.Ledger.show_ledger state ~client ~uri
  >>= fun account ->
  with_ledger_test_reject_and_succeed
    state
    EF.(
      wf
        "Importing %S in client `%s`. The ledger should be prompting for \
         acknowledgment to provide the public key of %s"
        uri
        client.Tezos_client.id
        (Tezos_protocol.Account.pubkey_hash account))
    (fun () ->
      Tezos_client.Keyed.initialize state baker >>= fun _ -> return ())
  >>= assert_failure state "baking before setup should fail" (fun () ->
          Tezos_client.Keyed.bake state baker "Baked by ledger")
  >>= assert_failure state "endorsing before setup should fail" (fun () ->
          Tezos_client.Keyed.endorse state baker "Endorsed by ledger")
  >>= fun () ->
  let test_invalid_delegations () =
    let ledger_pkh = Tezos_protocol.Account.pubkey_hash account in
    let other_pkh =
      Tezos_protocol.Account.pubkey_hash
        (fst (List.last_exn protocol.Tezos_protocol.bootstrap_accounts))
    in
    let cases =
      [ (ledger_pkh, other_pkh, "ledger to another account");
        (other_pkh, ledger_pkh, "another account to ledger");
        (other_pkh, other_pkh, "another account to another account") ]
    in
    List_sequential.iter cases ~f:(fun (src, dest, msg) ->
        forge_delegation state ~client ~src ~dest ()
        >>= fun forged_delegation_bytes ->
        assert_failure
          state
          (sprintf
             "signing a delegation from %s (%s to %s) should fail"
             msg
             src
             dest)
          (sign state ~client:baker ~bytes:forged_delegation_bytes)
          ())
  in
  test_invalid_delegations ()
  >>= fun () ->
  with_ledger_test_reject_and_succeed
    state
    EF.(
      wf
        "Setting up %S for baking.\n\
         Address: %S\n\
         Chain: mainnet\n\
         Main Chain HWM: 0\n\
         Test Chain HWM: 0"
        uri
        (Tezos_protocol.Account.pubkey_hash account))
    (fun () ->
      Tezos_client.successful_client_cmd
        state
        ~client
        [ "setup";
          "ledger";
          "to";
          "bake";
          "for";
          key_name;
          "--main-hwm";
          "0";
          "--test-hwm";
          "0" ])
  >>= assert_failure
        state
        "signing a 'Withdraw delegate' operation in Baking App should fail"
        (fun () ->
          Tezos_client.successful_client_cmd
            state
            ~client
            [ "--wait";
              "none";
              "withdraw";
              "delegate";
              "from";
              Tezos_protocol.Account.pubkey_hash account ])
  >>= assert_baking_key (Some uri)
  >>= test_invalid_delegations
  >>= fun () -> return (baker, account)

let run state ~protocol ~node_exec ~client_exec ~admin_exec ~size ~base_port
    ~uri ~enable_deterministic_nonce_tests () =
  Helpers.clear_root state
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ready to start"; af "Root path deleted."]
  >>= fun () ->
  let ledger_client = Tezos_client.no_node_client ~exec:client_exec in
  Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri
  >>= fun ledger_account ->
  let protocol =
    let open Tezos_protocol in
    {
      protocol with
      time_between_blocks = [1; 2];
      bootstrap_accounts =
        (ledger_account, 1_000_000_000_000L) :: protocol.bootstrap_accounts;
    }
  in
  let other_baker_account =
    fst (List.nth_exn protocol.Tezos_protocol.bootstrap_accounts 1)
  in
  Test_scenario.network_with_protocol
    ~protocol
    ~size
    ~base_port
    state
    ~node_exec
    ~client_exec
  >>= fun (nodes, protocol) ->
  let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~make_admin
          ~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
  Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
  >>= fun () ->
  let client n =
    Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
  in
  Tezos_client.successful_client_cmd
    state
    ~client:(client 0)
    Tezos_protocol.Account.
      [ "import";
        "secret";
        "key";
        name other_baker_account;
        private_key other_baker_account ]
  >>= fun _ ->
  Tezos_client.successful_client_cmd
    state
    ~client:(client 0)
    Tezos_protocol.Account.["bake"; "for"; name other_baker_account]
  >>= fun _ ->
  let assert_hwms_ ~main ~test () =
    assert_hwms state ~client:(client 0) ~uri ~main ~test
  in
  let set_hwm_ level () =
    with_ledger_prompt
      state
      EF.(wf "Setting HWM to %d" level)
      `Succeeds
      ~f:(fun () ->
        Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level)
  in
  get_chain_id state ~client:(client 0)
  >>= fun chain_id ->
  setup_baking_ledger state uri ~client:(client 0) ~protocol
  >>= fun (baker, ledger_account) ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.
      [ arbitrary_command_on_all_clients
          state
          ~command_names:["baker"]
          ~make_admin
          ~clients:[baker.Tezos_client.Keyed.client] ] ;
  let bake () = Tezos_client.Keyed.bake state baker "Baked by ledger" in
  let endorse () =
    Tezos_client.Keyed.endorse state baker "Endorsed by ledger"
  in
  let ask_hwm ~main ~test () =
    assert_hwms_ ~main ~test ()
    >>= ask_assert
          state
          EF.(wf "Is 'Chain' = %S and 'Last Block Level' = %d" "mainnet" main)
  in
  ( if enable_deterministic_nonce_tests then
    (* Test determinism of nonces *)
    Tezos_client.Keyed.generate_nonce state baker "this"
    >>= fun thisNonce1 ->
    Tezos_client.Keyed.generate_nonce state baker "that"
    >>= fun thatNonce1 ->
    Tezos_client.Keyed.generate_nonce state baker "this"
    >>= fun thisNonce2 ->
    Tezos_client.Keyed.generate_nonce state baker "that"
    >>= fun thatNonce2 ->
    assert_eq (fun x -> x) ~expected:thisNonce1 ~actual:thisNonce2
    >>= fun () ->
    assert_eq (fun x -> x) ~expected:thatNonce1 ~actual:thatNonce2
    >>= fun () -> assert_ (thisNonce1 <> thatNonce1)
  else return () )
  >>= fun () ->
  assert_failure
    state
    "originating an account from the Tezos Baking app should fail"
    (fun () ->
      originate_account_from state ~client:(client 0) ~account:ledger_account
      >>= fun _ -> return ())
    ()
  >>= fun () ->
  let fee = 0.00126 in
  let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
  forge_delegation
    state
    ~client:(client 0)
    ()
    ~src:ledger_pkh
    ~dest:ledger_pkh
    ~fee
  >>= fun forged_delegation_bytes ->
  with_ledger_test_reject_and_succeed
    state
    EF.(wf "Self delegating address %s with fee %f" ledger_pkh fee)
    (sign state ~client:baker ~bytes:forged_delegation_bytes)
  >>= bake >>= ask_hwm ~main:3 ~test:0
  >>= fun () ->
  (let level = 1 in
   with_ledger_test_reject_and_succeed
     state
     EF.(wf "Setting HWM to %d" level)
     (fun () ->
       Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level))
  >>= assert_hwms_ ~main:1 ~test:1
  >>= bake
  >>= assert_hwms_ ~main:4 ~test:1
  >>= set_hwm_ 5
  >>= assert_hwms_ ~main:5 ~test:5
  >>= assert_failure state "endorsing a level beneath HWM should fail" endorse
  >>= assert_failure state "baking a level beneath HWM should fail" bake
  >>= set_hwm_ 4 >>= bake
  >>= assert_hwms_ ~main:5 ~test:4
  >>= endorse (* does not increase level since we just baked *)
  >>= assert_failure state "endorsing same block twice should not work" endorse
  >>= assert_hwms_ ~main:5 ~test:4
  >>= bake
  >>= assert_hwms_ ~main:6 ~test:4
  >>= forge_endorsement state ~client:baker.client ~chain_id ~level:1
  >>= fun endorsement_at_low_level_bytes ->
  assert_failure
    state
    "endorsing-after-baking a level beneath HWM should fail"
    (sign state ~client:baker ~bytes:endorsement_at_low_level_bytes)
    ()
  >>= assert_hwms_ ~main:6 ~test:4
  (* HWM has not changed *)
  >>= endorse
  (* HWM still has not changed *)
  >>= assert_hwms_ ~main:6 ~test:4
  (* Forge an endorsement on a different chain *)
  >>= fun () ->
  let other_chain_id = "NetXSzLHKwSumh7" in
  Console.say
    state
    EF.(
      wf "Signing a forged endorsement on a different chain: %s" other_chain_id)
  >>= forge_endorsement
        state
        ~client:baker.client
        ~chain_id:(Tezos_crypto.Chain_id.of_b58check_exn other_chain_id)
        ~level:5
  >>= fun endorsement_on_different_chain_bytes ->
  sign state ~client:baker ~bytes:endorsement_on_different_chain_bytes ()
  (* Only the test HWM has changed *)
  >>= assert_hwms_ ~main:6 ~test:5
  >>= fun () ->
  Loop.n_times 5 (fun _ -> bake ())
  >>= ask_hwm ~main:11 ~test:5
  >>= fun () ->
  Tezos_client.Ledger.deauthorize_baking state ~client:(client 0) ~uri
  >>= assert_failure state "baking after deauthorization should fail" bake
  >>= assert_failure
        state
        "endorsing after deauthorization should fail"
        endorse

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun uri
             node_exec
             client_exec
             admin_exec
             size
             (`Base_port base_port)
             no_deterministic_nonce_tests
             protocol
             state
             ->
          ( state,
            Interactive_test.Pauser.run_test
              ~pp_error
              state
              (run
                 state
                 ~protocol
                 ~node_exec
                 ~size
                 ~admin_exec
                 ~base_port
                 ~client_exec
                 ~enable_deterministic_nonce_tests:
                   (not no_deterministic_nonce_tests)
                 ~uri) ))
    $ Arg.(
        required
          (pos
             0
             (some string)
             None
             (info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI")))
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Tezos_executable.cli_term `Admin "tezos"
    $ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network")))
    $ Arg.(
        pure (fun p -> `Base_port p)
        $ value
            (opt
               int
               46_000
               (info ["base-port"; "P"] ~doc:"Base port number to build upon")))
    $ Arg.(
        value
          (flag
             (info
                ["no-deterministic-nonce-tests"]
                ~doc:"Disable tests for deterministic nonces")))
    $ Tezos_protocol.cli_term ()
    $ Test_command_line.cli_state ~name:"ledger-baking" () )
    (let doc = "Interactive test exercising the Ledger Baking app features" in
     info ~doc "ledger-baking")
src/bin_sandbox/command_ledger_baking.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition failf {A B : Type} (fmt : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (fun s => op_star_t_y_p_e_minus_e_r_r_o_r_star variant) fmt.

Definition ledger_prompt_notice {A B C : Type}
  (state : A) (ef : B) (op_star_o_p_t_star : option variant) : unit -> C :=
  let button :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      let button_str :=
        match button with
        | Checkmark => "✔" % string
        | X => "❌" % string
        | Both => "❌ and ✔ at the same time" % string
        end in
      op_star_t_y_p_e_minus_e_r_r_o_r_star state
        op_star_t_y_p_e_minus_e_r_r_o_r_star
    end.

Definition assert_failure {A B C D : Type}
  (state : A) (msg : B) (f : unit -> C) (function_parameter : unit) : D :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state
        op_star_t_y_p_e_minus_e_r_r_o_r_star)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star (f tt)
                (fun function_parameter =>
                  match function_parameter with
                  | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
                  end))
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  fun function_parameter =>
                    match function_parameter with
                    | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
                    end
                end))
            (fun function_parameter =>
              match function_parameter with
              | Worked => failf "%s" % string msg
              | Didn'tWork => op_star_t_y_p_e_minus_e_r_r_o_r_star tt
              end)
        end)
  end.

Definition failf {A B : Type} (fmt : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (fun s => op_star_t_y_p_e_minus_e_r_r_o_r_star variant) fmt.

Definition assert_ {A : Type} (a : bool) : A :=
  if a then
    op_star_t_y_p_e_minus_e_r_r_o_r_star tt
  else
    failf "Assertion failed" % string.

Definition assert_eq {A B C : Type}
  (to_string : A -> B) (expected : A) (actual : A) : C :=
  if equiv_decb expected actual then
    op_star_t_y_p_e_minus_e_r_r_o_r_star tt
  else
    failf "Assertion failed: expected %s but got %s" % string
      (to_string expected) (to_string actual).

Fixpoint ask {A B C : Type} (state : A) (ef : B) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
      op_star_t_y_p_e_minus_e_r_r_o_r_star)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star)
          (fun function_parameter =>
            match function_parameter with
            | "y" % char | "Y" % char =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star true
            | "n" % char | "N" % char =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star false
            | _ => ask state ef
            end)
      end).

Definition ask_assert {A B C : Type}
  (state : A) (ef : B) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star (ask state ef) (fun b => assert_ b)
  end.

Definition with_ledger_prompt {A B C D : Type}
  (state : A) (message : B) (expectation : variant) (f : unit -> C) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (ledger_prompt_notice state op_star_t_y_p_e_minus_e_r_r_o_r_star
      (Some
        match expectation with
        | Succeeds => variant
        | Fails => variant
        end) tt)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        match expectation with
        | Succeeds =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star (f tt)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star state
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
              end)
        | Fails =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (assert_failure state "expected failure" % string f tt)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star state
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
              end)
        end
      end).

Definition with_ledger_test_reject_and_succeed {A B C D : Type}
  (state : A) (ef : B) (f : unit -> C) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star (with_ledger_prompt state ef variant f)
    (fun function_parameter =>
      match function_parameter with
      | tt => with_ledger_prompt state ef variant f
      end).

Definition assert_hwms {A B C D : Type}
  (state : A) (client : B) (uri : C) (main : Z) (test : Z) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
      op_star_t_y_p_e_minus_e_r_r_o_r_star)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star state client uri)
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (assert_eq OCaml.Stdlib.string_of_int main
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    assert_eq OCaml.Stdlib.string_of_int test
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                  end)
            end)
      end).

Definition get_chain_id {A B C : Type} (state : A) (client : B) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state client variant
        "/chains/main/chain_id" % string)
      (fun function_parameter =>
        match function_parameter with
        | String x => op_star_t_y_p_e_minus_e_r_r_o_r_star x
        | _ => failf "Failed to parse chain_id JSON from node" % string
        end))
    (fun chain_id_string =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star chain_id_string)).

Definition get_head_block_hash {A B C : Type}
  (state : A) (client : B) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state client variant
        "/chains/main/blocks/head/hash" % string)
      (fun function_parameter =>
        match function_parameter with
        | String x => op_star_t_y_p_e_minus_e_r_r_o_r_star x
        | _ => failf "Failed to parse block hash JSON from node" % string
        end)
  end.

Definition forge_endorsement {A B C D : Type}
  (state : A) (client : B) (chain_id : C) (level : Z)
  (function_parameter : unit) : D :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star (get_head_block_hash state client tt)
      (fun branch =>
        let json := variant in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
            "/chains/main/blocks/head/helpers/forge/operations" % string variant)
          (fun function_parameter =>
            match function_parameter with
            | String operation_bytes =>
              let endorsement_magic_byte := "02" % string in
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (String.append endorsement_magic_byte
                  (String.append
                    (OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply chain_id
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      op_star_t_y_p_e_minus_e_r_r_o_r_star) operation_bytes))
            | _ => failf "Failed to forge operation or parse result" % string
            end))
  end.

Definition forge_delegation {A B C : Type}
  (state : A) (client : B) (src : string) (dest : string)
  (op_star_o_p_t_star : option float) : unit -> C :=
  let fee :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star (get_head_block_hash state client tt)
        (fun branch =>
          let json := variant in
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
              "/chains/main/blocks/head/helpers/forge/operations" % string
              variant)
            (fun function_parameter =>
              match function_parameter with
              | String operation_bytes =>
                let magic_byte := "03" % string in
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (String.append magic_byte operation_bytes)
              | _ => failf "Failed to forge operation or parse result" % string
              end))
    end.

Definition sign {A B C : Type}
  (state : A) (client : B) (bytes : string) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state
        (Tezos_client.Keyed.client client)
        (cons "sign" % string
          (cons "bytes" % string
            (cons (String.append "0x" % string string)
              (cons "for" % string
                (cons (Tezos_client.Keyed.key_name client) []))))))
      (fun function_parameter =>
        match function_parameter with
        | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star tt
        end)
  end.

Definition originate_account_from {A B C D : Type}
  (state : A) (client : B) (account : C) : D :=
  let orig_account_name :=
    String.append (op_star_t_y_p_e_minus_e_r_r_o_r_star account)
      "-originated-account" % string in
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
      (cons "originate" % string
        (cons "account" % string
          (cons orig_account_name
            (cons "for" % string
              (cons (op_star_t_y_p_e_minus_e_r_r_o_r_star account)
                (cons "transferring" % string
                  (cons (OCaml.Stdlib.string_of_int 1000)
                    (cons "from" % string
                      (cons (op_star_t_y_p_e_minus_e_r_r_o_r_star account)
                        (cons "--burn-cap" % string
                          (cons (Stdlib.string_of_float 0) []))))))))))))
    (fun function_parameter =>
      match function_parameter with
      | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star orig_account_name
      end).

Definition setup_baking_ledger {A B C D : Type}
  (state : A) (uri : string) (client : B) (protocol : C) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
      op_star_t_y_p_e_minus_e_r_r_o_r_star)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let key_name := "ledgered" % string in
        let baker := op_star_t_y_p_e_minus_e_r_r_o_r_star client key_name uri in
        let assert_baking_key {E : Type}
          (x : option string) (function_parameter : unit) : E :=
          match function_parameter with
          | tt =>
            let to_string (function_parameter : option string) : string :=
              match function_parameter with
              | Some x => x
              | None => "<none>" % string
              end in
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                op_star_t_y_p_e_minus_e_r_r_o_r_star)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state client uri)
                    (fun auth_key => assert_eq to_string x auth_key)
                end)
          end in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star state client uri)
            (assert_baking_key None))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star state client uri)
                (fun account =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (with_ledger_test_reject_and_succeed state
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                  baker)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star tt
                                  end)
                            end))
                        (assert_failure state
                          "baking before setup should fail" % string
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star state baker
                                "Baked by ledger" % string
                            end)))
                      (assert_failure state
                        "endorsing before setup should fail" % string
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star state baker
                              "Endorsed by ledger" % string
                          end)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        let test_invalid_delegations {E : Type}
                          (function_parameter : unit) : E :=
                          match function_parameter with
                          | tt =>
                            let ledger_pkh :=
                              op_star_t_y_p_e_minus_e_r_r_o_r_star account in
                            let other_pkh :=
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (fst
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (Tezos_protocol.bootstrap_accounts protocol)))
                              in
                            let cases :=
                              cons
                                (ledger_pkh, other_pkh,
                                  "ledger to another account" % string)
                                (cons
                                  (other_pkh, ledger_pkh,
                                    "another account to ledger" % string)
                                  (cons
                                    (other_pkh, other_pkh,
                                      "another account to another account" %
                                        string) [])) in
                            op_star_t_y_p_e_minus_e_r_r_o_r_star cases
                              (fun function_parameter =>
                                match function_parameter with
                                | (src, dest, msg) =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (forge_delegation state client src dest None
                                      tt)
                                    (fun forged_delegation_bytes =>
                                      assert_failure state
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          "signing a delegation from %s (%s to %s) should fail"
                                            % string msg src dest)
                                        (sign state baker
                                          forged_delegation_bytes) tt)
                                end)
                          end in
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (test_invalid_delegations tt)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (with_ledger_test_reject_and_succeed state
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              state client
                                              (cons "setup" % string
                                                (cons "ledger" % string
                                                  (cons "to" % string
                                                    (cons "bake" % string
                                                      (cons "for" % string
                                                        (cons key_name
                                                          (cons
                                                            "--main-hwm" %
                                                              string
                                                            (cons "0" % string
                                                              (cons
                                                                "--test-hwm" %
                                                                  string
                                                                (cons
                                                                  "0" % string
                                                                  []))))))))))
                                          end))
                                      (assert_failure state
                                        "signing a 'Withdraw delegate' operation in Baking App should fail"
                                          % string
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              state client
                                              (cons "--wait" % string
                                                (cons "none" % string
                                                  (cons "withdraw" % string
                                                    (cons "delegate" % string
                                                      (cons "from" % string
                                                        (cons
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            account) []))))))
                                          end))) (assert_baking_key (Some uri)))
                                  test_invalid_delegations)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (baker, account)
                                  end)
                            end)
                      end))
            end)
      end).

Definition run {A B C D E F G H : Type}
  (state : A) (protocol : B) (node_exec : C) (client_exec : D) (admin_exec : E)
  (size : F) (base_port : G) (uri : string)
  (enable_deterministic_nonce_tests : bool) (function_parameter : unit) : H :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star state
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let ledger_client :=
                  op_star_t_y_p_e_minus_e_r_r_o_r_star client_exec in
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state ledger_client uri)
                  (fun ledger_account =>
                    let protocol := op_star_t_y_p_e_minus_e_r_r_o_r_star in
                    let other_baker_account :=
                      fst
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (Tezos_protocol.bootstrap_accounts protocol) 1) in
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star protocol size
                        base_port state node_exec client_exec)
                      (fun function_parameter =>
                        match function_parameter with
                        | (nodes, protocol) =>
                          let make_admin :=
                            op_star_t_y_p_e_minus_e_r_r_o_r_star admin_exec in
                          op_star_t_y_p_e_minus_e_r_r_o_r_star state
                            op_star_t_y_p_e_minus_e_r_r_o_r_star;
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                let client {I J : Type} (n : I) : J :=
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    client_exec
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star nodes
                                      n) in
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                    (client 0)
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          state (client 0)
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | _ =>
                                            let assert_hwms_ {I : Type}
                                              (main : Z) (test : Z)
                                              (function_parameter : unit) : I :=
                                              match function_parameter with
                                              | tt =>
                                                assert_hwms state (client 0) uri
                                                  main test
                                              end in
                                            let set_hwm_ {I J : Type}
                                              (level : I) (function_parameter :
                                              unit) : J :=
                                              match function_parameter with
                                              | tt =>
                                                with_ledger_prompt state
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  variant
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        state (client 0) uri
                                                        level
                                                    end)
                                              end in
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (get_chain_id state (client 0))
                                              (fun chain_id =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (setup_baking_ledger state uri
                                                    (client 0) protocol)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | (baker, ledger_account) =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        state
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star;
                                                      let bake {I : Type}
                                                        (function_parameter :
                                                        unit) : I :=
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            state baker
                                                            "Baked by ledger" %
                                                              string
                                                        end in
                                                      let endorse {I : Type}
                                                        (function_parameter :
                                                        unit) : I :=
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            state baker
                                                            "Endorsed by ledger"
                                                              % string
                                                        end in
                                                      let ask_hwm {I : Type}
                                                        (main : Z) (test : Z)
                                                        (function_parameter :
                                                        unit) : I :=
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (assert_hwms_ main
                                                              test tt)
                                                            (ask_assert state
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                        end in
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (if
                                                          enable_deterministic_nonce_tests
                                                          then
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              state baker
                                                              "this" % string)
                                                            (fun thisNonce1 =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  state baker
                                                                  "that" %
                                                                    string)
                                                                (fun thatNonce1
                                                                  =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      state
                                                                      baker
                                                                      "this" %
                                                                        string)
                                                                    (fun
                                                                      thisNonce2
                                                                      =>
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          state
                                                                          baker
                                                                          "that"
                                                                            %
                                                                            string)
                                                                        (fun
                                                                          thatNonce2
                                                                          =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (assert_eq
                                                                              (fun
                                                                                x
                                                                                =>
                                                                                x)
                                                                              thisNonce1
                                                                              thisNonce2)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (assert_eq
                                                                                    (fun
                                                                                      x
                                                                                      =>
                                                                                      x)
                                                                                    thatNonce1
                                                                                    thatNonce2)
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      assert_
                                                                                        (nequiv_decb
                                                                                          thisNonce1
                                                                                          thatNonce1)
                                                                                    end)
                                                                              end)))))
                                                        else
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            tt)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (assert_failure
                                                                state
                                                                "originating an account from the Tezos Baking app should fail"
                                                                  % string
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (originate_account_from
                                                                        state
                                                                        (client
                                                                          0)
                                                                        ledger_account)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | _ =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            tt
                                                                        end)
                                                                  end) tt)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  let fee := 0
                                                                    in
                                                                  let
                                                                    ledger_pkh :=
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      ledger_account
                                                                    in
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    (forge_delegation
                                                                      state
                                                                      (client 0)
                                                                      ledger_pkh
                                                                      ledger_pkh
                                                                      (Some fee)
                                                                      tt)
                                                                    (fun
                                                                      forged_delegation_bytes
                                                                      =>
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (with_ledger_test_reject_and_succeed
                                                                              state
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              (sign
                                                                                state
                                                                                baker
                                                                                forged_delegation_bytes))
                                                                            bake)
                                                                          (ask_hwm
                                                                            3 0))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | tt
                                                                            =>
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              (let
                                                                                                                level :=
                                                                                                                1
                                                                                                                in
                                                                                                              with_ledger_test_reject_and_succeed
                                                                                                                state
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  match
                                                                                                                    function_parameter
                                                                                                                    with
                                                                                                                  |
                                                                                                                    tt
                                                                                                                    =>
                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      state
                                                                                                                      (client
                                                                                                                        0)
                                                                                                                      uri
                                                                                                                      level
                                                                                                                  end))
                                                                                                              (assert_hwms_
                                                                                                                1
                                                                                                                1))
                                                                                                            bake)
                                                                                                          (assert_hwms_
                                                                                                            4
                                                                                                            1))
                                                                                                        (set_hwm_
                                                                                                          5))
                                                                                                      (assert_hwms_
                                                                                                        5
                                                                                                        5))
                                                                                                    (assert_failure
                                                                                                      state
                                                                                                      "endorsing a level beneath HWM should fail"
                                                                                                        %
                                                                                                        string
                                                                                                      endorse))
                                                                                                  (assert_failure
                                                                                                    state
                                                                                                    "baking a level beneath HWM should fail"
                                                                                                      %
                                                                                                      string
                                                                                                    bake))
                                                                                                (set_hwm_
                                                                                                  4))
                                                                                              bake)
                                                                                            (assert_hwms_
                                                                                              5
                                                                                              4))
                                                                                          endorse)
                                                                                        (assert_failure
                                                                                          state
                                                                                          "endorsing same block twice should not work"
                                                                                            %
                                                                                            string
                                                                                          endorse))
                                                                                      (assert_hwms_
                                                                                        5
                                                                                        4))
                                                                                    bake)
                                                                                  (assert_hwms_
                                                                                    6
                                                                                    4))
                                                                                (forge_endorsement
                                                                                  state
                                                                                  (client
                                                                                    baker)
                                                                                  chain_id
                                                                                  1))
                                                                              (fun
                                                                                endorsement_at_low_level_bytes
                                                                                =>
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (assert_failure
                                                                                          state
                                                                                          "endorsing-after-baking a level beneath HWM should fail"
                                                                                            %
                                                                                            string
                                                                                          (sign
                                                                                            state
                                                                                            baker
                                                                                            endorsement_at_low_level_bytes)
                                                                                          tt)
                                                                                        (assert_hwms_
                                                                                          6
                                                                                          4))
                                                                                      endorse)
                                                                                    (assert_hwms_
                                                                                      6
                                                                                      4))
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      let
                                                                                        other_chain_id :=
                                                                                        "NetXSzLHKwSumh7"
                                                                                          %
                                                                                          string
                                                                                        in
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            state
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                          (forge_endorsement
                                                                                            state
                                                                                            (client
                                                                                              baker)
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              other_chain_id)
                                                                                            5))
                                                                                        (fun
                                                                                          endorsement_on_different_chain_bytes
                                                                                          =>
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (sign
                                                                                                state
                                                                                                baker
                                                                                                endorsement_on_different_chain_bytes
                                                                                                tt)
                                                                                              (assert_hwms_
                                                                                                6
                                                                                                5))
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                tt
                                                                                                =>
                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      5
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        match
                                                                                                          function_parameter
                                                                                                          with
                                                                                                        |
                                                                                                          _
                                                                                                          =>
                                                                                                          bake
                                                                                                            tt
                                                                                                        end))
                                                                                                    (ask_hwm
                                                                                                      11
                                                                                                      5))
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    match
                                                                                                      function_parameter
                                                                                                      with
                                                                                                    |
                                                                                                      tt
                                                                                                      =>
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            state
                                                                                                            (client
                                                                                                              0)
                                                                                                            uri)
                                                                                                          (assert_failure
                                                                                                            state
                                                                                                            "baking after deauthorization should fail"
                                                                                                              %
                                                                                                              string
                                                                                                            bake))
                                                                                                        (assert_failure
                                                                                                          state
                                                                                                          "endorsing after deauthorization should fail"
                                                                                                            %
                                                                                                            string
                                                                                                          endorse)
                                                                                                    end)
                                                                                              end))
                                                                                    end))
                                                                          end))
                                                                end)
                                                          end)
                                                    end))
                                          end)
                                    end)
                              end)
                        end))
              end)
        end)
  end.

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  match function_parameter with
  | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.
src/bin_sandbox/command_ledger_wallet.ml 
open Flextesa
open Internal_pervasives

let client_async_cmd state ~client args ~f =
  Running_processes.Async.run_cmdf
    ~id_base:"client_async_cmd"
    state
    ~f
    "sh -c %s"
    ( Tezos_client.client_command client ~state args
    |> Genspio.Compile.to_one_liner |> Filename.quote )
  >>= fun (status, res) ->
  return
    ( object
        method out = fst res

        method err = snd res

        method status = status
      end
      : Process_result.t )

let ledger_hash_re =
  lazy
    Re.(
      compile
        (seq
           [ str "* Blake 2B Hash (ledger-style, with operation watermark):";
             rep1 (alt [space; eol]);
             group (rep1 alnum);
             rep1 (alt [space; eol]) ]))

(* Searches a stream for an expected ledger hash from `tezos-client --verbose-signing`*)
let find_and_print_signature_hash ?(display_expectation = true) state process =
  let re = Lazy.force ledger_hash_re in
  let check lines =
    Re.(
      match exec_opt re lines with
      | None ->
          None
      | Some matches ->
          Some (Group.get matches 1))
  in
  (* Dbg.e EF.(wf "find_and_print_signature_hash") ; *)
  Running_processes.Async.fold_process
    process
    ~init:("", "", not display_expectation)
    ~f:(fun (all_output_prev, all_error_prev, showed_message_prev) out err ->
      (* Dbg.e EF.(wf "find_and_print_signature_hash.fold_process %S %S" out err) ; *)
      let all_output = all_output_prev ^ out in
      let all_error = all_error_prev ^ err in
      ( if not showed_message_prev then
        match check all_output with
        | None ->
            return false
        | Some x ->
            Console.say state EF.(wf "Displayed hash should be: `%s`" x)
            >>= fun () -> return true
      else return true )
      >>= fun showed_message ->
      return (`Continue (all_output, all_error, showed_message)))
  >>= fun (output, error, _) ->
  return (String.split ~on:'\n' output, String.split ~on:'\n' error)

module MFmt = Experiments.More_fmt

let failf ?attach fmt =
  ksprintf (fun s -> fail ?attach (`Scenario_error s)) fmt

let process_should_fail msg f =
  Asynchronous_result.bind_on_error
    ( f ()
    >>= fun (proc : Process_result.t) ->
    match proc#status with
    | Unix.WEXITED 0 ->
        failf
          "Process should have failed: %s"
          msg
          ~attach:
            [("stdout", `Verbatim proc#out); ("stderr", `Verbatim proc#err)]
    | _ ->
        return () )
    ~f:(fun ~result:_ _ -> return ())

let ledger_prompt_notice state ~msgs ?(button = `Checkmark) () =
  let button_str =
    match button with
    | `Checkmark ->
        "✔"
    | `X ->
        "❌"
    | `Both ->
        "❌ and ✔ at the same time"
  in
  Console.sayf
    state
    MFmt.(
      fun ppf () ->
        vertical_box ~indent:4 ppf (fun ppf ->
            shout ppf (fun ppf -> const string "Ledger-prompt:" ppf ()) ;
            cut ppf () ;
            List.iter msgs ~f:(fun f -> f ppf () ; cut ppf ()) ;
            wf ppf "→ Press %s on the ledger." button_str))

let ledger_prompt_notice_expectation state ~messages ~user_answer =
  ledger_prompt_notice
    state
    ()
    ~button:(match user_answer with `Accept -> `Checkmark | `Reject -> `X)
    ~msgs:
      ( messages
      @ MFmt.
          [ cut;
            (fun ppf () ->
              match user_answer with
              | `Accept ->
                  shout ppf (fun ppf -> pf ppf ">> ACCEPT THIS <<")
              | `Reject ->
                  shout ppf (fun ppf -> pf ppf ">> REJECT THIS <<")) ] )

let with_ledger_test_reject_and_accept ?(only_success = false) state ~messages
    f =
  let with_ledger_prompt state ~messages ~user_answer ~f =
    ledger_prompt_notice_expectation state ~messages ~user_answer
    >>= fun () -> f ~user_answer
  in
  ( if only_success then return ()
  else with_ledger_prompt state ~messages ~user_answer:`Reject ~f )
  >>= fun () -> with_ledger_prompt state ~messages ~user_answer:`Accept ~f

let get_chain_id state ~client =
  Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id"
  >>= (function
        | `String x ->
            return x
        | _ ->
            failf "Failed to parse chain_id JSON from node")
  >>= fun chain_id_string ->
  return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string)

let get_head_block_hash state ~client () =
  Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash"
  >>= function
  | `String x ->
      return x
  | _ ->
      failf "Failed to parse block hash JSON from node"

let please_check_the_hash ppf () =
  let open MFmt in
  tag "prompt" ppf (fun ppf ->
      wf ppf "The ledger cannot parse this operation, please verify the hash.")

let forge_batch_transactions state ~client ~src ~dest:_ ~n ?(fee = 0.00126) ()
    =
  get_head_block_hash state ~client ()
  >>= fun branch ->
  let json =
    `O
      [ ("branch", `String branch);
        ( "contents",
          `A
            (List.map (List.range 0 n) ~f:(fun i ->
                 `O
                   [ ("kind", `String "transaction");
                     ("source", `String src);
                     ( "destination",
                       `String "tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F" );
                     ("amount", `String (string_of_int 100));
                     ( "fee",
                       `String (string_of_int (int_of_float (fee *. 1000000.)))
                     );
                     ("counter", `String (string_of_int i));
                     ("gas_limit", `String (string_of_int 127));
                     ("storage_limit", `String (string_of_int 277)) ])) ) ]
  in
  Tezos_client.rpc
    state
    ~client
    ~path:"/chains/main/blocks/head/helpers/forge/operations"
    (`Post (Ezjsonm.to_string json))
  >>= function
  | `String operation_bytes ->
      let magic_byte = "03" in
      return (magic_byte ^ operation_bytes)
  | _ ->
      failf "Failed to forge operation or parse result"

let expect_from_output ~expectation ~message (proc_res : Process_result.t) =
  (* let expect_rejection msg (success, (stdout, stderr)) = *)
  let exp =
    match expectation with
    | `Ledger_reject_or_timeout ->
        "rejection"
    | `Not_a_delegate ->
        "not-delegate-error"
    | `Success ->
        "success"
    | `Origination_failed ->
        "origination-failure"
  in
  let nope s =
    failf
      ~attach:
        [("stdout", `Verbatim proc_res#out); ("stderr", `Verbatim proc_res#err)]
      "%s, expected %s: %s."
      message
      exp
      s
  in
  let success = proc_res#status = Unix.WEXITED 0 in
  match expectation with
  | `Success when success ->
      return ()
  | `Success ->
      nope "did not succeed"
  | (`Ledger_reject_or_timeout | `Not_a_delegate | `Origination_failed) as e
    -> (
      let pattern =
        match e with
        | `Ledger_reject_or_timeout ->
            "Conditions of use not satisfied"
        | `Not_a_delegate ->
            "not registered as valid delegate key"
        | `Origination_failed ->
            "origination simulation failed"
      in
      let all_output = String.concat ~sep:"\n" (proc_res#out @ proc_res#err) in
      match (success, String.substr_index all_output ~pattern) with
      | (false, Some _) ->
          return ()
      | (false, None) ->
          nope "cannot find the right error message"
      | (true, _) ->
          nope "command succeeded??" )

let voting_tests state ~client ~src ~with_rejections ~protocol_kind
    ~ledger_account ~tested_proposal ~go_to_next_period () =
  let expect_success message v =
    expect_from_output ~expectation:`Not_a_delegate ~message v
  in
  let expect_rejection message v =
    expect_from_output ~expectation:`Ledger_reject_or_timeout ~message v
  in
  let test_reject_and_accept name ~messages action =
    ( if with_rejections then
      ledger_prompt_notice_expectation state ~messages ~user_answer:`Reject
      >>= fun () -> action () >>= fun res -> expect_rejection name res
    else return () )
    >>= fun () ->
    ledger_prompt_notice_expectation state ~messages ~user_answer:`Accept
    >>= fun () -> action () >>= fun res -> expect_success name res
  in
  let source_display = Tezos_protocol.Account.pubkey_hash ledger_account in
  let submit_proposals ~display_expectation proposals () =
    client_async_cmd
      state
      ~client:(client 0)
      ~f:(fun _ proc ->
        find_and_print_signature_hash ~display_expectation state proc)
      ( ["submit"; "proposals"; "for"; src]
      @ proposals
      @ ["--force"; "--verbose-signing"] )
  in
  test_reject_and_accept
    "single-proposal"
    ~messages:
      MFmt.
        [ (fun ppf () -> wf ppf "Submitting single proposal %s" tested_proposal);
          (fun ppf () ->
            match protocol_kind with
            | `Athens ->
                ()
            | `Babylon ->
                wf
                  ppf
                  "On Babylon, You will first be asked to provide the public \
                   key." ;
                cut ppf () ;
                wf
                  ppf
                  "Accept this prompt, regardless of below, then continue.");
          (fun ppf () ->
            vertical_box ppf ~indent:4 (fun ppf ->
                wf
                  ppf
                  "Protocol is %a, the ledger should be able to display \
                   voting parameters:"
                  Tezos_protocol.Protocol_kind.pp
                  protocol_kind ;
                cut ppf () ;
                wf ppf "* Source: `%s`" source_display ;
                cut ppf () ;
                wf ppf "* Period: `0`" ;
                cut ppf () ;
                wf ppf "* Protocol: `%s`" tested_proposal)) ]
    (submit_proposals ~display_expectation:false [tested_proposal])
  >>= fun () ->
  test_reject_and_accept
    "multiple-proposal"
    ~messages:
      MFmt.
        [ (fun ppf () -> wf ppf "Submitting 2 proposals together");
          please_check_the_hash ]
    (submit_proposals
       ~display_expectation:true
       [tested_proposal; "Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z"])
  >>= fun () ->
  go_to_next_period ()
  >>= fun () ->
  List_sequential.iteri ["yea"; "nay"] ~f:(fun n vote ->
      test_reject_and_accept
        (Fmt.strf "vote-%s" vote)
        ~messages:
          MFmt.
            [ (fun ppf () ->
                match protocol_kind with
                | `Athens ->
                    ()
                | `Babylon ->
                    wf
                      ppf
                      "On Babylon, You will first be asked to provide the \
                       public key." ;
                    cut ppf () ;
                    wf
                      ppf
                      "Accept this prompt, regardless of below, then continue.");
              (fun ppf () -> wf ppf "Voting %s for %s" vote tested_proposal);
              (fun ppf () -> wf ppf "Source: `%s`" source_display);
              (fun ppf () -> wf ppf "Period: `%i`" (n + 1));
              (fun ppf () -> wf ppf "Protocol: `%s`" tested_proposal) ]
        (fun () ->
          Tezos_client.client_cmd
            state
            ~client:(client 0)
            ["submit"; "ballot"; "for"; src; tested_proposal; vote]
          >>= fun (_, proc) -> return proc))

let ledger_should_display ppf l =
  let open MFmt in
  vertical_box ~indent:4 ppf (fun ppf ->
      wf ppf "Ledger should display:" ;
      List.iter l ~f:(fun (s, f) -> cut ppf () ; pf ppf "* %s: %a." s f ()))

let show_command_message command =
  MFmt.(
    fun ppf () ->
      wrapping_box ~indent:2 ppf (fun ppf ->
          wf ppf "Command:" ;
          sp ppf () ;
          const
            (list ~sep:sp string)
            ("<tezos-client>" :: command |> List.map ~f:Filename.quote)
            ppf
            ()))

let sign state ~client ~bytes =
  Tezos_client.client_cmd
    state
    ~client:client.Tezos_client.Keyed.client
    ["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name]

let delegation_tests state ~client ~src ~with_rejections ~protocol_kind
    ~ledger_account ~delegate ~bake () =
  let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
  let only_success = not with_rejections in
  let self_delegation () =
    (* Which is equivalent to registration as delegate. *)
    let command =
      [ "--wait";
        "none";
        "set";
        "delegate";
        "for";
        src;
        "to";
        src;
        "--verbose-signing" ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () -> wf ppf "Self-delegating account `%s`" ledger_pkh);
            show_command_message command;
            (fun ppf () ->
              wf
                ppf
                "Note that X is a placeholder for some value that will vary \
                 between runs");
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Fee", const string "0.00XXX");
                  ("Source", const string ledger_pkh);
                  ("Delegate", const string ledger_pkh);
                  ("Storage", const int 0) ]) ]
      (fun ~user_answer ->
        client_async_cmd
          state
          ~client
          ~f:(fun _ proc ->
            find_and_print_signature_hash
              ~display_expectation:(protocol_kind = `Babylon)
              state
              proc)
          command
        >>= fun res ->
        expect_from_output
          ~message:"self-delegation"
          res
          ~expectation:
            ( match user_answer with
            | `Reject ->
                `Ledger_reject_or_timeout
            | `Accept ->
                `Success ))
    >>= fun _ -> ksprintf bake "setting self-delegate of %s" src
    (* Self-delegate deletion is forbidden for both Athens and Babylon *)
  in
  let tz_account_delegation () =
    let command =
      [ "--wait";
        "none";
        "set";
        "delegate";
        "for";
        src;
        "to";
        delegate;
        "--verbose-signing" ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf ppf "Delegating account `%s` to `%s`" ledger_pkh delegate);
            show_command_message command;
            (fun ppf () ->
              wf
                ppf
                "Note that X is a placeholder for some value that will vary \
                 between runs");
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Fee", const string "0.00XXX");
                  ("Source", const string ledger_pkh);
                  ("Delegate", const string delegate);
                  ("Storage", const int 0) ]) ]
      (fun ~user_answer ->
        client_async_cmd
          state
          ~client
          ~f:(fun _ proc ->
            find_and_print_signature_hash
              ~display_expectation:(protocol_kind = `Babylon)
              state
              proc)
          command
        >>= fun res ->
        expect_from_output
          ~message:"tz123-delegation"
          res
          ~expectation:
            ( match user_answer with
            | `Reject ->
                `Ledger_reject_or_timeout
            | `Accept ->
                `Success ))
    >>= fun _ -> ksprintf bake "setting delegate of %s" src
    (* Self-delegate deletion is forbidden for both Athens and Babylon *)
  in
  let run_command_and_check state ~client ~command ~message ~user_answer =
    Tezos_client.client_cmd state ~client command
    >>= fun (_, res) ->
    expect_from_output
      ~message
      res
      ~expectation:
        ( match user_answer with
        | `Reject ->
            `Ledger_reject_or_timeout
        | `Accept ->
            `Success )
  in
  let delegate_with_scriptless_account () =
    let originated_account_name = "ledginated" in
    let amount = "200" in
    let burn_cap = "0.257" in
    let command =
      [ "--wait";
        "none";
        "originate";
        "account";
        originated_account_name;
        "for";
        src;
        "transferring";
        "200";
        "from";
        src;
        "--delegatable";
        "--burn-cap";
        burn_cap;
        "--force" ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf ppf "Originating account `%s`" originated_account_name);
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Amount", const string amount);
                  ("Fee", const string (strf "≤ %S" burn_cap));
                  ("Source", const string ledger_pkh);
                  ("Manager", const string ledger_pkh);
                  ("Delegation", const string "Any");
                  ("Storage", const int 277) ]) ]
      (fun ~user_answer ->
        run_command_and_check
          state
          ~client
          ~command
          ~message:"account origination"
          ~user_answer)
    >>= fun _ ->
    ksprintf bake "origination of %s" originated_account_name
    >>= fun () ->
    Tezos_client.client_cmd
      state
      ~client
      ["show"; "known"; "contract"; originated_account_name]
    >>= fun (_, proc_result) ->
    let contract_address = proc_result#out |> String.concat ~sep:"" in
    Tezos_client.client_cmd state ~client ["show"; "address"; delegate]
    >>= fun (_, proc_result) ->
    let delegate_address =
      List.hd_exn proc_result#out
      |> String.split ~on:' ' |> List.last
      |> Option.value ~default:delegate
    in
    let command =
      [ "--wait";
        "none";
        "set";
        "delegate";
        "for";
        originated_account_name;
        "to";
        delegate ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf
                ppf
                "Setting `%s` as delegate for `%s`"
                delegate
                originated_account_name);
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Source", const string contract_address);
                  ("Fee", const string "≤ 0.001");
                  ("Delegate", const string delegate_address);
                  ("Storage", const int 0) ]) ]
      (fun ~user_answer ->
        run_command_and_check
          state
          ~client
          ~command
          ~message:"setting delegate of KT1"
          ~user_answer)
    >>= fun () ->
    ksprintf bake "setting delegate of %s" originated_account_name
    >>= fun () ->
    let withdraw_command =
      [ "--wait";
        "none";
        "withdraw";
        "delegate";
        "from";
        originated_account_name ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf ppf "Withdrawing delegate from `%s`" originated_account_name);
            show_command_message withdraw_command;
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Source", const string contract_address);
                  ("Fee", const string "≤ 0.001");
                  ("Delegate", const string "None");
                  ("Storage", const int 0) ]) ]
      (fun ~user_answer ->
        run_command_and_check
          state
          ~client
          ~command:withdraw_command
          ~message:"withdrawing delegate from originated account"
          ~user_answer)
    >>= fun () ->
    ksprintf bake "withdrawing delegate of %s" originated_account_name
  in
  match protocol_kind with
  | `Athens ->
      self_delegation () >>= fun () -> delegate_with_scriptless_account ()
  | `Babylon ->
      tz_account_delegation () >>= fun () -> self_delegation ()

let transaction_tests state ~client ~src ~with_rejections ~protocol_kind
    ~pair_string_nat_kt1_account ~ledger_account ~unit_kt1_account ~bake () =
  let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
  let only_success = not with_rejections in
  let test_transaction ?(storage = 0) ?arguments ~name ~dst_name ~dst_pkh () =
    let amount = "15" in
    let command =
      ["--wait"; "none"; "transfer"; amount; "from"; src; "to"; dst_name]
      @ Option.value_map ~default:[] arguments ~f:(fun a -> ["--arg"; a])
      @ ["--burn-cap"; "100"; "--verbose-signing"]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () -> wf ppf "%s with account `%s`" name ledger_pkh);
            show_command_message command;
            (fun ppf () ->
              wf
                ppf
                "Note that X is a placeholder for some value that will vary \
                 between runs");
            (fun ppf () ->
              match arguments with
              | None ->
                  ledger_should_display
                    ppf
                    [ ("Amount", const string amount);
                      ("Fee", const string "0.00XXX");
                      ("Source", const string ledger_pkh);
                      ("Destination", const string dst_pkh);
                      ("Storage", const int storage) ]
              | _ (* some arguments *) ->
                  please_check_the_hash ppf ()) ]
      (fun ~user_answer ->
        client_async_cmd
          state
          ~client
          ~f:(fun _ proc ->
            find_and_print_signature_hash
              ~display_expectation:
                (protocol_kind = `Babylon || arguments <> None)
              state
              proc)
          command
        >>= fun res ->
        expect_from_output
          ~message:name
          res
          ~expectation:
            ( match user_answer with
            | `Reject ->
                `Ledger_reject_or_timeout
            | `Accept ->
                `Success ))
    >>= fun _ -> ksprintf bake "%s with %s" name src
  in
  test_transaction
    ~name:"Self-transaction"
    ~dst_pkh:ledger_pkh
    ~dst_name:src
    ()
  >>= fun () ->
  let module Acc = Tezos_protocol.Account in
  let random_account = Acc.of_name "random-account-for-transaction-test" in
  test_transaction
    ~name:"transaction-to-random-tz1"
    ~dst_pkh:(Acc.pubkey_hash random_account)
    ~dst_name:(Acc.pubkey_hash random_account)
    ~storage:277
    (* First time: there is a reveal *) ()
  >>= fun () ->
  test_transaction
    ~name:"transaction-to-random-tz1-again"
    ~dst_pkh:(Acc.pubkey_hash random_account)
    ~dst_name:(Acc.pubkey_hash random_account)
    ~storage:0
    (* no moa reveal *) ()
  >>= fun () ->
  test_transaction
    ~name:"parameterless-transaction-to-kt1"
    ~dst_pkh:"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
    ~dst_name:unit_kt1_account
    ()
  >>= fun () ->
  test_transaction
    ~name:"parameterfull-transaction-to-kt1"
    ~dst_pkh:"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
    ~arguments:"Pair \"hello from the ledger\" 51"
    ~dst_name:pair_string_nat_kt1_account
    ()

let prepare_origination_of_id_script ?(spendable = false)
    ?(delegatable = false) ?delegate ?(push_drops = 0) ?(amount = "2") state
    ~client:_ ~name ~from ~protocol_kind ~parameter ~init_storage =
  let id_script parameter =
    Fmt.strf
      "parameter %s;\n\
       storage %s;\n\
       code\n\
      \  {\n\
      \    %s\n\
      \    { CAR; NIL operation; PAIR }\n\
      \  };\n"
      parameter
      parameter
      ( match push_drops with
      | 0 ->
          "# No push-drops"
      | n ->
          Fmt.strf
            "# %d push-drop%s\n    %s"
            n
            (if n > 1 then "s" else "")
            ( List.init push_drops ~f:(fun ith ->
                  Fmt.strf
                    "{ PUSH string %S ; DROP } ;"
                    (Fmt.strf
                       "push-dropping %d adds stupid bytes to the contract"
                       ith))
            |> String.concat ~sep:"\n    " ) )
  in
  let tmp = Filename.temp_file "little-id-script" ".tz" in
  System.write_file state tmp ~content:(id_script parameter)
  >>= fun () ->
  Dbg.e EF.(wf "id_script %s: %s" parameter tmp) ;
  let origination =
    let opt = Option.value_map ~default:[] in
    ["--wait"; "none"; "originate"; "contract"; name]
    @ (match protocol_kind with `Athens -> ["for"; from] | `Babylon -> [])
    @ [ "transferring";
        amount;
        "from";
        from;
        "running";
        tmp;
        "--init";
        init_storage;
        "--force";
        "--burn-cap";
        "300000000000";
        (* ; "--fee-cap" ; "20000000000000" *)
        "--gas-limit";
        "1000000000000000";
        "--storage-limit";
        "20000000000000";
        "--verbose-signing" ]
    @ opt delegate ~f:(fun s -> (* Baby & Aths *) ["--delegate"; s])
    @ (if delegatable then [(* Aths *) "--delegatable"] else [])
    @ if spendable then [(* Aths *) "--spendable"] else []
  in
  return origination

let originate_id_script ?push_drops state ~client ~name ~from ~bake
    ~protocol_kind ~parameter ~init_storage =
  prepare_origination_of_id_script
    state
    ~client
    ~name
    ~from
    ~protocol_kind
    ?push_drops
    ~parameter
    ~init_storage
  >>= fun origination ->
  Tezos_client.successful_client_cmd state ~client origination
  >>= fun _ -> Fmt.kstrf bake "baking `%s` in" name

let pp_warning_ledger_takes_a_while ~adjective =
  let open MFmt in
  fun ppf () ->
    cut ppf () ;
    let prompt = "WARNING: " in
    let warning1 = "The ledger will take a few seconds to show" in
    let warning2 = strf "the hash for such a %s operation." adjective in
    let wl = String.length prompt + String.length warning1 in
    tag "shout" ppf (fun ppf -> string ppf ("/" ^ String.make wl '=' ^ "\\")) ;
    cut ppf () ;
    tag "shout" ppf (fun ppf -> pf ppf "|%s" prompt) ;
    string ppf warning1 ;
    tag "shout" ppf (fun ppf -> string ppf "|") ;
    cut ppf () ;
    tag "shout" ppf (fun ppf -> pf ppf "|") ;
    string ppf String.(make (length prompt) ' ') ;
    string ppf warning2 ;
    string ppf String.(make (length warning1 - length warning2) ' ') ;
    tag "shout" ppf (fun ppf -> string ppf "|") ;
    cut ppf () ;
    tag "shout" ppf (fun ppf -> string ppf ("\\" ^ String.make wl '=' ^ "/"))

let basic_contract_operations_tests state ~client ~src ~with_rejections
    ~protocol_kind ~ledger_account ~bake ~delegate () =
  let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
  let only_success = not with_rejections in
  let test_origination ?delegate ?delegatable ?spendable ?push_drops ~name
      ~amount ~parameter ~init_storage () =
    prepare_origination_of_id_script
      ~amount
      ?push_drops
      state
      ~client
      ~name
      ~from:src
      ?delegate
      ?delegatable
      ?spendable
      ~protocol_kind
      ~parameter
      ~init_storage
    >>= fun origination ->
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf ppf "Origination: %s (ledger: %s)" name ledger_pkh);
            show_command_message origination;
            please_check_the_hash;
            ( if push_drops <> None then
              pp_warning_ledger_takes_a_while ~adjective:"huge"
            else const string "" ) ]
      (fun ~user_answer ->
        client_async_cmd
          state
          ~client
          ~f:(fun _ proc ->
            find_and_print_signature_hash ~display_expectation:true state proc)
          origination
        >>= fun res ->
        expect_from_output
          ~message:name
          res
          ~expectation:
            ( match user_answer with
            | `Reject ->
                `Ledger_reject_or_timeout
            | `Accept ->
                `Success ))
    >>= fun _ -> ksprintf bake "%s with %s" name src
  in
  test_origination
    ~name:"ID-unit"
    ~amount:"0"
    ~parameter:"unit"
    ~init_storage:"Unit"
    ()
  >>= fun () ->
  test_origination
    ~name:"ID-string"
    ~amount:"10"
    ~parameter:"string"
    ~init_storage:"\"some string\""
    ()
  >>= fun () ->
  test_origination
    ~name:"ID-string-nat-mutez"
    ~amount:"10"
    ~parameter:"(pair string (pair nat mutez))"
    ~init_storage:"Pair \"hello\" (Pair 12 1)"
    ()
  >>= fun () ->
  test_origination
    ~name:"ID-address+delegate"
    ~amount:"1"
    ~parameter:"address"
    ~delegate
    ~init_storage:"\"tz1YPSCGWXwBdTncK2aCctSZAXWvGsGwVJqU\""
    ()
  >>= fun () ->
  ( match protocol_kind with
  | `Athens ->
      test_origination
        ~name:"ID-string+delegatable"
        ~amount:"0"
        ~parameter:"string"
        ~delegate
        ~init_storage:"\"delegatable contract\""
        ~delegatable:true
        ()
  | `Babylon ->
      return () )
  >>= fun () ->
  let push_drops =
    (* Found by dichotomic trial-and-error :)
       240 works, 250 fails at 16870 bytes, … *)
    242
  in
  test_origination
    ~push_drops
    ~name:"giant-contract"
    ~amount:"10"
    ~parameter:"(pair string nat)"
    ~init_storage:"Pair \"the answer is: \" 42"
    ()

module Wallet_scenario = struct
  type root =
    [ `All
    | `Voting
    | `Batch_transactions
    | `Delegation
    | `Transactions
    | `Contracts
    | `None ]

  type t = [root | `Without_rejections of root]

  let with_rejections : t -> bool = function
    | `Without_rejections _ ->
        false
    | _ ->
        true

  let enum_assoc : (string * root) list =
    [ ("everything", `All);
      ("voting", `Voting);
      ("none", `None);
      ("delegation", `Delegation);
      ("transactions", `Transactions);
      ("contracts", `Contracts);
      ("batch-transactions", `Batch_transactions) ]

  let root (ws : t) =
    match ws with `Without_rejections r -> r | #root as r -> r

  let run_if v t ~yes ~no =
    let with_rejections = with_rejections t in
    match root t with
    | `All ->
        yes ~with_rejections
    | other when other = v ->
        yes ~with_rejections
    | _other ->
        no
          (List.find_map_exn enum_assoc ~f:(function
              | (k, this) when v = this ->
                  Some k
              | _ ->
                  None))

  let if_voting t = run_if `Voting t

  let if_batch_transactions t = run_if `Batch_transactions t

  let if_delegation t = run_if `Delegation t

  let if_transactions t = run_if `Transactions t

  let if_contracts t = run_if `Contracts t

  let cli_term () =
    let make no_rejections v =
      if no_rejections then `Without_rejections v else (v :> t)
    in
    let open Cmdliner in
    let open Term in
    pure make
    $ Arg.(
        value
          (flag (info ["no-rejections"] ~doc:"Do not test ledger rejections.")))
    $ Arg.(
        value
          (opt
             (enum ([("all", `All)] @ enum_assoc))
             `All
             (info
                ["only-test"]
                ~doc:
                  (Fmt.strf
                     "Limit to a family of tests (one of: %s)."
                     ( List.map enum_assoc ~f:(fun (n, _) -> sprintf "`%s`" n)
                     |> String.concat ~sep:", " )))))
end

let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec
    ~admin_exec ~wallet_scenario ~size ~base_port ~uri () =
  Helpers.clear_root state
  >>= fun () ->
  Helpers.System_dependencies.precheck
    state
    `Or_fail
    ~executables:[node_exec; client_exec; admin_exec]
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ready to start"; af "Root path deleted."]
  >>= fun () ->
  let ledger_client = Tezos_client.no_node_client ~exec:client_exec in
  Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri
  >>= fun _ledger_account ->
  let (protocol, baker_0_account, _baker_0_balance) =
    let open Tezos_protocol in
    let d = protocol in
    let baker = List.nth_exn d.bootstrap_accounts 0 in
    ( {
        d with
        kind = protocol_kind;
        time_between_blocks = [1; 0];
        bootstrap_accounts =
          List.map d.bootstrap_accounts ~f:(fun (n, v) ->
              if fst baker = n then (n, v) else (n, 1_000L));
      },
      fst baker,
      snd baker )
  in
  Test_scenario.network_with_protocol
    ~protocol
    ~size
    ~base_port
    state
    ~node_exec
    ~client_exec
  >>= fun (nodes, protocol) ->
  let client n =
    Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
  in
  let client_0 = client 0 in
  let baker_0 =
    Tezos_client.Keyed.make
      client_0
      ~key_name:"baker-0"
      ~secret_key:(Tezos_protocol.Account.private_key baker_0_account)
  in
  Tezos_client.Keyed.initialize state baker_0
  >>= fun _ ->
  let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~make_admin
          ~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
  let first_bakes = 3 in
  Loop.n_times first_bakes (fun nth ->
      ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth)
  >>= fun () ->
  Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
  >>= fun () ->
  let signer =
    Tezos_client.Keyed.make (client 0) ~key_name:"ledgered" ~secret_key:uri
  in
  Tezos_client.Ledger.show_ledger state ~client:client_0 ~uri
  >>= fun ledger_account ->
  Tezos_client.successful_client_cmd
    state
    ~client:client_0
    [ "--wait";
      "none";
      "transfer";
      "20000";
      "from";
      baker_0.Tezos_client.Keyed.key_name;
      "to" (*  *);
      Tezos_protocol.Account.pubkey_hash ledger_account;
      "--burn-cap";
      "100" ]
  >>= fun _ ->
  let bake msg = Tezos_client.Keyed.bake state baker_0 msg in
  bake "After transferring tez to the ledger account"
  >>= fun () ->
  with_ledger_test_reject_and_accept
    ~only_success:(Wallet_scenario.with_rejections wallet_scenario |> not)
    state
    ~messages:
      MFmt.
        [ (fun ppf () ->
            wf ppf "Importing %S in client `%s`." uri client_0.Tezos_client.id);
          (fun ppf () ->
            wf
              ppf
              "The ledger should be prompting for acknowledgment to provide \
               the public key of `%s`."
              (Tezos_protocol.Account.pubkey_hash ledger_account)) ]
    (fun ~user_answer ->
      Tezos_client.client_cmd
        state
        ~client:client_0
        [ "import";
          "secret";
          "key";
          signer.key_name;
          signer.secret_key;
          "--force" ]
      >>= fun (_, proc) ->
      expect_from_output
        ~message:"importing key"
        proc
        ~expectation:
          ( match user_answer with
          | `Accept ->
              `Success
          | `Reject ->
              `Ledger_reject_or_timeout ))
  >>= fun () ->
  let skipping s = Console.say state EF.(haf "Skipping %s tests" s) in
  let voting_test ~with_rejections =
    let tested_proposal =
      "Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd"
    in
    voting_tests
      state
      ~client
      ~ledger_account
      ~src:signer.key_name
      ()
      ~with_rejections
      ~protocol_kind
      ~tested_proposal
      ~go_to_next_period:(fun () ->
        Tezos_client.successful_client_cmd
          state
          ~client:client_0
          [ "--wait";
            "none";
            "submit";
            "proposals";
            "for";
            baker_0.Tezos_client.Keyed.key_name;
            tested_proposal;
            "--force" ]
        >>= fun _ ->
        let blocks = protocol.Tezos_protocol.blocks_per_voting_period in
        Loop.n_times blocks (fun nth ->
            ksprintf
              (Tezos_client.Keyed.bake state baker_0)
              "going to testing-vote period %d/%d"
              (nth + 1)
              blocks)
        >>= fun () -> return ())
  in
  let batch_test ~with_rejections =
    let n = 50 in
    forge_batch_transactions
      state
      ~client:(client 0)
      ~src:(Tezos_protocol.Account.pubkey_hash ledger_account)
      ~dest:"tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F"
      ~n
      ()
    >>= fun batch_transaction_bytes ->
    let bytes_hash =
      Tezos_crypto.(
        `Hex batch_transaction_bytes |> Hex.to_bytes
        |> (fun x -> [x])
        |> Blake2B.hash_bytes |> Blake2B.to_string |> Base58.raw_encode)
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success:(not with_rejections)
      ~messages:
        MFmt.
          [ (fun ppf () -> wf ppf "Signing batch of %d transactions" n);
            (fun ppf () ->
              wf
                ppf
                "Ledger should display “Sign Hash” → `%s`"
                bytes_hash);
            pp_warning_ledger_takes_a_while ~adjective:"big" ]
      (fun ~user_answer ->
        sign state ~client:signer ~bytes:batch_transaction_bytes
        >>= fun (_, proc) ->
        expect_from_output
          ~message:"Signing batch operation"
          proc
          ~expectation:
            ( match user_answer with
            | `Accept ->
                `Success
            | `Reject ->
                `Ledger_reject_or_timeout ))
  in
  let delegation_tests ~with_rejections =
    delegation_tests
      state
      ~client:client_0
      ~ledger_account
      ~delegate:baker_0.Tezos_client.Keyed.key_name
      ~src:signer.key_name
      ()
      ~bake
      ~with_rejections
      ~protocol_kind
  in
  let unit_kt1_account = "unit-kt1-of-the-baker" in
  originate_id_script
    state
    ~client:client_0
    ~name:unit_kt1_account
    ~from:baker_0.Tezos_client.Keyed.key_name
    ~bake
    ~protocol_kind
    ~parameter:"unit"
    ~init_storage:"Unit"
  >>= fun () ->
  let pair_string_nat_kt1_account = "pair-string-nat-kt1-of-the-baker" in
  originate_id_script
    state
    ~client:client_0
    ~name:pair_string_nat_kt1_account
    ~push_drops:10
    ~from:baker_0.Tezos_client.Keyed.key_name
    ~bake
    ~protocol_kind
    ~parameter:"(pair string nat)"
    ~init_storage:"Pair \"the answer is: \" 42"
  >>= fun () ->
  let transactions_test ~with_rejections =
    transaction_tests
      state
      ~client:client_0
      ~ledger_account
      ~unit_kt1_account
      ~pair_string_nat_kt1_account
      ~src:signer.key_name
      ()
      ~bake
      ~with_rejections
      ~protocol_kind
  in
  let contracts_test ~with_rejections =
    basic_contract_operations_tests
      state
      ~client:client_0
      ~ledger_account
      ~delegate:baker_0.Tezos_client.Keyed.key_name
      ~src:signer.key_name
      ()
      ~bake
      ~with_rejections
      ~protocol_kind
  in
  let bake_command =
    Console.Prompt.unit_and_loop
      EF.(wf "Bake a block with the default baker.")
      ["bake"]
      (fun _sexps ->
        Asynchronous_result.transform_error
          ~f:(fun e ->
            Format.kasprintf
              (fun s -> `Command_line s)
              "run-test-error: %a"
              pp_error
              e)
          (bake "Interactive"))
  in
  let run_test_command =
    Console.Prompt.unit_and_loop
      EF.(
        wf
          "Run a test (%s)."
          (List.map Wallet_scenario.enum_assoc ~f:fst |> String.concat ~sep:"|"))
      ["rt"; "run-test"]
      (fun sexps ->
        Asynchronous_result.transform_error
          ~f:(fun e ->
            Format.kasprintf
              (fun s -> `Command_line s)
              "run-test-error: %a"
              pp_error
              e)
          ( match sexps with
          | [Atom a] -> (
              let run f = f ~with_rejections:true in
              match
                List.Assoc.find
                  ~equal:String.equal
                  Wallet_scenario.enum_assoc
                  a
              with
              | Some `None ->
                  return ()
              | Some `Delegation ->
                  run delegation_tests
              | Some `All ->
                  run delegation_tests
                  >>= fun () -> run batch_test >>= fun () -> run voting_test
              | Some `Batch_transactions ->
                  run batch_test
              | Some `Transactions ->
                  run transactions_test
              | Some `Voting ->
                  run voting_test
              | Some `Contracts ->
                  run contracts_test
              | None ->
                  failf "Don't know this test: %S" a )
          | _ ->
              failf "Cannot understand command line" ))
  in
  Interactive_test.Pauser.add_commands state [run_test_command; bake_command] ;
  Wallet_scenario.if_voting wallet_scenario ~yes:voting_test ~no:skipping
  >>= fun () ->
  Wallet_scenario.if_batch_transactions
    wallet_scenario
    ~yes:batch_test
    ~no:skipping
  >>= fun () ->
  Wallet_scenario.if_transactions
    wallet_scenario
    ~yes:transactions_test
    ~no:skipping
  >>= fun () ->
  Wallet_scenario.if_contracts wallet_scenario ~yes:contracts_test ~no:skipping
  >>= fun () ->
  Wallet_scenario.if_delegation
    wallet_scenario
    ~yes:delegation_tests
    ~no:skipping
  >>= fun () -> Interactive_test.Pauser.generic state EF.[af "Tests done."]

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun uri
             node_exec
             client_exec
             admin_exec
             size
             (`Base_port base_port)
             protocol
             wallet_scenario
             state
             ->
          ( state,
            Interactive_test.Pauser.run_test
              ~pp_error
              state
              (run
                 state
                 ~protocol_kind:protocol.kind
                 ~node_exec
                 ~size
                 ~admin_exec
                 ~base_port
                 ~pp_error
                 ~wallet_scenario
                 ~protocol
                 ~client_exec
                 ~uri) ))
    $ Arg.(
        required
          (pos
             0
             (some string)
             None
             (info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI")))
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Tezos_executable.cli_term `Admin "tezos"
    $ Arg.(value (opt int 2 (info ["size"; "S"] ~doc:"Size of the Network")))
    $ Arg.(
        pure (fun p -> `Base_port p)
        $ value
            (opt
               int
               32_000
               (info ["base-port"; "P"] ~doc:"Base port number to build upon")))
    $ Tezos_protocol.cli_term ()
    $ Wallet_scenario.cli_term ()
    $ Test_command_line.cli_state ~name:"ledger-wallet" () )
    (let doc = "Interactive test exercising the Ledger Wallet app features" in
     info ~doc "ledger-wallet")
src/bin_sandbox/command_ledger_wallet.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition client_async_cmd {A B C D E F : Type}
  (state : A) (client : B) (args : list string) (f : C -> D -> E) : F :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "client_async_cmd" % string state f
      "sh -c %s" % string
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (op_star_t_y_p_e_minus_e_r_r_o_r_star client state args)
          op_star_t_y_p_e_minus_e_r_r_o_r_star) Stdlib.Filename.quote))
    (fun function_parameter =>
      match function_parameter with
      | (status, res) =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star
      end).

Definition ledger_hash_re {A : Type} : lazy_t A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition find_and_print_signature_hash {A B C : Type}
  (op_star_o_p_t_star : option bool) : A -> B -> C :=
  let display_expectation :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun state =>
    fun process =>
      let re := Stdlib.Lazy.force ledger_hash_re in
      let check {D E : Type} (lines : D) : E :=
        op_star_t_y_p_e_minus_e_r_r_o_r_star in
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star process
          ("" % string, "" % string, (negb display_expectation))
          (fun function_parameter =>
            match function_parameter with
            | (all_output_prev, all_error_prev, showed_message_prev) =>
              fun out =>
                fun err =>
                  let all_output := String.append all_output_prev out in
                  let all_error := String.append all_error_prev err in
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (if negb showed_message_prev then
                      match check all_output with
                      | None => op_star_t_y_p_e_minus_e_r_r_o_r_star false
                      | Some x =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star true
                            end)
                      end
                    else
                      op_star_t_y_p_e_minus_e_r_r_o_r_star true)
                    (fun showed_message =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star variant)
            end))
        (fun function_parameter =>
          match function_parameter with
          | (output, error, _) =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              ((op_star_t_y_p_e_minus_e_r_r_o_r_star "010" % char output),
                (op_star_t_y_p_e_minus_e_r_r_o_r_star "010" % char error))
          end).

Module MFmt.

End MFmt.

Definition failf {A B C : Type} (attach : option A) (fmt : B) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (fun s => op_star_t_y_p_e_minus_e_r_r_o_r_star attach variant) fmt.

Definition process_should_fail {A B C : Type} (msg : A) (f : unit -> B) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star (f tt)
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          match send with
          | Unix.WEXITED 0 =>
            failf
              (Some
                (cons ("stdout" % string, variant)
                  (cons ("stderr" % string, variant) [])))
              "Process should have failed: %s" % string msg
          | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star tt
          end
        end))
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star tt
          end
      end).

Definition ledger_prompt_notice {A B C : Type}
  (state : A) (msgs : B -> unit) (op_star_o_p_t_star : option variant)
  : unit -> C :=
  let button :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      let button_str :=
        match button with
        | Checkmark => "✔" % string
        | X => "❌" % string
        | Both => "❌ and ✔ at the same time" % string
        end in
      op_star_t_y_p_e_minus_e_r_r_o_r_star state
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star 4 ppf
                (fun ppf =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                    (fun ppf =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "Ledger-prompt:" % string ppf tt);
                  op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
                  Stdlib.List.iter msgs expected_argument
                    (fun f =>
                      f ppf tt;
                      op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt);
                  op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                    "→ Press %s on the ledger." % string button_str)
            end)
    end.

Definition ledger_prompt_notice_expectation {A B C : Type}
  (state : A) (messages : list (B -> unit -> unit)) (user_answer : variant)
  : C := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition with_ledger_test_reject_and_accept {A B C D : Type}
  (op_star_o_p_t_star : option bool)
  : A -> (list (B -> unit -> unit)) -> (variant -> C) -> D :=
  let only_success :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun state =>
    fun messages =>
      fun f =>
        let with_ledger_prompt {E F : Type}
          (state : A) (messages : list (B -> unit -> unit)) (user_answer :
          variant) (f : variant -> E) : F :=
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (ledger_prompt_notice_expectation state messages user_answer)
            (fun function_parameter =>
              match function_parameter with
              | tt => f user_answer
              end) in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (if only_success then
            op_star_t_y_p_e_minus_e_r_r_o_r_star tt
          else
            with_ledger_prompt state messages variant f)
          (fun function_parameter =>
            match function_parameter with
            | tt => with_ledger_prompt state messages variant f
            end).

Definition get_chain_id {A B C : Type} (state : A) (client : B) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state client variant
        "/chains/main/chain_id" % string)
      (fun function_parameter =>
        match function_parameter with
        | String x => op_star_t_y_p_e_minus_e_r_r_o_r_star x
        | _ => failf None "Failed to parse chain_id JSON from node" % string
        end))
    (fun chain_id_string =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star chain_id_string)).

Definition get_head_block_hash {A B C : Type}
  (state : A) (client : B) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state client variant
        "/chains/main/blocks/head/hash" % string)
      (fun function_parameter =>
        match function_parameter with
        | String x => op_star_t_y_p_e_minus_e_r_r_o_r_star x
        | _ => failf None "Failed to parse block hash JSON from node" % string
        end)
  end.

Definition please_check_the_hash {A B : Type}
  (ppf : A) (function_parameter : unit) : B :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star "prompt" % string ppf
      (fun ppf =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
          "The ledger cannot parse this operation, please verify the hash." %
            string)
  end.

Definition forge_batch_transactions {A B C D E : Type}
  (state : A) (client : B) (src : string) (function_parameter : C)
  : D -> (option float) -> unit -> E :=
  match function_parameter with
  | _ =>
    fun n =>
      fun op_star_o_p_t_star =>
        let fee :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => 0
          end in
        fun function_parameter =>
          match function_parameter with
          | tt =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (get_head_block_hash state client tt)
              (fun branch =>
                let json := variant in
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
                    "/chains/main/blocks/head/helpers/forge/operations" % string
                    variant)
                  (fun function_parameter =>
                    match function_parameter with
                    | String operation_bytes =>
                      let magic_byte := "03" % string in
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (String.append magic_byte operation_bytes)
                    | _ =>
                      failf None
                        "Failed to forge operation or parse result" % string
                    end))
          end
  end.

Definition expect_from_output {A B : Type}
  (expectation : variant) (message : string) (function_parameter : A) : B :=
  match function_parameter with
  | _ =>
    let exp :=
      match expectation with
      | Ledger_reject_or_timeout => "rejection" % string
      | Not_a_delegate => "not-delegate-error" % string
      | Success => "success" % string
      | Origination_failed => "origination-failure" % string
      end in
    let nope {C D : Type} (s : C) : D :=
      failf
        (Some
          (cons ("stdout" % string, variant)
            (cons ("stderr" % string, variant) [])))
        "%s, expected %s: %s." % string message exp s in
    let success := equiv_decb send (Unix.WEXITED 0) in
    match expectation with
    | Success => nope "did not succeed" % string
    | (Ledger_reject_or_timeout | Not_a_delegate | Origination_failed) as e =>
      let pattern :=
        match e with
        | Ledger_reject_or_timeout => "Conditions of use not satisfied" % string
        | Not_a_delegate => "not registered as valid delegate key" % string
        | Origination_failed => "origination simulation failed" % string
        end in
      let all_output :=
        Stdlib.String.concat op_star_t_y_p_e_minus_e_r_r_o_r_star
          expected_argument "
" % string in
      match (success, (op_star_t_y_p_e_minus_e_r_r_o_r_star all_output pattern))
        with
      | (false, Some _) => op_star_t_y_p_e_minus_e_r_r_o_r_star tt
      | (false, None) => nope "cannot find the right error message" % string
      | (true, _) => nope "command succeeded??" % string
      end
    end
  end.

Definition voting_tests {A B C D E : Type}
  (state : A) (client : Z -> B) (src : string) (with_rejections : bool)
  (protocol_kind : variant) (ledger_account : C) (tested_proposal : string)
  (go_to_next_period : unit -> D) (function_parameter : unit) : E :=
  match function_parameter with
  | tt =>
    let expect_success {F G : Type} (message : string) (v : F) : G :=
      expect_from_output variant message v in
    let expect_rejection {F G : Type} (message : string) (v : F) : G :=
      expect_from_output variant message v in
    let test_reject_and_accept {F G H : Type}
      (name : string) (messages : list (F -> unit -> unit)) (action : unit -> G)
      : H :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (if with_rejections then
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (ledger_prompt_notice_expectation state messages variant)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star (action tt)
                  (fun res => expect_rejection name res)
              end)
        else
          op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (ledger_prompt_notice_expectation state messages variant)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star (action tt)
                    (fun res => expect_success name res)
                end)
          end) in
    let source_display := op_star_t_y_p_e_minus_e_r_r_o_r_star ledger_account in
    let submit_proposals {F : Type}
      (display_expectation : bool) (proposals : list string) (function_parameter
      : unit) : F :=
      match function_parameter with
      | tt =>
        client_async_cmd state (client 0)
          (OCaml.Stdlib.app
            (cons "submit" % string
              (cons "proposals" % string (cons "for" % string (cons src []))))
            (OCaml.Stdlib.app proposals
              (cons "--force" % string (cons "--verbose-signing" % string []))))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              fun proc =>
                find_and_print_signature_hash (Some display_expectation) state
                  proc
            end)
      end in
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (test_reject_and_accept "single-proposal" % string
        (cons
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                  "Submitting single proposal %s" % string tested_proposal
              end)
          (cons
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  match protocol_kind with
                  | Athens => tt
                  | Babylon =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                      "On Babylon, You will first be asked to provide the public key."
                        % string;
                    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
                    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                      "Accept this prompt, regardless of below, then continue."
                        % string
                  end
                end)
            (cons
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf 4
                      (fun ppf =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                          "Protocol is %a, the ledger should be able to display voting parameters:"
                            % string op_star_t_y_p_e_minus_e_r_r_o_r_star
                          protocol_kind;
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                          "* Source: `%s`" % string source_display;
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                          "* Period: `0`" % string;
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                          "* Protocol: `%s`" % string tested_proposal)
                  end) []))) (submit_proposals false (cons tested_proposal [])))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (test_reject_and_accept "multiple-proposal" % string
              (cons
                (fun ppf =>
                  fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                        "Submitting 2 proposals together" % string
                    end) (cons please_check_the_hash []))
              (submit_proposals true
                (cons tested_proposal
                  (cons
                    "Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z" %
                      string []))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star (go_to_next_period tt)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (cons "yea" % string (cons "nay" % string []))
                        (fun n =>
                          fun vote =>
                            test_reject_and_accept
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                "vote-%s" % string vote)
                              (cons
                                (fun ppf =>
                                  fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      match protocol_kind with
                                      | Athens => tt
                                      | Babylon =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                                          "On Babylon, You will first be asked to provide the public key."
                                            % string;
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                                          tt;
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                                          "Accept this prompt, regardless of below, then continue."
                                            % string
                                      end
                                    end)
                                (cons
                                  (fun ppf =>
                                    fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                                          "Voting %s for %s" % string vote
                                          tested_proposal
                                      end)
                                  (cons
                                    (fun ppf =>
                                      fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            ppf "Source: `%s`" % string
                                            source_display
                                        end)
                                    (cons
                                      (fun ppf =>
                                        fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              ppf "Period: `%i`" % string
                                              (Z.add n 1)
                                          end)
                                      (cons
                                        (fun ppf =>
                                          fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                ppf "Protocol: `%s`" % string
                                                tested_proposal
                                            end) [])))))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                      (client 0)
                                      (cons "submit" % string
                                        (cons "ballot" % string
                                          (cons "for" % string
                                            (cons src
                                              (cons tested_proposal
                                                (cons vote [])))))))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (_, proc) =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          proc
                                      end)
                                end))
                    end)
              end)
        end)
  end.

Definition ledger_should_display {A B C : Type} (ppf : A) (l : B -> unit) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star 4 ppf
    (fun ppf =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star ppf "Ledger should display:" % string;
      Stdlib.List.iter l expected_argument
        (fun function_parameter =>
          match function_parameter with
          | (s, f) =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
            op_star_t_y_p_e_minus_e_r_r_o_r_star ppf "* %s: %a." % string s f tt
          end)).

Definition show_command_message {A : Type}
  (command : list string) (ppf : A) (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star 2 ppf
      (fun ppf =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf "Command:" % string;
        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star)
          op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt)
  end.

Definition sign {A B C : Type} (state : A) (client : B) (bytes : string) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star state (Tezos_client.Keyed.client client)
    (cons "sign" % string
      (cons "bytes" % string
        (cons (String.append "0x" % string string)
          (cons "for" % string (cons (Tezos_client.Keyed.key_name client) []))))).

Definition delegation_tests {A B C D E : Type}
  (state : A) (client : B) (src : string) (with_rejections : bool)
  (protocol_kind : variant) (ledger_account : C) (delegate : string) (bake : D)
  (function_parameter : unit) : E :=
  match function_parameter with
  | tt =>
    let ledger_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star ledger_account in
    let only_success := negb with_rejections in
    let self_delegation {F : Type} (function_parameter : unit) : F :=
      match function_parameter with
      | tt =>
        let command :=
          cons "--wait" % string
            (cons "none" % string
              (cons "set" % string
                (cons "delegate" % string
                  (cons "for" % string
                    (cons src
                      (cons "to" % string
                        (cons src (cons "--verbose-signing" % string []))))))))
          in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (with_ledger_test_reject_and_accept (Some only_success) state
            (cons
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                      "Self-delegating account `%s`" % string ledger_pkh
                  end)
              (cons (show_command_message command)
                (cons
                  (fun ppf =>
                    fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                          "Note that X is a placeholder for some value that will vary between runs"
                            % string
                      end)
                  (cons
                    (fun ppf =>
                      fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          ledger_should_display ppf
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                        end) []))))
            (fun user_answer =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (client_async_cmd state client command
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      fun proc =>
                        find_and_print_signature_hash
                          (Some (equiv_decb protocol_kind variant)) state proc
                    end))
                (fun res =>
                  expect_from_output
                    match user_answer with
                    | Reject => variant
                    | Accept => variant
                    end "self-delegation" % string res)))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star bake
                "setting self-delegate of %s" % string src
            end)
      end in
    let tz_account_delegation {F : Type} (function_parameter : unit) : F :=
      match function_parameter with
      | tt =>
        let command :=
          cons "--wait" % string
            (cons "none" % string
              (cons "set" % string
                (cons "delegate" % string
                  (cons "for" % string
                    (cons src
                      (cons "to" % string
                        (cons delegate (cons "--verbose-signing" % string []))))))))
          in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (with_ledger_test_reject_and_accept (Some only_success) state
            (cons
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                      "Delegating account `%s` to `%s`" % string ledger_pkh
                      delegate
                  end)
              (cons (show_command_message command)
                (cons
                  (fun ppf =>
                    fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                          "Note that X is a placeholder for some value that will vary between runs"
                            % string
                      end)
                  (cons
                    (fun ppf =>
                      fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          ledger_should_display ppf
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                        end) []))))
            (fun user_answer =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (client_async_cmd state client command
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      fun proc =>
                        find_and_print_signature_hash
                          (Some (equiv_decb protocol_kind variant)) state proc
                    end))
                (fun res =>
                  expect_from_output
                    match user_answer with
                    | Reject => variant
                    | Accept => variant
                    end "tz123-delegation" % string res)))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star bake
                "setting delegate of %s" % string src
            end)
      end in
    let run_command_and_check {F G H I : Type}
      (state : F) (client : G) (command : H) (message : string) (user_answer :
      variant) : I :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star state client command)
        (fun function_parameter =>
          match function_parameter with
          | (_, res) =>
            expect_from_output
              match user_answer with
              | Reject => variant
              | Accept => variant
              end message res
          end) in
    let delegate_with_scriptless_account {F : Type} (function_parameter : unit)
      : F :=
      match function_parameter with
      | tt =>
        let originated_account_name := "ledginated" % string in
        let amount := "200" % string in
        let burn_cap := "0.257" % string in
        let command :=
          cons "--wait" % string
            (cons "none" % string
              (cons "originate" % string
                (cons "account" % string
                  (cons originated_account_name
                    (cons "for" % string
                      (cons src
                        (cons "transferring" % string
                          (cons "200" % string
                            (cons "from" % string
                              (cons src
                                (cons "--delegatable" % string
                                  (cons "--burn-cap" % string
                                    (cons burn_cap (cons "--force" % string []))))))))))))))
          in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (with_ledger_test_reject_and_accept (Some only_success) state
            (cons
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                      "Originating account `%s`" % string
                      originated_account_name
                  end)
              (cons
                (fun ppf =>
                  fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      ledger_should_display ppf
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                    end) []))
            (fun user_answer =>
              run_command_and_check state client command
                "account origination" % string user_answer))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star bake
                  "origination of %s" % string originated_account_name)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
                        (cons "show" % string
                          (cons "known" % string
                            (cons "contract" % string
                              (cons originated_account_name [])))))
                      (fun function_parameter =>
                        match function_parameter with
                        | (_, proc_result) =>
                          let contract_address :=
                            OCaml.Stdlib.reverse_apply send
                              (Stdlib.String.concat expected_argument
                                expected_argument "" % string) in
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
                              (cons "show" % string
                                (cons "address" % string (cons delegate []))))
                            (fun function_parameter =>
                              match function_parameter with
                              | (_, proc_result) =>
                                let delegate_address :=
                                  OCaml.Stdlib.reverse_apply
                                    (OCaml.Stdlib.reverse_apply
                                      (OCaml.Stdlib.reverse_apply
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          send)
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          " " % char))
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      delegate) in
                                let command :=
                                  cons "--wait" % string
                                    (cons "none" % string
                                      (cons "set" % string
                                        (cons "delegate" % string
                                          (cons "for" % string
                                            (cons originated_account_name
                                              (cons "to" % string
                                                (cons delegate []))))))) in
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (with_ledger_test_reject_and_accept
                                    (Some only_success) state
                                    (cons
                                      (fun ppf =>
                                        fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              ppf
                                              "Setting `%s` as delegate for `%s`"
                                                % string delegate
                                              originated_account_name
                                          end)
                                      (cons
                                        (fun ppf =>
                                          fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              ledger_should_display ppf
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            end) []))
                                    (fun user_answer =>
                                      run_command_and_check state client command
                                        "setting delegate of KT1" % string
                                        user_answer))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          bake "setting delegate of %s" % string
                                          originated_account_name)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            let withdraw_command :=
                                              cons "--wait" % string
                                                (cons "none" % string
                                                  (cons "withdraw" % string
                                                    (cons "delegate" % string
                                                      (cons "from" % string
                                                        (cons
                                                          originated_account_name
                                                          []))))) in
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (with_ledger_test_reject_and_accept
                                                (Some only_success) state
                                                (cons
                                                  (fun ppf =>
                                                    fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          ppf
                                                          "Withdrawing delegate from `%s`"
                                                            % string
                                                          originated_account_name
                                                      end)
                                                  (cons
                                                    (show_command_message
                                                      withdraw_command)
                                                    (cons
                                                      (fun ppf =>
                                                        fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            ledger_should_display
                                                              ppf
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          end) [])))
                                                (fun user_answer =>
                                                  run_command_and_check state
                                                    client withdraw_command
                                                    "withdrawing delegate from originated account"
                                                      % string user_answer))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    bake
                                                    "withdrawing delegate of %s"
                                                      % string
                                                    originated_account_name
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end in
    match protocol_kind with
    | Athens =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star (self_delegation tt)
        (fun function_parameter =>
          match function_parameter with
          | tt => delegate_with_scriptless_account tt
          end)
    | Babylon =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star (tz_account_delegation tt)
        (fun function_parameter =>
          match function_parameter with
          | tt => self_delegation tt
          end)
    end
  end.

Definition transaction_tests {A B C D E : Type}
  (state : A) (client : B) (src : string) (with_rejections : bool)
  (protocol_kind : variant) (pair_string_nat_kt1_account : string)
  (ledger_account : C) (unit_kt1_account : string) (bake : D)
  (function_parameter : unit) : E :=
  match function_parameter with
  | tt =>
    let ledger_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star ledger_account in
    let only_success := negb with_rejections in
    let test_transaction {F G H : Type} (op_star_o_p_t_star : option Z)
      : (option F) -> string -> string -> G -> unit -> H :=
      let storage :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => 0
        end in
      fun arguments =>
        fun name =>
          fun dst_name =>
            fun dst_pkh =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  let amount := "15" % string in
                  let command :=
                    OCaml.Stdlib.app
                      (cons "--wait" % string
                        (cons "none" % string
                          (cons "transfer" % string
                            (cons amount
                              (cons "from" % string
                                (cons src
                                  (cons "to" % string (cons dst_name []))))))))
                      (OCaml.Stdlib.app
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star [] arguments
                          (fun a => cons "--arg" % string (cons a [])))
                        (cons "--burn-cap" % string
                          (cons "100" % string
                            (cons "--verbose-signing" % string [])))) in
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (with_ledger_test_reject_and_accept (Some only_success)
                      state
                      (cons
                        (fun ppf =>
                          fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                                "%s with account `%s`" % string name ledger_pkh
                            end)
                        (cons (show_command_message command)
                          (cons
                            (fun ppf =>
                              fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                                    "Note that X is a placeholder for some value that will vary between runs"
                                      % string
                                end)
                            (cons
                              (fun ppf =>
                                fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    match arguments with
                                    | None =>
                                      ledger_should_display ppf
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    | _ => please_check_the_hash ppf tt
                                    end
                                  end) []))))
                      (fun user_answer =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (client_async_cmd state client command
                            (fun function_parameter =>
                              match function_parameter with
                              | _ =>
                                fun proc =>
                                  find_and_print_signature_hash
                                    (Some
                                      (orb (equiv_decb protocol_kind variant)
                                        (nequiv_decb arguments None))) state
                                    proc
                              end))
                          (fun res =>
                            expect_from_output
                              match user_answer with
                              | Reject => variant
                              | Accept => variant
                              end name res)))
                    (fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star bake
                          "%s with %s" % string name src
                      end)
                end in
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (test_transaction None None "Self-transaction" % string src ledger_pkh tt)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let Acc :=
            existT _ _
              {|
                
                |} in
          let random_account :=
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              "random-account-for-transaction-test" % string in
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (test_transaction (Some 277) None
              "transaction-to-random-tz1" % string
              (op_star_t_y_p_e_minus_e_r_r_o_r_star random_account)
              (op_star_t_y_p_e_minus_e_r_r_o_r_star random_account) tt)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (test_transaction (Some 0) None
                    "transaction-to-random-tz1-again" % string
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star random_account)
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star random_account) tt)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (test_transaction None None
                          "parameterless-transaction-to-kt1" % string
                          unit_kt1_account
                          "KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" % string tt)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            test_transaction None
                              (Some "Pair ""hello from the ledger"" 51" % string)
                              "parameterfull-transaction-to-kt1" % string
                              pair_string_nat_kt1_account
                              "KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" % string tt
                          end)
                    end)
              end)
        end)
  end.

Definition prepare_origination_of_id_script {A B C D : Type}
  (op_star_o_p_t_star : option bool)
  : (option bool) ->
    (option A) ->
      (option Z) ->
        (option string) ->
          B -> C -> string -> string -> variant -> string -> string -> D :=
  let spendable :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun op_star_o_p_t_star =>
    let delegatable :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun delegate =>
      fun op_star_o_p_t_star =>
        let push_drops :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => 0
          end in
        fun op_star_o_p_t_star =>
          let amount :=
            match op_star_o_p_t_star with
            | Some op_star_s_t_h_star => op_star_s_t_h_star
            | None => "2" % string
            end in
          fun state =>
            fun function_parameter =>
              match function_parameter with
              | _ =>
                fun name =>
                  fun from =>
                    fun protocol_kind =>
                      fun parameter =>
                        fun init_storage =>
                          let id_script {E : Type} (parameter : string) : E :=
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              "parameter %s;
storage %s;
code
  {
    %s
    { CAR; NIL operation; PAIR }
  };
"
                                % string parameter parameter
                              match push_drops with
                              | 0 => "# No push-drops" % string
                              | n =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  "# %d push-drop%s
    %s" % string n
                                  (if OCaml.Stdlib.gt n 1 then
                                    "s" % string
                                  else
                                    "" % string)
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                              end in
                          let tmp :=
                            Stdlib.Filename.temp_file None
                              "little-id-script" % string ".tz" % string in
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star state tmp
                              (id_script parameter))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star;
                                let origination :=
                                  let opt :=
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star [] in
                                  OCaml.Stdlib.app
                                    (cons "--wait" % string
                                      (cons "none" % string
                                        (cons "originate" % string
                                          (cons "contract" % string
                                            (cons name [])))))
                                    (OCaml.Stdlib.app
                                      match protocol_kind with
                                      | Athens =>
                                        cons "for" % string (cons from [])
                                      | Babylon => []
                                      end
                                      (OCaml.Stdlib.app
                                        (cons "transferring" % string
                                          (cons amount
                                            (cons "from" % string
                                              (cons from
                                                (cons "running" % string
                                                  (cons tmp
                                                    (cons "--init" % string
                                                      (cons init_storage
                                                        (cons "--force" % string
                                                          (cons
                                                            "--burn-cap" %
                                                              string
                                                            (cons
                                                              "300000000000" %
                                                                string
                                                              (cons
                                                                "--gas-limit" %
                                                                  string
                                                                (cons
                                                                  "1000000000000000"
                                                                    % string
                                                                  (cons
                                                                    "--storage-limit"
                                                                      % string
                                                                    (cons
                                                                      "20000000000000"
                                                                        % string
                                                                      (cons
                                                                        "--verbose-signing"
                                                                          %
                                                                          string
                                                                        []))))))))))))))))
                                        (OCaml.Stdlib.app
                                          (opt delegate
                                            (fun s =>
                                              cons "--delegate" % string
                                                (cons s [])))
                                          (OCaml.Stdlib.app
                                            (if delegatable then
                                              cons "--delegatable" % string []
                                            else
                                              [])
                                            (if spendable then
                                              cons "--spendable" % string []
                                            else
                                              []))))) in
                                op_star_t_y_p_e_minus_e_r_r_o_r_star origination
                              end)
              end.

Definition originate_id_script {A B C D : Type}
  (push_drops : option Z) (state : A) (client : B) (name : string)
  (from : string) (bake : C) (protocol_kind : variant) (parameter : string)
  (init_storage : string) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (prepare_origination_of_id_script None None None push_drops None state
      client name from protocol_kind parameter init_storage)
    (fun origination =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star state client origination)
        (fun function_parameter =>
          match function_parameter with
          | _ =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star bake "baking `%s` in" % string
              name
          end)).

Definition pp_warning_ledger_takes_a_while {A B C : Type}
  (adjective : A) (ppf : B) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
    let prompt := "WARNING: " % string in
    let warning1 := "The ledger will take a few seconds to show" % string in
    let warning2 :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        "the hash for such a %s operation." % string adjective in
    let wl := Z.add (OCaml.String.length prompt) (OCaml.String.length warning1)
      in
    op_star_t_y_p_e_minus_e_r_r_o_r_star "shout" % string ppf
      (fun ppf =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
          (String.append "/" % string
            (String.append (Stdlib.String.make wl "=" % char) "\" % string)));
    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
    op_star_t_y_p_e_minus_e_r_r_o_r_star "shout" % string ppf
      (fun ppf => op_star_t_y_p_e_minus_e_r_r_o_r_star ppf "|%s" % string prompt);
    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf warning1;
    op_star_t_y_p_e_minus_e_r_r_o_r_star "shout" % string ppf
      (fun ppf => op_star_t_y_p_e_minus_e_r_r_o_r_star ppf "|" % string);
    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
    op_star_t_y_p_e_minus_e_r_r_o_r_star "shout" % string ppf
      (fun ppf => op_star_t_y_p_e_minus_e_r_r_o_r_star ppf "|" % string);
    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
      (Stdlib.String.make (OCaml.String.length prompt) " " % char);
    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf warning2;
    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
      (Stdlib.String.make
        (Z.sub (OCaml.String.length warning1) (OCaml.String.length warning2))
        " " % char);
    op_star_t_y_p_e_minus_e_r_r_o_r_star "shout" % string ppf
      (fun ppf => op_star_t_y_p_e_minus_e_r_r_o_r_star ppf "|" % string);
    op_star_t_y_p_e_minus_e_r_r_o_r_star ppf tt;
    op_star_t_y_p_e_minus_e_r_r_o_r_star "shout" % string ppf
      (fun ppf =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
          (String.append "\" % string
            (String.append (Stdlib.String.make wl "=" % char) "/" % string)))
  end.

Definition basic_contract_operations_tests {A B C D E F : Type}
  (state : A) (client : B) (src : string) (with_rejections : bool)
  (protocol_kind : variant) (ledger_account : C) (bake : D) (delegate : E)
  (function_parameter : unit) : F :=
  match function_parameter with
  | tt =>
    let ledger_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star ledger_account in
    let only_success := negb with_rejections in
    let test_origination {G : Type}
      (delegate : option E) (delegatable : option bool) (spendable :
      option bool) (push_drops : option Z) (name : string) (amount : string)
      (parameter : string) (init_storage : string) (function_parameter : unit)
      : G :=
      match function_parameter with
      | tt =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (prepare_origination_of_id_script spendable delegatable delegate
            push_drops (Some amount) state client name src protocol_kind
            parameter init_storage)
          (fun origination =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (with_ledger_test_reject_and_accept (Some only_success) state
                (cons
                  (fun ppf =>
                    fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star ppf
                          "Origination: %s (ledger: %s)" % string name
                          ledger_pkh
                      end)
                  (cons (show_command_message origination)
                    (cons please_check_the_hash
                      (cons
                        (if nequiv_decb push_drops None then
                          pp_warning_ledger_takes_a_while "huge" % string
                        else
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star "" % string) []))))
                (fun user_answer =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (client_async_cmd state client origination
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          fun proc =>
                            find_and_print_signature_hash (Some true) state proc
                        end))
                    (fun res =>
                      expect_from_output
                        match user_answer with
                        | Reject => variant
                        | Accept => variant
                        end name res)))
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bake
                    "%s with %s" % string name src
                end))
      end in
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (test_origination None None None None "ID-unit" % string "0" % string
        "unit" % string "Unit" % string tt)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (test_origination None None None None "ID-string" % string
              "10" % string "string" % string """some string""" % string tt)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (test_origination None None None None
                    "ID-string-nat-mutez" % string "10" % string
                    "(pair string (pair nat mutez))" % string
                    "Pair ""hello"" (Pair 12 1)" % string tt)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (test_origination (Some delegate) None None None
                          "ID-address+delegate" % string "1" % string
                          "address" % string
                          """tz1YPSCGWXwBdTncK2aCctSZAXWvGsGwVJqU""" % string tt)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              match protocol_kind with
                              | Athens =>
                                test_origination (Some delegate) (Some true)
                                  None None "ID-string+delegatable" % string
                                  "0" % string "string" % string
                                  """delegatable contract""" % string tt
                              | Babylon =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star tt
                              end
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  let push_drops := 242 in
                                  test_origination None None None
                                    (Some push_drops) "giant-contract" % string
                                    "10" % string "(pair string nat)" % string
                                    "Pair ""the answer is: "" 42" % string tt
                                end)
                          end)
                    end)
              end)
        end)
  end.

Module Wallet_scenario.
  Definition root := variant.
  
  Definition t := variant.
  
  Definition with_rejections (function_parameter : t) : bool :=
    match function_parameter with
    | Without_rejections _ => false
    | _ => true
    end.
  
  Definition enum_assoc : list (string * root) :=
    cons ("everything" % string, variant)
      (cons ("voting" % string, variant)
        (cons ("none" % string, variant)
          (cons ("delegation" % string, variant)
            (cons ("transactions" % string, variant)
              (cons ("contracts" % string, variant)
                (cons ("batch-transactions" % string, variant) [])))))).
  
  Definition root (ws : t) : root :=
    match ws with
    | Without_rejections r => r
    |
      (Transactions |
        Delegation | Contracts | All | Batch_transactions | None | Voting) as r
      => r
    end.
  
  Definition run_if {A B : Type}
    (v : root) (t : t) (yes : bool -> A) (no : B -> A) : A :=
    let with_rejections := with_rejections t in
    match root t with
    | All => yes with_rejections
    | _other =>
      no
        (op_star_t_y_p_e_minus_e_r_r_o_r_star enum_assoc
          (fun function_parameter =>
            match function_parameter with
            | (k, this) => Some k
            | _ => None
            end))
    end.
  
  Definition if_voting {A B : Type} (t : t) : (bool -> A) -> (B -> A) -> A :=
    run_if variant t.
  
  Definition if_batch_transactions {A B : Type} (t : t)
    : (bool -> A) -> (B -> A) -> A := run_if variant t.
  
  Definition if_delegation {A B : Type} (t : t)
    : (bool -> A) -> (B -> A) -> A := run_if variant t.
  
  Definition if_transactions {A B : Type} (t : t)
    : (bool -> A) -> (B -> A) -> A := run_if variant t.
  
  Definition if_contracts {A B : Type} (t : t) : (bool -> A) -> (B -> A) -> A :=
    run_if variant t.
  
  Definition cli_term {A : Type} (function_parameter : unit) : A :=
    match function_parameter with
    | tt =>
      let make (no_rejections : bool) (v : root) : t :=
        if no_rejections then
          variant
        else
          v in
      op_star_t_y_p_e_minus_e_r_r_o_r_star
    end.
End Wallet_scenario.

Definition run {A B C D E F G H : Type}
  (state : A) (pp_error : Stdlib.Format.formatter -> B -> unit) (protocol : C)
  (protocol_kind : variant) (node_exec : D) (client_exec : D) (admin_exec : D)
  (wallet_scenario : Wallet_scenario.t) (size : E) (base_port : F) (uri : G)
  (function_parameter : unit) : H :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star state variant
              (cons node_exec (cons client_exec (cons admin_exec []))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      let ledger_client :=
                        op_star_t_y_p_e_minus_e_r_r_o_r_star client_exec in
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                          ledger_client uri)
                        (fun _ledger_account =>
                          match op_star_t_y_p_e_minus_e_r_r_o_r_star with
                          | (protocol, baker_0_account, _baker_0_balance) =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star protocol
                                size base_port state node_exec client_exec)
                              (fun function_parameter =>
                                match function_parameter with
                                | (nodes, protocol) =>
                                  let client {I J : Type} (n : I) : J :=
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      client_exec
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        nodes n) in
                                  let client_0 := client 0 in
                                  let baker_0 :=
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      client_0 "baker-0" % string
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        baker_0_account) in
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                      baker_0)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | _ =>
                                        let make_admin :=
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            admin_exec in
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          state
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star;
                                        let first_bakes := 3 in
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            first_bakes
                                            (fun nth =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  state baker_0)
                                                "initial-bake %d" % string nth))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  state
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    let signer :=
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (client 0)
                                                        "ledgered" % string uri
                                                      in
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        state client_0 uri)
                                                      (fun ledger_account =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            state client_0
                                                            (cons
                                                              "--wait" % string
                                                              (cons
                                                                "none" % string
                                                                (cons
                                                                  "transfer" %
                                                                    string
                                                                  (cons
                                                                    "20000" %
                                                                      string
                                                                    (cons
                                                                      "from" %
                                                                        string
                                                                      (cons
                                                                        (Tezos_client.Keyed.key_name
                                                                          baker_0)
                                                                        (cons
                                                                          "to" %
                                                                            string
                                                                          (cons
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              ledger_account)
                                                                            (cons
                                                                              "--burn-cap"
                                                                                %
                                                                                string
                                                                              (cons
                                                                                "100"
                                                                                  %
                                                                                  string
                                                                                [])))))))))))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | _ =>
                                                              let bake
                                                                {I J : Type}
                                                                (msg : I) : J :=
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  state baker_0
                                                                  msg in
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (bake
                                                                  "After transferring tez to the ledger account"
                                                                    % string)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (with_ledger_test_reject_and_accept
                                                                        (Some
                                                                          (OCaml.Stdlib.reverse_apply
                                                                            (Wallet_scenario.with_rejections
                                                                              wallet_scenario)
                                                                            negb))
                                                                        state
                                                                        (cons
                                                                          (fun
                                                                            ppf
                                                                            =>
                                                                            fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  ppf
                                                                                  "Importing %S in client `%s`."
                                                                                    %
                                                                                    string
                                                                                  uri
                                                                                  (Tezos_client.id
                                                                                    client_0)
                                                                              end)
                                                                          (cons
                                                                            (fun
                                                                              ppf
                                                                              =>
                                                                              fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  tt
                                                                                  =>
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    ppf
                                                                                    "The ledger should be prompting for acknowledgment to provide the public key of `%s`."
                                                                                      %
                                                                                      string
                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      ledger_account)
                                                                                end)
                                                                            []))
                                                                        (fun
                                                                          user_answer
                                                                          =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              state
                                                                              client_0
                                                                              (cons
                                                                                "import"
                                                                                  %
                                                                                  string
                                                                                (cons
                                                                                  "secret"
                                                                                    %
                                                                                    string
                                                                                  (cons
                                                                                    "key"
                                                                                      %
                                                                                      string
                                                                                    (cons
                                                                                      (key_name
                                                                                        signer)
                                                                                      (cons
                                                                                        (secret_key
                                                                                          signer)
                                                                                        (cons
                                                                                          "--force"
                                                                                            %
                                                                                            string
                                                                                          [])))))))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                (_,
                                                                                  proc)
                                                                                =>
                                                                                expect_from_output
                                                                                  match
                                                                                    user_answer
                                                                                    with
                                                                                  |
                                                                                    Accept
                                                                                    =>
                                                                                    variant
                                                                                  |
                                                                                    Reject
                                                                                    =>
                                                                                    variant
                                                                                  end
                                                                                  "importing key"
                                                                                    %
                                                                                    string
                                                                                  proc
                                                                              end)))
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          let
                                                                            skipping
                                                                            {I J
                                                                            :
                                                                            Type}
                                                                            (s :
                                                                            I)
                                                                            : J :=
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              state
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            in
                                                                          let
                                                                            voting_test
                                                                            {I :
                                                                            Type}
                                                                            (with_rejections
                                                                            :
                                                                            bool)
                                                                            : I :=
                                                                            let
                                                                              tested_proposal :=
                                                                              "Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd"
                                                                                %
                                                                                string
                                                                              in
                                                                            voting_tests
                                                                              state
                                                                              client
                                                                              (key_name
                                                                                signer)
                                                                              with_rejections
                                                                              protocol_kind
                                                                              ledger_account
                                                                              tested_proposal
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  tt
                                                                                  =>
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      state
                                                                                      client_0
                                                                                      (cons
                                                                                        "--wait"
                                                                                          %
                                                                                          string
                                                                                        (cons
                                                                                          "none"
                                                                                            %
                                                                                            string
                                                                                          (cons
                                                                                            "submit"
                                                                                              %
                                                                                              string
                                                                                            (cons
                                                                                              "proposals"
                                                                                                %
                                                                                                string
                                                                                              (cons
                                                                                                "for"
                                                                                                  %
                                                                                                  string
                                                                                                (cons
                                                                                                  (Tezos_client.Keyed.key_name
                                                                                                    baker_0)
                                                                                                  (cons
                                                                                                    tested_proposal
                                                                                                    (cons
                                                                                                      "--force"
                                                                                                        %
                                                                                                        string
                                                                                                      [])))))))))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        _
                                                                                        =>
                                                                                        let
                                                                                          blocks :=
                                                                                          Tezos_protocol.blocks_per_voting_period
                                                                                            protocol
                                                                                          in
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            blocks
                                                                                            (fun
                                                                                              nth
                                                                                              =>
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  state
                                                                                                  baker_0)
                                                                                                "going to testing-vote period %d/%d"
                                                                                                  %
                                                                                                  string
                                                                                                (Z.add
                                                                                                  nth
                                                                                                  1)
                                                                                                blocks))
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            match
                                                                                              function_parameter
                                                                                              with
                                                                                            |
                                                                                              tt
                                                                                              =>
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                tt
                                                                                            end)
                                                                                      end)
                                                                                end)
                                                                              tt
                                                                            in
                                                                          let
                                                                            batch_test
                                                                            {I :
                                                                            Type}
                                                                            (with_rejections
                                                                            :
                                                                            bool)
                                                                            : I :=
                                                                            let
                                                                              n :=
                                                                              50
                                                                              in
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              (forge_batch_transactions
                                                                                state
                                                                                (client
                                                                                  0)
                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  ledger_account)
                                                                                "tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F"
                                                                                  %
                                                                                  string
                                                                                n
                                                                                None
                                                                                tt)
                                                                              (fun
                                                                                batch_transaction_bytes
                                                                                =>
                                                                                let
                                                                                  bytes_hash :=
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  in
                                                                                with_ledger_test_reject_and_accept
                                                                                  (Some
                                                                                    (negb
                                                                                      with_rejections))
                                                                                  state
                                                                                  (cons
                                                                                    (fun
                                                                                      ppf
                                                                                      =>
                                                                                      fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          tt
                                                                                          =>
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            ppf
                                                                                            "Signing batch of %d transactions"
                                                                                              %
                                                                                              string
                                                                                            n
                                                                                        end)
                                                                                    (cons
                                                                                      (fun
                                                                                        ppf
                                                                                        =>
                                                                                        fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            tt
                                                                                            =>
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              ppf
                                                                                              "Ledger should display “Sign Hash” → `%s`"
                                                                                                %
                                                                                                string
                                                                                              bytes_hash
                                                                                          end)
                                                                                      (cons
                                                                                        (pp_warning_ledger_takes_a_while
                                                                                          "big"
                                                                                            %
                                                                                            string)
                                                                                        [])))
                                                                                  (fun
                                                                                    user_answer
                                                                                    =>
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      (sign
                                                                                        state
                                                                                        signer
                                                                                        batch_transaction_bytes)
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          (_,
                                                                                            proc)
                                                                                          =>
                                                                                          expect_from_output
                                                                                            match
                                                                                              user_answer
                                                                                              with
                                                                                            |
                                                                                              Accept
                                                                                              =>
                                                                                              variant
                                                                                            |
                                                                                              Reject
                                                                                              =>
                                                                                              variant
                                                                                            end
                                                                                            "Signing batch operation"
                                                                                              %
                                                                                              string
                                                                                            proc
                                                                                        end)))
                                                                            in
                                                                          let
                                                                            delegation_tests
                                                                            {I :
                                                                            Type}
                                                                            (with_rejections
                                                                            :
                                                                            bool)
                                                                            : I :=
                                                                            delegation_tests
                                                                              state
                                                                              client_0
                                                                              (key_name
                                                                                signer)
                                                                              with_rejections
                                                                              protocol_kind
                                                                              ledger_account
                                                                              (Tezos_client.Keyed.key_name
                                                                                baker_0)
                                                                              bake
                                                                              tt
                                                                            in
                                                                          let
                                                                            unit_kt1_account :=
                                                                            "unit-kt1-of-the-baker"
                                                                              %
                                                                              string
                                                                            in
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (originate_id_script
                                                                              None
                                                                              state
                                                                              client_0
                                                                              unit_kt1_account
                                                                              (Tezos_client.Keyed.key_name
                                                                                baker_0)
                                                                              bake
                                                                              protocol_kind
                                                                              "unit"
                                                                                %
                                                                                string
                                                                              "Unit"
                                                                                %
                                                                                string)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                let
                                                                                  pair_string_nat_kt1_account :=
                                                                                  "pair-string-nat-kt1-of-the-baker"
                                                                                    %
                                                                                    string
                                                                                  in
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (originate_id_script
                                                                                    (Some
                                                                                      10)
                                                                                    state
                                                                                    client_0
                                                                                    pair_string_nat_kt1_account
                                                                                    (Tezos_client.Keyed.key_name
                                                                                      baker_0)
                                                                                    bake
                                                                                    protocol_kind
                                                                                    "(pair string nat)"
                                                                                      %
                                                                                      string
                                                                                    "Pair ""the answer is: "" 42"
                                                                                      %
                                                                                      string)
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      let
                                                                                        transactions_test
                                                                                        {I
                                                                                        :
                                                                                        Type}
                                                                                        (with_rejections
                                                                                        :
                                                                                        bool)
                                                                                        : I :=
                                                                                        transaction_tests
                                                                                          state
                                                                                          client_0
                                                                                          (key_name
                                                                                            signer)
                                                                                          with_rejections
                                                                                          protocol_kind
                                                                                          pair_string_nat_kt1_account
                                                                                          ledger_account
                                                                                          unit_kt1_account
                                                                                          bake
                                                                                          tt
                                                                                        in
                                                                                      let
                                                                                        contracts_test
                                                                                        {I
                                                                                        :
                                                                                        Type}
                                                                                        (with_rejections
                                                                                        :
                                                                                        bool)
                                                                                        : I :=
                                                                                        basic_contract_operations_tests
                                                                                          state
                                                                                          client_0
                                                                                          (key_name
                                                                                            signer)
                                                                                          with_rejections
                                                                                          protocol_kind
                                                                                          ledger_account
                                                                                          bake
                                                                                          (Tezos_client.Keyed.key_name
                                                                                            baker_0)
                                                                                          tt
                                                                                        in
                                                                                      let
                                                                                        bake_command :=
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          (cons
                                                                                            "bake"
                                                                                              %
                                                                                              string
                                                                                            [])
                                                                                          (fun
                                                                                            _sexps
                                                                                            =>
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (fun
                                                                                                e
                                                                                                =>
                                                                                                Stdlib.Format.kasprintf
                                                                                                  (fun
                                                                                                    s
                                                                                                    =>
                                                                                                    variant)
                                                                                                  (CamlinternalFormatBasics.Format
                                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                                      "run-test-error: "
                                                                                                        %
                                                                                                        string
                                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                                        CamlinternalFormatBasics.End_of_format))
                                                                                                    "run-test-error: %a"
                                                                                                      %
                                                                                                      string)
                                                                                                  pp_error
                                                                                                  e)
                                                                                              (bake
                                                                                                "Interactive"
                                                                                                  %
                                                                                                  string))
                                                                                        in
                                                                                      let
                                                                                        run_test_command :=
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          (cons
                                                                                            "rt"
                                                                                              %
                                                                                              string
                                                                                            (cons
                                                                                              "run-test"
                                                                                                %
                                                                                                string
                                                                                              []))
                                                                                          (fun
                                                                                            sexps
                                                                                            =>
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (fun
                                                                                                e
                                                                                                =>
                                                                                                Stdlib.Format.kasprintf
                                                                                                  (fun
                                                                                                    s
                                                                                                    =>
                                                                                                    variant)
                                                                                                  (CamlinternalFormatBasics.Format
                                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                                      "run-test-error: "
                                                                                                        %
                                                                                                        string
                                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                                        CamlinternalFormatBasics.End_of_format))
                                                                                                    "run-test-error: %a"
                                                                                                      %
                                                                                                      string)
                                                                                                  pp_error
                                                                                                  e)
                                                                                              match
                                                                                                sexps
                                                                                                with
                                                                                              |
                                                                                                _
                                                                                                =>
                                                                                                let
                                                                                                  run
                                                                                                  {I
                                                                                                  :
                                                                                                  Type}
                                                                                                  (f
                                                                                                  :
                                                                                                  bool
                                                                                                    ->
                                                                                                    I)
                                                                                                  : I :=
                                                                                                  f
                                                                                                    true
                                                                                                  in
                                                                                                match
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    Stdlib.String.equal
                                                                                                    Wallet_scenario.enum_assoc
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  with
                                                                                                |
                                                                                                  Some
                                                                                                    None
                                                                                                  =>
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    tt
                                                                                                |
                                                                                                  Some
                                                                                                    Delegation
                                                                                                  =>
                                                                                                  run
                                                                                                    delegation_tests
                                                                                                |
                                                                                                  Some
                                                                                                    All
                                                                                                  =>
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (run
                                                                                                      delegation_tests)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      match
                                                                                                        function_parameter
                                                                                                        with
                                                                                                      |
                                                                                                        tt
                                                                                                        =>
                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          (run
                                                                                                            batch_test)
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            match
                                                                                                              function_parameter
                                                                                                              with
                                                                                                            |
                                                                                                              tt
                                                                                                              =>
                                                                                                              run
                                                                                                                voting_test
                                                                                                            end)
                                                                                                      end)
                                                                                                |
                                                                                                  Some
                                                                                                    Batch_transactions
                                                                                                  =>
                                                                                                  run
                                                                                                    batch_test
                                                                                                |
                                                                                                  Some
                                                                                                    Transactions
                                                                                                  =>
                                                                                                  run
                                                                                                    transactions_test
                                                                                                |
                                                                                                  Some
                                                                                                    Voting
                                                                                                  =>
                                                                                                  run
                                                                                                    voting_test
                                                                                                |
                                                                                                  Some
                                                                                                    Contracts
                                                                                                  =>
                                                                                                  run
                                                                                                    contracts_test
                                                                                                |
                                                                                                  None
                                                                                                  =>
                                                                                                  failf
                                                                                                    None
                                                                                                    "Don't know this test: %S"
                                                                                                      %
                                                                                                      string
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                end
                                                                                              |
                                                                                                _
                                                                                                =>
                                                                                                failf
                                                                                                  None
                                                                                                  "Cannot understand command line"
                                                                                                    %
                                                                                                    string
                                                                                              end)
                                                                                        in
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        state
                                                                                        (cons
                                                                                          run_test_command
                                                                                          (cons
                                                                                            bake_command
                                                                                            []));
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (Wallet_scenario.if_voting
                                                                                          wallet_scenario
                                                                                          voting_test
                                                                                          skipping)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            tt
                                                                                            =>
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (Wallet_scenario.if_batch_transactions
                                                                                                wallet_scenario
                                                                                                batch_test
                                                                                                skipping)
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  tt
                                                                                                  =>
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (Wallet_scenario.if_transactions
                                                                                                      wallet_scenario
                                                                                                      transactions_test
                                                                                                      skipping)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      match
                                                                                                        function_parameter
                                                                                                        with
                                                                                                      |
                                                                                                        tt
                                                                                                        =>
                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          (Wallet_scenario.if_contracts
                                                                                                            wallet_scenario
                                                                                                            contracts_test
                                                                                                            skipping)
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            match
                                                                                                              function_parameter
                                                                                                              with
                                                                                                            |
                                                                                                              tt
                                                                                                              =>
                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                (Wallet_scenario.if_delegation
                                                                                                                  wallet_scenario
                                                                                                                  delegation_tests
                                                                                                                  skipping)
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  match
                                                                                                                    function_parameter
                                                                                                                    with
                                                                                                                  |
                                                                                                                    tt
                                                                                                                    =>
                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      state
                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                  end)
                                                                                                            end)
                                                                                                      end)
                                                                                                end)
                                                                                          end)
                                                                                    end)
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end))
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  match function_parameter with
  | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.
src/bin_sandbox/command_prevalidation.ml 
open Flextesa
open Internal_pervasives
open Console

let run state node_exec client_exec () =
  Test_scenario.network_with_protocol ~size:2 state ~node_exec ~client_exec
  >>= fun (nodes, _protocol) ->
  match nodes with
  | [] | [_] | _ :: _ :: _ :: _ ->
      assert false
  | [n1; n2] ->
      let c1 = Tezos_client.of_node ~exec:client_exec n1 in
      let c2 = Tezos_client.of_node ~exec:client_exec n2 in
      (* TODO: helpers for
         - injecting an op
         - displaying the mempool
         - setting filter plugin config

         TODO: non-interactive test for propagation
         TODO: commands for interactivea use *)
      Pervasives.ignore c1 ;
      Pervasives.ignore c2 ;
      return ()
      >>= fun () ->
      let commands = Interactive_test.Commands.all_defaults state ~nodes in
      Prompt.command state ~commands
      >>= fun () -> Running_processes.wait_all state

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure (fun bnod bcli state -> (state, run state bnod bcli))
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Test_command_line.cli_state ~name:"prevalidation" () )
    (info ~doc:"Work-in-progress." "prevalidation")
src/bin_sandbox/command_prevalidation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition run {A B C D : Type}
  (state : A) (node_exec : B) (client_exec : C) (function_parameter : unit)
  : D :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2 state node_exec client_exec)
      (fun function_parameter =>
        match function_parameter with
        | (nodes, _protocol) =>
          match nodes with
          | [] | cons _ [] | cons _ (cons _ (cons _ _)) => false
          | cons n1 (cons n2 []) =>
            let c1 := op_star_t_y_p_e_minus_e_r_r_o_r_star client_exec n1 in
            let c2 := op_star_t_y_p_e_minus_e_r_r_o_r_star client_exec n2 in
            Stdlib.Pervasives.ignore c1;
            Stdlib.Pervasives.ignore c2;
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  let commands :=
                    op_star_t_y_p_e_minus_e_r_r_o_r_star state nodes in
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star state commands)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star state
                      end)
                end)
          end
        end)
  end.

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  match function_parameter with
  | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.
src/bin_sandbox/command_voting.ml 
(* Semi-interactive test for voting *)
open Flextesa
open Internal_pervasives
module Counter_log = Helpers.Counter_log

let ledger_prompt_notice state ef =
  Console.say
    state
    EF.(
      desc
        (shout "Ledger-prompt")
        (list [ef; wf "Please hit “✔” on the ledger."]))

let setup_baking_ledger state uri ~client =
  Interactive_test.Pauser.generic
    state
    EF.
      [ wf "Setting up the ledger device %S" uri;
        haf
          "Please make sure the ledger is on the Baking app and quit (`q`) \
           this prompt to continue." ]
    ~force:true
  >>= fun () ->
  let key_name = "ledgered" in
  let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in
  ledger_prompt_notice
    state
    EF.(
      wf
        "Importing %S in client `%s`. The ledger should be prompting for \
         acknowledgment to provide the public key."
        uri
        client.Tezos_client.id)
  >>= fun () ->
  Tezos_client.Keyed.initialize state baker
  >>= fun _ ->
  ledger_prompt_notice
    state
    EF.(
      wf
        "Setting up %S for baking. The ledger should be showing the setup \
         parameters (Address, Main chain, HWMs)."
        uri)
  >>= fun () ->
  Tezos_client.successful_client_cmd
    state
    ~client
    [ "setup";
      "ledger";
      "to";
      "bake";
      "for";
      key_name;
      "--main-hwm";
      "0";
      "--test-hwm";
      "0" ]
  >>= fun _ -> return baker

let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt

let transfer state ~client ~src ~dst ~amount =
  Tezos_client.successful_client_cmd
    state
    ~client
    [ "--wait";
      "none";
      "transfer";
      sprintf "%Ld" amount;
      "from";
      src;
      "to";
      dst;
      "--fee";
      "0.05";
      "--burn-cap";
      "0.3" ]

let register state ~client ~dst =
  Tezos_client.successful_client_cmd
    state
    ~client
    [ "--wait";
      "none";
      "register";
      "key";
      dst;
      "as";
      "delegate";
      "--fee";
      "0.05" ]

let bake_until_voting_period ?keep_alive_delegate state ~baker ~attempts period
    =
  let client = baker.Tezos_client.Keyed.client in
  let period_name = Tezos_protocol.Voting_period.to_string period in
  Helpers.wait_for state ~attempts ~seconds:0.5 (fun nth ->
      Tezos_client.rpc
        state
        ~client
        `Get
        ~path:"/chains/main/blocks/head/votes/current_period_kind"
      >>= function
      | `String p when p = period_name ->
          return (`Done (nth - 1))
      | _ ->
          Asynchronous_result.map_option keep_alive_delegate ~f:(fun dst ->
              register state ~client ~dst)
          >>= fun _ ->
          ksprintf
            (Tezos_client.Keyed.bake state baker)
            "Baker %s bakes %d/%d waiting for %S voting period"
            client.id
            nth
            attempts
            period_name
          >>= fun () ->
          return (`Not_done (sprintf "Waiting for %S period" period_name)))

let check_understood_protocols state ~chain ~client ~protocol_hash
    ~expect_clueless_client =
  Asynchronous_result.bind_on_result
    (Tezos_client.successful_client_cmd
       state
       ~client
       ["--chain"; chain; "list"; "understood"; "protocols"])
    ~f:(function
      | Ok client_protocols_result -> (
        match
          List.find client_protocols_result#out ~f:(fun prefix ->
              String.is_prefix protocol_hash ~prefix)
        with
        | Some _ ->
            return `Proper_understanding
        | None when expect_clueless_client ->
            return `Expected_misunderstanding
        | None ->
            return `Failure_to_understand )
      | Error (`Client_command_error _) when expect_clueless_client ->
          return `Expected_misunderstanding
      | Error e ->
          fail e)

let run state ~winner_path ~demo_path ~protocol ~node_exec ~client_exec
    ~clueless_winner ~admin_exec ~winner_client_exec ~size ~base_port
    ~serialize_proposals ?with_ledger () =
  let default_attempts = 50 in
  Helpers.clear_root state
  >>= fun () ->
  Helpers.System_dependencies.precheck
    state
    `Or_fail
    ~executables:[node_exec; client_exec; admin_exec; winner_client_exec]
    ~protocol_paths:[winner_path; demo_path]
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ready to start"; af "Root path deleted."]
  >>= fun () ->
  let (protocol, baker_0_account, baker_0_balance) =
    let open Tezos_protocol in
    let baker = List.nth_exn protocol.bootstrap_accounts 0 in
    ( {
        protocol with
        time_between_blocks = [1; 0];
        bootstrap_accounts =
          List.map protocol.bootstrap_accounts ~f:(fun (n, v) ->
              if fst baker = n then (n, v) else (n, 1_000L));
      },
      fst baker,
      snd baker )
  in
  Test_scenario.network_with_protocol
    ~protocol
    ~size
    ~base_port
    state
    ~node_exec
    ~client_exec
  >>= fun (nodes, protocol) ->
  let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~make_admin
          ~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
  Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
  >>= fun () ->
  let client n =
    Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
  in
  let baker_0 =
    Tezos_client.Keyed.make
      (client 0)
      ~key_name:"baker-0"
      ~secret_key:(Tezos_protocol.Account.private_key baker_0_account)
  in
  Tezos_client.Keyed.initialize state baker_0
  >>= fun _ ->
  let level_counter = Counter_log.create () in
  let first_bakes = 5 in
  Loop.n_times first_bakes (fun nth ->
      ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth)
  >>= fun () ->
  let initial_level = first_bakes + 1 in
  Counter_log.add level_counter "initial_level" initial_level ;
  ( match with_ledger with
  | None ->
      Console.say state EF.(wf "No ledger.")
      >>= fun () ->
      let account = Tezos_protocol.Account.of_name "special-baker" in
      let baker =
        Tezos_client.Keyed.make
          (client 0)
          ~key_name:(Tezos_protocol.Account.name account)
          ~secret_key:(Tezos_protocol.Account.private_key account)
      in
      Tezos_client.Keyed.initialize state baker >>= fun _ -> return baker
  | Some uri ->
      setup_baking_ledger state ~client:(client 0) uri )
  >>= fun special_baker ->
  let winner_client = {baker_0.client with exec = winner_client_exec} in
  let winner_baker_0 =
    let open Tezos_client.Keyed in
    {baker_0 with client = winner_client}
  in
  let winner_special_baker =
    let open Tezos_client.Keyed in
    {special_baker with client = winner_client}
  in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.
      [ arbitrary_command_on_all_clients
          state
          ~command_names:["wc"; "winner-client"]
          ?make_admin:None
          ~clients:[winner_client] ] ;
  Interactive_test.Pauser.generic
    state
    EF.[wf "You can now try the new-client"]
  >>= fun () ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.
      [ arbitrary_command_on_all_clients
          state
          ~command_names:["baker"]
          ~make_admin
          ~clients:[special_baker.Tezos_client.Keyed.client] ] ;
  transfer
    state (* Tezos_client.successful_client_cmd state *)
    ~client:(client 0)
    ~amount:(Int64.div baker_0_balance 2_000_000L)
    ~src:"baker-0"
    ~dst:special_baker.Tezos_client.Keyed.key_name
  >>= fun res ->
  Console.say
    state
    EF.(
      desc
        (wf "Successful transfer baker-0 -> special:")
        (ocaml_string_list res#out))
  >>= fun () ->
  let after_transfer_bakes = 2 in
  Loop.n_times after_transfer_bakes (fun nth ->
      ksprintf
        (Tezos_client.Keyed.bake state baker_0)
        "after-transfer-bake %d"
        nth)
  >>= fun () ->
  Counter_log.add level_counter "after-transfer-bakes" after_transfer_bakes ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  Asynchronous_result.map_option with_ledger ~f:(fun _ ->
      ledger_prompt_notice state EF.(wf "Registering as delegate."))
  >>= fun (_ : unit option) ->
  Tezos_client.successful_client_cmd
    state
    ~client:(client 0)
    [ "--wait";
      "none";
      "register";
      "key";
      special_baker.Tezos_client.Keyed.key_name;
      "as";
      "delegate";
      "--fee";
      "0.5" ]
  >>= fun _ ->
  let activation_bakes =
    let open Tezos_protocol in
    protocol.blocks_per_cycle * (protocol.preserved_cycles + 2)
  in
  Loop.n_times activation_bakes (fun nth ->
      ksprintf
        (Tezos_client.Keyed.bake state baker_0)
        "Baking after new delegate registered: %d/%d"
        nth
        activation_bakes
      >>= fun () ->
      Tezos_client.successful_client_cmd
        state
        ~client:(client 0)
        ["rpc"; "get"; "/chains/main/blocks/head/helpers/baking_rights"]
      >>= fun res ->
      Console.say
        state
        EF.(
          desc
            (haf "Baking rights")
            (markdown_verbatim (String.concat ~sep:"\n" res#out))))
  >>= fun () ->
  Counter_log.add level_counter "activation-bakes" activation_bakes ;
  Tezos_client.Keyed.bake state special_baker "Baked by Special Baker™"
  >>= fun () ->
  Counter_log.incr level_counter "special-baker-first-bake" ;
  let attempts =
    Tezos_protocol.(
      (* If we are right after the proposal period, we need to get to
         the next one *)
      3 * protocol.blocks_per_voting_period)
  in
  bake_until_voting_period
    state
    ~baker:special_baker
    ~attempts
    `Proposal
    ~keep_alive_delegate:baker_0.key_name
  >>= fun extra_bakes_waiting_for_proposal_period ->
  Counter_log.add
    level_counter
    "wait-for-proposal-period"
    extra_bakes_waiting_for_proposal_period ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  let admin_0 = Tezos_admin_client.of_client ~exec:admin_exec (client 0) in
  Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"]
  >>= fun res ->
  let default_protocols = res#out in
  let make_and_inject_protocol ?(make_different = false) name path =
    let tmpdir = Paths.root state // sprintf "protocol-%s" name in
    Console.say state EF.(wf "Injecting protocol from %s" tmpdir)
    >>= fun () ->
    Running_processes.run_successful_cmdf
      state
      "cp -L -R %s %s"
      (Filename.quote path)
      (Filename.quote tmpdir)
    >>= fun _ ->
    ( if make_different then
      Running_processes.run_successful_cmdf
        state
        "echo '(* Protocol %s *)' >> %s/main.mli"
        name
        (Filename.quote tmpdir)
      >>= fun _ -> return ()
    else return () )
    >>= fun () ->
    Tezos_admin_client.inject_protocol admin_0 state ~path:tmpdir
    >>= fun (res, hash) ->
    Interactive_test.Pauser.generic
      state
      EF.
        [ af "Just injected %s (%s): %s" name path hash;
          markdown_verbatim (String.concat ~sep:"\n" res#out) ]
    >>= fun () -> return hash
  in
  make_and_inject_protocol "winner" winner_path
  >>= fun winner_hash ->
  make_and_inject_protocol
    ~make_different:(winner_path = demo_path)
    "demo"
    demo_path
  >>= fun demo_hash ->
  Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"]
  >>= fun res ->
  let after_injections_protocols = res#out in
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "Network up";
        desc (haf "Protcols")
        @@ list
             (List.map after_injections_protocols ~f:(fun p ->
                  af
                    "`%s` (%s)"
                    p
                    ( if List.mem default_protocols p ~equal:String.equal then
                      "previously known"
                    else
                      match p with
                      | _ when p = winner_hash ->
                          "injected winner"
                      | _ when p = demo_hash ->
                          "injected demo"
                      | _ ->
                          "injected unknown" ))) ]
  >>= fun () ->
  Asynchronous_result.map_option with_ledger ~f:(fun _ ->
      Interactive_test.Pauser.generic
        state
        EF.
          [ af "About to VOTE";
            haf "Please switch to the Wallet app and quit (`q`) this prompt."
          ]
        ~force:true)
  >>= fun (_ : unit option) ->
  let submit_proposals baker props =
    Asynchronous_result.map_option with_ledger ~f:(fun _ ->
        ledger_prompt_notice
          state
          EF.(
            wf
              "Submitting proposal%s: %s"
              (if List.length props = 1 then "" else "s")
              (String.concat ~sep:", " props)))
    >>= fun _ ->
    Tezos_client.successful_client_cmd
      state
      ~client:baker.Tezos_client.Keyed.client
      (["submit"; "proposals"; "for"; baker.key_name] @ props)
    >>= fun _ -> return ()
  in
  let to_submit_first = [winner_hash; demo_hash] in
  ( match serialize_proposals with
  | false ->
      submit_proposals special_baker to_submit_first
  | true ->
      List_sequential.iter to_submit_first ~f:(fun one ->
          submit_proposals special_baker [one]) )
  >>= fun () ->
  Tezos_client.successful_client_cmd
    state
    ~client:baker_0.client
    ["submit"; "proposals"; "for"; baker_0.key_name; winner_hash]
  >>= fun _ ->
  bake_until_voting_period
    state
    ~baker:baker_0
    ~attempts:protocol.blocks_per_voting_period
    `Testing_vote
    ~keep_alive_delegate:special_baker.key_name
  >>= fun extra_bakes_waiting_for_testing_vote_period ->
  Counter_log.add
    level_counter
    "wait-for-testing-vote-period"
    extra_bakes_waiting_for_testing_vote_period ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  Helpers.wait_for state ~attempts:default_attempts ~seconds:2. (fun _ ->
      Tezos_client.rpc
        state
        ~client:(client 1)
        `Get
        ~path:"/chains/main/blocks/head/votes/current_proposal"
      >>= fun current_proposal_json ->
      if current_proposal_json <> `String winner_hash then
        return
          (`Not_done
            (sprintf
               "Waiting for current_proposal_json to be %s (%s)"
               winner_hash
               Ezjsonm.(to_string (wrap current_proposal_json))))
      else return (`Done ()))
  >>= fun () ->
  Tezos_client.successful_client_cmd
    state
    ~client:baker_0.client
    ["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"]
  >>= fun _ ->
  Asynchronous_result.map_option with_ledger ~f:(fun _ ->
      ledger_prompt_notice
        state
        EF.(wf "Submitting “Yes” ballot for %S" winner_hash))
  >>= fun (_ : unit option) ->
  Tezos_client.successful_client_cmd
    state
    ~client:special_baker.client
    ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"]
  >>= fun _ ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ballots are in (not baked though)"]
  >>= fun () ->
  bake_until_voting_period
    state
    ~baker:baker_0
    ~attempts:(1 + protocol.blocks_per_voting_period)
    ~keep_alive_delegate:special_baker.key_name
    `Testing
  >>= fun extra_bakes_waiting_for_testing_period ->
  Counter_log.add
    level_counter
    "wait-for-testing-period"
    extra_bakes_waiting_for_testing_period ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  check_understood_protocols
    state
    ~client:winner_client
    ~chain:"main"
    ~protocol_hash:winner_hash
    ~expect_clueless_client:clueless_winner
  >>= (function
        | `Proper_understanding ->
            let chain = "test" in
            Asynchronous_result.map_option with_ledger ~f:(fun _ ->
                Interactive_test.Pauser.generic
                  state
                  EF.
                    [ af "About to bake on the test chain.";
                      haf
                        "Please switch back to the Baking app and quit (`q`) \
                         this prompt." ]
                  ~force:true)
            >>= fun (_ : unit option) ->
            let testing_bakes = 5 in
            Loop.n_times testing_bakes (fun ith ->
                let baker =
                  if ith mod 2 = 0 then winner_baker_0
                  else winner_special_baker
                in
                Tezos_client.Keyed.bake
                  ~chain
                  state
                  baker
                  (sprintf
                     "Baking on the test chain [%d/%d]"
                     (ith + 1)
                     testing_bakes))
            >>= fun () ->
            Test_scenario.Queries.wait_for_all_levels_to_be
              state
              ~chain
              ~attempts:default_attempts
              ~seconds:8.
              nodes
              (`At_least (Counter_log.sum level_counter + testing_bakes))
            >>= fun () ->
            Interactive_test.Pauser.generic
              state
              EF.[wf "Testing period, with proper winner-client, have fun."]
            >>= fun () -> return ()
        | `Expected_misunderstanding ->
            Console.say
              state
              EF.(wf "Winner-Client cannot bake on test chain (expected)")
        | `Failure_to_understand ->
            failf "Winner-Client cannot bake on test chain!")
  >>= fun () ->
  Helpers.wait_for state ~attempts:default_attempts ~seconds:0.3 (fun _ ->
      Tezos_client.rpc
        state
        ~client:(client 1)
        `Get
        ~path:"/chains/main/blocks/head/metadata"
      >>= fun metadata_json ->
      try
        match
          Jqo.field metadata_json ~k:"test_chain_status"
          |> Jqo.field ~k:"protocol"
        with
        | `String s when s = winner_hash ->
            return (`Done ())
        | other ->
            return
              (`Not_done
                (sprintf "Wrong protocol: %s" Ezjsonm.(to_string (wrap other))))
      with e ->
        return
          (`Not_done
            (sprintf
               "Cannot get test-chain protocol: %s → %s"
               (Exn.to_string e)
               Ezjsonm.(to_string (wrap metadata_json)))))
  >>= fun () ->
  bake_until_voting_period
    state
    ~baker:baker_0
    ~attempts:(1 + protocol.blocks_per_voting_period)
    ~keep_alive_delegate:special_baker.key_name
    `Promotion_vote
  >>= fun extra_bakes_waiting_for_promotion_period ->
  Counter_log.add
    level_counter
    "wait-for-promotion-period"
    extra_bakes_waiting_for_promotion_period ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  Interactive_test.Pauser.generic state EF.[haf "Before ballots"]
  >>= fun () ->
  Tezos_client.successful_client_cmd
    state
    ~client:baker_0.client
    ["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"]
  >>= fun _ ->
  Asynchronous_result.map_option with_ledger ~f:(fun _ ->
      Interactive_test.Pauser.generic
        state
        EF.
          [ af "About to cast approval ballot.";
            haf
              "Please switch back to the Wallet app and quit (`q`) this prompt."
          ]
        ~force:true
      >>= fun () ->
      ledger_prompt_notice
        state
        EF.(wf "Submitting “Yes” ballot for %S" winner_hash))
  >>= fun (_ : unit option) ->
  Tezos_client.successful_client_cmd
    state
    ~client:special_baker.client
    ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"]
  >>= fun _ ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Final ballot(s) are in (not baked though)"]
  >>= fun () ->
  let ballot_bakes = 1 in
  Loop.n_times ballot_bakes (fun _ ->
      Tezos_client.Keyed.bake state baker_0 "Baking the promotion vote ballots")
  >>= fun () ->
  Counter_log.add level_counter "bake-the-ballots" ballot_bakes ;
  Tezos_client.successful_client_cmd
    state
    ~client:(client 0)
    ["list"; "understood"; "protocols"]
  >>= fun client_protocols_result ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "Final ballot(s) are baked in.";
        af
          "The client `%s` understands the following protocols: %s"
          Tezos_executable.(
            Option.value
              ~default:(default_binary client_exec)
              client_exec.binary)
          (String.concat ~sep:", " client_protocols_result#out) ]
  >>= fun () ->
  Helpers.wait_for
    state
    ~seconds:0.5
    ~attempts:(1 + protocol.blocks_per_voting_period)
    (fun nth ->
      let client = baker_0.client in
      Running_processes.run_successful_cmdf
        state
        "curl http://localhost:%d/chains/main/blocks/head/metadata"
        client.port
      >>= fun curl_res ->
      let json_string = curl_res#out |> String.concat ~sep:"\n" in
      let json_metadata = Ezjsonm.from_string json_string in
      match Jqo.field json_metadata ~k:"next_protocol" with
      | `String p when p = winner_hash ->
          return (`Done (nth - 1))
      | other ->
          transfer
            state
            ~client
            ~amount:1L
            ~src:baker_0.Tezos_client.Keyed.key_name
            ~dst:special_baker.Tezos_client.Keyed.key_name
          >>= fun _ ->
          ksprintf
            (Tezos_client.Keyed.bake state baker_0)
            "Baker %s bakes %d/%d waiting for next protocol: %S"
            client.id
            nth
            attempts
            winner_hash
          >>= fun () ->
          return
            (`Not_done
              (sprintf
                 "Waiting for next_protocol: %S (≠ %s)"
                 winner_hash
                 Ezjsonm.(to_string (wrap other)))))
  >>= fun extra_bakes_waiting_for_next_protocol ->
  Counter_log.add
    level_counter
    "wait-for-next-protocol"
    extra_bakes_waiting_for_next_protocol ;
  check_understood_protocols
    state
    ~client:winner_client
    ~chain:"main"
    ~protocol_hash:winner_hash
    ~expect_clueless_client:clueless_winner
  >>= (function
        | `Expected_misunderstanding ->
            Console.say
              state
              EF.(
                wf "As expected, the client does not know about %s" winner_hash)
        | `Failure_to_understand ->
            failf "The winner-client does not know about `%s`" winner_hash
        | `Proper_understanding -> (
            Console.say state EF.(wf "The client knows about %s" winner_hash)
            >>= fun () ->
            (* This actually depends on the protocol upgrade. *)
            Asynchronous_result.bind_on_result
              (Tezos_client.successful_client_cmd
                 state
                 ~client:winner_client
                 ["upgrade"; "baking"; "state"])
              ~f:(function
                | Ok _ ->
                    return ()
                | Error _ ->
                    Console.say
                      state
                      EF.(
                        desc
                          (shout "Warning")
                          (wf
                             "Command `upgrade baking state` failed, but we \
                              keep going with the baking.")))
            >>= fun () ->
            Asynchronous_result.map_option with_ledger ~f:(fun _ ->
                Interactive_test.Pauser.generic
                  state
                  EF.
                    [ af "About to bake on the new winning protocol.";
                      haf
                        "Please switch to the Baking app and quit (`q`) this \
                         prompt." ]
                  ~force:true
                >>= fun () ->
                Console.say state EF.(wf "Sleeping for a couple of seconds…")
                >>= fun () -> System.sleep 4.
                (* USB thing is often slower than humans hitting `q` *))
            >>= fun (_ : unit option) ->
            Tezos_client.Keyed.bake
              state
              winner_baker_0
              "First bake on new protocol !!"
            >>= fun () ->
            Counter_log.incr level_counter "baker-0-bakes-on-new-protocol" ;
            Tezos_client.Keyed.bake
              state
              winner_special_baker
              "Second bake on new protocol !!"
            >>= fun () ->
            Counter_log.incr
              level_counter
              "special-baker-bakes-on-new-protocol" ;
            Tezos_client.rpc
              state
              ~client:winner_client
              `Get
              ~path:"/chains/main/blocks/head/metadata"
            >>= fun json_metadata ->
            match Jqo.field json_metadata ~k:"protocol" with
            | `String p when p = winner_hash ->
                return ()
            | other ->
                failf
                  "Protocol is not `%s` but `%s`"
                  winner_hash
                  Ezjsonm.(to_string (wrap other)) ))
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ haf "End of the Voting test: SUCCESS \\o/";
        desc
          (af "Estimated level: %d" (Counter_log.sum level_counter))
          (markdown_verbatim (Counter_log.to_table_string level_counter)) ]
  >>= fun () -> return ()

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun winner_path
             demo_path
             node_exec
             client_exec
             admin_exec
             winner_client_exec
             size
             (`Clueless_winner clueless_winner)
             (`Base_port base_port)
             (`With_ledger with_ledger)
             (`Serialize_proposals serialize_proposals)
             protocol
             state
             ->
          ( state,
            Interactive_test.Pauser.run_test
              state
              ~pp_error
              (run
                 state
                 ~serialize_proposals
                 ~winner_path
                 ~clueless_winner
                 ~demo_path
                 ~node_exec
                 ~size
                 ~admin_exec
                 ~base_port
                 ~client_exec
                 ~winner_client_exec
                 ~protocol
                 ?with_ledger) ))
    $ Arg.(
        pure Filename.dirname
        $ required
            (pos
               0
               (some string)
               None
               (info
                  []
                  ~docv:"WINNER-PROTOCOL-PATH"
                  ~doc:
                    "The protocol to inject and make win the election, e.g. \
                     `src/proto_004_Pt24m4xi/lib_protocol/src/TEZOS_PROTOCOL`.")))
    $ Arg.(
        pure Filename.dirname
        $ required
            (pos
               1
               (some string)
               None
               (info
                  []
                  ~docv:"LOSER-PROTOCOL-PATH"
                  ~doc:
                    "The protocol to inject and down-vote, e.g. \
                     `./src/bin_client/test/proto_test_injection/TEZOS_PROTOCOL` \
                     (if same as `WINNER-PROTOCOL-PATH` the scenario will \
                     make them automatically & artificially different).")))
    $ Tezos_executable.cli_term `Node "current"
    $ Tezos_executable.cli_term `Client "current"
    $ Tezos_executable.cli_term `Admin "current"
    $ Tezos_executable.cli_term `Client "winner"
    $ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network.")))
    $ Arg.(
        pure (fun b -> `Clueless_winner b)
        $ value
            (flag
               (info
                  ["winning-client-is-clueless"]
                  ~doc:
                    "Do not fail if the client does not know about “next” \
                     protocol.")))
    (*
$ Arg.(
        pure (fun p -> `Hash p)
        $ value
            (opt
               (some string)
               None
               (info
                  ["current-hash"]
                  ~doc:"The hash to advertise as the current protocol.")))
 *)
    $ Arg.(
        pure (fun p -> `Base_port p)
        $ value
            (opt
               int
               46_000
               (info ["base-port"] ~doc:"Base port number to build upon.")))
    $ Arg.(
        pure (fun x -> `With_ledger x)
        $ value
            (opt
               (some string)
               None
               (info
                  ["with-ledger"]
                  ~docv:"ledger://..."
                  ~doc:
                    "Do the test with a Ledger Nano device as one of the \
                     bakers/voters.")))
    $ Arg.(
        pure (fun x -> `Serialize_proposals x)
        $ value
            (flag
               (info
                  ["serialize-proposals"]
                  ~doc:
                    "Run the proposals one-by-one instead of all together \
                     (preferred by the Ledger).")))
    $ Tezos_protocol.cli_term ()
    $ Test_command_line.cli_state ~name:"voting" () )
    (let doc = "Sandbox network with a full round of voting." in
     let man : Manpage.block list =
       [ `S "VOTING TEST";
         `P
           "This command provides a test which uses a network sandbox to \
            perform a full round of protocol vote and upgrade, including \
            voting and baking on the test chain with or without a Ledger Nano \
            device.";
         `P "There are two main test behaviors:";
         `P
           "* $(b,SIMPLE:) The simple one does as much as possible with any \
            dummy protocol candidates and a Tezos code-base which doesn't \
            handle them: it tests all the voting periods until baking the \
            last block of the currently understood protocol.";
         `Noblank;
         `P
           "To allow the test to succeed in this case, the option \
            `--winning-client-is-clueless` is required; it is meant to signal \
            that the “winner” `tezos-client` executable (from the \
            `--winner-client-binary` option) is expected to not understand \
            the winning protocol.";
         `Noblank;
         `P
           "This is the version running in Gitlab-CI, see `bin_flextesa/dune`.";
         `P
           "* $(b,FULL:) Without the `--winning-client-is-clueless` option, \
            the test will try to bake on the test chain as well as after the \
            protocol switch (with the winner-client). This requires the \
            winning protocol to be a working one and, of course, the \
            winning-client to understand it.";
         `P
           "The test can run fully automated unless one uses the \
            `\"--with-ledger=ledger://...\"` option in which case some steps \
            have to be interactive. In this case, the option \
            `--serialize-proposals` is recommended, because if it is not \
            provided, the proposal vote will be a “Sign Unverfied” \
            operation." ]
     in
     info ~doc ~man "voting")
src/bin_sandbox/command_voting.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Counter_log.

End Counter_log.

Definition ledger_prompt_notice {A B C : Type} (state : A) (ef : B) : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star state
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition setup_baking_ledger {A B C D : Type}
  (state : A) (uri : B) (client : C) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star state
      op_star_t_y_p_e_minus_e_r_r_o_r_star true)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let key_name := "ledgered" % string in
        let baker := op_star_t_y_p_e_minus_e_r_r_o_r_star client key_name uri in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (ledger_prompt_notice state op_star_t_y_p_e_minus_e_r_r_o_r_star)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star state baker)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (ledger_prompt_notice state
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
                              (cons "setup" % string
                                (cons "ledger" % string
                                  (cons "to" % string
                                    (cons "bake" % string
                                      (cons "for" % string
                                        (cons key_name
                                          (cons "--main-hwm" % string
                                            (cons "0" % string
                                              (cons "--test-hwm" % string
                                                (cons "0" % string [])))))))))))
                            (fun function_parameter =>
                              match function_parameter with
                              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star baker
                              end)
                        end)
                  end)
            end)
      end).

Definition failf {A B : Type} (fmt : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (fun s => op_star_t_y_p_e_minus_e_r_r_o_r_star variant) fmt.

Definition transfer {A B C D : Type}
  (state : A) (client : B) (src : string) (dst : string) (amount : C) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star state client
    (cons "--wait" % string
      (cons "none" % string
        (cons "transfer" % string
          (cons (op_star_t_y_p_e_minus_e_r_r_o_r_star "%Ld" % string amount)
            (cons "from" % string
              (cons src
                (cons "to" % string
                  (cons dst
                    (cons "--fee" % string
                      (cons "0.05" % string
                        (cons "--burn-cap" % string (cons "0.3" % string [])))))))))))).

Definition register {A B C : Type} (state : A) (client : B) (dst : string)
  : C :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star state client
    (cons "--wait" % string
      (cons "none" % string
        (cons "register" % string
          (cons "key" % string
            (cons dst
              (cons "as" % string
                (cons "delegate" % string
                  (cons "--fee" % string (cons "0.05" % string []))))))))).

Definition bake_until_voting_period {A B C D E F : Type}
  (keep_alive_delegate : option A) (state : B) (baker : C) (attempts : D)
  (period : E) : F :=
  let client := Tezos_client.Keyed.client baker in
  let period_name := op_star_t_y_p_e_minus_e_r_r_o_r_star period in
  op_star_t_y_p_e_minus_e_r_r_o_r_star state attempts 0
    (fun nth =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star state client variant
          "/chains/main/blocks/head/votes/current_period_kind" % string)
        (fun function_parameter =>
          match function_parameter with
          | String p => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
          | _ =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star keep_alive_delegate
                (fun dst => register state client dst))
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star state baker)
                      "Baker %s bakes %d/%d waiting for %S voting period" %
                        string (id client) nth attempts period_name)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
                      end)
                end)
          end)).

Definition check_understood_protocols {A B C D : Type}
  (state : A) (chain : string) (client : B) (protocol_hash : C)
  (expect_clueless_client : bool) : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (op_star_t_y_p_e_minus_e_r_r_o_r_star state client
      (cons "--chain" % string
        (cons chain
          (cons "list" % string
            (cons "understood" % string (cons "protocols" % string []))))))
    (fun function_parameter =>
      match function_parameter with
      | inl client_protocols_result =>
        match
          Stdlib.List.find send expected_argument
            (fun prefix =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star protocol_hash prefix) with
        | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
        | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star variant
        end
      | inr (Client_command_error _) =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star variant
      | inr e => op_star_t_y_p_e_minus_e_r_r_o_r_star e
      end).

Definition run {A B C D E F G : Type}
  (state : A) (winner_path : string) (demo_path : string) (protocol : B)
  (node_exec : C) (client_exec : C) (clueless_winner : bool) (admin_exec : C)
  (winner_client_exec : C) (size : D) (base_port : E)
  (serialize_proposals : bool) (with_ledger : option F)
  (function_parameter : unit) : G :=
  match function_parameter with
  | tt =>
    let default_attempts := 50 in
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star state)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star state variant
              (cons node_exec
                (cons client_exec (cons admin_exec (cons winner_client_exec []))))
              (cons winner_path (cons demo_path [])))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      match op_star_t_y_p_e_minus_e_r_r_o_r_star with
                      | (protocol, baker_0_account, baker_0_balance) =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star protocol size
                            base_port state node_exec client_exec)
                          (fun function_parameter =>
                            match function_parameter with
                            | (nodes, protocol) =>
                              let make_admin :=
                                op_star_t_y_p_e_minus_e_r_r_o_r_star admin_exec
                                in
                              op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                op_star_t_y_p_e_minus_e_r_r_o_r_star;
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star state
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    let client {H I : Type} (n : H) : I :=
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        client_exec
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          nodes n) in
                                    let baker_0 :=
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (client 0) "baker-0" % string
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          baker_0_account) in
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        state baker_0)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          let level_counter :=
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              tt in
                                          let first_bakes := 5 in
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              first_bakes
                                              (fun nth =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    state baker_0)
                                                  "initial-bake %d" % string nth))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                let initial_level :=
                                                  Z.add first_bakes 1 in
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  level_counter
                                                  "initial_level" % string
                                                  initial_level;
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  match with_ledger with
                                                  | None =>
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        state
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          let account :=
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              "special-baker" %
                                                                string in
                                                          let baker :=
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (client 0)
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                account)
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                account) in
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              state baker)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | _ =>
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  baker
                                                              end)
                                                        end)
                                                  | Some uri =>
                                                    setup_baking_ledger state
                                                      uri (client 0)
                                                  end
                                                  (fun special_baker =>
                                                    let winner_client :=
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      in
                                                    let winner_baker_0 :=
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      in
                                                    let winner_special_baker :=
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      in
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      state
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star;
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        state
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            state
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star;
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (transfer state
                                                              (client 0)
                                                              "baker-0" % string
                                                              (Tezos_client.Keyed.key_name
                                                                special_baker)
                                                              (Stdlib.Int64.div
                                                                baker_0_balance
                                                                2000000))
                                                            (fun res =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  state
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    let
                                                                      after_transfer_bakes :=
                                                                      2 in
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        after_transfer_bakes
                                                                        (fun nth
                                                                          =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              state
                                                                              baker_0)
                                                                            "after-transfer-bake %d"
                                                                              %
                                                                              string
                                                                            nth))
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            level_counter
                                                                            "after-transfer-bakes"
                                                                              %
                                                                              string
                                                                            after_transfer_bakes;
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              state
                                                                              default_attempts
                                                                              8
                                                                              nodes
                                                                              variant)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    with_ledger
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        _
                                                                                        =>
                                                                                        ledger_prompt_notice
                                                                                          state
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      end))
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      _
                                                                                      =>
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          state
                                                                                          (client
                                                                                            0)
                                                                                          (cons
                                                                                            "--wait"
                                                                                              %
                                                                                              string
                                                                                            (cons
                                                                                              "none"
                                                                                                %
                                                                                                string
                                                                                              (cons
                                                                                                "register"
                                                                                                  %
                                                                                                  string
                                                                                                (cons
                                                                                                  "key"
                                                                                                    %
                                                                                                    string
                                                                                                  (cons
                                                                                                    (Tezos_client.Keyed.key_name
                                                                                                      special_baker)
                                                                                                    (cons
                                                                                                      "as"
                                                                                                        %
                                                                                                        string
                                                                                                      (cons
                                                                                                        "delegate"
                                                                                                          %
                                                                                                          string
                                                                                                        (cons
                                                                                                          "--fee"
                                                                                                            %
                                                                                                            string
                                                                                                          (cons
                                                                                                            "0.5"
                                                                                                              %
                                                                                                              string
                                                                                                            []))))))))))
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            _
                                                                                            =>
                                                                                            let
                                                                                              activation_bakes :=
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              in
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                activation_bakes
                                                                                                (fun
                                                                                                  nth
                                                                                                  =>
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        state
                                                                                                        baker_0)
                                                                                                      "Baking after new delegate registered: %d/%d"
                                                                                                        %
                                                                                                        string
                                                                                                      nth
                                                                                                      activation_bakes)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      match
                                                                                                        function_parameter
                                                                                                        with
                                                                                                      |
                                                                                                        tt
                                                                                                        =>
                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            state
                                                                                                            (client
                                                                                                              0)
                                                                                                            (cons
                                                                                                              "rpc"
                                                                                                                %
                                                                                                                string
                                                                                                              (cons
                                                                                                                "get"
                                                                                                                  %
                                                                                                                  string
                                                                                                                (cons
                                                                                                                  "/chains/main/blocks/head/helpers/baking_rights"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  []))))
                                                                                                          (fun
                                                                                                            res
                                                                                                            =>
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              state
                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                      end)))
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  tt
                                                                                                  =>
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    level_counter
                                                                                                    "activation-bakes"
                                                                                                      %
                                                                                                      string
                                                                                                    activation_bakes;
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      state
                                                                                                      special_baker
                                                                                                      "Baked by Special Baker™"
                                                                                                        %
                                                                                                        string)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      match
                                                                                                        function_parameter
                                                                                                        with
                                                                                                      |
                                                                                                        tt
                                                                                                        =>
                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          level_counter
                                                                                                          "special-baker-first-bake"
                                                                                                            %
                                                                                                            string;
                                                                                                        let
                                                                                                          attempts :=
                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          in
                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          (bake_until_voting_period
                                                                                                            (Some
                                                                                                              (key_name
                                                                                                                baker_0))
                                                                                                            state
                                                                                                            special_baker
                                                                                                            attempts
                                                                                                            variant)
                                                                                                          (fun
                                                                                                            extra_bakes_waiting_for_proposal_period
                                                                                                            =>
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              level_counter
                                                                                                              "wait-for-proposal-period"
                                                                                                                %
                                                                                                                string
                                                                                                              extra_bakes_waiting_for_proposal_period;
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                state
                                                                                                                default_attempts
                                                                                                                8
                                                                                                                nodes
                                                                                                                variant)
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                match
                                                                                                                  function_parameter
                                                                                                                  with
                                                                                                                |
                                                                                                                  tt
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    admin_0 :=
                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      admin_exec
                                                                                                                      (client
                                                                                                                        0)
                                                                                                                    in
                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      admin_0
                                                                                                                      state
                                                                                                                      (cons
                                                                                                                        "list"
                                                                                                                          %
                                                                                                                          string
                                                                                                                        (cons
                                                                                                                          "protocols"
                                                                                                                            %
                                                                                                                            string
                                                                                                                          [])))
                                                                                                                    (fun
                                                                                                                      res
                                                                                                                      =>
                                                                                                                      let
                                                                                                                        default_protocols :=
                                                                                                                        send
                                                                                                                        in
                                                                                                                      let
                                                                                                                        make_and_inject_protocol
                                                                                                                        {H
                                                                                                                        I
                                                                                                                        :
                                                                                                                        Type}
                                                                                                                        (op_star_o_p_t_star
                                                                                                                        :
                                                                                                                        option
                                                                                                                          bool)
                                                                                                                        : H
                                                                                                                          ->
                                                                                                                          string
                                                                                                                            ->
                                                                                                                            I :=
                                                                                                                        let
                                                                                                                          make_different :=
                                                                                                                          match
                                                                                                                            op_star_o_p_t_star
                                                                                                                            with
                                                                                                                          |
                                                                                                                            Some
                                                                                                                              op_star_s_t_h_star
                                                                                                                            =>
                                                                                                                            op_star_s_t_h_star
                                                                                                                          |
                                                                                                                            None
                                                                                                                            =>
                                                                                                                            false
                                                                                                                          end
                                                                                                                          in
                                                                                                                        fun
                                                                                                                          name
                                                                                                                          =>
                                                                                                                          fun
                                                                                                                            path
                                                                                                                            =>
                                                                                                                            let
                                                                                                                              tmpdir :=
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  state)
                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  "protocol-%s"
                                                                                                                                    %
                                                                                                                                    string
                                                                                                                                  name)
                                                                                                                              in
                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                state
                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                              (fun
                                                                                                                                function_parameter
                                                                                                                                =>
                                                                                                                                match
                                                                                                                                  function_parameter
                                                                                                                                  with
                                                                                                                                |
                                                                                                                                  tt
                                                                                                                                  =>
                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      state
                                                                                                                                      "cp -L -R %s %s"
                                                                                                                                        %
                                                                                                                                        string
                                                                                                                                      (Stdlib.Filename.quote
                                                                                                                                        path)
                                                                                                                                      (Stdlib.Filename.quote
                                                                                                                                        tmpdir))
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      match
                                                                                                                                        function_parameter
                                                                                                                                        with
                                                                                                                                      |
                                                                                                                                        _
                                                                                                                                        =>
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          (if
                                                                                                                                            make_different
                                                                                                                                            then
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                state
                                                                                                                                                "echo '(* Protocol %s *)' >> %s/main.mli"
                                                                                                                                                  %
                                                                                                                                                  string
                                                                                                                                                name
                                                                                                                                                (Stdlib.Filename.quote
                                                                                                                                                  tmpdir))
                                                                                                                                              (fun
                                                                                                                                                function_parameter
                                                                                                                                                =>
                                                                                                                                                match
                                                                                                                                                  function_parameter
                                                                                                                                                  with
                                                                                                                                                |
                                                                                                                                                  _
                                                                                                                                                  =>
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                    tt
                                                                                                                                                end)
                                                                                                                                          else
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              tt)
                                                                                                                                          (fun
                                                                                                                                            function_parameter
                                                                                                                                            =>
                                                                                                                                            match
                                                                                                                                              function_parameter
                                                                                                                                              with
                                                                                                                                            |
                                                                                                                                              tt
                                                                                                                                              =>
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  admin_0
                                                                                                                                                  state
                                                                                                                                                  tmpdir)
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  match
                                                                                                                                                    function_parameter
                                                                                                                                                    with
                                                                                                                                                  |
                                                                                                                                                    (res,
                                                                                                                                                      hash)
                                                                                                                                                    =>
                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                        state
                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                      (fun
                                                                                                                                                        function_parameter
                                                                                                                                                        =>
                                                                                                                                                        match
                                                                                                                                                          function_parameter
                                                                                                                                                          with
                                                                                                                                                        |
                                                                                                                                                          tt
                                                                                                                                                          =>
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                            hash
                                                                                                                                                        end)
                                                                                                                                                  end)
                                                                                                                                            end)
                                                                                                                                      end)
                                                                                                                                end)
                                                                                                                        in
                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                        (make_and_inject_protocol
                                                                                                                          None
                                                                                                                          "winner"
                                                                                                                            %
                                                                                                                            string
                                                                                                                          winner_path)
                                                                                                                        (fun
                                                                                                                          winner_hash
                                                                                                                          =>
                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                            (make_and_inject_protocol
                                                                                                                              (Some
                                                                                                                                (equiv_decb
                                                                                                                                  winner_path
                                                                                                                                  demo_path))
                                                                                                                              "demo"
                                                                                                                                %
                                                                                                                                string
                                                                                                                              demo_path)
                                                                                                                            (fun
                                                                                                                              demo_hash
                                                                                                                              =>
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  admin_0
                                                                                                                                  state
                                                                                                                                  (cons
                                                                                                                                    "list"
                                                                                                                                      %
                                                                                                                                      string
                                                                                                                                    (cons
                                                                                                                                      "protocols"
                                                                                                                                        %
                                                                                                                                        string
                                                                                                                                      [])))
                                                                                                                                (fun
                                                                                                                                  res
                                                                                                                                  =>
                                                                                                                                  let
                                                                                                                                    after_injections_protocols :=
                                                                                                                                    send
                                                                                                                                    in
                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      state
                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      match
                                                                                                                                        function_parameter
                                                                                                                                        with
                                                                                                                                      |
                                                                                                                                        tt
                                                                                                                                        =>
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            with_ledger
                                                                                                                                            (fun
                                                                                                                                              function_parameter
                                                                                                                                              =>
                                                                                                                                              match
                                                                                                                                                function_parameter
                                                                                                                                                with
                                                                                                                                              |
                                                                                                                                                _
                                                                                                                                                =>
                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  state
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  true
                                                                                                                                              end))
                                                                                                                                          (fun
                                                                                                                                            function_parameter
                                                                                                                                            =>
                                                                                                                                            match
                                                                                                                                              function_parameter
                                                                                                                                              with
                                                                                                                                            |
                                                                                                                                              _
                                                                                                                                              =>
                                                                                                                                              let
                                                                                                                                                submit_proposals
                                                                                                                                                {H
                                                                                                                                                I
                                                                                                                                                :
                                                                                                                                                Type}
                                                                                                                                                (baker
                                                                                                                                                :
                                                                                                                                                H)
                                                                                                                                                (props
                                                                                                                                                :
                                                                                                                                                list
                                                                                                                                                  string)
                                                                                                                                                : I :=
                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                    with_ledger
                                                                                                                                                    (fun
                                                                                                                                                      function_parameter
                                                                                                                                                      =>
                                                                                                                                                      match
                                                                                                                                                        function_parameter
                                                                                                                                                        with
                                                                                                                                                      |
                                                                                                                                                        _
                                                                                                                                                        =>
                                                                                                                                                        ledger_prompt_notice
                                                                                                                                                          state
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      end))
                                                                                                                                                  (fun
                                                                                                                                                    function_parameter
                                                                                                                                                    =>
                                                                                                                                                    match
                                                                                                                                                      function_parameter
                                                                                                                                                      with
                                                                                                                                                    |
                                                                                                                                                      _
                                                                                                                                                      =>
                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                          state
                                                                                                                                                          (Tezos_client.Keyed.client
                                                                                                                                                            baker)
                                                                                                                                                          (OCaml.Stdlib.app
                                                                                                                                                            (cons
                                                                                                                                                              "submit"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              (cons
                                                                                                                                                                "proposals"
                                                                                                                                                                  %
                                                                                                                                                                  string
                                                                                                                                                                (cons
                                                                                                                                                                  "for"
                                                                                                                                                                    %
                                                                                                                                                                    string
                                                                                                                                                                  (cons
                                                                                                                                                                    (key_name
                                                                                                                                                                      baker)
                                                                                                                                                                    []))))
                                                                                                                                                            props))
                                                                                                                                                        (fun
                                                                                                                                                          function_parameter
                                                                                                                                                          =>
                                                                                                                                                          match
                                                                                                                                                            function_parameter
                                                                                                                                                            with
                                                                                                                                                          |
                                                                                                                                                            _
                                                                                                                                                            =>
                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                              tt
                                                                                                                                                          end)
                                                                                                                                                    end)
                                                                                                                                                in
                                                                                                                                              let
                                                                                                                                                to_submit_first :=
                                                                                                                                                cons
                                                                                                                                                  winner_hash
                                                                                                                                                  (cons
                                                                                                                                                    demo_hash
                                                                                                                                                    [])
                                                                                                                                                in
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                match
                                                                                                                                                  serialize_proposals
                                                                                                                                                  with
                                                                                                                                                |
                                                                                                                                                  false
                                                                                                                                                  =>
                                                                                                                                                  submit_proposals
                                                                                                                                                    special_baker
                                                                                                                                                    to_submit_first
                                                                                                                                                |
                                                                                                                                                  true
                                                                                                                                                  =>
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                    to_submit_first
                                                                                                                                                    (fun
                                                                                                                                                      one
                                                                                                                                                      =>
                                                                                                                                                      submit_proposals
                                                                                                                                                        special_baker
                                                                                                                                                        (cons
                                                                                                                                                          one
                                                                                                                                                          []))
                                                                                                                                                end
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  match
                                                                                                                                                    function_parameter
                                                                                                                                                    with
                                                                                                                                                  |
                                                                                                                                                    tt
                                                                                                                                                    =>
                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                        state
                                                                                                                                                        (client
                                                                                                                                                          baker_0)
                                                                                                                                                        (cons
                                                                                                                                                          "submit"
                                                                                                                                                            %
                                                                                                                                                            string
                                                                                                                                                          (cons
                                                                                                                                                            "proposals"
                                                                                                                                                              %
                                                                                                                                                              string
                                                                                                                                                            (cons
                                                                                                                                                              "for"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              (cons
                                                                                                                                                                (key_name
                                                                                                                                                                  baker_0)
                                                                                                                                                                (cons
                                                                                                                                                                  winner_hash
                                                                                                                                                                  []))))))
                                                                                                                                                      (fun
                                                                                                                                                        function_parameter
                                                                                                                                                        =>
                                                                                                                                                        match
                                                                                                                                                          function_parameter
                                                                                                                                                          with
                                                                                                                                                        |
                                                                                                                                                          _
                                                                                                                                                          =>
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                            (bake_until_voting_period
                                                                                                                                                              (Some
                                                                                                                                                                (key_name
                                                                                                                                                                  special_baker))
                                                                                                                                                              state
                                                                                                                                                              baker_0
                                                                                                                                                              (blocks_per_voting_period
                                                                                                                                                                protocol)
                                                                                                                                                              variant)
                                                                                                                                                            (fun
                                                                                                                                                              extra_bakes_waiting_for_testing_vote_period
                                                                                                                                                              =>
                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                level_counter
                                                                                                                                                                "wait-for-testing-vote-period"
                                                                                                                                                                  %
                                                                                                                                                                  string
                                                                                                                                                                extra_bakes_waiting_for_testing_vote_period;
                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  state
                                                                                                                                                                  default_attempts
                                                                                                                                                                  8
                                                                                                                                                                  nodes
                                                                                                                                                                  variant)
                                                                                                                                                                (fun
                                                                                                                                                                  function_parameter
                                                                                                                                                                  =>
                                                                                                                                                                  match
                                                                                                                                                                    function_parameter
                                                                                                                                                                    with
                                                                                                                                                                  |
                                                                                                                                                                    tt
                                                                                                                                                                    =>
                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                        state
                                                                                                                                                                        default_attempts
                                                                                                                                                                        2
                                                                                                                                                                        (fun
                                                                                                                                                                          function_parameter
                                                                                                                                                                          =>
                                                                                                                                                                          match
                                                                                                                                                                            function_parameter
                                                                                                                                                                            with
                                                                                                                                                                          |
                                                                                                                                                                            _
                                                                                                                                                                            =>
                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                state
                                                                                                                                                                                (client
                                                                                                                                                                                  1)
                                                                                                                                                                                variant
                                                                                                                                                                                "/chains/main/blocks/head/votes/current_proposal"
                                                                                                                                                                                  %
                                                                                                                                                                                  string)
                                                                                                                                                                              (fun
                                                                                                                                                                                current_proposal_json
                                                                                                                                                                                =>
                                                                                                                                                                                if
                                                                                                                                                                                  nequiv_decb
                                                                                                                                                                                    current_proposal_json
                                                                                                                                                                                    variant
                                                                                                                                                                                  then
                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                    variant
                                                                                                                                                                                else
                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                    variant)
                                                                                                                                                                          end))
                                                                                                                                                                      (fun
                                                                                                                                                                        function_parameter
                                                                                                                                                                        =>
                                                                                                                                                                        match
                                                                                                                                                                          function_parameter
                                                                                                                                                                          with
                                                                                                                                                                        |
                                                                                                                                                                          tt
                                                                                                                                                                          =>
                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                              state
                                                                                                                                                                              (client
                                                                                                                                                                                baker_0)
                                                                                                                                                                              (cons
                                                                                                                                                                                "submit"
                                                                                                                                                                                  %
                                                                                                                                                                                  string
                                                                                                                                                                                (cons
                                                                                                                                                                                  "ballot"
                                                                                                                                                                                    %
                                                                                                                                                                                    string
                                                                                                                                                                                  (cons
                                                                                                                                                                                    "for"
                                                                                                                                                                                      %
                                                                                                                                                                                      string
                                                                                                                                                                                    (cons
                                                                                                                                                                                      (key_name
                                                                                                                                                                                        baker_0)
                                                                                                                                                                                      (cons
                                                                                                                                                                                        winner_hash
                                                                                                                                                                                        (cons
                                                                                                                                                                                          "yay"
                                                                                                                                                                                            %
                                                                                                                                                                                            string
                                                                                                                                                                                          [])))))))
                                                                                                                                                                            (fun
                                                                                                                                                                              function_parameter
                                                                                                                                                                              =>
                                                                                                                                                                              match
                                                                                                                                                                                function_parameter
                                                                                                                                                                                with
                                                                                                                                                                              |
                                                                                                                                                                                _
                                                                                                                                                                                =>
                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                    with_ledger
                                                                                                                                                                                    (fun
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      =>
                                                                                                                                                                                      match
                                                                                                                                                                                        function_parameter
                                                                                                                                                                                        with
                                                                                                                                                                                      |
                                                                                                                                                                                        _
                                                                                                                                                                                        =>
                                                                                                                                                                                        ledger_prompt_notice
                                                                                                                                                                                          state
                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                      end))
                                                                                                                                                                                  (fun
                                                                                                                                                                                    function_parameter
                                                                                                                                                                                    =>
                                                                                                                                                                                    match
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      with
                                                                                                                                                                                    |
                                                                                                                                                                                      _
                                                                                                                                                                                      =>
                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                          state
                                                                                                                                                                                          (client
                                                                                                                                                                                            special_baker)
                                                                                                                                                                                          (cons
                                                                                                                                                                                            "submit"
                                                                                                                                                                                              %
                                                                                                                                                                                              string
                                                                                                                                                                                            (cons
                                                                                                                                                                                              "ballot"
                                                                                                                                                                                                %
                                                                                                                                                                                                string
                                                                                                                                                                                              (cons
                                                                                                                                                                                                "for"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  string
                                                                                                                                                                                                (cons
                                                                                                                                                                                                  (key_name
                                                                                                                                                                                                    special_baker)
                                                                                                                                                                                                  (cons
                                                                                                                                                                                                    winner_hash
                                                                                                                                                                                                    (cons
                                                                                                                                                                                                      "yay"
                                                                                                                                                                                                        %
                                                                                                                                                                                                        string
                                                                                                                                                                                                      [])))))))
                                                                                                                                                                                        (fun
                                                                                                                                                                                          function_parameter
                                                                                                                                                                                          =>
                                                                                                                                                                                          match
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            with
                                                                                                                                                                                          |
                                                                                                                                                                                            _
                                                                                                                                                                                            =>
                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                state
                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                              (fun
                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                =>
                                                                                                                                                                                                match
                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                  with
                                                                                                                                                                                                |
                                                                                                                                                                                                  tt
                                                                                                                                                                                                  =>
                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                    (bake_until_voting_period
                                                                                                                                                                                                      (Some
                                                                                                                                                                                                        (key_name
                                                                                                                                                                                                          special_baker))
                                                                                                                                                                                                      state
                                                                                                                                                                                                      baker_0
                                                                                                                                                                                                      (Z.add
                                                                                                                                                                                                        1
                                                                                                                                                                                                        (blocks_per_voting_period
                                                                                                                                                                                                          protocol))
                                                                                                                                                                                                      variant)
                                                                                                                                                                                                    (fun
                                                                                                                                                                                                      extra_bakes_waiting_for_testing_period
                                                                                                                                                                                                      =>
                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                        level_counter
                                                                                                                                                                                                        "wait-for-testing-period"
                                                                                                                                                                                                          %
                                                                                                                                                                                                          string
                                                                                                                                                                                                        extra_bakes_waiting_for_testing_period;
                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                          state
                                                                                                                                                                                                          default_attempts
                                                                                                                                                                                                          8
                                                                                                                                                                                                          nodes
                                                                                                                                                                                                          variant)
                                                                                                                                                                                                        (fun
                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                          =>
                                                                                                                                                                                                          match
                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                            with
                                                                                                                                                                                                          |
                                                                                                                                                                                                            tt
                                                                                                                                                                                                            =>
                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                (check_understood_protocols
                                                                                                                                                                                                                  state
                                                                                                                                                                                                                  "main"
                                                                                                                                                                                                                    %
                                                                                                                                                                                                                    string
                                                                                                                                                                                                                  winner_client
                                                                                                                                                                                                                  winner_hash
                                                                                                                                                                                                                  clueless_winner)
                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  match
                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                    with
                                                                                                                                                                                                                  |
                                                                                                                                                                                                                    Proper_understanding
                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                    let
                                                                                                                                                                                                                      chain :=
                                                                                                                                                                                                                      "test"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string
                                                                                                                                                                                                                      in
                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                        with_ledger
                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          match
                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                            with
                                                                                                                                                                                                                          |
                                                                                                                                                                                                                            _
                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                              state
                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                              true
                                                                                                                                                                                                                          end))
                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                        match
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          with
                                                                                                                                                                                                                        |
                                                                                                                                                                                                                          _
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          let
                                                                                                                                                                                                                            testing_bakes :=
                                                                                                                                                                                                                            5
                                                                                                                                                                                                                            in
                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                              testing_bakes
                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                ith
                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                let
                                                                                                                                                                                                                                  baker :=
                                                                                                                                                                                                                                  if
                                                                                                                                                                                                                                    equiv_decb
                                                                                                                                                                                                                                      (Z.modulo
                                                                                                                                                                                                                                        ith
                                                                                                                                                                                                                                        2)
                                                                                                                                                                                                                                      0
                                                                                                                                                                                                                                    then
                                                                                                                                                                                                                                    winner_baker_0
                                                                                                                                                                                                                                  else
                                                                                                                                                                                                                                    winner_special_baker
                                                                                                                                                                                                                                  in
                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                  chain
                                                                                                                                                                                                                                  state
                                                                                                                                                                                                                                  baker
                                                                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                    "Baking on the test chain [%d/%d]"
                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                    (Z.add
                                                                                                                                                                                                                                      ith
                                                                                                                                                                                                                                      1)
                                                                                                                                                                                                                                    testing_bakes)))
                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                with
                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                    state
                                                                                                                                                                                                                                    chain
                                                                                                                                                                                                                                    default_attempts
                                                                                                                                                                                                                                    8
                                                                                                                                                                                                                                    nodes
                                                                                                                                                                                                                                    variant)
                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                          state
                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                              tt
                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                  |
                                                                                                                                                                                                                    Expected_misunderstanding
                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                      state
                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                  |
                                                                                                                                                                                                                    Failure_to_understand
                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                    failf
                                                                                                                                                                                                                      "Winner-Client cannot bake on test chain!"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string
                                                                                                                                                                                                                  end))
                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                =>
                                                                                                                                                                                                                match
                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                  with
                                                                                                                                                                                                                |
                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                      state
                                                                                                                                                                                                                      default_attempts
                                                                                                                                                                                                                      0
                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                        match
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          with
                                                                                                                                                                                                                        |
                                                                                                                                                                                                                          _
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                              state
                                                                                                                                                                                                                              (client
                                                                                                                                                                                                                                1)
                                                                                                                                                                                                                              variant
                                                                                                                                                                                                                              "/chains/main/blocks/head/metadata"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string)
                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                              metadata_json
                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                              try)
                                                                                                                                                                                                                        end))
                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      match
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        with
                                                                                                                                                                                                                      |
                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                          (bake_until_voting_period
                                                                                                                                                                                                                            (Some
                                                                                                                                                                                                                              (key_name
                                                                                                                                                                                                                                special_baker))
                                                                                                                                                                                                                            state
                                                                                                                                                                                                                            baker_0
                                                                                                                                                                                                                            (Z.add
                                                                                                                                                                                                                              1
                                                                                                                                                                                                                              (blocks_per_voting_period
                                                                                                                                                                                                                                protocol))
                                                                                                                                                                                                                            variant)
                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                            extra_bakes_waiting_for_promotion_period
                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                              level_counter
                                                                                                                                                                                                                              "wait-for-promotion-period"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string
                                                                                                                                                                                                                              extra_bakes_waiting_for_promotion_period;
                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                state
                                                                                                                                                                                                                                default_attempts
                                                                                                                                                                                                                                8
                                                                                                                                                                                                                                nodes
                                                                                                                                                                                                                                variant)
                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                      state
                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                            state
                                                                                                                                                                                                                                            (client
                                                                                                                                                                                                                                              baker_0)
                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                              "submit"
                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                "ballot"
                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                  "for"
                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                    (key_name
                                                                                                                                                                                                                                                      baker_0)
                                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                                      winner_hash
                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                        "yay"
                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                        [])))))))
                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                              _
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                  with_ledger
                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                      _
                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                          state
                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                          true)
                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                            ledger_prompt_notice
                                                                                                                                                                                                                                                              state
                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                                    end))
                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                    _
                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                        state
                                                                                                                                                                                                                                                        (client
                                                                                                                                                                                                                                                          special_baker)
                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                          "submit"
                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                            "ballot"
                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                              "for"
                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                (key_name
                                                                                                                                                                                                                                                                  special_baker)
                                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                                  winner_hash
                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                    "yay"
                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                    [])))))))
                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                          _
                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                              state
                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                let
                                                                                                                                                                                                                                                                  ballot_bakes :=
                                                                                                                                                                                                                                                                  1
                                                                                                                                                                                                                                                                  in
                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                    ballot_bakes
                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                        _
                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                          state
                                                                                                                                                                                                                                                                          baker_0
                                                                                                                                                                                                                                                                          "Baking the promotion vote ballots"
                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                      end))
                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                        level_counter
                                                                                                                                                                                                                                                                        "bake-the-ballots"
                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                        ballot_bakes;
                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                          state
                                                                                                                                                                                                                                                                          (client
                                                                                                                                                                                                                                                                            0)
                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                            "list"
                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                              "understood"
                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                "protocols"
                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                []))))
                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                          client_protocols_result
                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                              state
                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                    state
                                                                                                                                                                                                                                                                                    0
                                                                                                                                                                                                                                                                                    (Z.add
                                                                                                                                                                                                                                                                                      1
                                                                                                                                                                                                                                                                                      (blocks_per_voting_period
                                                                                                                                                                                                                                                                                        protocol))
                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                      nth
                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                                        client :=
                                                                                                                                                                                                                                                                                        client
                                                                                                                                                                                                                                                                                          baker_0
                                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                          state
                                                                                                                                                                                                                                                                                          "curl http://localhost:%d/chains/main/blocks/head/metadata"
                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                          (port
                                                                                                                                                                                                                                                                                            client))
                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                          curl_res
                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                                            json_string :=
                                                                                                                                                                                                                                                                                            OCaml.Stdlib.reverse_apply
                                                                                                                                                                                                                                                                                              send
                                                                                                                                                                                                                                                                                              (Stdlib.String.concat
                                                                                                                                                                                                                                                                                                expected_argument
                                                                                                                                                                                                                                                                                                expected_argument
                                                                                                                                                                                                                                                                                                "
"
                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                  string)
                                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                                            json_metadata :=
                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                              json_string
                                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                              json_metadata
                                                                                                                                                                                                                                                                                              "next_protocol"
                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                            other
                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                              (transfer
                                                                                                                                                                                                                                                                                                state
                                                                                                                                                                                                                                                                                                client
                                                                                                                                                                                                                                                                                                (Tezos_client.Keyed.key_name
                                                                                                                                                                                                                                                                                                  baker_0)
                                                                                                                                                                                                                                                                                                (Tezos_client.Keyed.key_name
                                                                                                                                                                                                                                                                                                  special_baker)
                                                                                                                                                                                                                                                                                                1)
                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                  _
                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                        state
                                                                                                                                                                                                                                                                                                        baker_0)
                                                                                                                                                                                                                                                                                                      "Baker %s bakes %d/%d waiting for next protocol: %S"
                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                      (id
                                                                                                                                                                                                                                                                                                        client)
                                                                                                                                                                                                                                                                                                      nth
                                                                                                                                                                                                                                                                                                      attempts
                                                                                                                                                                                                                                                                                                      winner_hash)
                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                          variant
                                                                                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                                          end)))
                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                    extra_bakes_waiting_for_next_protocol
                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                      level_counter
                                                                                                                                                                                                                                                                                      "wait-for-next-protocol"
                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                      extra_bakes_waiting_for_next_protocol;
                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                        (check_understood_protocols
                                                                                                                                                                                                                                                                                          state
                                                                                                                                                                                                                                                                                          "main"
                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                          winner_client
                                                                                                                                                                                                                                                                                          winner_hash
                                                                                                                                                                                                                                                                                          clueless_winner)
                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                            Expected_misunderstanding
                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                              state
                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                            Failure_to_understand
                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                            failf
                                                                                                                                                                                                                                                                                              "The winner-client does not know about `%s`"
                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                              winner_hash
                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                            Proper_understanding
                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                state
                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                        state
                                                                                                                                                                                                                                                                                                        winner_client
                                                                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                                                                          "upgrade"
                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                            "baking"
                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                                                              "state"
                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                              []))))
                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                          inl
                                                                                                                                                                                                                                                                                                            _
                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                          inr
                                                                                                                                                                                                                                                                                                            _
                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                            state
                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                        end))
                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                            with_ledger
                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                _
                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                    state
                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                    true)
                                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                          state
                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                              4
                                                                                                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                                                                              end))
                                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                              _
                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                  state
                                                                                                                                                                                                                                                                                                                  winner_baker_0
                                                                                                                                                                                                                                                                                                                  "First bake on new protocol !!"
                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                    string)
                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                      level_counter
                                                                                                                                                                                                                                                                                                                      "baker-0-bakes-on-new-protocol"
                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                        string;
                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                        state
                                                                                                                                                                                                                                                                                                                        winner_special_baker
                                                                                                                                                                                                                                                                                                                        "Second bake on new protocol !!"
                                                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                                                          string)
                                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                            level_counter
                                                                                                                                                                                                                                                                                                                            "special-baker-bakes-on-new-protocol"
                                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                                              string;
                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                              state
                                                                                                                                                                                                                                                                                                                              winner_client
                                                                                                                                                                                                                                                                                                                              variant
                                                                                                                                                                                                                                                                                                                              "/chains/main/blocks/head/metadata"
                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                string)
                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                              json_metadata
                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                  json_metadata
                                                                                                                                                                                                                                                                                                                                  "protocol"
                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                                other
                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                failf
                                                                                                                                                                                                                                                                                                                                  "Protocol is not `%s` but `%s`"
                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                  winner_hash
                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                                          end))
                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                              state
                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                                                        end))
                                                                                                                                                                                                                                                                              end))
                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                end))
                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                end)
                                                                                                                                                                                                          end))
                                                                                                                                                                                                end)
                                                                                                                                                                                          end)
                                                                                                                                                                                    end)
                                                                                                                                                                              end)
                                                                                                                                                                        end)
                                                                                                                                                                  end))
                                                                                                                                                        end)
                                                                                                                                                  end)
                                                                                                                                            end)
                                                                                                                                      end)))))
                                                                                                                end))
                                                                                                      end)
                                                                                                end)
                                                                                          end)
                                                                                    end)
                                                                              end)
                                                                        end)
                                                                  end))
                                                        end))
                                              end)
                                        end)
                                  end)
                            end)
                      end
                    end)
              end)
        end)
  end.

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  match function_parameter with
  | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.
src/bin_sandbox/main.ml 
open Flextesa
open Internal_pervasives

module Small_utilities = struct
  let key_of_name_command () =
    let open Cmdliner in
    let open Term in
    ( ( pure (fun n ->
            let open Tezos_protocol.Account in
            let account = of_name n in
            Printf.printf
              "%s,%s,%s,%s\n%!"
              (name account)
              (pubkey account)
              (pubkey_hash account)
              (private_key account))
      $ Arg.(
          required
            (pos
               0
               (some string)
               None
               (info [] ~docv:"NAME" ~doc:"String to generate the data from.")))
      ),
      info
        "key-of-name"
        ~doc:"Make an unencrypted key-pair deterministically from a string."
        ~man:
          [ `P
              "`flextesa key-of-name hello-world` generates a key-pair of the \
               `unencrypted:..` kind and outputs it as a 4 values separated \
               by commas: `name,pub-key,pub-key-hash,private-uri` (hence \
               compatible with the `--add-bootstrap-account` option of some \
               of the test scenarios)." ] )

  let netstat_ports ~pp_error () =
    let open Cmdliner in
    let open Term in
    Test_command_line.Run_command.make
      ~pp_error
      ( pure (fun state ->
            ( state,
              fun () ->
                Test_scenario.Network.netstat_listening_ports state
                >>= fun ports ->
                let to_display =
                  List.map ports ~f:(fun (p, _) -> p)
                  |> List.sort ~compare:Int.compare
                in
                Console.sayf
                  state
                  Fmt.(
                    hvbox ~indent:2 (fun ppf () ->
                        box words ppf "Netstat listening ports:" ;
                        sp ppf () ;
                        box
                          (list
                             ~sep:(fun ppf () -> string ppf "," ; sp ppf ())
                             (fun ppf p -> fmt "%d" ppf p))
                          ppf
                          to_display)) ))
      $ Test_command_line.cli_state
          ~disable_interactivity:true
          ~name:"netstat-ports"
          () )
      (info
         "netstat-listening-ports"
         ~doc:"Like `netstat -nut | awk something-something` but glorified.")

  let all ~pp_error () = [key_of_name_command (); netstat_ports ~pp_error ()]
end

let () =
  let open Cmdliner in
  let help = Term.(ret (pure (`Help (`Auto, None))), info "help") in
  let pp_error fmt = function
    | `Scenario_error s ->
        Format.fprintf fmt "%s" s
    | #Test_scenario.Inconsistency_error.t as e ->
        Format.fprintf fmt "%a" Test_scenario.Inconsistency_error.pp e
    | #Process_result.Error.t as e ->
        Format.fprintf fmt "%a" Process_result.Error.pp e
    | #System_error.t as e ->
        Format.fprintf fmt "%a" System_error.pp e
    | `Client_command_error _ as e ->
        Tezos_client.Command_error.pp fmt e
    | `Admin_command_error _ as e ->
        Tezos_admin_client.Command_error.pp fmt e
    | `Waiting_for (msg, `Time_out) ->
        Format.fprintf fmt "WAITING-FOR “%s”: Time-out" msg
    | `Precheck_failure _ as p ->
        Helpers.System_dependencies.Error.pp fmt p
    | `Die _ ->
        ()
  in
  Term.exit
  @@ Term.eval_choice
       (help : unit Term.t * _)
       ( Small_utilities.all ~pp_error ()
       @ [ Command_daemons_protocol_change.cmd () ~pp_error;
           Command_voting.cmd () ~pp_error;
           Command_accusations.cmd () ~pp_error;
           Command_prevalidation.cmd () ~pp_error;
           Command_ledger_baking.cmd () ~pp_error;
           Command_ledger_wallet.cmd () ~pp_error;
           Flextesa.Interactive_mini_network.cmd ~pp_error () ] )
src/bin_sandbox/main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Small_utilities.
  Definition key_of_name_command {A : Type} (function_parameter : unit) : A :=
    match function_parameter with
    | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
    end.
  
  Definition netstat_ports {A B : Type}
    (pp_error : A) (function_parameter : unit) : B :=
    match function_parameter with
    | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
    end.
  
  Definition all {A B : Type} (pp_error : A) (function_parameter : unit)
    : list B :=
    match function_parameter with
    | tt => cons (key_of_name_command tt) (cons (netstat_ports pp_error tt) [])
    end.
End Small_utilities.
src/bin_signer/handler.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Signer_logging

let log = lwt_log_notice

module High_watermark = struct
  let encoding =
    let open Data_encoding in
    let raw_hash = conv Blake2B.to_bytes Blake2B.of_bytes_exn bytes in
    conv
      (List.map (fun (chain_id, marks) ->
           (Chain_id.to_b58check chain_id, marks)))
      (List.map (fun (chain_id, marks) ->
           (Chain_id.of_b58check_exn chain_id, marks)))
    @@ assoc
    @@ conv
         (List.map (fun (pkh, mark) ->
              (Signature.Public_key_hash.to_b58check pkh, mark)))
         (List.map (fun (pkh, mark) ->
              (Signature.Public_key_hash.of_b58check_exn pkh, mark)))
    @@ assoc
    @@ obj3
         (req "level" int32)
         (req "hash" raw_hash)
         (opt "signature" Signature.encoding)

  let mark_if_block_or_endorsement (cctxt : #Client_context.wallet) pkh bytes
      sign =
    let mark art name get_level =
      let file = name ^ "_high_watermark" in
      cctxt#with_lock
      @@ fun () ->
      cctxt#load file ~default:[] encoding
      >>=? fun all ->
      if Bytes.length bytes < 9 then
        failwith "byte sequence too short to be %s %s" art name
      else
        let hash = Blake2B.hash_bytes [bytes] in
        let chain_id = Chain_id.of_bytes_exn (Bytes.sub bytes 1 4) in
        let level = get_level () in
        ( match List.assoc_opt chain_id all with
        | None ->
            return_none
        | Some marks -> (
          match List.assoc_opt pkh marks with
          | None ->
              return_none
          | Some (previous_level, _, None) ->
              if previous_level >= level then
                failwith
                  "%s level %ld not above high watermark %ld"
                  name
                  level
                  previous_level
              else return_none
          | Some (previous_level, previous_hash, Some signature) ->
              if previous_level > level then
                failwith
                  "%s level %ld below high watermark %ld"
                  name
                  level
                  previous_level
              else if previous_level = level then
                if previous_hash <> hash then
                  failwith
                    "%s level %ld already signed with different data"
                    name
                    level
                else return_some signature
              else return_none ) )
        >>=? function
        | Some signature ->
            return signature
        | None ->
            sign bytes
            >>=? fun signature ->
            let rec update = function
              | [] ->
                  [(chain_id, [(pkh, (level, hash, Some signature))])]
              | (e_chain_id, marks) :: rest ->
                  if chain_id = e_chain_id then
                    let marks =
                      (pkh, (level, hash, Some signature))
                      :: List.filter (fun (pkh', _) -> pkh <> pkh') marks
                    in
                    (e_chain_id, marks) :: rest
                  else (e_chain_id, marks) :: update rest
            in
            cctxt#write file (update all) encoding
            >>=? fun () -> return signature
    in
    if Bytes.length bytes > 0 && TzEndian.get_uint8 bytes 0 = 0x01 then
      mark "a" "block" (fun () -> TzEndian.get_int32 bytes 5)
    else if Bytes.length bytes > 0 && TzEndian.get_uint8 bytes 0 = 0x02 then
      mark "an" "endorsement" (fun () ->
          TzEndian.get_int32 bytes (Bytes.length bytes - 4))
    else sign bytes
end

module Authorized_key = Client_aliases.Alias (struct
  include Signature.Public_key

  let name = "authorized_key"

  let to_source s = return (to_b58check s)

  let of_source t = Lwt.return (of_b58check t)
end)

let check_magic_byte magic_bytes data =
  match magic_bytes with
  | None ->
      return_unit
  | Some magic_bytes ->
      let byte = TzEndian.get_uint8 data 0 in
      if Bytes.length data > 1 && List.mem byte magic_bytes then return_unit
      else failwith "magic byte 0x%02X not allowed" byte

let check_authorization cctxt pkh data require_auth signature =
  match (require_auth, signature) with
  | (false, _) ->
      return_unit
  | (true, None) ->
      failwith "missing authentication signature field"
  | (true, Some signature) ->
      let to_sign = Signer_messages.Sign.Request.to_sign ~pkh ~data in
      Authorized_key.load cctxt
      >>=? fun keys ->
      if
        List.fold_left
          (fun acc (_, key) -> acc || Signature.check key signature to_sign)
          false
          keys
      then return_unit
      else failwith "invalid authentication signature"

let sign (cctxt : #Client_context.wallet)
    Signer_messages.Sign.Request.{pkh; data; signature} ?magic_bytes
    ~check_high_watermark ~require_auth =
  log
    Tag.DSL.(
      fun f ->
        f "Request for signing %d bytes of data for key %a, magic byte = %02X"
        -% t event "request_for_signing"
        -% s num_bytes (Bytes.length data)
        -% a Signature.Public_key_hash.Logging.tag pkh
        -% s magic_byte (TzEndian.get_uint8 data 0))
  >>= fun () ->
  check_magic_byte magic_bytes data
  >>=? fun () ->
  check_authorization cctxt pkh data require_auth signature
  >>=? fun () ->
  Client_keys.get_key cctxt pkh
  >>=? fun (name, _pkh, sk_uri) ->
  log
    Tag.DSL.(
      fun f ->
        f "Signing data for key %s"
        -% t event "signing_data"
        -% s Client_keys.Logging.tag name)
  >>= fun () ->
  let sign = Client_keys.sign cctxt sk_uri in
  if check_high_watermark then
    High_watermark.mark_if_block_or_endorsement cctxt pkh data sign
  else sign data

let deterministic_nonce (cctxt : #Client_context.wallet)
    Signer_messages.Deterministic_nonce.Request.{pkh; data; signature}
    ~require_auth =
  log
    Tag.DSL.(
      fun f ->
        f "Request for creating a nonce from %d input bytes for key %a"
        -% t event "request_for_deterministic_nonce"
        -% s num_bytes (Bytes.length data)
        -% a Signature.Public_key_hash.Logging.tag pkh)
  >>= fun () ->
  check_authorization cctxt pkh data require_auth signature
  >>=? fun () ->
  Client_keys.get_key cctxt pkh
  >>=? fun (name, _pkh, sk_uri) ->
  log
    Tag.DSL.(
      fun f ->
        f "Creating nonce for key %s"
        -% t event "creating_nonce"
        -% s Client_keys.Logging.tag name)
  >>= fun () -> Client_keys.deterministic_nonce sk_uri data

let deterministic_nonce_hash (cctxt : #Client_context.wallet)
    Signer_messages.Deterministic_nonce_hash.Request.{pkh; data; signature}
    ~require_auth =
  log
    Tag.DSL.(
      fun f ->
        f "Request for creating a nonce hash from %d input bytes for key %a"
        -% t event "request_for_deterministic_nonce_hash"
        -% s num_bytes (Bytes.length data)
        -% a Signature.Public_key_hash.Logging.tag pkh)
  >>= fun () ->
  check_authorization cctxt pkh data require_auth signature
  >>=? fun () ->
  Client_keys.get_key cctxt pkh
  >>=? fun (name, _pkh, sk_uri) ->
  log
    Tag.DSL.(
      fun f ->
        f "Creating nonce hash for key %s"
        -% t event "creating_nonce_hash"
        -% s Client_keys.Logging.tag name)
  >>= fun () -> Client_keys.deterministic_nonce_hash sk_uri data

let supports_deterministic_nonces (cctxt : #Client_context.wallet) pkh =
  log
    Tag.DSL.(
      fun f ->
        f
          "Request for checking whether the signer supports deterministic \
           nonces for key %a"
        -% t event "request_for_supports_deterministic_nonces"
        -% a Signature.Public_key_hash.Logging.tag pkh)
  >>= fun () ->
  Client_keys.get_key cctxt pkh
  >>=? fun (name, _pkh, sk_uri) ->
  log
    Tag.DSL.(
      fun f ->
        f
          "Returns true if and only if signer can generate determinstic \
           nonces for key %s"
        -% t event "supports_deterministic_nonces"
        -% s Client_keys.Logging.tag name)
  >>= fun () -> Client_keys.supports_deterministic_nonces sk_uri

let public_key (cctxt : #Client_context.wallet) pkh =
  log
    Tag.DSL.(
      fun f ->
        f "Request for public key %a"
        -% t event "request_for_public_key"
        -% a Signature.Public_key_hash.Logging.tag pkh)
  >>= fun () ->
  Client_keys.list_keys cctxt
  >>=? fun all_keys ->
  match
    List.find_opt
      (fun (_, h, _, _) -> Signature.Public_key_hash.equal h pkh)
      all_keys
  with
  | None ->
      log
        Tag.DSL.(
          fun f ->
            f "No public key found for hash %a"
            -% t event "not_found_public_key"
            -% a Signature.Public_key_hash.Logging.tag pkh)
      >>= fun () -> Lwt.fail Not_found
  | Some (_, _, None, _) ->
      log
        Tag.DSL.(
          fun f ->
            f "No public key found for hash %a"
            -% t event "not_found_public_key"
            -% a Signature.Public_key_hash.Logging.tag pkh)
      >>= fun () -> Lwt.fail Not_found
  | Some (name, _, Some pk, _) ->
      log
        Tag.DSL.(
          fun f ->
            f "Found public key for hash %a (name: %s)"
            -% t event "found_public_key"
            -% a Signature.Public_key_hash.Logging.tag pkh
            -% s Client_keys.Logging.tag name)
      >>= fun () -> return pk
src/bin_signer/handler.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Signer_logging.

Definition log {A : Type}
  : Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
  Signer_logging.lwt_log_notice.

Module High_watermark.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (list
        (Tezos_base__TzPervasives.Chain_id.t *
          (list
            (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
              (int32 * Tezos_base__TzPervasives.Blake2B.t *
                (option Tezos_base__TzPervasives.Signature.t)))))) :=
    let raw_hash :=
      Tezos_base__TzPervasives.Data_encoding.conv
        Tezos_base__TzPervasives.Blake2B.to_bytes
        Tezos_base__TzPervasives.Blake2B.of_bytes_exn None
        Tezos_base__TzPervasives.Data_encoding.bytes in
    apply
      (let arg :=
        Tezos_base__TzPervasives.Data_encoding.conv
          (Tezos_base__TzPervasives.List.map
            (fun function_parameter =>
              match function_parameter with
              | (chain_id, marks) =>
                ((Tezos_base__TzPervasives.Chain_id.to_b58check chain_id), marks)
              end))
          (Tezos_base__TzPervasives.List.map
            (fun function_parameter =>
              match function_parameter with
              | (chain_id, marks) =>
                ((Tezos_base__TzPervasives.Chain_id.of_b58check_exn chain_id),
                  marks)
              end)) in
      fun eta => arg None eta)
      (apply Tezos_base__TzPervasives.Data_encoding.assoc
        (apply
          (let arg :=
            Tezos_base__TzPervasives.Data_encoding.conv
              (Tezos_base__TzPervasives.List.map
                (fun function_parameter =>
                  match function_parameter with
                  | (pkh, mark) =>
                    ((Tezos_base__TzPervasives.Signature.Public_key_hash.to_b58check
                      pkh), mark)
                  end))
              (Tezos_base__TzPervasives.List.map
                (fun function_parameter =>
                  match function_parameter with
                  | (pkh, mark) =>
                    ((Tezos_base__TzPervasives.Signature.Public_key_hash.of_b58check_exn
                      pkh), mark)
                  end)) in
          fun eta => arg None eta)
          (apply Tezos_base__TzPervasives.Data_encoding.assoc
            (Tezos_base__TzPervasives.Data_encoding.obj3
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "level" % string Tezos_base__TzPervasives.Data_encoding.int32)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "hash" % string raw_hash)
              (Tezos_base__TzPervasives.Data_encoding.opt None None
                "signature" % string Tezos_base__TzPervasives.Signature.encoding))))).
  
  Definition mark_if_block_or_endorsement {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    (bytes : Stdlib.Bytes.t)
    (sign :
      Stdlib.Bytes.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_base__TzPervasives.Signature.t))
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
    let mark (art : string) (name : string) (get_level : unit -> int32)
      : Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
      let file := String.append name "_high_watermark" % string in
      apply send
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (send file [] encoding)
              (fun all =>
                if OCaml.Stdlib.lt (String.length string) 9 then
                  Tezos_base__TzPervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "byte sequence too short to be " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal " " % char
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))))
                      "byte sequence too short to be %s %s" % string) art name
                else
                  let hash :=
                    Tezos_base__TzPervasives.Blake2B.hash_bytes None
                      (cons string []) in
                  let chain_id :=
                    Tezos_base__TzPervasives.Chain_id.of_bytes_exn
                      (String.sub string 1 4) in
                  let level := get_level tt in
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    match Tezos_base__TzPervasives.List.assoc_opt chain_id all
                      with
                    | None => Tezos_base__TzPervasives.return_none
                    | Some marks =>
                      match Tezos_base__TzPervasives.List.assoc_opt pkh marks
                        with
                      | None => Tezos_base__TzPervasives.return_none
                      | Some (previous_level, _, None) =>
                        if OCaml.Stdlib.ge previous_level level then
                          Tezos_base__TzPervasives.failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " level " % string
                                  (CamlinternalFormatBasics.Int32
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.String_literal
                                      " not above high watermark " % string
                                      (CamlinternalFormatBasics.Int32
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        CamlinternalFormatBasics.End_of_format)))))
                              "%s level %ld not above high watermark %ld" %
                                string) name level previous_level
                        else
                          Tezos_base__TzPervasives.return_none
                      | Some (previous_level, previous_hash, Some signature) =>
                        if OCaml.Stdlib.gt previous_level level then
                          Tezos_base__TzPervasives.failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " level " % string
                                  (CamlinternalFormatBasics.Int32
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.String_literal
                                      " below high watermark " % string
                                      (CamlinternalFormatBasics.Int32
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        CamlinternalFormatBasics.End_of_format)))))
                              "%s level %ld below high watermark %ld" % string)
                            name level previous_level
                        else
                          if equiv_decb previous_level level then
                            if nequiv_decb previous_hash hash then
                              Tezos_base__TzPervasives.failwith
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String_literal
                                      " level " % string
                                      (CamlinternalFormatBasics.Int32
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.String_literal
                                          " already signed with different data"
                                            % string
                                          CamlinternalFormatBasics.End_of_format))))
                                  "%s level %ld already signed with different data"
                                    % string) name level
                            else
                              Tezos_base__TzPervasives.return_some signature
                          else
                            Tezos_base__TzPervasives.return_none
                      end
                    end
                    (fun function_parameter =>
                      match function_parameter with
                      | Some signature =>
                        Tezos_base__TzPervasives._return signature
                      | None =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (sign string)
                          (fun signature =>
                            let fix update
                              (function_parameter :
                              list
                                (Tezos_base__TzPervasives.Chain_id.t *
                                  (list
                                    (Tezos_base__TzPervasives.Signature.Public_key_hash.t
                                      *
                                      (int32 *
                                        Tezos_base__TzPervasives.Blake2B.t *
                                        (option
                                          Tezos_base__TzPervasives.Signature.t))))))
                              : list
                                (Tezos_base__TzPervasives.Chain_id.t *
                                  (list
                                    (Tezos_base__TzPervasives.Signature.Public_key_hash.t
                                      *
                                      (int32 *
                                        Tezos_base__TzPervasives.Blake2B.t *
                                        (option
                                          Tezos_base__TzPervasives.Signature.t))))) :=
                              match function_parameter with
                              | [] =>
                                cons
                                  (chain_id,
                                    (cons (pkh, (level, hash, (Some signature)))
                                      [])) []
                              | cons (e_chain_id, marks) rest =>
                                if equiv_decb chain_id e_chain_id then
                                  let marks :=
                                    cons (pkh, (level, hash, (Some signature)))
                                      (Tezos_base__TzPervasives.List.filter
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (pkh', _) => nequiv_decb pkh pkh'
                                          end) marks) in
                                  cons (e_chain_id, marks) rest
                                else
                                  cons (e_chain_id, marks) (update rest)
                              end in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (send file (update all) encoding)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives._return signature
                                end))
                      end))
          end) in
    if
      andb (OCaml.Stdlib.gt (String.length string) 0)
        (equiv_decb (Tezos_stdlib.TzEndian.get_uint8 string 0) 1) then
      mark "a" % string "block" % string
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_stdlib.TzEndian.get_int32 string 5
          end)
    else
      if
        andb (OCaml.Stdlib.gt (String.length string) 0)
          (equiv_decb (Tezos_stdlib.TzEndian.get_uint8 string 0) 2) then
        mark "an" % string "endorsement" % string
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_stdlib.TzEndian.get_int32 string
                (Z.sub (String.length string) 4)
            end)
      else
        sign string.
End High_watermark.

Definition check_magic_byte (magic_bytes : option (list Z)) (data : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match magic_bytes with
  | None => Tezos_base__TzPervasives.return_unit
  | Some magic_bytes =>
    let byte := Tezos_stdlib.TzEndian.get_uint8 data 0 in
    if
      andb (OCaml.Stdlib.gt (String.length data) 1)
        (Tezos_base__TzPervasives.List.mem byte magic_bytes) then
      Tezos_base__TzPervasives.return_unit
    else
      Tezos_base__TzPervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "magic byte 0x" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_X
              (CamlinternalFormatBasics.Lit_padding
                CamlinternalFormatBasics.Zeros 2)
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " not allowed" % string
                CamlinternalFormatBasics.End_of_format)))
          "magic byte 0x%02X not allowed" % string) byte
  end.

Definition check_authorization {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (data : Stdlib.Bytes.t) (require_auth : bool)
  (signature : option Tezos_base__TzPervasives.Signature.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match (require_auth, signature) with
  | (false, _) => Tezos_base__TzPervasives.return_unit
  | (true, None) =>
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "missing authentication signature field" % string
          CamlinternalFormatBasics.End_of_format)
        "missing authentication signature field" % string)
  | (true, Some signature) =>
    let to_sign :=
      Tezos_signer_services.Signer_messages.Sign.Request.to_sign pkh data in
    Tezos_base__TzPervasives.op_gt_gt_eq_question (Authorized_key.load cctxt)
      (fun keys =>
        if
          Tezos_base__TzPervasives.List.fold_left
            (fun acc =>
              fun function_parameter =>
                match function_parameter with
                | (_, key) =>
                  orb acc
                    (Tezos_base__TzPervasives.Signature.check None key signature
                      to_sign)
                end) false keys then
          Tezos_base__TzPervasives.return_unit
        else
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "invalid authentication signature" % string
                CamlinternalFormatBasics.End_of_format)
              "invalid authentication signature" % string))
  end.

Definition sign {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  (function_parameter : Tezos_signer_services.Signer_messages.Sign.Request.t)
  : (option (list Z)) ->
    bool ->
      bool ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_base__TzPervasives.Signature.t) :=
  match function_parameter with
  | {| pkh := pkh; data := data; signature := signature |} =>
    fun magic_bytes =>
      fun check_high_watermark =>
        fun require_auth =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (log
              (fun f =>
                Signer_logging.Tag.DSL.op_minus_percent
                  (Signer_logging.Tag.DSL.op_minus_percent
                    (Signer_logging.Tag.DSL.op_minus_percent
                      (Signer_logging.Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Request for signing " % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.String_literal
                                  " bytes of data for key " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      ", magic byte = " % string
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_X
                                        (CamlinternalFormatBasics.Lit_padding
                                          CamlinternalFormatBasics.Zeros 2)
                                        CamlinternalFormatBasics.No_precision
                                        CamlinternalFormatBasics.End_of_format))))))
                            "Request for signing %d bytes of data for key %a, magic byte = %02X"
                              % string))
                        (Signer_logging.Tag.DSL.t Signer_logging.event
                          "request_for_signing" % string))
                      (Signer_logging.Tag.DSL.s Signer_logging.num_bytes
                        (String.length data)))
                    (Signer_logging.Tag.DSL.a
                      Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                      pkh))
                  (Signer_logging.Tag.DSL.s Signer_logging.magic_byte
                    (Tezos_stdlib.TzEndian.get_uint8 data 0))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (check_magic_byte magic_bytes data)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (check_authorization cctxt pkh data require_auth
                          signature)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_client_base.Client_keys.get_key cctxt pkh)
                              (fun function_parameter =>
                                match function_parameter with
                                | (name, _pkh, sk_uri) =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (log
                                      (fun f =>
                                        Signer_logging.Tag.DSL.op_minus_percent
                                          (Signer_logging.Tag.DSL.op_minus_percent
                                            (f
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Signing data for key " %
                                                    string
                                                  (CamlinternalFormatBasics.String
                                                    CamlinternalFormatBasics.No_padding
                                                    CamlinternalFormatBasics.End_of_format))
                                                "Signing data for key %s" %
                                                  string))
                                            (Signer_logging.Tag.DSL.t
                                              Signer_logging.event
                                              "signing_data" % string))
                                          (Signer_logging.Tag.DSL.s
                                            Tezos_client_base.Client_keys.Logging.tag
                                            name)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        let sign :=
                                          Tezos_client_base.Client_keys.sign
                                            cctxt None sk_uri in
                                        if check_high_watermark then
                                          High_watermark.mark_if_block_or_endorsement
                                            cctxt pkh data sign
                                        else
                                          sign data
                                      end)
                                end)
                          end)
                    end)
              end)
  end.

Definition deterministic_nonce {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  (function_parameter :
    Tezos_signer_services.Signer_messages.Deterministic_nonce.Request.t)
  : bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
  match function_parameter with
  | {| pkh := pkh; data := data; signature := signature |} =>
    fun require_auth =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (log
          (fun f =>
            Signer_logging.Tag.DSL.op_minus_percent
              (Signer_logging.Tag.DSL.op_minus_percent
                (Signer_logging.Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Request for creating a nonce from " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.String_literal
                            " input bytes for key " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))))
                      "Request for creating a nonce from %d input bytes for key %a"
                        % string))
                  (Signer_logging.Tag.DSL.t Signer_logging.event
                    "request_for_deterministic_nonce" % string))
                (Signer_logging.Tag.DSL.s Signer_logging.num_bytes
                  (String.length data)))
              (Signer_logging.Tag.DSL.a
                Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                pkh)))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (check_authorization cctxt pkh data require_auth signature)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_client_base.Client_keys.get_key cctxt pkh)
                    (fun function_parameter =>
                      match function_parameter with
                      | (name, _pkh, sk_uri) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (log
                            (fun f =>
                              Signer_logging.Tag.DSL.op_minus_percent
                                (Signer_logging.Tag.DSL.op_minus_percent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Creating nonce for key " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))
                                      "Creating nonce for key %s" % string))
                                  (Signer_logging.Tag.DSL.t Signer_logging.event
                                    "creating_nonce" % string))
                                (Signer_logging.Tag.DSL.s
                                  Tezos_client_base.Client_keys.Logging.tag name)))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_client_base.Client_keys.deterministic_nonce
                                sk_uri data
                            end)
                      end)
                end)
          end)
  end.

Definition deterministic_nonce_hash {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  (function_parameter :
    Tezos_signer_services.Signer_messages.Deterministic_nonce_hash.Request.t)
  : bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  match function_parameter with
  | {| pkh := pkh; data := data; signature := signature |} =>
    fun require_auth =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (log
          (fun f =>
            Signer_logging.Tag.DSL.op_minus_percent
              (Signer_logging.Tag.DSL.op_minus_percent
                (Signer_logging.Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Request for creating a nonce hash from " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.String_literal
                            " input bytes for key " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))))
                      "Request for creating a nonce hash from %d input bytes for key %a"
                        % string))
                  (Signer_logging.Tag.DSL.t Signer_logging.event
                    "request_for_deterministic_nonce_hash" % string))
                (Signer_logging.Tag.DSL.s Signer_logging.num_bytes
                  (String.length data)))
              (Signer_logging.Tag.DSL.a
                Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                pkh)))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (check_authorization cctxt pkh data require_auth signature)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_client_base.Client_keys.get_key cctxt pkh)
                    (fun function_parameter =>
                      match function_parameter with
                      | (name, _pkh, sk_uri) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (log
                            (fun f =>
                              Signer_logging.Tag.DSL.op_minus_percent
                                (Signer_logging.Tag.DSL.op_minus_percent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Creating nonce hash for key " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))
                                      "Creating nonce hash for key %s" % string))
                                  (Signer_logging.Tag.DSL.t Signer_logging.event
                                    "creating_nonce_hash" % string))
                                (Signer_logging.Tag.DSL.s
                                  Tezos_client_base.Client_keys.Logging.tag name)))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_client_base.Client_keys.deterministic_nonce_hash
                                sk_uri data
                            end)
                      end)
                end)
          end)
  end.

Definition supports_deterministic_nonces {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Tezos_crypto__Signature.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (log
      (fun f =>
        Signer_logging.Tag.DSL.op_minus_percent
          (Signer_logging.Tag.DSL.op_minus_percent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Request for checking whether the signer supports deterministic nonces for key "
                    % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "Request for checking whether the signer supports deterministic nonces for key %a"
                  % string))
            (Signer_logging.Tag.DSL.t Signer_logging.event
              "request_for_supports_deterministic_nonces" % string))
          (Signer_logging.Tag.DSL.a
            Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag pkh)))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_client_base.Client_keys.get_key cctxt pkh)
          (fun function_parameter =>
            match function_parameter with
            | (name, _pkh, sk_uri) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (log
                  (fun f =>
                    Signer_logging.Tag.DSL.op_minus_percent
                      (Signer_logging.Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Returns true if and only if signer can generate determinstic nonces for key "
                                % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.End_of_format))
                            "Returns true if and only if signer can generate determinstic nonces for key %s"
                              % string))
                        (Signer_logging.Tag.DSL.t Signer_logging.event
                          "supports_deterministic_nonces" % string))
                      (Signer_logging.Tag.DSL.s
                        Tezos_client_base.Client_keys.Logging.tag name)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_client_base.Client_keys.supports_deterministic_nonces
                      sk_uri
                  end)
            end)
      end).

Definition public_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Tezos_crypto__Signature.Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.public_key) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (log
      (fun f =>
        Signer_logging.Tag.DSL.op_minus_percent
          (Signer_logging.Tag.DSL.op_minus_percent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Request for public key " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "Request for public key %a" % string))
            (Signer_logging.Tag.DSL.t Signer_logging.event
              "request_for_public_key" % string))
          (Signer_logging.Tag.DSL.a
            Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag pkh)))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_client_base.Client_keys.list_keys cctxt)
          (fun all_keys =>
            match
              Tezos_base__TzPervasives.List.find_opt
                (fun function_parameter =>
                  match function_parameter with
                  | (_, h, _, _) =>
                    Tezos_base__TzPervasives.Signature.Public_key_hash.equal h
                      pkh
                  end) all_keys with
            | None =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (log
                  (fun f =>
                    Signer_logging.Tag.DSL.op_minus_percent
                      (Signer_logging.Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "No public key found for hash " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))
                            "No public key found for hash %a" % string))
                        (Signer_logging.Tag.DSL.t Signer_logging.event
                          "not_found_public_key" % string))
                      (Signer_logging.Tag.DSL.a
                        Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                        pkh)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Lwt.fail OCaml.Not_found
                  end)
            | Some (_, _, None, _) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (log
                  (fun f =>
                    Signer_logging.Tag.DSL.op_minus_percent
                      (Signer_logging.Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "No public key found for hash " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))
                            "No public key found for hash %a" % string))
                        (Signer_logging.Tag.DSL.t Signer_logging.event
                          "not_found_public_key" % string))
                      (Signer_logging.Tag.DSL.a
                        Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                        pkh)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Lwt.fail OCaml.Not_found
                  end)
            | Some (name, _, Some pk, _) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (log
                  (fun f =>
                    Signer_logging.Tag.DSL.op_minus_percent
                      (Signer_logging.Tag.DSL.op_minus_percent
                        (Signer_logging.Tag.DSL.op_minus_percent
                          (f
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Found public key for hash " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " (name: " % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Char_literal
                                        ")" % char
                                        CamlinternalFormatBasics.End_of_format)))))
                              "Found public key for hash %a (name: %s)" % string))
                          (Signer_logging.Tag.DSL.t Signer_logging.event
                            "found_public_key" % string))
                        (Signer_logging.Tag.DSL.a
                          Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                          pkh))
                      (Signer_logging.Tag.DSL.s
                        Tezos_client_base.Client_keys.Logging.tag name)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives._return pk
                  end)
            end)
      end).
src/bin_signer/handler.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Storage for keys that have been authorized for baking. *)
module Authorized_key :
  Client_aliases.Alias with type t := Signature.public_key

(** [public_key cctxt pkh] returns the public key whose hash is [pkh]
    iff it is present if [cctxt]. *)
val public_key :
  #Client_context.wallet ->
  Signature.public_key_hash ->
  Signature.public_key tzresult Lwt.t

(** [sign cctxt req ?magic_bytes ~check_high_watermark ~require_auth]
    signs [req] and returns a signature. *)
val sign :
  #Client_context.wallet ->
  Signer_messages.Sign.Request.t ->
  ?magic_bytes:int list ->
  check_high_watermark:bool ->
  require_auth:bool ->
  Signature.t tzresult Lwt.t

(** [deterministic_nonce cctxt req ~require_auth] generates
    deterministically a nonce from [req.data]. *)
val deterministic_nonce :
  #Client_context.wallet ->
  Signer_messages.Deterministic_nonce.Request.t ->
  require_auth:bool ->
  Bigstring.t tzresult Lwt.t

(** [deterministic_nonce_hash cctxt req ~require_auth] generates
    deterministically a nonce from [req.data] and returns the hash of
    this nonce. *)
val deterministic_nonce_hash :
  #Client_context.wallet ->
  Signer_messages.Deterministic_nonce_hash.Request.t ->
  require_auth:bool ->
  Bytes.t tzresult Lwt.t

(** [supports_deterministic_nonces cctxt pkh] determines whether the signer
    provides the deterministic nonce functionality. *)
val supports_deterministic_nonces :
  #Client_context.wallet -> Signature.public_key_hash -> bool tzresult Lwt.t
src/bin_signer/handler.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

Parameter public_key : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Tezos_base__TzPervasives.Signature.public_key_hash ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_base__TzPervasives.Signature.public_key).

Parameter sign : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Tezos_signer_services.Signer_messages.Sign.Request.t ->
    (option (list Z)) ->
      bool ->
        bool ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_base__TzPervasives.Signature.t).

Parameter deterministic_nonce : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Tezos_signer_services.Signer_messages.Deterministic_nonce.Request.t ->
    bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t).

Parameter deterministic_nonce_hash : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Tezos_signer_services.Signer_messages.Deterministic_nonce_hash.Request.t ->
    bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t).

Parameter supports_deterministic_nonces : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Tezos_base__TzPervasives.Signature.public_key_hash ->
    Lwt.t (Tezos_base__TzPervasives.tzresult bool).
src/bin_signer/http_daemon.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let log = Signer_logging.lwt_log_notice

open Signer_logging

let run (cctxt : #Client_context.wallet) ~hosts ?magic_bytes
    ~check_high_watermark ~require_auth mode =
  let dir = RPC_directory.empty in
  let dir =
    RPC_directory.register1 dir Signer_services.sign (fun pkh signature data ->
        Handler.sign
          cctxt
          {pkh; data; signature}
          ?magic_bytes
          ~check_high_watermark
          ~require_auth)
  in
  let dir =
    RPC_directory.register1 dir Signer_services.public_key (fun pkh () () ->
        Handler.public_key cctxt pkh)
  in
  let dir =
    RPC_directory.register0 dir Signer_services.authorized_keys (fun () () ->
        if require_auth then
          Handler.Authorized_key.load cctxt
          >>=? fun keys ->
          return_some
            (keys |> List.split |> snd |> List.map Signature.Public_key.hash)
        else return_none)
  in
  Lwt.catch
    (fun () ->
      List.map
        (fun host ->
          let host = Ipaddr.V6.to_string host in
          log
            Tag.DSL.(
              fun f ->
                f "Listening on address %s"
                -% t event "signer_listening" -% s host_name host)
          >>= fun () ->
          RPC_server.launch
            ~host
            mode
            dir
            ~media_types:Media_type.all_media_types
          >>= fun _server -> fst (Lwt.wait ()))
        hosts
      |> Lwt.choose)
    (function
      | Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
          failwith "Port already in use."
      | exn ->
          Lwt.return (error_exn exn))

let run_https (cctxt : #Client_context.wallet) ~host ~port ~cert ~key
    ?magic_bytes ~check_high_watermark ~require_auth =
  Lwt_utils_unix.getaddrinfo
    ~passive:true
    ~node:host
    ~service:(string_of_int port)
  >>= function
  | [] ->
      failwith "Cannot resolve listening address: %S" host
  | points ->
      let hosts = fst (List.split points) in
      log
        Tag.DSL.(
          fun f ->
            f "Accepting HTTPS requests on port %d"
            -% t event "accepting_https_requests"
            -% s port_number port)
      >>= fun () ->
      let mode : Conduit_lwt_unix.server =
        `TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
      in
      run
        (cctxt : #Client_context.wallet)
        ~hosts
        ?magic_bytes
        ~check_high_watermark
        ~require_auth
        mode

let run_http (cctxt : #Client_context.wallet) ~host ~port ?magic_bytes
    ~check_high_watermark ~require_auth =
  Lwt_utils_unix.getaddrinfo
    ~passive:true
    ~node:host
    ~service:(string_of_int port)
  >>= function
  | [] ->
      failwith "Cannot resolve listening address: %S" host
  | points ->
      let hosts = fst (List.split points) in
      log
        Tag.DSL.(
          fun f ->
            f "Accepting HTTP requests on port %d"
            -% t event "accepting_http_requests"
            -% s port_number port)
      >>= fun () ->
      let mode : Conduit_lwt_unix.server = `TCP (`Port port) in
      run
        (cctxt : #Client_context.wallet)
        ~hosts
        ?magic_bytes
        ~check_high_watermark
        ~require_auth
        mode
src/bin_signer/http_daemon.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition log {A : Type}
  : Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
  Signer_logging.lwt_log_notice.

Import Signer_logging.

Definition run {B C a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (hosts : list Ipaddr.V6.t) (magic_bytes : option (list Z))
  (check_high_watermark : bool) (require_auth : bool)
  (mode : Conduit_lwt_unix.server)
  : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
  let dir := Tezos_base__TzPervasives.RPC_directory.empty in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register1 dir
      Tezos_signer_services.Signer_services.sign
      (fun pkh =>
        fun signature =>
          fun data =>
            Handler.sign cctxt
              {| pkh := pkh; data := data; signature := signature |} magic_bytes
              check_high_watermark require_auth) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register1 dir
      Tezos_signer_services.Signer_services.public_key
      (fun pkh =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt => Handler.public_key cctxt pkh
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register0 dir
      Tezos_signer_services.Signer_services.authorized_keys
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              if require_auth then
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Handler.Authorized_key.load cctxt)
                  (fun keys =>
                    Tezos_base__TzPervasives.return_some
                      (OCaml.Stdlib.reverse_apply
                        (OCaml.Stdlib.reverse_apply
                          (OCaml.Stdlib.reverse_apply keys
                            Tezos_base__TzPervasives.List.split) snd)
                        (Tezos_base__TzPervasives.List.map
                          Tezos_base__TzPervasives.Signature.Public_key.hash)))
              else
                Tezos_base__TzPervasives.return_none
            end
        end) in
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        OCaml.Stdlib.reverse_apply
          (Tezos_base__TzPervasives.List.map
            (fun host =>
              let host := Ipaddr.V6.to_string host in
              Tezos_base__TzPervasives.op_gt_gt_eq
                (log
                  (fun f =>
                    Signer_logging.Tag.DSL.op_minus_percent
                      (Signer_logging.Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Listening on address " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.End_of_format))
                            "Listening on address %s" % string))
                        (Signer_logging.Tag.DSL.t Signer_logging.event
                          "signer_listening" % string))
                      (Signer_logging.Tag.DSL.s Signer_logging.host_name host)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_rpc_http_server.RPC_server.launch (Some host) None
                        Tezos_rpc_http.Media_type.all_media_types mode dir)
                      (fun _server => fst (Lwt.wait tt))
                  end)) hosts) Lwt.choose
      end)
    (fun function_parameter =>
      match function_parameter with
      | Unix.Unix_error Unix.EADDRINUSE "bind" % string "" % string =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Port already in use." % string
              CamlinternalFormatBasics.End_of_format)
            "Port already in use." % string)
      | exn => Lwt._return (Tezos_base__TzPervasives.error_exn exn)
      end).

Definition run_https {B C a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (host : string) (port : Z) (cert : string) (key : string)
  (magic_bytes : option (list Z)) (check_high_watermark : bool)
  (require_auth : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_stdlib_unix.Lwt_utils_unix.getaddrinfo true host
      (OCaml.Stdlib.string_of_int port))
    (fun function_parameter =>
      match function_parameter with
      | [] =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Cannot resolve listening address: " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Cannot resolve listening address: %S" % string) host
      | points =>
        let hosts := fst (Tezos_base__TzPervasives.List.split points) in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (log
            (fun f =>
              Signer_logging.Tag.DSL.op_minus_percent
                (Signer_logging.Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Accepting HTTPS requests on port " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          CamlinternalFormatBasics.End_of_format))
                      "Accepting HTTPS requests on port %d" % string))
                  (Signer_logging.Tag.DSL.t Signer_logging.event
                    "accepting_https_requests" % string))
                (Signer_logging.Tag.DSL.s Signer_logging.port_number port)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let mode := variant in
              run cctxt hosts magic_bytes check_high_watermark require_auth mode
            end)
      end).

Definition run_http {B C a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (host : string) (port : Z) (magic_bytes : option (list Z))
  (check_high_watermark : bool) (require_auth : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_stdlib_unix.Lwt_utils_unix.getaddrinfo true host
      (OCaml.Stdlib.string_of_int port))
    (fun function_parameter =>
      match function_parameter with
      | [] =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Cannot resolve listening address: " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Cannot resolve listening address: %S" % string) host
      | points =>
        let hosts := fst (Tezos_base__TzPervasives.List.split points) in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (log
            (fun f =>
              Signer_logging.Tag.DSL.op_minus_percent
                (Signer_logging.Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Accepting HTTP requests on port " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          CamlinternalFormatBasics.End_of_format))
                      "Accepting HTTP requests on port %d" % string))
                  (Signer_logging.Tag.DSL.t Signer_logging.event
                    "accepting_http_requests" % string))
                (Signer_logging.Tag.DSL.s Signer_logging.port_number port)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let mode := variant in
              run cctxt hosts magic_bytes check_high_watermark require_auth mode
            end)
      end).
src/bin_signer/http_daemon.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val run_https :
  #Client_context.io_wallet ->
  host:string ->
  port:int ->
  cert:string ->
  key:string ->
  ?magic_bytes:int list ->
  check_high_watermark:bool ->
  require_auth:bool ->
  'a tzresult Lwt.t

val run_http :
  #Client_context.io_wallet ->
  host:string ->
  port:int ->
  ?magic_bytes:int list ->
  check_high_watermark:bool ->
  require_auth:bool ->
  'a tzresult Lwt.t
src/bin_signer/http_daemon.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter run_https : forall {_ a b : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
              *
              (((string ->
                (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
                *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  ((((Tezos_client_base.Client_context.lwt_format a
                    (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a
                      (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
                      (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) * _)))))))))))) * _) ->
  string ->
    Z ->
      string ->
        string ->
          (option (list Z)) ->
            bool -> bool -> Lwt.t (Tezos_base__TzPervasives.tzresult a).

Parameter run_http : forall {_ a b : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
              *
              (((string ->
                (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
                *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  ((((Tezos_client_base.Client_context.lwt_format a
                    (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a
                      (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
                      (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) * _)))))))))))) * _) ->
  string ->
    Z ->
      (option (list Z)) ->
        bool -> bool -> Lwt.t (Tezos_base__TzPervasives.tzresult a).
src/bin_signer/main_signer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "signer.main"
end)

let default_tcp_host =
  match Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" with
  | None ->
      "localhost"
  | Some host ->
      host

let default_tcp_port =
  match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" with
  | None ->
      "7732"
  | Some port ->
      port

let default_https_host =
  match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" with
  | None ->
      "localhost"
  | Some host ->
      host

let default_https_port =
  match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" with
  | None ->
      "443"
  | Some port ->
      port

let default_http_host =
  match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" with
  | None ->
      "localhost"
  | Some host ->
      host

let default_http_port =
  match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" with
  | None ->
      "6732"
  | Some port ->
      port

open Clic

let group =
  {Clic.name = "signer"; title = "Commands specific to the signing daemon"}

let magic_bytes_arg =
  Clic.arg
    ~doc:"values allowed for the magic bytes, defaults to any"
    ~short:'M'
    ~long:"magic-bytes"
    ~placeholder:"0xHH,0xHH,..."
    (Clic.parameter (fun _ s ->
         try
           return
             (List.map
                (fun s ->
                  let b = int_of_string s in
                  if b < 0 || b > 255 then raise Exit else b)
                (String.split ',' s))
         with _ ->
           failwith
             "Bad format for magic bytes, a series of numbers is expected, \
              separated by commas."))

let high_watermark_switch =
  Clic.switch
    ~doc:
      "high watermark restriction\n\
       Stores the highest level signed for blocks and endorsements for each \
       address, and forbids to sign a level that is inferior or equal \
       afterwards, except for the exact same input data."
    ~short:'W'
    ~long:"check-high-watermark"
    ()

let pidfile_arg =
  arg
    ~doc:"write process id in file"
    ~short:'P'
    ~long:"pidfile"
    ~placeholder:"filename"
    (parameter (fun _ s -> return s))

let may_setup_pidfile = function
  | None ->
      return_unit
  | Some pidfile ->
      trace (failure "Failed to create the pidfile: %s" pidfile)
      @@ Lwt_lock_file.create ~unlink_on_exit:true pidfile

let commands base_dir require_auth : Client_context.full command list =
  Tezos_signer_backends_unix.Ledger.commands ()
  @ Client_keys_commands.commands None
  @ [ command
        ~group
        ~desc:"Launch a signer daemon over a TCP socket."
        (args5
           pidfile_arg
           magic_bytes_arg
           high_watermark_switch
           (default_arg
              ~doc:"listening address or host name"
              ~short:'a'
              ~long:"address"
              ~placeholder:"host|address"
              ~default:default_tcp_host
              (parameter (fun _ s -> return s)))
           (default_arg
              ~doc:"listening TCP port or service name"
              ~short:'p'
              ~long:"port"
              ~placeholder:"port number"
              ~default:default_tcp_port
              (parameter (fun _ s -> return s))))
        (prefixes ["launch"; "socket"; "signer"] @@ stop)
        (fun (pidfile, magic_bytes, check_high_watermark, host, port) cctxt ->
          may_setup_pidfile pidfile
          >>=? fun () ->
          Tezos_signer_backends.Encrypted.decrypt_all cctxt
          >>=? fun () ->
          Socket_daemon.run
            cctxt
            (Tcp (host, port, [AI_SOCKTYPE SOCK_STREAM]))
            ?magic_bytes
            ~check_high_watermark
            ~require_auth
          >>=? fun _ -> return_unit);
      command
        ~group
        ~desc:"Launch a signer daemon over a local Unix socket."
        (args4
           pidfile_arg
           magic_bytes_arg
           high_watermark_switch
           (default_arg
              ~doc:"path to the local socket file"
              ~short:'s'
              ~long:"socket"
              ~placeholder:"path"
              ~default:(Filename.concat base_dir "socket")
              (parameter (fun _ s -> return s))))
        (prefixes ["launch"; "local"; "signer"] @@ stop)
        (fun (pidfile, magic_bytes, check_high_watermark, path) cctxt ->
          may_setup_pidfile pidfile
          >>=? fun () ->
          Tezos_signer_backends.Encrypted.decrypt_all cctxt
          >>=? fun () ->
          Socket_daemon.run
            cctxt
            (Unix path)
            ?magic_bytes
            ~check_high_watermark
            ~require_auth
          >>=? fun _ -> return_unit);
      command
        ~group
        ~desc:"Launch a signer daemon over HTTP."
        (args5
           pidfile_arg
           magic_bytes_arg
           high_watermark_switch
           (default_arg
              ~doc:"listening address or host name"
              ~short:'a'
              ~long:"address"
              ~placeholder:"host|address"
              ~default:default_http_host
              (parameter (fun _ s -> return s)))
           (default_arg
              ~doc:"listening HTTP port"
              ~short:'p'
              ~long:"port"
              ~placeholder:"port number"
              ~default:default_http_port
              (parameter (fun _ x ->
                   try return (int_of_string x)
                   with Failure _ -> failwith "Invalid port %s" x))))
        (prefixes ["launch"; "http"; "signer"] @@ stop)
        (fun (pidfile, magic_bytes, check_high_watermark, host, port) cctxt ->
          may_setup_pidfile pidfile
          >>=? fun () ->
          Tezos_signer_backends.Encrypted.decrypt_all cctxt
          >>=? fun () ->
          Http_daemon.run_http
            cctxt
            ~host
            ~port
            ?magic_bytes
            ~check_high_watermark
            ~require_auth);
      command
        ~group
        ~desc:"Launch a signer daemon over HTTPS."
        (args5
           pidfile_arg
           magic_bytes_arg
           high_watermark_switch
           (default_arg
              ~doc:"listening address or host name"
              ~short:'a'
              ~long:"address"
              ~placeholder:"host|address"
              ~default:default_https_host
              (parameter (fun _ s -> return s)))
           (default_arg
              ~doc:"listening HTTPS port"
              ~short:'p'
              ~long:"port"
              ~placeholder:"port number"
              ~default:default_https_port
              (parameter (fun _ x ->
                   try return (int_of_string x)
                   with Failure _ -> failwith "Invalid port %s" x))))
        ( prefixes ["launch"; "https"; "signer"]
        @@ param
             ~name:"cert"
             ~desc:"path to the TLS certificate"
             (parameter (fun _ s ->
                  if not (Sys.file_exists s) then
                    failwith "No such TLS certificate file %s" s
                  else return s))
        @@ param
             ~name:"key"
             ~desc:"path to the TLS key"
             (parameter (fun _ s ->
                  if not (Sys.file_exists s) then
                    failwith "No such TLS key file %s" s
                  else return s))
        @@ stop )
        (fun (pidfile, magic_bytes, check_high_watermark, host, port)
             cert
             key
             cctxt ->
          may_setup_pidfile pidfile
          >>=? fun () ->
          Tezos_signer_backends.Encrypted.decrypt_all cctxt
          >>=? fun () ->
          Http_daemon.run_https
            cctxt
            ~host
            ~port
            ~cert
            ~key
            ?magic_bytes
            ~check_high_watermark
            ~require_auth);
      command
        ~group
        ~desc:"Authorize a given public key to perform signing requests."
        (args1
           (arg
              ~doc:"an optional name for the key (defaults to the hash)"
              ~short:'N'
              ~long:"name"
              ~placeholder:"name"
              (parameter (fun _ s -> return s))))
        ( prefixes ["add"; "authorized"; "key"]
        @@ param
             ~name:"pk"
             ~desc:"full public key (Base58 encoded)"
             (parameter (fun _ s ->
                  Lwt.return (Signature.Public_key.of_b58check s)))
        @@ stop )
        (fun name key cctxt ->
          let pkh = Signature.Public_key.hash key in
          let name =
            match name with
            | Some name ->
                name
            | None ->
                Signature.Public_key_hash.to_b58check pkh
          in
          Handler.Authorized_key.add ~force:false cctxt name key) ]

let home = try Sys.getenv "HOME" with Not_found -> "/root"

let default_base_dir = Filename.concat home ".tezos-signer"

let string_parameter () : (string, _) parameter =
  parameter (fun _ x -> return x)

let base_dir_arg () =
  arg
    ~long:"base-dir"
    ~short:'d'
    ~placeholder:"path"
    ~doc:
      ( "signer data directory\n\
         The directory where the Tezos client will store all its data.\n\
         By default: '" ^ default_base_dir ^ "'." )
    (string_parameter ())

let require_auth_arg () =
  switch
    ~long:"require-authentication"
    ~short:'A'
    ~doc:"Require a signature from the caller to sign."
    ()

let password_filename_arg () =
  arg
    ~long:"password-file"
    ~short:'f'
    ~placeholder:"filename"
    ~doc:"Absolute path of the password file"
    (string_parameter ())

let global_options () =
  args3 (base_dir_arg ()) (require_auth_arg ()) (password_filename_arg ())

module C = struct
  type t = string option * bool * string option

  let global_options = global_options

  let parse_config_args ctx argv =
    Clic.parse_global_options (global_options ()) ctx argv
    >>=? fun ((base_dir, require_auth, password_filename), remaining) ->
    return
      ( {
          Client_config.default_parsed_config_args with
          base_dir;
          require_auth;
          password_filename;
        },
        remaining )

  let default_chain = Client_config.default_chain

  let default_block = Client_config.default_block

  let default_base_dir = default_base_dir

  let other_registrations = None

  let clic_commands ~base_dir ~config_commands:_ ~builtin_commands:_
      ~other_commands ~require_auth =
    commands base_dir require_auth @ other_commands

  let logger = Some (RPC_client_unix.full_logger Format.err_formatter)
end

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module C)
    ~select_commands:(fun _ _ -> return_nil)
src/bin_signer/main_signer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition default_tcp_host : string :=
  match Stdlib.Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" % string with
  | None => "localhost" % string
  | Some host => host
  end.

Definition default_tcp_port : string :=
  match Stdlib.Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" % string with
  | None => "7732" % string
  | Some port => port
  end.

Definition default_https_host : string :=
  match Stdlib.Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" % string with
  | None => "localhost" % string
  | Some host => host
  end.

Definition default_https_port : string :=
  match Stdlib.Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" % string with
  | None => "443" % string
  | Some port => port
  end.

Definition default_http_host : string :=
  match Stdlib.Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" % string with
  | None => "localhost" % string
  | Some host => host
  end.

Definition default_http_port : string :=
  match Stdlib.Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" % string with
  | None => "6732" % string
  | Some port => port
  end.

Import Tezos_base__TzPervasives.Clic.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "signer" % string;
    Clic.title := "Commands specific to the signing daemon" % string |}.

Definition magic_bytes_arg
  : Tezos_base__TzPervasives.Clic.arg (option (list Z))
    Tezos_client_base.Client_context.full :=
  Tezos_base__TzPervasives.Clic.arg
    "values allowed for the magic bytes, defaults to any" % string
    (Some "M" % char) "magic-bytes" % string "0xHH,0xHH,..." % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition high_watermark_switch
  : Tezos_base__TzPervasives.Clic.arg bool Tezos_client_base.Client_context.full :=
  Tezos_base__TzPervasives.Clic.switch
    "high watermark restriction
Stores the highest level signed for blocks and endorsements for each address, and forbids to sign a level that is inferior or equal afterwards, except for the exact same input data."
      % string (Some "W" % char) "check-high-watermark" % string tt.

Definition pidfile_arg
  : Tezos_base__TzPervasives.Clic.arg (option string)
    Tezos_client_base.Client_context.full :=
  Tezos_base__TzPervasives.Clic.arg "write process id in file" % string
    (Some "P" % char) "pidfile" % string "filename" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => Tezos_base__TzPervasives._return s
        end)).

Definition may_setup_pidfile (function_parameter : option string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | None => Tezos_base__TzPervasives.return_unit
  | Some pidfile =>
    apply
      (Tezos_base__TzPervasives.trace
        (Tezos_base__TzPervasives.failure
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Failed to create the pidfile: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Failed to create the pidfile: %s" % string) pidfile))
      (Tezos_stdlib_unix.Lwt_lock_file.create None (Some true) pidfile)
  end.

Definition commands (base_dir : string) (require_auth : bool)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  OCaml.Stdlib.app (Tezos_signer_backends_unix.Ledger.commands tt)
    (OCaml.Stdlib.app (Tezos_client_commands.Client_keys_commands.commands None)
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Launch a signer daemon over a TCP socket." % string
          (Tezos_base__TzPervasives.Clic.args5 pidfile_arg magic_bytes_arg
            high_watermark_switch
            (Tezos_base__TzPervasives.Clic.default_arg
              "listening address or host name" % string (Some "a" % char)
              "address" % string "host|address" % string default_tcp_host
              (Tezos_base__TzPervasives.Clic.parameter None
                (fun function_parameter =>
                  match function_parameter with
                  | _ => fun s => Tezos_base__TzPervasives._return s
                  end)))
            (Tezos_base__TzPervasives.Clic.default_arg
              "listening TCP port or service name" % string (Some "p" % char)
              "port" % string "port number" % string default_tcp_port
              (Tezos_base__TzPervasives.Clic.parameter None
                (fun function_parameter =>
                  match function_parameter with
                  | _ => fun s => Tezos_base__TzPervasives._return s
                  end))))
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "launch" % string
                (cons "socket" % string (cons "signer" % string []))))
            Tezos_base__TzPervasives.Clic.stop)
          (fun function_parameter =>
            match function_parameter with
            | (pidfile, magic_bytes, check_high_watermark, host, port) =>
              fun cctxt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (may_setup_pidfile pidfile)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_signer_backends.Encrypted.decrypt_all cctxt)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Socket_daemon.run cctxt
                                (Tcp host port
                                  (cons (AI_SOCKTYPE SOCK_STREAM) []))
                                magic_bytes check_high_watermark require_auth)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ => Tezos_base__TzPervasives.return_unit
                                end)
                          end)
                    end)
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Launch a signer daemon over a local Unix socket." % string
            (Tezos_base__TzPervasives.Clic.args4 pidfile_arg magic_bytes_arg
              high_watermark_switch
              (Tezos_base__TzPervasives.Clic.default_arg
                "path to the local socket file" % string (Some "s" % char)
                "socket" % string "path" % string
                (Stdlib.Filename.concat base_dir "socket" % string)
                (Tezos_base__TzPervasives.Clic.parameter None
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => fun s => Tezos_base__TzPervasives._return s
                    end))))
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "launch" % string
                  (cons "local" % string (cons "signer" % string []))))
              Tezos_base__TzPervasives.Clic.stop)
            (fun function_parameter =>
              match function_parameter with
              | (pidfile, magic_bytes, check_high_watermark, path) =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (may_setup_pidfile pidfile)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_signer_backends.Encrypted.decrypt_all cctxt)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Socket_daemon.run cctxt (Unix path) magic_bytes
                                  check_high_watermark require_auth)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | _ => Tezos_base__TzPervasives.return_unit
                                  end)
                            end)
                      end)
              end))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Launch a signer daemon over HTTP." % string
              (Tezos_base__TzPervasives.Clic.args5 pidfile_arg magic_bytes_arg
                high_watermark_switch
                (Tezos_base__TzPervasives.Clic.default_arg
                  "listening address or host name" % string (Some "a" % char)
                  "address" % string "host|address" % string default_http_host
                  (Tezos_base__TzPervasives.Clic.parameter None
                    (fun function_parameter =>
                      match function_parameter with
                      | _ => fun s => Tezos_base__TzPervasives._return s
                      end)))
                (Tezos_base__TzPervasives.Clic.default_arg
                  "listening HTTP port" % string (Some "p" % char)
                  "port" % string "port number" % string default_http_port
                  (Tezos_base__TzPervasives.Clic.parameter None
                    (fun function_parameter =>
                      match function_parameter with
                      | _ => fun x => try
                      end))))
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "launch" % string
                    (cons "http" % string (cons "signer" % string []))))
                Tezos_base__TzPervasives.Clic.stop)
              (fun function_parameter =>
                match function_parameter with
                | (pidfile, magic_bytes, check_high_watermark, host, port) =>
                  fun cctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (may_setup_pidfile pidfile)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_signer_backends.Encrypted.decrypt_all cctxt)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Http_daemon.run_http cctxt host port magic_bytes
                                  check_high_watermark require_auth
                              end)
                        end)
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Launch a signer daemon over HTTPS." % string
                (Tezos_base__TzPervasives.Clic.args5 pidfile_arg magic_bytes_arg
                  high_watermark_switch
                  (Tezos_base__TzPervasives.Clic.default_arg
                    "listening address or host name" % string (Some "a" % char)
                    "address" % string "host|address" % string
                    default_https_host
                    (Tezos_base__TzPervasives.Clic.parameter None
                      (fun function_parameter =>
                        match function_parameter with
                        | _ => fun s => Tezos_base__TzPervasives._return s
                        end)))
                  (Tezos_base__TzPervasives.Clic.default_arg
                    "listening HTTPS port" % string (Some "p" % char)
                    "port" % string "port number" % string default_https_port
                    (Tezos_base__TzPervasives.Clic.parameter None
                      (fun function_parameter =>
                        match function_parameter with
                        | _ => fun x => try
                        end))))
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "launch" % string
                      (cons "https" % string (cons "signer" % string []))))
                  (apply
                    (Tezos_base__TzPervasives.Clic.param "cert" % string
                      "path to the TLS certificate" % string
                      (Tezos_base__TzPervasives.Clic.parameter None
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            fun s =>
                              if negb (Stdlib.Sys.file_exists s) then
                                Tezos_base__TzPervasives.failwith
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "No such TLS certificate file " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))
                                    "No such TLS certificate file %s" % string)
                                  s
                              else
                                Tezos_base__TzPervasives._return s
                          end)))
                    (apply
                      (Tezos_base__TzPervasives.Clic.param "key" % string
                        "path to the TLS key" % string
                        (Tezos_base__TzPervasives.Clic.parameter None
                          (fun function_parameter =>
                            match function_parameter with
                            | _ =>
                              fun s =>
                                if negb (Stdlib.Sys.file_exists s) then
                                  Tezos_base__TzPervasives.failwith
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "No such TLS key file " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))
                                      "No such TLS key file %s" % string) s
                                else
                                  Tezos_base__TzPervasives._return s
                            end))) Tezos_base__TzPervasives.Clic.stop)))
                (fun function_parameter =>
                  match function_parameter with
                  | (pidfile, magic_bytes, check_high_watermark, host, port) =>
                    fun cert =>
                      fun key =>
                        fun cctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (may_setup_pidfile pidfile)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_signer_backends.Encrypted.decrypt_all
                                    cctxt)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Http_daemon.run_https cctxt host port cert
                                        key magic_bytes check_high_watermark
                                        require_auth
                                    end)
                              end)
                  end))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some group)
                  "Authorize a given public key to perform signing requests." %
                    string
                  (Tezos_base__TzPervasives.Clic.args1
                    (Tezos_base__TzPervasives.Clic.arg
                      "an optional name for the key (defaults to the hash)" %
                        string (Some "N" % char) "name" % string "name" % string
                      (Tezos_base__TzPervasives.Clic.parameter None
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => fun s => Tezos_base__TzPervasives._return s
                          end))))
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "add" % string
                        (cons "authorized" % string (cons "key" % string []))))
                    (apply
                      (Tezos_base__TzPervasives.Clic.param "pk" % string
                        "full public key (Base58 encoded)" % string
                        (Tezos_base__TzPervasives.Clic.parameter None
                          (fun function_parameter =>
                            match function_parameter with
                            | _ =>
                              fun s =>
                                Lwt._return
                                  (Tezos_base__TzPervasives.Signature.Public_key.of_b58check
                                    s)
                            end))) Tezos_base__TzPervasives.Clic.stop))
                  (fun name =>
                    fun key =>
                      fun cctxt =>
                        let pkh :=
                          Tezos_base__TzPervasives.Signature.Public_key.hash key
                          in
                        let name :=
                          match name with
                          | Some name => name
                          | None =>
                            Tezos_base__TzPervasives.Signature.Public_key_hash.to_b58check
                              pkh
                          end in
                        Handler.Authorized_key.add false cctxt name key)) [])))))).

Definition home : string := try.

Definition default_base_dir : string :=
  Stdlib.Filename.concat home ".tezos-signer" % string.

Definition string_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter string A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun x => Tezos_base__TzPervasives._return x
        end)
  end.

Definition base_dir_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg
      (String.append
        "signer data directory
The directory where the Tezos client will store all its data.
By default: '"
          % string (String.append default_base_dir "'." % string))
      (Some "d" % char) "base-dir" % string "path" % string
      (string_parameter tt)
  end.

Definition require_auth_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.switch
      "Require a signature from the caller to sign." % string (Some "A" % char)
      "require-authentication" % string tt
  end.

Definition password_filename_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg
      "Absolute path of the password file" % string (Some "f" % char)
      "password-file" % string "filename" % string (string_parameter tt)
  end.

Definition global_options {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.options
    ((option string) * bool * (option string)) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.args3 (base_dir_arg tt) (require_auth_arg tt)
      (password_filename_arg tt)
  end.

Module C.
  Definition t := (option string) * bool * (option string).
  
  Definition global_options {A : Type}
    : unit ->
      Tezos_base__TzPervasives.Clic.options
        ((option string) * bool * (option string)) A := global_options.
  
  Definition parse_config_args {A : Type} (ctx : A) (argv : list string)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_client_base_unix.Client_config.parsed_config_args * (list string))) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.Clic.parse_global_options (global_options tt)
        ctx argv)
      (fun function_parameter =>
        match function_parameter with
        | ((base_dir, require_auth, password_filename), remaining) =>
          Tezos_base__TzPervasives._return (record, remaining)
        end).
  
  Definition default_chain : variant :=
    Tezos_client_base_unix.Client_config.default_chain.
  
  Definition default_block : variant :=
    Tezos_client_base_unix.Client_config.default_block.
  
  Definition default_base_dir : string := default_base_dir.
  
  Definition other_registrations {A : Type} : option A := None.
  
  Definition clic_commands {A B : Type}
    (base_dir : string) (function_parameter : A)
    : B ->
      (list
        (Tezos_base__TzPervasives.Clic.command
          Tezos_client_base.Client_context.full)) ->
        bool ->
          list
            (Tezos_base__TzPervasives.Clic.command
              Tezos_client_base.Client_context.full) :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun other_commands =>
            fun require_auth =>
              OCaml.Stdlib.app (commands base_dir require_auth) other_commands
        end
    end.
  
  Definition logger
    : option Tezos_rpc_http_client_unix.RPC_client_unix.logger :=
    Some
      (Tezos_rpc_http_client_unix.RPC_client_unix.full_logger
        Stdlib.Format.err_formatter).
End C.
src/bin_signer/signer_logging.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "client.signer"
end)

let host_name = Tag.def ~doc:"Host name" "host" Format.pp_print_text

let service_name = Tag.def ~doc:"Service name" "service" Format.pp_print_text

let port_number = Tag.def ~doc:"Port number" "port" Format.pp_print_int

let magic_byte = Tag.def ~doc:"Magic byte" "magic_byte" Format.pp_print_int

let num_bytes = Tag.def ~doc:"Number of bytes" "num_bytes" Format.pp_print_int

let unix_socket_path =
  Tag.def ~doc:"UNIX socket file path" "unix_socket" Format.pp_print_text
src/bin_signer/signer_logging.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition host_name : Tag.def string :=
  Tag.def (Some "Host name" % string) "host" % string
    Stdlib.Format.pp_print_text.

Definition service_name : Tag.def string :=
  Tag.def (Some "Service name" % string) "service" % string
    Stdlib.Format.pp_print_text.

Definition port_number : Tag.def Z :=
  Tag.def (Some "Port number" % string) "port" % string
    Stdlib.Format.pp_print_int.

Definition magic_byte : Tag.def Z :=
  Tag.def (Some "Magic byte" % string) "magic_byte" % string
    Stdlib.Format.pp_print_int.

Definition num_bytes : Tag.def Z :=
  Tag.def (Some "Number of bytes" % string) "num_bytes" % string
    Stdlib.Format.pp_print_int.

Definition unix_socket_path : Tag.def string :=
  Tag.def (Some "UNIX socket file path" % string) "unix_socket" % string
    Stdlib.Format.pp_print_text.
src/bin_signer/signer_logging.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.SEMLOG

val host_name : string Tag.def

val service_name : string Tag.def

val port_number : int Tag.def

val magic_byte : int Tag.def

val num_bytes : int Tag.def

val unix_socket_path : string Tag.def
src/bin_signer/signer_logging.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter host_name : Tag.def string.

Parameter service_name : Tag.def string.

Parameter port_number : Tag.def Z.

Parameter magic_byte : Tag.def Z.

Parameter num_bytes : Tag.def Z.

Parameter unix_socket_path : Tag.def string.
src/bin_signer/socket_daemon.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Signer_logging
open Signer_messages

let log = lwt_log_notice

let handle_client ?magic_bytes ~check_high_watermark ~require_auth cctxt fd =
  Lwt_utils_unix.Socket.recv fd Request.encoding
  >>=? function
  | Sign req ->
      let encoding = result_encoding Sign.Response.encoding in
      Handler.sign cctxt req ?magic_bytes ~check_high_watermark ~require_auth
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Deterministic_nonce req ->
      let encoding = result_encoding Deterministic_nonce.Response.encoding in
      Handler.deterministic_nonce cctxt req ~require_auth
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Deterministic_nonce_hash req ->
      let encoding =
        result_encoding Deterministic_nonce_hash.Response.encoding
      in
      Handler.deterministic_nonce_hash cctxt req ~require_auth
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Supports_deterministic_nonces req ->
      let encoding =
        result_encoding Supports_deterministic_nonces.Response.encoding
      in
      Handler.supports_deterministic_nonces cctxt req
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Public_key pkh ->
      let encoding = result_encoding Public_key.Response.encoding in
      Handler.public_key cctxt pkh
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Authorized_keys ->
      let encoding = result_encoding Authorized_keys.Response.encoding in
      ( if require_auth then
        Handler.Authorized_key.load cctxt
        >>=? fun keys ->
        return
          (Authorized_keys.Response.Authorized_keys
             (keys |> List.split |> snd |> List.map Signature.Public_key.hash))
      else return Authorized_keys.Response.No_authentication )
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit

let run (cctxt : #Client_context.wallet) path ?magic_bytes
    ~check_high_watermark ~require_auth =
  let open Lwt_utils_unix.Socket in
  ( match path with
  | Tcp (host, service, _opts) ->
      log
        Tag.DSL.(
          fun f ->
            f "Accepting TCP requests on %s:%s"
            -% t event "accepting_tcp_requests"
            -% s host_name host -% s service_name service)
  | Unix path ->
      ListLabels.iter
        Sys.[sigint; sigterm]
        ~f:(fun signal ->
          Sys.set_signal
            signal
            (Signal_handle
               (fun _ ->
                 Format.printf "Removing the local socket file and quitting.@." ;
                 Unix.unlink path ;
                 exit 0))) ;
      log
        Tag.DSL.(
          fun f ->
            f "Accepting UNIX requests on %s"
            -% t event "accepting_unix_requests"
            -% s unix_socket_path path) )
  >>= fun () ->
  bind path
  >>=? fun fds ->
  let rec loop fd =
    Lwt_unix.accept fd
    >>= fun (cfd, _) ->
    Lwt.async (fun () ->
        protect
          ~on_error:(function
            | Exn End_of_file :: _ ->
                return_unit
            | errs ->
                Lwt.return_error errs)
          (fun () ->
            handle_client
              ?magic_bytes
              ~check_high_watermark
              ~require_auth
              cctxt
              cfd)) ;
    loop fd
  in
  Lwt_list.map_p loop fds >>= return
src/bin_signer/socket_daemon.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Signer_logging.

Import Tezos_signer_services.Signer_messages.

Definition log {A : Type}
  : Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
  Signer_logging.lwt_log_notice.

Definition handle_client {B a : Type}
  (magic_bytes : option (list Z)) (check_high_watermark : bool)
  (require_auth : bool)
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (fd : Lwt_unix.file_descr)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_stdlib_unix.Lwt_utils_unix.Socket.recv fd
      Tezos_signer_services.Signer_messages.Request.encoding)
    (fun function_parameter =>
      match function_parameter with
      | Sign req =>
        let encoding :=
          Tezos_base__TzPervasives.result_encoding
            Tezos_signer_services.Signer_messages.Sign.Response.encoding in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Handler.sign cctxt req magic_bytes check_high_watermark require_auth)
          (fun res =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_stdlib_unix.Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.close fd)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end))
      | Deterministic_nonce req =>
        let encoding :=
          Tezos_base__TzPervasives.result_encoding
            Tezos_signer_services.Signer_messages.Deterministic_nonce.Response.encoding
          in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Handler.deterministic_nonce cctxt req require_auth)
          (fun res =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_stdlib_unix.Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.close fd)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end))
      | Deterministic_nonce_hash req =>
        let encoding :=
          Tezos_base__TzPervasives.result_encoding
            Tezos_signer_services.Signer_messages.Deterministic_nonce_hash.Response.encoding
          in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Handler.deterministic_nonce_hash cctxt req require_auth)
          (fun res =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_stdlib_unix.Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.close fd)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end))
      | Supports_deterministic_nonces req =>
        let encoding :=
          Tezos_base__TzPervasives.result_encoding
            Tezos_signer_services.Signer_messages.Supports_deterministic_nonces.Response.encoding
          in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Handler.supports_deterministic_nonces cctxt req)
          (fun res =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_stdlib_unix.Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.close fd)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end))
      | Public_key pkh =>
        let encoding :=
          Tezos_base__TzPervasives.result_encoding
            Tezos_signer_services.Signer_messages.Public_key.Response.encoding
          in
        Tezos_base__TzPervasives.op_gt_gt_eq (Handler.public_key cctxt pkh)
          (fun res =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_stdlib_unix.Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.close fd)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end))
      | Authorized_keys =>
        let encoding :=
          Tezos_base__TzPervasives.result_encoding
            Tezos_signer_services.Signer_messages.Authorized_keys.Response.encoding
          in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (if require_auth then
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Handler.Authorized_key.load cctxt)
              (fun keys =>
                Tezos_base__TzPervasives._return
                  (Authorized_keys.Response.Authorized_keys
                    (OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply
                        (OCaml.Stdlib.reverse_apply keys
                          Tezos_base__TzPervasives.List.split) snd)
                      (Tezos_base__TzPervasives.List.map
                        Tezos_base__TzPervasives.Signature.Public_key.hash))))
          else
            Tezos_base__TzPervasives._return
              Authorized_keys.Response.No_authentication)
          (fun res =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_stdlib_unix.Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.close fd)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end))
      end).

Definition run {B C a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (path : Tezos_stdlib_unix.Lwt_utils_unix.Socket.addr)
  (magic_bytes : option (list Z)) (check_high_watermark : bool)
  (require_auth : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult (list C)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    match path with
    | Tcp host service _opts =>
      log
        (fun f =>
          Signer_logging.Tag.DSL.op_minus_percent
            (Signer_logging.Tag.DSL.op_minus_percent
              (Signer_logging.Tag.DSL.op_minus_percent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Accepting TCP requests on " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal ":" % char
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.End_of_format))))
                    "Accepting TCP requests on %s:%s" % string))
                (Signer_logging.Tag.DSL.t Signer_logging.event
                  "accepting_tcp_requests" % string))
              (Signer_logging.Tag.DSL.s Signer_logging.host_name host))
            (Signer_logging.Tag.DSL.s Signer_logging.service_name service))
    | Unix path =>
      Stdlib.ListLabels.iter
        (fun signal =>
          Stdlib.Sys.set_signal signal
            (Signal_handle
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Stdlib.Format.printf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Removing the local socket file and quitting." % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))
                      "Removing the local socket file and quitting.@." % string);
                  Unix.unlink path;
                  Stdlib.exit 0
                end))) (cons Stdlib.Sys.sigint (cons Stdlib.Sys.sigterm []));
      log
        (fun f =>
          Signer_logging.Tag.DSL.op_minus_percent
            (Signer_logging.Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Accepting UNIX requests on " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "Accepting UNIX requests on %s" % string))
              (Signer_logging.Tag.DSL.t Signer_logging.event
                "accepting_unix_requests" % string))
            (Signer_logging.Tag.DSL.s Signer_logging.unix_socket_path path))
    end
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_stdlib_unix.Lwt_utils_unix.Socket.bind None path)
          (fun fds =>
            let fix loop {D : Type} (fd : Lwt_unix.file_descr) : Lwt.t D :=
              Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.accept fd)
                (fun function_parameter =>
                  match function_parameter with
                  | (cfd, _) =>
                    Lwt.async
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.protect
                            (Some
                              (fun function_parameter =>
                                match function_parameter with
                                | cons (Exn OCaml.End_of_file) _ =>
                                  Tezos_base__TzPervasives.return_unit
                                | errs => Lwt.return_error errs
                                end)) None
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                handle_client magic_bytes check_high_watermark
                                  require_auth cctxt cfd
                              end)
                        end);
                    loop fd
                  end) in
            Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_list.map_p loop fds)
              Tezos_base__TzPervasives._return)
      end).
src/bin_signer/socket_daemon.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val run :
  #Client_context.io_wallet ->
  Lwt_utils_unix.Socket.addr ->
  ?magic_bytes:int list ->
  check_high_watermark:bool ->
  require_auth:bool ->
  'a list tzresult Lwt.t
src/bin_signer/socket_daemon.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter run : forall {_ a b : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
              *
              (((string ->
                (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
                *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  ((((Tezos_client_base.Client_context.lwt_format a
                    (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a
                      (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
                      (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) * _)))))))))))) * _) ->
  Tezos_stdlib_unix.Lwt_utils_unix.Socket.addr ->
    (option (list Z)) ->
      bool -> bool -> Lwt.t (Tezos_base__TzPervasives.tzresult (list a)).
src/bin_validation/main_validator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () = Pervasives.exit (Lwt_main.run @@ Validator.main ())
src/bin_validation/main_validator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/bin_validation/validator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

let load_protocol proto protocol_root =
  if Registered_protocol.mem proto then return_unit
  else
    let cmxs_file =
      protocol_root
      // Protocol_hash.to_short_b58check proto
      // Format.asprintf "protocol_%a" Protocol_hash.pp proto
    in
    try
      Dynlink.loadfile_private (cmxs_file ^ ".cmxs") ;
      return_unit
    with Dynlink.Error err ->
      Format.ksprintf
        (fun msg ->
          fail
            Block_validator_errors.(
              Validation_process_failed (Protocol_dynlink_failure msg)))
        "Cannot load file: %s. (Expected location: %s.)"
        (Dynlink.error_message err)
        cmxs_file

let inconsistent_handshake msg =
  Block_validator_errors.(
    Validation_process_failed (Inconsistent_handshake msg))

let run stdin stdout =
  External_validation.recv stdin Data_encoding.Variable.bytes
  >>= fun magic ->
  fail_when
    (not (Bytes.equal magic External_validation.magic))
    (inconsistent_handshake "bad magic")
  >>=? fun () ->
  External_validation.recv stdin External_validation.parameters_encoding
  >>= fun {context_root; protocol_root; sandbox_parameters} ->
  let genesis_block = ref Block_hash.zero in
  let genesis_time = ref Time.Protocol.epoch in
  let genesis_protocol = ref Protocol_hash.zero in
  let sandbox_param =
    Option.map ~f:(fun p -> ("sandbox_parameter", p)) sandbox_parameters
  in
  let patch_context ctxt =
    ( match sandbox_param with
    | None ->
        Lwt.return ctxt
    | Some (key, json) ->
        Tezos_storage.Context.set
          ctxt
          [key]
          (Data_encoding.Binary.to_bytes_exn Data_encoding.json json) )
    >>= fun ctxt ->
    match Registered_protocol.get !genesis_protocol with
    | None ->
        assert false (* FIXME error *)
    | Some proto -> (
        let module Proto = (val proto) in
        let ctxt = Shell_context.wrap_disk_context ctxt in
        Proto.init
          ctxt
          {
            level = 0l;
            proto_level = 0;
            predecessor = !genesis_block;
            timestamp = !genesis_time;
            validation_passes = 0;
            operations_hash = Operation_list_list_hash.empty;
            fitness = [];
            context = Context_hash.zero;
          }
        >>= function
        | Error _ ->
            assert false (* FIXME error *)
        | Ok {context; _} ->
            let context = Shell_context.unwrap_disk_context context in
            Lwt.return context )
  in
  Context.init ~patch_context context_root
  >>= fun context_index ->
  let rec loop () =
    External_validation.recv stdin External_validation.request_encoding
    >>= (function
          | External_validation.Validate
              { chain_id;
                block_header;
                predecessor_block_header;
                operations;
                max_operations_ttl } ->
              Error_monad.protect (fun () ->
                  let pred_context_hash =
                    predecessor_block_header.shell.context
                  in
                  Context.checkout context_index pred_context_hash
                  >>= function
                  | Some context ->
                      return context
                  | None ->
                      fail
                        (Block_validator_errors.Failed_to_checkout_context
                           pred_context_hash))
              >>=? (fun predecessor_context ->
                     Context.get_protocol predecessor_context
                     >>= fun protocol_hash ->
                     load_protocol protocol_hash protocol_root
                     >>=? fun () ->
                     Block_validation.apply
                       chain_id
                       ~max_operations_ttl
                       ~predecessor_block_header
                       ~predecessor_context
                       ~block_header
                       operations
                     >>= function
                     | Error
                         [ Block_validator_errors.Unavailable_protocol
                             {protocol; _} ] as err -> (
                         (* If `next_protocol` is missing, try to load it *)
                         load_protocol protocol protocol_root
                         >>= function
                         | Error _ ->
                             Lwt.return err
                         | Ok () ->
                             Block_validation.apply
                               chain_id
                               ~max_operations_ttl
                               ~predecessor_block_header
                               ~predecessor_context
                               ~block_header
                               operations )
                     | result ->
                         Lwt.return result)
              >>= fun res ->
              External_validation.send
                stdout
                (Error_monad.result_encoding Block_validation.result_encoding)
                res
          | External_validation.Commit_genesis
              {chain_id; time; genesis_hash; protocol} ->
              genesis_time := time ;
              genesis_block := genesis_hash ;
              genesis_protocol := protocol ;
              Error_monad.protect (fun () ->
                  Context.commit_genesis
                    context_index
                    ~chain_id
                    ~time
                    ~protocol
                  >>= fun commit -> return commit)
              >>= fun commit ->
              External_validation.send
                stdout
                (Error_monad.result_encoding Context_hash.encoding)
                commit
          | External_validation.Init ->
              External_validation.send
                stdout
                (Error_monad.result_encoding Data_encoding.empty)
                (Ok ())
          | External_validation.Fork_test_chain {context_hash; forked_header}
            -> (
              Context.checkout context_index context_hash
              >>= function
              | Some ctxt ->
                  Block_validation.init_test_chain ctxt forked_header
                  >>= (function
                        | Error
                            [ Block_validator_errors.Missing_test_protocol
                                protocol ] ->
                            load_protocol protocol protocol_root
                            >>=? fun () ->
                            Block_validation.init_test_chain ctxt forked_header
                        | result ->
                            Lwt.return result)
                  >>= fun result ->
                  External_validation.send
                    stdout
                    (Error_monad.result_encoding Block_header.encoding)
                    result
              | None ->
                  External_validation.send
                    stdout
                    (Error_monad.result_encoding Data_encoding.empty)
                    (error
                       (Block_validator_errors.Failed_to_checkout_context
                          context_hash)) )
          | External_validation.Terminate ->
              Lwt_io.flush_all () >>= fun () -> exit 0)
    >>= fun () -> loop ()
  in
  loop ()

let main () =
  let stdin = Lwt_io.of_fd ~mode:Input Lwt_unix.stdin in
  let stdout = Lwt_io.of_fd ~mode:Output Lwt_unix.stdout in
  Lwt.catch
    (fun () -> run stdin stdout >>=? fun () -> return 0)
    (fun e -> Lwt.return (error_exn e))
  >>= function
  | Ok v ->
      Lwt.return v
  | Error _ as errs ->
      External_validation.send
        stdout
        (Error_monad.result_encoding Data_encoding.unit)
        errs
      >>= fun () -> Lwt.return 1
src/bin_validation/validator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition load_protocol
  (proto : Tezos_base__TzPervasives.Protocol_hash.t) (protocol_root : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Tezos_protocol_updater.Registered_protocol.mem proto then
    Tezos_base__TzPervasives.return_unit
  else
    let cmxs_file :=
      op_div_div
        (op_div_div protocol_root
          (Tezos_base__TzPervasives.Protocol_hash.to_short_b58check proto))
        (Stdlib.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "protocol_" % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "protocol_%a" % string)
          Tezos_base__TzPervasives.Protocol_hash.pp proto) in
    try.

Definition inconsistent_handshake (msg : string)
  : Tezos_base__TzPervasives.error :=
  Validation_process_failed (Inconsistent_handshake msg).

Definition run {A : Type}
  (stdin : Lwt_io.input_channel) (stdout : Lwt_io.output_channel)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_validation.External_validation.recv stdin
      Tezos_base__TzPervasives.Data_encoding.Variable.bytes)
    (fun magic =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_base__TzPervasives.fail_when
          (negb
            (Stdlib.Bytes.equal magic Tezos_validation.External_validation.magic))
          (inconsistent_handshake "bad magic" % string))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_validation.External_validation.recv stdin
                Tezos_validation.External_validation.parameters_encoding)
              (fun function_parameter =>
                match function_parameter with
                | {|
                  context_root := context_root;
                    protocol_root := protocol_root;
                    sandbox_parameters := sandbox_parameters
                    |} =>
                  let genesis_block :=
                    Stdlib.ref Tezos_base__TzPervasives.Block_hash.zero in
                  let genesis_time :=
                    Stdlib.ref Tezos_base__TzPervasives.Time.Protocol.epoch in
                  let genesis_protocol :=
                    Stdlib.ref Tezos_base__TzPervasives.Protocol_hash.zero in
                  let sandbox_param :=
                    Tezos_base__TzPervasives.Option.map
                      (fun p => ("sandbox_parameter" % string, p))
                      sandbox_parameters in
                  let patch_context (ctxt : Tezos_storage.Context.context)
                    : Lwt.t Tezos_storage.Context.t :=
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      match sandbox_param with
                      | None => Lwt._return ctxt
                      | Some (key, json) =>
                        Tezos_storage.Context.set ctxt (cons key [])
                          (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                            Tezos_base__TzPervasives.Data_encoding.json json)
                      end
                      (fun ctxt =>
                        match
                          Tezos_protocol_updater.Registered_protocol.get
                            (Stdlib.op_exclamation genesis_protocol) with
                        | None => false
                        | Some proto =>
                          let Proto := projT2 proto in
                          let ctxt :=
                            Tezos_shell_context.Shell_context.wrap_disk_context
                              ctxt in
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Proto.(Tezos_protocol_updater__Registered_protocol.T.init)
                              ctxt
                              {| level := 0; proto_level := 0;
                                predecessor :=
                                  Stdlib.op_exclamation genesis_block;
                                timestamp := Stdlib.op_exclamation genesis_time;
                                validation_passes := 0;
                                operations_hash :=
                                  Tezos_base__TzPervasives.Operation_list_list_hash.empty;
                                fitness := [];
                                context :=
                                  Tezos_base__TzPervasives.Context_hash.zero |})
                            (fun function_parameter =>
                              match function_parameter with
                              | inr _ => false
                              | inl {| context := context |} =>
                                let context :=
                                  Tezos_shell_context.Shell_context.unwrap_disk_context
                                    context in
                                Lwt._return context
                              end)
                        end) in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_storage.Context.init (Some patch_context) None None
                      context_root)
                    (fun context_index =>
                      let fix loop {B : Type} (function_parameter : unit)
                        : Lwt.t B :=
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_validation.External_validation.recv stdin
                                Tezos_validation.External_validation.request_encoding)
                              (fun function_parameter =>
                                match function_parameter with
                                |
                                  External_validation.Validate {|
                                    chain_id := chain_id;
                                      block_header := block_header;
                                      predecessor_block_header :=
                                        predecessor_block_header;
                                      operations := operations;
                                      max_operations_ttl := max_operations_ttl
                                      |} =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_base__TzPervasives.Error_monad.protect
                                        None None
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            let pred_context_hash :=
                                              context
                                                (shell predecessor_block_header)
                                              in
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (Tezos_storage.Context.checkout
                                                context_index pred_context_hash)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | Some context =>
                                                  Tezos_base__TzPervasives._return
                                                    context
                                                | None =>
                                                  Tezos_base__TzPervasives.fail
                                                    (Block_validator_errors.Failed_to_checkout_context
                                                      pred_context_hash)
                                                end)
                                          end))
                                      (fun predecessor_context =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (Tezos_storage.Context.get_protocol
                                            predecessor_context)
                                          (fun protocol_hash =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                              (load_protocol protocol_hash
                                                protocol_root)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                    (Tezos_validation.Block_validation.apply
                                                      chain_id
                                                      max_operations_ttl
                                                      predecessor_block_header
                                                      predecessor_context
                                                      block_header operations)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      |
                                                        (inr
                                                          (cons
                                                            (Block_validator_errors.Unavailable_protocol
                                                              {|
                                                              protocol := protocol
                                                                |}) [])) as err
                                                        =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (load_protocol
                                                            protocol
                                                            protocol_root)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | inr _ =>
                                                              Lwt._return err
                                                            | inl tt =>
                                                              Tezos_validation.Block_validation.apply
                                                                chain_id
                                                                max_operations_ttl
                                                                predecessor_block_header
                                                                predecessor_context
                                                                block_header
                                                                operations
                                                            end)
                                                      | result =>
                                                        Lwt._return result
                                                      end)
                                                end))))
                                    (fun res =>
                                      Tezos_validation.External_validation.send
                                        stdout
                                        (Tezos_base__TzPervasives.Error_monad.result_encoding
                                          Tezos_validation.Block_validation.result_encoding)
                                        res)
                                |
                                  External_validation.Commit_genesis {|
                                    chain_id := chain_id;
                                      genesis_hash := genesis_hash;
                                      time := time;
                                      protocol := protocol
                                      |} =>
                                  Stdlib.op_colon_eq genesis_time time;
                                  Stdlib.op_colon_eq genesis_block genesis_hash;
                                  Stdlib.op_colon_eq genesis_protocol protocol;
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_base__TzPervasives.Error_monad.protect
                                      None None
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Tezos_storage.Context.commit_genesis
                                              context_index chain_id time
                                              protocol)
                                            (fun commit =>
                                              Tezos_base__TzPervasives._return
                                                commit)
                                        end))
                                    (fun commit =>
                                      Tezos_validation.External_validation.send
                                        stdout
                                        (Tezos_base__TzPervasives.Error_monad.result_encoding
                                          Tezos_base__TzPervasives.Context_hash.encoding)
                                        commit)
                                | External_validation.Init =>
                                  Tezos_validation.External_validation.send
                                    stdout
                                    (Tezos_base__TzPervasives.Error_monad.result_encoding
                                      Tezos_base__TzPervasives.Data_encoding.empty)
                                    (inl tt)
                                |
                                  External_validation.Fork_test_chain {|
                                    context_hash := context_hash;
                                      forked_header := forked_header
                                      |} =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_storage.Context.checkout
                                      context_index context_hash)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | Some ctxt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Tezos_validation.Block_validation.init_test_chain
                                              ctxt forked_header)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              |
                                                inr
                                                  (cons
                                                    (Block_validator_errors.Missing_test_protocol
                                                      protocol) []) =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (load_protocol protocol
                                                    protocol_root)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_validation.Block_validation.init_test_chain
                                                        ctxt forked_header
                                                    end)
                                              | result => Lwt._return result
                                              end))
                                          (fun result =>
                                            Tezos_validation.External_validation.send
                                              stdout
                                              (Tezos_base__TzPervasives.Error_monad.result_encoding
                                                Tezos_base__TzPervasives.Block_header.encoding)
                                              result)
                                      | None =>
                                        Tezos_validation.External_validation.send
                                          stdout
                                          (Tezos_base__TzPervasives.Error_monad.result_encoding
                                            Tezos_base__TzPervasives.Data_encoding.empty)
                                          (Tezos_base__TzPervasives.error
                                            (Block_validator_errors.Failed_to_checkout_context
                                              context_hash))
                                      end)
                                | External_validation.Terminate =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Lwt_io.flush_all tt)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt => Stdlib.exit 0
                                      end)
                                end))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => loop tt
                              end)
                        end in
                      loop tt)
                end)
          end)).

Definition main (function_parameter : unit) : Lwt.t Z :=
  match function_parameter with
  | tt =>
    let stdin := Lwt_io.of_fd None None Input Lwt_unix.stdin in
    let stdout := Lwt_io.of_fd None None Output Lwt_unix.stdout in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Lwt.catch
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question (run stdin stdout)
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives._return 0
                end)
          end) (fun e => Lwt._return (Tezos_base__TzPervasives.error_exn e)))
      (fun function_parameter =>
        match function_parameter with
        | inl v => Lwt._return v
        | (inr _) as errs =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_validation.External_validation.send stdout
              (Tezos_base__TzPervasives.Error_monad.result_encoding
                Tezos_base__TzPervasives.Data_encoding.unit) errs)
            (fun function_parameter =>
              match function_parameter with
              | tt => Lwt._return 1
              end)
        end)
  end.
src/lib_base/base_logging.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "base"
end)

let pp_exn_trace ppf backtrace =
  if String.length backtrace <> 0 then
    Format.fprintf
      ppf
      "@,Backtrace:@,  @[<h>%a@]"
      Format.pp_print_text
      backtrace

let pid =
  Tag.def
    ~doc:"unix process ID where problem occurred"
    "pid"
    Format.pp_print_int

let exn_trace =
  Tag.def ~doc:"backtrace from native Ocaml exception" "exn_trace" pp_exn_trace
src/lib_base/base_logging.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition pp_exn_trace (ppf : Stdlib.Format.formatter) (backtrace : string)
  : unit :=
  if nequiv_decb (OCaml.String.length backtrace) 0 then
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          (CamlinternalFormatBasics.Break "@," % string 0 0)
          (CamlinternalFormatBasics.String_literal "Backtrace:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "  " % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<h>" % string
                        CamlinternalFormatBasics.End_of_format) "<h>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))))
        "@,Backtrace:@,  @[<h>%a@]" % string) Stdlib.Format.pp_print_text
      backtrace
  else
    tt.

Definition pid : Tag.def Z :=
  Tag.def (Some "unix process ID where problem occurred" % string)
    "pid" % string Stdlib.Format.pp_print_int.

Definition exn_trace : Tag.def string :=
  Tag.def (Some "backtrace from native Ocaml exception" % string)
    "exn_trace" % string pp_exn_trace.
src/lib_base/base_logging.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.SEMLOG

val pid : int Tag.def

val exn_trace : string Tag.def
src/lib_base/base_logging.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter pid : Tag.def Z.

Parameter exn_trace : Tag.def string.
src/lib_base/block_header.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type shell_header = {
  level : Int32.t;
  proto_level : int;
  (* uint8 *)
  predecessor : Block_hash.t;
  timestamp : Time.Protocol.t;
  validation_passes : int;
  (* uint8 *)
  operations_hash : Operation_list_list_hash.t;
  fitness : Fitness.t;
  context : Context_hash.t;
}

let shell_header_encoding =
  let open Data_encoding in
  def
    "block_header.shell"
    ~title:"Shell header"
    ~description:
      "Block header's shell-related content. It contains information such as \
       the block level, its predecessor and timestamp."
  @@ conv
       (fun { level;
              proto_level;
              predecessor;
              timestamp;
              validation_passes;
              operations_hash;
              fitness;
              context } ->
         ( level,
           proto_level,
           predecessor,
           timestamp,
           validation_passes,
           operations_hash,
           fitness,
           context ))
       (fun ( level,
              proto_level,
              predecessor,
              timestamp,
              validation_passes,
              operations_hash,
              fitness,
              context ) ->
         {
           level;
           proto_level;
           predecessor;
           timestamp;
           validation_passes;
           operations_hash;
           fitness;
           context;
         })
       (obj8
          (req "level" int32)
          (req "proto" uint8)
          (req "predecessor" Block_hash.encoding)
          (req "timestamp" Time.Protocol.encoding)
          (req "validation_pass" uint8)
          (req "operations_hash" Operation_list_list_hash.encoding)
          (req "fitness" Fitness.encoding)
          (req "context" Context_hash.encoding))

type t = {shell : shell_header; protocol_data : Bytes.t}

include Compare.Make (struct
  type nonrec t = t

  let compare b1 b2 =
    let ( >> ) x y = if x = 0 then y () else x in
    let rec list compare xs ys =
      match (xs, ys) with
      | ([], []) ->
          0
      | (_ :: _, []) ->
          -1
      | ([], _ :: _) ->
          1
      | (x :: xs, y :: ys) ->
          compare x y >> fun () -> list compare xs ys
    in
    Block_hash.compare b1.shell.predecessor b2.shell.predecessor
    >> fun () ->
    compare b1.protocol_data b2.protocol_data
    >> fun () ->
    Operation_list_list_hash.compare
      b1.shell.operations_hash
      b2.shell.operations_hash
    >> fun () ->
    Time.Protocol.compare b1.shell.timestamp b2.shell.timestamp
    >> fun () -> list compare b1.shell.fitness b2.shell.fitness
end)

let encoding =
  let open Data_encoding in
  def
    "block_header"
    ~title:"Block header"
    ~description:
      "Block header. It contains both shell and protocol specific data."
  @@ conv
       (fun {shell; protocol_data} -> (shell, protocol_data))
       (fun (shell, protocol_data) -> {shell; protocol_data})
       (merge_objs
          shell_header_encoding
          (obj1 (req "protocol_data" Variable.bytes)))

let bounded_encoding ?max_size () =
  match max_size with
  | None ->
      encoding
  | Some max_size ->
      Data_encoding.check_size max_size encoding

let pp ppf op =
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op)

let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

let of_bytes b = Data_encoding.Binary.of_bytes encoding b

let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b

let to_b58check v = Base58.safe_encode (Bytes.to_string (to_bytes v))

let of_b58check b =
  Option.apply (Base58.safe_decode b) ~f:(fun s ->
      Data_encoding.Binary.of_bytes encoding (Bytes.of_string s))

let hash block = Block_hash.hash_bytes [to_bytes block]

let hash_raw bytes = Block_hash.hash_bytes [bytes]

let forced_protocol_upgrades : (Int32.t * Protocol_hash.t) list =
  [ (* nothing *) ]

let voted_protocol_overrides : (Protocol_hash.t * Protocol_hash.t) list =
  List.map
    (fun (a, b) ->
      (Protocol_hash.of_b58check_exn a, Protocol_hash.of_b58check_exn b))
    [ (* nothing *) ]

module LevelMap = Map.Make (struct
  type t = Int32.t

  let compare = Int32.compare
end)

let get_forced_protocol_upgrade =
  let table =
    List.fold_left
      (fun map (level, hash) -> LevelMap.add level hash map)
      LevelMap.empty
      forced_protocol_upgrades
  in
  fun ~level -> LevelMap.find_opt level table

let get_voted_protocol_overrides proto_hash =
  List.assoc_opt proto_hash voted_protocol_overrides

let () =
  Data_encoding.Registration.register shell_header_encoding ;
  Data_encoding.Registration.register encoding
src/lib_base/block_header.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record shell_header := {
  level : Stdlib.Int32.t;
  proto_level : Z;
  predecessor : Tezos_crypto.Block_hash.t;
  timestamp : Tezos_base.Time.Protocol.t;
  validation_passes : Z;
  operations_hash : Tezos_crypto.Operation_list_list_hash.t;
  fitness : Tezos_base.Fitness.t;
  context : Tezos_crypto.Context_hash.t }.

Definition shell_header_encoding
  : Tezos_data_encoding.Data_encoding.encoding shell_header :=
  apply
    (Tezos_data_encoding.Data_encoding.def "block_header.shell" % string
      (Some "Shell header" % string)
      (Some
        "Block header's shell-related content. It contains information such as the block level, its predecessor and timestamp."
          % string))
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          level := level;
            proto_level := proto_level;
            predecessor := predecessor;
            timestamp := timestamp;
            validation_passes := validation_passes;
            operations_hash := operations_hash;
            fitness := fitness;
            context := context
            |} =>
          (level, proto_level, predecessor, timestamp, validation_passes,
            operations_hash, fitness, context)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (level, proto_level, predecessor, timestamp, validation_passes,
            operations_hash, fitness, context) =>
          {| level := level; proto_level := proto_level;
            predecessor := predecessor; timestamp := timestamp;
            validation_passes := validation_passes;
            operations_hash := operations_hash; fitness := fitness;
            context := context |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj8
        (Tezos_data_encoding.Data_encoding.req None None "level" % string
          Tezos_data_encoding.Data_encoding.int32)
        (Tezos_data_encoding.Data_encoding.req None None "proto" % string
          Tezos_data_encoding.Data_encoding.uint8)
        (Tezos_data_encoding.Data_encoding.req None None "predecessor" % string
          Tezos_crypto.Block_hash.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "timestamp" % string
          Tezos_base.Time.Protocol.encoding)
        (Tezos_data_encoding.Data_encoding.req None None
          "validation_pass" % string Tezos_data_encoding.Data_encoding.uint8)
        (Tezos_data_encoding.Data_encoding.req None None
          "operations_hash" % string
          Tezos_crypto.Operation_list_list_hash.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "fitness" % string
          Tezos_base.Fitness.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "context" % string
          Tezos_crypto.Context_hash.encoding))).

Record t := {
  shell : shell_header;
  protocol_data : Stdlib.Bytes.t }.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (Tezos_data_encoding.Data_encoding.def "block_header" % string
      (Some "Block header" % string)
      (Some
        "Block header. It contains both shell and protocol specific data." %
          string))
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| shell := shell; protocol_data := protocol_data |} =>
          (shell, protocol_data)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (shell, protocol_data) =>
          {| shell := shell; protocol_data := protocol_data |}
        end) None
      (Tezos_data_encoding.Data_encoding.merge_objs shell_header_encoding
        (Tezos_data_encoding.Data_encoding.obj1
          (Tezos_data_encoding.Data_encoding.req None None
            "protocol_data" % string
            Tezos_data_encoding.Data_encoding.Variable.bytes)))).

Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding t :=
  match function_parameter with
  | tt =>
    match max_size with
    | None => encoding
    | Some max_size =>
      Tezos_data_encoding.Data_encoding.check_size max_size encoding
    end
  end.

Definition pp (ppf : Stdlib.Format.formatter) (op : t) : unit :=
  Tezos_data_encoding.Data_encoding.Json.pp ppf
    (Tezos_data_encoding.Data_encoding.Json.construct encoding op).

Definition to_bytes (v : t) : Stdlib.Bytes.t :=
  Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn encoding v.

Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
  Tezos_data_encoding.Data_encoding.Binary.of_bytes encoding b.

Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
  Tezos_data_encoding.Data_encoding.Binary.of_bytes_exn encoding b.

Definition to_b58check (v : t) : string :=
  Tezos_crypto.Base58.safe_encode None (Stdlib.Bytes.to_string (to_bytes v)).

Definition of_b58check (b : string) : option t :=
  Tezos_stdlib.Option.apply
    (fun s =>
      Tezos_data_encoding.Data_encoding.Binary.of_bytes encoding
        (Stdlib.Bytes.of_string s)) (Tezos_crypto.Base58.safe_decode None b).

Definition hash (block : t) : Tezos_crypto.Block_hash.t :=
  Tezos_crypto.Block_hash.hash_bytes None (cons (to_bytes block) []).

Definition hash_raw (bytes : Stdlib.Bytes.t) : Tezos_crypto.Block_hash.t :=
  Tezos_crypto.Block_hash.hash_bytes None (cons string []).

Definition forced_protocol_upgrades
  : list (Stdlib.Int32.t * Tezos_crypto.Protocol_hash.t) := [].

Definition voted_protocol_overrides
  : list (Tezos_crypto.Protocol_hash.t * Tezos_crypto.Protocol_hash.t) :=
  List.map
    (fun function_parameter =>
      match function_parameter with
      | (a, b) =>
        ((Tezos_crypto.Protocol_hash.of_b58check_exn a),
          (Tezos_crypto.Protocol_hash.of_b58check_exn b))
      end) [].

Definition get_forced_protocol_upgrade
  : LevelMap.key -> option Tezos_crypto.Protocol_hash.t :=
  let table :=
    Stdlib.List.fold_left
      (fun map =>
        fun function_parameter =>
          match function_parameter with
          | (level, hash) => LevelMap.add level hash map
          end) LevelMap.empty forced_protocol_upgrades in
  fun level => LevelMap.find_opt level table.

Definition get_voted_protocol_overrides
  (proto_hash : Tezos_crypto.Protocol_hash.t)
  : option Tezos_crypto.Protocol_hash.t :=
  Stdlib.List.assoc_opt proto_hash voted_protocol_overrides.
src/lib_base/block_header.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type shell_header = {
  level : Int32.t;  (** Height of the block, from the genesis block. *)
  proto_level : int;
      (* uint8 *)
      (** Number of protocol changes since genesis modulo 256. *)
  predecessor : Block_hash.t;  (** Hash of the preceding block. *)
  timestamp : Time.Protocol.t;
      (** Timestamp at which the block is claimed to have been created. *)
  validation_passes : int;
      (* uint8 *)
      (** Number of validation passes (also number of lists of operations). *)
  operations_hash : Operation_list_list_hash.t;
      (** Hash of the list of lists (actually root hashes of merkle trees)
      of operations included in the block. There is one list of
      operations per validation pass. *)
  fitness : Fitness.t;
      (** A sequence of sequences of unsigned bytes, ordered by length and
      then lexicographically. It represents the claimed fitness of the
      chain ending in this block. *)
  context : Context_hash.t;
      (** Hash of the state of the context after application of this block. *)
}

val shell_header_encoding : shell_header Data_encoding.t

type t = {shell : shell_header; protocol_data : Bytes.t}

include S.HASHABLE with type t := t and type hash := Block_hash.t

val of_bytes_exn : Bytes.t -> t

val to_b58check : t -> string

val of_b58check : string -> t option

val bounded_encoding : ?max_size:int -> unit -> t Data_encoding.t

val get_forced_protocol_upgrade : level:Int32.t -> Protocol_hash.t option

val get_voted_protocol_overrides : Protocol_hash.t -> Protocol_hash.t option
src/lib_base/block_header.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record shell_header := {
  level : Stdlib.Int32.t;
  proto_level : Z;
  predecessor : Tezos_crypto.Block_hash.t;
  timestamp : Tezos_base.Time.Protocol.t;
  validation_passes : Z;
  operations_hash : Tezos_crypto.Operation_list_list_hash.t;
  fitness : Tezos_base.Fitness.t;
  context : Tezos_crypto.Context_hash.t }.

Parameter shell_header_encoding :
Tezos_data_encoding.Data_encoding.t shell_header.

Record t := {
  shell : shell_header;
  protocol_data : Stdlib.Bytes.t }.

Parameter of_bytes_exn : Stdlib.Bytes.t -> t.

Parameter to_b58check : t -> string.

Parameter of_b58check : string -> option t.

Parameter bounded_encoding :
(option Z) -> unit -> Tezos_data_encoding.Data_encoding.t t.

Parameter get_forced_protocol_upgrade :
Stdlib.Int32.t -> option Tezos_crypto.Protocol_hash.t.

Parameter get_voted_protocol_overrides :
Tezos_crypto.Protocol_hash.t -> option Tezos_crypto.Protocol_hash.t.
src/lib_base/block_locator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type t = raw

and raw = Block_header.t * Block_hash.t list

let raw x = x

let pp ppf (hd, h_lst) =
  let repeats = 10 in
  let coef = 2 in
  (* list of hashes *)
  let rec pp_hash_list ppf (h_lst, acc, d, r) =
    match h_lst with
    | [] ->
        Format.fprintf ppf ""
    | hd :: tl ->
        let new_d = if r > 1 then d else d * coef in
        let new_r = if r > 1 then r - 1 else repeats in
        Format.fprintf
          ppf
          "%a (%i)\n%a"
          Block_hash.pp
          hd
          acc
          pp_hash_list
          (tl, acc - d, new_d, new_r)
  in
  Format.fprintf
    ppf
    "%a (head)\n%a"
    Block_hash.pp
    (Block_header.hash hd)
    pp_hash_list
    (h_lst, -1, 1, repeats - 1)

let pp_short ppf (hd, h_lst) =
  Format.fprintf
    ppf
    "head: %a, %d predecessors"
    Block_hash.pp
    (Block_header.hash hd)
    (List.length h_lst)

let encoding =
  let open Data_encoding in
  def "block_locator" ~description:"A sparse block locator à la Bitcoin"
  @@ obj2
       (req "current_head" (dynamic_size Block_header.encoding))
       (req "history" (Variable.list Block_hash.encoding))

let bounded_encoding ?max_header_size ?max_length () =
  let open Data_encoding in
  obj2
    (req
       "current_head"
       (dynamic_size
          (Block_header.bounded_encoding ?max_size:max_header_size ())))
    (req "history" (Variable.list ?max_length Block_hash.encoding))

type seed = {sender_id : P2p_peer.Id.t; receiver_id : P2p_peer.Id.t}

(* Random generator for locator steps.

   We draw steps by sequence of 10. The first sequence's steps are of
   length 1 (consecutive). The second sequence's steps are of a random
   length between 1 and 2. The third sequence's steps are of a random
   length between 2 and 4, and so on...

   The sequence is deterministic for a given triple of sender,
   receiver and block hash. *)
module Step : sig
  type state

  val init : seed -> Block_hash.t -> state

  val next : state -> int * state
end = struct
  (* (step, counter, seed) .
     The seed is stored in a bigstring and should be mlocked *)
  type state = Int32.t * int * Bigstring.t

  let update st b = Hacl.Hash.SHA256.update st (Bigstring.of_bytes b)

  let init seed head =
    let open Hacl.Hash in
    let st = SHA256.init () in
    List.iter
      (update st)
      [ P2p_peer.Id.to_bytes seed.sender_id;
        P2p_peer.Id.to_bytes seed.receiver_id;
        Block_hash.to_bytes head ] ;
    (1l, 9, SHA256.finish st)

  let draw seed n =
    ( Int32.rem (TzEndian.get_int32 (Bigstring.to_bytes seed) 0) n,
      Hacl.Hash.SHA256.digest seed )

  let next (step, counter, seed) =
    let (random_gap, seed) =
      if step <= 1l then (0l, seed)
      else draw seed (Int32.succ (Int32.div step 2l))
    in
    let new_state =
      if counter = 0 then (Int32.mul step 2l, 9, seed)
      else (step, counter - 1, seed)
    in
    (Int32.to_int (Int32.sub step random_gap), new_state)
end

let estimated_length seed (head, hist) =
  let rec loop acc state = function
    | [] ->
        acc
    | _ :: hist ->
        let (step, state) = Step.next state in
        loop (acc + step) state hist
  in
  let state = Step.init seed (Block_header.hash head) in
  let (step, state) = Step.next state in
  loop step state hist

let fold ~f ~init (head, hist) seed =
  let rec loop state acc = function
    | [] | [_] ->
        acc
    | block :: (pred :: rem as hist) ->
        let (step, state) = Step.next state in
        let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
        loop state acc hist
  in
  let head = Block_header.hash head in
  let state = Step.init seed head in
  loop state init (head :: hist)

type step = {
  block : Block_hash.t;
  predecessor : Block_hash.t;
  step : int;
  strict_step : bool;
}

let pp_step ppf step =
  Format.fprintf ppf "%d%s" step.step (if step.strict_step then "" else " max")

let to_steps seed locator =
  fold locator seed ~init:[] ~f:(fun acc ~block ~pred ~step ~strict_step ->
      {block; predecessor = pred; step; strict_step} :: acc)

let fold_truncate ~f ~init ~save_point ~limit (head, hist) seed =
  let rec loop state step_sum acc = function
    | [] | [_] ->
        acc
    | block :: (pred :: rem as hist) ->
        let (step, state) = Step.next state in
        let new_step_sum = step + step_sum in
        if new_step_sum >= limit then
          f acc ~block ~pred:save_point ~step ~strict_step:false
        else
          let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
          loop state new_step_sum acc hist
  in
  let hash = Block_header.hash head in
  let initial_state = Step.init seed hash in
  loop initial_state 0 init (hash :: hist)

let to_steps_truncate ~limit ~save_point seed locator =
  fold_truncate
    locator
    seed
    ~init:[]
    ~save_point
    ~limit
    ~f:(fun acc ~block ~pred ~step ~strict_step ->
      {block; predecessor = pred; step; strict_step} :: acc)

let compute ~get_predecessor ~caboose ~size block_hash header seed =
  let rec loop acc size state current_block_hash =
    if size = 0 then Lwt.return acc
    else
      let (step, state) = Step.next state in
      get_predecessor current_block_hash step
      >>= function
      | None ->
          if Block_hash.equal caboose current_block_hash then Lwt.return acc
          else Lwt.return (caboose :: acc)
      | Some predecessor ->
          loop (predecessor :: acc) (pred size) state predecessor
  in
  if size <= 0 then Lwt.return (header, [])
  else
    let initial_state = Step.init seed block_hash in
    loop [] size initial_state block_hash
    >>= fun hist -> Lwt.return (header, List.rev hist)

type validity = Unknown | Known_valid | Known_invalid

let unknown_prefix ~is_known locator =
  let (head, history) = locator in
  let rec loop hist acc =
    match hist with
    | [] ->
        Lwt.return (Unknown, locator)
    | h :: t -> (
        is_known h
        >>= function
        | Known_valid ->
            Lwt.return (Known_valid, (head, List.rev (h :: acc)))
        | Known_invalid ->
            Lwt.return (Known_invalid, (head, List.rev (h :: acc)))
        | Unknown ->
            loop t (h :: acc) )
  in
  is_known (Block_header.hash head)
  >>= function
  | Known_valid ->
      Lwt.return (Known_valid, (head, []))
  | Known_invalid ->
      Lwt.return (Known_invalid, (head, []))
  | Unknown ->
      loop history []

let () = Data_encoding.Registration.register ~pp:pp_short encoding
src/lib_base/block_locator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Reserved Notation "'t".
Reserved Notation "'raw".



where "'t" := ( 'raw)

and "'raw" := ( Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)).

Definition t := 't.
Definition raw := 'raw.

Definition raw {A : Type} (x : A) : A := x.

Definition pp
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : unit :=
  match function_parameter with
  | (hd, h_lst) =>
    let repeats := 10 in
    let coef := 2 in
    let fix pp_hash_list
      (ppf : Stdlib.Format.formatter) (function_parameter :
      (list Tezos_crypto.Block_hash.t) * Z * Z * Z) : unit :=
      match function_parameter with
      | (h_lst, acc, d, r) =>
        match h_lst with
        | [] =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string)
        | cons hd tl =>
          let new_d :=
            if OCaml.Stdlib.gt r 1 then
              d
            else
              Z.mul d coef in
          let new_r :=
            if OCaml.Stdlib.gt r 1 then
              Z.sub r 1
            else
              repeats in
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " (" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ")
" % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)))))
              "%a (%i)
%a" % string) Tezos_crypto.Block_hash.pp hd acc
            pp_hash_list (tl, (Z.sub acc d), new_d, new_r)
        end
      end in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal " (head)
" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))) "%a (head)
%a" % string)
      Tezos_crypto.Block_hash.pp (Tezos_base.Block_header.hash hd) pp_hash_list
      (h_lst, (-1), 1, (Z.sub repeats 1))
  end.

Definition pp_short {A : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter : Tezos_base.Block_header.t * (list A)) : unit :=
  match function_parameter with
  | (hd, h_lst) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "head: " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal ", " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal
                  " predecessors" % string
                  CamlinternalFormatBasics.End_of_format)))))
        "head: %a, %d predecessors" % string) Tezos_crypto.Block_hash.pp
      (Tezos_base.Block_header.hash hd) (OCaml.List.length h_lst)
  end.

Definition encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "block_locator" % string
        expected_argument (Some "A sparse block locator à la Bitcoin" % string)
      in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.obj2
      (Tezos_data_encoding.Data_encoding.req None None "current_head" % string
        (Tezos_data_encoding.Data_encoding.dynamic_size None
          Tezos_base.Block_header.encoding))
      (Tezos_data_encoding.Data_encoding.req None None "history" % string
        (Tezos_data_encoding.Data_encoding.Variable.list None
          Tezos_crypto.Block_hash.encoding))).

Definition bounded_encoding
  (max_header_size : option Z) (max_length : option Z)
  (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) :=
  match function_parameter with
  | tt =>
    Tezos_data_encoding.Data_encoding.obj2
      (Tezos_data_encoding.Data_encoding.req None None "current_head" % string
        (Tezos_data_encoding.Data_encoding.dynamic_size None
          (Tezos_base.Block_header.bounded_encoding max_header_size tt)))
      (Tezos_data_encoding.Data_encoding.req None None "history" % string
        (Tezos_data_encoding.Data_encoding.Variable.list max_length
          Tezos_crypto.Block_hash.encoding))
  end.

Record seed := {
  sender_id : Tezos_base.P2p_peer.Id.t;
  receiver_id : Tezos_base.P2p_peer.Id.t }.

Module Step.
  Definition state := Stdlib.Int32.t * Z * Bigstring.t.
  
  Definition update
    (st : Hacl.Hash.SHA256.(Hacl.S.Hash.state)) (b : Stdlib.Bytes.t) : unit :=
    Hacl.Hash.SHA256.(Hacl.S.Hash.update) st (Bigstring.of_bytes b).
  
  Definition init (seed : seed) (head : Tezos_crypto.Block_hash.t)
    : int32 * Z * Bigstring.t :=
    let st := Hacl.Hash.SHA256.(Hacl.Hash.S.init) tt in
    Stdlib.List.iter (update st)
      (cons (Tezos_base.P2p_peer.Id.to_bytes (sender_id seed))
        (cons (Tezos_base.P2p_peer.Id.to_bytes (receiver_id seed))
          (cons (Tezos_crypto.Block_hash.to_bytes head) [])));
    (1, 9, (Hacl.Hash.SHA256.(Hacl.Hash.S.finish) st)).
  
  Definition draw (seed : Bigstring.t) (n : int32) : int32 * Bigstring.t :=
    ((Stdlib.Int32.rem
      (Tezos_data_encoding.TzEndian.get_int32 (Bigstring.to_bytes seed) 0) n),
      (Hacl.Hash.SHA256.(Hacl.S.Hash.digest) seed)).
  
  Definition next (function_parameter : int32 * Z * Bigstring.t)
    : Z * (int32 * Z * Bigstring.t) :=
    match function_parameter with
    | (step, counter, seed) =>
      match
        if OCaml.Stdlib.le step 1 then
          (0, seed)
        else
          draw seed (Stdlib.Int32.succ (Stdlib.Int32.div step 2)) with
      | (random_gap, seed) =>
        let new_state :=
          if equiv_decb counter 0 then
            ((Stdlib.Int32.mul step 2), 9, seed)
          else
            (step, (Z.sub counter 1), seed) in
        ((Stdlib.Int32.to_int (Stdlib.Int32.sub step random_gap)), new_state)
      end
    end.
End Step.

Definition estimated_length {A : Type}
  (seed : seed) (function_parameter : Tezos_base.Block_header.t * (list A))
  : Z :=
  match function_parameter with
  | (head, hist) =>
    let fix loop {B : Type}
      (acc : Z) (state : Step.state) (function_parameter : list B) : Z :=
      match function_parameter with
      | [] => acc
      | cons _ hist =>
        match Step.next state with
        | (step, state) => loop (Z.add acc step) state hist
        end
      end in
    let state := Step.init seed (Tezos_base.Block_header.hash head) in
    match Step.next state with
    | (step, state) => loop step state hist
    end
  end.

Definition fold {A : Type}
  (f :
    A ->
      Tezos_crypto.Block_hash.t -> Tezos_crypto.Block_hash.t -> Z -> bool -> A)
  (init : A)
  (function_parameter :
    Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : seed -> A :=
  match function_parameter with
  | (head, hist) =>
    fun seed =>
      let fix loop
        (state : Step.state) (acc : A) (function_parameter :
        list Tezos_crypto.Block_hash.t) : A :=
        match function_parameter with
        | [] | cons _ [] => acc
        | cons block ((cons pred rem) as hist) =>
          match Step.next state with
          | (step, state) =>
            let acc := f acc block pred step (nequiv_decb rem []) in
            loop state acc hist
          end
        end in
      let head := Tezos_base.Block_header.hash head in
      let state := Step.init seed head in
      loop state init (cons head hist)
  end.

Record step := {
  block : Tezos_crypto.Block_hash.t;
  predecessor : Tezos_crypto.Block_hash.t;
  step : Z;
  strict_step : bool }.

Definition pp_step (ppf : Stdlib.Format.formatter) (step : step) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format)) "%d%s" % string) (step step)
    (if strict_step step then
      "" % string
    else
      " max" % string).

Definition to_steps
  (seed : seed)
  (locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
  : list step :=
  fold
    (fun acc =>
      fun block =>
        fun pred =>
          fun step =>
            fun strict_step =>
              cons
                {| block := block; predecessor := pred; step := step;
                  strict_step := strict_step |} acc) [] locator seed.

Definition fold_truncate {A : Type}
  (f :
    A ->
      Tezos_crypto.Block_hash.t -> Tezos_crypto.Block_hash.t -> Z -> bool -> A)
  (init : A) (save_point : Tezos_crypto.Block_hash.t) (limit : Z)
  (function_parameter :
    Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : seed -> A :=
  match function_parameter with
  | (head, hist) =>
    fun seed =>
      let fix loop
        (state : Step.state) (step_sum : Z) (acc : A) (function_parameter :
        list Tezos_crypto.Block_hash.t) : A :=
        match function_parameter with
        | [] | cons _ [] => acc
        | cons block ((cons pred rem) as hist) =>
          match Step.next state with
          | (step, state) =>
            let new_step_sum := Z.add step step_sum in
            if OCaml.Stdlib.ge new_step_sum limit then
              f acc block save_point step false
            else
              let acc := f acc block pred step (nequiv_decb rem []) in
              loop state new_step_sum acc hist
          end
        end in
      let hash := Tezos_base.Block_header.hash head in
      let initial_state := Step.init seed hash in
      loop initial_state 0 init (cons hash hist)
  end.

Definition to_steps_truncate
  (limit : Z) (save_point : Tezos_crypto.Block_hash.t) (seed : seed)
  (locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
  : list step :=
  fold_truncate
    (fun acc =>
      fun block =>
        fun pred =>
          fun step =>
            fun strict_step =>
              cons
                {| block := block; predecessor := pred; step := step;
                  strict_step := strict_step |} acc) [] save_point limit locator
    seed.

Definition compute {A : Type}
  (get_predecessor :
    Tezos_crypto.Block_hash.t -> Z -> Lwt.t (option Tezos_crypto.Block_hash.t))
  (caboose : Tezos_crypto.Block_hash.t) (size : Z)
  (block_hash : Tezos_crypto.Block_hash.t) (header : A) (seed : seed)
  : Lwt.t (A * (list Tezos_crypto.Block_hash.t)) :=
  let fix loop
    (acc : list Tezos_crypto.Block_hash.t) (size : Z) (state : Step.state)
    (current_block_hash : Tezos_crypto.Block_hash.t)
    : Lwt.t (list Tezos_crypto.Block_hash.t) :=
    if equiv_decb size 0 then
      Lwt._return acc
    else
      match Step.next state with
      | (step, state) =>
        Lwt.Infix.op_gt_gt_eq (get_predecessor current_block_hash step)
          (fun function_parameter =>
            match function_parameter with
            | None =>
              if Tezos_crypto.Block_hash.equal caboose current_block_hash then
                Lwt._return acc
              else
                Lwt._return (cons caboose acc)
            | Some predecessor =>
              loop (cons predecessor acc) (Z.pred size) state predecessor
            end)
      end in
  if OCaml.Stdlib.le size 0 then
    Lwt._return (header, [])
  else
    let initial_state := Step.init seed block_hash in
    Lwt.Infix.op_gt_gt_eq (loop [] size initial_state block_hash)
      (fun hist => Lwt._return (header, (List.rev hist))).

Inductive validity : Type :=
| Unknown : validity
| Known_valid : validity
| Known_invalid : validity.

Definition unknown_prefix
  (is_known : Tezos_crypto.Block_hash.t -> Lwt.t validity)
  (locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
  : Lwt.t
    (validity * (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))) :=
  match locator with
  | (head, history) =>
    let fix loop
      (hist : list Tezos_crypto.Block_hash.t) (acc :
      list Tezos_crypto.Block_hash.t)
      : Lwt.t
        (validity *
          (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))) :=
      match hist with
      | [] => Lwt._return (Unknown, locator)
      | cons h t =>
        Lwt.Infix.op_gt_gt_eq (is_known h)
          (fun function_parameter =>
            match function_parameter with
            | Known_valid =>
              Lwt._return (Known_valid, (head, (List.rev (cons h acc))))
            | Known_invalid =>
              Lwt._return (Known_invalid, (head, (List.rev (cons h acc))))
            | Unknown => loop t (cons h acc)
            end)
      end in
    Lwt.Infix.op_gt_gt_eq (is_known (Tezos_base.Block_header.hash head))
      (fun function_parameter =>
        match function_parameter with
        | Known_valid => Lwt._return (Known_valid, (head, []))
        | Known_invalid => Lwt._return (Known_invalid, (head, []))
        | Unknown => loop history []
        end)
  end.
src/lib_base/block_locator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A type for sparse block locator (/à la/ Bitcoin). *)
type t = private raw

(** Non private version of Block_store_locator.t for coercions. *)
and raw = Block_header.t * Block_hash.t list

val raw : t -> raw

val pp : Format.formatter -> t -> unit

val pp_short : Format.formatter -> t -> unit

val encoding : t Data_encoding.t

val bounded_encoding :
  ?max_header_size:int -> ?max_length:int -> unit -> t Data_encoding.t

(** Argument to the seed used to randomize the locator. *)
type seed = {sender_id : P2p_peer.Id.t; receiver_id : P2p_peer.Id.t}

(** [estimated_length seed locator] estimate the length of the chain
    represented by [locator] using [seed]. *)
val estimated_length : seed -> t -> int

(** [compute ~get_predecessor ~caboose ~size block_hash header seed] returns
    a sparse block locator whose header is the given [header] and whose
    sparse block is computed using [seed] to compute random jumps from
    the [block_hash], adding the [caboose] at the end of the sparse block.
    The sparse block locator contains at most [size + 1] elements, including the
    caboose. *)
val compute :
  get_predecessor:(Block_hash.t -> int -> Block_hash.t option Lwt.t) ->
  caboose:Block_hash.t ->
  size:int ->
  Block_hash.t ->
  Block_header.t ->
  seed ->
  t Lwt.t

(** A 'step' in a locator is a couple of consecutive hashes in the
    locator, and the expected difference of level between the two
    blocks (or an upper bounds when [strict_step = false]). *)
type step = {
  block : Block_hash.t;
  predecessor : Block_hash.t;
  step : int;
  strict_step : bool;
}

val pp_step : Format.formatter -> step -> unit

(** [to_steps seed t] builds all the 'steps' composing the locator
    using the given [seed], starting with the oldest one
    (typically the predecessor of the first step will be the `caboose`).
    All steps contains [strict_step = true], except the oldest one. *)
val to_steps : seed -> t -> step list

(** [to_steps_truncate ~limit ~save_point seed t] behaves as [to_steps]
    except that when the sum of all the steps already done, and the steps
    to do in order to reach the next block is superior to [limit],
    we return a truncated list of steps, setting the [predecessor] of the
    last step as [save_point] and its field [strict] to [false]. *)
val to_steps_truncate :
  limit:int -> save_point:Block_hash.t -> seed -> t -> step list

(** A block can either be known valid, invalid or unknown. *)
type validity = Unknown | Known_valid | Known_invalid

(** [unknown_prefix ~is_known t] either returns :

    - [(Known_valid, (h, hist))] when we find a known valid block in the
      locator history (w.r.t. [is_known]), where [h] is the given locator header
      and [hist] is the unknown prefix ending with the known valid block.

    - [(Known_invalid, (h, hist))] when we find a known invalid block
      (w.r.t. [is_known]) in the locator history, where [h] is the given locator
      header and [hist] is the unknown prefix ending with the known invalid
      block.

    - [(Unknown, (h, hist))] when no block is known valid nor invalid (w.r.t.
      [is_known]), where [(h, hist)] is the given [locator]. *)
val unknown_prefix :
  is_known:(Block_hash.t -> validity Lwt.t) -> t -> (validity * t) Lwt.t
src/lib_base/block_locator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Reserved Notation "'t".
Reserved Notation "'raw".



where "'t" := ( 'raw)

and "'raw" := ( Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)).

Definition t := 't.
Definition raw := 'raw.

Parameter raw : t -> raw.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter pp_short : Stdlib.Format.formatter -> t -> unit.

Parameter encoding : Tezos_data_encoding.Data_encoding.t t.

Parameter bounded_encoding :
(option Z) -> (option Z) -> unit -> Tezos_data_encoding.Data_encoding.t t.

Record seed := {
  sender_id : Tezos_base.P2p_peer.Id.t;
  receiver_id : Tezos_base.P2p_peer.Id.t }.

Parameter estimated_length : seed -> t -> Z.

Parameter compute :
(Tezos_crypto.Block_hash.t -> Z -> Lwt.t (option Tezos_crypto.Block_hash.t)) ->
  Tezos_crypto.Block_hash.t ->
    Z ->
      Tezos_crypto.Block_hash.t -> Tezos_base.Block_header.t -> seed -> Lwt.t t.

Record step := {
  block : Tezos_crypto.Block_hash.t;
  predecessor : Tezos_crypto.Block_hash.t;
  step : Z;
  strict_step : bool }.

Parameter pp_step : Stdlib.Format.formatter -> step -> unit.

Parameter to_steps : seed -> t -> list step.

Parameter to_steps_truncate :
Z -> Tezos_crypto.Block_hash.t -> seed -> t -> list step.

Inductive validity : Type :=
| Unknown : validity
| Known_valid : validity
| Known_invalid : validity.

Parameter unknown_prefix :
(Tezos_crypto.Block_hash.t -> Lwt.t validity) -> t -> Lwt.t (validity * t).
src/lib_base/distributed_db_version.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Distributed_db protocol version. *)

type name = string

let pp_name = Format.pp_print_string

let name_encoding =
  let open Data_encoding in
  def
    "distributed_db_version.name"
    ~description:"A name for the distributed DB protocol"
    string

let chain_name = "TEZOS"

let sandboxed_chain_name = "SANDBOXED_TEZOS"

type t = int

let pp = Format.pp_print_int

let encoding =
  let open Data_encoding in
  def
    "distributed_db_version"
    ~description:"A version number for the distributed DB protocol"
    uint16

let zero = 0

let () =
  Data_encoding.Registration.register ~pp:pp_name name_encoding ;
  Data_encoding.Registration.register ~pp encoding
src/lib_base/distributed_db_version.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition name := string.

Definition pp_name : Stdlib.Format.formatter -> string -> unit :=
  Stdlib.Format.pp_print_string.

Definition name_encoding : Tezos_data_encoding.Data_encoding.encoding string :=
  Tezos_data_encoding.Data_encoding.def "distributed_db_version.name" % string
    None (Some "A name for the distributed DB protocol" % string)
    Tezos_data_encoding.Data_encoding.string.

Definition chain_name : string := "TEZOS" % string.

Definition sandboxed_chain_name : string := "SANDBOXED_TEZOS" % string.

Definition t := Z.

Definition pp : Stdlib.Format.formatter -> Z -> unit :=
  Stdlib.Format.pp_print_int.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
  Tezos_data_encoding.Data_encoding.def "distributed_db_version" % string None
    (Some "A version number for the distributed DB protocol" % string)
    Tezos_data_encoding.Data_encoding.uint16.

Definition zero : Z := 0.
src/lib_base/distributed_db_version.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** [Distributed_db] protocol version. *)

type name = private string

val pp_name : Format.formatter -> name -> unit

val name_encoding : name Data_encoding.t

val chain_name : name

val sandboxed_chain_name : name

(** An abstract version number for the high-level [Distributed_db] messages. *)
type t = private int

val pp : Format.formatter -> t -> unit

val encoding : t Data_encoding.t

val zero : t
src/lib_base/distributed_db_version.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition name := string.

Parameter pp_name : Stdlib.Format.formatter -> name -> unit.

Parameter name_encoding : Tezos_data_encoding.Data_encoding.t name.

Parameter chain_name : name.

Parameter sandboxed_chain_name : name.

Definition t := Z.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter encoding : Tezos_data_encoding.Data_encoding.t t.

Parameter zero : t.
src/lib_base/fitness.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Bytes.t list

include Compare.Make (struct
  type nonrec t = t

  (* Fitness comparison:
       - shortest lists are smaller ;
       - lexicographical order for lists of the same length. *)
  let compare_bytes b1 b2 =
    let len1 = Bytes.length b1 in
    let len2 = Bytes.length b2 in
    let c = compare len1 len2 in
    if c <> 0 then c
    else
      let rec compare_byte b1 b2 pos len =
        if pos = len then 0
        else
          let c = compare (Bytes.get b1 pos) (Bytes.get b2 pos) in
          if c <> 0 then c else compare_byte b1 b2 (pos + 1) len
      in
      compare_byte b1 b2 0 len1

  let compare f1 f2 =
    let rec compare_rec f1 f2 =
      match (f1, f2) with
      | ([], []) ->
          0
      | (i1 :: f1, i2 :: f2) ->
          let i = compare_bytes i1 i2 in
          if i = 0 then compare_rec f1 f2 else i
      | (_, _) ->
          assert false
    in
    let len = compare (List.length f1) (List.length f2) in
    if len = 0 then compare_rec f1 f2 else len
end)

let rec pp fmt = function
  | [] ->
      ()
  | [f] ->
      Format.fprintf fmt "%a" Hex.pp (Hex.of_bytes f)
  | f1 :: f ->
      Format.fprintf fmt "%a::%a" Hex.pp (Hex.of_bytes f1) pp f

let encoding =
  let open Data_encoding in
  def
    "fitness"
    ~title:"Block fitness"
    ~description:
      "The fitness, or score, of a block, that allow the Tezos to decide \
       which chain is the best. A fitness value is a list of byte sequences. \
       They are compared as follows: shortest lists are smaller; lists of the \
       same length are compared according to the lexicographical order."
  @@ splitted ~json:(list bytes) ~binary:(list (def "fitness.elem" bytes))

let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

let of_bytes b = Data_encoding.Binary.of_bytes encoding b
src/lib_base/fitness.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := list Stdlib.Bytes.t.

Fixpoint pp (fmt : Stdlib.Format.formatter) (function_parameter : list string)
  : unit :=
  match function_parameter with
  | [] => tt
  | cons f [] =>
    Stdlib.Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Hex.pp (Hex.of_bytes None f)
  | cons f1 f =>
    Stdlib.Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal "::" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))) "%a::%a" % string)
      Hex.pp (Hex.of_bytes None f1) pp f
  end.

Definition encoding
  : Tezos_data_encoding.Data_encoding.encoding (list Stdlib.Bytes.t) :=
  apply
    (Tezos_data_encoding.Data_encoding.def "fitness" % string
      (Some "Block fitness" % string)
      (Some
        "The fitness, or score, of a block, that allow the Tezos to decide which chain is the best. A fitness value is a list of byte sequences. They are compared as follows: shortest lists are smaller; lists of the same length are compared according to the lexicographical order."
          % string))
    (Tezos_data_encoding.Data_encoding.splitted
      (Tezos_data_encoding.Data_encoding.list None
        Tezos_data_encoding.Data_encoding.bytes)
      (Tezos_data_encoding.Data_encoding.list None
        (Tezos_data_encoding.Data_encoding.def "fitness.elem" % string None None
          Tezos_data_encoding.Data_encoding.bytes))).

Definition to_bytes (v : list Stdlib.Bytes.t) : Stdlib.Bytes.t :=
  Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn encoding v.

Definition of_bytes (b : Stdlib.Bytes.t) : option (list Stdlib.Bytes.t) :=
  Tezos_data_encoding.Data_encoding.Binary.of_bytes encoding b.
src/lib_base/mempool.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {known_valid : Operation_hash.t list; pending : Operation_hash.Set.t}

type mempool = t

let encoding =
  let open Data_encoding in
  def
    "mempool"
    ~description:
      "A batch of operation. This format is used to gossip operations between \
       peers."
  @@ conv
       (fun {known_valid; pending} -> (known_valid, pending))
       (fun (known_valid, pending) -> {known_valid; pending})
       (obj2
          (req "known_valid" (list Operation_hash.encoding))
          (req "pending" (dynamic_size Operation_hash.Set.encoding)))

let bounded_encoding ?max_operations () =
  match max_operations with
  | None ->
      encoding
  | Some max_operations ->
      Data_encoding.check_size
        (8 + (max_operations * Operation_hash.size))
        encoding

let empty = {known_valid = []; pending = Operation_hash.Set.empty}

let () = Data_encoding.Registration.register encoding
src/lib_base/mempool.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  known_valid : list Tezos_crypto.Operation_hash.t;
  pending : Tezos_crypto.Operation_hash.Set.t }.

Definition mempool := t.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "mempool" % string expected_argument
        (Some
          "A batch of operation. This format is used to gossip operations between peers."
            % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| known_valid := known_valid; pending := pending |} =>
          (known_valid, pending)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (known_valid, pending) =>
          {| known_valid := known_valid; pending := pending |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj2
        (Tezos_data_encoding.Data_encoding.req None None "known_valid" % string
          (Tezos_data_encoding.Data_encoding.list None
            Tezos_crypto.Operation_hash.encoding))
        (Tezos_data_encoding.Data_encoding.req None None "pending" % string
          (Tezos_data_encoding.Data_encoding.dynamic_size None
            Tezos_crypto.Operation_hash.Set.encoding)))).

Definition bounded_encoding
  (max_operations : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding t :=
  match function_parameter with
  | tt =>
    match max_operations with
    | None => encoding
    | Some max_operations =>
      Tezos_data_encoding.Data_encoding.check_size
        (Z.add 8 (Z.mul max_operations Tezos_crypto.Operation_hash.size))
        encoding
    end
  end.

Definition empty : t :=
  {| known_valid := []; pending := Tezos_crypto.Operation_hash.Set.empty |}.
src/lib_base/mempool.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell Module - Mempool, a.k.a. the operations safe to be broadcast. *)

type t = {
  known_valid : Operation_hash.t list;
      (** A valid sequence of operations on top of the current head. *)
  pending : Operation_hash.Set.t;  (** Set of known not-invalid operation. *)
}

type mempool = t

val encoding : mempool Data_encoding.t

val bounded_encoding : ?max_operations:int -> unit -> mempool Data_encoding.t

(** Empty mempool. *)
val empty : mempool
src/lib_base/mempool.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  known_valid : list Tezos_crypto.Operation_hash.t;
  pending : Tezos_crypto.Operation_hash.Set.t }.

Definition mempool := t.

Parameter encoding : Tezos_data_encoding.Data_encoding.t mempool.

Parameter bounded_encoding :
(option Z) -> unit -> Tezos_data_encoding.Data_encoding.t mempool.

Parameter empty : mempool.
src/lib_base/network_version.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  chain_name : Distributed_db_version.name;
  distributed_db_version : Distributed_db_version.t;
  p2p_version : P2p_version.t;
}

let pp ppf {chain_name; distributed_db_version; p2p_version} =
  Format.fprintf
    ppf
    "%a.%a (p2p: %a)"
    Distributed_db_version.pp_name
    chain_name
    Distributed_db_version.pp
    distributed_db_version
    P2p_version.pp
    p2p_version

let encoding =
  let open Data_encoding in
  def
    "network_version"
    ~description:
      "A version number for the network protocol (includes distributed DB \
       version and p2p version)"
  @@ conv
       (fun {chain_name; distributed_db_version; p2p_version} ->
         (chain_name, distributed_db_version, p2p_version))
       (fun (chain_name, distributed_db_version, p2p_version) ->
         {chain_name; distributed_db_version; p2p_version})
       (obj3
          (req "chain_name" Distributed_db_version.name_encoding)
          (req "distributed_db_version" Distributed_db_version.encoding)
          (req "p2p_version" P2p_version.encoding))

let greatest = function
  | [] ->
      raise (Invalid_argument "Network_version.greatest")
  | h :: t ->
      List.fold_left max h t

let announced ~chain_name ~distributed_db_versions ~p2p_versions =
  assert (distributed_db_versions <> []) ;
  assert (p2p_versions <> []) ;
  {
    chain_name;
    distributed_db_version = greatest distributed_db_versions;
    p2p_version = greatest p2p_versions;
  }

let may_select_version accepted_versions remote_version =
  let best_local_version = greatest accepted_versions in
  if best_local_version <= remote_version then Some best_local_version
  else if List.mem remote_version accepted_versions then Some remote_version
  else None

let select ~chain_name ~distributed_db_versions ~p2p_versions remote =
  assert (distributed_db_versions <> []) ;
  assert (p2p_versions <> []) ;
  if chain_name <> remote.chain_name then None
  else
    let open Option in
    may_select_version distributed_db_versions remote.distributed_db_version
    >>= fun distributed_db_version ->
    may_select_version p2p_versions remote.p2p_version
    >>= fun p2p_version ->
    some {chain_name; distributed_db_version; p2p_version}

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/network_version.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  chain_name : Tezos_base.Distributed_db_version.name;
  distributed_db_version : Tezos_base.Distributed_db_version.t;
  p2p_version : Tezos_base.P2p_version.t }.

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | {|
    chain_name := chain_name;
      distributed_db_version := distributed_db_version;
      p2p_version := p2p_version
      |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Char_literal "." % char
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " (p2p: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format))))))
        "%a.%a (p2p: %a)" % string) Tezos_base.Distributed_db_version.pp_name
      chain_name Tezos_base.Distributed_db_version.pp distributed_db_version
      Tezos_base.P2p_version.pp p2p_version
  end.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "network_version" % string
        expected_argument
        (Some
          "A version number for the network protocol (includes distributed DB version and p2p version)"
            % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          chain_name := chain_name;
            distributed_db_version := distributed_db_version;
            p2p_version := p2p_version
            |} => (chain_name, distributed_db_version, p2p_version)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (chain_name, distributed_db_version, p2p_version) =>
          {| chain_name := chain_name;
            distributed_db_version := distributed_db_version;
            p2p_version := p2p_version |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj3
        (Tezos_data_encoding.Data_encoding.req None None "chain_name" % string
          Tezos_base.Distributed_db_version.name_encoding)
        (Tezos_data_encoding.Data_encoding.req None None
          "distributed_db_version" % string
          Tezos_base.Distributed_db_version.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "p2p_version" % string
          Tezos_base.P2p_version.encoding))).

Definition greatest {A : Type} (function_parameter : list A) : A :=
  match function_parameter with
  | [] =>
    Stdlib.raise (OCaml.Invalid_argument "Network_version.greatest" % string)
  | cons h t => Stdlib.List.fold_left OCaml.Stdlib.max h t
  end.

Definition announced
  (chain_name : Tezos_base.Distributed_db_version.name)
  (distributed_db_versions : list Tezos_base.Distributed_db_version.t)
  (p2p_versions : list Tezos_base.P2p_version.t) : t :=
  nequiv_decb distributed_db_versions [];
  nequiv_decb p2p_versions [];
  {| chain_name := chain_name;
    distributed_db_version := greatest distributed_db_versions;
    p2p_version := greatest p2p_versions |}.

Definition may_select_version {A : Type}
  (accepted_versions : list A) (remote_version : A) : option A :=
  let best_local_version := greatest accepted_versions in
  if OCaml.Stdlib.le best_local_version remote_version then
    Some best_local_version
  else
    if Stdlib.List.mem remote_version accepted_versions then
      Some remote_version
    else
      None.

Definition select
  (chain_name : Tezos_base.Distributed_db_version.name)
  (distributed_db_versions : list Tezos_base.Distributed_db_version.t)
  (p2p_versions : list Tezos_base.P2p_version.t) (remote : t) : option t :=
  nequiv_decb distributed_db_versions [];
  nequiv_decb p2p_versions [];
  if nequiv_decb chain_name (chain_name remote) then
    None
  else
    Tezos_stdlib.Option.op_gt_gt_eq
      (may_select_version distributed_db_versions
        (distributed_db_version remote))
      (fun distributed_db_version =>
        Tezos_stdlib.Option.op_gt_gt_eq
          (may_select_version p2p_versions (p2p_version remote))
          (fun p2p_version =>
            Tezos_stdlib.Option.some
              {| chain_name := chain_name;
                distributed_db_version := distributed_db_version;
                p2p_version := p2p_version |})).
src/lib_base/network_version.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  chain_name : Distributed_db_version.name;
  distributed_db_version : Distributed_db_version.t;
  p2p_version : P2p_version.t;
}

val pp : Format.formatter -> t -> unit

val encoding : t Data_encoding.t

(** [announced supported] computes the network protocol version
    announced on peer connection, given the [supported] versions for
    the higher-level messages. *)
val announced :
  chain_name:Distributed_db_version.name ->
  distributed_db_versions:Distributed_db_version.t list ->
  p2p_versions:P2p_version.t list ->
  t

(** [select acceptables remote] computes network protocol version to
    be used on a given connection where [remote] is version announced
    by the remote peer, and [acceptables] the locally accepted
    versions for the higher-level messages. *)
val select :
  chain_name:Distributed_db_version.name ->
  distributed_db_versions:Distributed_db_version.t list ->
  p2p_versions:P2p_version.t list ->
  t ->
  t option
src/lib_base/network_version.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  chain_name : Tezos_base.Distributed_db_version.name;
  distributed_db_version : Tezos_base.Distributed_db_version.t;
  p2p_version : Tezos_base.P2p_version.t }.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter encoding : Tezos_data_encoding.Data_encoding.t t.

Parameter announced :
Tezos_base.Distributed_db_version.name ->
  (list Tezos_base.Distributed_db_version.t) ->
    (list Tezos_base.P2p_version.t) -> t.

Parameter select :
Tezos_base.Distributed_db_version.name ->
  (list Tezos_base.Distributed_db_version.t) ->
    (list Tezos_base.P2p_version.t) -> t -> option t.
src/lib_base/operation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type shell_header = {branch : Block_hash.t}

let shell_header_encoding =
  let open Data_encoding in
  def "operation.shell_header" ~description:"An operation's shell header."
  @@ conv
       (fun {branch} -> branch)
       (fun branch -> {branch})
       (obj1 (req "branch" Block_hash.encoding))

type t = {shell : shell_header; proto : Bytes.t}

include Compare.Make (struct
  type nonrec t = t

  let compare o1 o2 =
    let ( >> ) x y = if x = 0 then y () else x in
    Block_hash.compare o1.shell.branch o1.shell.branch
    >> fun () -> Bytes.compare o1.proto o2.proto
end)

let encoding =
  let open Data_encoding in
  def
    "operation"
    ~description:
      "An operation. The shell_header part indicates a block an operation is \
       meant to apply on top of. The proto part is protocol-specific and \
       appears as a binary blob."
  @@ conv
       (fun {shell; proto} -> (shell, proto))
       (fun (shell, proto) -> {shell; proto})
       (merge_objs shell_header_encoding (obj1 (req "data" Variable.bytes)))

let bounded_encoding ?max_size () =
  match max_size with
  | None ->
      encoding
  | Some max_size ->
      Data_encoding.check_size max_size encoding

let bounded_list_encoding ?max_length ?max_size ?max_operation_size ?max_pass
    () =
  let open Data_encoding in
  let op_encoding = bounded_encoding ?max_size:max_operation_size () in
  let op_list_encoding =
    match max_size with
    | None ->
        Variable.list ?max_length (dynamic_size op_encoding)
    | Some max_size ->
        check_size
          max_size
          (Variable.list ?max_length (dynamic_size op_encoding))
  in
  obj2
    (req
       "operation_hashes_path"
       (Operation_list_list_hash.bounded_path_encoding ?max_length:max_pass ()))
    (req "operations" op_list_encoding)

let bounded_hash_list_encoding ?max_length ?max_pass () =
  let open Data_encoding in
  obj2
    (req
       "operation_hashes_path"
       (Operation_list_list_hash.bounded_path_encoding ?max_length:max_pass ()))
    (req "operation_hashes" (Variable.list ?max_length Operation_hash.encoding))

let pp fmt op =
  Data_encoding.Json.pp fmt (Data_encoding.Json.construct encoding op)

let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

let of_bytes b = Data_encoding.Binary.of_bytes encoding b

let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b

let hash op = Operation_hash.hash_bytes [to_bytes op]

let hash_raw bytes = Operation_hash.hash_bytes [bytes]

let () =
  Data_encoding.Registration.register ~pp encoding ;
  Data_encoding.Registration.register shell_header_encoding
src/lib_base/operation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record shell_header := {
  branch : Tezos_crypto.Block_hash.t }.

Definition shell_header_encoding
  : Tezos_data_encoding.Data_encoding.encoding shell_header :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "operation.shell_header" % string
        expected_argument (Some "An operation's shell header." % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| branch := branch |} => branch
        end) (fun branch => {| branch := branch |}) None
      (Tezos_data_encoding.Data_encoding.obj1
        (Tezos_data_encoding.Data_encoding.req None None "branch" % string
          Tezos_crypto.Block_hash.encoding))).

Record t := {
  shell : shell_header;
  proto : Stdlib.Bytes.t }.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "operation" % string
        expected_argument
        (Some
          "An operation. The shell_header part indicates a block an operation is meant to apply on top of. The proto part is protocol-specific and appears as a binary blob."
            % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| shell := shell; proto := proto |} => (shell, proto)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (shell, proto) => {| shell := shell; proto := proto |}
        end) None
      (Tezos_data_encoding.Data_encoding.merge_objs shell_header_encoding
        (Tezos_data_encoding.Data_encoding.obj1
          (Tezos_data_encoding.Data_encoding.req None None "data" % string
            Tezos_data_encoding.Data_encoding.Variable.bytes)))).

Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding t :=
  match function_parameter with
  | tt =>
    match max_size with
    | None => encoding
    | Some max_size =>
      Tezos_data_encoding.Data_encoding.check_size max_size encoding
    end
  end.

Definition bounded_list_encoding
  (max_length : option Z) (max_size : option Z) (max_operation_size : option Z)
  (max_pass : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_crypto.Operation_list_list_hash.path * (list t)) :=
  match function_parameter with
  | tt =>
    let op_encoding := bounded_encoding max_operation_size tt in
    let op_list_encoding :=
      match max_size with
      | None =>
        Tezos_data_encoding.Data_encoding.Variable.list max_length
          (Tezos_data_encoding.Data_encoding.dynamic_size None op_encoding)
      | Some max_size =>
        Tezos_data_encoding.Data_encoding.check_size max_size
          (Tezos_data_encoding.Data_encoding.Variable.list max_length
            (Tezos_data_encoding.Data_encoding.dynamic_size None op_encoding))
      end in
    Tezos_data_encoding.Data_encoding.obj2
      (Tezos_data_encoding.Data_encoding.req None None
        "operation_hashes_path" % string
        (Tezos_crypto.Operation_list_list_hash.bounded_path_encoding max_pass tt))
      (Tezos_data_encoding.Data_encoding.req None None "operations" % string
        op_list_encoding)
  end.

Definition bounded_hash_list_encoding
  (max_length : option Z) (max_pass : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_crypto.Operation_list_list_hash.path *
      (list Tezos_crypto.Operation_hash.t)) :=
  match function_parameter with
  | tt =>
    Tezos_data_encoding.Data_encoding.obj2
      (Tezos_data_encoding.Data_encoding.req None None
        "operation_hashes_path" % string
        (Tezos_crypto.Operation_list_list_hash.bounded_path_encoding max_pass tt))
      (Tezos_data_encoding.Data_encoding.req None None
        "operation_hashes" % string
        (Tezos_data_encoding.Data_encoding.Variable.list max_length
          Tezos_crypto.Operation_hash.encoding))
  end.

Definition pp (fmt : Stdlib.Format.formatter) (op : t) : unit :=
  Tezos_data_encoding.Data_encoding.Json.pp fmt
    (Tezos_data_encoding.Data_encoding.Json.construct encoding op).

Definition to_bytes (v : t) : Stdlib.Bytes.t :=
  Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn encoding v.

Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
  Tezos_data_encoding.Data_encoding.Binary.of_bytes encoding b.

Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
  Tezos_data_encoding.Data_encoding.Binary.of_bytes_exn encoding b.

Definition hash (op : t) : Tezos_crypto.Operation_hash.t :=
  Tezos_crypto.Operation_hash.hash_bytes None (cons (to_bytes op) []).

Definition hash_raw (bytes : Stdlib.Bytes.t) : Tezos_crypto.Operation_hash.t :=
  Tezos_crypto.Operation_hash.hash_bytes None (cons string []).
src/lib_base/operation.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type shell_header = {branch : Block_hash.t}

val shell_header_encoding : shell_header Data_encoding.t

type t = {shell : shell_header; proto : Bytes.t}

include S.HASHABLE with type t := t and type hash := Operation_hash.t

val of_bytes_exn : Bytes.t -> t

val bounded_encoding : ?max_size:int -> unit -> t Data_encoding.t

val bounded_list_encoding :
  ?max_length:int ->
  ?max_size:int ->
  ?max_operation_size:int ->
  ?max_pass:int ->
  unit ->
  (Operation_list_list_hash.path * t list) Data_encoding.t

val bounded_hash_list_encoding :
  ?max_length:int ->
  ?max_pass:int ->
  unit ->
  (Operation_list_list_hash.path * Operation_hash.t list) Data_encoding.t
src/lib_base/operation.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record shell_header := {
  branch : Tezos_crypto.Block_hash.t }.

Parameter shell_header_encoding :
Tezos_data_encoding.Data_encoding.t shell_header.

Record t := {
  shell : shell_header;
  proto : Stdlib.Bytes.t }.

Parameter of_bytes_exn : Stdlib.Bytes.t -> t.

Parameter bounded_encoding :
(option Z) -> unit -> Tezos_data_encoding.Data_encoding.t t.

Parameter bounded_list_encoding :
(option Z) ->
  (option Z) ->
    (option Z) ->
      (option Z) ->
        unit ->
          Tezos_data_encoding.Data_encoding.t
            (Tezos_crypto.Operation_list_list_hash.path * (list t)).

Parameter bounded_hash_list_encoding :
(option Z) ->
  (option Z) ->
    unit ->
      Tezos_data_encoding.Data_encoding.t
        (Tezos_crypto.Operation_list_list_hash.path *
          (list Tezos_crypto.Operation_hash.t)).
src/lib_base/p2p_addr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Ipaddr.V6.t

let encoding =
  let open Data_encoding in
  def "p2p_address" ~description:"An address for locating peers."
  @@ splitted
       ~json:(conv Ipaddr.V6.to_string Ipaddr.V6.of_string_exn string)
       ~binary:(conv Ipaddr.V6.to_octets Ipaddr.V6.of_octets_exn string)

type port = int

let pp ppf addr =
  match Ipaddr.v4_of_v6 addr with
  | Some addr ->
      Format.fprintf ppf "%a" Ipaddr.V4.pp addr
  | None ->
      Format.fprintf ppf "[%a]" Ipaddr.V6.pp addr

let of_string_opt str =
  match Ipaddr.of_string str with
  | Ok (Ipaddr.V4 addr) ->
      Some (Ipaddr.v6_of_v4 addr)
  | Ok (V6 addr) ->
      Some addr
  | Error (`Msg _) ->
      None

let of_string_exn str =
  match of_string_opt str with
  | None ->
      Pervasives.failwith "P2p_addr.of_string"
  | Some t ->
      t

let to_string saddr = Format.asprintf "%a" pp saddr

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_addr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Ipaddr.V6.t.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding Ipaddr.V6.t :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "p2p_address" % string
        expected_argument (Some "An address for locating peers." % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.splitted
      (Tezos_data_encoding.Data_encoding.conv Ipaddr.V6.to_string
        Ipaddr.V6.of_string_exn None Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.conv Ipaddr.V6.to_octets
        (let arg := Ipaddr.V6.of_octets_exn in
        fun eta => arg None eta) None Tezos_data_encoding.Data_encoding.string)).

Definition port := Z.

Definition pp (ppf : Stdlib.Format.formatter) (addr : Ipaddr.V6.t) : unit :=
  match Ipaddr.v4_of_v6 addr with
  | Some addr =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Ipaddr.V4.pp addr
  | None =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "]" % char
              CamlinternalFormatBasics.End_of_format))) "[%a]" % string)
      Ipaddr.V6.pp addr
  end.

Definition of_string_opt (str : string) : option Ipaddr.V6.t :=
  match Ipaddr.of_string str with
  | inl (Ipaddr.V4 addr) => Some (Ipaddr.v6_of_v4 addr)
  | inl (V6 addr) => Some addr
  | inr (Msg _) => None
  end.

Definition of_string_exn (str : string) : Ipaddr.V6.t :=
  match of_string_opt str with
  | None => Stdlib.Pervasives.failwith "P2p_addr.of_string" % string
  | Some t => t
  end.

Definition to_string (saddr : Ipaddr.V6.t) : string :=
  Stdlib.Format.asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
      "%a" % string) pp saddr.
src/lib_base/p2p_addr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Ipaddr.V6.t

type port = int

val encoding : t Data_encoding.t

val pp : Format.formatter -> t -> unit

val of_string_opt : string -> t option

val of_string_exn : string -> t

val to_string : t -> string
src/lib_base/p2p_addr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Ipaddr.V6.t.

Definition port := Z.

Parameter encoding : Tezos_data_encoding.Data_encoding.t t.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter of_string_opt : string -> option t.

Parameter of_string_exn : string -> t.

Parameter to_string : t -> string.
src/lib_base/p2p_connection.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id = struct
  (* A net point (address x port). *)
  type t = P2p_addr.t * P2p_addr.port option

  let compare (a1, p1) (a2, p2) =
    match Ipaddr.V6.compare a1 a2 with 0 -> Pervasives.compare p1 p2 | x -> x

  let equal p1 p2 = compare p1 p2 = 0

  let hash = Hashtbl.hash

  let pp ppf (addr, port) =
    match port with
    | None ->
        Format.fprintf ppf "[%a]:??" Ipaddr.V6.pp addr
    | Some port ->
        Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp addr port

  let pp_opt ppf = function
    | None ->
        Format.pp_print_string ppf "none"
    | Some point ->
        pp ppf point

  let to_string t = Format.asprintf "%a" pp t

  let is_local (addr, _) = Ipaddr.V6.is_private addr

  let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr

  let of_point (addr, port) = (addr, Some port)

  let to_point = function
    | (_, None) ->
        None
    | (addr, Some port) ->
        Some (addr, port)

  let to_point_exn = function
    | (_, None) ->
        invalid_arg "to_point_exn"
    | (addr, Some port) ->
        (addr, port)

  let encoding =
    let open Data_encoding in
    def
      "p2p_connection.id"
      ~description:
        "The identifier for a p2p connection. It includes an address and a \
         port number."
    @@ obj2 (req "addr" P2p_addr.encoding) (opt "port" uint16)
end

module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)

module Info = struct
  type 'meta t = {
    incoming : bool;
    peer_id : P2p_peer_id.t;
    id_point : Id.t;
    remote_socket_port : P2p_addr.port;
    announced_version : Network_version.t;
    private_node : bool;
    local_metadata : 'meta;
    remote_metadata : 'meta;
  }

  let encoding metadata_encoding =
    let open Data_encoding in
    conv
      (fun { incoming;
             peer_id;
             id_point;
             remote_socket_port;
             announced_version;
             private_node;
             local_metadata;
             remote_metadata } ->
        ( incoming,
          peer_id,
          id_point,
          remote_socket_port,
          announced_version,
          private_node,
          local_metadata,
          remote_metadata ))
      (fun ( incoming,
             peer_id,
             id_point,
             remote_socket_port,
             announced_version,
             private_node,
             local_metadata,
             remote_metadata ) ->
        {
          incoming;
          peer_id;
          id_point;
          remote_socket_port;
          announced_version;
          private_node;
          local_metadata;
          remote_metadata;
        })
      (obj8
         (req "incoming" bool)
         (req "peer_id" P2p_peer_id.encoding)
         (req "id_point" Id.encoding)
         (req "remote_socket_port" uint16)
         (req "announced_version" Network_version.encoding)
         (req "private" bool)
         (req "local_metadata" metadata_encoding)
         (req "remote_metadata" metadata_encoding))

  let pp pp_meta ppf
      { incoming;
        id_point = (remote_addr, remote_port);
        remote_socket_port;
        peer_id;
        announced_version;
        private_node;
        local_metadata = _;
        remote_metadata } =
    let point =
      match remote_port with
      | None ->
          (remote_addr, remote_socket_port)
      | Some port ->
          (remote_addr, port)
    in
    Format.fprintf
      ppf
      "%s %a %a (%a) %s%a"
      (if incoming then "↘" else "↗")
      P2p_peer_id.pp
      peer_id
      P2p_point.Id.pp
      point
      Network_version.pp
      announced_version
      (if private_node then " private" else "")
      pp_meta
      remote_metadata
end

module Pool_event = struct
  (** Pool-level events *)

  type t =
    | Too_few_connections
    | Too_many_connections
    | New_point of P2p_point.Id.t
    | New_peer of P2p_peer_id.t
    | Gc_points
    | Gc_peer_ids
    | Incoming_connection of P2p_point.Id.t
    | Outgoing_connection of P2p_point.Id.t
    | Authentication_failed of P2p_point.Id.t
    | Accepting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
    | Rejecting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
    | Request_rejected of P2p_point.Id.t * (Id.t * P2p_peer_id.t) option
    | Connection_established of Id.t * P2p_peer_id.t
    | Swap_request_received of {source : P2p_peer_id.t}
    | Swap_ack_received of {source : P2p_peer_id.t}
    | Swap_request_sent of {source : P2p_peer_id.t}
    | Swap_ack_sent of {source : P2p_peer_id.t}
    | Swap_request_ignored of {source : P2p_peer_id.t}
    | Swap_success of {source : P2p_peer_id.t}
    | Swap_failure of {source : P2p_peer_id.t}
    | Disconnection of P2p_peer_id.t
    | External_disconnection of P2p_peer_id.t

  let pp ppf (event : t) =
    match event with
    | Too_few_connections ->
        Format.pp_print_string ppf "Too_few_connections"
    | Too_many_connections ->
        Format.pp_print_string ppf "Too_many_connections"
    | New_point p ->
        Format.pp_print_string ppf "New_point " ;
        P2p_point.Id.pp ppf p
    | New_peer p ->
        Format.pp_print_string ppf "New_peer " ;
        P2p_peer_id.pp ppf p
    | Gc_points ->
        Format.pp_print_string ppf "Gc_points"
    | Gc_peer_ids ->
        Format.pp_print_string ppf "Gc_peer_ids"
    | Incoming_connection p ->
        Format.pp_print_string ppf "Incoming_connection " ;
        P2p_point.Id.pp ppf p
    | Outgoing_connection p ->
        Format.pp_print_string ppf "Outgoing_connection " ;
        P2p_point.Id.pp ppf p
    | Authentication_failed p ->
        Format.pp_print_string ppf "Authentication_failed " ;
        P2p_point.Id.pp ppf p
    | Accepting_request (pi, _, _) ->
        Format.pp_print_string ppf "Accepting_request " ;
        P2p_point.Id.pp ppf pi
    | Rejecting_request (pi, _, _) ->
        Format.pp_print_string ppf "Rejecting_request " ;
        P2p_point.Id.pp ppf pi
    | Request_rejected (pi, _) ->
        Format.pp_print_string ppf "Request_rejected " ;
        P2p_point.Id.pp ppf pi
    | Connection_established (_, pi) ->
        Format.pp_print_string ppf "Connection_established " ;
        P2p_peer_id.pp ppf pi
    | Swap_request_received {source} ->
        Format.pp_print_string ppf "Swap_request_received " ;
        P2p_peer_id.pp ppf source
    | Swap_ack_received {source} ->
        Format.pp_print_string ppf "Swap_ack_received " ;
        P2p_peer_id.pp ppf source
    | Swap_request_sent {source} ->
        Format.pp_print_string ppf "Swap_request_sent " ;
        P2p_peer_id.pp ppf source
    | Swap_ack_sent {source} ->
        Format.pp_print_string ppf "Swap_ack_sent " ;
        P2p_peer_id.pp ppf source
    | Swap_request_ignored {source} ->
        Format.pp_print_string ppf "Swap_request_ignored " ;
        P2p_peer_id.pp ppf source
    | Swap_success {source} ->
        Format.pp_print_string ppf "Swap_success " ;
        P2p_peer_id.pp ppf source
    | Swap_failure {source} ->
        Format.pp_print_string ppf "Swap_failure " ;
        P2p_peer_id.pp ppf source
    | Disconnection source ->
        Format.pp_print_string ppf "Disconnection " ;
        P2p_peer_id.pp ppf source
    | External_disconnection source ->
        Format.pp_print_string ppf "External_disconnection " ;
        P2p_peer_id.pp ppf source

  let encoding =
    let open Data_encoding in
    let branch_encoding name obj =
      conv
        (fun x -> ((), x))
        (fun ((), x) -> x)
        (merge_objs (obj1 (req "event" (constant name))) obj)
    in
    def
      "p2p_connection.pool_event"
      ~description:
        "An event that may happen during maintenance of and other operations \
         on the p2p connection pool. Typically, it includes connection \
         errors, peer swaps, etc."
    @@ union
         ~tag_size:`Uint8
         [ case
             (Tag 0)
             ~title:"Too_few_connections"
             (branch_encoding "too_few_connections" empty)
             (function Too_few_connections -> Some () | _ -> None)
             (fun () -> Too_few_connections);
           case
             (Tag 1)
             ~title:"Too_many_connections"
             (branch_encoding "too_many_connections" empty)
             (function Too_many_connections -> Some () | _ -> None)
             (fun () -> Too_many_connections);
           case
             (Tag 2)
             ~title:"New_point"
             (branch_encoding
                "new_point"
                (obj1 (req "point" P2p_point.Id.encoding)))
             (function New_point p -> Some p | _ -> None)
             (fun p -> New_point p);
           case
             (Tag 3)
             ~title:"New_peer"
             (branch_encoding
                "new_peer"
                (obj1 (req "peer_id" P2p_peer_id.encoding)))
             (function New_peer p -> Some p | _ -> None)
             (fun p -> New_peer p);
           case
             (Tag 4)
             ~title:"Incoming_connection"
             (branch_encoding
                "incoming_connection"
                (obj1 (req "point" P2p_point.Id.encoding)))
             (function Incoming_connection p -> Some p | _ -> None)
             (fun p -> Incoming_connection p);
           case
             (Tag 5)
             ~title:"Outgoing_connection"
             (branch_encoding
                "outgoing_connection"
                (obj1 (req "point" P2p_point.Id.encoding)))
             (function Outgoing_connection p -> Some p | _ -> None)
             (fun p -> Outgoing_connection p);
           case
             (Tag 6)
             ~title:"Authentication_failed"
             (branch_encoding
                "authentication_failed"
                (obj1 (req "point" P2p_point.Id.encoding)))
             (function Authentication_failed p -> Some p | _ -> None)
             (fun p -> Authentication_failed p);
           case
             (Tag 7)
             ~title:"Accepting_request"
             (branch_encoding
                "accepting_request"
                (obj3
                   (req "point" P2p_point.Id.encoding)
                   (req "id_point" Id.encoding)
                   (req "peer_id" P2p_peer_id.encoding)))
             (function
               | Accepting_request (p, id_p, g) ->
                   Some (p, id_p, g)
               | _ ->
                   None)
             (fun (p, id_p, g) -> Accepting_request (p, id_p, g));
           case
             (Tag 8)
             ~title:"Rejecting_request"
             (branch_encoding
                "rejecting_request"
                (obj3
                   (req "point" P2p_point.Id.encoding)
                   (req "id_point" Id.encoding)
                   (req "peer_id" P2p_peer_id.encoding)))
             (function
               | Rejecting_request (p, id_p, g) ->
                   Some (p, id_p, g)
               | _ ->
                   None)
             (fun (p, id_p, g) -> Rejecting_request (p, id_p, g));
           case
             (Tag 9)
             ~title:"Request_rejected"
             (branch_encoding
                "request_rejected"
                (obj2
                   (req "point" P2p_point.Id.encoding)
                   (opt "identity" (tup2 Id.encoding P2p_peer_id.encoding))))
             (function Request_rejected (p, id) -> Some (p, id) | _ -> None)
             (fun (p, id) -> Request_rejected (p, id));
           case
             (Tag 10)
             ~title:"Connection_established"
             (branch_encoding
                "connection_established"
                (obj2
                   (req "id_point" Id.encoding)
                   (req "peer_id" P2p_peer_id.encoding)))
             (function
               | Connection_established (id_p, g) -> Some (id_p, g) | _ -> None)
             (fun (id_p, g) -> Connection_established (id_p, g));
           case
             (Tag 11)
             ~title:"Disconnection"
             (branch_encoding
                "disconnection"
                (obj1 (req "peer_id" P2p_peer_id.encoding)))
             (function Disconnection g -> Some g | _ -> None)
             (fun g -> Disconnection g);
           case
             (Tag 12)
             ~title:"External_disconnection"
             (branch_encoding
                "external_disconnection"
                (obj1 (req "peer_id" P2p_peer_id.encoding)))
             (function External_disconnection g -> Some g | _ -> None)
             (fun g -> External_disconnection g);
           case
             (Tag 13)
             ~title:"Gc_points"
             (branch_encoding "gc_points" empty)
             (function Gc_points -> Some () | _ -> None)
             (fun () -> Gc_points);
           case
             (Tag 14)
             ~title:"Gc_peer_ids"
             (branch_encoding "gc_peer_ids" empty)
             (function Gc_peer_ids -> Some () | _ -> None)
             (fun () -> Gc_peer_ids);
           case
             (Tag 15)
             ~title:"Swap_request_received"
             (branch_encoding
                "swap_request_received"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function
               | Swap_request_received {source} -> Some source | _ -> None)
             (fun source -> Swap_request_received {source});
           case
             (Tag 16)
             ~title:"Swap_ack_received"
             (branch_encoding
                "swap_ack_received"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_ack_received {source} -> Some source | _ -> None)
             (fun source -> Swap_ack_received {source});
           case
             (Tag 17)
             ~title:"Swap_request_sent"
             (branch_encoding
                "swap_request_sent"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_request_sent {source} -> Some source | _ -> None)
             (fun source -> Swap_request_sent {source});
           case
             (Tag 18)
             ~title:"Swap_ack_sent"
             (branch_encoding
                "swap_ack_sent"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_ack_sent {source} -> Some source | _ -> None)
             (fun source -> Swap_ack_sent {source});
           case
             (Tag 19)
             ~title:"Swap_request_ignored"
             (branch_encoding
                "swap_request_ignored"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function
               | Swap_request_ignored {source} -> Some source | _ -> None)
             (fun source -> Swap_request_ignored {source});
           case
             (Tag 20)
             ~title:"Swap_success"
             (branch_encoding
                "swap_success"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_success {source} -> Some source | _ -> None)
             (fun source -> Swap_success {source});
           case
             (Tag 21)
             ~title:"Swap_failure"
             (branch_encoding
                "swap_failure"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_failure {source} -> Some source | _ -> None)
             (fun source -> Swap_failure {source}) ]
end

let () =
  Data_encoding.Registration.register ~pp:Id.pp Id.encoding ;
  Data_encoding.Registration.register ~pp:Pool_event.pp Pool_event.encoding
src/lib_base/p2p_connection.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Id.
  Definition t := Tezos_base.P2p_addr.t * (option Tezos_base.P2p_addr.port).
  
  Definition compare {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : (Ipaddr.V6.t * A) -> Z :=
    match function_parameter with
    | (a1, p1) =>
      fun function_parameter =>
        match function_parameter with
        | (a2, p2) =>
          match Ipaddr.V6.compare a1 a2 with
          | 0 => Stdlib.Pervasives.compare p1 p2
          | x => x
          end
        end
    end.
  
  Definition equal {A : Type} (p1 : Ipaddr.V6.t * A) (p2 : Ipaddr.V6.t * A)
    : bool := equiv_decb (compare p1 p2) 0.
  
  Definition hash {A : Type} : A -> Z := Stdlib.Hashtbl.hash.
  
  Definition pp
    (ppf : Stdlib.Format.formatter)
    (function_parameter : Ipaddr.V6.t * (option Z)) : unit :=
    match function_parameter with
    | (addr, port) =>
      match port with
      | None =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal "]:??" % string
                  CamlinternalFormatBasics.End_of_format))) "[%a]:??" % string)
          Ipaddr.V6.pp addr
      | Some port =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal "]:" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format))))
            "[%a]:%d" % string) Ipaddr.V6.pp addr port
      end
    end.
  
  Definition pp_opt
    (ppf : Stdlib.Format.formatter)
    (function_parameter : option (Ipaddr.V6.t * (option Z))) : unit :=
    match function_parameter with
    | None => Stdlib.Format.pp_print_string ppf "none" % string
    | Some point => pp ppf point
    end.
  
  Definition to_string (t : Ipaddr.V6.t * (option Z)) : string :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) pp t.
  
  Definition is_local {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : bool :=
    match function_parameter with
    | (addr, _) => Ipaddr.V6.is_private addr
    end.
  
  Definition is_global {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : bool :=
    match function_parameter with
    | (addr, _) => apply negb (Ipaddr.V6.is_private addr)
    end.
  
  Definition of_point {A B : Type} (function_parameter : A * B)
    : A * (option B) :=
    match function_parameter with
    | (addr, port) => (addr, (Some port))
    end.
  
  Definition to_point {A B : Type} (function_parameter : A * (option B))
    : option (A * B) :=
    match function_parameter with
    | (_, None) => None
    | (addr, Some port) => Some (addr, port)
    end.
  
  Definition to_point_exn {A B : Type} (function_parameter : A * (option B))
    : A * B :=
    match function_parameter with
    | (_, None) => OCaml.Stdlib.invalid_arg "to_point_exn" % string
    | (addr, Some port) => (addr, port)
    end.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.encoding
      (Tezos_base.P2p_addr.t * (option Z)) :=
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "p2p_connection.id" % string
          expected_argument
          (Some
            "The identifier for a p2p connection. It includes an address and a port number."
              % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.obj2
        (Tezos_data_encoding.Data_encoding.req None None "addr" % string
          Tezos_base.P2p_addr.encoding)
        (Tezos_data_encoding.Data_encoding.opt None None "port" % string
          Tezos_data_encoding.Data_encoding.uint16)).
End Id.

Module Info.
  Record t {meta : Type} := {
    incoming : bool;
    peer_id : Tezos_base.P2p_peer_id.t;
    id_point : Id.t;
    remote_socket_port : Tezos_base.P2p_addr.port;
    announced_version : Tezos_base.Network_version.t;
    private_node : bool;
    local_metadata : meta;
    remote_metadata : meta }.
  Arguments t : clear implicits.
  
  Definition encoding {A : Type}
    (metadata_encoding : Tezos_data_encoding.Data_encoding.encoding A)
    : Tezos_data_encoding.Data_encoding.encoding (t A) :=
    Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          incoming := incoming;
            peer_id := peer_id;
            id_point := id_point;
            remote_socket_port := remote_socket_port;
            announced_version := announced_version;
            private_node := private_node;
            local_metadata := local_metadata;
            remote_metadata := remote_metadata
            |} =>
          (incoming, peer_id, id_point, remote_socket_port, announced_version,
            private_node, local_metadata, remote_metadata)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (incoming, peer_id, id_point, remote_socket_port, announced_version,
            private_node, local_metadata, remote_metadata) =>
          {| incoming := incoming; peer_id := peer_id; id_point := id_point;
            remote_socket_port := remote_socket_port;
            announced_version := announced_version;
            private_node := private_node; local_metadata := local_metadata;
            remote_metadata := remote_metadata |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj8
        (Tezos_data_encoding.Data_encoding.req None None "incoming" % string
          Tezos_data_encoding.Data_encoding.bool)
        (Tezos_data_encoding.Data_encoding.req None None "peer_id" % string
          Tezos_base.P2p_peer_id.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "id_point" % string
          Id.encoding)
        (Tezos_data_encoding.Data_encoding.req None None
          "remote_socket_port" % string Tezos_data_encoding.Data_encoding.uint16)
        (Tezos_data_encoding.Data_encoding.req None None
          "announced_version" % string Tezos_base.Network_version.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "private" % string
          Tezos_data_encoding.Data_encoding.bool)
        (Tezos_data_encoding.Data_encoding.req None None
          "local_metadata" % string metadata_encoding)
        (Tezos_data_encoding.Data_encoding.req None None
          "remote_metadata" % string metadata_encoding)).
  
  Definition pp {A : Type}
    (pp_meta : Stdlib.Format.formatter -> A -> unit)
    (ppf : Stdlib.Format.formatter) (function_parameter : t A) : unit :=
    match function_parameter with
    | {|
      incoming := incoming;
        peer_id := peer_id;
        id_point := (remote_addr, remote_port);
        remote_socket_port := remote_socket_port;
        announced_version := announced_version;
        private_node := private_node;
        local_metadata := _;
        remote_metadata := remote_metadata
        |} =>
      let point :=
        match remote_port with
        | None => (remote_addr, remote_socket_port)
        | Some port => (remote_addr, port)
        end in
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal " " % char
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal " (" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal ") " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))))))))))
          "%s %a %a (%a) %s%a" % string)
        (if incoming then
          "↘" % string
        else
          "↗" % string) Tezos_base.P2p_peer_id.pp peer_id
        Tezos_base.P2p_point.Id.pp point Tezos_base.Network_version.pp
        announced_version
        (if private_node then
          " private" % string
        else
          "" % string) pp_meta remote_metadata
    end.
End Info.

Module Pool_event.
  Inductive t : Type :=
  | Too_few_connections : t
  | Too_many_connections : t
  | New_point : Tezos_base.P2p_point.Id.t -> t
  | New_peer : Tezos_base.P2p_peer_id.t -> t
  | Gc_points : t
  | Gc_peer_ids : t
  | Incoming_connection : Tezos_base.P2p_point.Id.t -> t
  | Outgoing_connection : Tezos_base.P2p_point.Id.t -> t
  | Authentication_failed : Tezos_base.P2p_point.Id.t -> t
  | Accepting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
    Tezos_base.P2p_peer_id.t -> t
  | Rejecting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
    Tezos_base.P2p_peer_id.t -> t
  | Request_rejected : Tezos_base.P2p_point.Id.t ->
    (option (Id.t * Tezos_base.P2p_peer_id.t)) -> t
  | Connection_established : Id.t -> Tezos_base.P2p_peer_id.t -> t
  | Swap_request_received : Tezos_base.P2p_peer_id.t -> t
  | Swap_ack_received : Tezos_base.P2p_peer_id.t -> t
  | Swap_request_sent : Tezos_base.P2p_peer_id.t -> t
  | Swap_ack_sent : Tezos_base.P2p_peer_id.t -> t
  | Swap_request_ignored : Tezos_base.P2p_peer_id.t -> t
  | Swap_success : Tezos_base.P2p_peer_id.t -> t
  | Swap_failure : Tezos_base.P2p_peer_id.t -> t
  | Disconnection : Tezos_base.P2p_peer_id.t -> t
  | External_disconnection : Tezos_base.P2p_peer_id.t -> t.
  
  Definition pp (ppf : Stdlib.Format.formatter) (event : t) : unit :=
    match event with
    | Too_few_connections =>
      Stdlib.Format.pp_print_string ppf "Too_few_connections" % string
    | Too_many_connections =>
      Stdlib.Format.pp_print_string ppf "Too_many_connections" % string
    | New_point p =>
      Stdlib.Format.pp_print_string ppf "New_point " % string;
      Tezos_base.P2p_point.Id.pp ppf p
    | New_peer p =>
      Stdlib.Format.pp_print_string ppf "New_peer " % string;
      Tezos_base.P2p_peer_id.pp ppf p
    | Gc_points => Stdlib.Format.pp_print_string ppf "Gc_points" % string
    | Gc_peer_ids => Stdlib.Format.pp_print_string ppf "Gc_peer_ids" % string
    | Incoming_connection p =>
      Stdlib.Format.pp_print_string ppf "Incoming_connection " % string;
      Tezos_base.P2p_point.Id.pp ppf p
    | Outgoing_connection p =>
      Stdlib.Format.pp_print_string ppf "Outgoing_connection " % string;
      Tezos_base.P2p_point.Id.pp ppf p
    | Authentication_failed p =>
      Stdlib.Format.pp_print_string ppf "Authentication_failed " % string;
      Tezos_base.P2p_point.Id.pp ppf p
    | Accepting_request pi _ _ =>
      Stdlib.Format.pp_print_string ppf "Accepting_request " % string;
      Tezos_base.P2p_point.Id.pp ppf pi
    | Rejecting_request pi _ _ =>
      Stdlib.Format.pp_print_string ppf "Rejecting_request " % string;
      Tezos_base.P2p_point.Id.pp ppf pi
    | Request_rejected pi _ =>
      Stdlib.Format.pp_print_string ppf "Request_rejected " % string;
      Tezos_base.P2p_point.Id.pp ppf pi
    | Connection_established _ pi =>
      Stdlib.Format.pp_print_string ppf "Connection_established " % string;
      Tezos_base.P2p_peer_id.pp ppf pi
    | Swap_request_received {| source := source |} =>
      Stdlib.Format.pp_print_string ppf "Swap_request_received " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    | Swap_ack_received {| source := source |} =>
      Stdlib.Format.pp_print_string ppf "Swap_ack_received " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    | Swap_request_sent {| source := source |} =>
      Stdlib.Format.pp_print_string ppf "Swap_request_sent " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    | Swap_ack_sent {| source := source |} =>
      Stdlib.Format.pp_print_string ppf "Swap_ack_sent " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    | Swap_request_ignored {| source := source |} =>
      Stdlib.Format.pp_print_string ppf "Swap_request_ignored " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    | Swap_success {| source := source |} =>
      Stdlib.Format.pp_print_string ppf "Swap_success " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    | Swap_failure {| source := source |} =>
      Stdlib.Format.pp_print_string ppf "Swap_failure " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    | Disconnection source =>
      Stdlib.Format.pp_print_string ppf "Disconnection " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    | External_disconnection source =>
      Stdlib.Format.pp_print_string ppf "External_disconnection " % string;
      Tezos_base.P2p_peer_id.pp ppf source
    end.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    let branch_encoding {A : Type}
      (name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
      : Tezos_data_encoding.Data_encoding.encoding A :=
      Tezos_data_encoding.Data_encoding.conv (fun x => (tt, x))
        (fun function_parameter =>
          match function_parameter with
          | (tt, x) => x
          end) None
        (Tezos_data_encoding.Data_encoding.merge_objs
          (Tezos_data_encoding.Data_encoding.obj1
            (Tezos_data_encoding.Data_encoding.req None None "event" % string
              (Tezos_data_encoding.Data_encoding.constant name))) obj) in
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def
          "p2p_connection.pool_event" % string expected_argument
          (Some
            "An event that may happen during maintenance of and other operations on the p2p connection pool. Typically, it includes connection errors, peer swaps, etc."
              % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.union (Some variant)
        (cons
          (Tezos_data_encoding.Data_encoding.case "Too_few_connections" % string
            None (Tag 0)
            (branch_encoding "too_few_connections" % string
              Tezos_data_encoding.Data_encoding.empty)
            (fun function_parameter =>
              match function_parameter with
              | Too_few_connections => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => Too_few_connections
              end))
          (cons
            (Tezos_data_encoding.Data_encoding.case
              "Too_many_connections" % string None (Tag 1)
              (branch_encoding "too_many_connections" % string
                Tezos_data_encoding.Data_encoding.empty)
              (fun function_parameter =>
                match function_parameter with
                | Too_many_connections => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | tt => Too_many_connections
                end))
            (cons
              (Tezos_data_encoding.Data_encoding.case "New_point" % string None
                (Tag 2)
                (branch_encoding "new_point" % string
                  (Tezos_data_encoding.Data_encoding.obj1
                    (Tezos_data_encoding.Data_encoding.req None None
                      "point" % string Tezos_base.P2p_point.Id.encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | New_point p => Some p
                  | _ => None
                  end) (fun p => New_point p))
              (cons
                (Tezos_data_encoding.Data_encoding.case "New_peer" % string None
                  (Tag 3)
                  (branch_encoding "new_peer" % string
                    (Tezos_data_encoding.Data_encoding.obj1
                      (Tezos_data_encoding.Data_encoding.req None None
                        "peer_id" % string Tezos_base.P2p_peer_id.encoding)))
                  (fun function_parameter =>
                    match function_parameter with
                    | New_peer p => Some p
                    | _ => None
                    end) (fun p => New_peer p))
                (cons
                  (Tezos_data_encoding.Data_encoding.case
                    "Incoming_connection" % string None (Tag 4)
                    (branch_encoding "incoming_connection" % string
                      (Tezos_data_encoding.Data_encoding.obj1
                        (Tezos_data_encoding.Data_encoding.req None None
                          "point" % string Tezos_base.P2p_point.Id.encoding)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Incoming_connection p => Some p
                      | _ => None
                      end) (fun p => Incoming_connection p))
                  (cons
                    (Tezos_data_encoding.Data_encoding.case
                      "Outgoing_connection" % string None (Tag 5)
                      (branch_encoding "outgoing_connection" % string
                        (Tezos_data_encoding.Data_encoding.obj1
                          (Tezos_data_encoding.Data_encoding.req None None
                            "point" % string Tezos_base.P2p_point.Id.encoding)))
                      (fun function_parameter =>
                        match function_parameter with
                        | Outgoing_connection p => Some p
                        | _ => None
                        end) (fun p => Outgoing_connection p))
                    (cons
                      (Tezos_data_encoding.Data_encoding.case
                        "Authentication_failed" % string None (Tag 6)
                        (branch_encoding "authentication_failed" % string
                          (Tezos_data_encoding.Data_encoding.obj1
                            (Tezos_data_encoding.Data_encoding.req None None
                              "point" % string Tezos_base.P2p_point.Id.encoding)))
                        (fun function_parameter =>
                          match function_parameter with
                          | Authentication_failed p => Some p
                          | _ => None
                          end) (fun p => Authentication_failed p))
                      (cons
                        (Tezos_data_encoding.Data_encoding.case
                          "Accepting_request" % string None (Tag 7)
                          (branch_encoding "accepting_request" % string
                            (Tezos_data_encoding.Data_encoding.obj3
                              (Tezos_data_encoding.Data_encoding.req None None
                                "point" % string
                                Tezos_base.P2p_point.Id.encoding)
                              (Tezos_data_encoding.Data_encoding.req None None
                                "id_point" % string Id.encoding)
                              (Tezos_data_encoding.Data_encoding.req None None
                                "peer_id" % string
                                Tezos_base.P2p_peer_id.encoding)))
                          (fun function_parameter =>
                            match function_parameter with
                            | Accepting_request p id_p g => Some (p, id_p, g)
                            | _ => None
                            end)
                          (fun function_parameter =>
                            match function_parameter with
                            | (p, id_p, g) => Accepting_request p id_p g
                            end))
                        (cons
                          (Tezos_data_encoding.Data_encoding.case
                            "Rejecting_request" % string None (Tag 8)
                            (branch_encoding "rejecting_request" % string
                              (Tezos_data_encoding.Data_encoding.obj3
                                (Tezos_data_encoding.Data_encoding.req None None
                                  "point" % string
                                  Tezos_base.P2p_point.Id.encoding)
                                (Tezos_data_encoding.Data_encoding.req None None
                                  "id_point" % string Id.encoding)
                                (Tezos_data_encoding.Data_encoding.req None None
                                  "peer_id" % string
                                  Tezos_base.P2p_peer_id.encoding)))
                            (fun function_parameter =>
                              match function_parameter with
                              | Rejecting_request p id_p g => Some (p, id_p, g)
                              | _ => None
                              end)
                            (fun function_parameter =>
                              match function_parameter with
                              | (p, id_p, g) => Rejecting_request p id_p g
                              end))
                          (cons
                            (Tezos_data_encoding.Data_encoding.case
                              "Request_rejected" % string None (Tag 9)
                              (branch_encoding "request_rejected" % string
                                (Tezos_data_encoding.Data_encoding.obj2
                                  (Tezos_data_encoding.Data_encoding.req None
                                    None "point" % string
                                    Tezos_base.P2p_point.Id.encoding)
                                  (Tezos_data_encoding.Data_encoding.opt None
                                    None "identity" % string
                                    (Tezos_data_encoding.Data_encoding.tup2
                                      Id.encoding
                                      Tezos_base.P2p_peer_id.encoding))))
                              (fun function_parameter =>
                                match function_parameter with
                                | Request_rejected p id => Some (p, id)
                                | _ => None
                                end)
                              (fun function_parameter =>
                                match function_parameter with
                                | (p, id) => Request_rejected p id
                                end))
                            (cons
                              (Tezos_data_encoding.Data_encoding.case
                                "Connection_established" % string None (Tag 10)
                                (branch_encoding
                                  "connection_established" % string
                                  (Tezos_data_encoding.Data_encoding.obj2
                                    (Tezos_data_encoding.Data_encoding.req None
                                      None "id_point" % string Id.encoding)
                                    (Tezos_data_encoding.Data_encoding.req None
                                      None "peer_id" % string
                                      Tezos_base.P2p_peer_id.encoding)))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Connection_established id_p g =>
                                    Some (id_p, g)
                                  | _ => None
                                  end)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (id_p, g) => Connection_established id_p g
                                  end))
                              (cons
                                (Tezos_data_encoding.Data_encoding.case
                                  "Disconnection" % string None (Tag 11)
                                  (branch_encoding "disconnection" % string
                                    (Tezos_data_encoding.Data_encoding.obj1
                                      (Tezos_data_encoding.Data_encoding.req
                                        None None "peer_id" % string
                                        Tezos_base.P2p_peer_id.encoding)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Disconnection g => Some g
                                    | _ => None
                                    end) (fun g => Disconnection g))
                                (cons
                                  (Tezos_data_encoding.Data_encoding.case
                                    "External_disconnection" % string None
                                    (Tag 12)
                                    (branch_encoding
                                      "external_disconnection" % string
                                      (Tezos_data_encoding.Data_encoding.obj1
                                        (Tezos_data_encoding.Data_encoding.req
                                          None None "peer_id" % string
                                          Tezos_base.P2p_peer_id.encoding)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | External_disconnection g => Some g
                                      | _ => None
                                      end) (fun g => External_disconnection g))
                                  (cons
                                    (Tezos_data_encoding.Data_encoding.case
                                      "Gc_points" % string None (Tag 13)
                                      (branch_encoding "gc_points" % string
                                        Tezos_data_encoding.Data_encoding.empty)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | Gc_points => Some tt
                                        | _ => None
                                        end)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt => Gc_points
                                        end))
                                    (cons
                                      (Tezos_data_encoding.Data_encoding.case
                                        "Gc_peer_ids" % string None (Tag 14)
                                        (branch_encoding "gc_peer_ids" % string
                                          Tezos_data_encoding.Data_encoding.empty)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | Gc_peer_ids => Some tt
                                          | _ => None
                                          end)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt => Gc_peer_ids
                                          end))
                                      (cons
                                        (Tezos_data_encoding.Data_encoding.case
                                          "Swap_request_received" % string None
                                          (Tag 15)
                                          (branch_encoding
                                            "swap_request_received" % string
                                            (Tezos_data_encoding.Data_encoding.obj1
                                              (Tezos_data_encoding.Data_encoding.req
                                                None None "source" % string
                                                Tezos_base.P2p_peer_id.encoding)))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              Swap_request_received {|
                                                source := source |} =>
                                              Some source
                                            | _ => None
                                            end)
                                          (fun source =>
                                            Swap_request_received
                                              {| source := source |}))
                                        (cons
                                          (Tezos_data_encoding.Data_encoding.case
                                            "Swap_ack_received" % string None
                                            (Tag 16)
                                            (branch_encoding
                                              "swap_ack_received" % string
                                              (Tezos_data_encoding.Data_encoding.obj1
                                                (Tezos_data_encoding.Data_encoding.req
                                                  None None "source" % string
                                                  Tezos_base.P2p_peer_id.encoding)))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              |
                                                Swap_ack_received {|
                                                  source := source |} =>
                                                Some source
                                              | _ => None
                                              end)
                                            (fun source =>
                                              Swap_ack_received
                                                {| source := source |}))
                                          (cons
                                            (Tezos_data_encoding.Data_encoding.case
                                              "Swap_request_sent" % string None
                                              (Tag 17)
                                              (branch_encoding
                                                "swap_request_sent" % string
                                                (Tezos_data_encoding.Data_encoding.obj1
                                                  (Tezos_data_encoding.Data_encoding.req
                                                    None None "source" % string
                                                    Tezos_base.P2p_peer_id.encoding)))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                |
                                                  Swap_request_sent {|
                                                    source := source |} =>
                                                  Some source
                                                | _ => None
                                                end)
                                              (fun source =>
                                                Swap_request_sent
                                                  {| source := source |}))
                                            (cons
                                              (Tezos_data_encoding.Data_encoding.case
                                                "Swap_ack_sent" % string None
                                                (Tag 18)
                                                (branch_encoding
                                                  "swap_ack_sent" % string
                                                  (Tezos_data_encoding.Data_encoding.obj1
                                                    (Tezos_data_encoding.Data_encoding.req
                                                      None None
                                                      "source" % string
                                                      Tezos_base.P2p_peer_id.encoding)))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  |
                                                    Swap_ack_sent {|
                                                      source := source |} =>
                                                    Some source
                                                  | _ => None
                                                  end)
                                                (fun source =>
                                                  Swap_ack_sent
                                                    {| source := source |}))
                                              (cons
                                                (Tezos_data_encoding.Data_encoding.case
                                                  "Swap_request_ignored" %
                                                    string None (Tag 19)
                                                  (branch_encoding
                                                    "swap_request_ignored" %
                                                      string
                                                    (Tezos_data_encoding.Data_encoding.obj1
                                                      (Tezos_data_encoding.Data_encoding.req
                                                        None None
                                                        "source" % string
                                                        Tezos_base.P2p_peer_id.encoding)))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Swap_request_ignored {|
                                                        source := source |}
                                                      => Some source
                                                    | _ => None
                                                    end)
                                                  (fun source =>
                                                    Swap_request_ignored
                                                      {| source := source |}))
                                                (cons
                                                  (Tezos_data_encoding.Data_encoding.case
                                                    "Swap_success" % string None
                                                    (Tag 20)
                                                    (branch_encoding
                                                      "swap_success" % string
                                                      (Tezos_data_encoding.Data_encoding.obj1
                                                        (Tezos_data_encoding.Data_encoding.req
                                                          None None
                                                          "source" % string
                                                          Tezos_base.P2p_peer_id.encoding)))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      |
                                                        Swap_success {|
                                                          source := source
                                                            |} => Some source
                                                      | _ => None
                                                      end)
                                                    (fun source =>
                                                      Swap_success
                                                        {| source := source |}))
                                                  (cons
                                                    (Tezos_data_encoding.Data_encoding.case
                                                      "Swap_failure" % string
                                                      None (Tag 21)
                                                      (branch_encoding
                                                        "swap_failure" % string
                                                        (Tezos_data_encoding.Data_encoding.obj1
                                                          (Tezos_data_encoding.Data_encoding.req
                                                            None None
                                                            "source" % string
                                                            Tezos_base.P2p_peer_id.encoding)))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        |
                                                          Swap_failure {|
                                                            source := source
                                                              |} => Some source
                                                        | _ => None
                                                        end)
                                                      (fun source =>
                                                        Swap_failure
                                                          {| source := source |}))
                                                    []))))))))))))))))))))))).
End Pool_event.
src/lib_base/p2p_connection.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id : sig
  type t = P2p_addr.t * P2p_addr.port option

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val pp : Format.formatter -> t -> unit

  val pp_opt : Format.formatter -> t option -> unit

  val to_string : t -> string

  val encoding : t Data_encoding.t

  val is_local : t -> bool

  val is_global : t -> bool

  val of_point : P2p_point.Id.t -> t

  val to_point : t -> P2p_point.Id.t option

  val to_point_exn : t -> P2p_point.Id.t
end

module Map : Map.S with type key = Id.t

module Set : Set.S with type elt = Id.t

module Table : Hashtbl.S with type key = Id.t

(** Information about a connection *)
module Info : sig
  type 'meta t = {
    incoming : bool;
    peer_id : P2p_peer_id.t;
    id_point : Id.t;
    remote_socket_port : P2p_addr.port;
    announced_version : Network_version.t;
    private_node : bool;
    local_metadata : 'meta;
    remote_metadata : 'meta;
  }

  val pp :
    (Format.formatter -> 'meta -> unit) -> Format.formatter -> 'meta t -> unit

  val encoding : 'meta Data_encoding.t -> 'meta t Data_encoding.t
end

module Pool_event : sig
  type t =
    | Too_few_connections
    | Too_many_connections
    | New_point of P2p_point.Id.t
    | New_peer of P2p_peer_id.t
    | Gc_points
        (** Garbage collection of known point table has been triggered. *)
    | Gc_peer_ids
        (** Garbage collection of known peer_ids table has been triggered. *)
    (* Connection-level events *)
    | Incoming_connection of P2p_point.Id.t
        (** We accept(2)-ed an incoming connection *)
    | Outgoing_connection of P2p_point.Id.t
        (** We connect(2)-ed to a remote endpoint *)
    | Authentication_failed of P2p_point.Id.t
        (** Remote point failed authentication *)
    | Accepting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
        (** We accepted a connection after authentifying the remote peer. *)
    | Rejecting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
        (** We rejected a connection after authentifying the remote peer. *)
    | Request_rejected of P2p_point.Id.t * (Id.t * P2p_peer_id.t) option
        (** The remote peer rejected our connection. *)
    | Connection_established of Id.t * P2p_peer_id.t
        (** We successfully established a authentified connection. *)
    | Swap_request_received of {source : P2p_peer_id.t}
        (** A swap request has been received. *)
    | Swap_ack_received of {source : P2p_peer_id.t}
        (** A swap ack has been received *)
    | Swap_request_sent of {source : P2p_peer_id.t}
        (** A swap request has been sent *)
    | Swap_ack_sent of {source : P2p_peer_id.t}
        (** A swap ack has been sent *)
    | Swap_request_ignored of {source : P2p_peer_id.t}
        (** A swap request has been ignored *)
    | Swap_success of {source : P2p_peer_id.t}
        (** A swap operation has succeeded *)
    | Swap_failure of {source : P2p_peer_id.t}
        (** A swap operation has failed *)
    | Disconnection of P2p_peer_id.t
        (** We decided to close the connection. *)
    | External_disconnection of P2p_peer_id.t
        (** The connection was closed for external reason. *)

  val pp : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t
end
src/lib_base/p2p_connection.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Id.
  Definition t := Tezos_base.P2p_addr.t * (option Tezos_base.P2p_addr.port).
  
  Parameter compare : t -> t -> Z.
  
  Parameter equal : t -> t -> bool.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
  
  Parameter pp_opt : Stdlib.Format.formatter -> (option t) -> unit.
  
  Parameter to_string : t -> string.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter is_local : t -> bool.
  
  Parameter is_global : t -> bool.
  
  Parameter of_point : Tezos_base.P2p_point.Id.t -> t.
  
  Parameter to_point : t -> option Tezos_base.P2p_point.Id.t.
  
  Parameter to_point_exn : t -> Tezos_base.P2p_point.Id.t.
End Id.

unhandled_module

unhandled_module

unhandled_module

Module Info.
  Record t {meta : Type} := {
    incoming : bool;
    peer_id : Tezos_base.P2p_peer_id.t;
    id_point : Id.t;
    remote_socket_port : Tezos_base.P2p_addr.port;
    announced_version : Tezos_base.Network_version.t;
    private_node : bool;
    local_metadata : meta;
    remote_metadata : meta }.
  Arguments t : clear implicits.
  
  Parameter pp : forall {meta : Type}, (Stdlib.Format.formatter -> meta -> unit)
    -> Stdlib.Format.formatter -> (t meta) -> unit.
  
  Parameter encoding : forall {meta : Type}, (Tezos_data_encoding.Data_encoding.t
    meta) -> Tezos_data_encoding.Data_encoding.t (t meta).
End Info.

Module Pool_event.
  Inductive t : Type :=
  | Too_few_connections : t
  | Too_many_connections : t
  | New_point : Tezos_base.P2p_point.Id.t -> t
  | New_peer : Tezos_base.P2p_peer_id.t -> t
  | Gc_points : t
  | Gc_peer_ids : t
  | Incoming_connection : Tezos_base.P2p_point.Id.t -> t
  | Outgoing_connection : Tezos_base.P2p_point.Id.t -> t
  | Authentication_failed : Tezos_base.P2p_point.Id.t -> t
  | Accepting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
    Tezos_base.P2p_peer_id.t -> t
  | Rejecting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
    Tezos_base.P2p_peer_id.t -> t
  | Request_rejected : Tezos_base.P2p_point.Id.t ->
    (option (Id.t * Tezos_base.P2p_peer_id.t)) -> t
  | Connection_established : Id.t -> Tezos_base.P2p_peer_id.t -> t
  | Swap_request_received : Tezos_base.P2p_peer_id.t -> t
  | Swap_ack_received : Tezos_base.P2p_peer_id.t -> t
  | Swap_request_sent : Tezos_base.P2p_peer_id.t -> t
  | Swap_ack_sent : Tezos_base.P2p_peer_id.t -> t
  | Swap_request_ignored : Tezos_base.P2p_peer_id.t -> t
  | Swap_success : Tezos_base.P2p_peer_id.t -> t
  | Swap_failure : Tezos_base.P2p_peer_id.t -> t
  | Disconnection : Tezos_base.P2p_peer_id.t -> t
  | External_disconnection : Tezos_base.P2p_peer_id.t -> t.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
End Pool_event.
src/lib_base/p2p_identity.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  peer_id : P2p_peer.Id.t;
  public_key : Crypto_box.public_key;
  secret_key : Crypto_box.secret_key;
  proof_of_work_stamp : Crypto_box.nonce;
}

let encoding =
  let open Data_encoding in
  def
    "p2p_identity"
    ~description:
      "The identity of a peer. This includes cryptographic keys as well as a \
       proof-of-work."
  @@ conv
       (fun {peer_id; public_key; secret_key; proof_of_work_stamp} ->
         (Some peer_id, public_key, secret_key, proof_of_work_stamp))
       (fun (peer_id_opt, public_key, secret_key, proof_of_work_stamp) ->
         let peer_id =
           match peer_id_opt with
           | Some peer_id ->
               peer_id
           | None ->
               Tezos_crypto.Crypto_box.hash public_key
         in
         {peer_id; public_key; secret_key; proof_of_work_stamp})
       (obj4
          (opt "peer_id" P2p_peer_id.encoding)
          (req "public_key" Crypto_box.public_key_encoding)
          (req "secret_key" Crypto_box.secret_key_encoding)
          (req "proof_of_work_stamp" Crypto_box.nonce_encoding))

let generate_with_bound ?max target =
  let (secret_key, public_key, peer_id) = Crypto_box.random_keypair () in
  let proof_of_work_stamp =
    Crypto_box.generate_proof_of_work ?max public_key target
  in
  {peer_id; public_key; secret_key; proof_of_work_stamp}

let generate target = generate_with_bound target

let () = Data_encoding.Registration.register encoding
src/lib_base/p2p_identity.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  peer_id : Tezos_base.P2p_peer.Id.t;
  public_key : Tezos_crypto.Crypto_box.public_key;
  secret_key : Tezos_crypto.Crypto_box.secret_key;
  proof_of_work_stamp : Tezos_crypto.Crypto_box.nonce }.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "p2p_identity" % string
        expected_argument
        (Some
          "The identity of a peer. This includes cryptographic keys as well as a proof-of-work."
            % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          peer_id := peer_id;
            public_key := public_key;
            secret_key := secret_key;
            proof_of_work_stamp := proof_of_work_stamp
            |} => ((Some peer_id), public_key, secret_key, proof_of_work_stamp)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (peer_id_opt, public_key, secret_key, proof_of_work_stamp) =>
          let peer_id :=
            match peer_id_opt with
            | Some peer_id => peer_id
            | None => Tezos_crypto.Crypto_box.hash public_key
            end in
          {| peer_id := peer_id; public_key := public_key;
            secret_key := secret_key; proof_of_work_stamp := proof_of_work_stamp
            |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj4
        (Tezos_data_encoding.Data_encoding.opt None None "peer_id" % string
          Tezos_base.P2p_peer_id.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "public_key" % string
          Tezos_crypto.Crypto_box.public_key_encoding)
        (Tezos_data_encoding.Data_encoding.req None None "secret_key" % string
          Tezos_crypto.Crypto_box.secret_key_encoding)
        (Tezos_data_encoding.Data_encoding.req None None
          "proof_of_work_stamp" % string Tezos_crypto.Crypto_box.nonce_encoding))).

Definition generate_with_bound
  (max : option Z) (target : Tezos_crypto.Crypto_box.target) : t :=
  match Tezos_crypto.Crypto_box.random_keypair tt with
  | (secret_key, public_key, peer_id) =>
    let proof_of_work_stamp :=
      Tezos_crypto.Crypto_box.generate_proof_of_work max public_key target in
    {| peer_id := peer_id; public_key := public_key; secret_key := secret_key;
      proof_of_work_stamp := proof_of_work_stamp |}
  end.

Definition generate (target : Tezos_crypto.Crypto_box.target) : t :=
  generate_with_bound None target.
src/lib_base/p2p_identity.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Type of an identity, comprising a [peer_id], a cryptographic key pair, and a
    proof of work stamp with enough difficulty so that the network
    accept this identity as genuine. *)
type t = {
  peer_id : P2p_peer.Id.t;
  public_key : Crypto_box.public_key;
  secret_key : Crypto_box.secret_key;
  proof_of_work_stamp : Crypto_box.nonce;
}

val encoding : t Data_encoding.t

(** [generate target] is a freshly minted identity whose proof of
    work stamp difficulty is at least equal to [target]. *)
val generate : Crypto_box.target -> t

val generate_with_bound : ?max:int -> Crypto_box.target -> t
src/lib_base/p2p_identity.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  peer_id : Tezos_base.P2p_peer.Id.t;
  public_key : Tezos_crypto.Crypto_box.public_key;
  secret_key : Tezos_crypto.Crypto_box.secret_key;
  proof_of_work_stamp : Tezos_crypto.Crypto_box.nonce }.

Parameter encoding : Tezos_data_encoding.Data_encoding.t t.

Parameter generate : Tezos_crypto.Crypto_box.target -> t.

Parameter generate_with_bound :
(option Z) -> Tezos_crypto.Crypto_box.target -> t.
src/lib_base/p2p_peer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id = P2p_peer_id
module Table = Id.Table
module Error_table = Id.Error_table
module Map = Id.Map
module Set = Id.Set

module Filter = struct
  type t = Accepted | Running | Disconnected

  let rpc_arg =
    RPC_arg.make
      ~name:"p2p.point.state_filter"
      ~destruct:(function
        | "accepted" ->
            Ok Accepted
        | "running" ->
            Ok Running
        | "disconnected" ->
            Ok Disconnected
        | s ->
            Error (Format.asprintf "Invalid state: %s" s))
      ~construct:(function
        | Accepted ->
            "accepted"
        | Running ->
            "running"
        | Disconnected ->
            "disconnected")
      ()
end

module State = struct
  type t = Accepted | Running | Disconnected

  let pp_digram ppf = function
    | Accepted ->
        Format.fprintf ppf "⚎"
    | Running ->
        Format.fprintf ppf "⚌"
    | Disconnected ->
        Format.fprintf ppf "⚏"

  let encoding =
    let open Data_encoding in
    def
      "p2p_peer.state"
      ~description:
        "The state a peer connection can be in: accepted (when the connection \
         is being established), running (when the connection is already \
         established), disconnected (otherwise)."
    @@ string_enum
         [ ("accepted", Accepted);
           ("running", Running);
           ("disconnected", Disconnected) ]

  let raw_filter (f : Filter.t) (s : t) =
    match (f, s) with
    | (Accepted, Accepted) ->
        true
    | (Accepted, (Running | Disconnected))
    | ((Running | Disconnected), Accepted) ->
        false
    | (Running, Running) ->
        true
    | (Disconnected, Disconnected) ->
        true
    | (Running, Disconnected) | (Disconnected, Running) ->
        false

  let filter filters state = List.exists (fun f -> raw_filter f state) filters
end

module Info = struct
  type ('peer_meta, 'conn_meta) t = {
    score : float;
    trusted : bool;
    conn_metadata : 'conn_meta option;
    peer_metadata : 'peer_meta;
    state : State.t;
    id_point : P2p_connection.Id.t option;
    stat : P2p_stat.t;
    last_failed_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_rejected_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_established_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_disconnection : (P2p_connection.Id.t * Time.System.t) option;
    last_seen : (P2p_connection.Id.t * Time.System.t) option;
    last_miss : (P2p_connection.Id.t * Time.System.t) option;
  }

  let encoding peer_metadata_encoding conn_metadata_encoding =
    let open Data_encoding in
    conv
      (fun { score;
             trusted;
             conn_metadata;
             peer_metadata;
             state;
             id_point;
             stat;
             last_failed_connection;
             last_rejected_connection;
             last_established_connection;
             last_disconnection;
             last_seen;
             last_miss } ->
        ( (score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
          ( last_failed_connection,
            last_rejected_connection,
            last_established_connection,
            last_disconnection,
            last_seen,
            last_miss ) ))
      (fun ( ( score,
               trusted,
               conn_metadata,
               peer_metadata,
               state,
               id_point,
               stat ),
             ( last_failed_connection,
               last_rejected_connection,
               last_established_connection,
               last_disconnection,
               last_seen,
               last_miss ) ) ->
        {
          score;
          trusted;
          conn_metadata;
          peer_metadata;
          state;
          id_point;
          stat;
          last_failed_connection;
          last_rejected_connection;
          last_established_connection;
          last_disconnection;
          last_seen;
          last_miss;
        })
      (merge_objs
         (obj7
            (req "score" float)
            (req "trusted" bool)
            (opt "conn_metadata" conn_metadata_encoding)
            (req "peer_metadata" peer_metadata_encoding)
            (req "state" State.encoding)
            (opt "reachable_at" P2p_connection.Id.encoding)
            (req "stat" P2p_stat.encoding))
         (obj6
            (opt
               "last_failed_connection"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_rejected_connection"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_established_connection"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_disconnection"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_seen"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_miss"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))))
end

module Pool_event = struct
  type kind =
    | Accepting_request
    | Rejecting_request
    | Request_rejected
    | Connection_established
    | Disconnection
    | External_disconnection

  let kind_encoding =
    Data_encoding.string_enum
      [ ("incoming_request", Accepting_request);
        ("rejecting_request", Rejecting_request);
        ("request_rejected", Request_rejected);
        ("connection_established", Connection_established);
        ("disconnection", Disconnection);
        ("external_disconnection", External_disconnection) ]

  type t = {
    kind : kind;
    timestamp : Time.System.t;
    point : P2p_connection.Id.t;
  }

  let encoding =
    let open Data_encoding in
    def
      "p2p_peer.pool_event"
      ~description:
        "An event that may happen during maintenance of and other operations \
         on the connection to a specific peer."
    @@ conv
         (fun {kind; timestamp; point = (addr, port)} ->
           (kind, timestamp, addr, port))
         (fun (kind, timestamp, addr, port) ->
           {kind; timestamp; point = (addr, port)})
         (obj4
            (req "kind" kind_encoding)
            (req "timestamp" Time.System.encoding)
            (req "addr" P2p_addr.encoding)
            (opt "port" uint16))
end

let () =
  Data_encoding.Registration.register ~pp:State.pp_digram State.encoding ;
  Data_encoding.Registration.register Pool_event.encoding
src/lib_base/p2p_peer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Filter.
  Inductive t : Type :=
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
    Tezos_rpc.RPC_arg.make None "p2p.point.state_filter" % string
      (fun function_parameter =>
        match function_parameter with
        | "accepted" % string => inl Accepted
        | "running" % string => inl Running
        | "disconnected" % string => inl Disconnected
        | s =>
          inr
            (Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Invalid state: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))
                "Invalid state: %s" % string) s)
        end)
      (fun function_parameter =>
        match function_parameter with
        | Accepted => "accepted" % string
        | Running => "running" % string
        | Disconnected => "disconnected" % string
        end) tt.
End Filter.

Module State.
  Inductive t : Type :=
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Definition pp_digram (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Accepted =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚎" % string
            CamlinternalFormatBasics.End_of_format) "⚎" % string)
    | Running =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚌" % string
            CamlinternalFormatBasics.End_of_format) "⚌" % string)
    | Disconnected =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚏" % string
            CamlinternalFormatBasics.End_of_format) "⚏" % string)
    end.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "p2p_peer.state" % string
          expected_argument
          (Some
            "The state a peer connection can be in: accepted (when the connection is being established), running (when the connection is already established), disconnected (otherwise)."
              % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.string_enum
        (cons ("accepted" % string, Accepted)
          (cons ("running" % string, Running)
            (cons ("disconnected" % string, Disconnected) [])))).
  
  Definition raw_filter (f : Filter.t) (s : t) : bool :=
    match (f, s) with
    | (Accepted, Accepted) => true
    | (Accepted, Running | Disconnected) | (Running | Disconnected, Accepted) =>
      false
    | (Running, Running) => true
    | (Disconnected, Disconnected) => true
    | (Running, Disconnected) | (Disconnected, Running) => false
    end.
  
  Definition filter (filters : list Filter.t) (state : t) : bool :=
    OCaml.List._exists (fun f => raw_filter f state) filters.
End State.

Module Info.
  Record t {peer_meta conn_meta : Type} := {
    score : float;
    trusted : bool;
    conn_metadata : option conn_meta;
    peer_metadata : peer_meta;
    state : State.t;
    id_point : option Tezos_base.P2p_connection.Id.t;
    stat : Tezos_base.P2p_stat.t;
    last_failed_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_rejected_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_established_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_disconnection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_seen :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_miss :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t) }.
  Arguments t : clear implicits.
  
  Definition encoding {A B : Type}
    (peer_metadata_encoding : Tezos_data_encoding.Data_encoding.encoding A)
    (conn_metadata_encoding : Tezos_data_encoding.Data_encoding.encoding B)
    : Tezos_data_encoding.Data_encoding.encoding (t A B) :=
    Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          score := score;
            trusted := trusted;
            conn_metadata := conn_metadata;
            peer_metadata := peer_metadata;
            state := state;
            id_point := id_point;
            stat := stat;
            last_failed_connection := last_failed_connection;
            last_rejected_connection := last_rejected_connection;
            last_established_connection := last_established_connection;
            last_disconnection := last_disconnection;
            last_seen := last_seen;
            last_miss := last_miss
            |} =>
          ((score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
            (last_failed_connection, last_rejected_connection,
              last_established_connection, last_disconnection, last_seen,
              last_miss))
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          ((score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
            (last_failed_connection, last_rejected_connection,
              last_established_connection, last_disconnection, last_seen,
              last_miss)) =>
          {| score := score; trusted := trusted; conn_metadata := conn_metadata;
            peer_metadata := peer_metadata; state := state;
            id_point := id_point; stat := stat;
            last_failed_connection := last_failed_connection;
            last_rejected_connection := last_rejected_connection;
            last_established_connection := last_established_connection;
            last_disconnection := last_disconnection; last_seen := last_seen;
            last_miss := last_miss |}
        end) None
      (Tezos_data_encoding.Data_encoding.merge_objs
        (Tezos_data_encoding.Data_encoding.obj7
          (Tezos_data_encoding.Data_encoding.req None None "score" % string
            Tezos_data_encoding.Data_encoding.float)
          (Tezos_data_encoding.Data_encoding.req None None "trusted" % string
            Tezos_data_encoding.Data_encoding.bool)
          (Tezos_data_encoding.Data_encoding.opt None None
            "conn_metadata" % string conn_metadata_encoding)
          (Tezos_data_encoding.Data_encoding.req None None
            "peer_metadata" % string peer_metadata_encoding)
          (Tezos_data_encoding.Data_encoding.req None None "state" % string
            State.encoding)
          (Tezos_data_encoding.Data_encoding.opt None None
            "reachable_at" % string Tezos_base.P2p_connection.Id.encoding)
          (Tezos_data_encoding.Data_encoding.req None None "stat" % string
            Tezos_base.P2p_stat.encoding))
        (Tezos_data_encoding.Data_encoding.obj6
          (Tezos_data_encoding.Data_encoding.opt None None
            "last_failed_connection" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_connection.Id.encoding
              Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None
            "last_rejected_connection" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_connection.Id.encoding
              Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None
            "last_established_connection" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_connection.Id.encoding
              Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None
            "last_disconnection" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_connection.Id.encoding
              Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None "last_seen" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_connection.Id.encoding
              Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None "last_miss" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_connection.Id.encoding
              Tezos_base.Time.System.encoding)))).
End Info.

Module Pool_event.
  Inductive kind : Type :=
  | Accepting_request : kind
  | Rejecting_request : kind
  | Request_rejected : kind
  | Connection_established : kind
  | Disconnection : kind
  | External_disconnection : kind.
  
  Definition kind_encoding : Tezos_data_encoding.Data_encoding.encoding kind :=
    Tezos_data_encoding.Data_encoding.string_enum
      (cons ("incoming_request" % string, Accepting_request)
        (cons ("rejecting_request" % string, Rejecting_request)
          (cons ("request_rejected" % string, Request_rejected)
            (cons ("connection_established" % string, Connection_established)
              (cons ("disconnection" % string, Disconnection)
                (cons
                  ("external_disconnection" % string, External_disconnection) [])))))).
  
  Record t := {
    kind : kind;
    timestamp : Tezos_base.Time.System.t;
    point : Tezos_base.P2p_connection.Id.t }.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "p2p_peer.pool_event" % string
          expected_argument
          (Some
            "An event that may happen during maintenance of and other operations on the connection to a specific peer."
              % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {| kind := kind; timestamp := timestamp; point := (addr, port) |} =>
            (kind, timestamp, addr, port)
          end)
        (fun function_parameter =>
          match function_parameter with
          | (kind, timestamp, addr, port) =>
            {| kind := kind; timestamp := timestamp; point := (addr, port) |}
          end) None
        (Tezos_data_encoding.Data_encoding.obj4
          (Tezos_data_encoding.Data_encoding.req None None "kind" % string
            kind_encoding)
          (Tezos_data_encoding.Data_encoding.req None None "timestamp" % string
            Tezos_base.Time.System.encoding)
          (Tezos_data_encoding.Data_encoding.req None None "addr" % string
            Tezos_base.P2p_addr.encoding)
          (Tezos_data_encoding.Data_encoding.opt None None "port" % string
            Tezos_data_encoding.Data_encoding.uint16))).
End Pool_event.
src/lib_base/p2p_peer.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id = P2p_peer_id
module Map = Id.Map
module Set = Id.Set
module Table = Id.Table

module Error_table : Error_table.S with type key = Table.key

module Filter : sig
  type t = Accepted | Running | Disconnected

  val rpc_arg : t RPC_arg.t
end

module State : sig
  type t = Accepted | Running | Disconnected

  val pp_digram : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t

  val filter : Filter.t list -> t -> bool
end

module Info : sig
  type ('peer_meta, 'conn_meta) t = {
    score : float;
    trusted : bool;
    conn_metadata : 'conn_meta option;
    peer_metadata : 'peer_meta;
    state : State.t;
    id_point : P2p_connection.Id.t option;
    stat : P2p_stat.t;
    last_failed_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_rejected_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_established_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_disconnection : (P2p_connection.Id.t * Time.System.t) option;
    last_seen : (P2p_connection.Id.t * Time.System.t) option;
    last_miss : (P2p_connection.Id.t * Time.System.t) option;
  }

  val encoding :
    'peer_meta Data_encoding.t ->
    'conn_meta Data_encoding.t ->
    ('peer_meta, 'conn_meta) t Data_encoding.t
end

module Pool_event : sig
  type kind =
    | Accepting_request
        (** We accepted a connection after authentifying the remote peer. *)
    | Rejecting_request
        (** We rejected a connection after authentifying the remote peer. *)
    | Request_rejected  (** The remote peer rejected our connection. *)
    | Connection_established
        (** We successfully established a authentified connection. *)
    | Disconnection  (** We decided to close the connection. *)
    | External_disconnection
        (** The connection was closed for external reason. *)

  type t = {
    kind : kind;
    timestamp : Time.System.t;
    point : P2p_connection.Id.t;
  }

  val encoding : t Data_encoding.t
end
src/lib_base/p2p_peer.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

Module Filter.
  Inductive t : Type :=
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Parameter rpc_arg : Tezos_rpc.RPC_arg.t t.
End Filter.

Module State.
  Inductive t : Type :=
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Parameter pp_digram : Stdlib.Format.formatter -> t -> unit.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter filter : (list Filter.t) -> t -> bool.
End State.

Module Info.
  Record t {peer_meta conn_meta : Type} := {
    score : float;
    trusted : bool;
    conn_metadata : option conn_meta;
    peer_metadata : peer_meta;
    state : State.t;
    id_point : option Tezos_base.P2p_connection.Id.t;
    stat : Tezos_base.P2p_stat.t;
    last_failed_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_rejected_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_established_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_disconnection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_seen :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_miss :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t) }.
  Arguments t : clear implicits.
  
  Parameter encoding : forall {conn_meta peer_meta : Type}, (Tezos_data_encoding.Data_encoding.t
    peer_meta) ->
    (Tezos_data_encoding.Data_encoding.t conn_meta) ->
      Tezos_data_encoding.Data_encoding.t (t peer_meta conn_meta).
End Info.

Module Pool_event.
  Inductive kind : Type :=
  | Accepting_request : kind
  | Rejecting_request : kind
  | Request_rejected : kind
  | Connection_established : kind
  | Disconnection : kind
  | External_disconnection : kind.
  
  Record t := {
    kind : kind;
    timestamp : Tezos_base.Time.System.t;
    point : Tezos_base.P2p_connection.Id.t }.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
End Pool_event.
src/lib_base/p2p_peer_id.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Crypto_box.Public_key_hash

let rpc_arg =
  RPC_arg.like
    rpc_arg
    ~descr:"A cryptographic node identity (Base58Check-encoded)"
    "peer_id"

let pp_source ppf = function
  | None ->
      ()
  | Some peer ->
      Format.fprintf ppf " from peer %a" pp peer

module Logging = struct
  include Internal_event.Legacy_logging.Make_semantic (struct
    let name = "node.distributed_db.p2p_peer_id"
  end)

  let mk_tag pp = Tag.def ~doc:"P2P peer ID" "p2p_peer_id" pp

  let tag = mk_tag pp_short

  let tag_opt =
    mk_tag (fun ppf -> function None -> () | Some peer -> pp_short ppf peer)

  let tag_source =
    Tag.def
      ~doc:"Peer which provided information"
      "p2p_peer_id_source"
      pp_source
end
src/lib_base/p2p_peer_id.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
  Tezos_rpc.RPC_arg.like rpc_arg
    (Some "A cryptographic node identity (Base58Check-encoded)" % string)
    "peer_id" % string.

Definition pp_source
  (ppf : Stdlib.Format.formatter) (function_parameter : option t) : unit :=
  match function_parameter with
  | None => tt
  | Some peer =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal " from peer " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        " from peer %a" % string) pp peer
  end.

Module Logging.
  Definition mk_tag {A : Type} (pp : Stdlib.Format.formatter -> A -> unit)
    : Tag.def A :=
    Tag.def (Some "P2P peer ID" % string) "p2p_peer_id" % string pp.
  
  Definition tag : Tag.def t := mk_tag pp_short.
  
  Definition tag_opt : Tag.def (option t) :=
    mk_tag
      (fun ppf =>
        fun function_parameter =>
          match function_parameter with
          | None => tt
          | Some peer => pp_short ppf peer
          end).
  
  Definition tag_source : Tag.def (option t) :=
    Tag.def (Some "Peer which provided information" % string)
      "p2p_peer_id_source" % string pp_source.
End Logging.
src/lib_base/p2p_peer_id.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Tezos_crypto.S.HASH with type t = Crypto_box.Public_key_hash.t

module Logging : sig
  include Internal_event.Legacy_logging.SEMLOG

  val tag : t Tag.def

  val tag_opt : t option Tag.def

  val tag_source : t option Tag.def
end
src/lib_base/p2p_peer_id.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Module Logging.
  include
  
  Parameter tag : Tag.def t.
  
  Parameter tag_opt : Tag.def (option t).
  
  Parameter tag_source : Tag.def (option t).
End Logging.
src/lib_base/p2p_point.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id = struct
  (* A net point (address x port). *)
  type t = P2p_addr.t * P2p_addr.port

  let compare (a1, p1) (a2, p2) =
    match Ipaddr.V6.compare a1 a2 with 0 -> p1 - p2 | x -> x

  let equal p1 p2 = compare p1 p2 = 0

  let hash = Hashtbl.hash

  let pp ppf (addr, port) =
    match Ipaddr.v4_of_v6 addr with
    | Some addr ->
        Format.fprintf ppf "%a:%d" Ipaddr.V4.pp addr port
    | None ->
        Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp addr port

  let pp_opt ppf = function
    | None ->
        Format.pp_print_string ppf "none"
    | Some point ->
        pp ppf point

  let pp_list ppf point_list =
    Format.pp_print_list ~pp_sep:Format.pp_print_space pp ppf point_list

  let is_local (addr, _) = Ipaddr.V6.is_private addr

  let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr

  let check_port port =
    if
      TzString.mem_char port '[' || TzString.mem_char port ']'
      || TzString.mem_char port ':'
    then invalid_arg "Utils.parse_addr_port (invalid character in port)"

  let parse_addr_port s =
    let len = String.length s in
    if len = 0 then ("", "")
    else if s.[0] = '[' then (
      (* inline IPv6 *)
      match String.rindex_opt s ']' with
      | None ->
          invalid_arg "Utils.parse_addr_port (missing ']')"
      | Some pos ->
          let addr = String.sub s 1 (pos - 1) in
          let port =
            if pos = len - 1 then ""
            else if s.[pos + 1] <> ':' then
              invalid_arg "Utils.parse_addr_port (unexpected char after ']')"
            else String.sub s (pos + 2) (len - pos - 2)
          in
          check_port port ; (addr, port) )
    else
      match String.rindex_opt s ']' with
      | Some _pos ->
          invalid_arg "Utils.parse_addr_port (unexpected char ']')"
      | None -> (
        match String.index s ':' with
        | exception _ ->
            (s, "")
        | pos -> (
          match String.index_from s (pos + 1) ':' with
          | exception _ ->
              let addr = String.sub s 0 pos in
              let port = String.sub s (pos + 1) (len - pos - 1) in
              check_port port ; (addr, port)
          | _pos ->
              invalid_arg
                "Utils.parse_addr_port: IPv6 addresses must be bracketed" ) )

  let of_string_exn ?default_port str =
    let (addr, port) = parse_addr_port str in
    let port =
      if port = "" then
        Option.unopt_exn
          (Invalid_argument "P2p_point.of_string_exn: no port")
          default_port
      else int_of_string port
    in
    if port < 0 && port > (1 lsl 16) - 1 then
      invalid_arg "port must be between 0 and 65535" ;
    match Ipaddr.of_string_exn addr with
    | V4 addr ->
        (Ipaddr.v6_of_v4 addr, port)
    | V6 addr ->
        (addr, port)

  let of_string ?default_port str =
    try Ok (of_string_exn ?default_port str) with
    | Invalid_argument s ->
        Error s
    | Failure s ->
        Error s
    | _ ->
        Error "P2p_point.of_string"

  let to_string saddr = Format.asprintf "%a" pp saddr

  let encoding =
    let open Data_encoding in
    def "p2p_point.id" ~description:"Identifier for a peer point"
    @@ conv to_string of_string_exn string

  let rpc_arg =
    RPC_arg.make
      ~name:"point"
      ~descr:"A network point (ipv4:port or [ipv6]:port)."
      ~destruct:of_string
      ~construct:to_string
      ()
end

module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)

module Filter = struct
  type t = Requested | Accepted | Running | Disconnected

  let rpc_arg =
    RPC_arg.make
      ~name:"p2p.point.state_filter"
      ~destruct:(function
        | "requested" ->
            Ok Requested
        | "accepted" ->
            Ok Accepted
        | "running" ->
            Ok Running
        | "disconnected" ->
            Ok Disconnected
        | s ->
            Error (Format.asprintf "Invalid state: %s" s))
      ~construct:(function
        | Requested ->
            "requested"
        | Accepted ->
            "accepted"
        | Running ->
            "running"
        | Disconnected ->
            "disconnected")
      ()
end

module State = struct
  type t =
    | Requested
    | Accepted of P2p_peer_id.t
    | Running of P2p_peer_id.t
    | Disconnected

  let of_p2p_peer_id = function
    | Requested ->
        None
    | Accepted pi ->
        Some pi
    | Running pi ->
        Some pi
    | Disconnected ->
        None

  let of_peerid_state state pi =
    match (state, pi) with
    | (Requested, _) ->
        Requested
    | (Accepted _, Some pi) ->
        Accepted pi
    | (Running _, Some pi) ->
        Running pi
    | (Disconnected, _) ->
        Disconnected
    | _ ->
        invalid_arg "state_of_state_peerid"

  let pp_digram ppf = function
    | Requested ->
        Format.fprintf ppf "⚎"
    | Accepted _ ->
        Format.fprintf ppf "⚍"
    | Running _ ->
        Format.fprintf ppf "⚌"
    | Disconnected ->
        Format.fprintf ppf "⚏"

  let encoding =
    let open Data_encoding in
    let branch_encoding name obj =
      conv
        (fun x -> ((), x))
        (fun ((), x) -> x)
        (merge_objs (obj1 (req "event_kind" (constant name))) obj)
    in
    def
      "p2p_point.state"
      ~description:
        "The state a connection to a peer point can be in: requested \
         (connection open from here), accepted (handshake), running \
         (connection already established), disconnected (no connection)."
    @@ union
         ~tag_size:`Uint8
         [ case
             (Tag 0)
             ~title:"Requested"
             (branch_encoding "requested" empty)
             (function Requested -> Some () | _ -> None)
             (fun () -> Requested);
           case
             (Tag 1)
             ~title:"Accepted"
             (branch_encoding
                "accepted"
                (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
             (function Accepted p2p_peer_id -> Some p2p_peer_id | _ -> None)
             (fun p2p_peer_id -> Accepted p2p_peer_id);
           case
             (Tag 2)
             ~title:"Running"
             (branch_encoding
                "running"
                (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
             (function Running p2p_peer_id -> Some p2p_peer_id | _ -> None)
             (fun p2p_peer_id -> Running p2p_peer_id);
           case
             (Tag 3)
             ~title:"Disconnected"
             (branch_encoding "disconnected" empty)
             (function Disconnected -> Some () | _ -> None)
             (fun () -> Disconnected) ]

  let raw_filter (f : Filter.t) (s : t) =
    match (f, s) with
    | (Requested, Requested) ->
        true
    | (Requested, (Accepted _ | Running _ | Disconnected))
    | ((Accepted | Running | Disconnected), Requested) ->
        false
    | (Accepted, Accepted _) ->
        true
    | (Accepted, (Running _ | Disconnected))
    | ((Running | Disconnected), Accepted _) ->
        false
    | (Running, Running _) ->
        true
    | (Disconnected, Disconnected) ->
        true
    | (Running, Disconnected) | (Disconnected, Running _) ->
        false

  let filter filters state = List.exists (fun f -> raw_filter f state) filters
end

module Info = struct
  type t = {
    trusted : bool;
    greylisted_until : Time.System.t;
    state : State.t;
    last_failed_connection : Time.System.t option;
    last_rejected_connection : (P2p_peer_id.t * Time.System.t) option;
    last_established_connection : (P2p_peer_id.t * Time.System.t) option;
    last_disconnection : (P2p_peer_id.t * Time.System.t) option;
    last_seen : (P2p_peer_id.t * Time.System.t) option;
    last_miss : Time.System.t option;
  }

  let encoding =
    let open Data_encoding in
    def
      "p2p_point.info"
      ~description:
        "Information about a peer point. Includes flags, state, and records \
         about past events."
    @@ conv
         (fun { trusted;
                greylisted_until;
                state;
                last_failed_connection;
                last_rejected_connection;
                last_established_connection;
                last_disconnection;
                last_seen;
                last_miss } ->
           let p2p_peer_id = State.of_p2p_peer_id state in
           ( trusted,
             greylisted_until,
             state,
             p2p_peer_id,
             last_failed_connection,
             last_rejected_connection,
             last_established_connection,
             last_disconnection,
             last_seen,
             last_miss ))
         (fun ( trusted,
                greylisted_until,
                state,
                p2p_peer_id,
                last_failed_connection,
                last_rejected_connection,
                last_established_connection,
                last_disconnection,
                last_seen,
                last_miss ) ->
           let state = State.of_peerid_state state p2p_peer_id in
           {
             trusted;
             greylisted_until;
             state;
             last_failed_connection;
             last_rejected_connection;
             last_established_connection;
             last_disconnection;
             last_seen;
             last_miss;
           })
         (obj10
            (req "trusted" bool)
            (dft "greylisted_until" Time.System.encoding Time.System.epoch)
            (req "state" State.encoding)
            (opt "p2p_peer_id" P2p_peer_id.encoding)
            (opt "last_failed_connection" Time.System.encoding)
            (opt
               "last_rejected_connection"
               (tup2 P2p_peer_id.encoding Time.System.encoding))
            (opt
               "last_established_connection"
               (tup2 P2p_peer_id.encoding Time.System.encoding))
            (opt
               "last_disconnection"
               (tup2 P2p_peer_id.encoding Time.System.encoding))
            (opt "last_seen" (tup2 P2p_peer_id.encoding Time.System.encoding))
            (opt "last_miss" Time.System.encoding))
end

module Pool_event = struct
  type kind =
    | Outgoing_request
    | Accepting_request of P2p_peer_id.t
    | Rejecting_request of P2p_peer_id.t
    | Request_rejected of P2p_peer_id.t option
    | Connection_established of P2p_peer_id.t
    | Disconnection of P2p_peer_id.t
    | External_disconnection of P2p_peer_id.t

  let kind_encoding =
    let open Data_encoding in
    let branch_encoding name obj =
      conv
        (fun x -> ((), x))
        (fun ((), x) -> x)
        (merge_objs (obj1 (req "event_kind" (constant name))) obj)
    in
    union
      ~tag_size:`Uint8
      [ case
          (Tag 0)
          ~title:"Outgoing_request"
          (branch_encoding "outgoing_request" empty)
          (function Outgoing_request -> Some () | _ -> None)
          (fun () -> Outgoing_request);
        case
          (Tag 1)
          ~title:"Accepting_request"
          (branch_encoding
             "accepting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Accepting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
          (fun p2p_peer_id -> Accepting_request p2p_peer_id);
        case
          (Tag 2)
          ~title:"Rejecting_request"
          (branch_encoding
             "rejecting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Rejecting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
          (fun p2p_peer_id -> Rejecting_request p2p_peer_id);
        case
          (Tag 3)
          ~title:"Rejecting_rejected"
          (branch_encoding
             "request_rejected"
             (obj1 (opt "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Request_rejected p2p_peer_id -> Some p2p_peer_id | _ -> None)
          (fun p2p_peer_id -> Request_rejected p2p_peer_id);
        case
          (Tag 4)
          ~title:"Connection_established"
          (branch_encoding
             "rejecting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Connection_established p2p_peer_id ->
                Some p2p_peer_id
            | _ ->
                None)
          (fun p2p_peer_id -> Connection_established p2p_peer_id);
        case
          (Tag 5)
          ~title:"Disconnection"
          (branch_encoding
             "rejecting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Disconnection p2p_peer_id -> Some p2p_peer_id | _ -> None)
          (fun p2p_peer_id -> Disconnection p2p_peer_id);
        case
          (Tag 6)
          ~title:"External_disconnection"
          (branch_encoding
             "rejecting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | External_disconnection p2p_peer_id ->
                Some p2p_peer_id
            | _ ->
                None)
          (fun p2p_peer_id -> External_disconnection p2p_peer_id) ]

  type t = kind Time.System.stamped

  let encoding =
    Data_encoding.def
      "p2p_point.pool_event"
      ~description:
        "Events happening during maintenance of and operations on a peer \
         point pool (such as connections, disconnections, connection \
         requests)."
    @@ Time.System.stamped_encoding kind_encoding
end

let () =
  Data_encoding.Registration.register ~pp:Id.pp Id.encoding ;
  Data_encoding.Registration.register ~pp:State.pp_digram State.encoding ;
  Data_encoding.Registration.register Info.encoding ;
  Data_encoding.Registration.register Pool_event.encoding
src/lib_base/p2p_point.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Id.
  Definition t := Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port.
  
  Definition compare (function_parameter : Ipaddr.V6.t * Z)
    : (Ipaddr.V6.t * Z) -> Z :=
    match function_parameter with
    | (a1, p1) =>
      fun function_parameter =>
        match function_parameter with
        | (a2, p2) =>
          match Ipaddr.V6.compare a1 a2 with
          | 0 => Z.sub p1 p2
          | x => x
          end
        end
    end.
  
  Definition equal (p1 : Ipaddr.V6.t * Z) (p2 : Ipaddr.V6.t * Z) : bool :=
    equiv_decb (compare p1 p2) 0.
  
  Definition hash {A : Type} : A -> Z := Stdlib.Hashtbl.hash.
  
  Definition pp
    (ppf : Stdlib.Format.formatter) (function_parameter : Ipaddr.V6.t * Z)
    : unit :=
    match function_parameter with
    | (addr, port) =>
      match Ipaddr.v4_of_v6 addr with
      | Some addr =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))) "%a:%d" % string)
          Ipaddr.V4.pp addr port
      | None =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal "]:" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format))))
            "[%a]:%d" % string) Ipaddr.V6.pp addr port
      end
    end.
  
  Definition pp_opt
    (ppf : Stdlib.Format.formatter)
    (function_parameter : option (Ipaddr.V6.t * Z)) : unit :=
    match function_parameter with
    | None => Stdlib.Format.pp_print_string ppf "none" % string
    | Some point => pp ppf point
    end.
  
  Definition pp_list
    (ppf : Stdlib.Format.formatter) (point_list : list (Ipaddr.V6.t * Z))
    : unit :=
    Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space) pp ppf
      point_list.
  
  Definition is_local {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : bool :=
    match function_parameter with
    | (addr, _) => Ipaddr.V6.is_private addr
    end.
  
  Definition is_global {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : bool :=
    match function_parameter with
    | (addr, _) => apply negb (Ipaddr.V6.is_private addr)
    end.
  
  Definition check_port (port : string) : unit :=
    if
      orb (Tezos_stdlib.TzString.mem_char port "[" % char)
        (orb (Tezos_stdlib.TzString.mem_char port "]" % char)
          (Tezos_stdlib.TzString.mem_char port ":" % char)) then
      OCaml.Stdlib.invalid_arg
        "Utils.parse_addr_port (invalid character in port)" % string
    else
      tt.
  
  Definition parse_addr_port (s : string) : string * string :=
    let len := OCaml.String.length s in
    if equiv_decb len 0 then
      ("" % string, "" % string)
    else
      if equiv_decb (Stdlib.String.get s 0) "[" % char then
        match Stdlib.String.rindex_opt s "]" % char with
        | None =>
          OCaml.Stdlib.invalid_arg
            "Utils.parse_addr_port (missing ']')" % string
        | Some pos =>
          let addr := Stdlib.String.sub s 1 (Z.sub pos 1) in
          let port :=
            if equiv_decb pos (Z.sub len 1) then
              "" % string
            else
              if nequiv_decb (Stdlib.String.get s (Z.add pos 1)) ":" % char then
                OCaml.Stdlib.invalid_arg
                  "Utils.parse_addr_port (unexpected char after ']')" % string
              else
                Stdlib.String.sub s (Z.add pos 2) (Z.sub (Z.sub len pos) 2) in
          check_port port;
          (addr, port)
        end
      else
        match Stdlib.String.rindex_opt s "]" % char with
        | Some _pos =>
          OCaml.Stdlib.invalid_arg
            "Utils.parse_addr_port (unexpected char ']')" % string
        | None =>
          match Stdlib.String.index s ":" % char with
          | pos =>
            match Stdlib.String.index_from s (Z.add pos 1) ":" % char with
            | _pos =>
              OCaml.Stdlib.invalid_arg
                "Utils.parse_addr_port: IPv6 addresses must be bracketed" %
                  string
            end
          end
        end.
  
  Definition of_string_exn (default_port : option Z) (str : string)
    : Ipaddr.V6.t * Z :=
    match parse_addr_port str with
    | (addr, port) =>
      let port :=
        if equiv_decb port "" % string then
          Tezos_stdlib.Option.unopt_exn
            (OCaml.Invalid_argument "P2p_point.of_string_exn: no port" % string)
            default_port
        else
          OCaml.Stdlib.int_of_string port in
      if
        andb (OCaml.Stdlib.lt port 0)
          (OCaml.Stdlib.gt port (Z.sub (Z.shiftl 1 16) 1)) then
        OCaml.Stdlib.invalid_arg "port must be between 0 and 65535" % string
      else
        tt;
      match Ipaddr.of_string_exn addr with
      | V4 addr => ((Ipaddr.v6_of_v4 addr), port)
      | V6 addr => (addr, port)
      end
    end.
  
  Definition of_string (default_port : option Z) (str : string)
    : sum (Ipaddr.V6.t * Z) string := try.
  
  Definition to_string (saddr : Ipaddr.V6.t * Z) : string :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) pp saddr.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.encoding (Ipaddr.V6.t * Z) :=
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "p2p_point.id" % string
          expected_argument (Some "Identifier for a peer point" % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.conv to_string
        (let arg := of_string_exn in
        fun eta => arg None eta) None Tezos_data_encoding.Data_encoding.string).
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg (Ipaddr.V6.t * Z) :=
    Tezos_rpc.RPC_arg.make
      (Some "A network point (ipv4:port or [ipv6]:port)." % string)
      "point" % string
      (let arg := of_string in
      fun eta => arg None eta) to_string tt.
End Id.

Module Filter.
  Inductive t : Type :=
  | Requested : t
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
    Tezos_rpc.RPC_arg.make None "p2p.point.state_filter" % string
      (fun function_parameter =>
        match function_parameter with
        | "requested" % string => inl Requested
        | "accepted" % string => inl Accepted
        | "running" % string => inl Running
        | "disconnected" % string => inl Disconnected
        | s =>
          inr
            (Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Invalid state: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))
                "Invalid state: %s" % string) s)
        end)
      (fun function_parameter =>
        match function_parameter with
        | Requested => "requested" % string
        | Accepted => "accepted" % string
        | Running => "running" % string
        | Disconnected => "disconnected" % string
        end) tt.
End Filter.

Module State.
  Inductive t : Type :=
  | Requested : t
  | Accepted : Tezos_base.P2p_peer_id.t -> t
  | Running : Tezos_base.P2p_peer_id.t -> t
  | Disconnected : t.
  
  Definition of_p2p_peer_id (function_parameter : t)
    : option Tezos_base.P2p_peer_id.t :=
    match function_parameter with
    | Requested => None
    | Accepted pi => Some pi
    | Running pi => Some pi
    | Disconnected => None
    end.
  
  Definition of_peerid_state (state : t) (pi : option Tezos_base.P2p_peer_id.t)
    : t :=
    match (state, pi) with
    | (Requested, _) => Requested
    | (Accepted _, Some pi) => Accepted pi
    | (Running _, Some pi) => Running pi
    | (Disconnected, _) => Disconnected
    | _ => OCaml.Stdlib.invalid_arg "state_of_state_peerid" % string
    end.
  
  Definition pp_digram (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Requested =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚎" % string
            CamlinternalFormatBasics.End_of_format) "⚎" % string)
    | Accepted _ =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚍" % string
            CamlinternalFormatBasics.End_of_format) "⚍" % string)
    | Running _ =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚌" % string
            CamlinternalFormatBasics.End_of_format) "⚌" % string)
    | Disconnected =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚏" % string
            CamlinternalFormatBasics.End_of_format) "⚏" % string)
    end.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    let branch_encoding {A : Type}
      (name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
      : Tezos_data_encoding.Data_encoding.encoding A :=
      Tezos_data_encoding.Data_encoding.conv (fun x => (tt, x))
        (fun function_parameter =>
          match function_parameter with
          | (tt, x) => x
          end) None
        (Tezos_data_encoding.Data_encoding.merge_objs
          (Tezos_data_encoding.Data_encoding.obj1
            (Tezos_data_encoding.Data_encoding.req None None
              "event_kind" % string
              (Tezos_data_encoding.Data_encoding.constant name))) obj) in
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "p2p_point.state" % string
          expected_argument
          (Some
            "The state a connection to a peer point can be in: requested (connection open from here), accepted (handshake), running (connection already established), disconnected (no connection)."
              % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.union (Some variant)
        (cons
          (Tezos_data_encoding.Data_encoding.case "Requested" % string None
            (Tag 0)
            (branch_encoding "requested" % string
              Tezos_data_encoding.Data_encoding.empty)
            (fun function_parameter =>
              match function_parameter with
              | Requested => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => Requested
              end))
          (cons
            (Tezos_data_encoding.Data_encoding.case "Accepted" % string None
              (Tag 1)
              (branch_encoding "accepted" % string
                (Tezos_data_encoding.Data_encoding.obj1
                  (Tezos_data_encoding.Data_encoding.req None None
                    "p2p_peer_id" % string Tezos_base.P2p_peer_id.encoding)))
              (fun function_parameter =>
                match function_parameter with
                | Accepted p2p_peer_id => Some p2p_peer_id
                | _ => None
                end) (fun p2p_peer_id => Accepted p2p_peer_id))
            (cons
              (Tezos_data_encoding.Data_encoding.case "Running" % string None
                (Tag 2)
                (branch_encoding "running" % string
                  (Tezos_data_encoding.Data_encoding.obj1
                    (Tezos_data_encoding.Data_encoding.req None None
                      "p2p_peer_id" % string Tezos_base.P2p_peer_id.encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | Running p2p_peer_id => Some p2p_peer_id
                  | _ => None
                  end) (fun p2p_peer_id => Running p2p_peer_id))
              (cons
                (Tezos_data_encoding.Data_encoding.case "Disconnected" % string
                  None (Tag 3)
                  (branch_encoding "disconnected" % string
                    Tezos_data_encoding.Data_encoding.empty)
                  (fun function_parameter =>
                    match function_parameter with
                    | Disconnected => Some tt
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Disconnected
                    end)) []))))).
  
  Definition raw_filter (f : Filter.t) (s : t) : bool :=
    match (f, s) with
    | (Requested, Requested) => true
    |
      (Requested, Accepted _ | Running _ | Disconnected) |
        (Accepted | Running | Disconnected, Requested) => false
    | (Accepted, Accepted _) => true
    |
      (Accepted, Running _ | Disconnected) |
        (Running | Disconnected, Accepted _) => false
    | (Running, Running _) => true
    | (Disconnected, Disconnected) => true
    | (Running, Disconnected) | (Disconnected, Running _) => false
    end.
  
  Definition filter (filters : list Filter.t) (state : t) : bool :=
    OCaml.List._exists (fun f => raw_filter f state) filters.
End State.

Module Info.
  Record t := {
    trusted : bool;
    greylisted_until : Tezos_base.Time.System.t;
    state : State.t;
    last_failed_connection : option Tezos_base.Time.System.t;
    last_rejected_connection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_established_connection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_disconnection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_seen : option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_miss : option Tezos_base.Time.System.t }.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "p2p_point.info" % string
          expected_argument
          (Some
            "Information about a peer point. Includes flags, state, and records about past events."
              % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {|
            trusted := trusted;
              greylisted_until := greylisted_until;
              state := state;
              last_failed_connection := last_failed_connection;
              last_rejected_connection := last_rejected_connection;
              last_established_connection := last_established_connection;
              last_disconnection := last_disconnection;
              last_seen := last_seen;
              last_miss := last_miss
              |} =>
            let p2p_peer_id := State.of_p2p_peer_id state in
            (trusted, greylisted_until, state, p2p_peer_id,
              last_failed_connection, last_rejected_connection,
              last_established_connection, last_disconnection, last_seen,
              last_miss)
          end)
        (fun function_parameter =>
          match function_parameter with
          |
            (trusted, greylisted_until, state, p2p_peer_id,
              last_failed_connection, last_rejected_connection,
              last_established_connection, last_disconnection, last_seen,
              last_miss) =>
            let state := State.of_peerid_state state p2p_peer_id in
            {| trusted := trusted; greylisted_until := greylisted_until;
              state := state; last_failed_connection := last_failed_connection;
              last_rejected_connection := last_rejected_connection;
              last_established_connection := last_established_connection;
              last_disconnection := last_disconnection; last_seen := last_seen;
              last_miss := last_miss |}
          end) None
        (Tezos_data_encoding.Data_encoding.obj10
          (Tezos_data_encoding.Data_encoding.req None None "trusted" % string
            Tezos_data_encoding.Data_encoding.bool)
          (Tezos_data_encoding.Data_encoding.dft None None
            "greylisted_until" % string Tezos_base.Time.System.encoding
            Tezos_base.Time.System.epoch)
          (Tezos_data_encoding.Data_encoding.req None None "state" % string
            State.encoding)
          (Tezos_data_encoding.Data_encoding.opt None None
            "p2p_peer_id" % string Tezos_base.P2p_peer_id.encoding)
          (Tezos_data_encoding.Data_encoding.opt None None
            "last_failed_connection" % string Tezos_base.Time.System.encoding)
          (Tezos_data_encoding.Data_encoding.opt None None
            "last_rejected_connection" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_peer_id.encoding Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None
            "last_established_connection" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_peer_id.encoding Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None
            "last_disconnection" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_peer_id.encoding Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None "last_seen" % string
            (Tezos_data_encoding.Data_encoding.tup2
              Tezos_base.P2p_peer_id.encoding Tezos_base.Time.System.encoding))
          (Tezos_data_encoding.Data_encoding.opt None None "last_miss" % string
            Tezos_base.Time.System.encoding))).
End Info.

Module Pool_event.
  Inductive kind : Type :=
  | Outgoing_request : kind
  | Accepting_request : Tezos_base.P2p_peer_id.t -> kind
  | Rejecting_request : Tezos_base.P2p_peer_id.t -> kind
  | Request_rejected : (option Tezos_base.P2p_peer_id.t) -> kind
  | Connection_established : Tezos_base.P2p_peer_id.t -> kind
  | Disconnection : Tezos_base.P2p_peer_id.t -> kind
  | External_disconnection : Tezos_base.P2p_peer_id.t -> kind.
  
  Definition kind_encoding : Tezos_data_encoding.Data_encoding.encoding kind :=
    let branch_encoding {A : Type}
      (name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
      : Tezos_data_encoding.Data_encoding.encoding A :=
      Tezos_data_encoding.Data_encoding.conv (fun x => (tt, x))
        (fun function_parameter =>
          match function_parameter with
          | (tt, x) => x
          end) None
        (Tezos_data_encoding.Data_encoding.merge_objs
          (Tezos_data_encoding.Data_encoding.obj1
            (Tezos_data_encoding.Data_encoding.req None None
              "event_kind" % string
              (Tezos_data_encoding.Data_encoding.constant name))) obj) in
    Tezos_data_encoding.Data_encoding.union (Some variant)
      (cons
        (Tezos_data_encoding.Data_encoding.case "Outgoing_request" % string None
          (Tag 0)
          (branch_encoding "outgoing_request" % string
            Tezos_data_encoding.Data_encoding.empty)
          (fun function_parameter =>
            match function_parameter with
            | Outgoing_request => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | tt => Outgoing_request
            end))
        (cons
          (Tezos_data_encoding.Data_encoding.case "Accepting_request" % string
            None (Tag 1)
            (branch_encoding "accepting_request" % string
              (Tezos_data_encoding.Data_encoding.obj1
                (Tezos_data_encoding.Data_encoding.req None None
                  "p2p_peer_id" % string Tezos_base.P2p_peer_id.encoding)))
            (fun function_parameter =>
              match function_parameter with
              | Accepting_request p2p_peer_id => Some p2p_peer_id
              | _ => None
              end) (fun p2p_peer_id => Accepting_request p2p_peer_id))
          (cons
            (Tezos_data_encoding.Data_encoding.case "Rejecting_request" % string
              None (Tag 2)
              (branch_encoding "rejecting_request" % string
                (Tezos_data_encoding.Data_encoding.obj1
                  (Tezos_data_encoding.Data_encoding.req None None
                    "p2p_peer_id" % string Tezos_base.P2p_peer_id.encoding)))
              (fun function_parameter =>
                match function_parameter with
                | Rejecting_request p2p_peer_id => Some p2p_peer_id
                | _ => None
                end) (fun p2p_peer_id => Rejecting_request p2p_peer_id))
            (cons
              (Tezos_data_encoding.Data_encoding.case
                "Rejecting_rejected" % string None (Tag 3)
                (branch_encoding "request_rejected" % string
                  (Tezos_data_encoding.Data_encoding.obj1
                    (Tezos_data_encoding.Data_encoding.opt None None
                      "p2p_peer_id" % string Tezos_base.P2p_peer_id.encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | Request_rejected p2p_peer_id => Some p2p_peer_id
                  | _ => None
                  end) (fun p2p_peer_id => Request_rejected p2p_peer_id))
              (cons
                (Tezos_data_encoding.Data_encoding.case
                  "Connection_established" % string None (Tag 4)
                  (branch_encoding "rejecting_request" % string
                    (Tezos_data_encoding.Data_encoding.obj1
                      (Tezos_data_encoding.Data_encoding.req None None
                        "p2p_peer_id" % string Tezos_base.P2p_peer_id.encoding)))
                  (fun function_parameter =>
                    match function_parameter with
                    | Connection_established p2p_peer_id => Some p2p_peer_id
                    | _ => None
                    end) (fun p2p_peer_id => Connection_established p2p_peer_id))
                (cons
                  (Tezos_data_encoding.Data_encoding.case
                    "Disconnection" % string None (Tag 5)
                    (branch_encoding "rejecting_request" % string
                      (Tezos_data_encoding.Data_encoding.obj1
                        (Tezos_data_encoding.Data_encoding.req None None
                          "p2p_peer_id" % string Tezos_base.P2p_peer_id.encoding)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Disconnection p2p_peer_id => Some p2p_peer_id
                      | _ => None
                      end) (fun p2p_peer_id => Disconnection p2p_peer_id))
                  (cons
                    (Tezos_data_encoding.Data_encoding.case
                      "External_disconnection" % string None (Tag 6)
                      (branch_encoding "rejecting_request" % string
                        (Tezos_data_encoding.Data_encoding.obj1
                          (Tezos_data_encoding.Data_encoding.req None None
                            "p2p_peer_id" % string
                            Tezos_base.P2p_peer_id.encoding)))
                      (fun function_parameter =>
                        match function_parameter with
                        | External_disconnection p2p_peer_id => Some p2p_peer_id
                        | _ => None
                        end)
                      (fun p2p_peer_id => External_disconnection p2p_peer_id))
                    []))))))).
  
  Definition t := Tezos_base.Time.System.stamped kind.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.encoding
      (Tezos_base.Time.System.stamped kind) :=
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "p2p_point.pool_event" % string
          expected_argument
          (Some
            "Events happening during maintenance of and operations on a peer point pool (such as connections, disconnections, connection requests)."
              % string) in
      fun eta => arg None eta)
      (Tezos_base.Time.System.stamped_encoding kind_encoding).
End Pool_event.
src/lib_base/p2p_point.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id : sig
  type t = P2p_addr.t * P2p_addr.port

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val pp : Format.formatter -> t -> unit

  val pp_opt : Format.formatter -> t option -> unit

  val pp_list : Format.formatter -> t list -> unit

  val of_string_exn : ?default_port:int -> string -> t

  val of_string : ?default_port:int -> string -> (t, string) result

  val to_string : t -> string

  val encoding : t Data_encoding.t

  val is_local : t -> bool

  val is_global : t -> bool

  val parse_addr_port : string -> string * string

  val rpc_arg : t RPC_arg.t
end

module Map : Map.S with type key = Id.t

module Set : Set.S with type elt = Id.t

module Table : Hashtbl.S with type key = Id.t

module Filter : sig
  type t = Requested | Accepted | Running | Disconnected

  val rpc_arg : t RPC_arg.t
end

module State : sig
  type t =
    | Requested
    | Accepted of P2p_peer_id.t
    | Running of P2p_peer_id.t
    | Disconnected

  val pp_digram : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t

  val of_p2p_peer_id : t -> P2p_peer_id.t option

  val of_peerid_state : t -> P2p_peer_id.t option -> t

  val filter : Filter.t list -> t -> bool
end

module Info : sig
  type t = {
    trusted : bool;
    greylisted_until : Time.System.t;
    state : State.t;
    last_failed_connection : Time.System.t option;
    last_rejected_connection : (P2p_peer_id.t * Time.System.t) option;
    last_established_connection : (P2p_peer_id.t * Time.System.t) option;
    last_disconnection : (P2p_peer_id.t * Time.System.t) option;
    last_seen : (P2p_peer_id.t * Time.System.t) option;
    last_miss : Time.System.t option;
  }

  val encoding : t Data_encoding.t
end

module Pool_event : sig
  type kind =
    | Outgoing_request  (** We initiated a connection. *)
    | Accepting_request of P2p_peer_id.t
        (** We accepted a connection after authentifying the remote peer. *)
    | Rejecting_request of P2p_peer_id.t
        (** We rejected a connection after authentifying the remote peer. *)
    | Request_rejected of P2p_peer_id.t option
        (** The remote peer rejected our connection. *)
    | Connection_established of P2p_peer_id.t
        (** We successfully established a authentified connection. *)
    | Disconnection of P2p_peer_id.t
        (** We decided to close the connection. *)
    | External_disconnection of P2p_peer_id.t
        (** The connection was closed for external reason. *)

  type t = kind Time.System.stamped

  val encoding : t Data_encoding.t
end
src/lib_base/p2p_point.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Id.
  Definition t := Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port.
  
  Parameter compare : t -> t -> Z.
  
  Parameter equal : t -> t -> bool.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
  
  Parameter pp_opt : Stdlib.Format.formatter -> (option t) -> unit.
  
  Parameter pp_list : Stdlib.Format.formatter -> (list t) -> unit.
  
  Parameter of_string_exn : (option Z) -> string -> t.
  
  Parameter of_string : (option Z) -> string -> sum t string.
  
  Parameter to_string : t -> string.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter is_local : t -> bool.
  
  Parameter is_global : t -> bool.
  
  Parameter parse_addr_port : string -> string * string.
  
  Parameter rpc_arg : Tezos_rpc.RPC_arg.t t.
End Id.

unhandled_module

unhandled_module

unhandled_module

Module Filter.
  Inductive t : Type :=
  | Requested : t
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Parameter rpc_arg : Tezos_rpc.RPC_arg.t t.
End Filter.

Module State.
  Inductive t : Type :=
  | Requested : t
  | Accepted : Tezos_base.P2p_peer_id.t -> t
  | Running : Tezos_base.P2p_peer_id.t -> t
  | Disconnected : t.
  
  Parameter pp_digram : Stdlib.Format.formatter -> t -> unit.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter of_p2p_peer_id : t -> option Tezos_base.P2p_peer_id.t.
  
  Parameter of_peerid_state : t -> (option Tezos_base.P2p_peer_id.t) -> t.
  
  Parameter filter : (list Filter.t) -> t -> bool.
End State.

Module Info.
  Record t := {
    trusted : bool;
    greylisted_until : Tezos_base.Time.System.t;
    state : State.t;
    last_failed_connection : option Tezos_base.Time.System.t;
    last_rejected_connection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_established_connection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_disconnection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_seen : option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_miss : option Tezos_base.Time.System.t }.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
End Info.

Module Pool_event.
  Inductive kind : Type :=
  | Outgoing_request : kind
  | Accepting_request : Tezos_base.P2p_peer_id.t -> kind
  | Rejecting_request : Tezos_base.P2p_peer_id.t -> kind
  | Request_rejected : (option Tezos_base.P2p_peer_id.t) -> kind
  | Connection_established : Tezos_base.P2p_peer_id.t -> kind
  | Disconnection : Tezos_base.P2p_peer_id.t -> kind
  | External_disconnection : Tezos_base.P2p_peer_id.t -> kind.
  
  Definition t := Tezos_base.Time.System.stamped kind.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
End Pool_event.
src/lib_base/p2p_stat.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  total_sent : int64;
  total_recv : int64;
  current_inflow : int;
  current_outflow : int;
}

let empty =
  {total_sent = 0L; total_recv = 0L; current_inflow = 0; current_outflow = 0}

let print_size ppf sz =
  let ratio n = float_of_int sz /. float_of_int (1 lsl n) in
  if sz < 1 lsl 10 then Format.fprintf ppf "%d B" sz
  else if sz < 1 lsl 20 then Format.fprintf ppf "%.2f kiB" (ratio 10)
  else Format.fprintf ppf "%.2f MiB" (ratio 20)

let print_size64 ppf sz =
  let open Int64 in
  let ratio n = to_float sz /. float_of_int (1 lsl n) in
  if sz < shift_left 1L 10 then Format.fprintf ppf "%Ld B" sz
  else if sz < shift_left 1L 20 then Format.fprintf ppf "%.2f kiB" (ratio 10)
  else if sz < shift_left 1L 30 then Format.fprintf ppf "%.2f MiB" (ratio 20)
  else if sz < shift_left 1L 40 then Format.fprintf ppf "%.2f GiB" (ratio 30)
  else Format.fprintf ppf "%.2f TiB" (ratio 40)

let pp ppf stat =
  Format.fprintf
    ppf
    "↗ %a (%a/s) ↘ %a (%a/s)"
    print_size64
    stat.total_sent
    print_size
    stat.current_outflow
    print_size64
    stat.total_recv
    print_size
    stat.current_inflow

let encoding =
  let open Data_encoding in
  def "p2p_stat" ~description:"Statistics about the p2p network."
  @@ conv
       (fun {total_sent; total_recv; current_inflow; current_outflow} ->
         (total_sent, total_recv, current_inflow, current_outflow))
       (fun (total_sent, total_recv, current_inflow, current_outflow) ->
         {total_sent; total_recv; current_inflow; current_outflow})
       (obj4
          (req "total_sent" int64)
          (req "total_recv" int64)
          (req "current_inflow" int31)
          (req "current_outflow" int31))

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_stat.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  total_sent : int64;
  total_recv : int64;
  current_inflow : Z;
  current_outflow : Z }.

Definition empty : t :=
  {| total_sent := 0; total_recv := 0; current_inflow := 0; current_outflow := 0
    |}.

Definition print_size (ppf : Stdlib.Format.formatter) (sz : Z) : unit :=
  let ratio (n : Z) : float :=
    Stdlib.op_div_point (Stdlib.float_of_int sz)
      (Stdlib.float_of_int (Z.shiftl 1 n)) in
  if OCaml.Stdlib.lt sz (Z.shiftl 1 10) then
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal " B" % string
            CamlinternalFormatBasics.End_of_format)) "%d B" % string) sz
  else
    if OCaml.Stdlib.lt sz (Z.shiftl 1 20) then
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Lit_precision 2)
            (CamlinternalFormatBasics.String_literal " kiB" % string
              CamlinternalFormatBasics.End_of_format)) "%.2f kiB" % string)
        (ratio 10)
    else
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Lit_precision 2)
            (CamlinternalFormatBasics.String_literal " MiB" % string
              CamlinternalFormatBasics.End_of_format)) "%.2f MiB" % string)
        (ratio 20).

Definition print_size64 (ppf : Stdlib.Format.formatter) (sz : int64) : unit :=
  let ratio (n : Z) : float :=
    Stdlib.op_div_point (Stdlib.Int64.to_float sz)
      (Stdlib.float_of_int (Z.shiftl 1 n)) in
  if OCaml.Stdlib.lt sz (Stdlib.Int64.shift_left 1 10) then
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal " B" % string
            CamlinternalFormatBasics.End_of_format)) "%Ld B" % string) sz
  else
    if OCaml.Stdlib.lt sz (Stdlib.Int64.shift_left 1 20) then
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Lit_precision 2)
            (CamlinternalFormatBasics.String_literal " kiB" % string
              CamlinternalFormatBasics.End_of_format)) "%.2f kiB" % string)
        (ratio 10)
    else
      if OCaml.Stdlib.lt sz (Stdlib.Int64.shift_left 1 30) then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Lit_precision 2)
              (CamlinternalFormatBasics.String_literal " MiB" % string
                CamlinternalFormatBasics.End_of_format)) "%.2f MiB" % string)
          (ratio 20)
      else
        if OCaml.Stdlib.lt sz (Stdlib.Int64.shift_left 1 40) then
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Lit_precision 2)
                (CamlinternalFormatBasics.String_literal " GiB" % string
                  CamlinternalFormatBasics.End_of_format)) "%.2f GiB" % string)
            (ratio 30)
        else
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Lit_precision 2)
                (CamlinternalFormatBasics.String_literal " TiB" % string
                  CamlinternalFormatBasics.End_of_format)) "%.2f TiB" % string)
            (ratio 40).

Definition pp (ppf : Stdlib.Format.formatter) (stat : t) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "↗ " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal " (" % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal "/s) ↘ " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal "/s)" % string
                        CamlinternalFormatBasics.End_of_format)))))))))
      "↗ %a (%a/s) ↘ %a (%a/s)" % string) print_size64 (total_sent stat)
    print_size (current_outflow stat) print_size64 (total_recv stat) print_size
    (current_inflow stat).

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "p2p_stat" % string
        expected_argument (Some "Statistics about the p2p network." % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          total_sent := total_sent;
            total_recv := total_recv;
            current_inflow := current_inflow;
            current_outflow := current_outflow
            |} => (total_sent, total_recv, current_inflow, current_outflow)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (total_sent, total_recv, current_inflow, current_outflow) =>
          {| total_sent := total_sent; total_recv := total_recv;
            current_inflow := current_inflow; current_outflow := current_outflow
            |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj4
        (Tezos_data_encoding.Data_encoding.req None None "total_sent" % string
          Tezos_data_encoding.Data_encoding.int64)
        (Tezos_data_encoding.Data_encoding.req None None "total_recv" % string
          Tezos_data_encoding.Data_encoding.int64)
        (Tezos_data_encoding.Data_encoding.req None None
          "current_inflow" % string Tezos_data_encoding.Data_encoding.int31)
        (Tezos_data_encoding.Data_encoding.req None None
          "current_outflow" % string Tezos_data_encoding.Data_encoding.int31))).
src/lib_base/p2p_stat.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Bandwidth usage statistics *)

type t = {
  total_sent : int64;
  total_recv : int64;
  current_inflow : int;
  current_outflow : int;
}

val empty : t

val pp : Format.formatter -> t -> unit

val encoding : t Data_encoding.t
src/lib_base/p2p_stat.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  total_sent : int64;
  total_recv : int64;
  current_inflow : Z;
  current_outflow : Z }.

Parameter empty : t.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
src/lib_base/p2p_version.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int

let pp = Format.pp_print_int

let encoding =
  let open Data_encoding in
  def "p2p_version" ~description:"A version number for the p2p layer." uint16

let zero = 0

let supported = [zero]

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_version.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Z.

Definition pp : Stdlib.Format.formatter -> Z -> unit :=
  Stdlib.Format.pp_print_int.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
  Tezos_data_encoding.Data_encoding.def "p2p_version" % string None
    (Some "A version number for the p2p layer." % string)
    Tezos_data_encoding.Data_encoding.uint16.

Definition zero : Z := 0.

Definition supported : list Z := cons zero [].
src/lib_base/p2p_version.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** P2p-layer protocol version. *)

(** An abstract version number for the low-level P2P layer. *)
type t = private int

val pp : Format.formatter -> t -> unit

val encoding : t Data_encoding.t

val supported : t list

val zero : t
src/lib_base/p2p_version.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Z.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter encoding : Tezos_data_encoding.Data_encoding.t t.

Parameter supported : list t.

Parameter zero : t.
src/lib_base/preapply_result.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'error t = {
  applied : (Operation_hash.t * Operation.t) list;
  refused : (Operation.t * 'error list) Operation_hash.Map.t;
  branch_refused : (Operation.t * 'error list) Operation_hash.Map.t;
  branch_delayed : (Operation.t * 'error list) Operation_hash.Map.t;
}

let empty =
  {
    applied = [];
    refused = Operation_hash.Map.empty;
    branch_refused = Operation_hash.Map.empty;
    branch_delayed = Operation_hash.Map.empty;
  }

let map f r =
  {
    applied = r.applied;
    refused = Operation_hash.Map.map f r.refused;
    branch_refused = Operation_hash.Map.map f r.branch_refused;
    branch_delayed = Operation_hash.Map.map f r.branch_delayed;
  }

let encoding error_encoding =
  let open Data_encoding in
  let operation_encoding =
    merge_objs
      (obj1 (req "hash" Operation_hash.encoding))
      (dynamic_size Operation.encoding)
  in
  let refused_encoding =
    merge_objs
      (obj1 (req "hash" Operation_hash.encoding))
      (merge_objs
         (dynamic_size Operation.encoding)
         (obj1 (req "error" error_encoding)))
  in
  let build_list map = Operation_hash.Map.bindings map in
  let build_map list =
    List.fold_right
      (fun (k, e) m -> Operation_hash.Map.add k e m)
      list
      Operation_hash.Map.empty
  in
  conv
    (fun {applied; refused; branch_refused; branch_delayed} ->
      ( applied,
        build_list refused,
        build_list branch_refused,
        build_list branch_delayed ))
    (fun (applied, refused, branch_refused, branch_delayed) ->
      let refused = build_map refused in
      let branch_refused = build_map branch_refused in
      let branch_delayed = build_map branch_delayed in
      {applied; refused; branch_refused; branch_delayed})
    (obj4
       (req "applied" (list operation_encoding))
       (req "refused" (list refused_encoding))
       (req "branch_refused" (list refused_encoding))
       (req "branch_delayed" (list refused_encoding)))

let operations t =
  let ops =
    List.fold_left
      (fun acc (h, op) -> Operation_hash.Map.add h op acc)
      Operation_hash.Map.empty
      t.applied
  in
  let ops =
    Operation_hash.Map.fold
      (fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
      t.branch_delayed
      ops
  in
  let ops =
    Operation_hash.Map.fold
      (fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
      t.branch_refused
      ops
  in
  ops
src/lib_base/preapply_result.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t {error : Type} := {
  applied : list (Tezos_crypto.Operation_hash.t * Tezos_base.Operation.t);
  refused :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
  branch_refused :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
  branch_delayed :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error)) }.
Arguments t : clear implicits.

Definition empty {A : Type} : t A :=
  {| applied := []; refused := Tezos_crypto.Operation_hash.Map.empty;
    branch_refused := Tezos_crypto.Operation_hash.Map.empty;
    branch_delayed := Tezos_crypto.Operation_hash.Map.empty |}.

Definition map {A B : Type}
  (f : (Tezos_base.Operation.t * (list A)) -> Tezos_base.Operation.t * (list B))
  (r : t A) : t B :=
  {| applied := applied r;
    refused := Tezos_crypto.Operation_hash.Map.map f (refused r);
    branch_refused := Tezos_crypto.Operation_hash.Map.map f (branch_refused r);
    branch_delayed := Tezos_crypto.Operation_hash.Map.map f (branch_delayed r)
    |}.

Definition encoding {A : Type}
  (error_encoding : Tezos_data_encoding.Data_encoding.encoding (list A))
  : Tezos_data_encoding.Data_encoding.encoding (t A) :=
  let operation_encoding :=
    Tezos_data_encoding.Data_encoding.merge_objs
      (Tezos_data_encoding.Data_encoding.obj1
        (Tezos_data_encoding.Data_encoding.req None None "hash" % string
          Tezos_crypto.Operation_hash.encoding))
      (Tezos_data_encoding.Data_encoding.dynamic_size None
        Tezos_base.Operation.encoding) in
  let refused_encoding :=
    Tezos_data_encoding.Data_encoding.merge_objs
      (Tezos_data_encoding.Data_encoding.obj1
        (Tezos_data_encoding.Data_encoding.req None None "hash" % string
          Tezos_crypto.Operation_hash.encoding))
      (Tezos_data_encoding.Data_encoding.merge_objs
        (Tezos_data_encoding.Data_encoding.dynamic_size None
          Tezos_base.Operation.encoding)
        (Tezos_data_encoding.Data_encoding.obj1
          (Tezos_data_encoding.Data_encoding.req None None "error" % string
            error_encoding))) in
  let build_list {B : Type} (map : Tezos_crypto.Operation_hash.Map.t B)
    : list (Tezos_crypto.Operation_hash.Map.key * B) :=
    Tezos_crypto.Operation_hash.Map.bindings map in
  let build_map {B : Type}
    (list : list (Tezos_crypto.Operation_hash.Map.key * B))
    : Tezos_crypto.Operation_hash.Map.t B :=
    Stdlib.List.fold_right
      (fun function_parameter =>
        match function_parameter with
        | (k, e) => fun m => Tezos_crypto.Operation_hash.Map.add k e m
        end) list Tezos_crypto.Operation_hash.Map.empty in
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        applied := applied;
          refused := refused;
          branch_refused := branch_refused;
          branch_delayed := branch_delayed
          |} =>
        (applied, (build_list refused), (build_list branch_refused),
          (build_list branch_delayed))
      end)
    (fun function_parameter =>
      match function_parameter with
      | (applied, refused, branch_refused, branch_delayed) =>
        let refused := build_map refused in
        let branch_refused := build_map branch_refused in
        let branch_delayed := build_map branch_delayed in
        {| applied := applied; refused := refused;
          branch_refused := branch_refused; branch_delayed := branch_delayed |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj4
      (Tezos_data_encoding.Data_encoding.req None None "applied" % string
        (Tezos_data_encoding.Data_encoding.list None operation_encoding))
      (Tezos_data_encoding.Data_encoding.req None None "refused" % string
        (Tezos_data_encoding.Data_encoding.list None refused_encoding))
      (Tezos_data_encoding.Data_encoding.req None None "branch_refused" % string
        (Tezos_data_encoding.Data_encoding.list None refused_encoding))
      (Tezos_data_encoding.Data_encoding.req None None "branch_delayed" % string
        (Tezos_data_encoding.Data_encoding.list None refused_encoding))).

Definition operations {A : Type} (t : t A)
  : Tezos_crypto.Operation_hash.Map.t Tezos_base.Operation.t :=
  let ops :=
    Stdlib.List.fold_left
      (fun acc =>
        fun function_parameter =>
          match function_parameter with
          | (h, op) => Tezos_crypto.Operation_hash.Map.add h op acc
          end) Tezos_crypto.Operation_hash.Map.empty (applied t) in
  let ops :=
    Tezos_crypto.Operation_hash.Map.fold
      (fun h =>
        fun function_parameter =>
          match function_parameter with
          | (op, _err) =>
            fun acc => Tezos_crypto.Operation_hash.Map.add h op acc
          end) (branch_delayed t) ops in
  let ops :=
    Tezos_crypto.Operation_hash.Map.fold
      (fun h =>
        fun function_parameter =>
          match function_parameter with
          | (op, _err) =>
            fun acc => Tezos_crypto.Operation_hash.Map.add h op acc
          end) (branch_refused t) ops in
  ops.
src/lib_base/preapply_result.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'error t = {
  applied : (Operation_hash.t * Operation.t) list;
  refused : (Operation.t * 'error list) Operation_hash.Map.t;
  (* e.g. invalid signature *)
  branch_refused : (Operation.t * 'error list) Operation_hash.Map.t;
  (* e.g. insufficient balance *)
  branch_delayed : (Operation.t * 'error list) Operation_hash.Map.t;
      (* e.g. timestamp in the future *)
}

val empty : 'error t

val map : (Operation.t * 'a list -> Operation.t * 'b list) -> 'a t -> 'b t

val operations : 'error t -> Operation.t Operation_hash.Map.t

val encoding : 'error list Data_encoding.t -> 'error t Data_encoding.t
src/lib_base/preapply_result.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t {error : Type} := {
  applied : list (Tezos_crypto.Operation_hash.t * Tezos_base.Operation.t);
  refused :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
  branch_refused :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
  branch_delayed :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error)) }.
Arguments t : clear implicits.

Parameter empty : forall {error : Type}, t error.

Parameter map : forall {a b : Type},
((Tezos_base.Operation.t * (list a)) -> Tezos_base.Operation.t * (list b)) ->
  (t a) -> t b.

Parameter operations : forall {error : Type},
(t error) -> Tezos_crypto.Operation_hash.Map.t Tezos_base.Operation.t.

Parameter encoding : forall {error : Type},
(Tezos_data_encoding.Data_encoding.t (list error)) ->
  Tezos_data_encoding.Data_encoding.t (t error).
src/lib_base/protocol.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {expected_env : env_version; components : component list}

and component = {
  name : string;
  interface : string option;
  implementation : string;
}

and env_version = V1

include Compare.Make (struct
  type nonrec t = t

  let compare = Pervasives.compare
end)

let component_encoding =
  let open Data_encoding in
  conv
    (fun {name; interface; implementation} ->
      (name, interface, implementation))
    (fun (name, interface, implementation) ->
      {name; interface; implementation})
    (obj3
       (req "name" string)
       (opt "interface" string)
       (req "implementation" string))

let env_version_encoding =
  let open Data_encoding in
  conv
    (function V1 -> 0)
    (function 0 -> V1 | _ -> failwith "unexpected environment version")
    int16

let encoding =
  let open Data_encoding in
  def
    "protocol"
    ~description:
      "The environment a protocol relies on and the components a protocol is \
       made of."
  @@ conv
       (fun {expected_env; components} -> (expected_env, components))
       (fun (expected_env, components) -> {expected_env; components})
       (obj2
          (req "expected_env_version" env_version_encoding)
          (req "components" (list component_encoding)))

let bounded_encoding ?max_size () =
  match max_size with
  | None ->
      encoding
  | Some max_size ->
      Data_encoding.check_size max_size encoding

let pp ppf op =
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op)

let env_version_to_string = function V1 -> "V1"

let pp_ocaml_component ppf {name; interface; implementation} =
  Format.fprintf
    ppf
    "@[{@[<v 1> name = %S ;@ interface = %a ;@ implementation = %S ;@]@ }@]"
    name
    (fun ppf -> function None -> Format.fprintf ppf "None" | Some s ->
          Format.fprintf ppf "Some %S" s)
    interface
    implementation

let pp_ocaml ppf {expected_env; components} =
  Format.fprintf
    ppf
    "@[{@[<v 1> expected_env = %s ;@ components = [@[<v>%a@]] ;@]@ }@]"
    (env_version_to_string expected_env)
    (Format.pp_print_list
       ~pp_sep:(fun ppf () -> Format.fprintf ppf " ;@ ")
       pp_ocaml_component)
    components

let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

let of_bytes b = Data_encoding.Binary.of_bytes encoding b

let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b

let hash proto = Protocol_hash.hash_bytes [to_bytes proto]

let hash_raw proto = Protocol_hash.hash_bytes [proto]

module Meta = struct
  type t = {
    hash : Protocol_hash.t option;
    expected_env_version : env_version option;
    modules : string list;
  }

  let encoding =
    let open Data_encoding in
    def "protocol.meta"
    (* FIXME: add ~description argument *)
    @@ conv
         (fun {hash; expected_env_version; modules} ->
           (hash, expected_env_version, modules))
         (fun (hash, expected_env_version, modules) ->
           {hash; expected_env_version; modules})
    @@ obj3
         (opt
            "hash"
            ~description:"Used to force the hash of the protocol"
            Protocol_hash.encoding)
         (opt "expected_env_version" env_version_encoding)
         (req
            "modules"
            ~description:"Modules comprising the protocol"
            (list string))
end

let () =
  Data_encoding.Registration.register ~pp:pp_ocaml encoding ;
  Data_encoding.Registration.register Meta.encoding
src/lib_base/protocol.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive env_version : Type :=
| V1 : env_version.

Definition component_encoding
  : Tezos_data_encoding.Data_encoding.encoding component :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        name := name;
          interface := interface;
          implementation := implementation
          |} => (name, interface, implementation)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (name, interface, implementation) =>
        {| name := name; interface := interface;
          implementation := implementation |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj3
      (Tezos_data_encoding.Data_encoding.req None None "name" % string
        Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.opt None None "interface" % string
        Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.req None None "implementation" % string
        Tezos_data_encoding.Data_encoding.string)).

Definition env_version_encoding
  : Tezos_data_encoding.Data_encoding.encoding env_version :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | V1 => 0
      end)
    (fun function_parameter =>
      match function_parameter with
      | 0 => V1
      | _ => OCaml.Stdlib.failwith "unexpected environment version" % string
      end) None Tezos_data_encoding.Data_encoding.int16.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "protocol" % string
        expected_argument
        (Some
          "The environment a protocol relies on and the components a protocol is made of."
            % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| expected_env := expected_env; components := components |} =>
          (expected_env, components)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (expected_env, components) =>
          {| expected_env := expected_env; components := components |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj2
        (Tezos_data_encoding.Data_encoding.req None None
          "expected_env_version" % string env_version_encoding)
        (Tezos_data_encoding.Data_encoding.req None None "components" % string
          (Tezos_data_encoding.Data_encoding.list None component_encoding)))).

Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding t :=
  match function_parameter with
  | tt =>
    match max_size with
    | None => encoding
    | Some max_size =>
      Tezos_data_encoding.Data_encoding.check_size max_size encoding
    end
  end.

Definition pp (ppf : Stdlib.Format.formatter) (op : t) : unit :=
  Tezos_data_encoding.Data_encoding.Json.pp ppf
    (Tezos_data_encoding.Data_encoding.Json.construct encoding op).

Definition env_version_to_string (function_parameter : env_version) : string :=
  match function_parameter with
  | V1 => "V1" % string
  end.

Definition pp_ocaml_component
  (ppf : Stdlib.Format.formatter) (function_parameter : component) : unit :=
  match function_parameter with
  | {| name := name; interface := interface; implementation := implementation |}
    =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.Char_literal "{" % char
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 1>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
              (CamlinternalFormatBasics.String_literal " name = " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " ;" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "interface = " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal " ;" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.String_literal
                                "implementation = " % string
                                (CamlinternalFormatBasics.Caml_string
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " ;" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.Char_literal
                                          "}" % char
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format))))))))))))))))))
        "@[{@[<v 1> name = %S ;@ interface = %a ;@ implementation = %S ;@]@ }@]"
          % string) name
      (fun ppf =>
        fun function_parameter =>
          match function_parameter with
          | None =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "None" % string
                  CamlinternalFormatBasics.End_of_format) "None" % string)
          | Some s =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Some " % string
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format)) "Some %S" % string)
              s
          end) interface implementation
  end.

Definition pp_ocaml (ppf : Stdlib.Format.formatter) (function_parameter : t)
  : unit :=
  match function_parameter with
  | {| expected_env := expected_env; components := components |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.Char_literal "{" % char
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 1>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
              (CamlinternalFormatBasics.String_literal
                " expected_env = " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " ;" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "components = [" % string
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v>" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.String_literal
                                "] ;" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.Char_literal
                                      "}" % char
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))))
        "@[{@[<v 1> expected_env = %s ;@ components = [@[<v>%a@]] ;@]@ }@]" %
          string) (env_version_to_string expected_env)
      (Stdlib.Format.pp_print_list
        (Some
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal " ;" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        CamlinternalFormatBasics.End_of_format)) " ;@ " % string)
              end)) pp_ocaml_component) components
  end.

Definition to_bytes (v : t) : Stdlib.Bytes.t :=
  Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn encoding v.

Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
  Tezos_data_encoding.Data_encoding.Binary.of_bytes encoding b.

Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
  Tezos_data_encoding.Data_encoding.Binary.of_bytes_exn encoding b.

Definition hash (proto : t) : Tezos_crypto.Protocol_hash.t :=
  Tezos_crypto.Protocol_hash.hash_bytes None (cons (to_bytes proto) []).

Definition hash_raw (proto : Stdlib.Bytes.t) : Tezos_crypto.Protocol_hash.t :=
  Tezos_crypto.Protocol_hash.hash_bytes None (cons proto []).

Module Meta.
  Record t := {
    hash : option Tezos_crypto.Protocol_hash.t;
    expected_env_version : option env_version;
    modules : list string }.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg := Tezos_data_encoding.Data_encoding.def "protocol.meta" % string
        in
      fun eta => arg None None eta)
      (apply
        (let arg :=
          Tezos_data_encoding.Data_encoding.conv
            (fun function_parameter =>
              match function_parameter with
              | {|
                hash := hash;
                  expected_env_version := expected_env_version;
                  modules := modules
                  |} => (hash, expected_env_version, modules)
              end)
            (fun function_parameter =>
              match function_parameter with
              | (hash, expected_env_version, modules) =>
                {| hash := hash; expected_env_version := expected_env_version;
                  modules := modules |}
              end) in
        fun eta => arg None eta)
        (Tezos_data_encoding.Data_encoding.obj3
          (Tezos_data_encoding.Data_encoding.opt None
            (Some "Used to force the hash of the protocol" % string)
            "hash" % string Tezos_crypto.Protocol_hash.encoding)
          (Tezos_data_encoding.Data_encoding.opt None None
            "expected_env_version" % string env_version_encoding)
          (Tezos_data_encoding.Data_encoding.req None
            (Some "Modules comprising the protocol" % string) "modules" % string
            (Tezos_data_encoding.Data_encoding.list None
              Tezos_data_encoding.Data_encoding.string)))).
End Meta.
src/lib_base/protocol.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {expected_env : env_version; components : component list}

and component = {
  name : string;
  interface : string option;
  implementation : string;
}

and env_version = V1

val component_encoding : component Data_encoding.t

val env_version_encoding : env_version Data_encoding.t

val pp_ocaml : Format.formatter -> t -> unit

include S.HASHABLE with type t := t and type hash := Protocol_hash.t

val of_bytes_exn : Bytes.t -> t

val bounded_encoding : ?max_size:int -> unit -> t Data_encoding.t

module Meta : sig
  type t = {
    hash : Protocol_hash.t option;
    expected_env_version : env_version option;
    modules : string list;
  }

  val encoding : t Data_encoding.t
end
src/lib_base/protocol.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive env_version : Type :=
| V1 : env_version.

Parameter component_encoding : Tezos_data_encoding.Data_encoding.t component.

Parameter env_version_encoding :
Tezos_data_encoding.Data_encoding.t env_version.

Parameter pp_ocaml : Stdlib.Format.formatter -> t -> unit.

Parameter of_bytes_exn : Stdlib.Bytes.t -> t.

Parameter bounded_encoding :
(option Z) -> unit -> Tezos_data_encoding.Data_encoding.t t.

Module Meta.
  Record t := {
    hash : option Tezos_crypto.Protocol_hash.t;
    expected_env_version : option env_version;
    modules : list string }.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
End Meta.
src/lib_base/s.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type T = sig
  type t

  include Compare.S with type t := t

  val pp : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t

  val to_bytes : t -> Bytes.t

  val of_bytes : Bytes.t -> t option
end

module type HASHABLE = sig
  include T

  type hash

  val hash : t -> hash

  val hash_raw : Bytes.t -> hash
end

module type SET = sig
  type elt

  type t

  val empty : t

  val is_empty : t -> bool

  val mem : elt -> t -> bool

  val add : elt -> t -> t

  val singleton : elt -> t

  val remove : elt -> t -> t

  val union : t -> t -> t

  val inter : t -> t -> t

  val diff : t -> t -> t

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val subset : t -> t -> bool

  val iter : (elt -> unit) -> t -> unit

  val map : (elt -> elt) -> t -> t

  val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a

  val for_all : (elt -> bool) -> t -> bool

  val exists : (elt -> bool) -> t -> bool

  val filter : (elt -> bool) -> t -> t

  val partition : (elt -> bool) -> t -> t * t

  val cardinal : t -> int

  val elements : t -> elt list

  val min_elt_opt : t -> elt option

  val max_elt_opt : t -> elt option

  val choose_opt : t -> elt option

  val split : elt -> t -> t * bool * t

  val find_opt : elt -> t -> elt option

  val find_first_opt : (elt -> bool) -> t -> elt option

  val find_last_opt : (elt -> bool) -> t -> elt option

  val of_list : elt list -> t
end

module type MAP = sig
  type key

  type +'a t

  val empty : 'a t

  val is_empty : 'a t -> bool

  val mem : key -> 'a t -> bool

  val add : key -> 'a -> 'a t -> 'a t

  val update : key -> ('a option -> 'a option) -> 'a t -> 'a t

  val singleton : key -> 'a -> 'a t

  val remove : key -> 'a t -> 'a t

  val merge :
    (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t

  val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t

  val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int

  val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool

  val iter : (key -> 'a -> unit) -> 'a t -> unit

  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val for_all : (key -> 'a -> bool) -> 'a t -> bool

  val exists : (key -> 'a -> bool) -> 'a t -> bool

  val filter : (key -> 'a -> bool) -> 'a t -> 'a t

  val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t

  val cardinal : 'a t -> int

  val bindings : 'a t -> (key * 'a) list

  val min_binding_opt : 'a t -> (key * 'a) option

  val max_binding_opt : 'a t -> (key * 'a) option

  val choose_opt : 'a t -> (key * 'a) option

  val split : key -> 'a t -> 'a t * 'a option * 'a t

  val find_opt : key -> 'a t -> 'a option

  val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option

  val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option

  val map : ('a -> 'b) -> 'a t -> 'b t

  val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
end
src/lib_base/s.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module T.
  Record signature {t : Type} := {
    t := t;
    include;
    pp : Stdlib.Format.formatter -> t -> unit;
    encoding : Tezos_data_encoding.Data_encoding.t t;
    to_bytes : t -> Stdlib.Bytes.t;
    of_bytes : Stdlib.Bytes.t -> option t;
  }.
  Arguments signature : clear implicits.
End T.

Module HASHABLE.
  Record signature {t hash : Type} := {
    include;
    hash := hash;
    hash : t -> hash;
    hash_raw : Stdlib.Bytes.t -> hash;
  }.
  Arguments signature : clear implicits.
End HASHABLE.

Module SET.
  Record signature {elt t : Type} := {
    elt := elt;
    t := t;
    empty : t;
    is_empty : t -> bool;
    mem : elt -> t -> bool;
    add : elt -> t -> t;
    singleton : elt -> t;
    remove : elt -> t -> t;
    union : t -> t -> t;
    inter : t -> t -> t;
    diff : t -> t -> t;
    compare : t -> t -> Z;
    equal : t -> t -> bool;
    subset : t -> t -> bool;
    iter : (elt -> unit) -> t -> unit;
    map : (elt -> elt) -> t -> t;
    fold : forall {a : Type}, (elt -> a -> a) -> t -> a -> a;
    for_all : (elt -> bool) -> t -> bool;
    _exists : (elt -> bool) -> t -> bool;
    filter : (elt -> bool) -> t -> t;
    partition : (elt -> bool) -> t -> t * t;
    cardinal : t -> Z;
    elements : t -> list elt;
    min_elt_opt : t -> option elt;
    max_elt_opt : t -> option elt;
    choose_opt : t -> option elt;
    split : elt -> t -> t * bool * t;
    find_opt : elt -> t -> option elt;
    find_first_opt : (elt -> bool) -> t -> option elt;
    find_last_opt : (elt -> bool) -> t -> option elt;
    of_list : (list elt) -> t;
  }.
  Arguments signature : clear implicits.
End SET.

Module MAP.
  Record signature {key t : Type} := {
    key := key;
    polymorphic_abstract_type;
    empty : forall {a : Type}, t a;
    is_empty : forall {a : Type}, (t a) -> bool;
    mem : forall {a : Type}, key -> (t a) -> bool;
    add : forall {a : Type}, key -> a -> (t a) -> t a;
    update : forall {a : Type}, key -> ((option a) -> option a) -> (t a) -> t a;
    singleton : forall {a : Type}, key -> a -> t a;
    remove : forall {a : Type}, key -> (t a) -> t a;
    merge : forall {a b c : Type}, (key -> (option a) -> (option b) -> option c)
      -> (t a) -> (t b) -> t c;
    union : forall {a : Type}, (key -> a -> a -> option a) ->
      (t a) -> (t a) -> t a;
    compare : forall {a : Type}, (a -> a -> Z) -> (t a) -> (t a) -> Z;
    equal : forall {a : Type}, (a -> a -> bool) -> (t a) -> (t a) -> bool;
    iter : forall {a : Type}, (key -> a -> unit) -> (t a) -> unit;
    fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
    for_all : forall {a : Type}, (key -> a -> bool) -> (t a) -> bool;
    _exists : forall {a : Type}, (key -> a -> bool) -> (t a) -> bool;
    filter : forall {a : Type}, (key -> a -> bool) -> (t a) -> t a;
    partition : forall {a : Type}, (key -> a -> bool) -> (t a) -> (t a) * (t a);
    cardinal : forall {a : Type}, (t a) -> Z;
    bindings : forall {a : Type}, (t a) -> list (key * a);
    min_binding_opt : forall {a : Type}, (t a) -> option (key * a);
    max_binding_opt : forall {a : Type}, (t a) -> option (key * a);
    choose_opt : forall {a : Type}, (t a) -> option (key * a);
    split : forall {a : Type}, key -> (t a) -> (t a) * (option a) * (t a);
    find_opt : forall {a : Type}, key -> (t a) -> option a;
    find_first_opt : forall {a : Type}, (key -> bool) ->
      (t a) -> option (key * a);
    find_last_opt : forall {a : Type}, (key -> bool) ->
      (t a) -> option (key * a);
    map : forall {a b : Type}, (a -> b) -> (t a) -> t b;
    mapi : forall {a b : Type}, (key -> a -> b) -> (t a) -> t b;
  }.
  Arguments signature : clear implicits.
End MAP.
src/lib_base/test_chain_status.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t =
  | Not_running
  | Forking of {protocol : Protocol_hash.t; expiration : Time.Protocol.t}
  | Running of {
      chain_id : Chain_id.t;
      genesis : Block_hash.t;
      protocol : Protocol_hash.t;
      expiration : Time.Protocol.t;
    }

let encoding =
  let open Data_encoding in
  def
    "test_chain_status"
    ~description:
      "The status of the test chain: not_running (there is no test chain at \
       the moment), forking (the test chain is being setup), running (the \
       test chain is running)."
  @@ union
       [ case
           (Tag 0)
           ~title:"Not_running"
           (obj1 (req "status" (constant "not_running")))
           (function Not_running -> Some () | _ -> None)
           (fun () -> Not_running);
         case
           (Tag 1)
           ~title:"Forking"
           (obj3
              (req "status" (constant "forking"))
              (req "protocol" Protocol_hash.encoding)
              (req "expiration" Time.Protocol.encoding))
           (function
             | Forking {protocol; expiration} ->
                 Some ((), protocol, expiration)
             | _ ->
                 None)
           (fun ((), protocol, expiration) -> Forking {protocol; expiration});
         case
           (Tag 2)
           ~title:"Running"
           (obj5
              (req "status" (constant "running"))
              (req "chain_id" Chain_id.encoding)
              (req "genesis" Block_hash.encoding)
              (req "protocol" Protocol_hash.encoding)
              (req "expiration" Time.Protocol.encoding))
           (function
             | Running {chain_id; genesis; protocol; expiration} ->
                 Some ((), chain_id, genesis, protocol, expiration)
             | _ ->
                 None)
           (fun ((), chain_id, genesis, protocol, expiration) ->
             Running {chain_id; genesis; protocol; expiration}) ]

let pp ppf = function
  | Not_running ->
      Format.fprintf ppf "@[<v 2>Not running@]"
  | Forking {protocol; expiration} ->
      Format.fprintf
        ppf
        "@[<v 2>Forking %a (expires %a)@]"
        Protocol_hash.pp
        protocol
        Time.System.pp_hum
        (Time.System.of_protocol_exn expiration)
  | Running {chain_id; genesis; protocol; expiration} ->
      Format.fprintf
        ppf
        "@[<v 2>Running %a@ Genesis: %a@ Net id: %a@ Expiration: %a@]"
        Protocol_hash.pp
        protocol
        Block_hash.pp
        genesis
        Chain_id.pp
        chain_id
        Time.System.pp_hum
        (Time.System.of_protocol_exn expiration)

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/test_chain_status.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Not_running : t
| Forking : Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t
| Running : Tezos_crypto.Chain_id.t -> Tezos_crypto.Block_hash.t ->
  Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      Tezos_data_encoding.Data_encoding.def "test_chain_status" % string
        expected_argument
        (Some
          "The status of the test chain: not_running (there is no test chain at the moment), forking (the test chain is being setup), running (the test chain is running)."
            % string) in
    fun eta => arg None eta)
    (Tezos_data_encoding.Data_encoding.union None
      (cons
        (Tezos_data_encoding.Data_encoding.case "Not_running" % string None
          (Tag 0)
          (Tezos_data_encoding.Data_encoding.obj1
            (Tezos_data_encoding.Data_encoding.req None None "status" % string
              (Tezos_data_encoding.Data_encoding.constant "not_running" % string)))
          (fun function_parameter =>
            match function_parameter with
            | Not_running => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | tt => Not_running
            end))
        (cons
          (Tezos_data_encoding.Data_encoding.case "Forking" % string None
            (Tag 1)
            (Tezos_data_encoding.Data_encoding.obj3
              (Tezos_data_encoding.Data_encoding.req None None "status" % string
                (Tezos_data_encoding.Data_encoding.constant "forking" % string))
              (Tezos_data_encoding.Data_encoding.req None None
                "protocol" % string Tezos_crypto.Protocol_hash.encoding)
              (Tezos_data_encoding.Data_encoding.req None None
                "expiration" % string Tezos_base.Time.Protocol.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Forking {| protocol := protocol; expiration := expiration |} =>
                Some (tt, protocol, expiration)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tt, protocol, expiration) =>
                Forking {| protocol := protocol; expiration := expiration |}
              end))
          (cons
            (Tezos_data_encoding.Data_encoding.case "Running" % string None
              (Tag 2)
              (Tezos_data_encoding.Data_encoding.obj5
                (Tezos_data_encoding.Data_encoding.req None None
                  "status" % string
                  (Tezos_data_encoding.Data_encoding.constant "running" % string))
                (Tezos_data_encoding.Data_encoding.req None None
                  "chain_id" % string Tezos_crypto.Chain_id.encoding)
                (Tezos_data_encoding.Data_encoding.req None None
                  "genesis" % string Tezos_crypto.Block_hash.encoding)
                (Tezos_data_encoding.Data_encoding.req None None
                  "protocol" % string Tezos_crypto.Protocol_hash.encoding)
                (Tezos_data_encoding.Data_encoding.req None None
                  "expiration" % string Tezos_base.Time.Protocol.encoding))
              (fun function_parameter =>
                match function_parameter with
                |
                  Running {|
                    chain_id := chain_id;
                      genesis := genesis;
                      protocol := protocol;
                      expiration := expiration
                      |} => Some (tt, chain_id, genesis, protocol, expiration)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (tt, chain_id, genesis, protocol, expiration) =>
                  Running
                    {| chain_id := chain_id; genesis := genesis;
                      protocol := protocol; expiration := expiration |}
                end)) [])))).

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | Not_running =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Not running" % string
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format)))
        "@[<v 2>Not running@]" % string)
  | Forking {| protocol := protocol; expiration := expiration |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Forking " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " (expires " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))))
        "@[<v 2>Forking %a (expires %a)@]" % string)
      Tezos_crypto.Protocol_hash.pp protocol Tezos_base.Time.System.pp_hum
      (Tezos_base.Time.System.of_protocol_exn expiration)
  |
    Running {|
      chain_id := chain_id;
        genesis := genesis;
        protocol := protocol;
        expiration := expiration
        |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Running " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.String_literal "Genesis: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "Net id: " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "Expiration: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format)))))))))))))
        "@[<v 2>Running %a@ Genesis: %a@ Net id: %a@ Expiration: %a@]" % string)
      Tezos_crypto.Protocol_hash.pp protocol Tezos_crypto.Block_hash.pp genesis
      Tezos_crypto.Chain_id.pp chain_id Tezos_base.Time.System.pp_hum
      (Tezos_base.Time.System.of_protocol_exn expiration)
  end.
src/lib_base/test_chain_status.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t =
  | Not_running
  | Forking of {protocol : Protocol_hash.t; expiration : Time.Protocol.t}
  | Running of {
      chain_id : Chain_id.t;
      genesis : Block_hash.t;
      protocol : Protocol_hash.t;
      expiration : Time.Protocol.t;
    }

val encoding : t Data_encoding.t

val pp : Format.formatter -> t -> unit
src/lib_base/test_chain_status.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Not_running : t
| Forking : Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t
| Running : Tezos_crypto.Chain_id.t -> Tezos_crypto.Block_hash.t ->
  Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t.

Parameter encoding : Tezos_data_encoding.Data_encoding.t t.

Parameter pp : Stdlib.Format.formatter -> t -> unit.
src/lib_base/time.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Protocol = struct
  type t = int64

  let epoch = 0L

  let diff = Int64.sub

  let add = Int64.add

  let of_ptime t =
    let (days, ps) = Ptime.Span.to_d_ps (Ptime.to_span t) in
    let s_days = Int64.mul (Int64.of_int days) 86_400L in
    Int64.add s_days (Int64.div ps 1_000_000_000_000L)

  let to_ptime t =
    let days = Int64.to_int (Int64.div t 86_400L) in
    let ps = Int64.mul (Int64.rem t 86_400L) 1_000_000_000_000L in
    match Option.apply ~f:Ptime.of_span (Ptime.Span.of_d_ps (days, ps)) with
    | None ->
        invalid_arg "Time.Protocol.to_ptime"
    | Some ptime ->
        ptime

  let of_notation s =
    match Ptime.of_rfc3339 s with
    | Ok (t, _, _) ->
        Some (of_ptime t)
    | Error _ ->
        None

  let of_notation_exn s =
    match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
    | Error (`Msg msg) ->
        invalid_arg ("Time.Protocol.of_notation: " ^ msg)
    | Ok (t, _, _) ->
        of_ptime t

  let to_notation t = Ptime.to_rfc3339 ~frac_s:0 ~tz_offset_s:0 (to_ptime t)

  let of_seconds x = x

  let to_seconds x = x

  let rfc_encoding =
    let open Data_encoding in
    def
      "timestamp.rfc"
      ~title:"RFC 3339 formatted timestamp"
      ~description:"A date in RFC 3339 notation."
    @@ conv
         to_notation
         (fun s ->
           match of_notation s with
           | Some s ->
               s
           | None ->
               Data_encoding.Json.cannot_destruct "Time.Protocol.of_notation")
         string

  let encoding =
    let open Data_encoding in
    def
      "timestamp.protocol"
      ~description:
        "A timestamp as seen by the protocol: second-level precision, epoch \
         based."
    @@ splitted
         ~binary:int64
         ~json:
           (union
              [ case
                  Json_only
                  ~title:"RFC encoding"
                  rfc_encoding
                  (fun i -> Some i)
                  (fun i -> i);
                case
                  Json_only
                  ~title:"Second since epoch"
                  int64
                  (fun _ -> None)
                  (fun i -> i) ])

  let rpc_arg =
    RPC_arg.make
      ~name:(Format.asprintf "date")
      ~descr:(Format.asprintf "A date in seconds from epoch")
      ~destruct:(fun s ->
        if s = "none" || s = "epoch" then Ok epoch
        else
          match Int64.of_string s with
          | t ->
              Ok t
          | exception _ ->
              Error (Format.asprintf "failed to parse time (epoch): %S" s))
      ~construct:Int64.to_string
      ()

  let pp_hum ppf t = Ptime.pp_rfc3339 () ppf (to_ptime t)

  include Compare.Make (Int64)
end

module System = struct
  type t = Ptime.t

  let epoch = Ptime.epoch

  module Span = struct
    type t = Ptime.Span.t

    let multiply_exn f s =
      let open Ptime.Span in
      Option.unopt_exn
        (Failure "Time.System.Span.multiply_exn")
        (of_float_s (f *. Ptime.Span.to_float_s s))

    let of_seconds_exn f =
      match Ptime.Span.of_float_s f with
      | None ->
          invalid_arg "Time.System.Span.of_seconds_exn"
      | Some s ->
          s

    let encoding =
      let open Data_encoding in
      def
        "timespan.system"
        ~description:"A span of time, as seen by the local computer."
      @@ conv
           Ptime.Span.to_float_s
           (fun f ->
             match Ptime.Span.of_float_s f with
             | None ->
                 invalid_arg "Time.System.Span.encoding"
             | Some s ->
                 s)
           float

    let rpc_arg =
      RPC_arg.make
        ~name:(Format.asprintf "timespan")
        ~descr:(Format.asprintf "A span of time in seconds")
        ~destruct:(fun s ->
          match Ptime.Span.of_float_s (float_of_string s) with
          | Some t ->
              Ok t
          | None ->
              Error (Format.asprintf "failed to parse timespan: %S" s)
          | exception _ ->
              Error (Format.asprintf "failed to parse timespan: %S" s))
        ~construct:(fun s -> string_of_float (Ptime.Span.to_float_s s))
        ()
  end

  let of_seconds_opt x =
    let days = Int64.to_int (Int64.div x 86_400L) in
    let ps = Int64.mul (Int64.rem x 86_400L) 1_000_000_000_000L in
    Option.apply ~f:Ptime.of_span (Ptime.Span.of_d_ps (days, ps))

  let of_seconds_exn x =
    match of_seconds_opt x with
    | Some t ->
        t
    | None ->
        invalid_arg "Time.of_seconds"

  let to_seconds x =
    let (days, ps) = Ptime.(Span.to_d_ps (to_span x)) in
    let s_days = Int64.mul (Int64.of_int days) 86_400L in
    Int64.add s_days (Int64.div ps 1_000_000_000_000L)

  let of_protocol_exn = of_seconds_exn

  let of_protocol_opt = of_seconds_opt

  let to_protocol = to_seconds

  let of_notation_opt s =
    match Ptime.of_rfc3339 s with Ok (t, _, _) -> Some t | Error _ -> None

  let of_notation_exn s =
    match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
    | Ok (t, _, _) ->
        t
    | Error (`Msg msg) ->
        invalid_arg ("Time.of_notation: " ^ msg)

  let to_notation t = Ptime.to_rfc3339 t

  let rfc_encoding =
    let open Data_encoding in
    def
      "timestamp.rfc"
      ~title:"RFC 3339 formatted timestamp"
      ~description:"A date in RFC 3339 notation."
    @@ conv
         to_notation
         (fun s ->
           match of_notation_opt s with
           | Some s ->
               s
           | None ->
               Data_encoding.Json.cannot_destruct "Time.of_notation")
         string

  let encoding =
    let open Data_encoding in
    let binary = conv to_seconds of_seconds_exn int64 in
    let json =
      union
        [ case
            Json_only
            ~title:"RFC encoding"
            rfc_encoding
            (fun i -> Some i)
            (fun i -> i);
          case
            Json_only
            ~title:"Second since epoch"
            int64
            (fun _ -> None)
            (fun i -> of_seconds_exn i) ]
    in
    def
      "timestamp.system"
      ~description:
        "A timestamp as seen by the underlying, local computer: \
         subsecond-level precision, epoch or rfc3339 based."
    @@ splitted ~binary ~json

  let rpc_arg =
    RPC_arg.make
      ~name:(Format.asprintf "date")
      ~descr:(Format.asprintf "A date in seconds from epoch")
      ~destruct:(fun s ->
        if s = "none" || s = "epoch" then Ok Ptime.epoch
        else
          match of_notation_opt s with
          | Some t ->
              Ok t
          | None -> (
            match of_seconds_exn (Int64.of_string s) with
            | t ->
                Ok t
            | exception _ ->
                Error (Format.asprintf "failed to parse time (epoch): %S" s) ))
      ~construct:to_notation
      ()

  let pp_hum ppf t = Ptime.pp_rfc3339 () ppf t

  type 'a stamped = {data : 'a; stamp : Ptime.t}

  let stamped_encoding arg_encoding =
    let open Data_encoding in
    conv
      (fun {stamp; data} -> (stamp, data))
      (fun (stamp, data) -> {stamp; data})
      (tup2 encoding arg_encoding)

  let pp_stamped pp fmt {data; stamp} =
    Format.fprintf fmt "%a(%a)" pp data pp_hum stamp

  let stamp ~time data = {data; stamp = time}

  let recent a1 a2 =
    match (a1, a2) with
    | (None, None) ->
        None
    | (None, (Some _ as a)) | ((Some _ as a), None) ->
        a
    | (Some (_, t1), Some (_, t2)) ->
        if Ptime.compare t1 t2 < 0 then a2 else a1

  let hash t = Int64.to_int (to_seconds t)

  include Compare.Make (Ptime)
  module Set = Set.Make (Ptime)
  module Map = Map.Make (Ptime)

  module Table = Hashtbl.Make (struct
    include Ptime

    let hash = hash
  end)
end

let () =
  Data_encoding.Registration.register ~pp:Protocol.pp_hum Protocol.encoding ;
  Data_encoding.Registration.register ~pp:System.pp_hum System.encoding ;
  Data_encoding.Registration.register System.Span.encoding
src/lib_base/time.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Protocol.
  Definition t := int64.
  
  Definition epoch : int64 := 0.
  
  Definition diff : int64 -> int64 -> int64 := Stdlib.Int64.sub.
  
  Definition add : int64 -> int64 -> int64 := Stdlib.Int64.add.
  
  Definition of_ptime (t : Ptime.t) : int64 :=
    match Ptime.Span.to_d_ps (Ptime.to_span t) with
    | (days, ps) =>
      let s_days := Stdlib.Int64.mul (Stdlib.Int64.of_int days) 86400 in
      Stdlib.Int64.add s_days (Stdlib.Int64.div ps 1000000000000)
    end.
  
  Definition to_ptime (t : int64) : Ptime.t :=
    let days := Stdlib.Int64.to_int (Stdlib.Int64.div t 86400) in
    let ps := Stdlib.Int64.mul (Stdlib.Int64.rem t 86400) 1000000000000 in
    match
      Tezos_stdlib.Option.apply Ptime.of_span (Ptime.Span.of_d_ps (days, ps))
      with
    | None => OCaml.Stdlib.invalid_arg "Time.Protocol.to_ptime" % string
    | Some ptime => ptime
    end.
  
  Definition of_notation (s : string) : option int64 :=
    match Ptime.of_rfc3339 None None None s with
    | inl (t, _, _) => Some (of_ptime t)
    | inr _ => None
    end.
  
  Definition of_notation_exn (s : string) : int64 :=
    match Ptime.rfc3339_error_to_msg (Ptime.of_rfc3339 None None None s) with
    | inr (Msg msg) =>
      OCaml.Stdlib.invalid_arg
        (String.append "Time.Protocol.of_notation: " % string msg)
    | inl (t, _, _) => of_ptime t
    end.
  
  Definition to_notation (t : int64) : string :=
    Ptime.to_rfc3339 None (Some 0) (Some 0) (to_ptime t).
  
  Definition of_seconds {A : Type} (x : A) : A := x.
  
  Definition to_seconds {A : Type} (x : A) : A := x.
  
  Definition rfc_encoding : Tezos_data_encoding.Data_encoding.encoding int64 :=
    apply
      (Tezos_data_encoding.Data_encoding.def "timestamp.rfc" % string
        (Some "RFC 3339 formatted timestamp" % string)
        (Some "A date in RFC 3339 notation." % string))
      (Tezos_data_encoding.Data_encoding.conv to_notation
        (fun s =>
          match of_notation s with
          | Some s => s
          | None =>
            Tezos_data_encoding.Data_encoding.Json.cannot_destruct
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Time.Protocol.of_notation" % string
                  CamlinternalFormatBasics.End_of_format)
                "Time.Protocol.of_notation" % string)
          end) None Tezos_data_encoding.Data_encoding.string).
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding int64 :=
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "timestamp.protocol" % string
          expected_argument
          (Some
            "A timestamp as seen by the protocol: second-level precision, epoch based."
              % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.splitted
        (Tezos_data_encoding.Data_encoding.union None
          (cons
            (Tezos_data_encoding.Data_encoding.case "RFC encoding" % string None
              Json_only rfc_encoding (fun i => Some i) (fun i => i))
            (cons
              (Tezos_data_encoding.Data_encoding.case
                "Second since epoch" % string None Json_only
                Tezos_data_encoding.Data_encoding.int64
                (fun function_parameter =>
                  match function_parameter with
                  | _ => None
                  end) (fun i => i)) [])))
        Tezos_data_encoding.Data_encoding.int64).
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg int64 :=
    Tezos_rpc.RPC_arg.make
      (Some
        (Stdlib.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "A date in seconds from epoch" % string
              CamlinternalFormatBasics.End_of_format)
            "A date in seconds from epoch" % string)))
      (Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "date" % string
            CamlinternalFormatBasics.End_of_format) "date" % string))
      (fun s =>
        if orb (equiv_decb s "none" % string) (equiv_decb s "epoch" % string)
          then
          inl epoch
        else
          match Stdlib.Int64.of_string s with
          | t => inl t
          end) Stdlib.Int64.to_string tt.
  
  Definition pp_hum (ppf : Stdlib.Format.formatter) (t : int64) : unit :=
    Ptime.pp_rfc3339 None None None tt ppf (to_ptime t).
End Protocol.

Module System.
  Definition t := Ptime.t.
  
  Definition epoch : Ptime.t := Ptime.epoch.
  
  Module Span.
    Definition t := Ptime.Span.t.
    
    Definition multiply_exn (f : float) (s : Ptime.span) : Ptime.span :=
      Tezos_stdlib.Option.unopt_exn
        (OCaml.Failure "Time.System.Span.multiply_exn" % string)
        (Ptime.Span.of_float_s
          (Stdlib.op_star_point f (Ptime.Span.to_float_s s))).
    
    Definition of_seconds_exn (f : float) : Ptime.span :=
      match Ptime.Span.of_float_s f with
      | None =>
        OCaml.Stdlib.invalid_arg "Time.System.Span.of_seconds_exn" % string
      | Some s => s
      end.
    
    Definition encoding
      : Tezos_data_encoding.Data_encoding.encoding Ptime.span :=
      apply
        (let arg :=
          Tezos_data_encoding.Data_encoding.def "timespan.system" % string
            expected_argument
            (Some "A span of time, as seen by the local computer." % string) in
        fun eta => arg None eta)
        (Tezos_data_encoding.Data_encoding.conv Ptime.Span.to_float_s
          (fun f =>
            match Ptime.Span.of_float_s f with
            | None =>
              OCaml.Stdlib.invalid_arg "Time.System.Span.encoding" % string
            | Some s => s
            end) None Tezos_data_encoding.Data_encoding.float).
    
    Definition rpc_arg : Tezos_rpc.RPC_arg.arg Ptime.span :=
      Tezos_rpc.RPC_arg.make
        (Some
          (Stdlib.Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "A span of time in seconds" % string
                CamlinternalFormatBasics.End_of_format)
              "A span of time in seconds" % string)))
        (Stdlib.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "timespan" % string
              CamlinternalFormatBasics.End_of_format) "timespan" % string))
        (fun s =>
          match Ptime.Span.of_float_s (Stdlib.float_of_string s) with
          | Some t => inl t
          | None =>
            inr
              (Stdlib.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "failed to parse timespan: " % string
                    (CamlinternalFormatBasics.Caml_string
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "failed to parse timespan: %S" % string) s)
          end) (fun s => Stdlib.string_of_float (Ptime.Span.to_float_s s)) tt.
  End Span.
  
  Definition of_seconds_opt (x : int64) : option Ptime.t :=
    let days := Stdlib.Int64.to_int (Stdlib.Int64.div x 86400) in
    let ps := Stdlib.Int64.mul (Stdlib.Int64.rem x 86400) 1000000000000 in
    Tezos_stdlib.Option.apply Ptime.of_span (Ptime.Span.of_d_ps (days, ps)).
  
  Definition of_seconds_exn (x : int64) : Ptime.t :=
    match of_seconds_opt x with
    | Some t => t
    | None => OCaml.Stdlib.invalid_arg "Time.of_seconds" % string
    end.
  
  Definition to_seconds (x : Ptime.t) : int64 :=
    match Ptime.Span.to_d_ps (Ptime.to_span x) with
    | (days, ps) =>
      let s_days := Stdlib.Int64.mul (Stdlib.Int64.of_int days) 86400 in
      Stdlib.Int64.add s_days (Stdlib.Int64.div ps 1000000000000)
    end.
  
  Definition of_protocol_exn : int64 -> Ptime.t := of_seconds_exn.
  
  Definition of_protocol_opt : int64 -> option Ptime.t := of_seconds_opt.
  
  Definition to_protocol : Ptime.t -> int64 := to_seconds.
  
  Definition of_notation_opt (s : string) : option Ptime.t :=
    match Ptime.of_rfc3339 None None None s with
    | inl (t, _, _) => Some t
    | inr _ => None
    end.
  
  Definition of_notation_exn (s : string) : Ptime.t :=
    match Ptime.rfc3339_error_to_msg (Ptime.of_rfc3339 None None None s) with
    | inl (t, _, _) => t
    | inr (Msg msg) =>
      OCaml.Stdlib.invalid_arg (String.append "Time.of_notation: " % string msg)
    end.
  
  Definition to_notation (t : Ptime.t) : string :=
    Ptime.to_rfc3339 None None None t.
  
  Definition rfc_encoding
    : Tezos_data_encoding.Data_encoding.encoding Ptime.t :=
    apply
      (Tezos_data_encoding.Data_encoding.def "timestamp.rfc" % string
        (Some "RFC 3339 formatted timestamp" % string)
        (Some "A date in RFC 3339 notation." % string))
      (Tezos_data_encoding.Data_encoding.conv to_notation
        (fun s =>
          match of_notation_opt s with
          | Some s => s
          | None =>
            Tezos_data_encoding.Data_encoding.Json.cannot_destruct
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Time.of_notation" % string
                  CamlinternalFormatBasics.End_of_format)
                "Time.of_notation" % string)
          end) None Tezos_data_encoding.Data_encoding.string).
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding Ptime.t :=
    let binary :=
      Tezos_data_encoding.Data_encoding.conv to_seconds of_seconds_exn None
        Tezos_data_encoding.Data_encoding.int64 in
    let json :=
      Tezos_data_encoding.Data_encoding.union None
        (cons
          (Tezos_data_encoding.Data_encoding.case "RFC encoding" % string None
            Json_only rfc_encoding (fun i => Some i) (fun i => i))
          (cons
            (Tezos_data_encoding.Data_encoding.case
              "Second since epoch" % string None Json_only
              Tezos_data_encoding.Data_encoding.int64
              (fun function_parameter =>
                match function_parameter with
                | _ => None
                end) (fun i => of_seconds_exn i)) [])) in
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "timestamp.system" % string
          expected_argument
          (Some
            "A timestamp as seen by the underlying, local computer: subsecond-level precision, epoch or rfc3339 based."
              % string) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.splitted json binary).
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg Ptime.t :=
    Tezos_rpc.RPC_arg.make
      (Some
        (Stdlib.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "A date in seconds from epoch" % string
              CamlinternalFormatBasics.End_of_format)
            "A date in seconds from epoch" % string)))
      (Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "date" % string
            CamlinternalFormatBasics.End_of_format) "date" % string))
      (fun s =>
        if orb (equiv_decb s "none" % string) (equiv_decb s "epoch" % string)
          then
          inl Ptime.epoch
        else
          match of_notation_opt s with
          | Some t => inl t
          | None =>
            match of_seconds_exn (Stdlib.Int64.of_string s) with
            | t => inl t
            end
          end) to_notation tt.
  
  Definition pp_hum (ppf : Stdlib.Format.formatter) (t : Ptime.t) : unit :=
    Ptime.pp_rfc3339 None None None tt ppf t.
  
  Record stamped {a : Type} := {
    data : a;
    stamp : Ptime.t }.
  Arguments stamped : clear implicits.
  
  Definition stamped_encoding {A : Type}
    (arg_encoding : Tezos_data_encoding.Data_encoding.encoding A)
    : Tezos_data_encoding.Data_encoding.encoding (stamped A) :=
    Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| data := data; stamp := stamp |} => (stamp, data)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (stamp, data) => {| data := data; stamp := stamp |}
        end) None (Tezos_data_encoding.Data_encoding.tup2 encoding arg_encoding).
  
  Definition pp_stamped {A : Type}
    (pp : Stdlib.Format.formatter -> A -> unit) (fmt : Stdlib.Format.formatter)
    (function_parameter : stamped A) : unit :=
    match function_parameter with
    | {| data := data; stamp := stamp |} =>
      Stdlib.Format.fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "(" % char
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))) "%a(%a)" % string)
        pp data pp_hum stamp
    end.
  
  Definition stamp {A : Type} (time : Ptime.t) (data : A) : stamped A :=
    {| data := data; stamp := time |}.
  
  Definition recent {A : Type}
    (a1 : option (A * Ptime.t)) (a2 : option (A * Ptime.t))
    : option (A * Ptime.t) :=
    match (a1, a2) with
    | (None, None) => None
    | (None, (Some _) as a) | ((Some _) as a, None) => a
    | (Some (_, t1), Some (_, t2)) =>
      if OCaml.Stdlib.lt (Ptime.compare t1 t2) 0 then
        a2
      else
        a1
    end.
  
  Definition hash (t : Ptime.t) : Z := Stdlib.Int64.to_int (to_seconds t).
End System.
src/lib_base/time.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Time management

    This module supports two distinct notions of time. The first notion of time
    is the time as handled by the protocol. This is the time that appears in the
    header of blocks, the time that baking slots are specified on, etc. It only
    has second-level precision.

    The second notion of time is the time as handled by the system. This is the
    time as returned by the processor clock, the time that network timeouts are
    specified on, etc. In has sub-second precision.

    The distinction between the two notions of time is important for multiple
    reasons:
    - Protocol time and system time may evolve independently. E.g., if a
    protocol update changes the notion of time.
    - Protocol time and system time have different levels of precision.
    - Protocol time and system time have different end-of-times. Respectively
    that's int64 end-of-time (some time in the year 292277026596) and rfc3339
    end-of-time (end of the year 9999).

*)

module Protocol : sig
  (** {1:Protocol time} *)

  (** The out-of-protocol view of in-protocol timestamps. The precision of
      in-protocol timestamps are only precise to the second.

      Note that the out-of-protocol view does not necessarily match the
      in-protocol representation.  *)

  (** The type of protocol times *)
  type t

  (** Unix epoch is 1970-01-01 00:00:00 +0000 (UTC) *)
  val epoch : t

  include Compare.S with type t := t

  (** [add t s] is [s] seconds later than [t] *)
  val add : t -> int64 -> t

  (** [diff a b] is the number of seconds between [a] and [b]. It is negative if
      [b] is later than [a]. *)
  val diff : t -> t -> int64

  (** Conversions to and from string representations. *)

  val of_notation : string -> t option

  val of_notation_exn : string -> t

  val to_notation : t -> string

  (** Conversion to and from "number of seconds since epoch" representation. *)

  val of_seconds : int64 -> t

  val to_seconds : t -> int64

  (** Serialization functions *)

  val encoding : t Data_encoding.t

  val rfc_encoding : t Data_encoding.t

  val rpc_arg : t RPC_arg.t

  (** Pretty-printing functions *)

  val pp_hum : Format.formatter -> t -> unit
end

module System : sig
  (** {1:System time} *)

  (** A representation of timestamps.

      NOTE: This representation is limited to times between
      0000-01-01 00:00:00 UTC and 9999-12-31 23:59:59.999999999999 UTC

      NOTE: This is based on the system clock. As a result, it is affected by
      system clock adjustments. IF you need monotonous time, you can use
      [Mtime]. *)

  type t = Ptime.t

  val epoch : t

  module Span : sig
    (** A representation of spans of time between two timestamps. *)
    type t = Ptime.Span.t

    (** [multiply_exn factor t] is a time spans that lasts [factor] time as long
        as [t]. It fails if the time span cannot be represented. *)
    val multiply_exn : float -> t -> t

    (** [of_seconds_exn f] is a time span of [f] seconds. It fails if the time
        span cannot be represented. *)
    val of_seconds_exn : float -> t

    (** Serialization functions *)

    val rpc_arg : t RPC_arg.t

    val encoding : t Data_encoding.t
  end

  (** Conversions to and from Protocol time. Note that converting system time to
      protocol time truncates any subsecond precision.  *)

  val of_protocol_opt : Protocol.t -> t option

  val of_protocol_exn : Protocol.t -> t

  val to_protocol : t -> Protocol.t

  (** Conversions to and from string. It uses rfc3339. *)

  val of_notation_opt : string -> t option

  val of_notation_exn : string -> t

  val to_notation : t -> string

  (** Serialization. *)

  val encoding : t Data_encoding.t

  val rfc_encoding : t Data_encoding.t

  val rpc_arg : t RPC_arg.t

  (** Pretty-printing *)

  val pp_hum : Format.formatter -> t -> unit

  (** Timestamping data. *)

  (** Data with an associated time stamp. *)
  type 'a stamped = {data : 'a; stamp : t}

  val stamped_encoding : 'a Data_encoding.t -> 'a stamped Data_encoding.t

  (** [stamp d] is a timestamped version of [d]. *)
  val stamp : time:t -> 'a -> 'a stamped

  val pp_stamped :
    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a stamped -> unit

  (** [recent a b] is either [a] or [b] (which ever carries the most recent
      timestamp), or [None] if both [a] and [b] are [None]. *)
  val recent : ('a * t) option -> ('a * t) option -> ('a * t) option

  (** Helper modules *)

  val hash : t -> int

  include Compare.S with type t := t

  module Set : Set.S with type elt = t

  module Map : Map.S with type key = t

  module Table : Hashtbl.S with type key = t
end
src/lib_base/time.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Protocol.
  Parameter t : Type.
  
  Parameter epoch : t.
  
  include
  
  Parameter add : t -> int64 -> t.
  
  Parameter diff : t -> t -> int64.
  
  Parameter of_notation : string -> option t.
  
  Parameter of_notation_exn : string -> t.
  
  Parameter to_notation : t -> string.
  
  Parameter of_seconds : int64 -> t.
  
  Parameter to_seconds : t -> int64.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter rfc_encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter rpc_arg : Tezos_rpc.RPC_arg.t t.
  
  Parameter pp_hum : Stdlib.Format.formatter -> t -> unit.
End Protocol.

Module System.
  Definition t := Ptime.t.
  
  Parameter epoch : t.
  
  Module Span.
    Definition t := Ptime.Span.t.
    
    Parameter multiply_exn : float -> t -> t.
    
    Parameter of_seconds_exn : float -> t.
    
    Parameter rpc_arg : Tezos_rpc.RPC_arg.t t.
    
    Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  End Span.
  
  Parameter of_protocol_opt : Protocol.t -> option t.
  
  Parameter of_protocol_exn : Protocol.t -> t.
  
  Parameter to_protocol : t -> Protocol.t.
  
  Parameter of_notation_opt : string -> option t.
  
  Parameter of_notation_exn : string -> t.
  
  Parameter to_notation : t -> string.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter rfc_encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter rpc_arg : Tezos_rpc.RPC_arg.t t.
  
  Parameter pp_hum : Stdlib.Format.formatter -> t -> unit.
  
  Record stamped {a : Type} := {
    data : a;
    stamp : t }.
  Arguments stamped : clear implicits.
  
  Parameter stamped_encoding : forall {a : Type}, (Tezos_data_encoding.Data_encoding.t
    a) -> Tezos_data_encoding.Data_encoding.t (stamped a).
  
  Parameter stamp : forall {a : Type}, t -> a -> stamped a.
  
  Parameter pp_stamped : forall {a : Type}, (Stdlib.Format.formatter ->
    a -> unit) -> Stdlib.Format.formatter -> (stamped a) -> unit.
  
  Parameter recent : forall {a : Type}, (option (a * t)) ->
    (option (a * t)) -> option (a * t).
  
  Parameter hash : t -> Z.
  
  include
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
End System.
src/lib_base/tzPervasives.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Tezos_stdlib
include Tezos_error_monad
include Tezos_rpc
include Tezos_clic
include Tezos_crypto
include Tezos_micheline
module Data_encoding = Tezos_data_encoding.Data_encoding

module List = struct
  include List
  include Tezos_stdlib.TzList
end

module String = struct
  include String
  include Tezos_stdlib.TzString
end

module Time = Time
module Fitness = Fitness
module Block_header = Block_header
module Operation = Operation
module Protocol = Protocol
module Test_chain_status = Test_chain_status
module Preapply_result = Preapply_result
module Block_locator = Block_locator
module Mempool = Mempool
module P2p_addr = P2p_addr
module P2p_identity = P2p_identity
module P2p_peer = P2p_peer
module P2p_point = P2p_point
module P2p_connection = P2p_connection
module P2p_stat = P2p_stat
module P2p_version = P2p_version
module Distributed_db_version = Distributed_db_version
module Network_version = Network_version
include Utils.Infix
include Error_monad
module Internal_event = Internal_event
src/lib_base/tzPervasives.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module List.

End List.

Module String.

End String.
src/lib_base/tzPervasives.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include module type of struct
  include Tezos_stdlib
end

include module type of struct
  include Tezos_error_monad
end

include module type of struct
  include Tezos_rpc
end

include module type of struct
  include Tezos_clic
end

include module type of struct
  include Tezos_crypto
end

module Data_encoding = Data_encoding

module List : sig
  include module type of struct
    include List
  end

  include module type of struct
    include Tezos_stdlib.TzList
  end
end

module String : sig
  include module type of struct
    include String
  end

  include module type of struct
    include Tezos_stdlib.TzString
  end
end

module Time = Time
module Fitness = Fitness
module Block_header = Block_header
module Operation = Operation
module Protocol = Protocol
module Test_chain_status = Test_chain_status
module Preapply_result = Preapply_result
module Block_locator = Block_locator
module Mempool = Mempool
module P2p_addr = P2p_addr
module P2p_identity = P2p_identity
module P2p_peer = P2p_peer
module P2p_point = P2p_point
module P2p_connection = P2p_connection
module P2p_stat = P2p_stat
module P2p_version = P2p_version
module Distributed_db_version = Distributed_db_version
module Network_version = Network_version

include module type of struct
  include Utils.Infix
end

include module type of struct
  include Error_monad
end

module Internal_event = Internal_event
src/lib_base/tzPervasives.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

include

include

include

include

unhandled_module

Module List.
  include
  
  include
End List.

Module String.
  include
  
  include
End String.

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

include

include

unhandled_module
src/lib_base/unix/protocol_files.ml 
open Error_monad

let name = "TEZOS_PROTOCOL"

open Protocol

let ( // ) = Filename.concat

let to_file ~dir:dirname ?hash ?env_version modules =
  let config_file =
    Data_encoding.Json.construct
      Meta.encoding
      {hash; expected_env_version = env_version; modules}
  in
  Lwt_utils_unix.Json.write_file (dirname // name) config_file

let of_file ~dir:dirname =
  Lwt_utils_unix.Json.read_file (dirname // name)
  >>=? fun json -> return (Data_encoding.Json.destruct Meta.encoding json)

let find_component dirname module_name =
  let name_lowercase = String.uncapitalize_ascii module_name in
  let implementation = (dirname // name_lowercase) ^ ".ml" in
  let interface = implementation ^ "i" in
  match (Sys.file_exists implementation, Sys.file_exists interface) with
  | (false, _) ->
      Pervasives.failwith @@ "Not such file: " ^ implementation
  | (true, false) ->
      Lwt_utils_unix.read_file implementation
      >|= fun implementation ->
      {name = module_name; interface = None; implementation}
  | _ ->
      Lwt_utils_unix.read_file interface
      >>= fun interface ->
      Lwt_utils_unix.read_file implementation
      >|= fun implementation ->
      {name = module_name; interface = Some interface; implementation}

let read_dir dir =
  of_file ~dir
  >>=? fun meta ->
  Lwt_list.map_p (find_component dir) meta.modules
  >>= fun components ->
  let expected_env =
    match meta.expected_env_version with None -> V1 | Some v -> v
  in
  return (meta.hash, {expected_env; components})

open Lwt.Infix

let create_files dir units =
  Lwt_utils_unix.remove_dir dir
  >>= fun () ->
  Lwt_utils_unix.create_dir dir
  >>= fun () ->
  Lwt_list.map_s
    (fun {name; interface; implementation} ->
      let name = String.lowercase_ascii name in
      let ml = dir // (name ^ ".ml") in
      let mli = dir // (name ^ ".mli") in
      Lwt_utils_unix.create_file ml implementation
      >>= fun () ->
      match interface with
      | None ->
          Lwt.return [ml]
      | Some content ->
          Lwt_utils_unix.create_file mli content
          >>= fun () -> Lwt.return [mli; ml])
    units
  >>= fun files ->
  let files = List.concat files in
  Lwt.return files

let write_dir dir ?hash (p : t) =
  create_files dir p.components
  >>= fun _files ->
  to_file
    ~dir
    ?hash
    ~env_version:p.expected_env
    (List.map (fun {name; _} -> String.capitalize_ascii name) p.components)
src/lib_base/unix/protocol_files.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Definition name : string := "TEZOS_PROTOCOL" % string.

Import Tezos_base.Protocol.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition to_file
  (dirname : string) (hash : option Tezos_crypto.Protocol_hash.t)
  (env_version : option Tezos_base__Protocol.env_version)
  (modules : list string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let config_file :=
    Tezos_data_encoding.Data_encoding.Json.construct
      Tezos_base.Protocol.Meta.encoding
      {| hash := hash; expected_env_version := env_version; modules := modules
        |} in
  Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file (op_div_div dirname name)
    config_file.

Definition of_file (dirname : string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult Tezos_base.Protocol.Meta.t) :=
  Tezos_error_monad.Error_monad.op_gt_gt_eq_question
    (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file (op_div_div dirname name))
    (fun json =>
      Tezos_error_monad.Error_monad._return
        (Tezos_data_encoding.Data_encoding.Json.destruct
          Tezos_base.Protocol.Meta.encoding json)).

Definition find_component (dirname : string) (module_name : string)
  : Lwt.t Tezos_base.Protocol.component :=
  let name_lowercase := Stdlib.String.uncapitalize_ascii module_name in
  let implementation :=
    String.append (op_div_div dirname name_lowercase) ".ml" % string in
  let interface := String.append implementation "i" % string in
  match
    ((Stdlib.Sys.file_exists implementation), (Stdlib.Sys.file_exists interface))
    with
  | (false, _) =>
    apply Stdlib.Pervasives.failwith
      (String.append "Not such file: " % string implementation)
  | (true, false) =>
    Tezos_error_monad.Error_monad.op_gt_pipe_eq
      (Tezos_stdlib_unix.Lwt_utils_unix.read_file implementation)
      (fun implementation =>
        {| name := module_name; interface := None;
          implementation := implementation |})
  | _ =>
    Tezos_error_monad.Error_monad.op_gt_gt_eq
      (Tezos_stdlib_unix.Lwt_utils_unix.read_file interface)
      (fun interface =>
        Tezos_error_monad.Error_monad.op_gt_pipe_eq
          (Tezos_stdlib_unix.Lwt_utils_unix.read_file implementation)
          (fun implementation =>
            {| name := module_name; interface := Some interface;
              implementation := implementation |}))
  end.

Definition read_dir (dir : string)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((option Tezos_crypto.Protocol_hash.t) * Tezos_base.Protocol.t)) :=
  Tezos_error_monad.Error_monad.op_gt_gt_eq_question (of_file dir)
    (fun meta =>
      Tezos_error_monad.Error_monad.op_gt_gt_eq
        (Lwt_list.map_p (find_component dir) (modules meta))
        (fun components =>
          let expected_env :=
            match expected_env_version meta with
            | None => V1
            | Some v => v
            end in
          Tezos_error_monad.Error_monad._return
            ((hash meta),
              {| expected_env := expected_env; components := components |}))).

Import Lwt.Infix.

Definition create_files
  (dir : string) (units : list Tezos_base.Protocol.component)
  : Lwt.t (list string) :=
  Lwt.Infix.op_gt_gt_eq (Tezos_stdlib_unix.Lwt_utils_unix.remove_dir dir)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Lwt.Infix.op_gt_gt_eq
          (Tezos_stdlib_unix.Lwt_utils_unix.create_dir None dir)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Lwt.Infix.op_gt_gt_eq
                (Lwt_list.map_s
                  (fun function_parameter =>
                    match function_parameter with
                    | {|
                      name := name;
                        interface := interface;
                        implementation := implementation
                        |} =>
                      let name := Stdlib.String.lowercase_ascii name in
                      let ml :=
                        op_div_div dir (String.append name ".ml" % string) in
                      let mli :=
                        op_div_div dir (String.append name ".mli" % string) in
                      Lwt.Infix.op_gt_gt_eq
                        (Tezos_stdlib_unix.Lwt_utils_unix.create_file None ml
                          implementation)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            match interface with
                            | None => Lwt._return (cons ml [])
                            | Some content =>
                              Lwt.Infix.op_gt_gt_eq
                                (Tezos_stdlib_unix.Lwt_utils_unix.create_file
                                  None mli content)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Lwt._return (cons mli (cons ml []))
                                  end)
                            end
                          end)
                    end) units)
                (fun files =>
                  let files := Stdlib.List.concat files in
                  Lwt._return files)
            end)
      end).

Definition write_dir
  (dir : string) (hash : option Tezos_crypto.Protocol_hash.t)
  (p : Tezos_base.Protocol.t)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  Lwt.Infix.op_gt_gt_eq (create_files dir (components p))
    (fun _files =>
      to_file dir hash (Some (expected_env p))
        (List.map
          (fun function_parameter =>
            match function_parameter with
            | {| name := name |} => Stdlib.String.capitalize_ascii name
            end) (components p))).
src/lib_base/unix/protocol_files.mli 
open Error_monad

val read_dir : string -> (Protocol_hash.t option * Protocol.t) tzresult Lwt.t

val write_dir :
  string -> ?hash:Protocol_hash.t -> Protocol.t -> unit tzresult Lwt.t
src/lib_base/unix/protocol_files.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter read_dir :
string ->
  Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((option Tezos_crypto.Protocol_hash.t) * Tezos_base.Protocol.t)).

Parameter write_dir :
string ->
  (option Tezos_crypto.Protocol_hash.t) ->
    Tezos_base.Protocol.t -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).
src/lib_clic/clic.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

type ('p, 'ctx) parameter = {
  converter : 'ctx -> string -> 'p tzresult Lwt.t;
  autocomplete : ('ctx -> string list tzresult Lwt.t) option;
}

let parameter ?autocomplete converter = {converter; autocomplete}

let compose_parameters {converter = c1; autocomplete = a1'}
    {converter = c2; autocomplete = a2'} =
  {
    converter =
      (fun ctx s ->
        c1 ctx s >>= function Ok r -> return r | Error _ -> c2 ctx s);
    autocomplete =
      ( match a1' with
      | None ->
          a2'
      | Some a1 -> (
        match a2' with
        | None ->
            a1'
        | Some a2 ->
            Some
              (fun ctx ->
                a1 ctx
                >>=? fun r1 ->
                a2 ctx >>=? fun r2 -> return (List.concat [r1; r2])) ) );
  }

let map_parameter ~f {converter; autocomplete} =
  {converter = (fun ctx s -> converter ctx s >>|? f); autocomplete}

type label = {long : string; short : char option}

type ('a, 'ctx) arg =
  | Arg : {
      doc : string;
      label : label;
      placeholder : string;
      kind : ('p, 'ctx) parameter;
    }
      -> ('p option, 'ctx) arg
  | DefArg : {
      doc : string;
      label : label;
      placeholder : string;
      kind : ('p, 'ctx) parameter;
      default : string;
    }
      -> ('p, 'ctx) arg
  | Switch : {label : label; doc : string} -> (bool, 'ctx) arg
  | Constant : 'a -> ('a, 'ctx) arg

type ('a, 'arg) args =
  | NoArgs : (unit, 'args) args
  | AddArg : ('a, 'args) arg * ('b, 'args) args -> ('a * 'b, 'args) args

(* A simple structure for command interpreters.
   This is more generic than the exported one, see end of file. *)
type ('a, 'ctx) params =
  | Prefix : string * ('a, 'ctx) params -> ('a, 'ctx) params
  | Param :
      string * string * ('p, 'ctx) parameter * ('a, 'ctx) params
      -> ('p -> 'a, 'ctx) params
  | Stop : ('ctx -> unit tzresult Lwt.t, 'ctx) params
  | Seq :
      string * string * ('p, 'ctx) parameter
      -> ('p list -> 'ctx -> unit tzresult Lwt.t, 'ctx) params

type (_, _) options =
  | Argument : {
      spec : ('a, 'arg) args;
      converter : 'a -> 'b;
    }
      -> ('b, 'arg) options

(* A command group *)
type group = {name : string; title : string}

(* A command wraps a callback with its type and info *)
type 'arg command =
  | Command : {
      params : ('a, 'iarg) params;
      options : ('b, 'iarg) options;
      handler : 'b -> 'a;
      desc : string;
      group : group option;
      conv : 'arg -> 'iarg;
    }
      -> 'arg command

type error += Bad_argument of int * string

type error += Unterminated_command : string list * 'ctx command list -> error

type error += Command_not_found : string list * 'ctx command list -> error

type error += Unknown_option : string * 'ctx command option -> error

type error +=
  | Option_expected_argument : string * 'ctx command option -> error

type error += Bad_option_argument : string * 'ctx command option -> error

type error += Multiple_occurences : string * 'ctx command option -> error

type error += Extra_arguments : string list * 'ctx command -> error

let trim s =
  (* config-file wokaround *)
  TzString.split '\n' s |> List.map String.trim |> String.concat "\n"

let print_desc ppf doc =
  let (short, long) =
    try
      let len = String.index doc '\n' in
      ( String.sub doc 0 len,
        Some (String.sub doc (len + 1) (String.length doc - len - 1)) )
    with _ -> (doc, None)
  in
  match long with
  | None ->
      Format.fprintf ppf "%s" short
  | Some doc ->
      Format.fprintf
        ppf
        "%s@{<full>@\n  @[<hov 0>%a@]@}"
        short
        Format.pp_print_text
        doc

let print_label ppf = function
  | {long; short = None} ->
      Format.fprintf ppf "--%s" long
  | {long; short = Some short} ->
      Format.fprintf ppf "-%c --%s" short long

let print_options_detailed (type ctx) =
  let help_option : type a. Format.formatter -> (a, ctx) arg -> unit =
   fun ppf -> function
    | Arg {label; placeholder; doc; _} ->
        Format.fprintf
          ppf
          "@{<opt>%a <%s>@}: %a"
          print_label
          label
          placeholder
          print_desc
          doc
    | DefArg {label; placeholder; doc; default; _} ->
        Format.fprintf
          ppf
          "@{<opt>%a <%s>@}: %a"
          print_label
          label
          placeholder
          print_desc
          (doc ^ "\nDefaults to `" ^ default ^ "`.")
    | Switch {label; doc} ->
        Format.fprintf ppf "@{<opt>%a@}: %a" print_label label print_desc doc
    | Constant _ ->
        ()
  in
  let rec help : type b. Format.formatter -> (b, ctx) args -> unit =
   fun ppf -> function
    | NoArgs ->
        ()
    | AddArg (arg, NoArgs) ->
        Format.fprintf ppf "%a" help_option arg
    | AddArg (arg, rest) ->
        Format.fprintf ppf "%a@,%a" help_option arg help rest
  in
  help

let has_args : type a ctx. (a, ctx) args -> bool = function
  | NoArgs ->
      false
  | AddArg (_, _) ->
      true

let print_options_brief (type ctx) =
  let help_option : type a. Format.formatter -> (a, ctx) arg -> unit =
   fun ppf -> function
    | DefArg {label; placeholder; _} ->
        Format.fprintf ppf "[@{<opt>%a <%s>@}]" print_label label placeholder
    | Arg {label; placeholder; _} ->
        Format.fprintf ppf "[@{<opt>%a <%s>@}]" print_label label placeholder
    | Switch {label; _} ->
        Format.fprintf ppf "[@{<opt>%a@}]" print_label label
    | Constant _ ->
        ()
  in
  let rec help : type b. Format.formatter -> (b, ctx) args -> unit =
   fun ppf -> function
    | NoArgs ->
        ()
    | AddArg (arg, NoArgs) ->
        Format.fprintf ppf "%a" help_option arg
    | AddArg (arg, rest) ->
        Format.fprintf ppf "%a@ %a" help_option arg help rest
  in
  help

let print_highlight highlight_strings formatter str =
  let rec print_string = function
    | [] ->
        Format.fprintf formatter "%s" str
    | regex :: tl -> (
      match Re.Str.full_split regex str with
      | [] | [Re.Str.Text _] ->
          print_string tl
      | list ->
          List.iter
            (function
              | Re.Str.Text text ->
                  Format.fprintf formatter "%s" text
              | Re.Str.Delim delimiter ->
                  Format.fprintf formatter "@{<hilight>%s@}" delimiter)
            list )
  in
  print_string (List.map Re.Str.regexp_string highlight_strings)

let print_commandline ppf (highlights, options, args) =
  let rec print : type a ctx. Format.formatter -> (a, ctx) params -> unit =
   fun ppf -> function
    | Stop ->
        Format.fprintf ppf "%a" print_options_brief options
    | Seq (n, _, _) when not (has_args options) ->
        Format.fprintf ppf "[@{<arg>%s@}...]" n
    | Seq (n, _, _) ->
        Format.fprintf ppf "[@{<arg>%s@}...] %a" n print_options_brief options
    | Prefix (n, Stop) when not (has_args options) ->
        Format.fprintf ppf "@{<kwd>%a@}" (print_highlight highlights) n
    | Prefix (n, next) ->
        Format.fprintf
          ppf
          "@{<kwd>%a@} %a"
          (print_highlight highlights)
          n
          print
          next
    | Param (n, _, _, Stop) when not (has_args options) ->
        Format.fprintf ppf "@{<arg>%s@}" n
    | Param (n, _, _, next) ->
        Format.fprintf ppf "@{<arg>%s@} %a" n print next
  in
  Format.fprintf ppf "@{<commandline>%a@}" print args

let rec print_params_detailed :
    type a b ctx. (b, ctx) args -> Format.formatter -> (a, ctx) params -> unit
    =
 fun spec ppf -> function
  | Stop ->
      print_options_detailed ppf spec
  | Seq (n, desc, _) -> (
      Format.fprintf ppf "@{<arg>%s@}: %a" n print_desc (trim desc) ;
      match spec with
      | NoArgs ->
          ()
      | _ ->
          Format.fprintf ppf "@,%a" print_options_detailed spec )
  | Prefix (_, next) ->
      print_params_detailed spec ppf next
  | Param (n, desc, _, Stop) -> (
      Format.fprintf ppf "@{<arg>%s@}: %a" n print_desc (trim desc) ;
      match spec with
      | NoArgs ->
          ()
      | _ ->
          Format.fprintf ppf "@,%a" print_options_detailed spec )
  | Param (n, desc, _, next) ->
      Format.fprintf
        ppf
        "@{<arg>%s@}: %a@,%a"
        n
        print_desc
        (trim desc)
        (print_params_detailed spec)
        next

let contains_params_args :
    type arg ctx. (arg, ctx) params -> (_, ctx) args -> bool =
 fun params args ->
  let rec help : (arg, ctx) params -> bool = function
    | Stop ->
        has_args args
    | Seq (_, _, _) ->
        true
    | Prefix (_, next) ->
        help next
    | Param (_, _, _, _) ->
        true
  in
  help params

let print_command :
    type ctx.
    ?prefix:(Format.formatter -> unit -> unit) ->
    ?highlights:string list ->
    Format.formatter ->
    ctx command ->
    unit =
 fun ?(prefix = fun _ () -> ())
     ?(highlights = [])
     ppf
     (Command {params; desc; options = Argument {spec; _}; _}) ->
  if contains_params_args params spec then
    Format.fprintf
      ppf
      "@{<command>%a%a@{<short>@,@{<commanddoc>%a@,%a@}@}@}"
      prefix
      ()
      print_commandline
      (highlights, spec, params)
      print_desc
      desc
      (print_params_detailed spec)
      params
  else
    Format.fprintf
      ppf
      "@{<command>%a%a@{<short>@,@{<commanddoc>%a@}@}@}"
      prefix
      ()
      print_commandline
      (highlights, spec, params)
      print_desc
      desc

type ex_command = Ex : _ command -> ex_command

let group_commands commands =
  let (grouped, ungrouped) =
    List.fold_left
      (fun (grouped, ungrouped) (Ex (Command {group; _}) as command) ->
        match group with
        | None ->
            (grouped, command :: ungrouped)
        | Some group -> (
          match
            List.find_opt (fun ({name; _}, _) -> group.name = name) grouped
          with
          | None ->
              ((group, ref [command]) :: grouped, ungrouped)
          | Some ({title; _}, r) ->
              if title <> group.title then
                invalid_arg "Clic.usage: duplicate group name" ;
              r := command :: !r ;
              (grouped, ungrouped) ))
      ([], [])
      commands
  in
  List.map
    (fun (g, c) -> (g, List.rev !c))
    ( match ungrouped with
    | [] ->
        grouped
    | l ->
        grouped @ [({name = "misc"; title = "Miscellaneous commands"}, ref l)]
    )

let print_group print_command ppf ({title; _}, commands) =
  Format.fprintf
    ppf
    "@{<title>%s@}@,@{<list>%a@}"
    title
    (Format.pp_print_list print_command)
    commands

type formatter_state =
  Format.formatter_out_functions * Format.formatter_tag_functions * bool

type format = Plain | Ansi | Html

type verbosity = Terse | Short | Details | Full

let setup_formatter ppf format verbosity =
  let skip = ref false in
  let ((orig_out_functions, _, _) as orig_state) =
    ( Format.pp_get_formatter_out_functions ppf (),
      Format.pp_get_formatter_tag_functions ppf (),
      Format.pp_get_print_tags ppf () )
  in
  ( Format.pp_print_flush ppf () ;
    Format.pp_set_formatter_out_functions
      ppf
      {
        out_string =
          (fun s b a ->
            if s = "\000\000\000" then skip := true
            else if s = "\255\255\255" then skip := false
            else if not !skip then orig_out_functions.out_string s b a);
        out_spaces =
          (fun n -> if not !skip then orig_out_functions.out_spaces n);
        out_newline =
          (fun () -> if not !skip then orig_out_functions.out_newline ());
        out_flush =
          (fun () -> if not !skip then orig_out_functions.out_flush ());
        out_indent = orig_out_functions.out_indent;
      } ;
    let levels = ref [] in
    let setup_level (level, op) =
      if op level verbosity then Format.fprintf ppf "@<0>%s" "\255\255\255"
      else Format.fprintf ppf "@<0>%s" "\000\000\000"
    in
    let push_level level =
      levels := level :: !levels ;
      setup_level level
    in
    let pop_level () =
      match !levels with
      | _ :: level :: rest ->
          levels := level :: rest ;
          setup_level level
      | [_] | [] ->
          Pervasives.failwith "Clic: unclosed verbosity tag"
    in
    push_level (Terse, ( <= )) ;
    let push_level_tag tag =
      let push op = function
        | "full" ->
            push_level (Full, op)
        | "details" ->
            push_level (Details, op)
        | "short" ->
            push_level (Short, op)
        | "terse" ->
            push_level (Terse, op)
        | tag ->
            Pervasives.failwith ("Clic: invalid semantic tag <" ^ tag ^ ">")
      in
      if String.length tag > 0 && tag.[0] = '=' then
        push ( = ) (String.sub tag 1 (String.length tag - 1))
      else if String.length tag > 0 && tag.[0] = '-' then
        push ( > ) (String.sub tag 1 (String.length tag - 1))
      else push ( <= ) tag
    in
    let pop_level_tag = function
      | "full"
      | "details"
      | "short"
      | "terse"
      | "-full"
      | "-details"
      | "-short"
      | "-terse"
      | "=full"
      | "=details"
      | "=short"
      | "=terse" ->
          pop_level ()
      | tag ->
          Pervasives.failwith ("Clic: invalid semantic tag <" ^ tag ^ ">")
    in
    match format with
    | Ansi ->
        let color_num = function
          | `Auto ->
              None
          | `Black ->
              Some 0
          | `Red ->
              Some 1
          | `Green ->
              Some 2
          | `Yellow ->
              Some 3
          | `Blue ->
              Some 4
          | `Magenta ->
              Some 5
          | `Cyan ->
              Some 6
          | `White ->
              Some 7
        in
        let ansi_format ppf (fg, bg, b, u) =
          Format.fprintf ppf "@<0>%s" "\027[0m" ;
          match
            ( match color_num fg with
            | Some n ->
                [string_of_int (30 + n)]
            | None ->
                [] )
            @ ( match color_num bg with
              | Some n ->
                  [string_of_int (40 + n)]
              | None ->
                  [] )
            @ (if b then ["1"] else [])
            @ if u then ["4"] else []
          with
          | [] ->
              ()
          | l ->
              Format.fprintf ppf "@<0>%s" ("\027[" ^ String.concat ";" l ^ "m")
        in
        let ansi_stack = ref [(`Auto, `Auto, false, false)] in
        let push_ansi_format (fg, bg, b, u) =
          let format =
            match !ansi_stack with
            | (pfg, pbg, pb, pu) :: _ ->
                ( Option.unopt ~default:pfg fg,
                  Option.unopt ~default:pbg bg,
                  pb || b,
                  pu || u )
            | [] ->
                assert false
          in
          ansi_stack := format :: !ansi_stack ;
          Format.fprintf ppf "@<0>%a" ansi_format format
        in
        let pop_ansi_format () =
          Format.fprintf ppf "@<0>%s" "\027[0m" ;
          match !ansi_stack with
          | _ :: format :: rest ->
              ansi_stack := format :: rest ;
              Format.fprintf ppf "@<0>%a" ansi_format format
          | [_] | [] ->
              Pervasives.failwith "Clic: unclosed ansi format"
        in
        Format.pp_set_formatter_tag_functions
          ppf
          {
            mark_open_tag = (fun _ -> "");
            mark_close_tag = (fun _ -> "");
            print_open_tag =
              (function
              | "title" ->
                  push_ansi_format (None, None, true, true)
              | "commandline" ->
                  Format.fprintf ppf "@[<hov 4>"
              | "commanddoc" ->
                  Format.fprintf ppf "  @[<v 0>"
              | "opt" ->
                  push_ansi_format (Some `Green, None, false, false)
              | "arg" ->
                  push_ansi_format (Some `Yellow, None, false, false) ;
                  Format.fprintf ppf "<"
              | "kwd" ->
                  push_ansi_format (None, None, false, true)
              | "error" ->
                  push_ansi_format (Some `Red, None, true, true)
              | "warning" ->
                  push_ansi_format (Some `Yellow, None, true, true)
              | "hilight" ->
                  push_ansi_format (Some `White, Some `Yellow, true, true)
              | "list" ->
                  Format.fprintf ppf "  @[<v 0>"
              | "command" ->
                  Format.fprintf ppf "@[<v 0>"
              | "document" ->
                  Format.fprintf ppf "@[<v 0>"
              | other ->
                  push_level_tag other);
            print_close_tag =
              (function
              | "title" ->
                  Format.fprintf ppf ":" ; pop_ansi_format ()
              | "commandline" ->
                  Format.fprintf ppf "@]"
              | "commanddoc" ->
                  Format.fprintf ppf "@]"
              | "opt" ->
                  pop_ansi_format ()
              | "arg" ->
                  Format.fprintf ppf ">" ; pop_ansi_format ()
              | "kwd" ->
                  pop_ansi_format ()
              | "error" ->
                  pop_ansi_format ()
              | "warning" ->
                  pop_ansi_format ()
              | "hilight" ->
                  pop_ansi_format ()
              | "command" | "list" ->
                  Format.fprintf ppf "@]"
              | "document" ->
                  Format.fprintf ppf "@]"
              | other ->
                  pop_level_tag other);
          } ;
        Format.pp_set_print_tags ppf true
    | Plain ->
        Format.pp_set_formatter_tag_functions
          ppf
          {
            mark_open_tag = (fun _ -> "");
            mark_close_tag = (fun _ -> "");
            print_open_tag =
              (function
              | "title" ->
                  ()
              | "commandline" ->
                  Format.fprintf ppf "@[<hov 4>"
              | "commanddoc" ->
                  Format.fprintf ppf "  @[<v 0>"
              | "opt" ->
                  ()
              | "arg" ->
                  Format.fprintf ppf "<"
              | "kwd" ->
                  ()
              | "hilight" ->
                  ()
              | "error" ->
                  ()
              | "warning" ->
                  ()
              | "list" ->
                  Format.fprintf ppf "  @[<v 0>"
              | "command" ->
                  Format.fprintf ppf "@[<v 0>"
              | "document" ->
                  Format.fprintf ppf "@[<v 0>"
              | other ->
                  push_level_tag other);
            print_close_tag =
              (function
              | "title" ->
                  Format.fprintf ppf ":"
              | "commandline" ->
                  Format.fprintf ppf "@]"
              | "commanddoc" ->
                  Format.fprintf ppf "@]"
              | "opt" ->
                  ()
              | "arg" ->
                  Format.fprintf ppf ">"
              | "kwd" ->
                  ()
              | "error" ->
                  ()
              | "warning" ->
                  ()
              | "hilight" ->
                  ()
              | "command" | "list" ->
                  Format.fprintf ppf "@]"
              | "document" ->
                  Format.fprintf ppf "@]"
              | other ->
                  pop_level_tag other);
          } ;
        Format.pp_set_print_tags ppf true
    | Html ->
        Format.pp_set_formatter_tag_functions
          ppf
          {
            mark_open_tag = (fun _ -> "");
            mark_close_tag = (fun _ -> "");
            print_open_tag =
              (function
              | "title" ->
                  Format.fprintf ppf "\003h3\004"
              | "commandline" ->
                  Format.fprintf ppf "\003div class='cmdline'\004@[<h>"
              | "commanddoc" ->
                  Format.fprintf ppf "\003div class='cmddoc'\004"
              | "opt" ->
                  Format.fprintf ppf "\003span class='opt'\004"
              | "arg" ->
                  Format.fprintf ppf "\003span class='arg'\004"
              | "kwd" ->
                  Format.fprintf ppf "\003span class='kwd'\004"
              | "hilight" ->
                  ()
              | "error" ->
                  ()
              | "warning" ->
                  ()
              | "list" ->
                  Format.fprintf ppf "\003ul\004@\n"
              | "command" ->
                  Format.fprintf ppf "\003li\004@\n"
              | "document" ->
                  Format.fprintf
                    ppf
                    "@[<v 0>\003style\004.cmdline { font-family: monospace \
                     }.cmddoc { white-space: pre-wrap ; font-family: \
                     monospace; line-height: 170%%; margin: 0 0 20px 0 \
                     }.cmdline { background: #343131; padding: 2px 8px; \
                     border-radius:10px; color: white; margin: 5px; \
                     }.cmdline+.cmddoc { margin: -5px 5px 0 20px; padding: \
                     5px }.opt,.arg { background: #343131; font-weight: \
                     bold;  padding: 2px 4px; border-radius:5px; }.kwd { \
                     font-weight: bold; } .opt { color:#CF0; background: \
                     #460; } .arg { color: #CEF; background: #369; \
                     }\003/style\004@\n"
              | other ->
                  push_level_tag other);
            print_close_tag =
              (function
              | "title" ->
                  Format.fprintf ppf "\003/h3\004@\n"
              | "commandline" ->
                  Format.fprintf ppf "@]\003/div\004@\n"
              | "commanddoc" ->
                  Format.fprintf ppf "\003/div\004@\n"
              | "opt" | "arg" | "kwd" ->
                  Format.fprintf ppf "\003/span\004"
              | "error" | "warning" | "hilight" ->
                  ()
              | "list" ->
                  Format.fprintf ppf "\003/ul\004@\n"
              | "command" ->
                  Format.fprintf ppf "\003/li\004@\n"
              | "document" ->
                  Format.fprintf ppf "@]"
              | other ->
                  pop_level_tag other);
          } ;
        let orig_out_functions =
          Format.pp_get_formatter_out_functions ppf ()
        in
        Format.pp_set_formatter_out_functions
          ppf
          {
            orig_out_functions with
            out_string =
              (fun s i j ->
                let buf = Buffer.create (j - i) in
                for n = i to j - 1 do
                  match s.[n] with
                  | '\003' ->
                      Buffer.add_char buf '<'
                  | '\004' ->
                      Buffer.add_char buf '>'
                  | '>' ->
                      Buffer.add_string buf "&gt;"
                  | '<' ->
                      Buffer.add_string buf "&lt;"
                  | c ->
                      Buffer.add_char buf c
                done ;
                let s' = Buffer.contents buf in
                orig_out_functions.out_string s' 0 (String.length s'));
          } ;
        Format.pp_set_print_tags ppf true ) ;
  orig_state

let restore_formatter ppf (out_functions, tag_functions, tags) =
  Format.pp_print_flush ppf () ;
  Format.pp_set_formatter_out_functions ppf out_functions ;
  Format.pp_set_formatter_tag_functions ppf tag_functions ;
  Format.pp_set_print_tags ppf tags

let usage_internal ppf ~executable_name ~global_options ?(highlights = [])
    commands =
  let by_group = group_commands commands in
  let (Argument {spec; _}) = global_options in
  let print_groups =
    Format.pp_print_list
      ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,@,")
      (print_group (fun ppf (Ex command) ->
           print_command ?prefix:None ~highlights ppf command))
  in
  Format.fprintf
    ppf
    "@{<document>@{<title>Usage@}@,\
     @{<list>@{<command>@{<commandline>%s [@{<opt>global options@}] \
     @{<kwd>command@} [@{<opt>command options@}]@}@}@,\
     @{<command>@{<commandline>%s @{<opt>--help@} (for global options)@}@}@,\
     @{<command>@{<commandline>%s [@{<opt>global options@}] @{<kwd>command@} \
     @{<opt>--help@} (for command options)@}@}@}@,\
     @,\
     @{<title>To browse the documentation@}@,\
     @{<list>@{<command>@{<commandline>%s [@{<opt>global options@}] \
     @{<kwd>man@} (for a list of commands)@}@}@,\
     @{<command>@{<commandline>%s [@{<opt>global options@}] @{<kwd>man@} \
     @{<opt>-v 3@} (for the full manual)@}@}@}@,\
     @,\
     @{<title>Global options (must come before the command)@}@,\
     @{<commanddoc>%a@}%a%a@}@."
    executable_name
    executable_name
    executable_name
    executable_name
    executable_name
    print_options_detailed
    spec
    (fun ppf () -> if by_group <> [] then Format.fprintf ppf "@,@,")
    ()
    print_groups
    by_group

let constant c = Constant c

let arg ~doc ?short ~long ~placeholder kind =
  Arg {doc; label = {long; short}; placeholder; kind}

let default_arg ~doc ?short ~long ~placeholder ~default kind =
  DefArg {doc; placeholder; label = {long; short}; kind; default}

let switch ~doc ?short ~long () = Switch {doc; label = {long; short}}

let parse_arg :
    type a ctx.
    ?command:_ command ->
    (a, ctx) arg ->
    string list TzString.Map.t ->
    ctx ->
    a tzresult Lwt.t =
 fun ?command spec args_dict ctx ->
  match spec with
  | Arg {label = {long; short = _}; kind = {converter; _}; _} -> (
    match TzString.Map.find_opt long args_dict with
    | None | Some [] ->
        return_none
    | Some [s] ->
        trace (Bad_option_argument ("--" ^ long, command)) (converter ctx s)
        >>|? fun x -> Some x
    | Some (_ :: _) ->
        fail (Multiple_occurences ("--" ^ long, command)) )
  | DefArg {label = {long; short = _}; kind = {converter; _}; default; _} -> (
      converter ctx default
      >>= fun default ->
      ( match default with
      | Ok x ->
          return x
      | Error _ ->
          invalid_arg
            (Format.sprintf
               "Value provided as default for '%s' could not be parsed by \
                converter function."
               long) )
      >>=? fun default ->
      match TzString.Map.find_opt long args_dict with
      | None | Some [] ->
          return default
      | Some [s] ->
          trace (Bad_option_argument (long, command)) (converter ctx s)
      | Some (_ :: _) ->
          fail (Multiple_occurences (long, command)) )
  | Switch {label = {long; short = _}; _} -> (
    match TzString.Map.find_opt long args_dict with
    | None | Some [] ->
        return_false
    | Some [_] ->
        return_true
    | Some (_ :: _) ->
        fail (Multiple_occurences (long, command)) )
  | Constant c ->
      return c

(* Argument parsing *)
let rec parse_args :
    type a ctx.
    ?command:_ command ->
    (a, ctx) args ->
    string list TzString.Map.t ->
    ctx ->
    a tzresult Lwt.t =
 fun ?command spec args_dict ctx ->
  match spec with
  | NoArgs ->
      return_unit
  | AddArg (arg, rest) ->
      parse_arg ?command arg args_dict ctx
      >>=? fun arg ->
      parse_args ?command rest args_dict ctx >>|? fun rest -> (arg, rest)

let empty_args_dict = TzString.Map.empty

let rec make_arities_dict :
    type a b.
    (a, b) args ->
    (int * string) TzString.Map.t ->
    (int * string) TzString.Map.t =
 fun args acc ->
  match args with
  | NoArgs ->
      acc
  | AddArg (arg, rest) -> (
      let recur {long; short} num =
        ( match short with
        | None ->
            acc
        | Some c ->
            TzString.Map.add ("-" ^ String.make 1 c) (num, long) acc )
        |> TzString.Map.add ("-" ^ long) (num, long)
        |> TzString.Map.add ("--" ^ long) (num, long)
        |> make_arities_dict rest
      in
      match arg with
      | Arg {label; _} ->
          recur label 1
      | DefArg {label; _} ->
          recur label 1
      | Switch {label; _} ->
          recur label 0
      | Constant _c ->
          make_arities_dict rest acc )

type error += Help : 'a command option -> error

let check_help_flag ?command = function
  | ("-h" | "--help") :: _ ->
      fail (Help command)
  | _ ->
      return_unit

let add_occurrence long value acc =
  match TzString.Map.find_opt long acc with
  | Some v ->
      TzString.Map.add long v acc
  | None ->
      TzString.Map.add long [value] acc

let make_args_dict_consume ?command spec args =
  let rec make_args_dict completing arities acc args =
    check_help_flag ?command args
    >>=? fun () ->
    match args with
    | [] ->
        return (acc, [])
    | arg :: tl ->
        if String.length arg > 0 && arg.[0] = '-' then
          if TzString.Map.mem arg arities then
            let (arity, long) = TzString.Map.find arg arities in
            check_help_flag ?command tl
            >>=? fun () ->
            match (arity, tl) with
            | (0, tl') ->
                make_args_dict
                  completing
                  arities
                  (add_occurrence long "" acc)
                  tl'
            | (1, value :: tl') ->
                make_args_dict
                  completing
                  arities
                  (add_occurrence long value acc)
                  tl'
            | (1, []) when completing ->
                return (acc, [])
            | (1, []) ->
                fail (Option_expected_argument (arg, None))
            | (_, _) ->
                raise
                  (Failure
                     "cli_entries: Arguments with arity not equal to 1 or 0 \
                      not supported")
          else fail (Unknown_option (arg, None))
        else return (acc, args)
  in
  make_args_dict
    false
    (make_arities_dict spec TzString.Map.empty)
    TzString.Map.empty
    args

let make_args_dict_filter ?command spec args =
  let rec make_args_dict arities (dict, other_args) args =
    check_help_flag ?command args
    >>=? fun () ->
    match args with
    | [] ->
        return (dict, other_args)
    | arg :: tl ->
        if TzString.Map.mem arg arities then
          let (arity, long) = TzString.Map.find arg arities in
          check_help_flag ?command tl
          >>=? fun () ->
          match (arity, tl) with
          | (0, tl) ->
              make_args_dict
                arities
                (add_occurrence long "" dict, other_args)
                tl
          | (1, value :: tl') ->
              make_args_dict
                arities
                (add_occurrence long value dict, other_args)
                tl'
          | (1, []) ->
              fail (Option_expected_argument (arg, command))
          | (_, _) ->
              raise
                (Failure
                   "cli_entries: Arguments with arity not equal to 1 or 0 not \
                    supported")
        else make_args_dict arities (dict, arg :: other_args) tl
  in
  make_args_dict
    (make_arities_dict spec TzString.Map.empty)
    (TzString.Map.empty, [])
    args
  >>|? fun (dict, remaining) -> (dict, List.rev remaining)

let ( >> ) arg1 arg2 = AddArg (arg1, arg2)

let args1 spec =
  Argument {spec = spec >> NoArgs; converter = (fun (arg, ()) -> arg)}

let args2 spec1 spec2 =
  Argument
    {
      spec = spec1 >> (spec2 >> NoArgs);
      converter = (fun (arg1, (arg2, ())) -> (arg1, arg2));
    }

let args3 spec1 spec2 spec3 =
  Argument
    {
      spec = spec1 >> (spec2 >> (spec3 >> NoArgs));
      converter = (fun (arg1, (arg2, (arg3, ()))) -> (arg1, arg2, arg3));
    }

let args4 spec1 spec2 spec3 spec4 =
  Argument
    {
      spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> NoArgs)));
      converter =
        (fun (arg1, (arg2, (arg3, (arg4, ())))) -> (arg1, arg2, arg3, arg4));
    }

let args5 spec1 spec2 spec3 spec4 spec5 =
  Argument
    {
      spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> NoArgs))));
      converter =
        (fun (arg1, (arg2, (arg3, (arg4, (arg5, ()))))) ->
          (arg1, arg2, arg3, arg4, arg5));
    }

let args6 spec1 spec2 spec3 spec4 spec5 spec6 =
  Argument
    {
      spec =
        spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> NoArgs)))));
      converter =
        (fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, ())))))) ->
          (arg1, arg2, arg3, arg4, arg5, spec6));
    }

let args7 spec1 spec2 spec3 spec4 spec5 spec6 spec7 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> NoArgs))))) );
      converter =
        (fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, ()))))))) ->
          (arg1, arg2, arg3, arg4, arg5, spec6, spec7));
    }

let args8 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> NoArgs)))))
              ) );
      converter =
        (fun ( arg1,
               (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, ()))))))) ) ->
          (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8));
    }

let args9 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> NoArgs)))) ) )
              ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, ())))))))
               ) ) ->
          (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9));
    }

let args10 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> ( spec6
                       >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> NoArgs))))
                       ) ) ) ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 ( arg3,
                   ( arg4,
                     (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, ()))))))
                   ) ) ) ) ->
          (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10));
    }

let args11 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11
    =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> ( spec6
                       >> ( spec7
                          >> ( spec8
                             >> (spec9 >> (spec10 >> (spec11 >> NoArgs))) ) )
                       ) ) ) ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 ( arg3,
                   ( arg4,
                     ( arg5,
                       ( spec6,
                         (spec7, (spec8, (spec9, (spec10, (spec11, ()))))) ) )
                   ) ) ) ) ->
          ( arg1,
            arg2,
            arg3,
            arg4,
            arg5,
            spec6,
            spec7,
            spec8,
            spec9,
            spec10,
            spec11 ));
    }

let args12 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11
    spec12 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> ( spec6
                       >> ( spec7
                          >> ( spec8
                             >> ( spec9
                                >> (spec10 >> (spec11 >> (spec12 >> NoArgs)))
                                ) ) ) ) ) ) ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 ( arg3,
                   ( arg4,
                     ( arg5,
                       ( spec6,
                         ( spec7,
                           (spec8, (spec9, (spec10, (spec11, (spec12, ())))))
                         ) ) ) ) ) ) ) ->
          ( arg1,
            arg2,
            arg3,
            arg4,
            arg5,
            spec6,
            spec7,
            spec8,
            spec9,
            spec10,
            spec11,
            spec12 ));
    }

let args13 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11
    spec12 spec13 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> ( spec6
                       >> ( spec7
                          >> ( spec8
                             >> ( spec9
                                >> ( spec10
                                   >> (spec11 >> (spec12 >> (spec13 >> NoArgs)))
                                   ) ) ) ) ) ) ) ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 ( arg3,
                   ( arg4,
                     ( arg5,
                       ( spec6,
                         ( spec7,
                           ( spec8,
                             (spec9, (spec10, (spec11, (spec12, (spec13, ())))))
                           ) ) ) ) ) ) ) ) ->
          ( arg1,
            arg2,
            arg3,
            arg4,
            arg5,
            spec6,
            spec7,
            spec8,
            spec9,
            spec10,
            spec11,
            spec12,
            spec13 ));
    }

let args14 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11
    spec12 spec13 spec14 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> ( spec6
                       >> ( spec7
                          >> ( spec8
                             >> ( spec9
                                >> ( spec10
                                   >> ( spec11
                                      >> ( spec12
                                         >> (spec13 >> (spec14 >> NoArgs)) ) )
                                   ) ) ) ) ) ) ) ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 ( arg3,
                   ( arg4,
                     ( arg5,
                       ( spec6,
                         ( spec7,
                           ( spec8,
                             ( spec9,
                               ( spec10,
                                 (spec11, (spec12, (spec13, (spec14, ())))) )
                             ) ) ) ) ) ) ) ) ) ->
          ( arg1,
            arg2,
            arg3,
            arg4,
            arg5,
            spec6,
            spec7,
            spec8,
            spec9,
            spec10,
            spec11,
            spec12,
            spec13,
            spec14 ));
    }

let args15 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11
    spec12 spec13 spec14 spec15 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> ( spec6
                       >> ( spec7
                          >> ( spec8
                             >> ( spec9
                                >> ( spec10
                                   >> ( spec11
                                      >> ( spec12
                                         >> ( spec13
                                            >> (spec14 >> (spec15 >> NoArgs))
                                            ) ) ) ) ) ) ) ) ) ) ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 ( arg3,
                   ( arg4,
                     ( arg5,
                       ( spec6,
                         ( spec7,
                           ( spec8,
                             ( spec9,
                               ( spec10,
                                 ( spec11,
                                   (spec12, (spec13, (spec14, (spec15, ()))))
                                 ) ) ) ) ) ) ) ) ) ) ) ->
          ( arg1,
            arg2,
            arg3,
            arg4,
            arg5,
            spec6,
            spec7,
            spec8,
            spec9,
            spec10,
            spec11,
            spec12,
            spec13,
            spec14,
            spec15 ));
    }

let args16 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11
    spec12 spec13 spec14 spec15 spec16 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> ( spec6
                       >> ( spec7
                          >> ( spec8
                             >> ( spec9
                                >> ( spec10
                                   >> ( spec11
                                      >> ( spec12
                                         >> ( spec13
                                            >> ( spec14
                                               >> (spec15 >> (spec16 >> NoArgs))
                                               ) ) ) ) ) ) ) ) ) ) ) ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 ( arg3,
                   ( arg4,
                     ( arg5,
                       ( spec6,
                         ( spec7,
                           ( spec8,
                             ( spec9,
                               ( spec10,
                                 ( spec11,
                                   ( spec12,
                                     (spec13, (spec14, (spec15, (spec16, ()))))
                                   ) ) ) ) ) ) ) ) ) ) ) ) ->
          ( arg1,
            arg2,
            arg3,
            arg4,
            arg5,
            spec6,
            spec7,
            spec8,
            spec9,
            spec10,
            spec11,
            spec12,
            spec13,
            spec14,
            spec15,
            spec16 ));
    }

let args17 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11
    spec12 spec13 spec14 spec15 spec16 spec17 =
  Argument
    {
      spec =
        spec1
        >> ( spec2
           >> ( spec3
              >> ( spec4
                 >> ( spec5
                    >> ( spec6
                       >> ( spec7
                          >> ( spec8
                             >> ( spec9
                                >> ( spec10
                                   >> ( spec11
                                      >> ( spec12
                                         >> ( spec13
                                            >> ( spec14
                                               >> ( spec15
                                                  >> ( spec16
                                                     >> (spec17 >> NoArgs) ) )
                                               ) ) ) ) ) ) ) ) ) ) ) ) );
      converter =
        (fun ( arg1,
               ( arg2,
                 ( arg3,
                   ( arg4,
                     ( arg5,
                       ( spec6,
                         ( spec7,
                           ( spec8,
                             ( spec9,
                               ( spec10,
                                 ( spec11,
                                   ( spec12,
                                     ( spec13,
                                       ( spec14,
                                         (spec15, (spec16, (spec17, ()))) ) )
                                   ) ) ) ) ) ) ) ) ) ) ) ) ->
          ( arg1,
            arg2,
            arg3,
            arg4,
            arg5,
            spec6,
            spec7,
            spec8,
            spec9,
            spec10,
            spec11,
            spec12,
            spec13,
            spec14,
            spec15,
            spec16,
            spec17 ));
    }

(* Some combinators for writing commands concisely. *)
let param ~name ~desc kind next = Param (name, desc, kind, next)

let seq_of_param param =
  match param Stop with
  | Param (n, desc, parameter, Stop) ->
      Seq (n, desc, parameter)
  | _ ->
      invalid_arg "Clic.seq_of_param"

let prefix keyword next = Prefix (keyword, next)

let rec fixed = function [] -> Stop | n :: r -> Prefix (n, fixed r)

let rec prefixes p next =
  match p with [] -> next | n :: r -> Prefix (n, prefixes r next)

let stop = Stop

let no_options = Argument {spec = NoArgs; converter = (fun () -> ())}

let command ?group ~desc options params handler =
  Command {params; options; handler; desc; group; conv = (fun x -> x)}

(* Param combinators *)
let string ~name ~desc next =
  param
    ~name
    ~desc
    {converter = (fun _ s -> return s); autocomplete = None}
    next

let string_contains ~needle ~haystack =
  try Some (Re.Str.search_forward (Re.Str.regexp_string needle) haystack 0)
  with Not_found -> None

let rec search_params_prefix : type a arg. string -> (a, arg) params -> bool =
 fun prefix -> function
  | Prefix (keyword, next) -> (
    match string_contains ~needle:prefix ~haystack:keyword with
    | None ->
        search_params_prefix prefix next
    | Some _ ->
        true )
  | Param (_, _, _, next) ->
      search_params_prefix prefix next
  | Stop ->
      false
  | Seq _ ->
      false

let search_command keyword (Command {params; _}) =
  search_params_prefix keyword params

(* Command execution *)
let exec (type ctx)
    ( Command
        { options = Argument {converter; spec = options_spec};
          params = spec;
          handler;
          conv;
          _ } as command ) (ctx : ctx) params args_dict =
  let rec exec :
      type ctx a.
      int -> ctx -> (a, ctx) params -> a -> string list -> unit tzresult Lwt.t
      =
   fun i ctx spec cb params ->
    match (spec, params) with
    | (Stop, _) ->
        cb ctx
    | (Seq (_, _, {converter; _}), seq) ->
        let rec do_seq i acc = function
          | [] ->
              return (List.rev acc)
          | p :: rest ->
              Lwt.catch
                (fun () -> converter ctx p)
                (function
                  | Failure msg ->
                      Error_monad.failwith "%s" msg
                  | exn ->
                      fail (Exn exn))
              |> trace (Bad_argument (i, p))
              >>=? fun v -> do_seq (succ i) (v :: acc) rest
        in
        do_seq i [] seq >>=? fun parsed -> cb parsed ctx
    | (Prefix (n, next), p :: rest) when n = p ->
        exec (succ i) ctx next cb rest
    | (Param (_, _, {converter; _}, next), p :: rest) ->
        Lwt.catch
          (fun () -> converter ctx p)
          (function
            | Failure msg ->
                Error_monad.failwith "%s" msg
            | exn ->
                fail (Exn exn))
        |> trace (Bad_argument (i, p))
        >>=? fun v -> exec (succ i) ctx next (cb v) rest
    | _ ->
        raise (Failure "cli_entries internal error: exec no case matched")
  in
  let ctx = conv ctx in
  parse_args ~command options_spec args_dict ctx
  >>=? fun parsed_options ->
  exec 1 ctx spec (handler (converter parsed_options)) params

[@@@ocaml.warning "-30"]

(* Command dispatch tree *)
type 'arg level = {
  stop : 'arg command option;
  prefix : (string * 'arg tree) list;
}

and 'arg param_level = {
  stop : 'arg command option;
  autocomplete : ('arg -> string list tzresult Lwt.t) option;
  tree : 'arg tree;
}

and 'ctx tree =
  | TPrefix : 'ctx level -> 'ctx tree
  | TParam : 'ctx param_level -> 'ctx tree
  | TStop : 'ctx command -> 'ctx tree
  | TSeq :
      'ctx command * ('ctx -> string list tzresult Lwt.t) option
      -> 'ctx tree
  | TEmpty : 'ctx tree

let has_options : type ctx. ctx command -> bool =
 fun (Command {options = Argument {spec; _}; _}) ->
  let args_help : type a ctx. (a, ctx) args -> bool = function
    | NoArgs ->
        false
    | AddArg (_, _) ->
        true
  in
  args_help spec

let insert_in_dispatch_tree : type ctx. ctx tree -> ctx command -> ctx tree =
 fun root (Command {params; conv; _} as command) ->
  let access_autocomplete :
      type p ctx.
      (p, ctx) parameter -> (ctx -> string list tzresult Lwt.t) option =
   fun {autocomplete; _} -> autocomplete
  in
  let rec insert_tree :
      type a ictx. (ctx -> ictx) -> ctx tree -> (a, ictx) params -> ctx tree =
   fun conv t c ->
    let insert_tree t c = insert_tree conv t c in
    match (t, c) with
    | (TEmpty, Stop) ->
        TStop command
    | (TEmpty, Seq (_, _, {autocomplete; _})) ->
        TSeq (command, Option.map autocomplete ~f:(fun a c -> a (conv c)))
    | (TEmpty, Param (_, _, param, next)) ->
        let autocomplete = access_autocomplete param in
        let autocomplete =
          Option.map autocomplete ~f:(fun a c -> a (conv c))
        in
        TParam {tree = insert_tree TEmpty next; stop = None; autocomplete}
    | (TEmpty, Prefix (n, next)) ->
        TPrefix {stop = None; prefix = [(n, insert_tree TEmpty next)]}
    | (TStop cmd, Param (_, _, param, next)) ->
        let autocomplete = access_autocomplete param in
        let autocomplete =
          Option.map autocomplete ~f:(fun a c -> a (conv c))
        in
        if not (has_options cmd) then
          TParam
            {tree = insert_tree TEmpty next; stop = Some cmd; autocomplete}
        else raise (Failure "Command cannot have both prefix and options")
    | (TStop cmd, Prefix (n, next)) ->
        TPrefix {stop = Some cmd; prefix = [(n, insert_tree TEmpty next)]}
    | (TParam t, Param (_, _, _, next)) ->
        TParam {t with tree = insert_tree t.tree next}
    | (TPrefix ({prefix; _} as l), Prefix (n, next)) ->
        let rec insert_prefix = function
          | [] ->
              [(n, insert_tree TEmpty next)]
          | (n', t) :: rest when n = n' ->
              (n, insert_tree t next) :: rest
          | item :: rest ->
              item :: insert_prefix rest
        in
        TPrefix {l with prefix = insert_prefix prefix}
    | (TPrefix ({stop = None; _} as l), Stop) ->
        TPrefix {l with stop = Some command}
    | (TParam ({stop = None; _} as l), Stop) ->
        TParam {l with stop = Some command}
    | (TParam t, Prefix (_n, next)) ->
        TParam {t with tree = insert_tree t.tree next}
    | (_, _) ->
        Pervasives.failwith
          (Format.asprintf
             "Clic.Command_tree.insert: conflicting commands \"%a\""
             (fun ppf (Command {params; options = Argument {spec; _}; _}) ->
               print_commandline ppf ([], spec, params))
             command)
  in
  insert_tree conv root params

let make_dispatch_tree commands =
  List.fold_left insert_in_dispatch_tree TEmpty commands

let rec gather_commands ?(acc = []) tree =
  match tree with
  | TEmpty ->
      acc
  | TSeq (c, _) | TStop c ->
      c :: acc
  | TPrefix {stop; prefix} ->
      gather_assoc
        ~acc:(match stop with None -> acc | Some c -> c :: acc)
        prefix
  | TParam {tree; stop; _} ->
      gather_commands
        tree
        ~acc:(match stop with None -> acc | Some c -> c :: acc)

and gather_assoc ?(acc = []) trees =
  List.fold_left (fun acc (_, tree) -> gather_commands tree ~acc) acc trees

let find_command tree initial_arguments =
  let rec traverse tree arguments acc =
    match (tree, arguments) with
    | ( ( TStop _
        | TSeq _
        | TPrefix {stop = Some _; _}
        | TParam {stop = Some _; _} ),
        ("-h" | "--help") :: _ ) -> (
      match gather_commands tree with
      | [] ->
          assert false
      | [command] ->
          fail (Help (Some command))
      | more ->
          fail (Unterminated_command (initial_arguments, more)) )
    | (TStop c, []) ->
        return (c, empty_args_dict, initial_arguments)
    | (TStop (Command {options = Argument {spec; _}; _} as command), remaining)
      -> (
        make_args_dict_filter ~command spec remaining
        >>=? fun (args_dict, unparsed) ->
        match unparsed with
        | [] ->
            return (command, args_dict, initial_arguments)
        | hd :: _ ->
            if String.length hd > 0 && hd.[0] = '-' then
              fail (Unknown_option (hd, Some command))
            else fail (Extra_arguments (unparsed, command)) )
    | ( TSeq ((Command {options = Argument {spec; _}; _} as command), _),
        remaining ) ->
        if
          List.exists
            (function "-h" | "--help" -> true | _ -> false)
            remaining
        then fail (Help (Some command))
        else
          make_args_dict_filter ~command spec remaining
          >>|? fun (dict, remaining) ->
          (command, dict, List.rev_append acc remaining)
    | (TPrefix {stop = Some cmd; _}, []) ->
        return (cmd, empty_args_dict, initial_arguments)
    | (TPrefix {stop = None; prefix}, ([] | ("-h" | "--help") :: _)) ->
        fail (Unterminated_command (initial_arguments, gather_assoc prefix))
    | (TPrefix {prefix; _}, hd_arg :: tl) ->
        ( try return (List.assoc hd_arg prefix)
          with Not_found ->
            fail (Command_not_found (List.rev acc, gather_assoc prefix)) )
        >>=? fun tree' -> traverse tree' tl (hd_arg :: acc)
    | (TParam {stop = None; _}, ([] | ("-h" | "--help") :: _)) ->
        fail (Unterminated_command (initial_arguments, gather_commands tree))
    | (TParam {stop = Some c; _}, []) ->
        return (c, empty_args_dict, initial_arguments)
    | (TParam {tree; _}, parameter :: arguments') ->
        traverse tree arguments' (parameter :: acc)
    | (TEmpty, _) ->
        fail (Command_not_found (List.rev acc, []))
  in
  traverse tree initial_arguments []

let get_arg_label (type a) (arg : (a, _) arg) =
  match arg with
  | Arg {label; _} ->
      label
  | DefArg {label; _} ->
      label
  | Switch {label; _} ->
      label
  | Constant _ ->
      assert false

let get_arg : type a ctx. (a, ctx) arg -> string list =
 fun arg ->
  let {long; short} = get_arg_label arg in
  ("--" ^ long)
  :: (match short with None -> [] | Some c -> ["-" ^ String.make 1 c])

let rec list_args : type arg ctx. (arg, ctx) args -> string list = function
  | NoArgs ->
      []
  | AddArg (Constant _, args) ->
      list_args args
  | AddArg (arg, args) ->
      get_arg arg @ list_args args

let complete_func autocomplete cctxt =
  match autocomplete with
  | None ->
      return_nil
  | Some autocomplete ->
      autocomplete cctxt

let list_command_args (Command {options = Argument {spec; _}; _}) =
  list_args spec

let complete_arg :
    type a ctx. ctx -> (a, ctx) arg -> string list tzresult Lwt.t =
 fun ctx -> function
  | Arg {kind = {autocomplete; _}; _} ->
      complete_func autocomplete ctx
  | DefArg {kind = {autocomplete; _}; _} ->
      complete_func autocomplete ctx
  | Switch _ ->
      return_nil
  | Constant _ ->
      return_nil

let rec remaining_spec :
    type a ctx. TzString.Set.t -> (a, ctx) args -> string list =
 fun seen -> function
  | NoArgs ->
      []
  | AddArg (Constant _, rest) ->
      remaining_spec seen rest
  | AddArg (arg, rest) ->
      let {long; _} = get_arg_label arg in
      if TzString.Set.mem long seen then remaining_spec seen rest
      else get_arg arg @ remaining_spec seen rest

let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) =
  let arities = make_arities_dict args_spec TzString.Map.empty in
  let rec complete_spec :
      type a. string -> (a, ctx) args -> string list tzresult Lwt.t =
   fun name -> function
    | NoArgs ->
        return_nil
    | AddArg (Constant _, rest) ->
        complete_spec name rest
    | AddArg (arg, rest) ->
        if (get_arg_label arg).long = name then complete_arg ctx arg
        else complete_spec name rest
  in
  let rec help args ind seen =
    match args with
    | _ when ind = 0 ->
        continuation args 0
        >>|? fun cont_args -> cont_args @ remaining_spec seen args_spec
    | [] ->
        Pervasives.failwith "cli_entries internal autocomplete error"
    | arg :: tl ->
        if TzString.Map.mem arg arities then
          let (arity, long) = TzString.Map.find arg arities in
          let seen = TzString.Set.add long seen in
          match (arity, tl) with
          | (0, args) when ind = 0 ->
              continuation args 0
              >>|? fun cont_args -> remaining_spec seen args_spec @ cont_args
          | (0, args) ->
              help args (ind - 1) seen
          | (1, _) when ind = 1 ->
              complete_spec arg args_spec
          | (1, _ :: tl) ->
              help tl (ind - 2) seen
          | _ ->
              Pervasives.failwith "cli_entries internal error, invalid arity"
        else continuation args ind
  in
  help args ind TzString.Set.empty

let complete_next_tree cctxt = function
  | TPrefix {stop; prefix} ->
      return
        ( ( match stop with
          | None ->
              []
          | Some command ->
              list_command_args command )
        @ List.map fst prefix )
  | TSeq (command, autocomplete) ->
      complete_func autocomplete cctxt
      >>|? fun completions -> completions @ list_command_args command
  | TParam {autocomplete; _} ->
      complete_func autocomplete cctxt
  | TStop command ->
      return (list_command_args command)
  | TEmpty ->
      return_nil

let complete_tree cctxt tree index args =
  let rec help tree args ind =
    if ind = 0 then complete_next_tree cctxt tree
    else
      match (tree, args) with
      | (TSeq _, _) ->
          complete_next_tree cctxt tree
      | (TPrefix {prefix; _}, hd :: tl) -> (
        try help (List.assoc hd prefix) tl (ind - 1)
        with Not_found -> return_nil )
      | (TParam {tree; _}, _ :: tl) ->
          help tree tl (ind - 1)
      | (TStop (Command {options = Argument {spec; _}; conv; _}), args) ->
          complete_options (fun _ _ -> return_nil) args spec ind (conv cctxt)
      | ((TParam _ | TPrefix _), []) | (TEmpty, _) ->
          return_nil
  in
  help tree args index

let autocompletion ~script ~cur_arg ~prev_arg ~args ~global_options commands
    cctxt =
  let tree = make_dispatch_tree commands in
  let rec ind n = function
    | [] ->
        None
    | hd :: tl ->
        if hd = prev_arg then
          Some (Option.unopt ~default:(n + 1) (ind (n + 1) tl))
        else ind (n + 1) tl
  in
  ( if prev_arg = script then
    complete_next_tree cctxt tree
    >>|? fun command_completions ->
    let (Argument {spec; _}) = global_options in
    list_args spec @ command_completions
  else
    match ind 0 args with
    | None ->
        return_nil
    | Some index ->
        let (Argument {spec; _}) = global_options in
        complete_options
          (fun args ind -> complete_tree cctxt tree ind args)
          args
          spec
          index
          cctxt )
  >>|? fun completions ->
  List.filter
    (fun completion ->
      Re.Str.(string_match (regexp_string cur_arg) completion 0))
    completions

let parse_global_options global_options ctx args =
  let (Argument {spec; converter}) = global_options in
  make_args_dict_consume spec args
  >>=? fun (dict, remaining) ->
  parse_args spec dict ctx
  >>=? fun nested -> return (converter nested, remaining)

let dispatch commands ctx args =
  let tree = make_dispatch_tree commands in
  match args with
  | [] | [("-h" | "--help")] ->
      fail (Help None)
  | _ ->
      find_command tree args
      >>=? fun (command, args_dict, filtered_args) ->
      exec command ctx filtered_args args_dict

type error += No_manual_entry of string list

let manual_group = {name = "man"; title = "Access the documentation"}

let add_manual ~executable_name ~global_options format ppf commands =
  let rec with_manual =
    lazy
      ( commands
      @ [ command
            ~group:manual_group
            ~desc:
              "Print documentation of commands.\n\
               Add search keywords to narrow list.\n\
               Will display only the commands by default, unless [-verbosity \
               <2|3>] is passed or the list of matching commands if less than \
               3."
            (args2
               (arg
                  ~doc:
                    "level of details\n\
                     0. Only shows command mnemonics, without documentation.\n\
                     1. Shows command mnemonics with short descriptions.\n\
                     2. Show commands and arguments with short descriptions\n\
                     3. Show everything"
                  ~long:"verbosity"
                  ~short:'v'
                  ~placeholder:"0|1|2|3"
                  (parameter
                     ~autocomplete:(fun _ -> return ["0"; "1"; "2"; "3"])
                     (fun _ arg ->
                       match arg with
                       | "0" ->
                           return Terse
                       | "1" ->
                           return Short
                       | "2" ->
                           return Details
                       | "3" ->
                           return Full
                       | _ ->
                           failwith "Level of details out of range")))
               (default_arg
                  ~doc:"the manual's output format"
                  ~placeholder:"plain|colors|html"
                  ~long:"format"
                  ~default:
                    ( match format with
                    | Ansi ->
                        "colors"
                    | Plain ->
                        "plain"
                    | Html ->
                        "html" )
                  (parameter
                     ~autocomplete:(fun _ ->
                       return ["colors"; "plain"; "html"])
                     (fun _ arg ->
                       match arg with
                       | "colors" ->
                           return Ansi
                       | "plain" ->
                           return Plain
                       | "html" ->
                           return Html
                       | _ ->
                           failwith "Unknown manual format"))))
            (prefix
               "man"
               (seq_of_param
                  (string
                     ~name:"keyword"
                     ~desc:
                       "keyword to search for\n\
                        If several are given they must all appear in the \
                        command.")))
            (fun (verbosity, format) keywords _ ->
              let commands =
                List.fold_left
                  (fun commands keyword ->
                    List.filter (search_command keyword) commands)
                  (Lazy.force with_manual)
                  keywords
              in
              let verbosity =
                match verbosity with
                | Some verbosity ->
                    verbosity
                | None when List.length commands <= 3 ->
                    Full
                | None ->
                    Short
              in
              match commands with
              | [] ->
                  fail (No_manual_entry keywords)
              | _ ->
                  let state = setup_formatter ppf format verbosity in
                  let commands = List.map (fun c -> Ex c) commands in
                  usage_internal
                    ppf
                    ~executable_name
                    ~global_options
                    ~highlights:keywords
                    commands ;
                  restore_formatter ppf state ;
                  return_unit) ] )
  in
  Lazy.force with_manual

let pp_cli_errors ppf ~executable_name ~global_options ~default errs =
  let pp_one = function
    | Bad_argument (i, v) ->
        Format.fprintf ppf "Erroneous command line argument %d (%s)." i v ;
        Some []
    | Option_expected_argument (arg, command) ->
        Format.fprintf
          ppf
          "Command line option @{<opt>%s@} expects an argument."
          arg ;
        Some
          (Option.unopt_map
             ~f:(fun command -> [Ex command])
             ~default:[]
             command)
    | Bad_option_argument (arg, command) ->
        Format.fprintf
          ppf
          "Wrong value for command line option @{<opt>%s@}."
          arg ;
        Some
          (Option.unopt_map
             ~f:(fun command -> [Ex command])
             ~default:[]
             command)
    | Multiple_occurences (arg, command) ->
        Format.fprintf
          ppf
          "Command line option @{<opt>%s@} appears multiple times."
          arg ;
        Some
          (Option.unopt_map
             ~f:(fun command -> [Ex command])
             ~default:[]
             command)
    | No_manual_entry [keyword] ->
        Format.fprintf
          ppf
          "No manual entry that match @{<hilight>%s@}."
          keyword ;
        Some []
    | No_manual_entry (keyword :: keywords) ->
        Format.fprintf
          ppf
          "No manual entry that match %a and @{<hilight>%s@}."
          (Format.pp_print_list
             ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
             (fun ppf keyword -> Format.fprintf ppf "@{<hilight>%s@}" keyword))
          keywords
          keyword ;
        Some []
    | Unknown_option (option, command) ->
        Format.fprintf ppf "Unexpected command line option @{<opt>%s@}." option ;
        Some
          (Option.unopt_map
             ~f:(fun command -> [Ex command])
             ~default:[]
             command)
    | Extra_arguments (extra, command) ->
        Format.fprintf
          ppf
          "Extra command line arguments:@, @[<h>%a@]."
          (Format.pp_print_list (fun ppf -> Format.fprintf ppf "%s"))
          extra ;
        Some [Ex command]
    | Unterminated_command (_, commands) ->
        Format.fprintf
          ppf
          "@[<v 2>Unterminated command, here are possible completions.@,%a@]"
          (Format.pp_print_list
             (fun ppf (Command {params; options = Argument {spec; _}; _}) ->
               print_commandline ppf ([], spec, params)))
          commands ;
        Some (List.map (fun c -> Ex c) commands)
    | Command_not_found ([], _all_commands) ->
        Format.fprintf
          ppf
          "@[<v 0>Unrecognized command.@,\
           Try using the @{<kwd>man@} command to get more information.@]" ;
        Some []
    | Command_not_found (_, commands) ->
        Format.fprintf
          ppf
          "@[<v 0>Unrecognized command.@,\
           Did you mean one of the following?@,\
          \  @[<v 0>%a@]@]"
          (Format.pp_print_list
             (fun ppf (Command {params; options = Argument {spec; _}; _}) ->
               print_commandline ppf ([], spec, params)))
          commands ;
        Some (List.map (fun c -> Ex c) commands)
    | err ->
        default ppf err ; None
  in
  let rec pp acc errs =
    let return command =
      match (command, acc) with
      | (None, _) ->
          acc
      | (Some command, Some commands) ->
          Some (command @ commands)
      | (Some command, None) ->
          Some command
    in
    match errs with
    | [] ->
        None
    | [last] ->
        return (pp_one last)
    | err :: errs ->
        let acc = return (pp_one err) in
        Format.fprintf ppf "@," ; pp acc errs
  in
  Format.fprintf ppf "@[<v 2>@{<error>@{<title>Error@}@}@," ;
  match pp None errs with
  | None ->
      Format.fprintf ppf "@]@\n"
  | Some commands ->
      Format.fprintf
        ppf
        "@]@\n@\n@[<v 0>%a@]"
        (fun ppf commands ->
          usage_internal ppf ~executable_name ~global_options commands)
        commands

let usage ppf ~executable_name ~global_options commands =
  usage_internal
    ppf
    ~executable_name
    ~global_options
    (List.map (fun c -> Ex c) commands)

let map_command f (Command c) = Command {c with conv = (fun x -> c.conv (f x))}
src/lib_clic/clic.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Record parameter {p ctx : Type} := {
  converter : ctx -> string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult p);
  autocomplete :
    option (ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)))
  }.
Arguments parameter : clear implicits.

Definition parameter {A B : Type}
  (autocomplete :
    option (A -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string))))
  (converter : A -> string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult B))
  : parameter B A := {| converter := converter; autocomplete := autocomplete |}.

Definition compose_parameters {A B : Type} (function_parameter : parameter A B)
  : (parameter A B) -> parameter A B :=
  match function_parameter with
  | {| converter := c1; autocomplete := a1' |} =>
    fun function_parameter =>
      match function_parameter with
      | {| converter := c2; autocomplete := a2' |} =>
        {|
          converter :=
            fun ctx =>
              fun s =>
                Tezos_error_monad.Error_monad.op_gt_gt_eq (c1 ctx s)
                  (fun function_parameter =>
                    match function_parameter with
                    | inl r => Tezos_error_monad.Error_monad._return r
                    | inr _ => c2 ctx s
                    end);
          autocomplete :=
            match a1' with
            | None => a2'
            | Some a1 =>
              match a2' with
              | None => a1'
              | Some a2 =>
                Some
                  (fun ctx =>
                    Tezos_error_monad.Error_monad.op_gt_gt_eq_question (a1 ctx)
                      (fun r1 =>
                        Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                          (a2 ctx)
                          (fun r2 =>
                            Tezos_error_monad.Error_monad._return
                              (Stdlib.List.concat (cons r1 (cons r2 []))))))
              end
            end |}
      end
  end.

Definition map_parameter {A B C : Type}
  (f : A -> B) (function_parameter : parameter A C) : parameter B C :=
  match function_parameter with
  | {| converter := converter; autocomplete := autocomplete |} =>
    {|
      converter :=
        fun ctx =>
          fun s =>
            Tezos_error_monad.Error_monad.op_gt_gt_pipe_question
              (converter ctx s) f; autocomplete := autocomplete |}
  end.

Record label := {
  long : string;
  short : option ascii }.

Inductive arg (ctx : Type) : forall (a : Type), Type :=
| Arg : forall {p : Type}, string -> label -> string -> (parameter p ctx) ->
  arg (option p) ctx
| DefArg : forall {p : Type}, string -> label -> string -> (parameter p ctx) ->
  string -> arg p ctx
| Switch : label -> string -> arg bool ctx
| Constant : forall {a : Type}, a -> arg a ctx.

Arguments Arg {_}.
Arguments DefArg {_}.
Arguments Switch {_}.
Arguments Constant {_}.

Inductive args : forall (a arg : Type), Type :=
| NoArgs : forall {args : Type}, args unit args
| AddArg : forall {a args b : Type}, (arg a args) -> (args b args) ->
  args (a * b) args.

Inductive params (ctx : Type) : forall (a : Type), Type :=
| Prefix : forall {a : Type}, string -> (params a ctx) -> params a ctx
| Param : forall {a p : Type}, string -> string -> (parameter p ctx) ->
  (params a ctx) -> params (p -> a) ctx
| Stop : params (ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ctx
| Seq : forall {p : Type}, string -> string -> (parameter p ctx) ->
  params
    ((list p) -> ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ctx.

Arguments Prefix {_}.
Arguments Param {_}.
Arguments Stop {_}.
Arguments Seq {_}.

Inductive options : forall (_ _ : Type), Type :=
| Argument : forall {a arg b : Type}, (args a arg) -> (a -> b) -> options b arg.

Record group := {
  name : string;
  title : string }.

Inductive command (arg : Type) : Type :=
| Command : forall {a b iarg : Type}, (params a iarg) -> (options b iarg) ->
  (b -> a) -> string -> (option group) -> (arg -> iarg) -> command arg.

Arguments Command {_}.

Definition trim (s : string) : string :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (Tezos_stdlib.TzString.split "010" % char None None s)
      (List.map Stdlib.String.trim)) (Stdlib.String.concat "
" % string).

Definition print_desc (ppf : Stdlib.Format.formatter) (doc : string) : unit :=
  match try with
  | (short, long) =>
    match long with
    | None =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) short
    | Some doc =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<full>" % string
                    CamlinternalFormatBasics.End_of_format) "<full>" % string))
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Force_newline
                (CamlinternalFormatBasics.String_literal "  " % string
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<hov 0>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<hov 0>" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_tag
                          CamlinternalFormatBasics.End_of_format))))))))
          "%s@{<full>@
  @[<hov 0>%a@]@}" % string) short
        Stdlib.Format.pp_print_text doc
    end
  end.

Definition print_label
  (ppf : Stdlib.Format.formatter) (function_parameter : label) : unit :=
  match function_parameter with
  | {| long := long; short := None |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "--%s" % string) long
  | {| long := long; short := Some short |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "-" % char
          (CamlinternalFormatBasics.Char
            (CamlinternalFormatBasics.String_literal " --" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)))) "-%c --%s" % string)
      short long
  end.

Definition print_options_detailed {A B : Type}
  : Stdlib.Format.formatter -> (args A B) -> unit :=
  let help_option {a : Type}
    (ppf : Stdlib.Format.formatter) (function_parameter : arg a ctx) : unit :=
    match function_parameter with
    | Arg {| doc := doc; label := label; placeholder := placeholder |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<opt>" % string
                  CamlinternalFormatBasics.End_of_format) "<opt>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " <" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal ">" % char
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      (CamlinternalFormatBasics.String_literal ": " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))))))))
          "@{<opt>%a <%s>@}: %a" % string) print_label label placeholder
        print_desc doc
    |
      DefArg {|
        doc := doc;
          label := label;
          placeholder := placeholder;
          default := default
          |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<opt>" % string
                  CamlinternalFormatBasics.End_of_format) "<opt>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " <" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal ">" % char
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      (CamlinternalFormatBasics.String_literal ": " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))))))))
          "@{<opt>%a <%s>@}: %a" % string) print_label label placeholder
        print_desc
        (String.append doc
          (String.append "
Defaults to `" % string
            (String.append default "`." % string)))
    | Switch {| label := label; doc := doc |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<opt>" % string
                  CamlinternalFormatBasics.End_of_format) "<opt>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_tag
                (CamlinternalFormatBasics.String_literal ": " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))))
          "@{<opt>%a@}: %a" % string) print_label label print_desc doc
    | Constant _ => tt
    end in
  let fix help {b : Type}
    (ppf : Stdlib.Format.formatter) (function_parameter : args b ctx) : unit :=
    match function_parameter with
    | NoArgs => tt
    | AddArg arg NoArgs =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) help_option arg
    | AddArg arg rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))) "%a@,%a" % string)
        help_option arg help rest
    end in
  help.

Definition has_args {a ctx : Type} (function_parameter : args a ctx) : bool :=
  match function_parameter with
  | NoArgs => false
  | AddArg _ _ => true
  end.

Definition print_options_brief {A B : Type}
  : Stdlib.Format.formatter -> (args A B) -> unit :=
  let help_option {a : Type}
    (ppf : Stdlib.Format.formatter) (function_parameter : arg a ctx) : unit :=
    match function_parameter with
    | DefArg {| label := label; placeholder := placeholder |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "[" % char
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<opt>" % string
                    CamlinternalFormatBasics.End_of_format) "<opt>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " <" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal ">" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_tag
                        (CamlinternalFormatBasics.Char_literal "]" % char
                          CamlinternalFormatBasics.End_of_format))))))))
          "[@{<opt>%a <%s>@}]" % string) print_label label placeholder
    | Arg {| label := label; placeholder := placeholder |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "[" % char
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<opt>" % string
                    CamlinternalFormatBasics.End_of_format) "<opt>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " <" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal ">" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_tag
                        (CamlinternalFormatBasics.Char_literal "]" % char
                          CamlinternalFormatBasics.End_of_format))))))))
          "[@{<opt>%a <%s>@}]" % string) print_label label placeholder
    | Switch {| label := label |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "[" % char
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<opt>" % string
                    CamlinternalFormatBasics.End_of_format) "<opt>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Char_literal "]" % char
                    CamlinternalFormatBasics.End_of_format)))))
          "[@{<opt>%a@}]" % string) print_label label
    | Constant _ => tt
    end in
  let fix help {b : Type}
    (ppf : Stdlib.Format.formatter) (function_parameter : args b ctx) : unit :=
    match function_parameter with
    | NoArgs => tt
    | AddArg arg NoArgs =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) help_option arg
    | AddArg arg rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))) "%a@ %a" % string)
        help_option arg help rest
    end in
  help.

Definition print_highlight
  (highlight_strings : list string) (formatter : Stdlib.Format.formatter)
  (str : string) : unit :=
  let fix print_string (function_parameter : list Re.Str.regexp) : unit :=
    match function_parameter with
    | [] =>
      Stdlib.Format.fprintf formatter
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) str
    | cons regex tl =>
      match Re.Str.full_split regex str with
      | [] | cons (Re.Str.Text _) [] => print_string tl
      | list =>
        Stdlib.List.iter
          (fun function_parameter =>
            match function_parameter with
            | Re.Str.Text text =>
              Stdlib.Format.fprintf formatter
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format) "%s" % string) text
            | Re.Str.Delim delimiter =>
              Stdlib.Format.fprintf formatter
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_tag
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<hilight>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<hilight>" % string))
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_tag
                        CamlinternalFormatBasics.End_of_format)))
                  "@{<hilight>%s@}" % string) delimiter
            end) list
      end
    end in
  print_string (List.map Re.Str.regexp_string highlight_strings).

Definition print_commandline {A B C D : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter : (list string) * (args A B) * (params C D)) : unit :=
  match function_parameter with
  | (highlights, options, args) =>
    let fix print {a ctx : Type}
      (ppf : Stdlib.Format.formatter) (function_parameter : params a ctx)
      : unit :=
      match function_parameter with
      | Stop =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          print_options_brief options
      | Seq n _ _ =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_tag
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<arg>" % string
                      CamlinternalFormatBasics.End_of_format) "<arg>" % string))
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.String_literal "...]" % string
                      CamlinternalFormatBasics.End_of_format)))))
            "[@{<arg>%s@}...]" % string) n
      | Seq n _ _ =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_tag
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<arg>" % string
                      CamlinternalFormatBasics.End_of_format) "<arg>" % string))
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.String_literal "...] " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))))
            "[@{<arg>%s@}...] %a" % string) n print_options_brief options
      | Prefix n Stop =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<kwd>" % string
                    CamlinternalFormatBasics.End_of_format) "<kwd>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  CamlinternalFormatBasics.End_of_format)))
            "@{<kwd>%a@}" % string) (print_highlight highlights) n
      | Prefix n next =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<kwd>" % string
                    CamlinternalFormatBasics.End_of_format) "<kwd>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))))
            "@{<kwd>%a@} %a" % string) (print_highlight highlights) n print next
      | Param n _ _ Stop =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<arg>" % string
                    CamlinternalFormatBasics.End_of_format) "<arg>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  CamlinternalFormatBasics.End_of_format)))
            "@{<arg>%s@}" % string) n
      | Param n _ _ next =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<arg>" % string
                    CamlinternalFormatBasics.End_of_format) "<arg>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))))
            "@{<arg>%s@} %a" % string) n print next
      end in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_tag
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<commandline>" % string
                CamlinternalFormatBasics.End_of_format) "<commandline>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_tag
              CamlinternalFormatBasics.End_of_format)))
        "@{<commandline>%a@}" % string) print args
  end.

Fixpoint print_params_detailed {a b ctx : Type}
  (spec : args b ctx) (ppf : Stdlib.Format.formatter)
  (function_parameter : params a ctx) : unit :=
  match function_parameter with
  | Stop => print_options_detailed ppf spec
  | Seq n desc _ =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_tag
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<arg>" % string
                CamlinternalFormatBasics.End_of_format) "<arg>" % string))
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_tag
              (CamlinternalFormatBasics.String_literal ": " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))))
        "@{<arg>%s@}: %a" % string) n print_desc (trim desc);
    match spec with
    | NoArgs => tt
    | _ =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "@,%a" % string)
        print_options_detailed spec
    end
  | Prefix _ next => print_params_detailed spec ppf next
  | Param n desc _ Stop =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_tag
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<arg>" % string
                CamlinternalFormatBasics.End_of_format) "<arg>" % string))
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_tag
              (CamlinternalFormatBasics.String_literal ": " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))))
        "@{<arg>%s@}: %a" % string) n print_desc (trim desc);
    match spec with
    | NoArgs => tt
    | _ =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "@,%a" % string)
        print_options_detailed spec
    end
  | Param n desc _ next =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_tag
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<arg>" % string
                CamlinternalFormatBasics.End_of_format) "<arg>" % string))
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_tag
              (CamlinternalFormatBasics.String_literal ": " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))))))
        "@{<arg>%s@}: %a@,%a" % string) n print_desc (trim desc)
      (print_params_detailed spec) next
  end.

Definition contains_params_args {C arg ctx : Type}
  (params : params arg ctx) (args : args C ctx) : bool :=
  let fix help (function_parameter : params arg ctx) : bool :=
    match function_parameter with
    | Stop => has_args args
    | Seq _ _ _ => true
    | Prefix _ next => help next
    | Param _ _ _ _ => true
    end in
  help params.

Definition print_command {ctx : Type}
  (op_star_o_p_t_star : option (Stdlib.Format.formatter -> unit -> unit))
  : (option (list string)) -> Stdlib.Format.formatter -> (command ctx) -> unit :=
  let prefix :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | tt => tt
            end
        end
    end in
  fun op_star_o_p_t_star =>
    let highlights :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun ppf =>
      fun function_parameter =>
        match function_parameter with
        |
          Command {|
            params := params;
              options := Argument {| spec := spec |};
              desc := desc
              |} =>
          if contains_params_args params spec then
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_tag
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<command>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<command>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_tag
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<short>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<short>" % string))
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_tag
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<commanddoc>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<commanddoc>" % string))
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_tag
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_tag
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_tag
                                        CamlinternalFormatBasics.End_of_format))))))))))))
                "@{<command>%a%a@{<short>@,@{<commanddoc>%a@,%a@}@}@}" % string)
              prefix tt print_commandline (highlights, spec, params) print_desc
              desc (print_params_detailed spec) params
          else
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_tag
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<command>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<command>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_tag
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<short>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<short>" % string))
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_tag
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<commanddoc>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<commanddoc>" % string))
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_tag
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_tag
                                    CamlinternalFormatBasics.End_of_format))))))))))
                "@{<command>%a%a@{<short>@,@{<commanddoc>%a@}@}@}" % string)
              prefix tt print_commandline (highlights, spec, params) print_desc
              desc
        end.

Inductive ex_command : Type :=
| Ex : forall {A : Type}, (command A) -> ex_command.

Definition group_commands (commands : list ex_command)
  : list (group * (list ex_command)) :=
  match
    Stdlib.List.fold_left
      (fun function_parameter =>
        match function_parameter with
        | (grouped, ungrouped) =>
          fun function_parameter =>
            match function_parameter with
            | (Ex (Command {| group := group |})) as command =>
              match group with
              | None => (grouped, (cons command ungrouped))
              | Some group =>
                match
                  Stdlib.List.find_opt
                    (fun function_parameter =>
                      match function_parameter with
                      | ({| name := name |}, _) => equiv_decb (name group) name
                      end) grouped with
                | None =>
                  ((cons (group, (Stdlib.ref (cons command []))) grouped),
                    ungrouped)
                | Some ({| title := title |}, r) =>
                  if nequiv_decb title (title group) then
                    OCaml.Stdlib.invalid_arg
                      "Clic.usage: duplicate group name" % string
                  else
                    tt;
                  Stdlib.op_colon_eq r (cons command (Stdlib.op_exclamation r));
                  (grouped, ungrouped)
                end
              end
            end
        end) ([], []) commands with
  | (grouped, ungrouped) =>
    List.map
      (fun function_parameter =>
        match function_parameter with
        | (g, c) => (g, (List.rev (Stdlib.op_exclamation c)))
        end)
      match ungrouped with
      | [] => grouped
      | l =>
        OCaml.Stdlib.app grouped
          (cons
            ({| name := "misc" % string;
              title := "Miscellaneous commands" % string |}, (Stdlib.ref l)) [])
      end
  end.

Definition print_group {A : Type}
  (print_command : Stdlib.Format.formatter -> A -> unit)
  (ppf : Stdlib.Format.formatter) (function_parameter : group * (list A))
  : unit :=
  match function_parameter with
  | ({| title := title |}, commands) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_tag
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<title>" % string
                CamlinternalFormatBasics.End_of_format) "<title>" % string))
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_tag
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_tag
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<list>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<list>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      CamlinternalFormatBasics.End_of_format)))))))
        "@{<title>%s@}@,@{<list>%a@}" % string) title
      (Stdlib.Format.pp_print_list None print_command) commands
  end.

Definition formatter_state :=
  Stdlib.Format.formatter_out_functions * Stdlib.Format.formatter_tag_functions
    * bool.

Inductive format : Type :=
| Plain : format
| Ansi : format
| Html : format.

Inductive verbosity : Type :=
| Terse : verbosity
| Short : verbosity
| Details : verbosity
| Full : verbosity.

Definition setup_formatter
  (ppf : Stdlib.Format.formatter) (format : format) (verbosity : verbosity)
  : Stdlib.Format.formatter_out_functions *
    Stdlib.Format.formatter_tag_functions * bool :=
  let skip := Stdlib.ref false in
  match
    ((Stdlib.Format.pp_get_formatter_out_functions ppf tt),
      (Stdlib.Format.pp_get_formatter_tag_functions ppf tt),
      (Stdlib.Format.pp_get_print_tags ppf tt)) with
  | (orig_out_functions, _, _) as orig_state =>
    Stdlib.Format.pp_print_flush ppf tt;
    Stdlib.Format.pp_set_formatter_out_functions ppf
      {|
        out_string :=
          fun s =>
            fun b =>
              fun a =>
                if equiv_decb s "" % string then
                  Stdlib.op_colon_eq skip true
                else
                  if equiv_decb s "ÿÿÿ" % string then
                    Stdlib.op_colon_eq skip false
                  else
                    if negb (Stdlib.op_exclamation skip) then
                      (out_string orig_out_functions) s b a
                    else
                      tt;
        out_flush :=
          fun function_parameter =>
            match function_parameter with
            | tt =>
              if negb (Stdlib.op_exclamation skip) then
                (out_flush orig_out_functions) tt
              else
                tt
            end;
        out_newline :=
          fun function_parameter =>
            match function_parameter with
            | tt =>
              if negb (Stdlib.op_exclamation skip) then
                (out_newline orig_out_functions) tt
              else
                tt
            end;
        out_spaces :=
          fun n =>
            if negb (Stdlib.op_exclamation skip) then
              (out_spaces orig_out_functions) n
            else
              tt; out_indent := out_indent orig_out_functions |};
    let levels := Stdlib.ref [] in
    let setup_level {A : Type}
      (function_parameter : A * (A -> verbosity -> bool)) : unit :=
      match function_parameter with
      | (level, op) =>
        if op level verbosity then
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Magic_size "@<0>" % string 0)
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)) "@<0>%s" % string)
            "ÿÿÿ" % string
        else
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Magic_size "@<0>" % string 0)
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)) "@<0>%s" % string)
            "" % string
      end in
    let push_level (level : verbosity * (verbosity -> verbosity -> bool))
      : unit :=
      Stdlib.op_colon_eq levels (cons level (Stdlib.op_exclamation levels));
      setup_level level in
    let pop_level (function_parameter : unit) : unit :=
      match function_parameter with
      | tt =>
        match Stdlib.op_exclamation levels with
        | cons _ (cons level rest) =>
          Stdlib.op_colon_eq levels (cons level rest);
          setup_level level
        | cons _ [] | [] =>
          Stdlib.Pervasives.failwith "Clic: unclosed verbosity tag" % string
        end
      end in
    push_level (Terse, OCaml.Stdlib.le);
    let push_level_tag (tag : string) : unit :=
      let push
        (op : verbosity -> verbosity -> bool) (function_parameter : string)
        : unit :=
        match function_parameter with
        | "full" % string => push_level (Full, op)
        | "details" % string => push_level (Details, op)
        | "short" % string => push_level (Short, op)
        | "terse" % string => push_level (Terse, op)
        | tag =>
          Stdlib.Pervasives.failwith
            (String.append "Clic: invalid semantic tag <" % string
              (String.append tag ">" % string))
        end in
      if
        andb (OCaml.Stdlib.gt (OCaml.String.length tag) 0)
          (equiv_decb (Stdlib.String.get tag 0) "=" % char) then
        push equiv_decb
          (Stdlib.String.sub tag 1 (Z.sub (OCaml.String.length tag) 1))
      else
        if
          andb (OCaml.Stdlib.gt (OCaml.String.length tag) 0)
            (equiv_decb (Stdlib.String.get tag 0) "-" % char) then
          push OCaml.Stdlib.gt
            (Stdlib.String.sub tag 1 (Z.sub (OCaml.String.length tag) 1))
        else
          push OCaml.Stdlib.le tag in
    let pop_level_tag (function_parameter : string) : unit :=
      match function_parameter with
      |
        "full" % string | "details" % string | "short" % string |
          "terse" % string | "-full" % string | "-details" % string |
          "-short" % string | "-terse" % string | "=full" % string |
          "=details" % string | "=short" % string | "=terse" % string =>
        pop_level tt
      | tag =>
        Stdlib.Pervasives.failwith
          (String.append "Clic: invalid semantic tag <" % string
            (String.append tag ">" % string))
      end in
    match format with
    | Ansi =>
      let color_num (function_parameter : variant) : option Z :=
        match function_parameter with
        | Auto => None
        | Black => Some 0
        | Red => Some 1
        | Green => Some 2
        | Yellow => Some 3
        | Blue => Some 4
        | Magenta => Some 5
        | Cyan => Some 6
        | White => Some 7
        end in
      let ansi_format
        (ppf : Stdlib.Format.formatter) (function_parameter :
        variant * variant * bool * bool) : unit :=
        match function_parameter with
        | (fg, bg, b, u) =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Magic_size "@<0>" % string 0)
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)) "@<0>%s" % string)
            "" % string;
          match
            OCaml.Stdlib.app
              match color_num fg with
              | Some n => cons (OCaml.Stdlib.string_of_int (Z.add 30 n)) []
              | None => []
              end
              (OCaml.Stdlib.app
                match color_num bg with
                | Some n => cons (OCaml.Stdlib.string_of_int (Z.add 40 n)) []
                | None => []
                end
                (OCaml.Stdlib.app
                  (if b then
                    cons "1" % string []
                  else
                    [])
                  (if u then
                    cons "4" % string []
                  else
                    []))) with
          | [] => tt
          | l =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Magic_size "@<0>" % string 0)
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format)) "@<0>%s" % string)
              (String.append "[" % string
                (String.append (Stdlib.String.concat ";" % string l)
                  "m" % string))
          end
        end in
      let ansi_stack := Stdlib.ref (cons (variant, variant, false, false) []) in
      let push_ansi_format
        (function_parameter : (option variant) * (option variant) * bool * bool)
        : unit :=
        match function_parameter with
        | (fg, bg, b, u) =>
          let format :=
            match Stdlib.op_exclamation ansi_stack with
            | cons (pfg, pbg, pb, pu) _ =>
              ((Tezos_stdlib.Option.unopt pfg fg),
                (Tezos_stdlib.Option.unopt pbg bg), (orb pb b), (orb pu u))
            | [] => false
            end in
          Stdlib.op_colon_eq ansi_stack
            (cons format (Stdlib.op_exclamation ansi_stack));
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Magic_size "@<0>" % string 0)
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)) "@<0>%a" % string)
            ansi_format format
        end in
      let pop_ansi_format (function_parameter : unit) : unit :=
        match function_parameter with
        | tt =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Magic_size "@<0>" % string 0)
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)) "@<0>%s" % string)
            "" % string;
          match Stdlib.op_exclamation ansi_stack with
          | cons _ (cons format rest) =>
            Stdlib.op_colon_eq ansi_stack (cons format rest);
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Magic_size "@<0>" % string 0)
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)) "@<0>%a" % string)
              ansi_format format
          | cons _ [] | [] =>
            Stdlib.Pervasives.failwith "Clic: unclosed ansi format" % string
          end
        end in
      Stdlib.Format.pp_set_formatter_tag_functions ppf
        {|
          mark_open_tag :=
            fun function_parameter =>
              match function_parameter with
              | _ => "" % string
              end;
          mark_close_tag :=
            fun function_parameter =>
              match function_parameter with
              | _ => "" % string
              end;
          print_open_tag :=
            fun function_parameter =>
              match function_parameter with
              | "title" % string => push_ansi_format (None, None, true, true)
              | "commandline" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<hov 4>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<hov 4>" % string))
                      CamlinternalFormatBasics.End_of_format)
                    "@[<hov 4>" % string)
              | "commanddoc" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "  " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 0>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 0>" % string))
                        CamlinternalFormatBasics.End_of_format))
                    "  @[<v 0>" % string)
              | "opt" % string =>
                push_ansi_format ((Some variant), None, false, false)
              | "arg" % string =>
                push_ansi_format ((Some variant), None, false, false);
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Char_literal "<" % char
                      CamlinternalFormatBasics.End_of_format) "<" % string)
              | "kwd" % string => push_ansi_format (None, None, false, true)
              | "error" % string =>
                push_ansi_format ((Some variant), None, true, true)
              | "warning" % string =>
                push_ansi_format ((Some variant), None, true, true)
              | "hilight" % string =>
                push_ansi_format ((Some variant), (Some variant), true, true)
              | "list" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "  " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 0>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 0>" % string))
                        CamlinternalFormatBasics.End_of_format))
                    "  @[<v 0>" % string)
              | "command" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string)
              | "document" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string)
              | other => push_level_tag other
              end;
          print_close_tag :=
            fun function_parameter =>
              match function_parameter with
              | "title" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Char_literal ":" % char
                      CamlinternalFormatBasics.End_of_format) ":" % string);
                pop_ansi_format tt
              | "commandline" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | "commanddoc" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | "opt" % string => pop_ansi_format tt
              | "arg" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Char_literal ">" % char
                      CamlinternalFormatBasics.End_of_format) ">" % string);
                pop_ansi_format tt
              | "kwd" % string => pop_ansi_format tt
              | "error" % string => pop_ansi_format tt
              | "warning" % string => pop_ansi_format tt
              | "hilight" % string => pop_ansi_format tt
              | "command" % string | "list" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | "document" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | other => pop_level_tag other
              end |};
      Stdlib.Format.pp_set_print_tags ppf true
    | Plain =>
      Stdlib.Format.pp_set_formatter_tag_functions ppf
        {|
          mark_open_tag :=
            fun function_parameter =>
              match function_parameter with
              | _ => "" % string
              end;
          mark_close_tag :=
            fun function_parameter =>
              match function_parameter with
              | _ => "" % string
              end;
          print_open_tag :=
            fun function_parameter =>
              match function_parameter with
              | "title" % string => tt
              | "commandline" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<hov 4>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<hov 4>" % string))
                      CamlinternalFormatBasics.End_of_format)
                    "@[<hov 4>" % string)
              | "commanddoc" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "  " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 0>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 0>" % string))
                        CamlinternalFormatBasics.End_of_format))
                    "  @[<v 0>" % string)
              | "opt" % string => tt
              | "arg" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Char_literal "<" % char
                      CamlinternalFormatBasics.End_of_format) "<" % string)
              | "kwd" % string => tt
              | "hilight" % string => tt
              | "error" % string => tt
              | "warning" % string => tt
              | "list" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "  " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 0>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 0>" % string))
                        CamlinternalFormatBasics.End_of_format))
                    "  @[<v 0>" % string)
              | "command" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string)
              | "document" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string)
              | other => push_level_tag other
              end;
          print_close_tag :=
            fun function_parameter =>
              match function_parameter with
              | "title" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Char_literal ":" % char
                      CamlinternalFormatBasics.End_of_format) ":" % string)
              | "commandline" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | "commanddoc" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | "opt" % string => tt
              | "arg" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Char_literal ">" % char
                      CamlinternalFormatBasics.End_of_format) ">" % string)
              | "kwd" % string => tt
              | "error" % string => tt
              | "warning" % string => tt
              | "hilight" % string => tt
              | "command" % string | "list" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | "document" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | other => pop_level_tag other
              end |};
      Stdlib.Format.pp_set_print_tags ppf true
    | Html =>
      Stdlib.Format.pp_set_formatter_tag_functions ppf
        {|
          mark_open_tag :=
            fun function_parameter =>
              match function_parameter with
              | _ => "" % string
              end;
          mark_close_tag :=
            fun function_parameter =>
              match function_parameter with
              | _ => "" % string
              end;
          print_open_tag :=
            fun function_parameter =>
              match function_parameter with
              | "title" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "h3" % string
                      CamlinternalFormatBasics.End_of_format) "h3" % string)
              | "commandline" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "div class='cmdline'" % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<h>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<h>" % string))
                        CamlinternalFormatBasics.End_of_format))
                    "div class='cmdline'@[<h>" % string)
              | "commanddoc" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "div class='cmddoc'" % string
                      CamlinternalFormatBasics.End_of_format)
                    "div class='cmddoc'" % string)
              | "opt" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "span class='opt'" % string
                      CamlinternalFormatBasics.End_of_format)
                    "span class='opt'" % string)
              | "arg" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "span class='arg'" % string
                      CamlinternalFormatBasics.End_of_format)
                    "span class='arg'" % string)
              | "kwd" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "span class='kwd'" % string
                      CamlinternalFormatBasics.End_of_format)
                    "span class='kwd'" % string)
              | "hilight" % string => tt
              | "error" % string => tt
              | "warning" % string => tt
              | "list" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "ul" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        CamlinternalFormatBasics.End_of_format))
                    "ul@
" % string)
              | "command" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "li" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        CamlinternalFormatBasics.End_of_format))
                    "li@
" % string)
              | "document" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "style.cmdline { font-family: monospace }.cmddoc { white-space: pre-wrap ; font-family: monospace; line-height: 170"
                          % string
                        (CamlinternalFormatBasics.Char_literal "%" % char
                          (CamlinternalFormatBasics.String_literal
                            "; margin: 0 0 20px 0 }.cmdline { background: #343131; padding: 2px 8px; border-radius:10px; color: white; margin: 5px; }.cmdline+.cmddoc { margin: -5px 5px 0 20px; padding: 5px }.opt,.arg { background: #343131; font-weight: bold;  padding: 2px 4px; border-radius:5px; }.kwd { font-weight: bold; } .opt { color:#CF0; background: #460; } .arg { color: #CEF; background: #369; }/style"
                              % string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Force_newline
                              CamlinternalFormatBasics.End_of_format)))))
                    "@[<v 0>style.cmdline { font-family: monospace }.cmddoc { white-space: pre-wrap ; font-family: monospace; line-height: 170%%; margin: 0 0 20px 0 }.cmdline { background: #343131; padding: 2px 8px; border-radius:10px; color: white; margin: 5px; }.cmdline+.cmddoc { margin: -5px 5px 0 20px; padding: 5px }.opt,.arg { background: #343131; font-weight: bold;  padding: 2px 4px; border-radius:5px; }.kwd { font-weight: bold; } .opt { color:#CF0; background: #460; } .arg { color: #CEF; background: #369; }/style@
"
                      % string)
              | other => push_level_tag other
              end;
          print_close_tag :=
            fun function_parameter =>
              match function_parameter with
              | "title" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "/h3" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        CamlinternalFormatBasics.End_of_format))
                    "/h3@
" % string)
              | "commandline" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.String_literal "/div" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          CamlinternalFormatBasics.End_of_format)))
                    "@]/div@
" % string)
              | "commanddoc" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "/div" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        CamlinternalFormatBasics.End_of_format))
                    "/div@
" % string)
              | "opt" % string | "arg" % string | "kwd" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "/span" % string
                      CamlinternalFormatBasics.End_of_format) "/span" % string)
              | "error" % string | "warning" % string | "hilight" % string => tt
              | "list" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "/ul" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        CamlinternalFormatBasics.End_of_format))
                    "/ul@
" % string)
              | "command" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "/li" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        CamlinternalFormatBasics.End_of_format))
                    "/li@
" % string)
              | "document" % string =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format) "@]" % string)
              | other => pop_level_tag other
              end |};
      let orig_out_functions :=
        Stdlib.Format.pp_get_formatter_out_functions ppf tt in
      Stdlib.Format.pp_set_formatter_out_functions ppf record;
      Stdlib.Format.pp_set_print_tags ppf true
    end;
    orig_state
  end.

Definition restore_formatter
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Stdlib.Format.formatter_out_functions *
      Stdlib.Format.formatter_tag_functions * bool) : unit :=
  match function_parameter with
  | (out_functions, tag_functions, tags) =>
    Stdlib.Format.pp_print_flush ppf tt;
    Stdlib.Format.pp_set_formatter_out_functions ppf out_functions;
    Stdlib.Format.pp_set_formatter_tag_functions ppf tag_functions;
    Stdlib.Format.pp_set_print_tags ppf tags
  end.

Definition usage_internal {A B : Type}
  (ppf : Stdlib.Format.formatter) (executable_name : string)
  (global_options : options A B) (op_star_o_p_t_star : option (list string))
  : (list ex_command) -> unit :=
  let highlights :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun commands =>
    let by_group := group_commands commands in
    match global_options with
    | Argument {| spec := spec |} =>
      let print_groups :=
        Stdlib.Format.pp_print_list
          (Some
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          CamlinternalFormatBasics.End_of_format))
                      "@,@," % string)
                end))
          (print_group
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | Ex command => print_command None (Some highlights) ppf command
                end)) in
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<document>" % string
                  CamlinternalFormatBasics.End_of_format) "<document>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<title>" % string
                    CamlinternalFormatBasics.End_of_format) "<title>" % string))
              (CamlinternalFormatBasics.String_literal "Usage" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_tag
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<list>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<list>" % string))
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_tag
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<command>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<command>" % string))
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_tag
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<commandline>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<commandline>" % string))
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              " [" % string
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_tag
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<opt>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<opt>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "global options" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_tag
                                    (CamlinternalFormatBasics.String_literal
                                      "] " % string
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_tag
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<kwd>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<kwd>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "command" % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_tag
                                            (CamlinternalFormatBasics.String_literal
                                              " [" % string
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_tag
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "<opt>" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "<opt>" % string))
                                                (CamlinternalFormatBasics.String_literal
                                                  "command options" % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_tag
                                                    (CamlinternalFormatBasics.Char_literal
                                                      "]" % char
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_tag
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Close_tag
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            (CamlinternalFormatBasics.Break
                                                              "@," % string 0 0)
                                                            (CamlinternalFormatBasics.Formatting_gen
                                                              (CamlinternalFormatBasics.Open_tag
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "<command>"
                                                                      % string
                                                                    CamlinternalFormatBasics.End_of_format)
                                                                  "<command>" %
                                                                    string))
                                                              (CamlinternalFormatBasics.Formatting_gen
                                                                (CamlinternalFormatBasics.Open_tag
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "<commandline>"
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "<commandline>"
                                                                      % string))
                                                                (CamlinternalFormatBasics.String
                                                                  CamlinternalFormatBasics.No_padding
                                                                  (CamlinternalFormatBasics.Char_literal
                                                                    " " % char
                                                                    (CamlinternalFormatBasics.Formatting_gen
                                                                      (CamlinternalFormatBasics.Open_tag
                                                                        (CamlinternalFormatBasics.Format
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "<opt>"
                                                                              %
                                                                              string
                                                                            CamlinternalFormatBasics.End_of_format)
                                                                          "<opt>"
                                                                            %
                                                                            string))
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "--help"
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          CamlinternalFormatBasics.Close_tag
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            " (for global options)"
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                              CamlinternalFormatBasics.Close_tag
                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                CamlinternalFormatBasics.Close_tag
                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                  (CamlinternalFormatBasics.Break
                                                                                    "@,"
                                                                                      %
                                                                                      string
                                                                                    0
                                                                                    0)
                                                                                  (CamlinternalFormatBasics.Formatting_gen
                                                                                    (CamlinternalFormatBasics.Open_tag
                                                                                      (CamlinternalFormatBasics.Format
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          "<command>"
                                                                                            %
                                                                                            string
                                                                                          CamlinternalFormatBasics.End_of_format)
                                                                                        "<command>"
                                                                                          %
                                                                                          string))
                                                                                    (CamlinternalFormatBasics.Formatting_gen
                                                                                      (CamlinternalFormatBasics.Open_tag
                                                                                        (CamlinternalFormatBasics.Format
                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                            "<commandline>"
                                                                                              %
                                                                                              string
                                                                                            CamlinternalFormatBasics.End_of_format)
                                                                                          "<commandline>"
                                                                                            %
                                                                                            string))
                                                                                      (CamlinternalFormatBasics.String
                                                                                        CamlinternalFormatBasics.No_padding
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          " ["
                                                                                            %
                                                                                            string
                                                                                          (CamlinternalFormatBasics.Formatting_gen
                                                                                            (CamlinternalFormatBasics.Open_tag
                                                                                              (CamlinternalFormatBasics.Format
                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                  "<opt>"
                                                                                                    %
                                                                                                    string
                                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                                "<opt>"
                                                                                                  %
                                                                                                  string))
                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                              "global options"
                                                                                                %
                                                                                                string
                                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                                CamlinternalFormatBasics.Close_tag
                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                  "] "
                                                                                                    %
                                                                                                    string
                                                                                                  (CamlinternalFormatBasics.Formatting_gen
                                                                                                    (CamlinternalFormatBasics.Open_tag
                                                                                                      (CamlinternalFormatBasics.Format
                                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                                          "<kwd>"
                                                                                                            %
                                                                                                            string
                                                                                                          CamlinternalFormatBasics.End_of_format)
                                                                                                        "<kwd>"
                                                                                                          %
                                                                                                          string))
                                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                                      "command"
                                                                                                        %
                                                                                                        string
                                                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                                                        CamlinternalFormatBasics.Close_tag
                                                                                                        (CamlinternalFormatBasics.Char_literal
                                                                                                          " "
                                                                                                            %
                                                                                                            char
                                                                                                          (CamlinternalFormatBasics.Formatting_gen
                                                                                                            (CamlinternalFormatBasics.Open_tag
                                                                                                              (CamlinternalFormatBasics.Format
                                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                                  "<opt>"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                                                "<opt>"
                                                                                                                  %
                                                                                                                  string))
                                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                                              "--help"
                                                                                                                %
                                                                                                                string
                                                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                                                CamlinternalFormatBasics.Close_tag
                                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                                  " (for command options)"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                                    CamlinternalFormatBasics.Close_tag
                                                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                                                      CamlinternalFormatBasics.Close_tag
                                                                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                                                                        CamlinternalFormatBasics.Close_tag
                                                                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                                                                          (CamlinternalFormatBasics.Break
                                                                                                                            "@,"
                                                                                                                              %
                                                                                                                              string
                                                                                                                            0
                                                                                                                            0)
                                                                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                                                                            (CamlinternalFormatBasics.Break
                                                                                                                              "@,"
                                                                                                                                %
                                                                                                                                string
                                                                                                                              0
                                                                                                                              0)
                                                                                                                            (CamlinternalFormatBasics.Formatting_gen
                                                                                                                              (CamlinternalFormatBasics.Open_tag
                                                                                                                                (CamlinternalFormatBasics.Format
                                                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                                                    "<title>"
                                                                                                                                      %
                                                                                                                                      string
                                                                                                                                    CamlinternalFormatBasics.End_of_format)
                                                                                                                                  "<title>"
                                                                                                                                    %
                                                                                                                                    string))
                                                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                                                "To browse the documentation"
                                                                                                                                  %
                                                                                                                                  string
                                                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                  CamlinternalFormatBasics.Close_tag
                                                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                    (CamlinternalFormatBasics.Break
                                                                                                                                      "@,"
                                                                                                                                        %
                                                                                                                                        string
                                                                                                                                      0
                                                                                                                                      0)
                                                                                                                                    (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                      (CamlinternalFormatBasics.Open_tag
                                                                                                                                        (CamlinternalFormatBasics.Format
                                                                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                                                                            "<list>"
                                                                                                                                              %
                                                                                                                                              string
                                                                                                                                            CamlinternalFormatBasics.End_of_format)
                                                                                                                                          "<list>"
                                                                                                                                            %
                                                                                                                                            string))
                                                                                                                                      (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                        (CamlinternalFormatBasics.Open_tag
                                                                                                                                          (CamlinternalFormatBasics.Format
                                                                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                                                                              "<command>"
                                                                                                                                                %
                                                                                                                                                string
                                                                                                                                              CamlinternalFormatBasics.End_of_format)
                                                                                                                                            "<command>"
                                                                                                                                              %
                                                                                                                                              string))
                                                                                                                                        (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                          (CamlinternalFormatBasics.Open_tag
                                                                                                                                            (CamlinternalFormatBasics.Format
                                                                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                                                                "<commandline>"
                                                                                                                                                  %
                                                                                                                                                  string
                                                                                                                                                CamlinternalFormatBasics.End_of_format)
                                                                                                                                              "<commandline>"
                                                                                                                                                %
                                                                                                                                                string))
                                                                                                                                          (CamlinternalFormatBasics.String
                                                                                                                                            CamlinternalFormatBasics.No_padding
                                                                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                                                                              " ["
                                                                                                                                                %
                                                                                                                                                string
                                                                                                                                              (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                (CamlinternalFormatBasics.Open_tag
                                                                                                                                                  (CamlinternalFormatBasics.Format
                                                                                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                                                                                      "<opt>"
                                                                                                                                                        %
                                                                                                                                                        string
                                                                                                                                                      CamlinternalFormatBasics.End_of_format)
                                                                                                                                                    "<opt>"
                                                                                                                                                      %
                                                                                                                                                      string))
                                                                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                                                                  "global options"
                                                                                                                                                    %
                                                                                                                                                    string
                                                                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                    CamlinternalFormatBasics.Close_tag
                                                                                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                                                                                      "] "
                                                                                                                                                        %
                                                                                                                                                        string
                                                                                                                                                      (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                        (CamlinternalFormatBasics.Open_tag
                                                                                                                                                          (CamlinternalFormatBasics.Format
                                                                                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                                                                                              "<kwd>"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              CamlinternalFormatBasics.End_of_format)
                                                                                                                                                            "<kwd>"
                                                                                                                                                              %
                                                                                                                                                              string))
                                                                                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                                                                                          "man"
                                                                                                                                                            %
                                                                                                                                                            string
                                                                                                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                            CamlinternalFormatBasics.Close_tag
                                                                                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                                                                                              " (for a list of commands)"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                CamlinternalFormatBasics.Close_tag
                                                                                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                  CamlinternalFormatBasics.Close_tag
                                                                                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                    (CamlinternalFormatBasics.Break
                                                                                                                                                                      "@,"
                                                                                                                                                                        %
                                                                                                                                                                        string
                                                                                                                                                                      0
                                                                                                                                                                      0)
                                                                                                                                                                    (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                                      (CamlinternalFormatBasics.Open_tag
                                                                                                                                                                        (CamlinternalFormatBasics.Format
                                                                                                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                                                                                                            "<command>"
                                                                                                                                                                              %
                                                                                                                                                                              string
                                                                                                                                                                            CamlinternalFormatBasics.End_of_format)
                                                                                                                                                                          "<command>"
                                                                                                                                                                            %
                                                                                                                                                                            string))
                                                                                                                                                                      (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                                        (CamlinternalFormatBasics.Open_tag
                                                                                                                                                                          (CamlinternalFormatBasics.Format
                                                                                                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                                                                                                              "<commandline>"
                                                                                                                                                                                %
                                                                                                                                                                                string
                                                                                                                                                                              CamlinternalFormatBasics.End_of_format)
                                                                                                                                                                            "<commandline>"
                                                                                                                                                                              %
                                                                                                                                                                              string))
                                                                                                                                                                        (CamlinternalFormatBasics.String
                                                                                                                                                                          CamlinternalFormatBasics.No_padding
                                                                                                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                                                                                                            " ["
                                                                                                                                                                              %
                                                                                                                                                                              string
                                                                                                                                                                            (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                                              (CamlinternalFormatBasics.Open_tag
                                                                                                                                                                                (CamlinternalFormatBasics.Format
                                                                                                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                    "<opt>"
                                                                                                                                                                                      %
                                                                                                                                                                                      string
                                                                                                                                                                                    CamlinternalFormatBasics.End_of_format)
                                                                                                                                                                                  "<opt>"
                                                                                                                                                                                    %
                                                                                                                                                                                    string))
                                                                                                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                "global options"
                                                                                                                                                                                  %
                                                                                                                                                                                  string
                                                                                                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                  CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                    "] "
                                                                                                                                                                                      %
                                                                                                                                                                                      string
                                                                                                                                                                                    (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                                                      (CamlinternalFormatBasics.Open_tag
                                                                                                                                                                                        (CamlinternalFormatBasics.Format
                                                                                                                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                            "<kwd>"
                                                                                                                                                                                              %
                                                                                                                                                                                              string
                                                                                                                                                                                            CamlinternalFormatBasics.End_of_format)
                                                                                                                                                                                          "<kwd>"
                                                                                                                                                                                            %
                                                                                                                                                                                            string))
                                                                                                                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                        "man"
                                                                                                                                                                                          %
                                                                                                                                                                                          string
                                                                                                                                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                          CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                          (CamlinternalFormatBasics.Char_literal
                                                                                                                                                                                            " "
                                                                                                                                                                                              %
                                                                                                                                                                                              char
                                                                                                                                                                                            (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                                                              (CamlinternalFormatBasics.Open_tag
                                                                                                                                                                                                (CamlinternalFormatBasics.Format
                                                                                                                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                                    "<opt>"
                                                                                                                                                                                                      %
                                                                                                                                                                                                      string
                                                                                                                                                                                                    CamlinternalFormatBasics.End_of_format)
                                                                                                                                                                                                  "<opt>"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string))
                                                                                                                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                                "-v 3"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  string
                                                                                                                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                  CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                                    " (for the full manual)"
                                                                                                                                                                                                      %
                                                                                                                                                                                                      string
                                                                                                                                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                      CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                        CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                          CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                            (CamlinternalFormatBasics.Break
                                                                                                                                                                                                              "@,"
                                                                                                                                                                                                                %
                                                                                                                                                                                                                string
                                                                                                                                                                                                              0
                                                                                                                                                                                                              0)
                                                                                                                                                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                              (CamlinternalFormatBasics.Break
                                                                                                                                                                                                                "@,"
                                                                                                                                                                                                                  %
                                                                                                                                                                                                                  string
                                                                                                                                                                                                                0
                                                                                                                                                                                                                0)
                                                                                                                                                                                                              (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                                                                                (CamlinternalFormatBasics.Open_tag
                                                                                                                                                                                                                  (CamlinternalFormatBasics.Format
                                                                                                                                                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                                                      "<title>"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string
                                                                                                                                                                                                                      CamlinternalFormatBasics.End_of_format)
                                                                                                                                                                                                                    "<title>"
                                                                                                                                                                                                                      %
                                                                                                                                                                                                                      string))
                                                                                                                                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                                                  "Global options (must come before the command)"
                                                                                                                                                                                                                    %
                                                                                                                                                                                                                    string
                                                                                                                                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                                    CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                                      (CamlinternalFormatBasics.Break
                                                                                                                                                                                                                        "@,"
                                                                                                                                                                                                                          %
                                                                                                                                                                                                                          string
                                                                                                                                                                                                                        0
                                                                                                                                                                                                                        0)
                                                                                                                                                                                                                      (CamlinternalFormatBasics.Formatting_gen
                                                                                                                                                                                                                        (CamlinternalFormatBasics.Open_tag
                                                                                                                                                                                                                          (CamlinternalFormatBasics.Format
                                                                                                                                                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                                                                                                                                                              "<commanddoc>"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string
                                                                                                                                                                                                                              CamlinternalFormatBasics.End_of_format)
                                                                                                                                                                                                                            "<commanddoc>"
                                                                                                                                                                                                                              %
                                                                                                                                                                                                                              string))
                                                                                                                                                                                                                        (CamlinternalFormatBasics.Alpha
                                                                                                                                                                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                                            CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                                                            (CamlinternalFormatBasics.Alpha
                                                                                                                                                                                                                              (CamlinternalFormatBasics.Alpha
                                                                                                                                                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                                                  CamlinternalFormatBasics.Close_tag
                                                                                                                                                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                                                                                                                                                    CamlinternalFormatBasics.Flush_newline
                                                                                                                                                                                                                                    CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
          "@{<document>@{<title>Usage@}@,@{<list>@{<command>@{<commandline>%s [@{<opt>global options@}] @{<kwd>command@} [@{<opt>command options@}]@}@}@,@{<command>@{<commandline>%s @{<opt>--help@} (for global options)@}@}@,@{<command>@{<commandline>%s [@{<opt>global options@}] @{<kwd>command@} @{<opt>--help@} (for command options)@}@}@}@,@,@{<title>To browse the documentation@}@,@{<list>@{<command>@{<commandline>%s [@{<opt>global options@}] @{<kwd>man@} (for a list of commands)@}@}@,@{<command>@{<commandline>%s [@{<opt>global options@}] @{<kwd>man@} @{<opt>-v 3@} (for the full manual)@}@}@}@,@,@{<title>Global options (must come before the command)@}@,@{<commanddoc>%a@}%a%a@}@."
            % string) executable_name executable_name executable_name
        executable_name executable_name print_options_detailed spec
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              if nequiv_decb by_group [] then
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        CamlinternalFormatBasics.End_of_format)) "@,@," % string)
              else
                tt
            end) tt print_groups by_group
    end.

Definition constant {A B : Type} (c : A) : arg A B := Constant c.

Definition arg {A B : Type}
  (doc : string) (short : option ascii) (long : string) (placeholder : string)
  (kind : parameter A B) : arg (option A) B :=
  Arg
    {| doc := doc; label := {| long := long; short := short |};
      placeholder := placeholder; kind := kind |}.

Definition default_arg {A B : Type}
  (doc : string) (short : option ascii) (long : string) (placeholder : string)
  (default : string) (kind : parameter A B) : arg A B :=
  DefArg
    {| doc := doc; label := {| long := long; short := short |};
      placeholder := placeholder; kind := kind; default := default |}.

Definition switch {A : Type}
  (doc : string) (short : option ascii) (long : string)
  (function_parameter : unit) : arg bool A :=
  match function_parameter with
  | tt => Switch {| label := {| long := long; short := short |}; doc := doc |}
  end.

Definition parse_arg {A a ctx : Type}
  (command : option (command A)) (spec : arg a ctx)
  (args_dict : Tezos_stdlib.TzString.Map.t (list string)) (ctx : ctx)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult a) :=
  match spec with
  |
    Arg {|
      label := {| long := long; short := _ |};
        kind := {| converter := converter |}
        |} =>
    match Tezos_stdlib.TzString.Map.find_opt long args_dict with
    | None | Some [] => Tezos_error_monad.Error_monad.return_none
    | Some (cons s []) =>
      Tezos_error_monad.Error_monad.op_gt_gt_pipe_question
        (Tezos_error_monad.Error_monad.trace
          (Bad_option_argument (String.append "--" % string long) command)
          (converter ctx s)) (fun x => Some x)
    | Some (cons _ _) =>
      Tezos_error_monad.Error_monad.fail
        (Multiple_occurences (String.append "--" % string long) command)
    end
  |
    DefArg {|
      label := {| long := long; short := _ |};
        kind := {| converter := converter |};
        default := default
        |} =>
    Tezos_error_monad.Error_monad.op_gt_gt_eq (converter ctx default)
      (fun default =>
        Tezos_error_monad.Error_monad.op_gt_gt_eq_question
          match default with
          | inl x => Tezos_error_monad.Error_monad._return x
          | inr _ =>
            OCaml.Stdlib.invalid_arg
              (Stdlib.Format.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Value provided as default for '" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        "' could not be parsed by converter function." % string
                        CamlinternalFormatBasics.End_of_format)))
                  "Value provided as default for '%s' could not be parsed by converter function."
                    % string) long)
          end
          (fun default =>
            match Tezos_stdlib.TzString.Map.find_opt long args_dict with
            | None | Some [] => Tezos_error_monad.Error_monad._return default
            | Some (cons s []) =>
              Tezos_error_monad.Error_monad.trace
                (Bad_option_argument long command) (converter ctx s)
            | Some (cons _ _) =>
              Tezos_error_monad.Error_monad.fail
                (Multiple_occurences long command)
            end))
  | Switch {| label := {| long := long; short := _ |} |} =>
    match Tezos_stdlib.TzString.Map.find_opt long args_dict with
    | None | Some [] => Tezos_error_monad.Error_monad.return_false
    | Some (cons _ []) => Tezos_error_monad.Error_monad.return_true
    | Some (cons _ _) =>
      Tezos_error_monad.Error_monad.fail (Multiple_occurences long command)
    end
  | Constant c => Tezos_error_monad.Error_monad._return c
  end.

Fixpoint parse_args {A a ctx : Type}
  (command : option (command A)) (spec : args a ctx)
  (args_dict : Tezos_stdlib.TzString.Map.t (list string)) (ctx : ctx)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult a) :=
  match spec with
  | NoArgs => Tezos_error_monad.Error_monad.return_unit
  | AddArg arg rest =>
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
      (parse_arg command arg args_dict ctx)
      (fun arg =>
        Tezos_error_monad.Error_monad.op_gt_gt_pipe_question
          (parse_args command rest args_dict ctx) (fun rest => (arg, rest)))
  end.

Definition empty_args_dict {A : Type} : Tezos_stdlib.TzString.Map.t A :=
  Tezos_stdlib.TzString.Map.empty.

Fixpoint make_arities_dict {a b : Type}
  (args : args a b) (acc : Tezos_stdlib.TzString.Map.t (Z * string))
  : Tezos_stdlib.TzString.Map.t (Z * string) :=
  match args with
  | NoArgs => acc
  | AddArg arg rest =>
    let recur (function_parameter : label)
      : Z -> Tezos_stdlib.TzString.Map.t (Z * string) :=
      match function_parameter with
      | {| long := long; short := short |} =>
        fun num =>
          OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply
                match short with
                | None => acc
                | Some c =>
                  Tezos_stdlib.TzString.Map.add
                    (String.append "-" % string (Stdlib.String.make 1 c))
                    (num, long) acc
                end
                (Tezos_stdlib.TzString.Map.add (String.append "-" % string long)
                  (num, long)))
              (Tezos_stdlib.TzString.Map.add (String.append "--" % string long)
                (num, long))) (make_arities_dict rest)
      end in
    match arg with
    | Arg {| label := label |} => recur label 1
    | DefArg {| label := label |} => recur label 1
    | Switch {| label := label |} => recur label 0
    | Constant _c => make_arities_dict rest acc
    end
  end.

Definition check_help_flag {A : Type}
  (command : option (command A)) (function_parameter : list string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  match function_parameter with
  | cons ("-h" % string | "--help" % string) _ =>
    Tezos_error_monad.Error_monad.fail (Help command)
  | _ => Tezos_error_monad.Error_monad.return_unit
  end.

Definition add_occurrence {A : Type}
  (long : Tezos_stdlib.TzString.Map.key) (value : A)
  (acc : Tezos_stdlib.TzString.Map.t (list A))
  : Tezos_stdlib.TzString.Map.t (list A) :=
  match Tezos_stdlib.TzString.Map.find_opt long acc with
  | Some v => Tezos_stdlib.TzString.Map.add long v acc
  | None => Tezos_stdlib.TzString.Map.add long (cons value []) acc
  end.

Definition make_args_dict_consume {A B C : Type}
  (command : option (command A)) (spec : args B C) (args : list string)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Tezos_stdlib.TzString.Map.t (list string)) * (list string))) :=
  let fix make_args_dict
    (completing : bool) (arities :
    Tezos_stdlib.TzString.Map.t (Z * Tezos_stdlib.TzString.Map.key)) (acc :
    Tezos_stdlib.TzString.Map.t (list string)) (args : list string)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        ((Tezos_stdlib.TzString.Map.t (list string)) * (list string))) :=
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
      (check_help_flag command args)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          match args with
          | [] => Tezos_error_monad.Error_monad._return (acc, [])
          | cons arg tl =>
            if
              andb (OCaml.Stdlib.gt (OCaml.String.length arg) 0)
                (equiv_decb (Stdlib.String.get arg 0) "-" % char) then
              if Tezos_stdlib.TzString.Map.mem arg arities then
                match Tezos_stdlib.TzString.Map.find arg arities with
                | (arity, long) =>
                  Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                    (check_help_flag command tl)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        match (arity, tl) with
                        | (0, tl') =>
                          make_args_dict completing arities
                            (add_occurrence long "" % string acc) tl'
                        | (1, cons value tl') =>
                          make_args_dict completing arities
                            (add_occurrence long value acc) tl'
                        | (1, []) =>
                          Tezos_error_monad.Error_monad.fail
                            (Option_expected_argument arg None)
                        | (_, _) =>
                          Stdlib.raise
                            (OCaml.Failure
                              "cli_entries: Arguments with arity not equal to 1 or 0 not supported"
                                % string)
                        end
                      end)
                end
              else
                Tezos_error_monad.Error_monad.fail (Unknown_option arg None)
            else
              Tezos_error_monad.Error_monad._return (acc, args)
          end
        end) in
  make_args_dict false (make_arities_dict spec Tezos_stdlib.TzString.Map.empty)
    Tezos_stdlib.TzString.Map.empty args.

Definition make_args_dict_filter {A B C : Type}
  (command : option (command A)) (spec : args B C) (args : list string)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Tezos_stdlib.TzString.Map.t (list string)) * (list string))) :=
  let fix make_args_dict
    (arities : Tezos_stdlib.TzString.Map.t (Z * Tezos_stdlib.TzString.Map.key))
    (function_parameter :
    (Tezos_stdlib.TzString.Map.t (list string)) * (list string))
    : (list string) ->
      Lwt.t
        (Tezos_error_monad.Error_monad.tzresult
          ((Tezos_stdlib.TzString.Map.t (list string)) * (list string))) :=
    match function_parameter with
    | (dict, other_args) =>
      fun args =>
        Tezos_error_monad.Error_monad.op_gt_gt_eq_question
          (check_help_flag command args)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              match args with
              | [] => Tezos_error_monad.Error_monad._return (dict, other_args)
              | cons arg tl =>
                if Tezos_stdlib.TzString.Map.mem arg arities then
                  match Tezos_stdlib.TzString.Map.find arg arities with
                  | (arity, long) =>
                    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                      (check_help_flag command tl)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          match (arity, tl) with
                          | (0, tl) =>
                            make_args_dict arities
                              ((add_occurrence long "" % string dict),
                                other_args) tl
                          | (1, cons value tl') =>
                            make_args_dict arities
                              ((add_occurrence long value dict), other_args) tl'
                          | (1, []) =>
                            Tezos_error_monad.Error_monad.fail
                              (Option_expected_argument arg command)
                          | (_, _) =>
                            Stdlib.raise
                              (OCaml.Failure
                                "cli_entries: Arguments with arity not equal to 1 or 0 not supported"
                                  % string)
                          end
                        end)
                  end
                else
                  make_args_dict arities (dict, (cons arg other_args)) tl
              end
            end)
    end in
  Tezos_error_monad.Error_monad.op_gt_gt_pipe_question
    (make_args_dict (make_arities_dict spec Tezos_stdlib.TzString.Map.empty)
      (Tezos_stdlib.TzString.Map.empty, []) args)
    (fun function_parameter =>
      match function_parameter with
      | (dict, remaining) => (dict, (List.rev remaining))
      end).

Definition op_gt_gt {A B C : Type} (arg1 : arg A B) (arg2 : args C B)
  : args (A * C) B := AddArg arg1 arg2.

Definition args1 {A B : Type} (spec : arg A B) : options A B :=
  Argument
    {| spec := op_gt_gt spec NoArgs;
      converter :=
        fun function_parameter =>
          match function_parameter with
          | (arg, tt) => arg
          end |}.

Definition args2 {A B C : Type} (spec1 : arg A B) (spec2 : arg C B)
  : options (A * C) B :=
  Argument
    {| spec := op_gt_gt spec1 (op_gt_gt spec2 NoArgs);
      converter :=
        fun function_parameter =>
          match function_parameter with
          | (arg1, (arg2, tt)) => (arg1, arg2)
          end |}.

Definition args3 {A B C D : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B)
  : options (A * C * D) B :=
  Argument
    {| spec := op_gt_gt spec1 (op_gt_gt spec2 (op_gt_gt spec3 NoArgs));
      converter :=
        fun function_parameter =>
          match function_parameter with
          | (arg1, (arg2, (arg3, tt))) => (arg1, arg2, arg3)
          end |}.

Definition args4 {A B C D E : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  : options (A * C * D * E) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1 (op_gt_gt spec2 (op_gt_gt spec3 (op_gt_gt spec4 NoArgs)));
      converter :=
        fun function_parameter =>
          match function_parameter with
          | (arg1, (arg2, (arg3, (arg4, tt)))) => (arg1, arg2, arg3, arg4)
          end |}.

Definition args5 {A B C D E F : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) : options (A * C * D * E * F) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3 (op_gt_gt spec4 (op_gt_gt spec5 NoArgs))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          | (arg1, (arg2, (arg3, (arg4, (arg5, tt))))) =>
            (arg1, arg2, arg3, arg4, arg5)
          end |}.

Definition args6 {A B C D E F G : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) : options (A * C * D * E * F * G) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4 (op_gt_gt spec5 (op_gt_gt spec6 NoArgs)))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          | (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, tt)))))) =>
            (arg1, arg2, arg3, arg4, arg5, spec6)
          end |}.

Definition args7 {A B C D E F G H : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B)
  : options (A * C * D * E * F * G * H) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5 (op_gt_gt spec6 (op_gt_gt spec7 NoArgs))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          | (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, tt))))))) =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7)
          end |}.

Definition args8 {A B C D E F G H I : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  : options (A * C * D * E * F * G * H * I) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6 (op_gt_gt spec7 (op_gt_gt spec8 NoArgs)))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, tt))))))))
            => (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8)
          end |}.

Definition args9 {A B C D E F G H I J : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) : options (A * C * D * E * F * G * H * I * J) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7 (op_gt_gt spec8 (op_gt_gt spec9 NoArgs))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, tt)))))))))
            => (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9)
          end |}.

Definition args10 {A B C D E F G H I J K : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) (spec10 : arg K B)
  : options (A * C * D * E * F * G * H * I * J * K) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7
                      (op_gt_gt spec8 (op_gt_gt spec9 (op_gt_gt spec10 NoArgs)))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3,
                  (arg4,
                    (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, tt))))))))))
            =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10)
          end |}.

Definition args11 {A B C D E F G H I J K L : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) (spec10 : arg K B) (spec11 : arg L B)
  : options (A * C * D * E * F * G * H * I * J * K * L) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7
                      (op_gt_gt spec8
                        (op_gt_gt spec9
                          (op_gt_gt spec10 (op_gt_gt spec11 NoArgs))))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3,
                  (arg4,
                    (arg5,
                      (spec6, (spec7, (spec8, (spec9, (spec10, (spec11, tt)))))))))))
            =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10,
              spec11)
          end |}.

Definition args12 {A B C D E F G H I J K L M : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) (spec10 : arg K B) (spec11 : arg L B) (spec12 : arg M B)
  : options (A * C * D * E * F * G * H * I * J * K * L * M) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7
                      (op_gt_gt spec8
                        (op_gt_gt spec9
                          (op_gt_gt spec10
                            (op_gt_gt spec11 (op_gt_gt spec12 NoArgs)))))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3,
                  (arg4,
                    (arg5,
                      (spec6,
                        (spec7,
                          (spec8, (spec9, (spec10, (spec11, (spec12, tt))))))))))))
            =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10,
              spec11, spec12)
          end |}.

Definition args13 {A B C D E F G H I J K L M N : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) (spec10 : arg K B) (spec11 : arg L B) (spec12 : arg M B)
  (spec13 : arg N B)
  : options (A * C * D * E * F * G * H * I * J * K * L * M * N) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7
                      (op_gt_gt spec8
                        (op_gt_gt spec9
                          (op_gt_gt spec10
                            (op_gt_gt spec11
                              (op_gt_gt spec12 (op_gt_gt spec13 NoArgs))))))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3,
                  (arg4,
                    (arg5,
                      (spec6,
                        (spec7,
                          (spec8,
                            (spec9, (spec10, (spec11, (spec12, (spec13, tt)))))))))))))
            =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10,
              spec11, spec12, spec13)
          end |}.

Definition args14 {A B C D E F G H I J K L M N O : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) (spec10 : arg K B) (spec11 : arg L B) (spec12 : arg M B)
  (spec13 : arg N B) (spec14 : arg O B)
  : options (A * C * D * E * F * G * H * I * J * K * L * M * N * O) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7
                      (op_gt_gt spec8
                        (op_gt_gt spec9
                          (op_gt_gt spec10
                            (op_gt_gt spec11
                              (op_gt_gt spec12
                                (op_gt_gt spec13 (op_gt_gt spec14 NoArgs)))))))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3,
                  (arg4,
                    (arg5,
                      (spec6,
                        (spec7,
                          (spec8,
                            (spec9,
                              (spec10,
                                (spec11, (spec12, (spec13, (spec14, tt))))))))))))))
            =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10,
              spec11, spec12, spec13, spec14)
          end |}.

Definition args15 {A B C D E F G H I J K L M N O P : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) (spec10 : arg K B) (spec11 : arg L B) (spec12 : arg M B)
  (spec13 : arg N B) (spec14 : arg O B) (spec15 : arg P B)
  : options (A * C * D * E * F * G * H * I * J * K * L * M * N * O * P) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7
                      (op_gt_gt spec8
                        (op_gt_gt spec9
                          (op_gt_gt spec10
                            (op_gt_gt spec11
                              (op_gt_gt spec12
                                (op_gt_gt spec13
                                  (op_gt_gt spec14 (op_gt_gt spec15 NoArgs))))))))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3,
                  (arg4,
                    (arg5,
                      (spec6,
                        (spec7,
                          (spec8,
                            (spec9,
                              (spec10,
                                (spec11,
                                  (spec12, (spec13, (spec14, (spec15, tt)))))))))))))))
            =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10,
              spec11, spec12, spec13, spec14, spec15)
          end |}.

Definition args16 {A B C D E F G H I J K L M N O P Q : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) (spec10 : arg K B) (spec11 : arg L B) (spec12 : arg M B)
  (spec13 : arg N B) (spec14 : arg O B) (spec15 : arg P B) (spec16 : arg Q B)
  : options (A * C * D * E * F * G * H * I * J * K * L * M * N * O * P * Q) B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7
                      (op_gt_gt spec8
                        (op_gt_gt spec9
                          (op_gt_gt spec10
                            (op_gt_gt spec11
                              (op_gt_gt spec12
                                (op_gt_gt spec13
                                  (op_gt_gt spec14
                                    (op_gt_gt spec15 (op_gt_gt spec16 NoArgs)))))))))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3,
                  (arg4,
                    (arg5,
                      (spec6,
                        (spec7,
                          (spec8,
                            (spec9,
                              (spec10,
                                (spec11,
                                  (spec12,
                                    (spec13, (spec14, (spec15, (spec16, tt))))))))))))))))
            =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10,
              spec11, spec12, spec13, spec14, spec15, spec16)
          end |}.

Definition args17 {A B C D E F G H I J K L M N O P Q R : Type}
  (spec1 : arg A B) (spec2 : arg C B) (spec3 : arg D B) (spec4 : arg E B)
  (spec5 : arg F B) (spec6 : arg G B) (spec7 : arg H B) (spec8 : arg I B)
  (spec9 : arg J B) (spec10 : arg K B) (spec11 : arg L B) (spec12 : arg M B)
  (spec13 : arg N B) (spec14 : arg O B) (spec15 : arg P B) (spec16 : arg Q B)
  (spec17 : arg R B)
  : options (A * C * D * E * F * G * H * I * J * K * L * M * N * O * P * Q * R)
    B :=
  Argument
    {|
      spec :=
        op_gt_gt spec1
          (op_gt_gt spec2
            (op_gt_gt spec3
              (op_gt_gt spec4
                (op_gt_gt spec5
                  (op_gt_gt spec6
                    (op_gt_gt spec7
                      (op_gt_gt spec8
                        (op_gt_gt spec9
                          (op_gt_gt spec10
                            (op_gt_gt spec11
                              (op_gt_gt spec12
                                (op_gt_gt spec13
                                  (op_gt_gt spec14
                                    (op_gt_gt spec15
                                      (op_gt_gt spec16 (op_gt_gt spec17 NoArgs))))))))))))))));
      converter :=
        fun function_parameter =>
          match function_parameter with
          |
            (arg1,
              (arg2,
                (arg3,
                  (arg4,
                    (arg5,
                      (spec6,
                        (spec7,
                          (spec8,
                            (spec9,
                              (spec10,
                                (spec11,
                                  (spec12,
                                    (spec13,
                                      (spec14, (spec15, (spec16, (spec17, tt)))))))))))))))))
            =>
            (arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10,
              spec11, spec12, spec13, spec14, spec15, spec16, spec17)
          end |}.

Definition param {A B C : Type}
  (name : string) (desc : string) (kind : parameter A B) (next : params C B)
  : params (A -> C) B := Param name desc kind next.

Definition seq_of_param {A B C : Type}
  (param :
    (params (A -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) A) ->
      params (B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) C)
  : params
    ((list B) -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) C :=
  match param Stop with
  | Param n desc parameter Stop => Seq n desc parameter
  | _ => OCaml.Stdlib.invalid_arg "Clic.seq_of_param" % string
  end.

Definition prefix {A B : Type} (keyword : string) (next : params A B)
  : params A B := Prefix keyword next.

Fixpoint fixed {A : Type} (function_parameter : list string)
  : params (A -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) A :=
  match function_parameter with
  | [] => Stop
  | cons n r => Prefix n (fixed r)
  end.

Fixpoint prefixes {A B : Type} (p : list string) (next : params A B)
  : params A B :=
  match p with
  | [] => next
  | cons n r => Prefix n (prefixes r next)
  end.

Definition stop {A : Type}
  : params (A -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) A := Stop.

Definition no_options {A : Type} : options unit A :=
  Argument
    {| spec := NoArgs;
      converter :=
        fun function_parameter =>
          match function_parameter with
          | tt => tt
          end |}.

Definition command {A B C : Type}
  (group : option group) (desc : string) (options : options A B)
  (params : params C B) (handler : A -> C) : command B :=
  Command
    {| params := params; options := options; handler := handler; desc := desc;
      group := group; conv := fun x => x |}.

Definition string {A B : Type}
  (name : string) (desc : string) (next : params A B)
  : params (string -> A) B :=
  param name desc
    {|
      converter :=
        fun function_parameter =>
          match function_parameter with
          | _ => fun s => Tezos_error_monad.Error_monad._return s
          end; autocomplete := None |} next.

Definition string_contains (needle : string) (haystack : string) : option Z :=
  try.

Fixpoint search_params_prefix {a arg : Type}
  (prefix : string) (function_parameter : params a arg) : bool :=
  match function_parameter with
  | Prefix keyword next =>
    match string_contains prefix keyword with
    | None => search_params_prefix prefix next
    | Some _ => true
    end
  | Param _ _ _ next => search_params_prefix prefix next
  | Stop => false
  | Seq _ _ _ => false
  end.

Definition search_command {A : Type}
  (keyword : string) (function_parameter : command A) : bool :=
  match function_parameter with
  | Command {| params := params |} => search_params_prefix keyword params
  end.

Definition exec {A : Type} (function_parameter : command A)
  : A ->
    (list string) ->
      (Tezos_stdlib.TzString.Map.t (list string)) ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  match function_parameter with
  |
    (Command {|
      params := spec;
        options := Argument {| spec := options_spec; converter := converter |};
        handler := handler;
        conv := conv
        |}) as command =>
    fun ctx =>
      fun params =>
        fun args_dict =>
          let fix exec {a ctx : Type}
            (i : Z) (ctx : ctx) (spec : params a ctx) (cb : a) (params :
            list string)
            : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
            match (spec, params) with
            | (Stop, _) => cb ctx
            | (Seq _ _ {| converter := converter |}, seq) =>
              let fix do_seq
                (i : Z) (acc : list op_dollar_1) (function_parameter :
                list string)
                : Lwt.t
                  (Tezos_error_monad.Error_monad.tzresult (list op_dollar_1)) :=
                match function_parameter with
                | [] => Tezos_error_monad.Error_monad._return (List.rev acc)
                | cons p rest =>
                  Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                    (OCaml.Stdlib.reverse_apply
                      (Lwt.catch
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => converter ctx p
                          end)
                        (fun function_parameter =>
                          match function_parameter with
                          | OCaml.Failure msg =>
                            Tezos_error_monad.Error_monad.failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.End_of_format)
                                "%s" % string) msg
                          | exn => Tezos_error_monad.Error_monad.fail (Exn exn)
                          end))
                      (Tezos_error_monad.Error_monad.trace (Bad_argument i p)))
                    (fun v => do_seq (Z.succ i) (cons v acc) rest)
                end in
              Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                (do_seq i [] seq) (fun parsed => cb parsed ctx)
            | (Param _ _ {| converter := converter |} next, cons p rest) =>
              Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                (OCaml.Stdlib.reverse_apply
                  (Lwt.catch
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => converter ctx p
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | OCaml.Failure msg =>
                        Tezos_error_monad.Error_monad.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format)
                            "%s" % string) msg
                      | exn => Tezos_error_monad.Error_monad.fail (Exn exn)
                      end))
                  (Tezos_error_monad.Error_monad.trace (Bad_argument i p)))
                (fun v => exec (Z.succ i) ctx next (cb v) rest)
            | _ =>
              Stdlib.raise
                (OCaml.Failure
                  "cli_entries internal error: exec no case matched" % string)
            end in
          let ctx := conv ctx in
          Tezos_error_monad.Error_monad.op_gt_gt_eq_question
            (parse_args (Some command) options_spec args_dict ctx)
            (fun parsed_options =>
              exec 1 ctx spec (handler (converter parsed_options)) params)
  end.

Inductive tree (ctx : Type) : Type :=
| TPrefix : (level ctx) -> tree ctx
| TParam : (param_level ctx) -> tree ctx
| TStop : (command ctx) -> tree ctx
| TSeq : (command ctx) ->
  (option (ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string))))
  -> tree ctx
| TEmpty : tree ctx.

Arguments TPrefix {_}.
Arguments TParam {_}.
Arguments TStop {_}.
Arguments TSeq {_}.
Arguments TEmpty {_}.

Definition has_options {ctx : Type} (function_parameter : command ctx) : bool :=
  match function_parameter with
  | Command {| options := Argument {| spec := spec |} |} =>
    let args_help {a : Type} (function_parameter : args a ctx) : bool :=
      match function_parameter with
      | NoArgs => false
      | AddArg _ _ => true
      end in
    args_help spec
  end.

Definition insert_in_dispatch_tree {ctx : Type}
  (root : tree ctx) (function_parameter : command ctx) : tree ctx :=
  match function_parameter with
  | (Command {| params := params; conv := conv |}) as command =>
    let access_autocomplete {p : Type} (function_parameter : parameter p ctx)
      : option
        (ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string))) :=
      match function_parameter with
      | {| autocomplete := autocomplete |} => autocomplete
      end in
    let fix insert_tree {a ictx : Type}
      (conv : ctx -> ictx) (t : tree ctx) (c : params a ictx) : tree ctx :=
      let insert_tree {D : Type} (t : tree ctx) (c : params D ictx)
        : tree ctx :=
        insert_tree conv t c in
      match (t, c) with
      | (TEmpty, Stop) => TStop command
      | (TEmpty, Seq _ _ {| autocomplete := autocomplete |}) =>
        TSeq command
          (Tezos_stdlib.Option.map (fun a => fun c => a (conv c)) autocomplete)
      | (TEmpty, Param _ _ param next) =>
        let autocomplete := access_autocomplete param in
        let autocomplete :=
          Tezos_stdlib.Option.map (fun a => fun c => a (conv c)) autocomplete in
        TParam
          {| stop := None; autocomplete := autocomplete;
            tree := insert_tree TEmpty next |}
      | (TEmpty, Prefix n next) =>
        TPrefix
          {| stop := None; prefix := cons (n, (insert_tree TEmpty next)) [] |}
      | (TStop cmd, Param _ _ param next) =>
        let autocomplete := access_autocomplete param in
        let autocomplete :=
          Tezos_stdlib.Option.map (fun a => fun c => a (conv c)) autocomplete in
        if negb (has_options cmd) then
          TParam
            {| stop := Some cmd; autocomplete := autocomplete;
              tree := insert_tree TEmpty next |}
        else
          Stdlib.raise
            (OCaml.Failure
              "Command cannot have both prefix and options" % string)
      | (TStop cmd, Prefix n next) =>
        TPrefix
          {| stop := Some cmd; prefix := cons (n, (insert_tree TEmpty next)) []
            |}
      | (TParam t, Param _ _ _ next) => TParam record
      | (TPrefix ({| prefix := prefix |} as l), Prefix n next) =>
        let fix insert_prefix (function_parameter : list (string * (tree ctx)))
          : list (string * (tree ctx)) :=
          match function_parameter with
          | [] => cons (n, (insert_tree TEmpty next)) []
          | cons (n', t) rest => cons (n, (insert_tree t next)) rest
          | cons item rest => cons item (insert_prefix rest)
          end in
        TPrefix record
      | (TPrefix ({| stop := None |} as l), Stop) => TPrefix record
      | (TParam ({| stop := None |} as l), Stop) => TParam record
      | (TParam t, Prefix _n next) => TParam record
      | (_, _) =>
        Stdlib.Pervasives.failwith
          (Stdlib.Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Clic.Command_tree.insert: conflicting commands """ % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal """" % char
                    CamlinternalFormatBasics.End_of_format)))
              "Clic.Command_tree.insert: conflicting commands ""%a""" % string)
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                |
                  Command {|
                    params := params;
                      options := Argument {| spec := spec |}
                      |} => print_commandline ppf ([], spec, params)
                end) command)
      end in
    insert_tree conv root params
  end.

Definition make_dispatch_tree {A : Type} (commands : list (command A))
  : tree A := Stdlib.List.fold_left insert_in_dispatch_tree TEmpty commands.

Fixpoint gather_commands {A : Type}
  (op_star_o_p_t_star : option (list (command A)))
  : (tree A) -> list (command A) :=
  let acc :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun tree =>
    match tree with
    | TEmpty => acc
    | TSeq c _ | TStop c => cons c acc
    | TPrefix {| stop := stop; prefix := prefix |} =>
      gather_assoc
        (Some
          match stop with
          | None => acc
          | Some c => cons c acc
          end) prefix
    | TParam {| stop := stop; tree := tree |} =>
      gather_commands
        (Some
          match stop with
          | None => acc
          | Some c => cons c acc
          end) tree
    end

with gather_assoc {A : Type} (op_star_o_p_t_star : option (list (command A)))
  : (list (string * (tree A))) -> list (command A) :=
  let acc :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun trees =>
    Stdlib.List.fold_left
      (fun acc =>
        fun function_parameter =>
          match function_parameter with
          | (_, tree) => gather_commands (Some acc) tree
          end) acc trees.

Definition find_command {A : Type}
  (tree : tree A) (initial_arguments : list string)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((command A) * (Tezos_stdlib.TzString.Map.t (list string)) * (list string))) :=
  let fix traverse {B : Type}
    (tree : tree B) (arguments : list string) (acc : list string)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        ((command B) * (Tezos_stdlib.TzString.Map.t (list string)) *
          (list string))) :=
    match (tree, arguments) with
    |
      (TStop _ | TSeq _ _ | TPrefix {| stop := Some _ |} |
        TParam {| stop := Some _ |}, cons ("-h" % string | "--help" % string) _)
      =>
      match gather_commands None tree with
      | [] => false
      | cons command [] =>
        Tezos_error_monad.Error_monad.fail (Help (Some command))
      | more =>
        Tezos_error_monad.Error_monad.fail
          (Unterminated_command initial_arguments more)
      end
    | (TStop c, []) =>
      Tezos_error_monad.Error_monad._return
        (c, empty_args_dict, initial_arguments)
    |
      (TStop ((Command {| options := Argument {| spec := spec |} |}) as command),
        remaining) =>
      Tezos_error_monad.Error_monad.op_gt_gt_eq_question
        (make_args_dict_filter (Some command) spec remaining)
        (fun function_parameter =>
          match function_parameter with
          | (args_dict, unparsed) =>
            match unparsed with
            | [] =>
              Tezos_error_monad.Error_monad._return
                (command, args_dict, initial_arguments)
            | cons hd _ =>
              if
                andb (OCaml.Stdlib.gt (OCaml.String.length hd) 0)
                  (equiv_decb (Stdlib.String.get hd 0) "-" % char) then
                Tezos_error_monad.Error_monad.fail
                  (Unknown_option hd (Some command))
              else
                Tezos_error_monad.Error_monad.fail
                  (Extra_arguments unparsed command)
            end
          end)
    |
      (TSeq ((Command {| options := Argument {| spec := spec |} |}) as command)
        _, remaining) =>
      if
        OCaml.List._exists
          (fun function_parameter =>
            match function_parameter with
            | "-h" % string | "--help" % string => true
            | _ => false
            end) remaining then
        Tezos_error_monad.Error_monad.fail (Help (Some command))
      else
        Tezos_error_monad.Error_monad.op_gt_gt_pipe_question
          (make_args_dict_filter (Some command) spec remaining)
          (fun function_parameter =>
            match function_parameter with
            | (dict, remaining) =>
              (command, dict, (Stdlib.List.rev_append acc remaining))
            end)
    | (TPrefix {| stop := Some cmd |}, []) =>
      Tezos_error_monad.Error_monad._return
        (cmd, empty_args_dict, initial_arguments)
    |
      (TPrefix {| stop := None; prefix := prefix |},
        [] | cons ("-h" % string | "--help" % string) _) =>
      Tezos_error_monad.Error_monad.fail
        (Unterminated_command initial_arguments (gather_assoc None prefix))
    | (TPrefix {| prefix := prefix |}, cons hd_arg tl) =>
      Tezos_error_monad.Error_monad.op_gt_gt_eq_question try
        (fun tree' => traverse tree' tl (cons hd_arg acc))
    |
      (TParam {| stop := None |},
        [] | cons ("-h" % string | "--help" % string) _) =>
      Tezos_error_monad.Error_monad.fail
        (Unterminated_command initial_arguments (gather_commands None tree))
    | (TParam {| stop := Some c |}, []) =>
      Tezos_error_monad.Error_monad._return
        (c, empty_args_dict, initial_arguments)
    | (TParam {| tree := tree |}, cons parameter arguments') =>
      traverse tree arguments' (cons parameter acc)
    | (TEmpty, _) =>
      Tezos_error_monad.Error_monad.fail (Command_not_found (List.rev acc) [])
    end in
  traverse tree initial_arguments [].

Definition get_arg_label {A B : Type} (arg : arg A B) : label :=
  match arg with
  | Arg {| label := label |} => label
  | DefArg {| label := label |} => label
  | Switch {| label := label |} => label
  | Constant _ => false
  end.

Definition get_arg {a ctx : Type} (arg : arg a ctx) : list string :=
  match get_arg_label arg with
  | {| long := long; short := short |} =>
    cons (String.append "--" % string long)
      match short with
      | None => []
      | Some c => cons (String.append "-" % string (Stdlib.String.make 1 c)) []
      end
  end.

Fixpoint list_args {arg ctx : Type} (function_parameter : args arg ctx)
  : list string :=
  match function_parameter with
  | NoArgs => []
  | AddArg (Constant _) args => list_args args
  | AddArg arg args => OCaml.Stdlib.app (get_arg arg) (list_args args)
  end.

Definition complete_func {A B : Type}
  (autocomplete :
    option (A -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (list B))))
  (cctxt : A) : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list B)) :=
  match autocomplete with
  | None => Tezos_error_monad.Error_monad.return_nil
  | Some autocomplete => autocomplete cctxt
  end.

Definition list_command_args {A : Type} (function_parameter : command A)
  : list string :=
  match function_parameter with
  | Command {| options := Argument {| spec := spec |} |} => list_args spec
  end.

Definition complete_arg {a ctx : Type}
  (ctx : ctx) (function_parameter : arg a ctx)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)) :=
  match function_parameter with
  | Arg {| kind := {| autocomplete := autocomplete |} |} =>
    complete_func autocomplete ctx
  | DefArg {| kind := {| autocomplete := autocomplete |} |} =>
    complete_func autocomplete ctx
  | Switch _ => Tezos_error_monad.Error_monad.return_nil
  | Constant _ => Tezos_error_monad.Error_monad.return_nil
  end.

Fixpoint remaining_spec {a ctx : Type}
  (seen : Tezos_stdlib.TzString.Set.t) (function_parameter : args a ctx)
  : list string :=
  match function_parameter with
  | NoArgs => []
  | AddArg (Constant _) rest => remaining_spec seen rest
  | AddArg arg rest =>
    match get_arg_label arg with
    | {| long := long |} =>
      if Tezos_stdlib.TzString.Set.mem long seen then
        remaining_spec seen rest
      else
        OCaml.Stdlib.app (get_arg arg) (remaining_spec seen rest)
    end
  end.

Definition complete_options {A B : Type}
  (continuation :
    (list Tezos_stdlib.TzString.Map.key) ->
      Z -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)))
  (args : list Tezos_stdlib.TzString.Map.key) (args_spec : args A B) (ind : Z)
  (ctx : B) : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)) :=
  let arities := make_arities_dict args_spec Tezos_stdlib.TzString.Map.empty in
  let fix complete_spec {a : Type}
    (name : string) (function_parameter : args a ctx)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)) :=
    match function_parameter with
    | NoArgs => Tezos_error_monad.Error_monad.return_nil
    | AddArg (Constant _) rest => complete_spec name rest
    | AddArg arg rest =>
      if equiv_decb (long (get_arg_label arg)) name then
        complete_arg ctx arg
      else
        complete_spec name rest
    end in
  let fix help
    (args : list Tezos_stdlib.TzString.Map.key) (ind : Z) (seen :
    Tezos_stdlib.TzString.Set.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)) :=
    match args with
    | [] =>
      Stdlib.Pervasives.failwith
        "cli_entries internal autocomplete error" % string
    | cons arg tl =>
      if Tezos_stdlib.TzString.Map.mem arg arities then
        match Tezos_stdlib.TzString.Map.find arg arities with
        | (arity, long) =>
          let seen := Tezos_stdlib.TzString.Set.add long seen in
          match (arity, tl) with
          | (0, args) => help args (Z.sub ind 1) seen
          | (1, cons _ tl) => help tl (Z.sub ind 2) seen
          | _ =>
            Stdlib.Pervasives.failwith
              "cli_entries internal error, invalid arity" % string
          end
        end
      else
        continuation args ind
    end in
  help args ind Tezos_stdlib.TzString.Set.empty.

Definition complete_next_tree {A : Type}
  (cctxt : A) (function_parameter : tree A)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)) :=
  match function_parameter with
  | TPrefix {| stop := stop; prefix := prefix |} =>
    Tezos_error_monad.Error_monad._return
      (OCaml.Stdlib.app
        match stop with
        | None => []
        | Some command => list_command_args command
        end (List.map fst prefix))
  | TSeq command autocomplete =>
    Tezos_error_monad.Error_monad.op_gt_gt_pipe_question
      (complete_func autocomplete cctxt)
      (fun completions =>
        OCaml.Stdlib.app completions (list_command_args command))
  | TParam {| autocomplete := autocomplete |} =>
    complete_func autocomplete cctxt
  | TStop command =>
    Tezos_error_monad.Error_monad._return (list_command_args command)
  | TEmpty => Tezos_error_monad.Error_monad.return_nil
  end.

Definition complete_tree {A : Type}
  (cctxt : A) (tree : tree A) (index : Z)
  (args : list Tezos_stdlib.TzString.Map.key)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)) :=
  let fix help
    (tree : tree A) (args : list Tezos_stdlib.TzString.Map.key) (ind : Z)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)) :=
    if equiv_decb ind 0 then
      complete_next_tree cctxt tree
    else
      match (tree, args) with
      | (TSeq _ _, _) => complete_next_tree cctxt tree
      | (TPrefix {| prefix := prefix |}, cons hd tl) => try
      | (TParam {| tree := tree |}, cons _ tl) => help tree tl (Z.sub ind 1)
      |
        (TStop
          (Command {| options := Argument {| spec := spec |}; conv := conv |}),
          args) =>
        complete_options
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              fun function_parameter =>
                match function_parameter with
                | _ => Tezos_error_monad.Error_monad.return_nil
                end
            end) args spec ind (conv cctxt)
      | (TParam _ | TPrefix _, []) | (TEmpty, _) =>
        Tezos_error_monad.Error_monad.return_nil
      end in
  help tree args index.

Definition autocompletion {A B : Type}
  (script : Tezos_stdlib.TzString.Map.key) (cur_arg : string)
  (prev_arg : Tezos_stdlib.TzString.Map.key)
  (args : list Tezos_stdlib.TzString.Map.key) (global_options : options A B)
  (commands : list (command B)) (cctxt : B)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)) :=
  let tree := make_dispatch_tree commands in
  let fix ind (n : Z) (function_parameter : list Tezos_stdlib.TzString.Map.key)
    : option Z :=
    match function_parameter with
    | [] => None
    | cons hd tl =>
      if equiv_decb hd prev_arg then
        Some (Tezos_stdlib.Option.unopt (Z.add n 1) (ind (Z.add n 1) tl))
      else
        ind (Z.add n 1) tl
    end in
  Tezos_error_monad.Error_monad.op_gt_gt_pipe_question
    (if equiv_decb prev_arg script then
      Tezos_error_monad.Error_monad.op_gt_gt_pipe_question
        (complete_next_tree cctxt tree)
        (fun command_completions =>
          match global_options with
          | Argument {| spec := spec |} =>
            OCaml.Stdlib.app (list_args spec) command_completions
          end)
    else
      match ind 0 args with
      | None => Tezos_error_monad.Error_monad.return_nil
      | Some index =>
        match global_options with
        | Argument {| spec := spec |} =>
          complete_options
            (fun args => fun ind => complete_tree cctxt tree ind args) args spec
            index cctxt
        end
      end)
    (fun completions =>
      Stdlib.List.filter
        (fun completion =>
          Re.Str.string_match (Re.Str.regexp_string cur_arg) completion 0)
        completions).

Definition parse_global_options {A B : Type}
  (global_options : options A B) (ctx : B) (args : list string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult (A * (list string))) :=
  match global_options with
  | Argument {| spec := spec; converter := converter |} =>
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
      (make_args_dict_consume None spec args)
      (fun function_parameter =>
        match function_parameter with
        | (dict, remaining) =>
          Tezos_error_monad.Error_monad.op_gt_gt_eq_question
            (parse_args None spec dict ctx)
            (fun nested =>
              Tezos_error_monad.Error_monad._return
                ((converter nested), remaining))
        end)
  end.

Definition dispatch {A : Type}
  (commands : list (command A)) (ctx : A) (args : list string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let tree := make_dispatch_tree commands in
  match args with
  | [] | cons ("-h" % string | "--help" % string) [] =>
    Tezos_error_monad.Error_monad.fail (Help None)
  | _ =>
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question (find_command tree args)
      (fun function_parameter =>
        match function_parameter with
        | (command, args_dict, filtered_args) =>
          exec command ctx filtered_args args_dict
        end)
  end.

Definition manual_group : group :=
  {| name := "man" % string; title := "Access the documentation" % string |}.

Definition add_manual {A B C : Type}
  (executable_name : string) (global_options : options A B) (format : format)
  (ppf : Stdlib.Format.formatter) (commands : list (command C))
  : list (command C) :=
  let with_manual :=
    OCaml.Stdlib.app commands
      (cons
        (command (Some manual_group)
          "Print documentation of commands.
Add search keywords to narrow list.
Will display only the commands by default, unless [-verbosity <2|3>] is passed or the list of matching commands if less than 3."
            % string
          (args2
            (arg
              "level of details
0. Only shows command mnemonics, without documentation.
1. Shows command mnemonics with short descriptions.
2. Show commands and arguments with short descriptions
3. Show everything"
                % string (Some "v" % char) "verbosity" % string
              "0|1|2|3" % string
              (parameter
                (Some
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      Tezos_error_monad.Error_monad._return
                        (cons "0" % string
                          (cons "1" % string
                            (cons "2" % string (cons "3" % string []))))
                    end))
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    fun arg =>
                      match arg with
                      | "0" % string =>
                        Tezos_error_monad.Error_monad._return Terse
                      | "1" % string =>
                        Tezos_error_monad.Error_monad._return Short
                      | "2" % string =>
                        Tezos_error_monad.Error_monad._return Details
                      | "3" % string =>
                        Tezos_error_monad.Error_monad._return Full
                      | _ =>
                        Tezos_error_monad.Error_monad.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Level of details out of range" % string
                              CamlinternalFormatBasics.End_of_format)
                            "Level of details out of range" % string)
                      end
                  end)))
            (default_arg "the manual's output format" % string None
              "format" % string "plain|colors|html" % string
              match format with
              | Ansi => "colors" % string
              | Plain => "plain" % string
              | Html => "html" % string
              end
              (parameter
                (Some
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      Tezos_error_monad.Error_monad._return
                        (cons "colors" % string
                          (cons "plain" % string (cons "html" % string [])))
                    end))
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    fun arg =>
                      match arg with
                      | "colors" % string =>
                        Tezos_error_monad.Error_monad._return Ansi
                      | "plain" % string =>
                        Tezos_error_monad.Error_monad._return Plain
                      | "html" % string =>
                        Tezos_error_monad.Error_monad._return Html
                      | _ =>
                        Tezos_error_monad.Error_monad.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Unknown manual format" % string
                              CamlinternalFormatBasics.End_of_format)
                            "Unknown manual format" % string)
                      end
                  end))))
          (prefix "man" % string
            (seq_of_param
              (string "keyword" % string
                "keyword to search for
If several are given they must all appear in the command."
                  % string)))
          (fun function_parameter =>
            match function_parameter with
            | (verbosity, format) =>
              fun keywords =>
                fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    let commands :=
                      Stdlib.List.fold_left
                        (fun commands =>
                          fun keyword =>
                            Stdlib.List.filter (search_command keyword) commands)
                        (Stdlib.Lazy.force with_manual) keywords in
                    let verbosity :=
                      match verbosity with
                      | Some verbosity => verbosity
                      | None => Short
                      end in
                    match commands with
                    | [] =>
                      Tezos_error_monad.Error_monad.fail
                        (No_manual_entry keywords)
                    | _ =>
                      let state := setup_formatter ppf format verbosity in
                      let commands := List.map (fun c => Ex c) commands in
                      usage_internal ppf executable_name global_options
                        (Some keywords) commands;
                      restore_formatter ppf state;
                      Tezos_error_monad.Error_monad.return_unit
                    end
                  end
            end)) []) in
  Stdlib.Lazy.force with_manual.

Definition pp_cli_errors {A B : Type}
  (ppf : Stdlib.Format.formatter) (executable_name : string)
  (global_options : options A B)
  (default :
    Stdlib.Format.formatter -> Tezos_error_monad.Error_monad.error -> unit)
  (errs : list Tezos_error_monad.Error_monad.error) : unit :=
  let pp_one (function_parameter : Tezos_error_monad.Error_monad.error)
    : option (list ex_command) :=
    match function_parameter with
    | Bad_argument i v =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Erroneous command line argument " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " (" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal ")." % string
                    CamlinternalFormatBasics.End_of_format)))))
          "Erroneous command line argument %d (%s)." % string) i v;
      Some []
    | Option_expected_argument arg command =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Command line option " % string
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<opt>" % string
                    CamlinternalFormatBasics.End_of_format) "<opt>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.String_literal
                    " expects an argument." % string
                    CamlinternalFormatBasics.End_of_format)))))
          "Command line option @{<opt>%s@} expects an argument." % string) arg;
      Some
        (Tezos_stdlib.Option.unopt_map (fun command => cons (Ex command) []) []
          command)
    | Bad_option_argument arg command =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Wrong value for command line option " % string
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<opt>" % string
                    CamlinternalFormatBasics.End_of_format) "<opt>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format)))))
          "Wrong value for command line option @{<opt>%s@}." % string) arg;
      Some
        (Tezos_stdlib.Option.unopt_map (fun command => cons (Ex command) []) []
          command)
    | Multiple_occurences arg command =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Command line option " % string
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<opt>" % string
                    CamlinternalFormatBasics.End_of_format) "<opt>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.String_literal
                    " appears multiple times." % string
                    CamlinternalFormatBasics.End_of_format)))))
          "Command line option @{<opt>%s@} appears multiple times." % string)
        arg;
      Some
        (Tezos_stdlib.Option.unopt_map (fun command => cons (Ex command) []) []
          command)
    | No_manual_entry (cons keyword []) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "No manual entry that match " % string
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hilight>" % string
                    CamlinternalFormatBasics.End_of_format) "<hilight>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format)))))
          "No manual entry that match @{<hilight>%s@}." % string) keyword;
      Some []
    | No_manual_entry (cons keyword keywords) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "No manual entry that match " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " and " % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_tag
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<hilight>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hilight>" % string))
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      (CamlinternalFormatBasics.Char_literal "." % char
                        CamlinternalFormatBasics.End_of_format)))))))
          "No manual entry that match %a and @{<hilight>%s@}." % string)
        (Stdlib.Format.pp_print_list
          (Some
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal ", " % string
                        CamlinternalFormatBasics.End_of_format) ", " % string)
                end))
          (fun ppf =>
            fun keyword =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_tag
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<hilight>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<hilight>" % string))
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_tag
                        CamlinternalFormatBasics.End_of_format)))
                  "@{<hilight>%s@}" % string) keyword)) keywords keyword;
      Some []
    | Unknown_option option command =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Unexpected command line option " % string
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<opt>" % string
                    CamlinternalFormatBasics.End_of_format) "<opt>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format)))))
          "Unexpected command line option @{<opt>%s@}." % string) option;
      Some
        (Tezos_stdlib.Option.unopt_map (fun command => cons (Ex command) []) []
          command)
    | Extra_arguments extra command =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Extra command line arguments:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Char_literal " " % char
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<h>" % string
                        CamlinternalFormatBasics.End_of_format) "<h>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Char_literal "." % char
                        CamlinternalFormatBasics.End_of_format)))))))
          "Extra command line arguments:@, @[<h>%a@]." % string)
        (Stdlib.Format.pp_print_list None
          (fun ppf =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format) "%s" % string))) extra;
      Some (cons (Ex command) [])
    | Unterminated_command _ commands =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String_literal
              "Unterminated command, here are possible completions." % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "@[<v 2>Unterminated command, here are possible completions.@,%a@]" %
            string)
        (Stdlib.Format.pp_print_list None
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              |
                Command {|
                  params := params;
                    options := Argument {| spec := spec |}
                    |} => print_commandline ppf ([], spec, params)
              end)) commands;
      Some (List.map (fun c => Ex c) commands)
    | Command_not_found [] _all_commands =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Unrecognized command." % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Try using the " % string
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_tag
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<kwd>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<kwd>" % string))
                    (CamlinternalFormatBasics.String_literal "man" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_tag
                        (CamlinternalFormatBasics.String_literal
                          " command to get more information." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))))))
          "@[<v 0>Unrecognized command.@,Try using the @{<kwd>man@} command to get more information.@]"
            % string);
      Some []
    | Command_not_found _ commands =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Unrecognized command." % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Did you mean one of the following?" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "  " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 0>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 0>" % string))
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format))))))))))
          "@[<v 0>Unrecognized command.@,Did you mean one of the following?@,  @[<v 0>%a@]@]"
            % string)
        (Stdlib.Format.pp_print_list None
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              |
                Command {|
                  params := params;
                    options := Argument {| spec := spec |}
                    |} => print_commandline ppf ([], spec, params)
              end)) commands;
      Some (List.map (fun c => Ex c) commands)
    | err =>
      default ppf err;
      None
    end in
  let fix pp
    (acc : option (list ex_command)) (errs :
    list Tezos_error_monad.Error_monad.error) : option (list ex_command) :=
    let _return (command : option (list ex_command))
      : option (list ex_command) :=
      match (command, acc) with
      | (None, _) => acc
      | (Some command, Some commands) =>
        Some (OCaml.Stdlib.app command commands)
      | (Some command, None) => Some command
      end in
    match errs with
    | [] => None
    | cons last [] => _return (pp_one last)
    | cons err errs =>
      let acc := _return (pp_one err) in
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            CamlinternalFormatBasics.End_of_format) "@," % string);
      pp acc errs
    end in
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 2>" % string
              CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_tag
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<error>" % string
                CamlinternalFormatBasics.End_of_format) "<error>" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<title>" % string
                  CamlinternalFormatBasics.End_of_format) "<title>" % string))
            (CamlinternalFormatBasics.String_literal "Error" % string
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_tag
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    CamlinternalFormatBasics.End_of_format)))))))
      "@[<v 2>@{<error>@{<title>Error@}@}@," % string);
  match pp None errs with
  | None =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Force_newline
            CamlinternalFormatBasics.End_of_format)) "@]@
" % string)
  | Some commands =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Force_newline
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Force_newline
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format))))))
        "@]@
@
@[<v 0>%a@]" % string)
      (fun ppf =>
        fun commands =>
          usage_internal ppf executable_name global_options None commands)
      commands
  end.

Definition usage {A B C : Type}
  (ppf : Stdlib.Format.formatter) (executable_name : string)
  (global_options : options A B) (commands : list (command C)) : unit :=
  usage_internal ppf executable_name global_options None
    (List.map (fun c => Ex c) commands).

Definition map_command {A B : Type}
  (f : A -> B) (function_parameter : command B) : command A :=
  match function_parameter with
  | Command c => Command record
  end.
src/lib_clic/clic.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

(** Command Line Interpretation Combinators.

    Supports command lines of the following form:

    [executable [global options] command [command options]]

    Global options must be passed before the command, and may define
    the set of supported commands.

    Commands are series of fixed keywords and positional arguments, in
    order to support command lines close to a natural language. *)

(** {2 Argument parsers.} *)

(** The type for argument parsers, used for both positional and
    optional arguments.

    The first type parameter is the OCaml type of the argument once
    parsed from its string notation. The second parameter is a context
    that is passed throughout the parsing of the command line. Some
    parameters (for instance a simple [int]) can remain polymorphic,
    while others need a context to be parsed. Of course, a command line
    can only contain parameters that bear the same context type. *)
type ('a, 'ctx) parameter

(** Build an argument parser, combining a parsing function and an
    autocompletion function. The autocompletion must simply return the
    list of all valid values for the parameter. *)
val parameter :
  ?autocomplete:('ctx -> string list tzresult Lwt.t) ->
  ('ctx -> string -> 'a tzresult Lwt.t) ->
  ('a, 'ctx) parameter

(** Build an argument parser by composing two other parsers. The
    resulting parser will try the first parser and if it fails will
    try the second. The auto-complete contents of the two will be
    concatenated. *)
val compose_parameters :
  ('a, 'ctx) parameter -> ('a, 'ctx) parameter -> ('a, 'ctx) parameter

(** Map a pure function over the result of a parameter parser. *)
val map_parameter :
  f:('a -> 'b) -> ('a, 'ctx) parameter -> ('b, 'ctx) parameter

(** {2 Flags and Options } *)

(** The type for optional arguments (and switches).

    Extends a parser with a parameter name and a placeholder to
    display in help screens.

    Also adds a documentation for the switch, that must be of the form
    ["lowercase short description\nOptional longer description."]. *)
type ('a, 'ctx) arg

val constant : 'a -> ('a, 'ctx) arg

(** [arg ~doc ~long ?short converter] creates an argument to a command.
    The [~long] argument is the long format, without the double dashes.
    The [?short] argument is the optional one letter shortcut.
    If the argument is not provided, [None] is returned. *)
val arg :
  doc:string ->
  ?short:char ->
  long:string ->
  placeholder:string ->
  ('a, 'ctx) parameter ->
  ('a option, 'ctx) arg

(** Create an argument that will contain the [~default] value if it is not provided. *)
val default_arg :
  doc:string ->
  ?short:char ->
  long:string ->
  placeholder:string ->
  default:string ->
  ('a, 'ctx) parameter ->
  ('a, 'ctx) arg

(** Create a boolean switch.
    The value will be set to [true] if the switch is provided and [false] if it is not. *)
val switch :
  doc:string -> ?short:char -> long:string -> unit -> (bool, 'ctx) arg

(** {2 Groups of Optional Arguments} *)

(** Defines a group of options, either the global options or the
    command options. *)

(** The type of a series of labeled arguments to a command *)
type ('a, 'ctx) options

(** Include no optional parameters *)
val no_options : (unit, 'ctx) options

(** Include 1 optional parameter *)
val args1 : ('a, 'ctx) arg -> ('a, 'ctx) options

(** Include 2 optional parameters *)
val args2 : ('a, 'ctx) arg -> ('b, 'ctx) arg -> ('a * 'b, 'ctx) options

(** Include 3 optional parameters *)
val args3 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('a * 'b * 'c, 'ctx) options

(** Include 4 optional parameters *)
val args4 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('a * 'b * 'c * 'd, 'ctx) options

(** Include 5 optional parameters *)
val args5 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('a * 'b * 'c * 'd * 'e, 'ctx) options

(** Include 6 optional parameters *)
val args6 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('a * 'b * 'c * 'd * 'e * 'f, 'ctx) options

(** Include 7 optional parameters *)
val args7 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('a * 'b * 'c * 'd * 'e * 'f * 'g, 'ctx) options

(** Include 8 optional parameters *)
val args8 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h, 'ctx) options

(** Include 9 optional parameters *)
val args9 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i, 'ctx) options

(** Include 10 optional parameters *)
val args10 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('j, 'ctx) arg ->
  ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j, 'ctx) options

(** Include 11 optional parameters *)
val args11 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('j, 'ctx) arg ->
  ('k, 'ctx) arg ->
  ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k, 'ctx) options

(** Include 12 optional parameters *)
val args12 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('j, 'ctx) arg ->
  ('k, 'ctx) arg ->
  ('l, 'ctx) arg ->
  ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l, 'ctx) options

(** Include 13 optional parameters *)
val args13 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('j, 'ctx) arg ->
  ('k, 'ctx) arg ->
  ('l, 'ctx) arg ->
  ('m, 'ctx) arg ->
  ( 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm,
    'ctx )
  options

(** Include 14 optional parameters *)
val args14 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('j, 'ctx) arg ->
  ('k, 'ctx) arg ->
  ('l, 'ctx) arg ->
  ('m, 'ctx) arg ->
  ('n, 'ctx) arg ->
  ( 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n,
    'ctx )
  options

(** Include 15 optional parameters *)
val args15 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('j, 'ctx) arg ->
  ('k, 'ctx) arg ->
  ('l, 'ctx) arg ->
  ('m, 'ctx) arg ->
  ('n, 'ctx) arg ->
  ('o, 'ctx) arg ->
  ( 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n * 'o,
    'ctx )
  options

(** Include 16 optional parameters *)
val args16 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('j, 'ctx) arg ->
  ('k, 'ctx) arg ->
  ('l, 'ctx) arg ->
  ('m, 'ctx) arg ->
  ('n, 'ctx) arg ->
  ('o, 'ctx) arg ->
  ('p, 'ctx) arg ->
  ( 'a
    * 'b
    * 'c
    * 'd
    * 'e
    * 'f
    * 'g
    * 'h
    * 'i
    * 'j
    * 'k
    * 'l
    * 'm
    * 'n
    * 'o
    * 'p,
    'ctx )
  options

(** Include 17 optional parameters *)
val args17 :
  ('a, 'ctx) arg ->
  ('b, 'ctx) arg ->
  ('c, 'ctx) arg ->
  ('d, 'ctx) arg ->
  ('e, 'ctx) arg ->
  ('f, 'ctx) arg ->
  ('g, 'ctx) arg ->
  ('h, 'ctx) arg ->
  ('i, 'ctx) arg ->
  ('j, 'ctx) arg ->
  ('k, 'ctx) arg ->
  ('l, 'ctx) arg ->
  ('m, 'ctx) arg ->
  ('n, 'ctx) arg ->
  ('o, 'ctx) arg ->
  ('p, 'ctx) arg ->
  ('q, 'ctx) arg ->
  ( 'a
    * 'b
    * 'c
    * 'd
    * 'e
    * 'f
    * 'g
    * 'h
    * 'i
    * 'j
    * 'k
    * 'l
    * 'm
    * 'n
    * 'o
    * 'p
    * 'q,
    'ctx )
  options

(** {2 Parameter based command lines} *)

(** Type of parameters for a command *)
type ('a, 'ctx) params

(** A piece of data inside a command line *)
val param :
  name:string ->
  desc:string ->
  ('a, 'ctx) parameter ->
  ('b, 'ctx) params ->
  ('a -> 'b, 'ctx) params

(** A word in a command line.
    Should be descriptive. *)
val prefix : string -> ('a, 'ctx) params -> ('a, 'ctx) params

(** Multiple words given in sequence for a command line *)
val prefixes : string list -> ('a, 'ctx) params -> ('a, 'ctx) params

(** A fixed series of words that trigger a command. *)
val fixed : string list -> ('ctx -> unit tzresult Lwt.t, 'ctx) params

(** End the description of the command line *)
val stop : ('ctx -> unit tzresult Lwt.t, 'ctx) params

(** Take a sequence of parameters instead of only a single one.
    Must be the last thing in the command line. *)
val seq_of_param :
  (('ctx -> unit tzresult Lwt.t, 'ctx) params ->
  ('a -> 'ctx -> unit tzresult Lwt.t, 'ctx) params) ->
  ('a list -> 'ctx -> unit tzresult Lwt.t, 'ctx) params

(** Parameter that expects a string *)
val string :
  name:string ->
  desc:string ->
  ('a, 'ctx) params ->
  (string -> 'a, 'ctx) params

(** {2 Commands }  *)

(** Command, including a parameter specification, optional arguments, and handlers  *)
type 'ctx command

(** Type of a group of commands.
    Groups have their documentation printed together
    and should include a descriptive title. *)
type group = {name : string; title : string}

(** A complete command, with documentation, a specification of its
    options, parameters, and handler function. *)
val command :
  ?group:group ->
  desc:string ->
  ('b, 'ctx) options ->
  ('a, 'ctx) params ->
  ('b -> 'a) ->
  'ctx command

(** Combinator to use a command in an adapted context. *)
val map_command : ('a -> 'b) -> 'b command -> 'a command

(** {2 Output formatting} *)

(** Used to restore the formatter state after [setup_formatter]. *)
type formatter_state

(** Supported output formats.
    Currently: black and white, colors using ANSI escapes, and HTML.*)
type format = Plain | Ansi | Html

(** Verbosity level, from terse to verbose. *)
type verbosity = Terse | Short | Details | Full

(** Updates the formatter's functions to interpret some semantic tags
    used in manual production. Returns the previous state of the
    formatter to restore it afterwards if needed.

    Toplevel structure tags:

      * [<document>]: a toplevel group
      * [<title>]: a section title (just below a [<document])
      * [<list>]: a list section (just below a [<document])

    Structure tags used internally for generating the manual:

    * [<command>]: wraps the full documentation bloc for a command
    * [<commandline>]: wraps the command line in a [<command>]
    * [<commanddoc>]: wraps everything but the command line in a [<command>]

    Cosmetic tags for highlighting text:

    * [<opt>]: optional arguments * [<arg>]: positional arguments
    * [<kwd>]: positional keywords * [<hilight>]: search results

    Verbosity levels, in order, and how they are used in the manual:

    * [<terse>]: titles, commands lines
    * [<short>]: lists of arguments
    * [<details>]: single line descriptions
    * [<full>]: with long descriptions

    Wrapping a piece of text with a debug level means that the
    contents are only printed if the verbosity is equal to or
    above that level. Use prefix [=] for an exact match, or [-]
    for the inverse interpretation. *)
val setup_formatter :
  Format.formatter -> format -> verbosity -> formatter_state

(** Restore the formatter state after [setup_formatter]. *)
val restore_formatter : Format.formatter -> formatter_state -> unit

(** {2 Parsing and error reporting} *)

(** Help error (not really an error), thrown by {!dispatch} and {!parse_initial_options}. *)
type error += Help : _ command option -> error

(** Find and call the applicable command on the series of arguments.
    @raise [Failure] if the command list would be ambiguous. *)
val dispatch : 'ctx command list -> 'ctx -> string list -> unit tzresult Lwt.t

(** Parse the global options, and return their value, with the rest of
    the command to be parsed. *)
val parse_global_options :
  ('a, 'ctx) options ->
  'ctx ->
  string list ->
  ('a * string list) tzresult Lwt.t

(** Pretty prints the error messages to the given formatter.
    [executable_name] and [global_options] are for help screens.
    [default] is used to print non-CLI errors. *)
val pp_cli_errors :
  Format.formatter ->
  executable_name:string ->
  global_options:(_, _) options ->
  default:(Format.formatter -> error -> unit) ->
  error list ->
  unit

(** Acts as {!dispatch}, but stops if the given command up to
    [prev_arg] is a valid prefix command, returning the list of valid
    next words, filtered with [cur_arg]. *)
val autocompletion :
  script:string ->
  cur_arg:string ->
  prev_arg:string ->
  args:string list ->
  global_options:('a, 'ctx) options ->
  'ctx command list ->
  'ctx ->
  string list Error_monad.tzresult Lwt.t

(** Displays a help page for the given commands. *)
val usage :
  Format.formatter ->
  executable_name:string ->
  global_options:(_, _) options ->
  _ command list ->
  unit

(** {2 Manual} *)

(** Add manual commands to a list of commands.
    For this to work, the command list must be complete.
    Commands added later will not appear in the manual. *)
val add_manual :
  executable_name:string ->
  global_options:('a, 'ctx) options ->
  format ->
  Format.formatter ->
  'ctx command list ->
  'ctx command list
src/lib_clic/clic.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter parameter : forall (a ctx : Type), Type.

Parameter parameter : forall {a ctx : Type},
(option (ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string))))
  ->
  (ctx -> string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult a)) ->
    parameter a ctx.

Parameter compose_parameters : forall {a ctx : Type},
(parameter a ctx) -> (parameter a ctx) -> parameter a ctx.

Parameter map_parameter : forall {a b ctx : Type},
(a -> b) -> (parameter a ctx) -> parameter b ctx.

Parameter arg : forall (a ctx : Type), Type.

Parameter constant : forall {a ctx : Type}, a -> arg a ctx.

Parameter arg : forall {a ctx : Type},
string ->
  (option ascii) -> string -> string -> (parameter a ctx) -> arg (option a) ctx.

Parameter default_arg : forall {a ctx : Type},
string ->
  (option ascii) -> string -> string -> string -> (parameter a ctx) -> arg a ctx.

Parameter switch : forall {ctx : Type},
string -> (option ascii) -> string -> unit -> arg bool ctx.

Parameter options : forall (a ctx : Type), Type.

Parameter no_options : forall {ctx : Type}, options unit ctx.

Parameter args1 : forall {a ctx : Type}, (arg a ctx) -> options a ctx.

Parameter args2 : forall {a b ctx : Type},
(arg a ctx) -> (arg b ctx) -> options (a * b) ctx.

Parameter args3 : forall {a b c ctx : Type},
(arg a ctx) -> (arg b ctx) -> (arg c ctx) -> options (a * b * c) ctx.

Parameter args4 : forall {a b c ctx d : Type},
(arg a ctx) ->
  (arg b ctx) -> (arg c ctx) -> (arg d ctx) -> options (a * b * c * d) ctx.

Parameter args5 : forall {a b c ctx d e : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) -> (arg d ctx) -> (arg e ctx) -> options (a * b * c * d * e) ctx.

Parameter args6 : forall {a b c ctx d e f : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) -> (arg f ctx) -> options (a * b * c * d * e * f) ctx.

Parameter args7 : forall {a b c ctx d e f g : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) -> (arg g ctx) -> options (a * b * c * d * e * f * g) ctx.

Parameter args8 : forall {a b c ctx d e f g h : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) -> options (a * b * c * d * e * f * g * h) ctx.

Parameter args9 : forall {a b c ctx d e f g h i : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) -> options (a * b * c * d * e * f * g * h * i) ctx.

Parameter args10 : forall {a b c ctx d e f g h i j : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) ->
                  (arg j ctx) ->
                    options (a * b * c * d * e * f * g * h * i * j) ctx.

Parameter args11 : forall {a b c ctx d e f g h i j k : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) ->
                  (arg j ctx) ->
                    (arg k ctx) ->
                      options (a * b * c * d * e * f * g * h * i * j * k) ctx.

Parameter args12 : forall {a b c ctx d e f g h i j k l : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) ->
                  (arg j ctx) ->
                    (arg k ctx) ->
                      (arg l ctx) ->
                        options (a * b * c * d * e * f * g * h * i * j * k * l)
                          ctx.

Parameter args13 : forall {a b c ctx d e f g h i j k l m : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) ->
                  (arg j ctx) ->
                    (arg k ctx) ->
                      (arg l ctx) ->
                        (arg m ctx) ->
                          options
                            (a * b * c * d * e * f * g * h * i * j * k * l * m)
                            ctx.

Parameter args14 : forall {a b c ctx d e f g h i j k l m n : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) ->
                  (arg j ctx) ->
                    (arg k ctx) ->
                      (arg l ctx) ->
                        (arg m ctx) ->
                          (arg n ctx) ->
                            options
                              (a * b * c * d * e * f * g * h * i * j * k * l * m
                                * n) ctx.

Parameter args15 : forall {a b c ctx d e f g h i j k l m n o : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) ->
                  (arg j ctx) ->
                    (arg k ctx) ->
                      (arg l ctx) ->
                        (arg m ctx) ->
                          (arg n ctx) ->
                            (arg o ctx) ->
                              options
                                (a * b * c * d * e * f * g * h * i * j * k * l *
                                  m * n * o) ctx.

Parameter args16 : forall {a b c ctx d e f g h i j k l m n o p : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) ->
                  (arg j ctx) ->
                    (arg k ctx) ->
                      (arg l ctx) ->
                        (arg m ctx) ->
                          (arg n ctx) ->
                            (arg o ctx) ->
                              (arg p ctx) ->
                                options
                                  (a * b * c * d * e * f * g * h * i * j * k * l
                                    * m * n * o * p) ctx.

Parameter args17 : forall {a b c ctx d e f g h i j k l m n o p q : Type},
(arg a ctx) ->
  (arg b ctx) ->
    (arg c ctx) ->
      (arg d ctx) ->
        (arg e ctx) ->
          (arg f ctx) ->
            (arg g ctx) ->
              (arg h ctx) ->
                (arg i ctx) ->
                  (arg j ctx) ->
                    (arg k ctx) ->
                      (arg l ctx) ->
                        (arg m ctx) ->
                          (arg n ctx) ->
                            (arg o ctx) ->
                              (arg p ctx) ->
                                (arg q ctx) ->
                                  options
                                    (a * b * c * d * e * f * g * h * i * j * k *
                                      l * m * n * o * p * q) ctx.

Parameter params : forall (a ctx : Type), Type.

Parameter param : forall {a b ctx : Type},
string -> string -> (parameter a ctx) -> (params b ctx) -> params (a -> b) ctx.

Parameter prefix : forall {a ctx : Type},
string -> (params a ctx) -> params a ctx.

Parameter prefixes : forall {a ctx : Type},
(list string) -> (params a ctx) -> params a ctx.

Parameter fixed : forall {ctx : Type},
(list string) ->
  params (ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ctx.

Parameter stop : forall {ctx : Type},
params (ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ctx.

Parameter seq_of_param : forall {a ctx : Type},
((params (ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ctx) ->
  params (a -> ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ctx)
  ->
  params
    ((list a) -> ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ctx.

Parameter string : forall {a ctx : Type},
string -> string -> (params a ctx) -> params (string -> a) ctx.

Parameter command : forall (ctx : Type), Type.

Record group := {
  name : string;
  title : string }.

Parameter command : forall {a b ctx : Type},
(option group) ->
  string -> (options b ctx) -> (params a ctx) -> (b -> a) -> command ctx.

Parameter map_command : forall {a b : Type},
(a -> b) -> (command b) -> command a.

Parameter formatter_state : Type.

Inductive format : Type :=
| Plain : format
| Ansi : format
| Html : format.

Inductive verbosity : Type :=
| Terse : verbosity
| Short : verbosity
| Details : verbosity
| Full : verbosity.

Parameter setup_formatter :
Stdlib.Format.formatter -> format -> verbosity -> formatter_state.

Parameter restore_formatter :
Stdlib.Format.formatter -> formatter_state -> unit.

extensible_type

Parameter dispatch : forall {ctx : Type},
(list (command ctx)) ->
  ctx -> (list string) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).

Parameter parse_global_options : forall {a ctx : Type},
(options a ctx) ->
  ctx ->
    (list string) ->
      Lwt.t (Tezos_error_monad.Error_monad.tzresult (a * (list string))).

Parameter pp_cli_errors : forall {_ : Type},
Stdlib.Format.formatter ->
  string ->
    (options _ _) ->
      (Stdlib.Format.formatter -> Tezos_error_monad.Error_monad.error -> unit)
        -> (list Tezos_error_monad.Error_monad.error) -> unit.

Parameter autocompletion : forall {a ctx : Type},
string ->
  string ->
    string ->
      (list string) ->
        (options a ctx) ->
          (list (command ctx)) ->
            ctx -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (list string)).

Parameter usage : forall {_ : Type},
Stdlib.Format.formatter -> string -> (options _ _) -> (list (command _)) -> unit.

Parameter add_manual : forall {a ctx : Type},
string ->
  (options a ctx) ->
    format ->
      Stdlib.Format.formatter -> (list (command ctx)) -> list (command ctx).
src/lib_clic/unix/scriptable.ml 
open Error_monad

type output_format = Rows of {separator : string; escape : [`No | `OCaml]}

let rows separator escape = Rows {separator; escape}

let tsv = rows "\t" `No

let csv = rows "," `OCaml

let clic_arg () =
  let open Clic in
  arg
    ~doc:"Make the output script-friendly"
    ~long:"for-script"
    ~placeholder:"FORMAT"
    (parameter (fun _ spec ->
         match String.lowercase_ascii spec with
         | "tsv" ->
             return tsv
         | "csv" ->
             return csv
         | other ->
             failwith
               "Cannot recognize format %S, please try 'TSV' or 'CSV'"
               other))

let fprintf_lwt chan fmt =
  Format.kasprintf
    (fun s ->
      protect (fun () -> Lwt_io.write chan s >>= fun () -> return_unit))
    fmt

let output ?(channel = Lwt_io.stdout) how_option ~for_human ~for_script =
  match how_option with
  | None ->
      for_human ()
  | Some (Rows {separator; escape}) ->
      let open Format in
      iter_s
        (fun row ->
          fprintf_lwt
            channel
            "%a@."
            (pp_print_list
               ~pp_sep:(fun fmt () -> pp_print_string fmt separator)
               (fun fmt cell ->
                 match escape with
                 | `OCaml ->
                     fprintf fmt "%S" cell
                 | `No ->
                     pp_print_string fmt cell))
            row)
        (for_script ())
      >>=? fun () ->
      protect (fun () -> Lwt_io.flush channel >>= fun () -> return_unit)

let output_for_human how_option for_human =
  output how_option ~for_human ~for_script:(fun () -> [])

let output_row ?channel how_option ~for_human ~for_script =
  output ?channel how_option ~for_human ~for_script:(fun () -> [for_script ()])
src/lib_clic/unix/scriptable.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Inductive output_format : Type :=
| Rows : string -> variant -> output_format.

Definition rows (separator : string) (escape : variant) : output_format :=
  Rows {| separator := separator; escape := escape |}.

Definition tsv : output_format := rows "	" % string variant.

Definition csv : output_format := rows "," % string variant.

Definition clic_arg {A : Type} (function_parameter : unit)
  : Tezos_clic.Clic.arg (option output_format) A :=
  match function_parameter with
  | tt =>
    Tezos_clic.Clic.arg "Make the output script-friendly" % string None
      "for-script" % string "FORMAT" % string
      (Tezos_clic.Clic.parameter None
        (fun function_parameter =>
          match function_parameter with
          | _ =>
            fun spec =>
              match Stdlib.String.lowercase_ascii spec with
              | "tsv" % string => Tezos_error_monad.Error_monad._return tsv
              | "csv" % string => Tezos_error_monad.Error_monad._return csv
              | other =>
                Tezos_error_monad.Error_monad.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Cannot recognize format " % string
                      (CamlinternalFormatBasics.Caml_string
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          ", please try 'TSV' or 'CSV'" % string
                          CamlinternalFormatBasics.End_of_format)))
                    "Cannot recognize format %S, please try 'TSV' or 'CSV'" %
                      string) other
              end
          end))
  end.

Definition fprintf_lwt {A : Type}
  (chan : Lwt_io.output_channel)
  (fmt :
    Stdlib.format4 A Stdlib.Format.formatter unit
      (Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))) : A :=
  Stdlib.Format.kasprintf
    (fun s =>
      Tezos_error_monad.Error_monad.protect None None
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_error_monad.Error_monad.op_gt_gt_eq (Lwt_io.write chan s)
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_error_monad.Error_monad.return_unit
                end)
          end)) fmt.

Definition output (op_star_o_p_t_star : option Lwt_io.output_channel)
  : (option output_format) ->
    (unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ->
      (unit -> list (list string)) ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let channel :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Lwt_io.stdout
    end in
  fun how_option =>
    fun for_human =>
      fun for_script =>
        match how_option with
        | None => for_human tt
        | Some (Rows {| separator := separator; escape := escape |}) =>
          Tezos_error_monad.Error_monad.op_gt_gt_eq_question
            (Tezos_error_monad.Error_monad.iter_s
              (fun row =>
                fprintf_lwt channel
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Flush_newline
                        CamlinternalFormatBasics.End_of_format)) "%a@." % string)
                  (Stdlib.Format.pp_print_list
                    (Some
                      (fun fmt =>
                        fun function_parameter =>
                          match function_parameter with
                          | tt => Stdlib.Format.pp_print_string fmt separator
                          end))
                    (fun fmt =>
                      fun cell =>
                        match escape with
                        | OCaml =>
                          Stdlib.Format.fprintf fmt
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Caml_string
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.End_of_format)
                              "%S" % string) cell
                        | No => Stdlib.Format.pp_print_string fmt cell
                        end)) row) (for_script tt))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_error_monad.Error_monad.protect None None
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_error_monad.Error_monad.op_gt_gt_eq
                        (Lwt_io.flush channel)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_error_monad.Error_monad.return_unit
                          end)
                    end)
              end)
        end.

Definition output_for_human
  (how_option : option output_format)
  (for_human : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  output None how_option for_human
    (fun function_parameter =>
      match function_parameter with
      | tt => []
      end).

Definition output_row
  (channel : option Lwt_io.output_channel) (how_option : option output_format)
  (for_human : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
  (for_script : unit -> list string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  output channel how_option for_human
    (fun function_parameter =>
      match function_parameter with
      | tt => cons (for_script tt) []
      end).
src/lib_clic/unix/scriptable.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

(** Manage a common ["--for-script <FORMAT>"] option to make the
    output of certain commands script-friendly. *)

(** A representation of the output format. *)
type output_format

(** Command line argument for {!Clic.command} (and the [Clic.args*]
    functions). Not that this is the only way to obtain a value of type
    [output_format]. On the command line, it appears as [--for-script] with
    values [TSV] or [CSV]. *)
val clic_arg : unit -> (output_format option, _) Clic.arg

(** [output fmt_opt ~for_human ~for_script] behaves in one of two ways.
    If [fmt_opt] is [Some _], then it formats the value returned by
    [for_script ()]. The function's return value is formatted as lines of
    columns of values (list of lists of strings). This is to help scripts to
    decode/interpret/parse the output.
    Otherwise, if [fmt_opt] is [None], it calls [for_human ()] which is
    responsible for the whole formatting.

    The optional argument [channel] is used when automatically formatting the
    value returned by [for_script ()]. It has no effect on [for_human ()]. *)
val output :
  ?channel:Lwt_io.output_channel ->
  output_format option ->
  for_human:(unit -> unit tzresult Lwt.t) ->
  for_script:(unit -> string list list) ->
  unit tzresult Lwt.t

(** Same as {!output} but for a single row of data. *)
val output_row :
  ?channel:Lwt_io.output_channel ->
  output_format option ->
  for_human:(unit -> unit tzresult Lwt.t) ->
  for_script:(unit -> string list) ->
  unit tzresult Lwt.t

(** [output_for_human fmt_opt for_human] behaves in either of two ways.
    If [fmt_opt] is [None], then it calls [for_human ()].
    Otherwise, it does nothing.

    Use this function to provide output that is of no interest to automatic
    tools. *)
val output_for_human :
  output_format option -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t
src/lib_clic/unix/scriptable.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter output_format : Type.

Parameter clic_arg : forall {_ : Type},
unit -> Tezos_clic.Clic.arg (option output_format) _.

Parameter output :
(option Lwt_io.output_channel) ->
  (option output_format) ->
    (unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ->
      (unit -> list (list string)) ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).

Parameter output_row :
(option Lwt_io.output_channel) ->
  (option output_format) ->
    (unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ->
      (unit -> list string) ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).

Parameter output_for_human :
(option output_format) ->
  (unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ->
    Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).
src/lib_client_base/client_aliases.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Command line interface - Local Storage for Configuration *)

open Lwt.Infix
open Clic

module type Entity = sig
  type t

  val encoding : t Data_encoding.t

  val of_source : string -> t tzresult Lwt.t

  val to_source : t -> string tzresult Lwt.t

  val name : string
end

module type Alias = sig
  type t

  type fresh_param

  val load : #Client_context.wallet -> (string * t) list tzresult Lwt.t

  val set : #Client_context.wallet -> (string * t) list -> unit tzresult Lwt.t

  val find : #Client_context.wallet -> string -> t tzresult Lwt.t

  val find_opt : #Client_context.wallet -> string -> t option tzresult Lwt.t

  val rev_find : #Client_context.wallet -> t -> string option tzresult Lwt.t

  val name : #Client_context.wallet -> t -> string tzresult Lwt.t

  val mem : #Client_context.wallet -> string -> bool tzresult Lwt.t

  val add :
    force:bool -> #Client_context.wallet -> string -> t -> unit tzresult Lwt.t

  val del : #Client_context.wallet -> string -> unit tzresult Lwt.t

  val update : #Client_context.wallet -> string -> t -> unit tzresult Lwt.t

  val of_source : string -> t tzresult Lwt.t

  val to_source : t -> string tzresult Lwt.t

  val alias_parameter :
    unit -> (string * t, #Client_context.wallet) Clic.parameter

  val alias_param :
    ?name:string ->
    ?desc:string ->
    ('a, (#Client_context.wallet as 'b)) Clic.params ->
    (string * t -> 'a, 'b) Clic.params

  val fresh_alias_param :
    ?name:string ->
    ?desc:string ->
    ('a, (< .. > as 'obj)) Clic.params ->
    (fresh_param -> 'a, 'obj) Clic.params

  val force_switch : unit -> (bool, _) arg

  val of_fresh :
    #Client_context.wallet -> bool -> fresh_param -> string tzresult Lwt.t

  val source_param :
    ?name:string ->
    ?desc:string ->
    ('a, (#Client_context.wallet as 'obj)) Clic.params ->
    (t -> 'a, 'obj) Clic.params

  val source_arg :
    ?long:string ->
    ?placeholder:string ->
    ?doc:string ->
    unit ->
    (t option, (#Client_context.wallet as 'obj)) Clic.arg

  val autocomplete : #Client_context.wallet -> string list tzresult Lwt.t
end

module Alias (Entity : Entity) = struct
  open Client_context

  let wallet_encoding : (string * Entity.t) list Data_encoding.encoding =
    let open Data_encoding in
    list (obj2 (req "name" string) (req "value" Entity.encoding))

  let load (wallet : #wallet) =
    wallet#load Entity.name ~default:[] wallet_encoding

  let set (wallet : #wallet) entries =
    wallet#write Entity.name entries wallet_encoding

  let autocomplete wallet =
    load wallet
    >>= function
    | Error _ -> return_nil | Ok list -> return (List.map fst list)

  let find_opt (wallet : #wallet) name =
    load wallet
    >>=? fun list ->
    try return_some (List.assoc name list) with Not_found -> return_none

  let find (wallet : #wallet) name =
    load wallet
    >>=? fun list ->
    try return (List.assoc name list)
    with Not_found -> failwith "no %s alias named %s" Entity.name name

  let rev_find (wallet : #wallet) v =
    load wallet
    >>=? fun list ->
    try return_some (List.find (fun (_, v') -> v = v') list |> fst)
    with Not_found -> return_none

  let mem (wallet : #wallet) name =
    load wallet
    >>=? fun list ->
    try
      ignore (List.assoc name list) ;
      return_true
    with Not_found -> return_false

  let add ~force (wallet : #wallet) name value =
    let keep = ref false in
    load wallet
    >>=? fun list ->
    ( if force then return_unit
    else
      iter_s
        (fun (n, v) ->
          if n = name && v = value then (
            keep := true ;
            return_unit )
          else if n = name && v <> value then
            failwith
              "another %s is already aliased as %s, use --force to update"
              Entity.name
              n
          else if n <> name && v = value then
            failwith
              "this %s is already aliased as %s, use --force to insert \
               duplicate"
              Entity.name
              n
          else return_unit)
        list )
    >>=? fun () ->
    let list = List.filter (fun (n, _) -> n <> name) list in
    let list = (name, value) :: list in
    if !keep then return_unit
    else wallet#write Entity.name list wallet_encoding

  let del (wallet : #wallet) name =
    load wallet
    >>=? fun list ->
    let list = List.filter (fun (n, _) -> n <> name) list in
    wallet#write Entity.name list wallet_encoding

  let update (wallet : #wallet) name value =
    load wallet
    >>=? fun list ->
    let list =
      List.map (fun (n, v) -> (n, if n = name then value else v)) list
    in
    wallet#write Entity.name list wallet_encoding

  include Entity

  let alias_parameter () =
    parameter ~autocomplete (fun cctxt s ->
        find cctxt s >>=? fun v -> return (s, v))

  let alias_param ?(name = "name")
      ?(desc = "existing " ^ Entity.name ^ " alias") next =
    param ~name ~desc (alias_parameter ()) next

  type fresh_param = Fresh of string

  let of_fresh (wallet : #wallet) force (Fresh s) =
    load wallet
    >>=? fun list ->
    ( if force then return_unit
    else
      iter_s
        (fun (n, v) ->
          if n = s then
            Entity.to_source v
            >>=? fun value ->
            failwith
              "@[<v 2>The %s alias %s already exists.@,\
               The current value is %s.@,\
               Use --force to update@]"
              Entity.name
              n
              value
          else return_unit)
        list )
    >>=? fun () -> return s

  let fresh_alias_param ?(name = "new")
      ?(desc = "new " ^ Entity.name ^ " alias") next =
    param
      ~name
      ~desc
      (parameter (fun (_ : < .. >) s -> return @@ Fresh s))
      next

  let parse_source_string cctxt s =
    match String.split ~limit:1 ':' s with
    | ["alias"; alias] ->
        find cctxt alias
    | ["text"; text] ->
        of_source text
    | ["file"; path] ->
        cctxt#read_file path >>=? of_source
    | _ -> (
        find cctxt s
        >>= function
        | Ok v ->
            return v
        | Error a_errs -> (
            cctxt#read_file s >>=? of_source
            >>= function
            | Ok v ->
                return v
            | Error r_errs -> (
                of_source s
                >>= function
                | Ok v ->
                    return v
                | Error s_errs ->
                    let all_errs = List.flatten [a_errs; r_errs; s_errs] in
                    Lwt.return_error all_errs ) ) )

  let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
    let desc =
      Format.asprintf
        "%s\n\
         Can be a %s name, a file or a raw %s literal. If the parameter is \
         not the name of an existing %s, the client will look for a file \
         containing a %s, and if it does not exist, the argument will be read \
         as a raw %s.\n\
         Use 'alias:name', 'file:path' or 'text:literal' to disable autodetect."
        desc
        Entity.name
        Entity.name
        Entity.name
        Entity.name
        Entity.name
    in
    param ~name ~desc (parameter parse_source_string) next

  let source_arg ?(long = "source " ^ Entity.name) ?(placeholder = "src")
      ?(doc = "") () =
    let doc =
      Format.asprintf
        "%s\n\
         Can be a %s name, a file or a raw %s literal. If the parameter is \
         not the name of an existing %s, the client will look for a file \
         containing a %s, and if it does not exist, the argument will be read \
         as a raw %s.\n\
         Use 'alias:name', 'file:path' or 'text:literal' to disable autodetect."
        doc
        Entity.name
        Entity.name
        Entity.name
        Entity.name
        Entity.name
    in
    arg ~long ~placeholder ~doc (parameter parse_source_string)

  let force_switch () =
    Clic.switch
      ~long:"force"
      ~short:'f'
      ~doc:("overwrite existing " ^ Entity.name)
      ()

  let name (wallet : #wallet) d =
    rev_find wallet d
    >>=? function None -> Entity.to_source d | Some name -> return name
end
src/lib_client_base/client_aliases.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Import Tezos_base__TzPervasives.Clic.

Module Entity.
  Record signature {t : Type} := {
    t := t;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
    of_source : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
    to_source : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
    name : string;
  }.
  Arguments signature : clear implicits.
End Entity.

Module Alias.
  Record signature {t fresh_param : Type} := {
    t := t;
    fresh_param := fresh_param;
    load : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list (string * t)));
    set : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) ->
      (list (string * t)) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
    find_opt : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult (option t));
    rev_find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option string));
    name : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
    mem : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult bool);
    add : forall {_ a : Type}, bool ->
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
        * _) -> string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    del : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    update : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    of_source : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
    to_source : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
    alias_parameter : forall {_ a : Type}, unit ->
      Tezos_base__TzPervasives.Clic.parameter (string * t)
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
          * _);
    alias_param : forall {a b : Type}, (option string) ->
      (option string) ->
        (Tezos_base__TzPervasives.Clic.params a
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    b))))) * b)) ->
          Tezos_base__TzPervasives.Clic.params ((string * t) -> a)
            (((option (Lwt_stream.t string)) *
              ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
                ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                    (((string ->
                      a ->
                        (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                          Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
                      * b))))) * b);
    fresh_alias_param : forall {a obj : Type}, (option string) ->
      (option string) ->
        (Tezos_base__TzPervasives.Clic.params a (obj)) ->
          Tezos_base__TzPervasives.Clic.params (fresh_param -> a) (obj);
    force_switch : forall {_ : Type}, unit ->
      Tezos_base__TzPervasives.Clic.arg bool _;
    of_fresh : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) ->
      bool -> fresh_param -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
    source_param : forall {a obj : Type}, (option string) ->
      (option string) ->
        (Tezos_base__TzPervasives.Clic.params a
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    obj))))) * obj)) ->
          Tezos_base__TzPervasives.Clic.params (t -> a)
            (((option (Lwt_stream.t string)) *
              ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
                ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                    (((string ->
                      a ->
                        (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                          Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
                      * obj))))) * obj);
    source_arg : forall {a obj : Type}, (option string) ->
      (option string) ->
        (option string) ->
          unit ->
            Tezos_base__TzPervasives.Clic.arg (option t)
              (((option (Lwt_stream.t string)) *
                ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
                  ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                    (((string ->
                      a ->
                        (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                          Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                      (((string ->
                        a ->
                          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                            Lwt.t (Tezos_base__TzPervasives.tzresult unit)) *
                        (a)) * obj))))) * obj);
    autocomplete : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list string));
  }.
  Arguments signature : clear implicits.
End Alias.
src/lib_client_base/client_aliases.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type Entity = sig
  type t

  val encoding : t Data_encoding.t

  val of_source : string -> t tzresult Lwt.t

  val to_source : t -> string tzresult Lwt.t

  val name : string
end

module type Alias = sig
  type t

  type fresh_param

  val load : #Client_context.wallet -> (string * t) list tzresult Lwt.t

  val set : #Client_context.wallet -> (string * t) list -> unit tzresult Lwt.t

  val find : #Client_context.wallet -> string -> t tzresult Lwt.t

  val find_opt : #Client_context.wallet -> string -> t option tzresult Lwt.t

  val rev_find : #Client_context.wallet -> t -> string option tzresult Lwt.t

  val name : #Client_context.wallet -> t -> string tzresult Lwt.t

  val mem : #Client_context.wallet -> string -> bool tzresult Lwt.t

  val add :
    force:bool -> #Client_context.wallet -> string -> t -> unit tzresult Lwt.t

  val del : #Client_context.wallet -> string -> unit tzresult Lwt.t

  val update : #Client_context.wallet -> string -> t -> unit tzresult Lwt.t

  val of_source : string -> t tzresult Lwt.t

  val to_source : t -> string tzresult Lwt.t

  val alias_parameter :
    unit -> (string * t, #Client_context.wallet) Clic.parameter

  val alias_param :
    ?name:string ->
    ?desc:string ->
    ('a, (#Client_context.wallet as 'b)) Clic.params ->
    (string * t -> 'a, 'b) Clic.params

  val fresh_alias_param :
    ?name:string ->
    ?desc:string ->
    ('a, (< .. > as 'obj)) Clic.params ->
    (fresh_param -> 'a, 'obj) Clic.params

  val force_switch : unit -> (bool, _) Clic.arg

  val of_fresh :
    #Client_context.wallet -> bool -> fresh_param -> string tzresult Lwt.t

  val source_param :
    ?name:string ->
    ?desc:string ->
    ('a, (#Client_context.wallet as 'obj)) Clic.params ->
    (t -> 'a, 'obj) Clic.params

  val source_arg :
    ?long:string ->
    ?placeholder:string ->
    ?doc:string ->
    unit ->
    (t option, (#Client_context.wallet as 'obj)) Clic.arg

  val autocomplete : #Client_context.wallet -> string list tzresult Lwt.t
end

module Alias (Entity : Entity) : Alias with type t = Entity.t
src/lib_client_base/client_aliases.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

unhandled_module
src/lib_client_base/client_confirmations.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let in_block operation_hash operations =
  let exception Found of int * int in
  try
    List.iteri
      (fun i ops ->
        List.iteri
          (fun j op ->
            if Operation_hash.equal operation_hash op then raise (Found (i, j)))
          ops)
      operations ;
    None
  with Found (i, j) -> Some (i, j)

type operation_status =
  | Confirmed of (Block_hash.t * int * int)
  | Pending
  | Still_not_found

let wait_for_operation_inclusion (ctxt : #Client_context.full) ~chain
    ?(predecessors = 10) ?(confirmations = 1) ?branch operation_hash =
  let exception WrapError of error list in
  let exception Outdated of Operation_hash.t in
  (* Table of known blocks:
     - None: if neither the block or its predecessors contains the operation
     - (Some ((hash, i, j), n)):
          if the `hash` contains the operation in list `i` at position `j`
          and if `hash` denotes the `n-th` predecessors of the block. *)
  let blocks : ((Block_hash.t * int * int) * int) option Block_hash.Table.t =
    Block_hash.Table.create confirmations
  in
  (* Fetch _all_ the 'unknown' predecessors af a block. *)
  let fetch_predecessors (hash, header) =
    let rec loop acc (_hash, header) =
      let predecessor = header.Block_header.predecessor in
      if Block_hash.Table.mem blocks predecessor then return acc
      else
        Chain_services.Blocks.Header.shell_header
          ctxt
          ~chain
          ~block:(`Hash (predecessor, 0))
          ()
        >>=? fun shell ->
        let block = (predecessor, shell) in
        loop (block :: acc) block
    in
    loop [(hash, header.Block_header.shell)] (hash, header.shell)
    >>= function
    | Ok blocks ->
        Lwt.return blocks
    | Error err ->
        ctxt#warning
          "Error while fetching block (ignored): %a"
          pp_print_error
          err
        >>= fun () ->
        (* Will be retried when a new head arrives *)
        Lwt.return_nil
  in
  (* Check whether a block as enough confirmations. This function
     assumes that the block predecessor has been processed already. *)
  let process hash header =
    let block = `Hash (hash, 0) in
    let predecessor = header.Tezos_base.Block_header.predecessor in
    match Block_hash.Table.find blocks predecessor with
    | Some (block_with_op, n) ->
        ctxt#answer
          "Operation received %d confirmations as of block: %a"
          (n + 1)
          Block_hash.pp
          hash
        >>= fun () ->
        Block_hash.Table.add blocks hash (Some (block_with_op, n + 1)) ;
        if n + 1 < confirmations then return Pending
        else return (Confirmed block_with_op)
    | None -> (
        Shell_services.Blocks.Operation_hashes.operation_hashes
          ctxt
          ~chain
          ~block
          ()
        >>=? fun operations ->
        match in_block operation_hash operations with
        | None ->
            Block_hash.Table.add blocks hash None ;
            return Still_not_found
        | Some (i, j) ->
            ctxt#answer
              "Operation found in block: %a (pass: %d, offset: %d)"
              Block_hash.pp
              hash
              i
              j
            >>= fun () ->
            Block_hash.Table.add blocks hash (Some ((hash, i, j), 0)) ;
            if confirmations <= 0 then return (Confirmed (hash, i, j))
            else return Pending )
  in
  (* Checks if the given branch is considered alive.*)
  let check_branch_alive () =
    match branch with
    | Some branch_hash -> (
        Shell_services.Blocks.live_blocks ctxt ~chain ~block:(`Head 0) ()
        >>= function
        | Ok live_blocks ->
            if Block_hash.Set.mem branch_hash live_blocks then Lwt.return_unit
            else
              ctxt#error
                "The operation %a is outdated and may never be included in \
                 the chain.@,\
                 We recommand to use an external block explorer."
                Operation_hash.pp
                operation_hash
              >>= fun () -> Lwt.fail (Outdated operation_hash)
        | Error err ->
            Lwt.fail (WrapError err) )
    | None ->
        Lwt.return_unit
  in
  Shell_services.Monitor.heads ctxt chain
  >>=? fun (stream, stop) ->
  Lwt_stream.get stream
  >>= function
  | None ->
      assert false
  | Some (head, _) ->
      let rec loop n =
        if n >= 0 then
          (*Search for the operation in the n head predecessors*)
          let block = `Hash (head, n) in
          Shell_services.Blocks.hash ctxt ~chain ~block ()
          >>=? fun hash ->
          Shell_services.Blocks.Header.shell_header ctxt ~chain ~block ()
          >>=? fun shell ->
          process hash shell
          >>=? function
          | Confirmed block ->
              stop () ; return block
          | Pending | Still_not_found ->
              loop (n - 1)
        else
          (*Search for the operation in new heads*)
          Lwt.catch
            (fun () ->
              (*Fetching potential unknown blocks from potential new heads*)
              let stream = Lwt_stream.map_list_s fetch_predecessors stream in
              Lwt_stream.find_s
                (fun (hash, header) ->
                  process hash header
                  >>= function
                  | Ok Pending ->
                      Lwt.return_false
                  | Ok Still_not_found ->
                      check_branch_alive () >>= fun () -> Lwt.return_false
                  | Ok (Confirmed _) ->
                      Lwt.return_true
                  | Error err ->
                      Lwt.fail (WrapError err))
                stream
              >>= return)
            (function
              | WrapError e -> Lwt.return_error e | exn -> Lwt.fail exn)
          >>=? function
          | None ->
              failwith "..."
          | Some (hash, _) -> (
              stop () ;
              match Block_hash.Table.find_opt blocks hash with
              | None | Some None ->
                  assert false
              | Some (Some (hash, _)) ->
                  return hash )
      in
      ( match branch with
      | Some branch_hash ->
          Shell_services.Blocks.Header.shell_header
            ctxt
            ~chain
            ~block:(`Hash (branch_hash, 0))
            ()
          >>=? fun branch_header ->
          let branch_level = branch_header.Block_header.level in
          Shell_services.Blocks.Header.shell_header
            ctxt
            ~chain
            ~block:(`Hash (head, 0))
            ()
          >>=? fun head_shell ->
          let head_level = head_shell.Block_header.level in
          return Int32.(to_int (sub head_level branch_level))
      | None ->
          return predecessors )
      >>=? fun block_hook ->
      Block_services.Empty.hash
        ctxt
        ~chain
        ~block:(`Hash (head, block_hook + 1))
        ()
      >>=? fun oldest ->
      Block_hash.Table.add blocks oldest None ;
      loop block_hook

let lookup_operation_in_previous_block ctxt chain operation_hash i =
  Block_services.Empty.hash ctxt ~block:(`Head i) ()
  >>=? fun block ->
  Shell_services.Blocks.Operation_hashes.operation_hashes
    ctxt
    ~chain
    ~block:(`Hash (block, 0))
    ()
  >>=? fun operations ->
  match in_block operation_hash operations with
  | None ->
      return_none
  | Some (a, b) ->
      return_some (block, a, b)

let lookup_operation_in_previous_blocks (ctxt : #Client_context.full) ~chain
    ~predecessors operation_hash =
  let rec loop i =
    if i = predecessors + 1 then return_none
    else
      lookup_operation_in_previous_block ctxt chain operation_hash i
      >>=? function
      | None -> loop (i + 1) | Some (block, a, b) -> return_some (block, a, b)
  in
  loop 0

let wait_for_bootstrapped (ctxt : #Client_context.full) =
  let display = ref false in
  Lwt.async (fun () ->
      ctxt#sleep 0.3
      >>= fun () ->
      if not !display then (
        ctxt#answer
          "Waiting for the node to be bootstrapped before injection..."
        >>= fun () ->
        display := true ;
        Lwt.return_unit )
      else Lwt.return_unit) ;
  Monitor_services.bootstrapped ctxt
  >>=? fun (stream, _stop) ->
  Lwt_stream.iter_s
    (fun (hash, time) ->
      if !display then
        ctxt#message
          "Current head: %a (timestamp: %a, validation: %a)"
          Block_hash.pp_short
          hash
          Time.System.pp_hum
          (Time.System.of_protocol_exn time)
          Time.System.pp_hum
          (ctxt#now ())
      else Lwt.return_unit)
    stream
  >>= fun () ->
  display := true ;
  ctxt#answer "Node is bootstrapped, ready for injecting operations."
  >>= fun () -> return_unit
src/lib_client_base/client_confirmations.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition in_block
  (operation_hash : Tezos_base__TzPervasives.Operation_hash.t)
  (operations : list (list Tezos_base__TzPervasives.Operation_hash.t))
  : option (Z * Z) := let_exception.

Inductive operation_status : Type :=
| Confirmed : (Tezos_base__TzPervasives.Block_hash.t * Z * Z) ->
  operation_status
| Pending : operation_status
| Still_not_found : operation_status.

Definition wait_for_operation_inclusion {F G I a b i o p q : Type}
  (ctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (chain : Tezos_shell_services__Block_services.chain)
  (op_star_o_p_t_star : option Z)
  : (option Z) ->
    (option Tezos_base__TzPervasives.Block_hash.Set.elt) ->
      Tezos_base__TzPervasives.Operation_hash.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Block_hash.t * Z * Z)) :=
  let predecessors :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 10
    end in
  fun op_star_o_p_t_star =>
    let confirmations :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => 1
      end in
    fun branch => fun operation_hash => let_exception.

Definition lookup_operation_in_previous_block {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (chain : Tezos_shell_services__Block_services.chain)
  (operation_hash : Tezos_base__TzPervasives.Operation_hash.t) (i : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell_services.Block_services.Empty.hash ctxt None (Some variant) tt)
    (fun block =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell_services.Shell_services.Blocks.Operation_hashes.operation_hashes
          ctxt (Some chain) (Some variant) tt)
        (fun operations =>
          match in_block operation_hash operations with
          | None => Tezos_base__TzPervasives.return_none
          | Some (a, b) => Tezos_base__TzPervasives.return_some (block, a, b)
          end)).

Definition lookup_operation_in_previous_blocks {F G I a b i o p q : Type}
  (ctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (chain : Tezos_shell_services__Block_services.chain)
  (predecessors : Z)
  (operation_hash : Tezos_base__TzPervasives.Operation_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
  let fix loop (i : Z)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
    if equiv_decb i (Z.add predecessors 1) then
      Tezos_base__TzPervasives.return_none
    else
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (lookup_operation_in_previous_block ctxt chain operation_hash i)
        (fun function_parameter =>
          match function_parameter with
          | None => loop (Z.add i 1)
          | Some (block, a, b) =>
            Tezos_base__TzPervasives.return_some (block, a, b)
          end) in
  loop 0.

Definition wait_for_bootstrapped {F G I a b i o p q : Type}
  (ctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let display := Stdlib.ref false in
  Lwt.async
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq (send 0)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              if negb (Stdlib.op_exclamation display) then
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Waiting for the node to be bootstrapped before injection..."
                          % string CamlinternalFormatBasics.End_of_format)
                      "Waiting for the node to be bootstrapped before injection..."
                        % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Stdlib.op_colon_eq display true;
                      Lwt.return_unit
                    end)
              else
                Lwt.return_unit
            end)
      end);
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell_services.Monitor_services.bootstrapped ctxt)
    (fun function_parameter =>
      match function_parameter with
      | (stream, _stop) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Lwt_stream.iter_s
            (fun function_parameter =>
              match function_parameter with
              | (hash, time) =>
                if Stdlib.op_exclamation display then
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Current head: " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " (timestamp: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                ", validation: " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    ")" % char
                                    CamlinternalFormatBasics.End_of_format)))))))
                      "Current head: %a (timestamp: %a, validation: %a)" %
                        string) Tezos_base__TzPervasives.Block_hash.pp_short
                    hash Tezos_base__TzPervasives.Time.System.pp_hum
                    (Tezos_base__TzPervasives.Time.System.of_protocol_exn time)
                    Tezos_base__TzPervasives.Time.System.pp_hum (send tt)
                else
                  Lwt.return_unit
              end) stream)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Stdlib.op_colon_eq display true;
              Tezos_base__TzPervasives.op_gt_gt_eq
                (send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Node is bootstrapped, ready for injecting operations." %
                        string CamlinternalFormatBasics.End_of_format)
                    "Node is bootstrapped, ready for injecting operations." %
                      string))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            end)
      end).
src/lib_client_base/client_confirmations.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** [wait_for_operation_inclusion chain ~predecessors ~confirmations
    oph] waits for `oph` to appears in the main chain with at least
    `confirmations`. It returns the hash of the block that contains
    the operation and the operation position in the block.

    This functions also looks for the operations in the `predecessors`
    of the initial chain head. *)
val wait_for_operation_inclusion :
  #Client_context.full ->
  chain:Chain_services.chain ->
  ?predecessors:int ->
  ?confirmations:int ->
  ?branch:Block_hash.t ->
  Operation_hash.t ->
  (Block_hash.t * int * int) tzresult Lwt.t

(** lookup an operation in [predecessors] previous blocks, starting
    from head *)
val lookup_operation_in_previous_blocks :
  #Client_context.full ->
  chain:Block_services.chain ->
  predecessors:int ->
  Operation_list_hash.elt ->
  (Block_hash.t * int * int) option tzresult Lwt.t

(** wait for the node to be bootstrapped *)
val wait_for_bootstrapped : #Client_context.full -> unit tzresult Lwt.t
src/lib_client_base/client_confirmations.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter wait_for_operation_inclusion : forall {_ a b i o p q variant : Type},
(((float -> Lwt.t unit) *
  ((unit -> Ptime.t) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      (Uri.t *
        (Tezos_shell_services.Shell_services.block *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              (Tezos_shell_services.Shell_services.chain *
                ((option Z) *
                  ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                    (a * b)) *
                    ((Tezos_rpc.RPC_service.meth ->
                      (option Tezos_data_encoding.Data_encoding.json) ->
                        Uri.t ->
                          Lwt.t
                            (Tezos_rpc.RPC_context.rest_result
                              Tezos_data_encoding.Data_encoding.json
                              (option Tezos_data_encoding.Data_encoding.json)))
                      *
                      (((string ->
                        a ->
                          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a))
                        *
                        ((option (Lwt_stream.t string)) *
                          (((string ->
                            (Tezos_client_base.Client_context.lwt_format a unit)
                              -> a) * (a)) *
                            ((((Tezos_client_base.Client_context.lwt_format a
                              unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                (Tezos_base__TzPervasives.tzresult string)) -> a)
                                * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a
                                  (Tezos_base__TzPervasives.tzresult Bigstring.t))
                                  -> a) * (a)) *
                                  ((string ->
                                    Lwt.t
                                      (Tezos_base__TzPervasives.tzresult string))
                                    *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                                        (((string ->
                                          a ->
                                            (Tezos_base__TzPervasives.Data_encoding.encoding
                                              a) ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  unit)) * (a)) * _)))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    (option Z) ->
      (option Z) ->
        (option Tezos_base__TzPervasives.Block_hash.t) ->
          Tezos_base__TzPervasives.Operation_hash.t ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                (Tezos_base__TzPervasives.Block_hash.t * Z * Z)).

Parameter lookup_operation_in_previous_blocks : forall
{_ a b i o p q variant : Type},
(((float -> Lwt.t unit) *
  ((unit -> Ptime.t) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      (Uri.t *
        (Tezos_shell_services.Shell_services.block *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              (Tezos_shell_services.Shell_services.chain *
                ((option Z) *
                  ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                    (a * b)) *
                    ((Tezos_rpc.RPC_service.meth ->
                      (option Tezos_data_encoding.Data_encoding.json) ->
                        Uri.t ->
                          Lwt.t
                            (Tezos_rpc.RPC_context.rest_result
                              Tezos_data_encoding.Data_encoding.json
                              (option Tezos_data_encoding.Data_encoding.json)))
                      *
                      (((string ->
                        a ->
                          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a))
                        *
                        ((option (Lwt_stream.t string)) *
                          (((string ->
                            (Tezos_client_base.Client_context.lwt_format a unit)
                              -> a) * (a)) *
                            ((((Tezos_client_base.Client_context.lwt_format a
                              unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                (Tezos_base__TzPervasives.tzresult string)) -> a)
                                * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a
                                  (Tezos_base__TzPervasives.tzresult Bigstring.t))
                                  -> a) * (a)) *
                                  ((string ->
                                    Lwt.t
                                      (Tezos_base__TzPervasives.tzresult string))
                                    *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                                        (((string ->
                                          a ->
                                            (Tezos_base__TzPervasives.Data_encoding.encoding
                                              a) ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  unit)) * (a)) * _)))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Block_services.chain ->
    Z ->
      Tezos_base__TzPervasives.Operation_list_hash.elt ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))).

Parameter wait_for_bootstrapped : forall {_ a b i o p q variant : Type},
(((float -> Lwt.t unit) *
  ((unit -> Ptime.t) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      (Uri.t *
        (Tezos_shell_services.Shell_services.block *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              (Tezos_shell_services.Shell_services.chain *
                ((option Z) *
                  ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                    (a * b)) *
                    ((Tezos_rpc.RPC_service.meth ->
                      (option Tezos_data_encoding.Data_encoding.json) ->
                        Uri.t ->
                          Lwt.t
                            (Tezos_rpc.RPC_context.rest_result
                              Tezos_data_encoding.Data_encoding.json
                              (option Tezos_data_encoding.Data_encoding.json)))
                      *
                      (((string ->
                        a ->
                          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a))
                        *
                        ((option (Lwt_stream.t string)) *
                          (((string ->
                            (Tezos_client_base.Client_context.lwt_format a unit)
                              -> a) * (a)) *
                            ((((Tezos_client_base.Client_context.lwt_format a
                              unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                (Tezos_base__TzPervasives.tzresult string)) -> a)
                                * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a
                                  (Tezos_base__TzPervasives.tzresult Bigstring.t))
                                  -> a) * (a)) *
                                  ((string ->
                                    Lwt.t
                                      (Tezos_base__TzPervasives.tzresult string))
                                    *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                                        (((string ->
                                          a ->
                                            (Tezos_base__TzPervasives.Data_encoding.encoding
                                              a) ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  unit)) * (a)) * _)))))))))))))))))))))
  * _) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/lib_client_base/client_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4

class type printer =
  object
    method error : ('a, 'b) lwt_format -> 'a

    method warning : ('a, unit) lwt_format -> 'a

    method message : ('a, unit) lwt_format -> 'a

    method answer : ('a, unit) lwt_format -> 'a

    method log : string -> ('a, unit) lwt_format -> 'a
  end

class type prompter =
  object
    method prompt : ('a, string tzresult) lwt_format -> 'a

    method prompt_password : ('a, Bigstring.t tzresult) lwt_format -> 'a
  end

class type io =
  object
    inherit printer

    inherit prompter
  end

class simple_printer log =
  let message x = Format.kasprintf (fun msg -> log "stdout" msg) x in
  object
    method error : type a b. (a, b) lwt_format -> a =
      Format.kasprintf (fun msg -> Lwt.fail (Failure msg))

    method warning : type a. (a, unit) lwt_format -> a =
      Format.kasprintf (fun msg -> log "stderr" msg)

    method message : type a. (a, unit) lwt_format -> a = message

    method answer : type a. (a, unit) lwt_format -> a = message

    method log : type a. string -> (a, unit) lwt_format -> a =
      fun name -> Format.kasprintf (fun msg -> log name msg)
  end

class type wallet =
  object
    method load_passwords : string Lwt_stream.t option

    method read_file : string -> string tzresult Lwt.t

    method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t

    method load :
      string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t

    method write :
      string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
  end

class type chain =
  object
    method chain : Shell_services.chain
  end

class type block =
  object
    method block : Shell_services.block

    method confirmations : int option
  end

class type io_wallet =
  object
    inherit printer

    inherit prompter

    inherit wallet
  end

class type io_rpcs =
  object
    inherit printer

    inherit prompter

    inherit RPC_context.json
  end

class type ui =
  object
    method sleep : float -> unit Lwt.t

    method now : unit -> Ptime.t
  end

class type full =
  object
    inherit printer

    inherit prompter

    inherit wallet

    inherit RPC_context.json

    inherit chain

    inherit block

    inherit ui
  end

class proxy_context (obj : full) =
  object
    method load_passwords = obj#load_passwords

    method read_file = obj#read_file

    method base = obj#base

    method chain = obj#chain

    method block = obj#block

    method confirmations = obj#confirmations

    method answer : type a. (a, unit) lwt_format -> a = obj#answer

    method call_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
          'q -> 'i -> 'o tzresult Lwt.t =
      obj#call_service

    method call_streamed_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
          on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
          (unit -> unit) tzresult Lwt.t =
      obj#call_streamed_service

    method error : type a b. (a, b) lwt_format -> a = obj#error

    method generic_json_call = obj#generic_json_call

    method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = obj#with_lock

    method load : type a.
        string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
      obj#load

    method log : type a. string -> (a, unit) lwt_format -> a = obj#log

    method message : type a. (a, unit) lwt_format -> a = obj#message

    method warning : type a. (a, unit) lwt_format -> a = obj#warning

    method write : type a.
        string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
      obj#write

    method prompt : type a. (a, string tzresult) lwt_format -> a = obj#prompt

    method prompt_password : type a. (a, Bigstring.t tzresult) lwt_format -> a
        =
      obj#prompt_password

    method sleep : float -> unit Lwt.t = obj#sleep

    method now : unit -> Ptime.t = obj#now
  end

let log _ _ = Lwt.return_unit

let null_printer : #printer = new simple_printer log
src/lib_client_base/client_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition lwt_format (a b : Type) :=
  Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t b).

Definition log {A B : Type} (function_parameter : A) : B -> Lwt.t unit :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ => Lwt.return_unit
      end
  end.

Definition null_printer {a b : Type}
  : ((((lwt_format a b) -> a) * (a * b)) *
    ((((lwt_format a unit) -> a) * (a)) *
      ((((lwt_format a unit) -> a) * (a)) *
        ((((lwt_format a unit) -> a) * (a)) *
          (((string -> (lwt_format a unit) -> a) * (a)) * nil))))) * nil :=
  new log.
src/lib_client_base/client_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4

class type printer =
  object
    method error : ('a, 'b) lwt_format -> 'a

    method warning : ('a, unit) lwt_format -> 'a

    method message : ('a, unit) lwt_format -> 'a

    method answer : ('a, unit) lwt_format -> 'a

    method log : string -> ('a, unit) lwt_format -> 'a
  end

class type prompter =
  object
    method prompt : ('a, string tzresult) lwt_format -> 'a

    method prompt_password : ('a, Bigstring.t tzresult) lwt_format -> 'a
  end

class type io =
  object
    inherit printer

    inherit prompter
  end

class type wallet =
  object
    method load_passwords : string Lwt_stream.t option

    method read_file : string -> string tzresult Lwt.t

    method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t

    method load :
      string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t

    method write :
      string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
  end

class type chain =
  object
    method chain : Shell_services.chain
  end

class type block =
  object
    method block : Shell_services.block

    method confirmations : int option
  end

class type io_wallet =
  object
    inherit printer

    inherit prompter

    inherit wallet
  end

class type io_rpcs =
  object
    inherit printer

    inherit prompter

    inherit RPC_context.json
  end

class type ui =
  object
    method sleep : float -> unit Lwt.t

    method now : unit -> Ptime.t
  end

class type full =
  object
    inherit printer

    inherit prompter

    inherit wallet

    inherit RPC_context.json

    inherit chain

    inherit block

    inherit ui
  end

class simple_printer : (string -> string -> unit Lwt.t) -> printer

class proxy_context : full -> full

val null_printer : printer
src/lib_client_base/client_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition lwt_format (a b : Type) :=
  Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t b).

class_type

class_type

class_type

class_type

class_type

class_type

class_type

class_type

class_type

class_type

class

class

Parameter null_printer : printer.
src/lib_client_base/client_keys.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Unregistered_key_scheme of string

type error += Invalid_uri of Uri.t

let () =
  register_error_kind
    `Permanent
    ~id:"cli.unregistered_key_scheme"
    ~title:"Unregistered key scheme"
    ~description:
      "A key has been provided with an unregistered scheme (no corresponding \
       plugin)"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "No matching plugin for key scheme %s" s)
    Data_encoding.(obj1 (req "value" string))
    (function Unregistered_key_scheme s -> Some s | _ -> None)
    (fun s -> Unregistered_key_scheme s) ;
  register_error_kind
    `Permanent
    ~id:"cli.key.invalid_uri"
    ~title:"Invalid key uri"
    ~description:"A key has been provided with an invalid uri."
    ~pp:(fun ppf s -> Format.fprintf ppf "Cannot parse the key uri: %s" s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_uri s -> Some (Uri.to_string s) | _ -> None)
    (fun s -> Invalid_uri (Uri.of_string s))

module Public_key_hash = struct
  include Client_aliases.Alias (struct
    type t = Signature.Public_key_hash.t

    let encoding = Signature.Public_key_hash.encoding

    let of_source s = Lwt.return (Signature.Public_key_hash.of_b58check s)

    let to_source p = return (Signature.Public_key_hash.to_b58check p)

    let name = "public key hash"
  end)
end

module Logging = struct
  let tag = Tag.def ~doc:"Identity" "pk_alias" Format.pp_print_text
end

let uri_encoding = Data_encoding.(conv Uri.to_string Uri.of_string string)

type pk_uri = Uri.t

let make_pk_uri (x : Uri.t) : pk_uri =
  match Uri.scheme x with
  | None ->
      Pervasives.failwith "PK_URI needs a scheme"
  | Some _ ->
      x

type sk_uri = Uri.t

let make_sk_uri (x : Uri.t) : sk_uri =
  match Uri.scheme x with
  | None ->
      Pervasives.failwith "SK_URI needs a scheme"
  | Some _ ->
      x

let pk_uri_parameter () =
  Clic.parameter (fun _ s ->
      try return (make_pk_uri @@ Uri.of_string s)
      with Failure s -> failwith "Error while parsing URI: %s" s)

let pk_uri_param ?name ?desc params =
  let name = Option.unopt ~default:"uri" name in
  let desc =
    Option.unopt
      ~default:
        "public key\n\
         Varies from one scheme to the other.\n\
         Use command `list signing schemes` for more information."
      desc
  in
  Clic.param ~name ~desc (pk_uri_parameter ()) params

let sk_uri_parameter () =
  Clic.parameter (fun _ s ->
      try return (make_sk_uri @@ Uri.of_string s)
      with Failure s -> failwith "Error while parsing URI: %s" s)

let sk_uri_param ?name ?desc params =
  let name = Option.unopt ~default:"uri" name in
  let desc =
    Option.unopt
      ~default:
        "secret key\n\
         Varies from one scheme to the other.\n\
         Use command `list signing schemes` for more information."
      desc
  in
  Clic.param ~name ~desc (sk_uri_parameter ()) params

module Secret_key = Client_aliases.Alias (struct
  let name = "secret_key"

  type t = Uri.t

  let of_source s = return (Uri.of_string s)

  let to_source t = return (Uri.to_string t)

  let encoding = uri_encoding
end)

module Public_key = Client_aliases.Alias (struct
  let name = "public_key"

  type t = Uri.t * Signature.Public_key.t option

  let of_source s = return (Uri.of_string s, None)

  let to_source (t, _) = return (Uri.to_string t)

  let encoding =
    let open Data_encoding in
    union
      [ case
          Json_only
          ~title:"Locator_only"
          uri_encoding
          (function (uri, None) -> Some uri | (_, Some _) -> None)
          (fun uri -> (uri, None));
        case
          Json_only
          ~title:"Locator_and_full_key"
          (obj2
             (req "locator" uri_encoding)
             (req "key" Signature.Public_key.encoding))
          (function (uri, Some key) -> Some (uri, key) | (_, None) -> None)
          (fun (uri, key) -> (uri, Some key)) ]
end)

module type SIGNER = sig
  val scheme : string

  val title : string

  val description : string

  val neuterize : sk_uri -> pk_uri tzresult Lwt.t

  val import_secret_key :
    io:Client_context.io_wallet ->
    pk_uri ->
    (Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
    Lwt.t

  val public_key : pk_uri -> Signature.Public_key.t tzresult Lwt.t

  val public_key_hash :
    pk_uri ->
    (Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
    Lwt.t

  val sign :
    ?watermark:Signature.watermark ->
    sk_uri ->
    Bytes.t ->
    Signature.t tzresult Lwt.t

  val deterministic_nonce : sk_uri -> Bytes.t -> Bigstring.t tzresult Lwt.t

  val deterministic_nonce_hash : sk_uri -> Bytes.t -> Bytes.t tzresult Lwt.t

  val supports_deterministic_nonces : sk_uri -> bool tzresult Lwt.t
end

let signers_table : (string, (module SIGNER)) Hashtbl.t = Hashtbl.create 13

let register_signer signer =
  let module Signer = (val signer : SIGNER) in
  Hashtbl.replace signers_table Signer.scheme signer

let find_signer_for_key ~scheme =
  match Hashtbl.find_opt signers_table scheme with
  | None ->
      fail (Unregistered_key_scheme scheme)
  | Some signer ->
      return signer

let registered_signers () : (string * (module SIGNER)) list =
  Hashtbl.fold (fun k v acc -> (k, v) :: acc) signers_table []

type error += Signature_mismatch of sk_uri

let () =
  register_error_kind
    `Permanent
    ~id:"cli.signature_mismatch"
    ~title:"Signature mismatch"
    ~description:"The signer produced an invalid signature"
    ~pp:(fun ppf sk ->
      Format.fprintf
        ppf
        "The signer for %a produced an invalid signature"
        Uri.pp_hum
        sk)
    Data_encoding.(obj1 (req "locator" uri_encoding))
    (function Signature_mismatch sk -> Some sk | _ -> None)
    (fun sk -> Signature_mismatch sk)

let with_scheme_signer (uri : Uri.t) (f : (module SIGNER) -> 'a) : 'a =
  match Uri.scheme uri with
  | None ->
      assert false
  | Some scheme ->
      find_signer_for_key ~scheme >>=? fun signer -> f signer

let neuterize sk_uri =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.neuterize sk_uri)

let public_key pk_uri =
  with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
      Signer.public_key pk_uri)

let public_key_hash pk_uri =
  with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
      Signer.public_key_hash pk_uri)

let import_secret_key ~io pk_uri =
  with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
      Signer.import_secret_key ~io pk_uri)

let sign cctxt ?watermark sk_uri buf =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.sign ?watermark sk_uri buf
      >>=? fun signature ->
      Signer.neuterize sk_uri
      >>=? fun pk_uri ->
      Secret_key.rev_find cctxt sk_uri
      >>=? (function
             | None ->
                 public_key pk_uri
             | Some name -> (
                 Public_key.find cctxt name
                 >>=? function
                 | (_, None) ->
                     public_key pk_uri
                     >>=? fun pk ->
                     Public_key.update cctxt name (pk_uri, Some pk)
                     >>=? fun () -> return pk
                 | (_, Some pubkey) ->
                     return pubkey ))
      >>=? fun pubkey ->
      fail_unless
        (Signature.check ?watermark pubkey signature buf)
        (Signature_mismatch sk_uri)
      >>=? fun () -> return signature)

let append cctxt ?watermark loc buf =
  sign cctxt ?watermark loc buf
  >>|? fun signature -> Signature.concat buf signature

let check ?watermark pk_uri signature buf =
  public_key pk_uri
  >>=? fun pk -> return (Signature.check ?watermark pk signature buf)

let deterministic_nonce sk_uri data =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.deterministic_nonce sk_uri data)

let deterministic_nonce_hash sk_uri data =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.deterministic_nonce_hash sk_uri data)

let supports_deterministic_nonces sk_uri =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.supports_deterministic_nonces sk_uri)

let register_key cctxt ?(force = false) (public_key_hash, pk_uri, sk_uri)
    ?public_key name =
  Public_key.add ~force cctxt name (pk_uri, public_key)
  >>=? fun () ->
  Secret_key.add ~force cctxt name sk_uri
  >>=? fun () ->
  Public_key_hash.add ~force cctxt name public_key_hash
  >>=? fun () -> return_unit

let raw_get_key (cctxt : #Client_context.wallet) pkh =
  Public_key_hash.rev_find cctxt pkh
  >>=? (function
         | None ->
             failwith "no keys for the source contract manager"
         | Some n ->
             Secret_key.find_opt cctxt n
             >>=? fun sk_uri ->
             Public_key.find_opt cctxt n
             >>=? (function
                    | None ->
                        return_none
                    | Some (_, Some pk) ->
                        return_some pk
                    | Some (pk_uri, None) ->
                        public_key pk_uri
                        >>=? fun pk ->
                        Public_key.update cctxt n (pk_uri, Some pk)
                        >>=? fun () -> return_some pk)
             >>=? fun pk -> return (n, pk, sk_uri))
  >>= function
  | (Ok (_, None, None) | Error _) as initial_result -> (
      (* try to lookup for a remote key *)
      find_signer_for_key ~scheme:"remote"
      >>=? (fun signer ->
             let module Signer = (val signer : SIGNER) in
             let path = Signature.Public_key_hash.to_b58check pkh in
             let uri = Uri.make ~scheme:Signer.scheme ~path () in
             Signer.public_key uri
             >>=? fun pk -> return (path, Some pk, Some uri))
      >>= function
      | Error _ ->
          Lwt.return initial_result
      | Ok _ as success ->
          Lwt.return success )
  | Ok _ as success ->
      Lwt.return success

let get_key cctxt pkh =
  raw_get_key cctxt pkh
  >>=? function
  | (pkh, Some pk, Some sk) ->
      return (pkh, pk, sk)
  | (_pkh, _pk, None) ->
      failwith "Unknown secret key for %a" Signature.Public_key_hash.pp pkh
  | (_pkh, None, _sk) ->
      failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh

let get_public_key cctxt pkh =
  raw_get_key cctxt pkh
  >>=? function
  | (pkh, Some pk, _sk) ->
      return (pkh, pk)
  | (_pkh, None, _sk) ->
      failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh

let get_keys (cctxt : #Client_context.wallet) =
  Secret_key.load cctxt
  >>=? fun sks ->
  Lwt_list.filter_map_s
    (fun (name, sk_uri) ->
      Public_key_hash.find cctxt name
      >>=? (fun pkh ->
             Public_key.find cctxt name
             >>=? (function
                    | (_, Some pk) ->
                        return pk
                    | (pk_uri, None) ->
                        public_key pk_uri
                        >>=? fun pk ->
                        Public_key.update cctxt name (pk_uri, Some pk)
                        >>=? fun () -> return pk)
             >>=? fun pk -> return (name, pkh, pk, sk_uri))
      >>= function Ok r -> Lwt.return_some r | Error _ -> Lwt.return_none)
    sks
  >>= fun keys -> return keys

let list_keys cctxt =
  Public_key_hash.load cctxt
  >>=? fun l ->
  map_s
    (fun (name, pkh) ->
      raw_get_key cctxt pkh
      >>= function
      | Ok (_name, pk, sk_uri) ->
          return (name, pkh, pk, sk_uri)
      | Error _ ->
          return (name, pkh, None, None))
    l

let alias_keys cctxt name =
  Public_key_hash.find cctxt name
  >>=? fun pkh ->
  raw_get_key cctxt pkh
  >>= function
  | Ok (_name, pk, sk_uri) ->
      return_some (pkh, pk, sk_uri)
  | Error _ ->
      return_none

let force_switch () =
  Clic.switch ~long:"force" ~short:'f' ~doc:"overwrite existing keys" ()
src/lib_client_base/client_keys.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Public_key_hash.

End Public_key_hash.

Module Logging.
  Definition tag : Tezos_base__TzPervasives.Tag.def string :=
    Tezos_base__TzPervasives.Tag.def (Some "Identity" % string)
      "pk_alias" % string Stdlib.Format.pp_print_text.
End Logging.

Definition uri_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding Uri.t :=
  Tezos_base__TzPervasives.Data_encoding.conv Uri.to_string Uri.of_string None
    Tezos_base__TzPervasives.Data_encoding.string.

Definition pk_uri := Uri.t.

Definition make_pk_uri (x : Uri.t) : pk_uri :=
  match Uri.scheme x with
  | None => Stdlib.Pervasives.failwith "PK_URI needs a scheme" % string
  | Some _ => x
  end.

Definition sk_uri := Uri.t.

Definition make_sk_uri (x : Uri.t) : sk_uri :=
  match Uri.scheme x with
  | None => Stdlib.Pervasives.failwith "SK_URI needs a scheme" % string
  | Some _ => x
  end.

Definition pk_uri_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter pk_uri A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)
  end.

Definition pk_uri_param {A B : Type}
  (name : option string) (desc : option string)
  (params : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params (pk_uri -> A) B :=
  let name := Tezos_base__TzPervasives.Option.unopt "uri" % string name in
  let desc :=
    Tezos_base__TzPervasives.Option.unopt
      "public key
Varies from one scheme to the other.
Use command `list signing schemes` for more information."
        % string desc in
  Tezos_base__TzPervasives.Clic.param name desc (pk_uri_parameter tt) params.

Definition sk_uri_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter sk_uri A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)
  end.

Definition sk_uri_param {A B : Type}
  (name : option string) (desc : option string)
  (params : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params (sk_uri -> A) B :=
  let name := Tezos_base__TzPervasives.Option.unopt "uri" % string name in
  let desc :=
    Tezos_base__TzPervasives.Option.unopt
      "secret key
Varies from one scheme to the other.
Use command `list signing schemes` for more information."
        % string desc in
  Tezos_base__TzPervasives.Clic.param name desc (sk_uri_parameter tt) params.

Module SIGNER.
  Record signature := {
    scheme : string;
    title : string;
    description : string;
    neuterize : sk_uri -> Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri);
    import_secret_key : Tezos_client_base.Client_context.io_wallet ->
      pk_uri ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
              (option Tezos_base__TzPervasives.Signature.Public_key.t)));
    public_key : pk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Signature.Public_key.t);
    public_key_hash : pk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
            (option Tezos_base__TzPervasives.Signature.Public_key.t)));
    sign : (option Tezos_base__TzPervasives.Signature.watermark) ->
      sk_uri ->
        Stdlib.Bytes.t ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_base__TzPervasives.Signature.t);
    deterministic_nonce : sk_uri ->
      Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t);
    deterministic_nonce_hash : sk_uri ->
      Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t);
    supports_deterministic_nonces : sk_uri ->
      Lwt.t (Tezos_base__TzPervasives.tzresult bool);
  }.
End SIGNER.

Definition signers_table
  : Stdlib.Hashtbl.t string {_ : unit & SIGNER.signature } :=
  Stdlib.Hashtbl.create None 13.

Definition register_signer (signer : {_ : unit & SIGNER.signature }) : unit :=
  let Signer := projT2 signer in
  Stdlib.Hashtbl.replace signers_table Signer.(SIGNER.scheme) signer.

Definition find_signer_for_key (scheme : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult {_ : unit & SIGNER.signature }) :=
  match Stdlib.Hashtbl.find_opt signers_table scheme with
  | None => Tezos_base__TzPervasives.fail (Unregistered_key_scheme scheme)
  | Some signer => Tezos_base__TzPervasives._return signer
  end.

Definition registered_signers (function_parameter : unit)
  : list (string * {_ : unit & SIGNER.signature }) :=
  match function_parameter with
  | tt =>
    Stdlib.Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc)
      signers_table []
  end.

Definition with_scheme_signer {A : Type}
  (uri : Uri.t)
  (f :
    {_ : unit & SIGNER.signature } ->
      Lwt.t (Tezos_base__TzPervasives.tzresult A))
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  match Uri.scheme uri with
  | None => false
  | Some scheme =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question (find_signer_for_key scheme)
      (fun signer => f signer)
  end.

Definition neuterize (sk_uri : sk_uri)
  : Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.neuterize) sk_uri).

Definition public_key (pk_uri : pk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Public_key.t) :=
  with_scheme_signer pk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.public_key) pk_uri).

Definition public_key_hash (pk_uri : pk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        (option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
  with_scheme_signer pk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.public_key_hash) pk_uri).

Definition import_secret_key
  (io : Tezos_client_base.Client_context.io_wallet) (pk_uri : pk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        (option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
  with_scheme_signer pk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.import_secret_key) io pk_uri).

Definition sign {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (sk_uri : sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Signer.(SIGNER.sign) watermark sk_uri buf)
        (fun signature =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Signer.(SIGNER.neuterize) sk_uri)
            (fun pk_uri =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Secret_key.rev_find cctxt sk_uri)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => public_key pk_uri
                    | Some name =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Public_key.find cctxt name)
                        (fun function_parameter =>
                          match function_parameter with
                          | (_, None) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (public_key pk_uri)
                              (fun pk =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Public_key.update cctxt name
                                    (pk_uri, (Some pk)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives._return pk
                                    end))
                          | (_, Some pubkey) =>
                            Tezos_base__TzPervasives._return pubkey
                          end)
                    end))
                (fun pubkey =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_base__TzPervasives.fail_unless
                      (Tezos_base__TzPervasives.Signature.check watermark pubkey
                        signature buf) (Signature_mismatch sk_uri))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives._return signature
                      end))))).

Definition append {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (loc : sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  Tezos_base__TzPervasives.op_gt_gt_pipe_question (sign cctxt watermark loc buf)
    (fun signature => Tezos_base__TzPervasives.Signature.concat buf signature).

Definition check
  (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (pk_uri : pk_uri) (signature : Tezos_base__TzPervasives.Signature.t)
  (buf : Stdlib.Bytes.t) : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (public_key pk_uri)
    (fun pk =>
      Tezos_base__TzPervasives._return
        (Tezos_base__TzPervasives.Signature.check watermark pk signature buf)).

Definition deterministic_nonce (sk_uri : sk_uri) (data : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.deterministic_nonce) sk_uri data).

Definition deterministic_nonce_hash (sk_uri : sk_uri) (data : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.deterministic_nonce_hash) sk_uri data).

Definition supports_deterministic_nonces (sk_uri : sk_uri)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.supports_deterministic_nonces) sk_uri).

Definition register_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (op_star_o_p_t_star : option bool)
  : (Public_key_hash.t * Uri.t * Secret_key.t) ->
    (option Tezos_base__TzPervasives.Signature.Public_key.t) ->
      string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let force :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun function_parameter =>
    match function_parameter with
    | (public_key_hash, pk_uri, sk_uri) =>
      fun public_key =>
        fun name =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Public_key.add force cctxt name (pk_uri, public_key))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Secret_key.add force cctxt name sk_uri)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Public_key_hash.add force cctxt name public_key_hash)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives.return_unit
                          end)
                    end)
              end)
    end.

Definition raw_get_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Public_key_hash.t)
  : Lwt.t
    (sum
      (string * (option Tezos_base__TzPervasives.Signature.Public_key.t) *
        (option Secret_key.t)) (list Tezos_base__TzPervasives.error)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Public_key_hash.rev_find cctxt pkh)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "no keys for the source contract manager" % string
                CamlinternalFormatBasics.End_of_format)
              "no keys for the source contract manager" % string)
        | Some n =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Secret_key.find_opt cctxt n)
            (fun sk_uri =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Public_key.find_opt cctxt n)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => Tezos_base__TzPervasives.return_none
                    | Some (_, Some pk) =>
                      Tezos_base__TzPervasives.return_some pk
                    | Some (pk_uri, None) =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (public_key pk_uri)
                        (fun pk =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Public_key.update cctxt n (pk_uri, (Some pk)))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_some pk
                              end))
                    end))
                (fun pk => Tezos_base__TzPervasives._return (n, pk, sk_uri)))
        end))
    (fun function_parameter =>
      match function_parameter with
      | (inl (_, None, None) | inr _) as initial_result =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_base__TzPervasives.op_gt_gt_eq_question
            (find_signer_for_key "remote" % string)
            (fun signer =>
              let Signer := projT2 signer in
              let path :=
                Tezos_base__TzPervasives.Signature.Public_key_hash.to_b58check
                  pkh in
              let uri :=
                Uri.make (Some Signer.(SIGNER.scheme)) None None None
                  (Some path) None None tt in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Signer.(SIGNER.public_key) uri)
                (fun pk =>
                  Tezos_base__TzPervasives._return (path, (Some pk), (Some uri)))))
          (fun function_parameter =>
            match function_parameter with
            | inr _ => Lwt._return initial_result
            | (inl _) as success => Lwt._return success
            end)
      | (inl _) as success => Lwt._return success
      end).

Definition get_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (string * Tezos_base__TzPervasives.Signature.Public_key.t * Secret_key.t)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (raw_get_key cctxt pkh)
    (fun function_parameter =>
      match function_parameter with
      | (pkh, Some pk, Some sk) =>
        Tezos_base__TzPervasives._return (pkh, pk, sk)
      | (_pkh, _pk, None) =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Unknown secret key for " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Unknown secret key for %a" % string)
          Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh
      | (_pkh, None, _sk) =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Unknown public key for " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Unknown public key for %a" % string)
          Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh
      end).

Definition get_public_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (string * Tezos_base__TzPervasives.Signature.Public_key.t)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (raw_get_key cctxt pkh)
    (fun function_parameter =>
      match function_parameter with
      | (pkh, Some pk, _sk) => Tezos_base__TzPervasives._return (pkh, pk)
      | (_pkh, None, _sk) =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Unknown public key for " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Unknown public key for %a" % string)
          Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh
      end).

Definition get_keys {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (string * Public_key_hash.t *
          Tezos_base__TzPervasives.Signature.Public_key.t * Secret_key.t))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (Secret_key.load cctxt)
    (fun sks =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt_list.filter_map_s
          (fun function_parameter =>
            match function_parameter with
            | (name, sk_uri) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Public_key_hash.find cctxt name)
                  (fun pkh =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Public_key.find cctxt name)
                        (fun function_parameter =>
                          match function_parameter with
                          | (_, Some pk) => Tezos_base__TzPervasives._return pk
                          | (pk_uri, None) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (public_key pk_uri)
                              (fun pk =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Public_key.update cctxt name
                                    (pk_uri, (Some pk)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives._return pk
                                    end))
                          end))
                      (fun pk =>
                        Tezos_base__TzPervasives._return (name, pkh, pk, sk_uri))))
                (fun function_parameter =>
                  match function_parameter with
                  | inl r => Lwt.return_some r
                  | inr _ => Lwt.return_none
                  end)
            end) sks) (fun keys => Tezos_base__TzPervasives._return keys)).

Definition list_keys {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (string * Public_key_hash.t *
          (option Tezos_base__TzPervasives.Signature.Public_key.t) *
          (option Secret_key.t)))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (Public_key_hash.load cctxt)
    (fun l =>
      Tezos_base__TzPervasives.map_s
        (fun function_parameter =>
          match function_parameter with
          | (name, pkh) =>
            Tezos_base__TzPervasives.op_gt_gt_eq (raw_get_key cctxt pkh)
              (fun function_parameter =>
                match function_parameter with
                | inl (_name, pk, sk_uri) =>
                  Tezos_base__TzPervasives._return (name, pkh, pk, sk_uri)
                | inr _ =>
                  Tezos_base__TzPervasives._return (name, pkh, None, None)
                end)
          end) l).

Definition alias_keys {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (name : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        (Public_key_hash.t *
          (option Tezos_base__TzPervasives.Signature.Public_key.t) *
          (option Secret_key.t)))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Public_key_hash.find cctxt name)
    (fun pkh =>
      Tezos_base__TzPervasives.op_gt_gt_eq (raw_get_key cctxt pkh)
        (fun function_parameter =>
          match function_parameter with
          | inl (_name, pk, sk_uri) =>
            Tezos_base__TzPervasives.return_some (pkh, pk, sk_uri)
          | inr _ => Tezos_base__TzPervasives.return_none
          end)).

Definition force_switch {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.switch "overwrite existing keys" % string
      (Some "f" % char) "force" % string tt
  end.
src/lib_client_base/client_keys.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {2 Cryptographic keys tables } *)

type pk_uri = private Uri.t

type sk_uri = private Uri.t

val pk_uri_parameter : unit -> (pk_uri, 'a) Clic.parameter

val pk_uri_param :
  ?name:string ->
  ?desc:string ->
  ('a, 'b) Clic.params ->
  (pk_uri -> 'a, 'b) Clic.params

val sk_uri_parameter : unit -> (sk_uri, 'a) Clic.parameter

val sk_uri_param :
  ?name:string ->
  ?desc:string ->
  ('a, 'b) Clic.params ->
  (sk_uri -> 'a, 'b) Clic.params

type error += Unregistered_key_scheme of string

type error += Invalid_uri of Uri.t

module Public_key_hash :
  Client_aliases.Alias with type t = Signature.Public_key_hash.t

module Public_key :
  Client_aliases.Alias with type t = pk_uri * Signature.Public_key.t option

module Secret_key : Client_aliases.Alias with type t = sk_uri

module Logging : sig
  val tag : string Tag.def
end

(** {2 Interface for external signing modules.} *)

module type SIGNER = sig
  (** [scheme] is the name of the scheme implemented by this signer
      module. *)
  val scheme : string

  (** [title] is a one-line human readable description of the signer. *)
  val title : string

  (** [description] is a multi-line human readable description of the
      signer, that should include the format of key specifications. *)
  val description : string

  (** [neuterize sk] is the corresponding [pk]. *)
  val neuterize : sk_uri -> pk_uri tzresult Lwt.t

  (** [import_secret_key ~io pk] is the function to be called when
      interactively importing a key-pair and returning the public key
      and its hash.

      Some signer implementations improve long-term security by
      requiring human/manual validation while importing keys, the
      [~io] argument can be used to prompt the user in such case. *)
  val import_secret_key :
    io:Client_context.io_wallet ->
    pk_uri ->
    (Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
    Lwt.t

  (** [public_key pk] is the Ed25519 version of [pk].*)
  val public_key : pk_uri -> Signature.Public_key.t tzresult Lwt.t

  (** [public_key_hash pk] is the hash of [pk].
      As some signers will query the full public key to obtain the hash,
      it can be optionally returned to reduce the amount of queries. *)
  val public_key_hash :
    pk_uri ->
    (Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
    Lwt.t

  (** [sign ?watermark sk data] is signature obtained by signing [data] with
        [sk]. *)
  val sign :
    ?watermark:Signature.watermark ->
    sk_uri ->
    Bytes.t ->
    Signature.t tzresult Lwt.t

  (** [deterministic_nonce sk data] is a nonce obtained
      deterministically from [data] and [sk]. *)
  val deterministic_nonce : sk_uri -> Bytes.t -> Bigstring.t tzresult Lwt.t

  (** [deterministic_nonce_hash sk data] is a nonce hash obtained
      deterministically from [data] and [sk]. *)
  val deterministic_nonce_hash : sk_uri -> Bytes.t -> Bytes.t tzresult Lwt.t

  (** [supports_deterministic_nonces] indicates whether the
      [deterministic_nonce] functionality is supported. *)
  val supports_deterministic_nonces : sk_uri -> bool tzresult Lwt.t
end

(** [register_signer signer] registers first-class module [signer] as
    signer for keys with scheme [(val signer : SIGNER).scheme]. *)
val register_signer : (module SIGNER) -> unit

val registered_signers : unit -> (string * (module SIGNER)) list

val import_secret_key :
  io:Client_context.io_wallet ->
  pk_uri ->
  (Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult Lwt.t

val public_key : pk_uri -> Signature.Public_key.t tzresult Lwt.t

val public_key_hash :
  pk_uri ->
  (Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult Lwt.t

val neuterize : sk_uri -> pk_uri tzresult Lwt.t

val sign :
  #Client_context.wallet ->
  ?watermark:Signature.watermark ->
  sk_uri ->
  Bytes.t ->
  Signature.t tzresult Lwt.t

val append :
  #Client_context.wallet ->
  ?watermark:Signature.watermark ->
  sk_uri ->
  Bytes.t ->
  Bytes.t tzresult Lwt.t

val check :
  ?watermark:Signature.watermark ->
  pk_uri ->
  Signature.t ->
  Bytes.t ->
  bool tzresult Lwt.t

val deterministic_nonce : sk_uri -> Bytes.t -> Bigstring.t tzresult Lwt.t

val deterministic_nonce_hash : sk_uri -> Bytes.t -> Bytes.t tzresult Lwt.t

val supports_deterministic_nonces : sk_uri -> bool tzresult Lwt.t

val register_key :
  #Client_context.wallet ->
  ?force:bool ->
  Signature.Public_key_hash.t * pk_uri * sk_uri ->
  ?public_key:Signature.Public_key.t ->
  string ->
  unit tzresult Lwt.t

val list_keys :
  #Client_context.wallet ->
  (string * Public_key_hash.t * Signature.public_key option * sk_uri option)
  list
  tzresult
  Lwt.t

val alias_keys :
  #Client_context.wallet ->
  string ->
  (Public_key_hash.t * Signature.public_key option * sk_uri option) option
  tzresult
  Lwt.t

val get_key :
  #Client_context.wallet ->
  Public_key_hash.t ->
  (string * Signature.Public_key.t * sk_uri) tzresult Lwt.t

val get_public_key :
  #Client_context.wallet ->
  Public_key_hash.t ->
  (string * Signature.Public_key.t) tzresult Lwt.t

val get_keys :
  #Client_context.wallet ->
  (string * Public_key_hash.t * Signature.Public_key.t * sk_uri) list tzresult
  Lwt.t

val force_switch : unit -> (bool, 'ctx) Clic.arg

(**/**)

val make_pk_uri : Uri.t -> pk_uri

val make_sk_uri : Uri.t -> sk_uri
src/lib_client_base/client_keys.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition pk_uri := Uri.t.

Definition sk_uri := Uri.t.

Parameter pk_uri_parameter : forall {a : Type},
unit -> Tezos_base__TzPervasives.Clic.parameter pk_uri a.

Parameter pk_uri_param : forall {a b : Type},
(option string) ->
  (option string) ->
    (Tezos_base__TzPervasives.Clic.params a b) ->
      Tezos_base__TzPervasives.Clic.params (pk_uri -> a) b.

Parameter sk_uri_parameter : forall {a : Type},
unit -> Tezos_base__TzPervasives.Clic.parameter sk_uri a.

Parameter sk_uri_param : forall {a b : Type},
(option string) ->
  (option string) ->
    (Tezos_base__TzPervasives.Clic.params a b) ->
      Tezos_base__TzPervasives.Clic.params (sk_uri -> a) b.

extensible_type

extensible_type

unhandled_module

unhandled_module

unhandled_module

Module Logging.
  Parameter tag : Tezos_base__TzPervasives.Tag.def string.
End Logging.

module_type

Parameter register_signer : {_ : unit & SIGNER.signature } -> unit.

Parameter registered_signers :
unit -> list (string * {_ : unit & SIGNER.signature }).

Parameter import_secret_key :
Tezos_client_base.Client_context.io_wallet ->
  pk_uri ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
          (option Tezos_base__TzPervasives.Signature.Public_key.t))).

Parameter public_key :
pk_uri ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Public_key.t).

Parameter public_key_hash :
pk_uri ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        (option Tezos_base__TzPervasives.Signature.Public_key.t))).

Parameter neuterize :
sk_uri -> Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri).

Parameter sign : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  (option Tezos_base__TzPervasives.Signature.watermark) ->
    sk_uri ->
      Stdlib.Bytes.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_base__TzPervasives.Signature.t).

Parameter append : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  (option Tezos_base__TzPervasives.Signature.watermark) ->
    sk_uri ->
      Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t).

Parameter check :
(option Tezos_base__TzPervasives.Signature.watermark) ->
  pk_uri ->
    Tezos_base__TzPervasives.Signature.t ->
      Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult bool).

Parameter deterministic_nonce :
sk_uri ->
  Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t).

Parameter deterministic_nonce_hash :
sk_uri ->
  Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t).

Parameter supports_deterministic_nonces :
sk_uri -> Lwt.t (Tezos_base__TzPervasives.tzresult bool).

Parameter register_key : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  (option bool) ->
    (Tezos_base__TzPervasives.Signature.Public_key_hash.t * pk_uri * sk_uri) ->
      (option Tezos_base__TzPervasives.Signature.Public_key.t) ->
        string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter list_keys : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (string * Public_key_hash.t *
          (option Tezos_base__TzPervasives.Signature.public_key) *
          (option sk_uri)))).

Parameter alias_keys : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  string ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option
          (Public_key_hash.t *
            (option Tezos_base__TzPervasives.Signature.public_key) *
            (option sk_uri)))).

Parameter get_key : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Public_key_hash.t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (string * Tezos_base__TzPervasives.Signature.Public_key.t * sk_uri)).

Parameter get_public_key : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Public_key_hash.t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (string * Tezos_base__TzPervasives.Signature.Public_key.t)).

Parameter get_keys : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (string * Public_key_hash.t *
          Tezos_base__TzPervasives.Signature.Public_key.t * sk_uri))).

Parameter force_switch : forall {ctx : Type},
unit -> Tezos_base__TzPervasives.Clic.arg bool ctx.

Parameter make_pk_uri : Uri.t -> pk_uri.

Parameter make_sk_uri : Uri.t -> sk_uri.
src/lib_client_base_unix/client_config.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Command line interface - Configuration and Arguments Parsing *)

type error += Invalid_chain_argument of string

type error += Invalid_block_argument of string

type error += Invalid_protocol_argument of string

type error += Invalid_port_arg of string

type error += Invalid_remote_signer_argument of string

type error += Invalid_wait_arg of string

let () =
  register_error_kind
    `Branch
    ~id:"badChainArgument"
    ~title:"Bad Chain Argument"
    ~description:"Chain argument could not be parsed"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "Value %s is not a value chain reference." s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_chain_argument s -> Some s | _ -> None)
    (fun s -> Invalid_chain_argument s) ;
  register_error_kind
    `Branch
    ~id:"badBlockArgument"
    ~title:"Bad Block Argument"
    ~description:"Block argument could not be parsed"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "Value %s is not a value block reference." s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_block_argument s -> Some s | _ -> None)
    (fun s -> Invalid_block_argument s) ;
  register_error_kind
    `Branch
    ~id:"badProtocolArgument"
    ~title:"Bad Protocol Argument"
    ~description:"Protocol argument could not be parsed"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Value %s does not correspond to any known protocol."
        s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_protocol_argument s -> Some s | _ -> None)
    (fun s -> Invalid_protocol_argument s) ;
  register_error_kind
    `Branch
    ~id:"invalidPortArgument"
    ~title:"Bad Port Argument"
    ~description:"Port argument could not be parsed"
    ~pp:(fun ppf s -> Format.fprintf ppf "Value %s is not a valid TCP port." s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_port_arg s -> Some s | _ -> None)
    (fun s -> Invalid_port_arg s) ;
  register_error_kind
    `Branch
    ~id:"invalid_remote_signer_argument"
    ~title:"Unexpected URI of remote signer"
    ~description:"The remote signer argument could not be parsed"
    ~pp:(fun ppf s -> Format.fprintf ppf "Value '%s' is not a valid URI." s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_remote_signer_argument s -> Some s | _ -> None)
    (fun s -> Invalid_remote_signer_argument s) ;
  register_error_kind
    `Branch
    ~id:"invalidWaitArgument"
    ~title:"Bad Wait Argument"
    ~description:"Wait argument could not be parsed"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Value %s is not a valid number of confirmation, nor 'none'."
        s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_wait_arg s -> Some s | _ -> None)
    (fun s -> Invalid_wait_arg s)

let home = try Sys.getenv "HOME" with Not_found -> "/root"

let default_base_dir = Filename.concat home ".tezos-client"

let default_chain = `Main

let default_block = `Head 0

let ( // ) = Filename.concat

module Cfg_file = struct
  type t = {
    base_dir : string;
    node_addr : string;
    node_port : int;
    tls : bool;
    web_port : int;
    remote_signer : Uri.t option;
    confirmations : int option;
    password_filename : string option;
  }

  let default =
    {
      base_dir = default_base_dir;
      node_addr = "localhost";
      node_port = 8732;
      tls = false;
      web_port = 8080;
      remote_signer = None;
      confirmations = Some 0;
      password_filename = None;
    }

  open Data_encoding

  let encoding =
    conv
      (fun { base_dir;
             node_addr;
             node_port;
             tls;
             web_port;
             remote_signer;
             confirmations;
             password_filename } ->
        ( base_dir,
          Some node_addr,
          Some node_port,
          Some tls,
          Some web_port,
          remote_signer,
          confirmations,
          password_filename ))
      (fun ( base_dir,
             node_addr,
             node_port,
             tls,
             web_port,
             remote_signer,
             confirmations,
             password_filename ) ->
        let node_addr = Option.unopt ~default:default.node_addr node_addr in
        let node_port = Option.unopt ~default:default.node_port node_port in
        let tls = Option.unopt ~default:default.tls tls in
        let web_port = Option.unopt ~default:default.web_port web_port in
        {
          base_dir;
          node_addr;
          node_port;
          tls;
          web_port;
          remote_signer;
          confirmations;
          password_filename;
        })
      (obj8
         (req "base_dir" string)
         (opt "node_addr" string)
         (opt "node_port" int16)
         (opt "tls" bool)
         (opt "web_port" int16)
         (opt "remote_signer" RPC_encoding.uri_encoding)
         (opt "confirmations" int8)
         (opt "password_filename" string))

  let from_json json = Data_encoding.Json.destruct encoding json

  let read fp =
    Lwt_utils_unix.Json.read_file fp >>=? fun json -> return (from_json json)

  let write out cfg =
    Lwt_utils_unix.Json.write_file
      out
      (Data_encoding.Json.construct encoding cfg)
end

type cli_args = {
  chain : Chain_services.chain;
  block : Shell_services.block;
  confirmations : int option;
  password_filename : string option;
  protocol : Protocol_hash.t option;
  print_timings : bool;
  log_requests : bool;
}

let default_cli_args =
  {
    chain = default_chain;
    block = default_block;
    confirmations = Some 0;
    password_filename = None;
    protocol = None;
    print_timings = false;
    log_requests = false;
  }

open Clic

let string_parameter () : (string, #Client_context.full) parameter =
  parameter (fun _ x -> return x)

let chain_parameter () =
  parameter (fun _ chain ->
      match Chain_services.parse_chain chain with
      | Error _ ->
          fail (Invalid_chain_argument chain)
      | Ok chain ->
          return chain)

let block_parameter () =
  parameter (fun _ block ->
      match Block_services.parse_block block with
      | Error _ ->
          fail (Invalid_block_argument block)
      | Ok block ->
          return block)

let wait_parameter () =
  parameter (fun _ wait ->
      match wait with
      | "no" | "none" ->
          return_none
      | _ -> (
        try
          let w = int_of_string wait in
          if 0 <= w then return_some w else fail (Invalid_wait_arg wait)
        with _ -> fail (Invalid_wait_arg wait) ))

let protocol_parameter () =
  parameter (fun _ arg ->
      try
        let (hash, _commands) =
          List.find
            (fun (hash, _commands) ->
              String.has_prefix ~prefix:arg (Protocol_hash.to_b58check hash))
            (Client_commands.get_versions ())
        in
        return_some hash
      with Not_found -> fail (Invalid_protocol_argument arg))

(* Command-line only args (not in config file) *)
let base_dir_arg () =
  arg
    ~long:"base-dir"
    ~short:'d'
    ~placeholder:"path"
    ~doc:
      ( "client data directory\n\
         The directory where the Tezos client will store all its data.\n\
         By default: '" ^ default_base_dir ^ "'." )
    (string_parameter ())

let config_file_arg () =
  arg
    ~long:"config-file"
    ~short:'c'
    ~placeholder:"path"
    ~doc:"configuration file"
    (string_parameter ())

let timings_switch () =
  switch ~long:"timings" ~short:'t' ~doc:"show RPC request times" ()

let chain_arg () =
  default_arg
    ~long:"chain"
    ~placeholder:"hash|tag"
    ~doc:
      "chain on which to apply contextual commands (possible tags are 'main' \
       and 'test')"
    ~default:(Chain_services.to_string default_cli_args.chain)
    (chain_parameter ())

let block_arg () =
  default_arg
    ~long:"block"
    ~short:'b'
    ~placeholder:"hash|tag"
    ~doc:
      "block on which to apply contextual commands (possible tags are 'head' \
       and 'genesis')"
    ~default:(Block_services.to_string default_cli_args.block)
    (block_parameter ())

let wait_arg () =
  arg
    ~long:"wait"
    ~short:'w'
    ~placeholder:"none|<int>"
    ~doc:
      "how many confirmation blocks before to consider an operation as included"
    (wait_parameter ())

let protocol_arg () =
  arg
    ~long:"protocol"
    ~short:'p'
    ~placeholder:"hash"
    ~doc:"use commands of a specific protocol"
    (protocol_parameter ())

let log_requests_switch () =
  switch ~long:"log-requests" ~short:'l' ~doc:"log all requests to the node" ()

(* Command-line args which can be set in config file as well *)
let addr_arg () =
  arg
    ~long:"addr"
    ~short:'A'
    ~placeholder:"IP addr|host"
    ~doc:"IP address of the node"
    (string_parameter ())

let port_arg () =
  arg
    ~long:"port"
    ~short:'P'
    ~placeholder:"number"
    ~doc:"RPC port of the node"
    (parameter (fun _ x ->
         try return (int_of_string x)
         with Failure _ -> fail (Invalid_port_arg x)))

let tls_switch () =
  switch ~long:"tls" ~short:'S' ~doc:"use TLS to connect to node." ()

let remote_signer_arg () =
  arg
    ~long:"remote-signer"
    ~short:'R'
    ~placeholder:"uri"
    ~doc:"URI of the remote signer"
    (parameter (fun _ x -> Tezos_signer_backends_unix.Remote.parse_base_uri x))

let password_filename_arg () =
  arg
    ~long:"password-filename"
    ~short:'f'
    ~placeholder:"filename"
    ~doc:"path to the password filename"
    (string_parameter ())

let read_config_file config_file =
  Lwt_utils_unix.Json.read_file config_file
  >>=? fun cfg_json ->
  try return @@ Cfg_file.from_json cfg_json
  with exn ->
    failwith
      "Can't parse the configuration file: %s@,%a"
      config_file
      (fun ppf exn -> Json_encoding.print_error ppf exn)
      exn

let default_config_file_name = "config"

let commands config_file cfg =
  let open Clic in
  let group =
    {
      Clic.name = "config";
      title = "Commands for editing and viewing the client's config file";
    }
  in
  [ command
      ~group
      ~desc:"Show the config file."
      no_options
      (fixed ["config"; "show"])
      (fun () (cctxt : #Client_context.full) ->
        let pp_cfg ppf cfg =
          Format.fprintf
            ppf
            "%a"
            Data_encoding.Json.pp
            (Data_encoding.Json.construct Cfg_file.encoding cfg)
        in
        if not @@ Sys.file_exists config_file then
          cctxt#warning
            "@[<v 2>Warning: no config file at %s,@,\
             displaying the default configuration.@]"
            config_file
          >>= fun () -> cctxt#warning "%a@," pp_cfg Cfg_file.default >>= return
        else
          read_config_file config_file
          >>=? fun cfg -> cctxt#message "%a@," pp_cfg cfg >>= return);
    command
      ~group
      ~desc:"Reset the config file to the factory defaults."
      no_options
      (fixed ["config"; "reset"])
      (fun () _cctxt -> Cfg_file.(write config_file default));
    command
      ~group
      ~desc:
        "Update the config based on the current cli values.\n\
         Loads the current configuration (default or as specified with \
         `-config-file`), applies alterations from other command line \
         arguments (such as the node's address, etc.), and overwrites the \
         updated configuration file."
      no_options
      (fixed ["config"; "update"])
      (fun () _cctxt -> Cfg_file.(write config_file cfg));
    command
      ~group
      ~desc:
        "Create a config file based on the current CLI values.\n\
         If the `-file` option is not passed, this will initialize the \
         default config file, based on default parameters, altered by other \
         command line options (such as the node's address, etc.).\n\
         Otherwise, it will create a new config file, based on the default \
         parameters (or the the ones specified with `-config-file`), altered \
         by other command line options.\n\
         The command will always fail if the file already exists."
      (args1
         (default_arg
            ~long:"output"
            ~short:'o'
            ~placeholder:"path"
            ~doc:"path at which to create the file"
            ~default:(cfg.base_dir // default_config_file_name)
            (parameter (fun _ctx str -> return str))))
      (fixed ["config"; "init"])
      (fun config_file _cctxt ->
        if not (Sys.file_exists config_file) then
          Cfg_file.(write config_file cfg)
          (* Should be default or command would have failed *)
        else failwith "Config file already exists at location") ]

let global_options () =
  args13
    (base_dir_arg ())
    (config_file_arg ())
    (timings_switch ())
    (chain_arg ())
    (block_arg ())
    (wait_arg ())
    (protocol_arg ())
    (log_requests_switch ())
    (addr_arg ())
    (port_arg ())
    (tls_switch ())
    (remote_signer_arg ())
    (password_filename_arg ())

type parsed_config_args = {
  parsed_config_file : Cfg_file.t option;
  parsed_args : cli_args option;
  config_commands : Client_context.full command list;
  base_dir : string option;
  require_auth : bool;
  password_filename : string option;
}

let default_parsed_config_args =
  {
    parsed_config_file = None;
    parsed_args = None;
    config_commands = [];
    base_dir = None;
    require_auth = false;
    password_filename = None;
  }

let parse_config_args (ctx : #Client_context.full) argv =
  parse_global_options (global_options ()) ctx argv
  >>=? fun ( ( base_dir,
               config_file,
               timings,
               chain,
               block,
               confirmations,
               protocol,
               log_requests,
               node_addr,
               node_port,
               tls,
               remote_signer,
               password_filename ),
             remaining ) ->
  ( match base_dir with
  | None ->
      let base_dir = default_base_dir in
      unless (Sys.file_exists base_dir) (fun () ->
          Lwt_utils_unix.create_dir base_dir >>= return)
      >>=? fun () -> return base_dir
  | Some dir ->
      if not (Sys.file_exists dir) then
        failwith
          "Specified -base-dir does not exist. Please create the directory \
           and try again."
      else if Sys.is_directory dir then return dir
      else failwith "Specified -base-dir must be a directory" )
  >>=? fun base_dir ->
  ( match config_file with
  | None ->
      return @@ (base_dir // default_config_file_name)
  | Some config_file ->
      if Sys.file_exists config_file then return config_file
      else
        failwith
          "Config file specified in option does not exist. Use `client config \
           init` to create one." )
  >>=? fun config_file ->
  let config_dir = Filename.dirname config_file in
  let protocol = match protocol with None -> None | Some p -> p in
  ( if not (Sys.file_exists config_file) then
    return {Cfg_file.default with base_dir}
  else read_config_file config_file )
  >>=? fun cfg ->
  let tls = cfg.tls || tls in
  let node_addr = Option.unopt ~default:cfg.node_addr node_addr in
  let node_port = Option.unopt ~default:cfg.node_port node_port in
  Tezos_signer_backends_unix.Remote.read_base_uri_from_env ()
  >>=? fun remote_signer_env ->
  let remote_signer =
    Option.first_some
      remote_signer
      (Option.first_some remote_signer_env cfg.remote_signer)
  in
  let confirmations = Option.unopt ~default:cfg.confirmations confirmations in
  let cfg =
    {
      cfg with
      tls;
      node_port;
      node_addr;
      remote_signer;
      confirmations;
      password_filename;
    }
  in
  if Sys.file_exists base_dir && not (Sys.is_directory base_dir) then (
    Format.eprintf "%s is not a directory.@." base_dir ;
    exit 1 ) ;
  if Sys.file_exists config_dir && not (Sys.is_directory config_dir) then (
    Format.eprintf "%s is not a directory.@." config_dir ;
    exit 1 ) ;
  Lwt_utils_unix.create_dir config_dir
  >>= fun () ->
  return
    ( {
        default_parsed_config_args with
        parsed_config_file = Some cfg;
        parsed_args =
          Some
            {
              chain;
              block;
              confirmations;
              print_timings = timings;
              log_requests;
              password_filename;
              protocol;
            };
        config_commands = commands config_file cfg;
      },
      remaining )

type t =
  string option
  * string option
  * bool
  * Shell_services.chain
  * Shell_services.block
  * int option option
  * Protocol_hash.t option option
  * bool
  * string option
  * int option
  * bool
  * Uri.t option
  * string option

module type Remote_params = sig
  val authenticate :
    Signature.public_key_hash list -> Bytes.t -> Signature.t tzresult Lwt.t

  val logger : RPC_client_unix.logger
end

let other_registrations : (_ -> (module Remote_params) -> _) option =
  Some
    (fun parsed_config_file (module Remote_params) ->
      Option.iter parsed_config_file.Cfg_file.remote_signer ~f:(fun signer ->
          Client_keys.register_signer
            ( module Tezos_signer_backends_unix.Remote.Make
                       (RPC_client_unix)
                       (struct
                         let default = signer

                         include Remote_params
                       end) )))

let clic_commands ~base_dir:_ ~config_commands ~builtin_commands
    ~other_commands ~require_auth:_ =
  config_commands @ builtin_commands @ other_commands

let logger = None
src/lib_client_base_unix/client_config.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition home : string := try.

Definition default_base_dir : string :=
  Stdlib.Filename.concat home ".tezos-client" % string.

Definition default_chain : variant := variant.

Definition default_block : variant := variant.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Module Cfg_file.
  Record t := {
    base_dir : string;
    node_addr : string;
    node_port : Z;
    tls : bool;
    web_port : Z;
    remote_signer : option Uri.t;
    confirmations : option Z;
    password_filename : option string }.
  
  Definition default : t :=
    {| base_dir := default_base_dir; node_addr := "localhost" % string;
      node_port := 8732; tls := false; web_port := 8080; remote_signer := None;
      confirmations := Some 0; password_filename := None |}.
  
  Import Tezos_base__TzPervasives.Data_encoding.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          base_dir := base_dir;
            node_addr := node_addr;
            node_port := node_port;
            tls := tls;
            web_port := web_port;
            remote_signer := remote_signer;
            confirmations := confirmations;
            password_filename := password_filename
            |} =>
          (base_dir, (Some node_addr), (Some node_port), (Some tls),
            (Some web_port), remote_signer, confirmations, password_filename)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (base_dir, node_addr, node_port, tls, web_port, remote_signer,
            confirmations, password_filename) =>
          let node_addr :=
            Tezos_base__TzPervasives.Option.unopt (node_addr default) node_addr
            in
          let node_port :=
            Tezos_base__TzPervasives.Option.unopt (node_port default) node_port
            in
          let tls := Tezos_base__TzPervasives.Option.unopt (tls default) tls in
          let web_port :=
            Tezos_base__TzPervasives.Option.unopt (web_port default) web_port in
          {| base_dir := base_dir; node_addr := node_addr;
            node_port := node_port; tls := tls; web_port := web_port;
            remote_signer := remote_signer; confirmations := confirmations;
            password_filename := password_filename |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj8
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "base_dir" % string Tezos_base__TzPervasives.Data_encoding.string)
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "node_addr" % string Tezos_base__TzPervasives.Data_encoding.string)
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "node_port" % string Tezos_base__TzPervasives.Data_encoding.int16)
        (Tezos_base__TzPervasives.Data_encoding.opt None None "tls" % string
          Tezos_base__TzPervasives.Data_encoding.bool)
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "web_port" % string Tezos_base__TzPervasives.Data_encoding.int16)
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "remote_signer" % string
          Tezos_base__TzPervasives.RPC_encoding.uri_encoding)
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "confirmations" % string Tezos_base__TzPervasives.Data_encoding.int8)
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "password_filename" % string
          Tezos_base__TzPervasives.Data_encoding.string)).
  
  Definition from_json (json : Tezos_base__TzPervasives.Data_encoding.Json.json)
    : t := Tezos_base__TzPervasives.Data_encoding.Json.destruct encoding json.
  
  Definition read (fp : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file fp)
      (fun json => Tezos_base__TzPervasives._return (from_json json)).
  
  Definition write (out : string) (cfg : t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file out
      (Tezos_base__TzPervasives.Data_encoding.Json.construct encoding cfg).
End Cfg_file.

Record cli_args := {
  chain : Tezos_shell_services.Chain_services.chain;
  block : Tezos_shell_services.Shell_services.block;
  confirmations : option Z;
  password_filename : option string;
  protocol : option Tezos_base__TzPervasives.Protocol_hash.t;
  print_timings : bool;
  log_requests : bool }.

Definition default_cli_args : cli_args :=
  {| chain := default_chain; block := default_block; confirmations := Some 0;
    password_filename := None; protocol := None; print_timings := false;
    log_requests := false |}.

Import Tezos_base__TzPervasives.Clic.

Definition string_parameter {F G I a b i o p q : Type}
  (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter string
    (((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun x => Tezos_base__TzPervasives._return x
        end)
  end.

Definition chain_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_shell_services.Chain_services.chain A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun chain =>
            match Tezos_shell_services.Chain_services.parse_chain chain with
            | inr _ =>
              Tezos_base__TzPervasives.fail (Invalid_chain_argument chain)
            | inl chain => Tezos_base__TzPervasives._return chain
            end
        end)
  end.

Definition block_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_shell_services.Block_services.block A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun block =>
            match Tezos_shell_services.Block_services.parse_block block with
            | inr _ =>
              Tezos_base__TzPervasives.fail (Invalid_block_argument block)
            | inl block => Tezos_base__TzPervasives._return block
            end
        end)
  end.

Definition wait_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter (option Z) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun wait =>
            match wait with
            | "no" % string | "none" % string =>
              Tezos_base__TzPervasives.return_none
            | _ => try
            end
        end)
  end.

Definition protocol_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter
    (option Tezos_base__TzPervasives.Protocol_hash.t) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun arg => try
        end)
  end.

Definition base_dir_arg {F G I a b i o p q : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string)
    (((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg
      (String.append
        "client data directory
The directory where the Tezos client will store all its data.
By default: '"
          % string (String.append default_base_dir "'." % string))
      (Some "d" % char) "base-dir" % string "path" % string
      (string_parameter tt)
  end.

Definition config_file_arg {F G I a b i o p q : Type}
  (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string)
    (((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg "configuration file" % string
      (Some "c" % char) "config-file" % string "path" % string
      (string_parameter tt)
  end.

Definition timings_switch {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.switch "show RPC request times" % string
      (Some "t" % char) "timings" % string tt
  end.

Definition chain_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg Tezos_shell_services.Chain_services.chain
    A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.default_arg
      "chain on which to apply contextual commands (possible tags are 'main' and 'test')"
        % string None "chain" % string "hash|tag" % string
      (Tezos_shell_services.Chain_services.to_string (chain default_cli_args))
      (chain_parameter tt)
  end.

Definition block_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg Tezos_shell_services.Block_services.block
    A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.default_arg
      "block on which to apply contextual commands (possible tags are 'head' and 'genesis')"
        % string (Some "b" % char) "block" % string "hash|tag" % string
      (Tezos_shell_services.Block_services.to_string (block default_cli_args))
      (block_parameter tt)
  end.

Definition wait_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option (option Z)) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg
      "how many confirmation blocks before to consider an operation as included"
        % string (Some "w" % char) "wait" % string "none|<int>" % string
      (wait_parameter tt)
  end.

Definition protocol_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg
    (option (option Tezos_base__TzPervasives.Protocol_hash.t)) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg
      "use commands of a specific protocol" % string (Some "p" % char)
      "protocol" % string "hash" % string (protocol_parameter tt)
  end.

Definition log_requests_switch {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.switch "log all requests to the node" % string
      (Some "l" % char) "log-requests" % string tt
  end.

Definition addr_arg {F G I a b i o p q : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string)
    (((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg "IP address of the node" % string
      (Some "A" % char) "addr" % string "IP addr|host" % string
      (string_parameter tt)
  end.

Definition port_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option Z) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg "RPC port of the node" % string
      (Some "P" % char) "port" % string "number" % string
      (Tezos_base__TzPervasives.Clic.parameter None
        (fun function_parameter =>
          match function_parameter with
          | _ => fun x => try
          end))
  end.

Definition tls_switch {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.switch "use TLS to connect to node." % string
      (Some "S" % char) "tls" % string tt
  end.

Definition remote_signer_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option Uri.t) A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg "URI of the remote signer" % string
      (Some "R" % char) "remote-signer" % string "uri" % string
      (Tezos_base__TzPervasives.Clic.parameter None
        (fun function_parameter =>
          match function_parameter with
          | _ => fun x => Tezos_signer_backends_unix.Remote.parse_base_uri x
          end))
  end.

Definition password_filename_arg {F G I a b i o p q : Type}
  (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string)
    (((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.arg "path to the password filename" % string
      (Some "f" % char) "password-filename" % string "filename" % string
      (string_parameter tt)
  end.

Definition read_config_file (config_file : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Cfg_file.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file config_file)
    (fun cfg_json => try).

Definition default_config_file_name : string := "config" % string.

Definition commands {F G I a b i o p q : Type}
  (config_file : string) (cfg : Cfg_file.t)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  let group :=
    {| Clic.name := "config" % string;
      Clic.title :=
        "Commands for editing and viewing the client's config file" % string |}
    in
  cons
    (Tezos_base__TzPervasives.Clic.command (Some group)
      "Show the config file." % string Tezos_base__TzPervasives.Clic.no_options
      (Tezos_base__TzPervasives.Clic.fixed
        (cons "config" % string (cons "show" % string [])))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun cctxt =>
            let pp_cfg (ppf : Stdlib.Format.formatter) (cfg : Cfg_file.t)
              : unit :=
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                Tezos_base__TzPervasives.Data_encoding.Json.pp
                (Tezos_base__TzPervasives.Data_encoding.Json.construct
                  Cfg_file.encoding cfg) in
            if apply negb (Stdlib.Sys.file_exists config_file) then
              Tezos_base__TzPervasives.op_gt_gt_eq
                (send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Warning: no config file at " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal "," % char
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "displaying the default configuration." % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "@[<v 2>Warning: no config file at %s,@,displaying the default configuration.@]"
                      % string) config_file)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              CamlinternalFormatBasics.End_of_format))
                          "%a@," % string) pp_cfg Cfg_file.default)
                      Tezos_base__TzPervasives._return
                  end)
            else
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (read_config_file config_file)
                (fun cfg =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            CamlinternalFormatBasics.End_of_format))
                        "%a@," % string) pp_cfg cfg)
                    Tezos_base__TzPervasives._return)
        end))
    (cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Reset the config file to the factory defaults." % string
        Tezos_base__TzPervasives.Clic.no_options
        (Tezos_base__TzPervasives.Clic.fixed
          (cons "config" % string (cons "reset" % string [])))
        (fun function_parameter =>
          match function_parameter with
          | tt => fun _cctxt => Cfg_file.write config_file Cfg_file.default
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Update the config based on the current cli values.
Loads the current configuration (default or as specified with `-config-file`), applies alterations from other command line arguments (such as the node's address, etc.), and overwrites the updated configuration file."
            % string Tezos_base__TzPervasives.Clic.no_options
          (Tezos_base__TzPervasives.Clic.fixed
            (cons "config" % string (cons "update" % string [])))
          (fun function_parameter =>
            match function_parameter with
            | tt => fun _cctxt => Cfg_file.write config_file cfg
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Create a config file based on the current CLI values.
If the `-file` option is not passed, this will initialize the default config file, based on default parameters, altered by other command line options (such as the node's address, etc.).
Otherwise, it will create a new config file, based on the default parameters (or the the ones specified with `-config-file`), altered by other command line options.
The command will always fail if the file already exists."
              % string
            (Tezos_base__TzPervasives.Clic.args1
              (Tezos_base__TzPervasives.Clic.default_arg
                "path at which to create the file" % string (Some "o" % char)
                "output" % string "path" % string
                (op_div_div (base_dir cfg) default_config_file_name)
                (Tezos_base__TzPervasives.Clic.parameter None
                  (fun _ctx => fun str => Tezos_base__TzPervasives._return str))))
            (Tezos_base__TzPervasives.Clic.fixed
              (cons "config" % string (cons "init" % string [])))
            (fun config_file =>
              fun _cctxt =>
                if negb (Stdlib.Sys.file_exists config_file) then
                  Cfg_file.write config_file cfg
                else
                  Tezos_base__TzPervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Config file already exists at location" % string
                        CamlinternalFormatBasics.End_of_format)
                      "Config file already exists at location" % string))) []))).

Definition global_options {F G I a b i o p q : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.options
    ((option string) * (option string) * bool *
      Tezos_shell_services.Chain_services.chain *
      Tezos_shell_services.Block_services.block * (option (option Z)) *
      (option (option Tezos_base__TzPervasives.Protocol_hash.t)) * bool *
      (option string) * (option Z) * bool * (option Uri.t) * (option string))
    (((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.args13 (base_dir_arg tt) (config_file_arg tt)
      (timings_switch tt) (chain_arg tt) (block_arg tt) (wait_arg tt)
      (protocol_arg tt) (log_requests_switch tt) (addr_arg tt) (port_arg tt)
      (tls_switch tt) (remote_signer_arg tt) (password_filename_arg tt)
  end.

Record parsed_config_args := {
  parsed_config_file : option Cfg_file.t;
  parsed_args : option cli_args;
  config_commands :
    list
      (Tezos_base__TzPervasives.Clic.command
        Tezos_client_base.Client_context.full);
  base_dir : option string;
  require_auth : bool;
  password_filename : option string }.

Definition default_parsed_config_args : parsed_config_args :=
  {| parsed_config_file := None; parsed_args := None; config_commands := [];
    base_dir := None; require_auth := false; password_filename := None |}.

Definition parse_config_args {F G I a b i o p q : Type}
  (ctx :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (argv : list string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (parsed_config_args * (list string))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.Clic.parse_global_options (global_options tt) ctx
      argv)
    (fun function_parameter =>
      match function_parameter with
      |
        ((base_dir, config_file, timings, chain, block, confirmations, protocol,
          log_requests, node_addr, node_port, tls, remote_signer,
          password_filename), remaining) =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          match base_dir with
          | None =>
            let base_dir := default_base_dir in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.unless (Stdlib.Sys.file_exists base_dir)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_stdlib_unix.Lwt_utils_unix.create_dir None base_dir)
                      Tezos_base__TzPervasives._return
                  end))
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives._return base_dir
                end)
          | Some dir =>
            if negb (Stdlib.Sys.file_exists dir) then
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Specified -base-dir does not exist. Please create the directory and try again."
                      % string CamlinternalFormatBasics.End_of_format)
                  "Specified -base-dir does not exist. Please create the directory and try again."
                    % string)
            else
              if Stdlib.Sys.is_directory dir then
                Tezos_base__TzPervasives._return dir
              else
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Specified -base-dir must be a directory" % string
                      CamlinternalFormatBasics.End_of_format)
                    "Specified -base-dir must be a directory" % string)
          end
          (fun base_dir =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              match config_file with
              | None =>
                apply Tezos_base__TzPervasives._return
                  (op_div_div base_dir default_config_file_name)
              | Some config_file =>
                if Stdlib.Sys.file_exists config_file then
                  Tezos_base__TzPervasives._return config_file
                else
                  Tezos_base__TzPervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Config file specified in option does not exist. Use `client config init` to create one."
                          % string CamlinternalFormatBasics.End_of_format)
                      "Config file specified in option does not exist. Use `client config init` to create one."
                        % string)
              end
              (fun config_file =>
                let config_dir := Stdlib.Filename.dirname config_file in
                let protocol :=
                  match protocol with
                  | None => None
                  | Some p => p
                  end in
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (if negb (Stdlib.Sys.file_exists config_file) then
                    Tezos_base__TzPervasives._return record
                  else
                    read_config_file config_file)
                  (fun cfg =>
                    let tls := orb (tls cfg) tls in
                    let node_addr :=
                      Tezos_base__TzPervasives.Option.unopt (node_addr cfg)
                        node_addr in
                    let node_port :=
                      Tezos_base__TzPervasives.Option.unopt (node_port cfg)
                        node_port in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_signer_backends_unix.Remote.read_base_uri_from_env
                        tt)
                      (fun remote_signer_env =>
                        let remote_signer :=
                          Tezos_base__TzPervasives.Option.first_some
                            remote_signer
                            (Tezos_base__TzPervasives.Option.first_some
                              remote_signer_env (remote_signer cfg)) in
                        let confirmations :=
                          Tezos_base__TzPervasives.Option.unopt
                            (confirmations cfg) confirmations in
                        let cfg := record in
                        if
                          andb (Stdlib.Sys.file_exists base_dir)
                            (negb (Stdlib.Sys.is_directory base_dir)) then
                          Stdlib.Format.eprintf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " is not a directory." % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format)))
                              "%s is not a directory.@." % string) base_dir;
                          Stdlib.exit 1
                        else
                          tt;
                        if
                          andb (Stdlib.Sys.file_exists config_dir)
                            (negb (Stdlib.Sys.is_directory config_dir)) then
                          Stdlib.Format.eprintf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " is not a directory." % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format)))
                              "%s is not a directory.@." % string) config_dir;
                          Stdlib.exit 1
                        else
                          tt;
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_stdlib_unix.Lwt_utils_unix.create_dir None
                            config_dir)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives._return
                                (record, remaining)
                            end)))))
      end).

Definition t :=
  (option string) * (option string) * bool *
    Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block * (option (option Z)) *
    (option (option Tezos_base__TzPervasives.Protocol_hash.t)) * bool *
    (option string) * (option Z) * bool * (option Uri.t) * (option string).

Module Remote_params.
  Record signature := {
    authenticate : (list Tezos_base__TzPervasives.Signature.public_key_hash) ->
      Stdlib.Bytes.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_base__TzPervasives.Signature.t);
    logger : Tezos_rpc_http_client_unix.RPC_client_unix.logger;
  }.
End Remote_params.

Definition other_registrations
  : option (Cfg_file.t -> {_ : unit & Remote_params.signature } -> unit) :=
  Some
    (fun parsed_config_file =>
      fun Remote_params =>
        let Remote_params := projT2 Remote_params in
        Tezos_base__TzPervasives.Option.iter
          (fun signer =>
            Tezos_client_base.Client_keys.register_signer
              unsupported_functor_application)
          (Cfg_file.remote_signer parsed_config_file)).

Definition clic_commands {A B C : Type} (function_parameter : A)
  : (list B) -> (list B) -> (list B) -> C -> list B :=
  match function_parameter with
  | _ =>
    fun config_commands =>
      fun builtin_commands =>
        fun other_commands =>
          fun function_parameter =>
            match function_parameter with
            | _ =>
              OCaml.Stdlib.app config_commands
                (OCaml.Stdlib.app builtin_commands other_commands)
            end
  end.

Definition logger {A : Type} : option A := None.
src/lib_client_base_unix/client_context_unix.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "client.context.unix"
end)

class unix_wallet ~base_dir ~password_filename : Client_context.wallet =
  object (self)
    method load_passwords =
      match password_filename with
      | None ->
          None
      | Some filename ->
          if Sys.file_exists filename then Some (Lwt_io.lines_of_file filename)
          else None

    method read_file path =
      Lwt.catch
        (fun () ->
          Lwt_io.(with_file ~mode:Input path read)
          >>= fun content -> return content)
        (fun exn -> failwith "cannot read file (%s)" (Printexc.to_string exn))

    method private filename alias_name =
      Filename.concat
        base_dir
        (String.map (function ' ' -> '_' | c -> c) alias_name ^ "s")

    method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t =
      fun f ->
        let unlock fd =
          let fd = Lwt_unix.unix_file_descr fd in
          Unix.lockf fd Unix.F_ULOCK 0 ;
          Unix.close fd
        in
        let lock () =
          Lwt_unix.openfile
            (Filename.concat base_dir "wallet_lock")
            Lwt_unix.[O_CREAT; O_WRONLY]
            0o644
          >>= fun fd ->
          Lwt_unix.lockf fd Unix.F_LOCK 0
          >>= fun () ->
          let sighandler =
            Lwt_unix.on_signal Sys.sigint (fun _s -> unlock fd)
          in
          Lwt.return (fd, sighandler)
        in
        lock ()
        >>= fun (fd, sh) ->
        (* catch might be useless if f always uses the error monad *)
        Lwt.catch f (function e -> Lwt.return (unlock fd ; raise e))
        >>= fun res ->
        Lwt.return (unlock fd)
        >>= fun () ->
        Lwt_unix.disable_signal_handler sh ;
        Lwt.return res

    method load : type a.
        string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
      fun alias_name ~default encoding ->
        let filename = self#filename alias_name in
        if not (Sys.file_exists filename) then return default
        else
          Lwt_utils_unix.Json.read_file filename
          |> generic_trace "could not read the %s alias file" alias_name
          >>=? fun json ->
          match Data_encoding.Json.destruct encoding json with
          | exception e ->
              failwith
                "did not understand the %s alias file %s : %s"
                alias_name
                filename
                (Printexc.to_string e)
          | data ->
              return data

    method write : type a.
        string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
      fun alias_name list encoding ->
        Lwt.catch
          (fun () ->
            Lwt_utils_unix.create_dir base_dir
            >>= fun () ->
            let filename = self#filename alias_name in
            let json = Data_encoding.Json.construct encoding list in
            Lwt_utils_unix.Json.write_file filename json)
          (fun exn -> Lwt.return (error_exn exn))
        |> generic_trace "could not write the %s alias file." alias_name
  end

class unix_prompter : Client_context.prompter =
  object
    method prompt : type a. (a, string tzresult) Client_context.lwt_format -> a
        =
      Format.kasprintf (fun msg ->
          print_string msg ;
          let line = read_line () in
          return line)

    method prompt_password : type a.
        (a, Bigstring.t tzresult) Client_context.lwt_format -> a =
      Format.kasprintf (fun msg ->
          print_string msg ;
          let line = Lwt_utils_unix.getpass () in
          return (Bigstring.of_string line))
  end

class unix_logger ~base_dir : Client_context.printer =
  let startup = Format.asprintf "%a" Time.System.pp_hum (Systime_os.now ()) in
  let log channel msg =
    match channel with
    | "stdout" ->
        print_endline msg ; Lwt.return_unit
    | "stderr" ->
        prerr_endline msg ; Lwt.return_unit
    | log ->
        let ( // ) = Filename.concat in
        Lwt_utils_unix.create_dir (base_dir // "logs" // log)
        >>= fun () ->
        Lwt_io.with_file
          ~flags:Unix.[O_APPEND; O_CREAT; O_WRONLY]
          ~mode:Lwt_io.Output
          (base_dir // "logs" // log // startup)
          (fun chan -> Lwt_io.write chan msg)
  in
  object
    inherit Client_context.simple_printer log
  end

class unix_ui : Client_context.ui =
  object
    method sleep f = Lwt_unix.sleep f

    method now = Tezos_stdlib_unix.Systime_os.now
  end

class unix_full ~base_dir ~chain ~block ~confirmations ~password_filename
  ~rpc_config : Client_context.full =
  object
    inherit unix_logger ~base_dir

    inherit unix_prompter

    inherit unix_wallet ~base_dir ~password_filename

    inherit RPC_client_unix.http_ctxt rpc_config Media_type.all_media_types

    inherit unix_ui

    method chain = chain

    method block = block

    method confirmations = confirmations
  end
src/lib_client_base_unix/client_context_unix.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_client_base_unix/client_context_unix.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

class unix_wallet :
  base_dir:string -> password_filename:string option -> Client_context.wallet

class unix_prompter : Client_context.prompter

class unix_logger : base_dir:string -> Client_context.printer

class unix_ui : Client_context.ui

class unix_full :
  base_dir:string
  -> chain:Shell_services.chain
  -> block:Shell_services.block
  -> confirmations:int option
  -> password_filename:string option
  -> rpc_config:RPC_client_unix.config
  -> Client_context.full
src/lib_client_base_unix/client_context_unix.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

class

class

class

class

class
src/lib_client_base_unix/client_main_run.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Command line interface - Main Program *)

open Client_context_unix

let builtin_commands =
  let open Clic in
  [ command
      ~desc:"List the protocol versions that this client understands."
      no_options
      (fixed ["list"; "understood"; "protocols"])
      (fun () (cctxt : #Client_context.full) ->
        Lwt_list.iter_s
          (fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver)
          (Client_commands.get_versions ())
        >>= fun () -> return_unit) ]

module type M = sig
  type t

  val global_options : unit -> (t, Client_context_unix.unix_full) Clic.options

  val parse_config_args :
    #Tezos_client_base.Client_context.full ->
    string list ->
    (Client_config.parsed_config_args * string list) tzresult Lwt.t

  val default_chain : Chain_services.chain

  val default_block : [> `Head of int]

  val default_base_dir : string

  val other_registrations :
    (Client_config.Cfg_file.t -> (module Client_config.Remote_params) -> unit)
    option

  val clic_commands :
    base_dir:string ->
    config_commands:Tezos_client_base.Client_context.full Clic.command list ->
    builtin_commands:Tezos_client_base.Client_context.full Clic.command list ->
    other_commands:Tezos_client_base.Client_context.full Clic.command list ->
    require_auth:bool ->
    Tezos_client_base.Client_context.full Clic.command list

  val logger : RPC_client_unix.logger option
end

(* Main (lwt) entry *)
let main (module C : M) ~select_commands =
  let global_options = C.global_options () in
  let executable_name = Filename.basename Sys.executable_name in
  let (original_args, autocomplete) =
    (* for shell aliases *)
    let rec move_autocomplete_token_upfront acc = function
      | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args ->
          let args = List.rev acc @ args in
          (args, Some (prev_arg, cur_arg, script))
      | x :: rest ->
          move_autocomplete_token_upfront (x :: acc) rest
      | [] ->
          (List.rev acc, None)
    in
    match Array.to_list Sys.argv with
    | _ :: args ->
        move_autocomplete_token_upfront [] args
    | [] ->
        ([], None)
  in
  Random.self_init () ;
  ignore
    Clic.(
      setup_formatter
        Format.std_formatter
        (if Unix.isatty Unix.stdout then Ansi else Plain)
        Short) ;
  ignore
    Clic.(
      setup_formatter
        Format.err_formatter
        (if Unix.isatty Unix.stderr then Ansi else Plain)
        Short) ;
  Internal_event_unix.init ()
  >>= fun () ->
  Lwt.catch
    (fun () ->
      C.parse_config_args
        (new unix_full
           ~chain:C.default_chain
           ~block:C.default_block
           ~confirmations:None
           ~password_filename:None
           ~base_dir:C.default_base_dir
           ~rpc_config:RPC_client_unix.default_config)
        original_args
      >>=? (fun (parsed, remaining) ->
             let parsed_config_file = parsed.Client_config.parsed_config_file
             and parsed_args = parsed.Client_config.parsed_args
             and config_commands = parsed.Client_config.config_commands in
             let base_dir : string =
               match parsed.Client_config.base_dir with
               | Some p ->
                   p
               | None -> (
                 match parsed_config_file with
                 | None ->
                     C.default_base_dir
                 | Some p ->
                     p.Client_config.Cfg_file.base_dir )
             and require_auth = parsed.Client_config.require_auth in
             let rpc_config =
               let rpc_config : RPC_client_unix.config =
                 match parsed_config_file with
                 | None ->
                     RPC_client_unix.default_config
                 | Some parsed_config_file ->
                     {
                       RPC_client_unix.default_config with
                       host =
                         parsed_config_file.Client_config.Cfg_file.node_addr;
                       port =
                         parsed_config_file.Client_config.Cfg_file.node_port;
                       tls = parsed_config_file.Client_config.Cfg_file.tls;
                     }
               in
               match parsed_args with
               | Some parsed_args ->
                   if parsed_args.Client_config.print_timings then
                     let gettimeofday = Unix.gettimeofday in
                     {
                       rpc_config with
                       logger =
                         RPC_client_unix.timings_logger
                           ~gettimeofday
                           Format.err_formatter;
                     }
                   else if parsed_args.Client_config.log_requests then
                     {
                       rpc_config with
                       logger =
                         RPC_client_unix.full_logger Format.err_formatter;
                     }
                   else rpc_config
               | None ->
                   rpc_config
             in
             let client_config =
               new unix_full
                 ~chain:
                   ( match parsed_args with
                   | Some p ->
                       p.Client_config.chain
                   | None ->
                       Client_config.default_chain )
                 ~block:
                   ( match parsed_args with
                   | Some p ->
                       p.Client_config.block
                   | None ->
                       Client_config.default_block )
                 ~confirmations:
                   ( match parsed_args with
                   | Some p ->
                       p.Client_config.confirmations
                   | None ->
                       None )
                 ~password_filename:
                   ( match parsed_args with
                   | Some p ->
                       p.Client_config.password_filename
                   | None ->
                       None )
                 ~base_dir
                 ~rpc_config
             in
             let module Remote_params = struct
               let authenticate pkhs payload =
                 Client_keys.list_keys client_config
                 >>=? fun keys ->
                 match
                   List.filter_map
                     (function
                       | (_, known_pkh, _, Some known_sk_uri)
                         when List.exists
                                (fun pkh ->
                                  Signature.Public_key_hash.equal pkh known_pkh)
                                pkhs ->
                           Some known_sk_uri
                       | _ ->
                           None)
                     keys
                 with
                 | sk_uri :: _ ->
                     Client_keys.sign client_config sk_uri payload
                 | [] ->
                     failwith
                       "remote signer expects authentication signature, but \
                        no authorized key was found in the wallet"

               let logger =
                 (* overriding the logger we might already have with the one from
             module C *)
                 match C.logger with
                 | Some logger ->
                     logger
                 | None ->
                     rpc_config.logger
             end in
             let module Http =
               Tezos_signer_backends.Http.Make
                 (RPC_client_unix)
                 (Remote_params)
             in
             let module Https =
               Tezos_signer_backends.Https.Make
                 (RPC_client_unix)
                 (Remote_params)
             in
             let module Socket =
               Tezos_signer_backends_unix.Socket.Make (Remote_params) in
             Client_keys.register_signer
               ( module Tezos_signer_backends.Encrypted.Make (struct
                 let cctxt = (client_config :> Client_context.prompter)
               end) ) ;
             Client_keys.register_signer
               (module Tezos_signer_backends.Unencrypted) ;
             Client_keys.register_signer
               (module Tezos_signer_backends_unix.Ledger.Signer_implementation) ;
             Client_keys.register_signer (module Socket.Unix) ;
             Client_keys.register_signer (module Socket.Tcp) ;
             Client_keys.register_signer (module Http) ;
             Client_keys.register_signer (module Https) ;
             ( match parsed_config_file with
             | None ->
                 ()
             | Some parsed_config_file -> (
               match C.other_registrations with
               | Some r ->
                   r parsed_config_file (module Remote_params)
               | None ->
                   () ) ) ;
             ( match parsed_args with
             | Some parsed_args ->
                 select_commands
                   (client_config :> RPC_client_unix.http_ctxt)
                   parsed_args
             | None ->
                 return_nil )
             >>=? fun other_commands ->
             let commands =
               Clic.add_manual
                 ~executable_name
                 ~global_options
                 (if Unix.isatty Unix.stdout then Clic.Ansi else Clic.Plain)
                 Format.std_formatter
                 (C.clic_commands
                    ~base_dir
                    ~config_commands
                    ~builtin_commands
                    ~other_commands
                    ~require_auth)
             in
             match autocomplete with
             | Some (prev_arg, cur_arg, script) ->
                 Clic.autocompletion
                   ~script
                   ~cur_arg
                   ~prev_arg
                   ~args:original_args
                   ~global_options
                   commands
                   client_config
                 >>=? fun completions ->
                 List.iter print_endline completions ;
                 return_unit
             | None ->
                 Clic.dispatch commands client_config remaining)
      >>= function
      | Ok () ->
          Lwt.return 0
      | Error [Clic.Help command] ->
          Clic.usage
            Format.std_formatter
            ~executable_name
            ~global_options
            (match command with None -> [] | Some c -> [c]) ;
          Lwt.return 0
      | Error errs ->
          Clic.pp_cli_errors
            Format.err_formatter
            ~executable_name
            ~global_options
            ~default:Error_monad.pp
            errs ;
          Lwt.return 1)
    (function
      | Client_commands.Version_not_found ->
          Format.eprintf
            "@{<error>@{<title>Fatal error@}@} unknown protocol version.@." ;
          Lwt.return 1
      | Failure message ->
          Format.eprintf
            "@{<error>@{<title>Fatal error@}@}@.  @[<h 0>%a@]@."
            Format.pp_print_text
            message ;
          Lwt.return 1
      | exn ->
          Format.printf
            "@{<error>@{<title>Fatal error@}@}@.  @[<h 0>%a@]@."
            Format.pp_print_text
            (Printexc.to_string exn) ;
          Lwt.return 1)
  >>= fun retcode ->
  Format.pp_print_flush Format.err_formatter () ;
  Format.pp_print_flush Format.std_formatter () ;
  Internal_event_unix.close () >>= fun () -> Lwt.return retcode

(* Where all the user friendliness starts *)
let run ?log (module M : M)
    ~(select_commands :
       RPC_client_unix.http_ctxt ->
       Client_config.cli_args ->
       Client_context.full Clic.command list tzresult Lwt.t) =
  Lwt_exit.exit_on ?log Sys.sigint ;
  Lwt_exit.exit_on ?log Sys.sigterm ;
  Pervasives.exit @@ Lwt_main.run @@ Lwt_exit.wrap_promise
  @@ main (module M) ~select_commands
src/lib_client_base_unix/client_main_run.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base_unix.Client_context_unix.

Definition builtin_commands {F G a b i o p q : Type}
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * nil)))))))))))))))))))))
        * nil)) :=
  cons
    (Tezos_base__TzPervasives.Clic.command None
      "List the protocol versions that this client understands." % string
      Tezos_base__TzPervasives.Clic.no_options
      (Tezos_base__TzPervasives.Clic.fixed
        (cons "list" % string
          (cons "understood" % string (cons "protocols" % string []))))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun cctxt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Lwt_list.iter_s
                (fun function_parameter =>
                  match function_parameter with
                  | (ver, _) =>
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format) "%a" % string)
                      Tezos_base__TzPervasives.Protocol_hash.pp_short ver
                  end) (Tezos_client_commands.Client_commands.get_versions tt))
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives.return_unit
                end)
        end)) [].

Module M.
  Record signature {t : Type} := {
    t := t;
    global_options : unit ->
      Tezos_base__TzPervasives.Clic.options t
        Tezos_client_base_unix.Client_context_unix.unix_full;
    parse_config_args : forall {_ a b i o p q variant : Type}, (((float ->
      Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * _)))))))))))))))))))))
      * _) ->
      (list string) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_client_base_unix.Client_config.parsed_config_args *
              (list string)));
    default_chain : Tezos_shell_services.Chain_services.chain;
    default_block : forall {variant : Type}, variant;
    default_base_dir : string;
    other_registrations : option
      (Tezos_client_base_unix.Client_config.Cfg_file.t ->
        {_ : unit &
          Tezos_client_base_unix.Client_config.Remote_params.signature } -> unit);
    clic_commands : string ->
      (list
        (Tezos_base__TzPervasives.Clic.command
          Tezos_client_base.Client_context.full)) ->
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full)) ->
          (list
            (Tezos_base__TzPervasives.Clic.command
              Tezos_client_base.Client_context.full)) ->
            bool ->
              list
                (Tezos_base__TzPervasives.Clic.command
                  Tezos_client_base.Client_context.full);
    logger : option Tezos_rpc_http_client_unix.RPC_client_unix.logger;
  }.
  Arguments signature : clear implicits.
End M.

Definition main (C : {t : _ & M.signature t})
  : (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
    Tezos_client_base_unix.Client_config.cli_args ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list
            (Tezos_base__TzPervasives.Clic.command
              Tezos_client_base.Client_context.full)))) -> Lwt.t Z :=
  let C := projT2 C in
  fun select_commands =>
    let global_options := C.(M.global_options) tt in
    let executable_name := Stdlib.Filename.basename Stdlib.Sys.executable_name
      in
    match
      let fix move_autocomplete_token_upfront
        (acc : list string) (function_parameter : list string)
        : (list string) * (option (string * string * string)) :=
        match function_parameter with
        |
          cons "bash_autocomplete" % string
            (cons prev_arg (cons cur_arg (cons script args))) =>
          let args :=
            OCaml.Stdlib.app (Tezos_base__TzPervasives.List.rev acc) args in
          (args, (Some (prev_arg, cur_arg, script)))
        | cons x rest => move_autocomplete_token_upfront (cons x acc) rest
        | [] => ((Tezos_base__TzPervasives.List.rev acc), None)
        end in
      match Stdlib.Array.to_list Stdlib.Sys.argv with
      | cons _ args => move_autocomplete_token_upfront [] args
      | [] => ([], None)
      end with
    | (original_args, autocomplete) =>
      Stdlib.Random.self_init tt;
      OCaml.Stdlib.ignore
        (Tezos_base__TzPervasives.Clic.setup_formatter
          Stdlib.Format.std_formatter
          (if Unix.isatty Unix.stdout then
            Ansi
          else
            Plain) Short);
      OCaml.Stdlib.ignore
        (Tezos_base__TzPervasives.Clic.setup_formatter
          Stdlib.Format.err_formatter
          (if Unix.isatty Unix.stderr then
            Ansi
          else
            Plain) Short);
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_stdlib_unix.Internal_event_unix.init None None tt)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Lwt.catch
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (C.(M.parse_config_args)
                          (new C.(M.default_base_dir) C.(M.default_chain)
                            C.(M.default_block) None None
                            Tezos_rpc_http_client_unix.RPC_client_unix.default_config)
                          original_args)
                        (fun function_parameter =>
                          match function_parameter with
                          | (parsed, remaining) =>
                            let parsed_config_file
                              : option
                                Tezos_client_base_unix.Client_config.Cfg_file.t :=
                              Client_config.parsed_config_file parsed
                            with parsed_args
                              : option
                                Tezos_client_base_unix.Client_config.cli_args :=
                              Client_config.parsed_args parsed
                            with config_commands
                              : list
                                (Tezos_base__TzPervasives.Clic.command
                                  Tezos_client_base.Client_context.full) :=
                              Client_config.config_commands parsed in
                            let base_dir : string :=
                              match Client_config.base_dir parsed with
                              | Some p => p
                              | None =>
                                match parsed_config_file with
                                | None => C.(M.default_base_dir)
                                | Some p => Client_config.Cfg_file.base_dir p
                                end
                              end
                            with require_auth : bool :=
                              Client_config.require_auth parsed in
                            let rpc_config :=
                              let rpc_config :=
                                match parsed_config_file with
                                | None =>
                                  Tezos_rpc_http_client_unix.RPC_client_unix.default_config
                                | Some parsed_config_file => record
                                end in
                              match parsed_args with
                              | Some parsed_args =>
                                if Client_config.print_timings parsed_args then
                                  let gettimeofday := Unix.gettimeofday in
                                  record
                                else
                                  if Client_config.log_requests parsed_args then
                                    record
                                  else
                                    rpc_config
                              | None => rpc_config
                              end in
                            let client_config :=
                              new base_dir
                                match parsed_args with
                                | Some p => Client_config.chain p
                                | None =>
                                  Tezos_client_base_unix.Client_config.default_chain
                                end
                                match parsed_args with
                                | Some p => Client_config.block p
                                | None =>
                                  Tezos_client_base_unix.Client_config.default_block
                                end
                                match parsed_args with
                                | Some p => Client_config.confirmations p
                                | None => None
                                end
                                match parsed_args with
                                | Some p => Client_config.password_filename p
                                | None => None
                                end rpc_config in
                            let Remote_params :=
                              existT _ unit
                                {|
                                  Tezos_client_base_unix__Client_config.Remote_params.logger :=
                                    match C.(M.logger) with
                                    | Some logger => logger
                                    | None => logger rpc_config
                                    end
                                  |} in
                            let Http := unsupported_functor_application in
                            let Https := unsupported_functor_application in
                            let Socket := unsupported_functor_application in
                            Tezos_client_base.Client_keys.register_signer
                              unsupported_functor_application;
                            Tezos_client_base.Client_keys.register_signer
                              Tezos_signer_backends.Unencrypted;
                            Tezos_client_base.Client_keys.register_signer
                              Tezos_signer_backends_unix.Ledger.Signer_implementation;
                            Tezos_client_base.Client_keys.register_signer
                              Socket.Unix;
                            Tezos_client_base.Client_keys.register_signer
                              Socket.Tcp;
                            Tezos_client_base.Client_keys.register_signer Http;
                            Tezos_client_base.Client_keys.register_signer Https;
                            match parsed_config_file with
                            | None => tt
                            | Some parsed_config_file =>
                              match C.(M.other_registrations) with
                              | Some r => r parsed_config_file Remote_params
                              | None => tt
                              end
                            end;
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              match parsed_args with
                              | Some parsed_args =>
                                select_commands client_config parsed_args
                              | None => Tezos_base__TzPervasives.return_nil
                              end
                              (fun other_commands =>
                                let commands :=
                                  Tezos_base__TzPervasives.Clic.add_manual
                                    executable_name global_options
                                    (if Unix.isatty Unix.stdout then
                                      Clic.Ansi
                                    else
                                      Clic.Plain) Stdlib.Format.std_formatter
                                    (C.(M.clic_commands) base_dir
                                      config_commands builtin_commands
                                      other_commands require_auth) in
                                match autocomplete with
                                | Some (prev_arg, cur_arg, script) =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_base__TzPervasives.Clic.autocompletion
                                      script cur_arg prev_arg original_args
                                      global_options commands client_config)
                                    (fun completions =>
                                      Tezos_base__TzPervasives.List.iter
                                        OCaml.Stdlib.print_endline completions;
                                      Tezos_base__TzPervasives.return_unit)
                                | None =>
                                  Tezos_base__TzPervasives.Clic.dispatch
                                    commands client_config remaining
                                end)
                          end))
                      (fun function_parameter =>
                        match function_parameter with
                        | inl tt => Lwt._return 0
                        | inr (cons (Clic.Help command) []) =>
                          Tezos_base__TzPervasives.Clic.usage
                            Stdlib.Format.std_formatter executable_name
                            global_options
                            match command with
                            | None => []
                            | Some c => cons c []
                            end;
                          Lwt._return 0
                        | inr errs =>
                          Tezos_base__TzPervasives.Clic.pp_cli_errors
                            Stdlib.Format.err_formatter executable_name
                            global_options
                            Tezos_base__TzPervasives.Error_monad.pp errs;
                          Lwt._return 1
                        end)
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | Client_commands.Version_not_found =>
                    Stdlib.Format.eprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_tag
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<error>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<error>" % string))
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_tag
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<title>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<title>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "Fatal error" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_tag
                                  (CamlinternalFormatBasics.String_literal
                                    " unknown protocol version." % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      CamlinternalFormatBasics.End_of_format)))))))
                        "@{<error>@{<title>Fatal error@}@} unknown protocol version.@."
                          % string);
                    Lwt._return 1
                  | OCaml.Failure message =>
                    Stdlib.Format.eprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_tag
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<error>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<error>" % string))
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_tag
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<title>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<title>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "Fatal error" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_tag
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    (CamlinternalFormatBasics.String_literal
                                      "  " % string
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<h 0>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<h 0>" % string))
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format)))))))))))
                        "@{<error>@{<title>Fatal error@}@}@.  @[<h 0>%a@]@." %
                          string) Stdlib.Format.pp_print_text message;
                    Lwt._return 1
                  | exn =>
                    Stdlib.Format.printf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_tag
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<error>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<error>" % string))
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_tag
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<title>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<title>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "Fatal error" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_tag
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    (CamlinternalFormatBasics.String_literal
                                      "  " % string
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<h 0>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<h 0>" % string))
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format)))))))))))
                        "@{<error>@{<title>Fatal error@}@}@.  @[<h 0>%a@]@." %
                          string) Stdlib.Format.pp_print_text
                      (Stdlib.Printexc.to_string exn);
                    Lwt._return 1
                  end))
              (fun retcode =>
                Stdlib.Format.pp_print_flush Stdlib.Format.err_formatter tt;
                Stdlib.Format.pp_print_flush Stdlib.Format.std_formatter tt;
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_stdlib_unix.Internal_event_unix.close tt)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Lwt._return retcode
                    end))
          end)
    end.

Definition run {A : Type}
  (log : option (string -> unit)) (M : {t : _ & M.signature t})
  : (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
    Tezos_client_base_unix.Client_config.cli_args ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list
            (Tezos_base__TzPervasives.Clic.command
              Tezos_client_base.Client_context.full)))) -> A :=
  let M := projT2 M in
  fun select_commands =>
    Tezos_stdlib_unix.Lwt_exit.exit_on log Stdlib.Sys.sigint;
    Tezos_stdlib_unix.Lwt_exit.exit_on log Stdlib.Sys.sigterm;
    apply Stdlib.Pervasives.exit
      (apply Lwt_main.run
        (apply Tezos_stdlib_unix.Lwt_exit.wrap_promise (main M select_commands))).
src/lib_client_base_unix/client_main_run.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type M = (* This module type lists the parameters you can give to the
                   function [run] defined below; most calls use and will use the
                   default value for this module type, which is module
                   [Client_config] (client_config.ml). Another instance of this
                   module type is in main_signer.ml *)
sig
  type t

  val global_options :
    (* Global options for the CLI. The presence of (unit ->) is
       because of weak type variables. *)
    unit ->
    (t, Client_context_unix.unix_full) Clic.options

  val parse_config_args :
    (* How to parse CLI arguments *)
    #Tezos_client_base.Client_context.full ->
    string list ->
    (Client_config.parsed_config_args * string list) tzresult Lwt.t

  val default_chain : Chain_services.chain

  val default_block : [> `Head of int]

  val default_base_dir :
    (* You may use the default base directory in [Client_config] or
       define your own one. *)
    string

  val other_registrations :
    (* You may give an **optional** function that will work on the
       configuration file and the remote parameters. *)
    (Client_config.Cfg_file.t -> (module Client_config.Remote_params) -> unit)
    option

  val clic_commands :
    base_dir:(* This function defines how you put together different types of
       commands. Default (in [Client_config]) is to simply append the lists
       together. Arguments [base_dir] and [require_auth] are to be used
       if you need them, default (in [Client_config]) is to ignore them. *)
             string ->
    config_commands:Tezos_client_base.Client_context.full Clic.command list ->
    builtin_commands:Tezos_client_base.Client_context.full Clic.command list ->
    other_commands:Tezos_client_base.Client_context.full Clic.command list ->
    require_auth:bool ->
    Tezos_client_base.Client_context.full Clic.command list

  val logger :
    (* Provide your own [logger] here if you need to override the
       logger that might come from elsewhere. Default (in [Client_config]) is
       [None], but [Main_signer] uses this overriding feature. *)
    RPC_client_unix.logger option
end

val run :
  ?log:(string -> unit) ->
  (module M) ->
  select_commands:(RPC_client_unix.http_ctxt ->
                  Client_config.cli_args ->
                  Client_context.full Clic.command list tzresult Lwt.t) ->
  unit
src/lib_client_base_unix/client_main_run.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

Parameter run :
(option (string -> unit)) ->
  {t : _ & M.signature t} ->
    (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
      Tezos_client_base_unix.Client_config.cli_args ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list
              (Tezos_base__TzPervasives.Clic.command
                Tezos_client_base.Client_context.full)))) -> unit.
src/lib_client_commands/client_admin_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let block_param ~name ~desc t =
  Clic.param
    ~name
    ~desc
    (Clic.parameter (fun _ str -> Lwt.return (Block_hash.of_b58check str)))
    t

let commands () =
  let open Clic in
  let group =
    {
      name = "admin";
      title = "Commands to perform privileged operations on the node";
    }
  in
  [ command
      ~group
      ~desc:"Make the node forget its decision of rejecting blocks."
      no_options
      ( prefixes ["unmark"; "invalid"]
      @@ seq_of_param
           (block_param
              ~name:"block"
              ~desc:"blocks to remove from invalid list") )
      (fun () blocks (cctxt : #Client_context.full) ->
        iter_s
          (fun block ->
            Shell_services.Invalid_blocks.delete cctxt block
            >>=? fun () ->
            cctxt#message
              "Block %a no longer marked invalid."
              Block_hash.pp
              block
            >>= fun () -> return_unit)
          blocks);
    command
      ~group
      ~desc:"Make the node forget every decision of rejecting blocks."
      no_options
      (prefixes ["unmark"; "all"; "invalid"; "blocks"] @@ stop)
      (fun () (cctxt : #Client_context.full) ->
        Shell_services.Invalid_blocks.list cctxt ()
        >>=? fun invalid_blocks ->
        iter_s
          (fun {Chain_services.hash; _} ->
            Shell_services.Invalid_blocks.delete cctxt hash
            >>=? fun () ->
            cctxt#message
              "Block %a no longer marked invalid."
              Block_hash.pp_short
              hash
            >>= fun () -> return_unit)
          invalid_blocks);
    command
      ~group
      ~desc:
        "Retrieve the current checkpoint and display it in a format \
         compatible with node argument `--checkpoint`."
      no_options
      (fixed ["show"; "current"; "checkpoint"])
      (fun () (cctxt : #Client_context.full) ->
        Shell_services.Chain.checkpoint cctxt ~chain:cctxt#chain ()
        >>=? fun (block_header, save_point, caboose, history_mode) ->
        cctxt#message
          "@[<v 0>Checkpoint: %s@,\
           Checkpoint level: %ld@,\
           History mode: %a@,\
           Save point level: %ld@,\
           Caboose level: %ld@]"
          (Block_header.to_b58check block_header)
          block_header.shell.level
          History_mode.pp
          history_mode
          save_point
          caboose
        >>= fun () -> return ()) ]
src/lib_client_commands/client_admin_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition block_param {A B : Type}
  (name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.Block_hash.t -> A) B :=
  Tezos_base__TzPervasives.Clic.param name desc
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun str =>
            Lwt._return (Tezos_base__TzPervasives.Block_hash.of_b58check str)
        end)) t.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  match function_parameter with
  | tt =>
    let group :=
      {| name := "admin" % string;
        title :=
          "Commands to perform privileged operations on the node" % string |} in
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Make the node forget its decision of rejecting blocks." % string
        Tezos_base__TzPervasives.Clic.no_options
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "unmark" % string (cons "invalid" % string [])))
          (Tezos_base__TzPervasives.Clic.seq_of_param
            (block_param "block" % string
              "blocks to remove from invalid list" % string)))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun blocks =>
              fun cctxt =>
                Tezos_base__TzPervasives.iter_s
                  (fun block =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell_services.Shell_services.Invalid_blocks.delete
                        cctxt None block)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Block " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " no longer marked invalid." % string
                                      CamlinternalFormatBasics.End_of_format)))
                                "Block %a no longer marked invalid." % string)
                              Tezos_base__TzPervasives.Block_hash.pp block)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        end)) blocks
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Make the node forget every decision of rejecting blocks." % string
          Tezos_base__TzPervasives.Clic.no_options
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "unmark" % string
                (cons "all" % string
                  (cons "invalid" % string (cons "blocks" % string [])))))
            Tezos_base__TzPervasives.Clic.stop)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              fun cctxt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_shell_services.Shell_services.Invalid_blocks.list cctxt
                    None tt)
                  (fun invalid_blocks =>
                    Tezos_base__TzPervasives.iter_s
                      (fun function_parameter =>
                        match function_parameter with
                        | {| Chain_services.hash := hash |} =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_shell_services.Shell_services.Invalid_blocks.delete
                              cctxt None hash)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Block " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            " no longer marked invalid." %
                                              string
                                            CamlinternalFormatBasics.End_of_format)))
                                      "Block %a no longer marked invalid." %
                                        string)
                                    Tezos_base__TzPervasives.Block_hash.pp_short
                                    hash)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end)
                              end)
                        end) invalid_blocks)
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Retrieve the current checkpoint and display it in a format compatible with node argument `--checkpoint`."
              % string Tezos_base__TzPervasives.Clic.no_options
            (Tezos_base__TzPervasives.Clic.fixed
              (cons "show" % string
                (cons "current" % string (cons "checkpoint" % string []))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_shell_services.Shell_services.Chain.checkpoint cctxt
                      (Some send) tt)
                    (fun function_parameter =>
                      match function_parameter with
                      | (block_header, save_point, caboose, history_mode) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 0>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 0>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "Checkpoint: " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "Checkpoint level: " % string
                                        (CamlinternalFormatBasics.Int32
                                          CamlinternalFormatBasics.Int_d
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.No_precision
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@," % string 0 0)
                                            (CamlinternalFormatBasics.String_literal
                                              "History mode: " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@," % string 0 0)
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Save point level: " %
                                                      string
                                                    (CamlinternalFormatBasics.Int32
                                                      CamlinternalFormatBasics.Int_d
                                                      CamlinternalFormatBasics.No_padding
                                                      CamlinternalFormatBasics.No_precision
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@," % string 0 0)
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Caboose level: " %
                                                            string
                                                          (CamlinternalFormatBasics.Int32
                                                            CamlinternalFormatBasics.Int_d
                                                            CamlinternalFormatBasics.No_padding
                                                            CamlinternalFormatBasics.No_precision
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Close_box
                                                              CamlinternalFormatBasics.End_of_format))))))))))))))))
                              "@[<v 0>Checkpoint: %s@,Checkpoint level: %ld@,History mode: %a@,Save point level: %ld@,Caboose level: %ld@]"
                                % string)
                            (Tezos_base__TzPervasives.Block_header.to_b58check
                              block_header) (level (shell block_header))
                            Tezos_shell_services.History_mode.pp history_mode
                            save_point caboose)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives._return tt
                            end)
                      end)
              end)) []))
  end.
src/lib_client_commands/client_admin_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> #Client_context.full Clic.command list
src/lib_client_commands/client_admin_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands : forall {_ a b i o p q variant : Type},
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (_ * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (_ * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * _)))))))))))))))))))))
        * _)).
src/lib_client_commands/client_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_context

type command = full Clic.command

type network = [`Mainnet | `Alphanet | `Zeronet | `Sandbox]

exception Version_not_found

let versions = Protocol_hash.Table.create 7

let get_versions () =
  Protocol_hash.Table.fold (fun k c acc -> (k, c) :: acc) versions []

let register name commands =
  let previous =
    try Protocol_hash.Table.find versions name
    with Not_found -> fun (_network : network option) -> ([] : command list)
  in
  Protocol_hash.Table.replace versions name (fun (network : network option) ->
      commands network @ previous network)

let commands_for_version version =
  try Protocol_hash.Table.find versions version
  with Not_found -> raise Version_not_found
src/lib_client_commands/client_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base.Client_context.

Definition command :=
  Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full.

Definition network := variant.

Definition versions
  : Tezos_base__TzPervasives.Protocol_hash.Table.t
    ((option network) -> list command) :=
  Tezos_base__TzPervasives.Protocol_hash.Table.create 7.

Definition get_versions (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Protocol_hash.Table.key *
      ((option network) -> list command)) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Protocol_hash.Table.fold
      (fun k => fun c => fun acc => cons (k, c) acc) versions []
  end.

Definition register
  (name : Tezos_base__TzPervasives.Protocol_hash.Table.key)
  (commands : (option network) -> list command) : unit :=
  let previous := try in
  Tezos_base__TzPervasives.Protocol_hash.Table.replace versions name
    (fun network => OCaml.Stdlib.app (commands network) (previous network)).

Definition commands_for_version
  (version : Tezos_base__TzPervasives.Protocol_hash.Table.key)
  : (option network) -> list command := try.
src/lib_client_commands/client_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_context

type command = full Clic.command

type network = [`Mainnet | `Alphanet | `Zeronet | `Sandbox]

exception Version_not_found

val register : Protocol_hash.t -> (network option -> command list) -> unit

val commands_for_version : Protocol_hash.t -> network option -> command list

val get_versions :
  unit -> (Protocol_hash.t * (network option -> command list)) list
src/lib_client_commands/client_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition command :=
  Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full.

Definition network := variant.

exception

Parameter register :
Tezos_base__TzPervasives.Protocol_hash.t ->
  ((option network) -> list command) -> unit.

Parameter commands_for_version :
Tezos_base__TzPervasives.Protocol_hash.t -> (option network) -> list command.

Parameter get_versions :
unit ->
  list
    (Tezos_base__TzPervasives.Protocol_hash.t *
      ((option network) -> list command)).
src/lib_client_commands/client_event_logging_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let group =
  Clic.
    {
      name = "event-logging-framework";
      title = "Commands to inspect the event-logging framework";
    }

let date_parameter option_name build =
  let open Clic in
  parameter (fun _ s ->
      let problem fmt = Printf.ksprintf invalid_arg fmt in
      try
        if String.length s <> 8 then problem "date should be `YYYYMMDD`" ;
        String.iteri
          (fun idx -> function '0' .. '9' -> () | other ->
                problem "character %d is not a digit: '%c'." idx other)
          s ;
        let month = int_of_string (String.sub s 4 2) - 1 in
        if month < 0 then problem "The month cannot be '00'" ;
        if month > 11 then problem "The month cannot be more than '12'" ;
        let day = int_of_string (String.sub s 6 2) in
        if day > 31 then problem "The month cannot be more than '31'" ;
        let t =
          let tm =
            Unix.
              {
                tm_sec = 0;
                tm_min = 0;
                tm_hour = 0;
                tm_mday = day;
                tm_mon = month;
                tm_year = int_of_string (String.sub s 0 4) - 1900;
                tm_wday = 0;
                tm_yday = 0;
                tm_isdst = false;
              }
          in
          Unix.mktime tm |> fst
        in
        return (build t)
      with
      | Invalid_argument e ->
          failwith "In `%s %S`, %s" option_name s e
      | e ->
          failwith "Exn: %a" pp_exn e)

let flat_pp pp o =
  Format.(
    asprintf
      "%a"
      (fun fmt () ->
        pp_set_margin fmt 2_000_000 ;
        pp fmt o)
      ())

let commands () =
  let open Clic in
  let command ~desc = command ~group ~desc in
  [ command
      ~desc:"Query the events from an event sink."
      (args7
         (arg
            ~doc:"Filter on event names"
            ~long:"names"
            ~placeholder:"LIST"
            (parameter (fun _ s ->
                 try return (String.split_on_char ',' s)
                 with _ -> failwith "List of names cannot be parsed")))
         (arg
            ~doc:"Filter on event sections (use '_' for no-section)"
            ~long:"sections"
            ~placeholder:"LIST"
            (parameter (fun _ s ->
                 try
                   return
                     ( String.split_on_char ',' s
                     |> List.map (function "_" -> None | other -> Some other)
                     )
                 with _ -> failwith "List of sections cannot be parsed")))
         (arg
            ~doc:"Filter out events before DATE"
            ~long:"since"
            ~placeholder:"DATE"
            (date_parameter "--since" (fun s -> `Date (`Ge, s))))
         (arg
            ~doc:"Filter out events after DATE"
            ~long:"until"
            ~placeholder:"DATE"
            (date_parameter "--until" (fun s -> `Date (`Le, s))))
         (switch
            ~doc:"Display events as JSON instead of pretty-printing them"
            ~long:"as-json"
            ())
         (switch ~doc:"Try to display unknown events" ~long:"dump-unknown" ())
         (Scriptable.clic_arg ()))
      ( prefixes ["query"; "events"; "from"]
      @@ param
           ~name:"Sink-Name"
           ~desc:"The URI of the SINK to query"
           (parameter (fun _ s ->
                try return (Uri.of_string s)
                with _ -> failwith "Uri cannot be parsed"))
      @@ stop )
      (fun ( only_names,
             only_sections,
             since,
             until,
             as_json,
             dump_unknown,
             scriptable )
           uri
           (cctxt : #Client_context.full) ->
        let open Tezos_stdlib_unix in
        match Uri.scheme uri with
        | None | Some "unix-files" -> (
            let script_row kind date evname data () =
              [kind; date; evname; data]
            in
            Scriptable.output_for_human scriptable (fun () ->
                cctxt#message "### Events" >>= fun () -> return_unit)
            >>=? fun () ->
            let on_unknown =
              if not dump_unknown then None
              else
                Some
                  (fun path ->
                    Scriptable.output_row
                      scriptable
                      ~for_human:(fun () ->
                        cctxt#message "Unknown: %s" path
                        >>= fun () ->
                        Lwt_stream.iter_s
                          (fun line -> cctxt#message "    |%s" line)
                          (Lwt_io.lines_of_file path)
                        >>= fun () -> return_unit)
                      ~for_script:(script_row "unknown-event" "-" "-" path))
            in
            let time_query =
              match (since, until) with
              | (None, None) ->
                  None
              | (Some a, None) | (None, Some a) ->
                  Some a
              | (Some a, Some b) ->
                  Some (`And (a, b))
            in
            File_event_sink.Query.fold
              ?only_names
              ?on_unknown
              ?only_sections
              ?time_query
              uri
              ~init:()
              ~f:(fun () ~time_stamp ev ->
                let o = Internal_event.Generic.explode_event ev in
                let time_string time_value =
                  let open Unix in
                  let tm = gmtime time_value in
                  Printf.sprintf
                    "%04d%02d%02d-%02d%02d%02d-%04d"
                    (1900 + tm.tm_year)
                    (tm.tm_mon + 1)
                    tm.tm_mday
                    tm.tm_hour
                    tm.tm_min
                    tm.tm_sec
                    ( (time_value -. floor time_value) *. 10_000.
                    |> int_of_float )
                in
                let pp fmt o =
                  if as_json then Data_encoding.Json.pp fmt o#json
                  else o#pp fmt ()
                in
                Scriptable.output_row
                  scriptable
                  ~for_human:(fun () ->
                    cctxt#message
                      "@[<2>* [%s %s]@ %a@]"
                      (time_string time_stamp)
                      o#name
                      pp
                      o
                    >>= fun () -> return_unit)
                  ~for_script:(fun () ->
                    let text = flat_pp pp o in
                    script_row "event" (time_string time_stamp) o#name text ()))
            >>=? function
            | ([], ()) ->
                return_unit
            | (errors_and_warnings, ()) ->
                let open Format in
                Scriptable.output
                  scriptable
                  ~for_human:(fun () ->
                    cctxt#message
                      "### Some things were not perfect:@.@[<2>%a@]"
                      (pp_print_list
                         ~pp_sep:(fun fmt () -> fprintf fmt "@.")
                         (fun fmt item ->
                           fprintf
                             fmt
                             "* %a"
                             File_event_sink.Query.Report.pp
                             item))
                      errors_and_warnings
                    >>= fun () -> return_unit)
                  ~for_script:(fun () ->
                    let make_row e =
                      let text = flat_pp File_event_sink.Query.Report.pp e in
                      let tag =
                        match e with
                        | `Error _ ->
                            "error"
                        | `Warning _ ->
                            "warning"
                      in
                      script_row tag "-" "-" text ()
                    in
                    List.map make_row errors_and_warnings) )
        | Some other ->
            cctxt#message "URI scheme %S not handled as of now." other
            >>= fun () -> return_unit);
    command
      ~desc:
        "Display configuration/state information about the internal-event \
         logging framework."
      no_options
      (prefixes ["show"; "event-logging"] @@ stop)
      (fun () (cctxt : #Client_context.full) ->
        let pp_event_definitions fmt schs =
          let open Format in
          pp_open_box fmt 0 ;
          pp_print_list
            ~pp_sep:(fun fmt () -> fprintf fmt "@;")
            (fun fmt obj_schema ->
              pp_open_box fmt 2 ;
              fprintf fmt "* `%s`:@ " obj_schema#name ;
              pp_print_text fmt obj_schema#doc ;
              pp_close_box fmt ())
            fmt
            schs ;
          pp_close_box fmt ()
        in
        cctxt#message
          "Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a"
          Internal_event.All_sinks.pp_state
          ()
          pp_event_definitions
          Internal_event.(
            All_definitions.get () |> List.map Generic.json_schema)
        >>= fun () -> return_unit);
    command
      ~desc:"Output the JSON schema of an internal-event."
      no_options
      ( prefixes ["output"; "schema"; "of"]
      @@ param
           ~name:"Event-Name"
           ~desc:"Name of the event"
           (parameter (fun _ s -> return s))
      @@ prefix "to"
      @@ param
           ~name:"File-path"
           ~desc:"Path to a JSON file"
           (parameter (fun _ s -> return s))
      @@ stop )
      (fun () event path (cctxt : #Client_context.full) ->
        let open Internal_event in
        match All_definitions.find (( = ) event) with
        | None ->
            failwith "Event %S not found" event
        | Some ev ->
            let o = Generic.json_schema ev in
            Lwt_io.with_file ~mode:Lwt_io.output path (fun chan ->
                let v = Format.asprintf "%a" Json_schema.pp o#schema in
                Lwt_io.write chan v)
            >>= fun () ->
            cctxt#message "Wrote schema of %s to %s" event path
            >>= fun () -> return_unit) ]
src/lib_client_commands/client_event_logging_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| name := "event-logging-framework" % string;
    title := "Commands to inspect the event-logging framework" % string |}.

Definition date_parameter {A B : Type}
  (option_name : string) (build : float -> A)
  : Tezos_base__TzPervasives.Clic.parameter A B :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun s =>
          let problem {C D : Type} (fmt : Stdlib.format4 C unit string D) : C :=
            Stdlib.Printf.ksprintf OCaml.Stdlib.invalid_arg fmt in
          try
      end).

Definition flat_pp {A : Type}
  (pp : Stdlib.Format.formatter -> A -> unit) (o : A) : string :=
  Stdlib.Format.asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
      "%a" % string)
    (fun fmt =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Stdlib.Format.pp_set_margin fmt 2000000;
          pp fmt o
        end) tt.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  match function_parameter with
  | tt =>
    let command {J K L : Type} (desc : string)
      : (Tezos_base__TzPervasives.Clic.options J K) ->
        (Tezos_base__TzPervasives.Clic.params L K) ->
          (J -> L) -> Tezos_base__TzPervasives.Clic.command K :=
      Tezos_base__TzPervasives.Clic.command (Some group) desc in
    cons
      (command "Query the events from an event sink." % string
        (Tezos_base__TzPervasives.Clic.args7
          (Tezos_base__TzPervasives.Clic.arg "Filter on event names" % string
            None "names" % string "LIST" % string
            (Tezos_base__TzPervasives.Clic.parameter None
              (fun function_parameter =>
                match function_parameter with
                | _ => fun s => try
                end)))
          (Tezos_base__TzPervasives.Clic.arg
            "Filter on event sections (use '_' for no-section)" % string None
            "sections" % string "LIST" % string
            (Tezos_base__TzPervasives.Clic.parameter None
              (fun function_parameter =>
                match function_parameter with
                | _ => fun s => try
                end)))
          (Tezos_base__TzPervasives.Clic.arg
            "Filter out events before DATE" % string None "since" % string
            "DATE" % string
            (date_parameter "--since" % string (fun s => variant)))
          (Tezos_base__TzPervasives.Clic.arg
            "Filter out events after DATE" % string None "until" % string
            "DATE" % string
            (date_parameter "--until" % string (fun s => variant)))
          (Tezos_base__TzPervasives.Clic.switch
            "Display events as JSON instead of pretty-printing them" % string
            None "as-json" % string tt)
          (Tezos_base__TzPervasives.Clic.switch
            "Try to display unknown events" % string None
            "dump-unknown" % string tt) (Tezos_clic_unix.Scriptable.clic_arg tt))
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "query" % string
              (cons "events" % string (cons "from" % string []))))
          (apply
            (Tezos_base__TzPervasives.Clic.param "Sink-Name" % string
              "The URI of the SINK to query" % string
              (Tezos_base__TzPervasives.Clic.parameter None
                (fun function_parameter =>
                  match function_parameter with
                  | _ => fun s => try
                  end))) Tezos_base__TzPervasives.Clic.stop))
        (fun function_parameter =>
          match function_parameter with
          |
            (only_names, only_sections, since, until, as_json, dump_unknown,
              scriptable) =>
            fun uri =>
              fun cctxt =>
                match Uri.scheme uri with
                | None | Some "unix-files" % string =>
                  let script_row {J : Type}
                    (kind : J) (date : J) (evname : J) (data : J)
                    (function_parameter : unit) : list J :=
                    match function_parameter with
                    | tt => cons kind (cons date (cons evname (cons data [])))
                    end in
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_clic_unix.Scriptable.output_for_human scriptable
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "### Events" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "### Events" % string))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        end))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        let on_unknown :=
                          if negb dump_unknown then
                            None
                          else
                            Some
                              (fun path =>
                                Tezos_clic_unix.Scriptable.output_row None
                                  scriptable
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Unknown: " % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.End_of_format))
                                            "Unknown: %s" % string) path)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (Lwt_stream.iter_s
                                                (fun line =>
                                                  send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "    |" % string
                                                        (CamlinternalFormatBasics.String
                                                          CamlinternalFormatBasics.No_padding
                                                          CamlinternalFormatBasics.End_of_format))
                                                      "    |%s" % string) line)
                                                (Lwt_io.lines_of_file path))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.return_unit
                                                end)
                                          end)
                                    end)
                                  (script_row "unknown-event" % string
                                    "-" % string "-" % string path)) in
                        let time_query :=
                          match (since, until) with
                          | (None, None) => None
                          | (Some a, None) | (None, Some a) => Some a
                          | (Some a, Some b) => Some variant
                          end in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_stdlib_unix.File_event_sink.Query.fold
                            on_unknown only_sections only_names time_query uri
                            tt
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                fun time_stamp =>
                                  fun ev =>
                                    let o :=
                                      Tezos_base__TzPervasives.Internal_event.Generic.explode_event
                                        ev in
                                    let time_string (time_value : float)
                                      : string :=
                                      let tm := Unix.gmtime time_value in
                                      Stdlib.Printf.sprintf
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Int
                                            CamlinternalFormatBasics.Int_d
                                            (CamlinternalFormatBasics.Lit_padding
                                              CamlinternalFormatBasics.Zeros 4)
                                            CamlinternalFormatBasics.No_precision
                                            (CamlinternalFormatBasics.Int
                                              CamlinternalFormatBasics.Int_d
                                              (CamlinternalFormatBasics.Lit_padding
                                                CamlinternalFormatBasics.Zeros 2)
                                              CamlinternalFormatBasics.No_precision
                                              (CamlinternalFormatBasics.Int
                                                CamlinternalFormatBasics.Int_d
                                                (CamlinternalFormatBasics.Lit_padding
                                                  CamlinternalFormatBasics.Zeros
                                                  2)
                                                CamlinternalFormatBasics.No_precision
                                                (CamlinternalFormatBasics.Char_literal
                                                  "-" % char
                                                  (CamlinternalFormatBasics.Int
                                                    CamlinternalFormatBasics.Int_d
                                                    (CamlinternalFormatBasics.Lit_padding
                                                      CamlinternalFormatBasics.Zeros
                                                      2)
                                                    CamlinternalFormatBasics.No_precision
                                                    (CamlinternalFormatBasics.Int
                                                      CamlinternalFormatBasics.Int_d
                                                      (CamlinternalFormatBasics.Lit_padding
                                                        CamlinternalFormatBasics.Zeros
                                                        2)
                                                      CamlinternalFormatBasics.No_precision
                                                      (CamlinternalFormatBasics.Int
                                                        CamlinternalFormatBasics.Int_d
                                                        (CamlinternalFormatBasics.Lit_padding
                                                          CamlinternalFormatBasics.Zeros
                                                          2)
                                                        CamlinternalFormatBasics.No_precision
                                                        (CamlinternalFormatBasics.Char_literal
                                                          "-" % char
                                                          (CamlinternalFormatBasics.Int
                                                            CamlinternalFormatBasics.Int_d
                                                            (CamlinternalFormatBasics.Lit_padding
                                                              CamlinternalFormatBasics.Zeros
                                                              4)
                                                            CamlinternalFormatBasics.No_precision
                                                            CamlinternalFormatBasics.End_of_format)))))))))
                                          "%04d%02d%02d-%02d%02d%02d-%04d" %
                                            string) (Z.add 1900 (tm_year tm))
                                        (Z.add (tm_mon tm) 1) (tm_mday tm)
                                        (tm_hour tm) (tm_min tm) (tm_sec tm)
                                        (OCaml.Stdlib.reverse_apply
                                          (Stdlib.op_star_point
                                            (Stdlib.op_minus_point time_value
                                              (Stdlib.floor time_value)) 10000)
                                          Stdlib.int_of_float) in
                                    let pp {J : Type}
                                      (fmt : Stdlib.Format.formatter) (o :
                                      (Tezos_data_encoding.Data_encoding.Json.json
                                        *
                                        ((Stdlib.Format.formatter ->
                                          unit -> unit) * J))) : unit :=
                                      if as_json then
                                        Tezos_data_encoding.Data_encoding.Json.pp
                                          fmt send
                                      else
                                        send fmt tt in
                                    Tezos_clic_unix.Scriptable.output_row None
                                      scriptable
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "<2>" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "<2>" % string))
                                                  (CamlinternalFormatBasics.String_literal
                                                    "* [" % string
                                                    (CamlinternalFormatBasics.String
                                                      CamlinternalFormatBasics.No_padding
                                                      (CamlinternalFormatBasics.Char_literal
                                                        " " % char
                                                        (CamlinternalFormatBasics.String
                                                          CamlinternalFormatBasics.No_padding
                                                          (CamlinternalFormatBasics.Char_literal
                                                            "]" % char
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              (CamlinternalFormatBasics.Break
                                                                "@ " % string 1
                                                                0)
                                                              (CamlinternalFormatBasics.Alpha
                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                  CamlinternalFormatBasics.Close_box
                                                                  CamlinternalFormatBasics.End_of_format)))))))))
                                                "@[<2>* [%s %s]@ %a@]" % string)
                                              (time_string time_stamp) send pp o)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.return_unit
                                              end)
                                        end)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          let text := flat_pp pp o in
                                          script_row "event" % string
                                            (time_string time_stamp) send text
                                            tt
                                        end)
                              end))
                          (fun function_parameter =>
                            match function_parameter with
                            | ([], tt) => Tezos_base__TzPervasives.return_unit
                            | (errors_and_warnings, tt) =>
                              Tezos_clic_unix.Scriptable.output None scriptable
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "### Some things were not perfect:"
                                              % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_box
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "<2>" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "<2>" % string))
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    CamlinternalFormatBasics.End_of_format)))))
                                          "### Some things were not perfect:@.@[<2>%a@]"
                                            % string)
                                        (Stdlib.Format.pp_print_list
                                          (Some
                                            (fun fmt =>
                                              fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Stdlib.Format.fprintf fmt
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Flush_newline
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "@." % string)
                                                end))
                                          (fun fmt =>
                                            fun item =>
                                              Stdlib.Format.fprintf fmt
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "* " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      CamlinternalFormatBasics.End_of_format))
                                                  "* %a" % string)
                                                Tezos_stdlib_unix.File_event_sink.Query.Report.pp
                                                item)) errors_and_warnings)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.return_unit
                                        end)
                                  end)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    let make_row
                                      (e :
                                      Tezos_stdlib_unix.File_event_sink.Query.Report.item)
                                      : list string :=
                                      let text :=
                                        flat_pp
                                          Tezos_stdlib_unix.File_event_sink.Query.Report.pp
                                          e in
                                      let tag :=
                                        match e with
                                        | Error _ => "error" % string
                                        | Warning _ => "warning" % string
                                        end in
                                      script_row tag "-" % string "-" % string
                                        text tt in
                                    Tezos_base__TzPervasives.List.map make_row
                                      errors_and_warnings
                                  end)
                            end)
                      end)
                | Some other =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "URI scheme " % string
                          (CamlinternalFormatBasics.Caml_string
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              " not handled as of now." % string
                              CamlinternalFormatBasics.End_of_format)))
                        "URI scheme %S not handled as of now." % string) other)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end
          end))
      (cons
        (command
          "Display configuration/state information about the internal-event logging framework."
            % string Tezos_base__TzPervasives.Clic.no_options
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "show" % string (cons "event-logging" % string [])))
            Tezos_base__TzPervasives.Clic.stop)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              fun cctxt =>
                let pp_event_definitions {J : Type}
                  (fmt : Stdlib.Format.formatter) (schs :
                  list ((string * (string * J)))) : unit :=
                  Stdlib.Format.pp_open_box fmt 0;
                  Stdlib.Format.pp_print_list
                    (Some
                      (fun fmt =>
                        fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Stdlib.Format.fprintf fmt
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@;" % string
                                    1 0) CamlinternalFormatBasics.End_of_format)
                                "@;" % string)
                          end))
                    (fun fmt =>
                      fun obj_schema =>
                        Stdlib.Format.pp_open_box fmt 2;
                        Stdlib.Format.fprintf fmt
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "* `" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  "`:" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    CamlinternalFormatBasics.End_of_format))))
                            "* `%s`:@ " % string) send;
                        Stdlib.Format.pp_print_text fmt send;
                        Stdlib.Format.pp_close_box fmt tt) fmt schs;
                  Stdlib.Format.pp_close_box fmt tt in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Event logging framework:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          (CamlinternalFormatBasics.String_literal
                            "Sinks state:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  (CamlinternalFormatBasics.String_literal
                                    "Events registered:" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format)))))))))
                      "Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a"
                        % string)
                    Tezos_base__TzPervasives.Internal_event.All_sinks.pp_state
                    tt pp_event_definitions
                    (OCaml.Stdlib.reverse_apply
                      (Tezos_base__TzPervasives.Internal_event.All_definitions.get
                        tt)
                      (Tezos_base__TzPervasives.List.map
                        Tezos_base__TzPervasives.Internal_event.Generic.json_schema)))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives.return_unit
                    end)
            end))
        (cons
          (command "Output the JSON schema of an internal-event." % string
            Tezos_base__TzPervasives.Clic.no_options
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "output" % string
                  (cons "schema" % string (cons "of" % string []))))
              (apply
                (Tezos_base__TzPervasives.Clic.param "Event-Name" % string
                  "Name of the event" % string
                  (Tezos_base__TzPervasives.Clic.parameter None
                    (fun function_parameter =>
                      match function_parameter with
                      | _ => fun s => Tezos_base__TzPervasives._return s
                      end)))
                (apply (Tezos_base__TzPervasives.Clic.prefix "to" % string)
                  (apply
                    (Tezos_base__TzPervasives.Clic.param "File-path" % string
                      "Path to a JSON file" % string
                      (Tezos_base__TzPervasives.Clic.parameter None
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => fun s => Tezos_base__TzPervasives._return s
                          end))) Tezos_base__TzPervasives.Clic.stop))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun event =>
                  fun path =>
                    fun cctxt =>
                      match
                        Tezos_base__TzPervasives.Internal_event.All_definitions.find
                          (equiv_decb event) with
                      | None =>
                        Tezos_base__TzPervasives.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Event " % string
                              (CamlinternalFormatBasics.Caml_string
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " not found" % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Event %S not found" % string) event
                      | Some ev =>
                        let o :=
                          Tezos_base__TzPervasives.Internal_event.Generic.json_schema
                            ev in
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Lwt_io.with_file None None None Lwt_io.output path
                            (fun chan =>
                              let v :=
                                Stdlib.Format.asprintf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format)
                                    "%a" % string) Json_schema.pp send in
                              Lwt_io.write chan v))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Wrote schema of " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.String_literal
                                          " to " % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            CamlinternalFormatBasics.End_of_format))))
                                    "Wrote schema of %s to %s" % string) event
                                  path)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                            end)
                      end
              end)) []))
  end.
src/lib_client_commands/client_event_logging_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> Client_commands.command list
src/lib_client_commands/client_event_logging_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands : unit -> list Tezos_client_commands.Client_commands.command.
src/lib_client_commands/client_helpers_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let unique_switch =
  Clic.switch
    ~long:"unique"
    ~short:'u'
    ~doc:"Fail when there is more than one possible completion."
    ()

let commands () =
  Clic.
    [ command
        ~desc:
          "Autocomplete a prefix of Base58Check-encoded hash.\n\
           This actually works only for blocks, operations, public key and \
           contract identifiers."
        (args1 unique_switch)
        ( prefixes ["complete"]
        @@ string ~name:"prefix" ~desc:"the prefix of the hash to complete"
        @@ stop )
        (fun unique prefix (cctxt : #Client_context.full) ->
          Shell_services.Blocks.Helpers.complete
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            prefix
          >>=? fun completions ->
          match completions with
          | [] ->
              Pervasives.exit 3
          | _ :: _ :: _ when unique ->
              Pervasives.exit 3
          | completions ->
              List.iter print_endline completions ;
              return_unit);
      command
        ~desc:"Wait for the node to be bootstrapped."
        no_options
        (prefixes ["bootstrapped"] @@ stop)
        (fun () (cctxt : #Client_context.full) ->
          Monitor_services.bootstrapped cctxt
          >>=? fun (stream, _) ->
          Lwt_stream.iter_s
            (fun (hash, time) ->
              cctxt#message
                "Current head: %a (timestamp: %a, validation: %a)"
                Block_hash.pp_short
                hash
                Time.System.pp_hum
                (Time.System.of_protocol_exn time)
                Time.System.pp_hum
                (Tezos_stdlib_unix.Systime_os.now ()))
            stream
          >>= fun () -> cctxt#answer "Bootstrapped." >>= fun () -> return_unit)
    ]
src/lib_client_commands/client_helpers_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition unique_switch {F G I a b i o p q : Type}
  : Tezos_base__TzPervasives.Clic.arg bool
    (((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  Tezos_base__TzPervasives.Clic.switch
    "Fail when there is more than one possible completion." % string
    (Some "u" % char) "unique" % string tt.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  match function_parameter with
  | tt =>
    cons
      (Tezos_base__TzPervasives.Clic.command None
        "Autocomplete a prefix of Base58Check-encoded hash.
This actually works only for blocks, operations, public key and contract identifiers."
          % string (Tezos_base__TzPervasives.Clic.args1 unique_switch)
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes (cons "complete" % string []))
          (apply
            (Tezos_base__TzPervasives.Clic.string "prefix" % string
              "the prefix of the hash to complete" % string)
            Tezos_base__TzPervasives.Clic.stop))
        (fun unique =>
          fun prefix =>
            fun cctxt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell_services.Shell_services.Blocks.Helpers.complete
                  cctxt (Some send) (Some send) prefix)
                (fun completions =>
                  match completions with
                  | [] => Stdlib.Pervasives.exit 3
                  | completions =>
                    Tezos_base__TzPervasives.List.iter
                      OCaml.Stdlib.print_endline completions;
                    Tezos_base__TzPervasives.return_unit
                  end)))
      (cons
        (Tezos_base__TzPervasives.Clic.command None
          "Wait for the node to be bootstrapped." % string
          Tezos_base__TzPervasives.Clic.no_options
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "bootstrapped" % string []))
            Tezos_base__TzPervasives.Clic.stop)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              fun cctxt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_shell_services.Monitor_services.bootstrapped cctxt)
                  (fun function_parameter =>
                    match function_parameter with
                    | (stream, _) =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Lwt_stream.iter_s
                          (fun function_parameter =>
                            match function_parameter with
                            | (hash, time) =>
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Current head: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " (timestamp: " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            ", validation: " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                ")" % char
                                                CamlinternalFormatBasics.End_of_format)))))))
                                  "Current head: %a (timestamp: %a, validation: %a)"
                                    % string)
                                Tezos_base__TzPervasives.Block_hash.pp_short
                                hash Tezos_base__TzPervasives.Time.System.pp_hum
                                (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                                  time)
                                Tezos_base__TzPervasives.Time.System.pp_hum
                                (Tezos_stdlib_unix.Systime_os.now tt)
                            end) stream)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Bootstrapped." % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "Bootstrapped." % string))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_unit
                                end)
                          end)
                    end)
            end)) [])
  end.
src/lib_client_commands/client_helpers_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> Client_commands.command list
src/lib_client_commands/client_helpers_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands : unit -> list Tezos_client_commands.Client_commands.command.
src/lib_client_commands/client_keys_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys

let group =
  {
    Clic.name = "keys";
    title = "Commands for managing the wallet of cryptographic keys";
  }

let algo_param () =
  Clic.parameter
    ~autocomplete:(fun _ -> return ["ed25519"; "secp256k1"; "p256"])
    (fun _ name ->
      match name with
      | "ed25519" ->
          return Signature.Ed25519
      | "secp256k1" ->
          return Signature.Secp256k1
      | "p256" ->
          return Signature.P256
      | name ->
          failwith
            "Unknown signature algorithm (%s). Available: 'ed25519', \
             'secp256k1' or 'p256'"
            name)

let sig_algo_arg =
  Clic.default_arg
    ~doc:"use custom signature algorithm"
    ~long:"sig"
    ~short:'s'
    ~placeholder:"ed25519|secp256k1|p256"
    ~default:"ed25519"
    (algo_param ())

let gen_keys_containing ?(encrypted = false) ?(prefix = false) ?(force = false)
    ~containing ~name (cctxt : #Client_context.io_wallet) =
  let unrepresentable =
    List.filter
      (fun s ->
        not @@ Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s)
      containing
  in
  let good_initial_char = "KLMNPQRSTUVWXYZabcdefghi" in
  let bad_initial_char = "123456789ABCDEFGHJjkmnopqrstuvwxyz" in
  match unrepresentable with
  | _ :: _ ->
      cctxt#error
        "@[<v 0>The following words can't be written in the key alphabet: %a.@,\
         Valid characters: %a@,\
         Extra restriction for the first character: %s@]"
        (Format.pp_print_list
           ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
           (fun ppf s -> Format.fprintf ppf "'%s'" s))
        unrepresentable
        Base58.Alphabet.pp
        Base58.Alphabet.bitcoin
        good_initial_char
  | [] -> (
      let unrepresentable =
        List.filter
          (fun s -> prefix && String.contains bad_initial_char s.[0])
          containing
      in
      match unrepresentable with
      | _ :: _ ->
          cctxt#error
            "@[<v 0>The following words don't respect the first character \
             restriction: %a.@,\
             Valid characters: %a@,\
             Extra restriction for the first character: %s@]"
            (Format.pp_print_list
               ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
               (fun ppf s -> Format.fprintf ppf "'%s'" s))
            unrepresentable
            Base58.Alphabet.pp
            Base58.Alphabet.bitcoin
            good_initial_char
      | [] ->
          Public_key_hash.mem cctxt name
          >>=? fun name_exists ->
          if name_exists && not force then
            cctxt#warning
              "Key for name '%s' already exists. Use --force to update."
              name
            >>= return
          else
            cctxt#warning
              "This process uses a brute force search and may take a long \
               time to find a key."
            >>= fun () ->
            let matches =
              if prefix then
                let containing_tz1 = List.map (( ^ ) "tz1") containing in
                fun key ->
                  List.exists
                    (fun containing ->
                      String.sub key 0 (String.length containing) = containing)
                    containing_tz1
              else
                let re = Re.Str.regexp (String.concat "\\|" containing) in
                fun key ->
                  try
                    ignore (Re.Str.search_forward re key 0) ;
                    true
                  with Not_found -> false
            in
            let rec loop attempts =
              let (public_key_hash, public_key, secret_key) =
                Signature.generate_key ()
              in
              let hash =
                Signature.Public_key_hash.to_b58check
                @@ Signature.Public_key.hash public_key
              in
              if matches hash then
                let pk_uri =
                  Tezos_signer_backends.Unencrypted.make_pk public_key
                in
                ( if encrypted then
                  Tezos_signer_backends.Encrypted.encrypt cctxt secret_key
                else
                  return (Tezos_signer_backends.Unencrypted.make_sk secret_key)
                )
                >>=? fun sk_uri ->
                register_key
                  cctxt
                  ~force
                  (public_key_hash, pk_uri, sk_uri)
                  name
                >>=? fun () -> return hash
              else
                ( if attempts mod 25_000 = 0 then
                  cctxt#message
                    "Tried %d keys without finding a match"
                    attempts
                else Lwt.return_unit )
                >>= fun () ->
                Lwt_unix.yield () >>= fun () -> loop (attempts + 1)
            in
            loop 1
            >>=? fun key_hash ->
            cctxt#message "Generated '%s' under the name '%s'." key_hash name
            >>= fun () -> return_unit )

let rec input_fundraiser_params (cctxt : #Client_context.io_wallet) =
  let rec get_boolean_answer (cctxt : #Client_context.io_wallet) ~default ~msg
      =
    let prompt = if default then "(Y/n/q)" else "(y/N/q)" in
    cctxt#prompt "%s %s: " msg prompt
    >>=? fun gen ->
    match (default, String.lowercase_ascii gen) with
    | (default, "") ->
        return default
    | (_, "y") ->
        return_true
    | (_, "n") ->
        return_false
    | (_, "q") ->
        failwith "Exit by user request."
    | _ ->
        get_boolean_answer cctxt ~msg ~default
  in
  cctxt#prompt "Enter the e-mail used for the paper wallet: "
  >>=? fun email ->
  let rec loop_words acc i =
    if i > 14 then return (List.rev acc)
    else
      cctxt#prompt_password "Enter word %d: " i
      >>=? fun word ->
      match Bip39.index_of_word (Bigstring.to_string word) with
      | None ->
          loop_words acc i
      | Some wordidx ->
          loop_words (wordidx :: acc) (succ i)
  in
  loop_words [] 0
  >>=? fun words ->
  match Bip39.of_indices words with
  | None ->
      assert false
  | Some t -> (
      cctxt#prompt_password "Enter the password used for the paper wallet: "
      >>=? fun password ->
      (* TODO: unicode normalization (NFKD)... *)
      let passphrase = Bigstring.(concat "" [of_string email; password]) in
      let sk = Bip39.to_seed ~passphrase t in
      let sk = Bigstring.sub_bytes sk 0 32 in
      let sk : Signature.Secret_key.t =
        Ed25519
          (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
      in
      let pk = Signature.Secret_key.to_public_key sk in
      let pkh = Signature.Public_key.hash pk in
      let msg =
        Format.asprintf
          "Your public Tezos address is %a is that correct?"
          Signature.Public_key_hash.pp
          pkh
      in
      get_boolean_answer cctxt ~msg ~default:true
      >>=? function
      | true -> return sk | false -> input_fundraiser_params cctxt )

let commands version : Client_context.full Clic.command list =
  let open Clic in
  let encrypted_switch () =
    if
      List.exists
        (fun (scheme, _) -> scheme = Tezos_signer_backends.Unencrypted.scheme)
        (Client_keys.registered_signers ())
    then Clic.switch ~long:"encrypted" ~doc:"Encrypt the key on-disk" ()
    else Clic.constant true
  in
  let show_private_switch =
    switch ~long:"show-secret" ~short:'S' ~doc:"show the private key" ()
  in
  [ command
      ~group
      ~desc:
        "List supported signing schemes.\n\
         Signing schemes are identifiers for signer modules: the built-in \
         signing routines, a hardware wallet, an external agent, etc.\n\
         Each signer has its own format for describing secret keys, such a \
         raw secret key for the default `unencrypted` scheme, the path on a \
         hardware security module, an alias for an external agent, etc.\n\
         This command gives the list of signer modules that this version of \
         the tezos client supports."
      no_options
      (fixed ["list"; "signing"; "schemes"])
      (fun () (cctxt : Client_context.full) ->
        let signers =
          List.sort
            (fun (ka, _) (kb, _) -> String.compare ka kb)
            (registered_signers ())
        in
        Lwt_list.iter_s
          (fun (n, (module S : SIGNER)) ->
            cctxt#message
              "@[<v 2>Scheme `%s`: %s@,@[<hov 0>%a@]@]"
              n
              S.title
              Format.pp_print_text
              S.description)
          signers
        >>= return);
    ( match version with
    | Some `Mainnet ->
        command
          ~group
          ~desc:"Generate a pair of keys."
          (args2 (Secret_key.force_switch ()) sig_algo_arg)
          (prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop)
          (fun (force, algo) name (cctxt : Client_context.full) ->
            Secret_key.of_fresh cctxt force name
            >>=? fun name ->
            let (pkh, pk, sk) = Signature.generate_key ~algo () in
            let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
            Tezos_signer_backends.Encrypted.encrypt cctxt sk
            >>=? fun sk_uri ->
            register_key cctxt ~force (pkh, pk_uri, sk_uri) name)
    | _ ->
        command
          ~group
          ~desc:"Generate a pair of keys."
          (args3
             (Secret_key.force_switch ())
             sig_algo_arg
             (encrypted_switch ()))
          (prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop)
          (fun (force, algo, encrypted) name (cctxt : Client_context.full) ->
            Secret_key.of_fresh cctxt force name
            >>=? fun name ->
            let (pkh, pk, sk) = Signature.generate_key ~algo () in
            let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
            ( if encrypted then Tezos_signer_backends.Encrypted.encrypt cctxt sk
            else return (Tezos_signer_backends.Unencrypted.make_sk sk) )
            >>=? fun sk_uri ->
            register_key cctxt ~force (pkh, pk_uri, sk_uri) name) );
    ( match version with
    | Some `Mainnet ->
        command
          ~group
          ~desc:"Generate keys including the given string."
          (args2
             (switch
                ~long:"prefix"
                ~short:'P'
                ~doc:"the key must begin with tz1[word]"
                ())
             (force_switch ()))
          ( prefixes ["gen"; "vanity"; "keys"]
          @@ Public_key_hash.fresh_alias_param @@ prefix "matching"
          @@ seq_of_param
          @@ string
               ~name:"words"
               ~desc:"string key must contain one of these words" )
          (fun (prefix, force) name containing (cctxt : Client_context.full) ->
            Public_key_hash.of_fresh cctxt force name
            >>=? fun name ->
            gen_keys_containing
              ~encrypted:true
              ~force
              ~prefix
              ~containing
              ~name
              cctxt)
    | _ ->
        command
          ~group
          ~desc:"Generate keys including the given string."
          (args3
             (switch
                ~long:"prefix"
                ~short:'P'
                ~doc:"the key must begin with tz1[word]"
                ())
             (force_switch ())
             (encrypted_switch ()))
          ( prefixes ["gen"; "vanity"; "keys"]
          @@ Public_key_hash.fresh_alias_param @@ prefix "matching"
          @@ seq_of_param
          @@ string
               ~name:"words"
               ~desc:"string key must contain one of these words" )
          (fun (prefix, force, encrypted)
               name
               containing
               (cctxt : Client_context.full) ->
            Public_key_hash.of_fresh cctxt force name
            >>=? fun name ->
            gen_keys_containing
              ~encrypted
              ~force
              ~prefix
              ~containing
              ~name
              cctxt) );
    command
      ~group
      ~desc:"Encrypt an unencrypted secret key."
      no_options
      (prefixes ["encrypt"; "secret"; "key"] @@ stop)
      (fun () (cctxt : Client_context.full) ->
        cctxt#prompt_password "Enter unencrypted secret key: "
        >>=? fun sk_uri ->
        let sk_uri = Uri.of_string (Bigstring.to_string sk_uri) in
        ( match Uri.scheme sk_uri with
        | None | Some "unencrypted" ->
            return_unit
        | _ ->
            failwith
              "This command can only be used with the \"unencrypted\" scheme"
        )
        >>=? fun () ->
        Lwt.return (Signature.Secret_key.of_b58check (Uri.path sk_uri))
        >>=? fun sk ->
        Tezos_signer_backends.Encrypted.encrypt cctxt sk
        >>=? fun sk_uri ->
        cctxt#message "Encrypted secret key %a" Uri.pp_hum (sk_uri :> Uri.t)
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Add a secret key to the wallet."
      (args1 (Secret_key.force_switch ()))
      ( prefix "import"
      @@ prefixes ["secret"; "key"]
      @@ Secret_key.fresh_alias_param @@ Client_keys.sk_uri_param @@ stop )
      (fun force name sk_uri (cctxt : Client_context.full) ->
        Secret_key.of_fresh cctxt force name
        >>=? fun name ->
        Client_keys.neuterize sk_uri
        >>=? fun pk_uri ->
        Public_key.find_opt cctxt name
        >>=? (function
               | None ->
                   return_unit
               | Some (pk_uri_found, _) ->
                   fail_unless
                     (pk_uri = pk_uri_found || force)
                     (failure
                        "public and secret keys '%s' don't correspond, please \
                         don't use --force"
                        name))
        >>=? fun () ->
        Client_keys.import_secret_key
          ~io:(cctxt :> Client_context.io_wallet)
          pk_uri
        >>=? fun (pkh, public_key) ->
        cctxt#message
          "Tezos address added: %a"
          Signature.Public_key_hash.pp
          pkh
        >>= fun () ->
        register_key cctxt ~force (pkh, pk_uri, sk_uri) ?public_key name) ]
  @ ( if version <> Some `Mainnet then []
    else
      [ command
          ~group
          ~desc:"Add a fundraiser secret key to the wallet."
          (args1 (Secret_key.force_switch ()))
          ( prefix "import"
          @@ prefixes ["fundraiser"; "secret"; "key"]
          @@ Secret_key.fresh_alias_param @@ stop )
          (fun force name (cctxt : Client_context.full) ->
            Secret_key.of_fresh cctxt force name
            >>=? fun name ->
            input_fundraiser_params cctxt
            >>=? fun sk ->
            Tezos_signer_backends.Encrypted.encrypt cctxt sk
            >>=? fun sk_uri ->
            Client_keys.neuterize sk_uri
            >>=? fun pk_uri ->
            Public_key.find_opt cctxt name
            >>=? (function
                   | None ->
                       return_unit
                   | Some (pk_uri_found, _) ->
                       fail_unless
                         (pk_uri = pk_uri_found || force)
                         (failure
                            "public and secret keys '%s' don't correspond, \
                             please don't use --force"
                            name))
            >>=? fun () ->
            Client_keys.public_key_hash pk_uri
            >>=? fun (pkh, _public_key) ->
            register_key cctxt ~force (pkh, pk_uri, sk_uri) name) ] )
  @ [ command
        ~group
        ~desc:"Add a public key to the wallet."
        (args1 (Public_key.force_switch ()))
        ( prefix "import"
        @@ prefixes ["public"; "key"]
        @@ Public_key.fresh_alias_param @@ Client_keys.pk_uri_param @@ stop )
        (fun force name pk_uri (cctxt : Client_context.full) ->
          Public_key.of_fresh cctxt force name
          >>=? fun name ->
          Client_keys.public_key_hash pk_uri
          >>=? fun (pkh, public_key) ->
          Public_key_hash.add ~force cctxt name pkh
          >>=? fun () ->
          cctxt#message
            "Tezos address added: %a"
            Signature.Public_key_hash.pp
            pkh
          >>= fun () -> Public_key.add ~force cctxt name (pk_uri, public_key));
      command
        ~group
        ~desc:"Add an address to the wallet."
        (args1 (Public_key.force_switch ()))
        ( prefixes ["add"; "address"]
        @@ Public_key_hash.fresh_alias_param @@ Public_key_hash.source_param
        @@ stop )
        (fun force name hash cctxt ->
          Public_key_hash.of_fresh cctxt force name
          >>=? fun name -> Public_key_hash.add ~force cctxt name hash);
      command
        ~group
        ~desc:"List all addresses and associated keys."
        no_options
        (fixed ["list"; "known"; "addresses"])
        (fun () (cctxt : #Client_context.full) ->
          list_keys cctxt
          >>=? fun l ->
          iter_s
            (fun (name, pkh, pk, sk) ->
              Public_key_hash.to_source pkh
              >>=? fun v ->
              ( match (pk, sk) with
              | (None, None) ->
                  cctxt#message "%s: %s" name v
              | (_, Some uri) ->
                  let scheme =
                    Option.unopt ~default:"unencrypted"
                    @@ Uri.scheme (uri : sk_uri :> Uri.t)
                  in
                  cctxt#message "%s: %s (%s sk known)" name v scheme
              | (Some _, _) ->
                  cctxt#message "%s: %s (pk known)" name v )
              >>= fun () -> return_unit)
            l);
      command
        ~group
        ~desc:"Show the keys associated with an implicit account."
        (args1 show_private_switch)
        (prefixes ["show"; "address"] @@ Public_key_hash.alias_param @@ stop)
        (fun show_private (name, _) (cctxt : #Client_context.full) ->
          alias_keys cctxt name
          >>=? fun key_info ->
          match key_info with
          | None ->
              cctxt#message "No keys found for address"
              >>= fun () -> return_unit
          | Some (pkh, pk, skloc) -> (
              cctxt#message "Hash: %a" Signature.Public_key_hash.pp pkh
              >>= fun () ->
              match pk with
              | None ->
                  return_unit
              | Some pk ->
                  cctxt#message "Public Key: %a" Signature.Public_key.pp pk
                  >>= fun () ->
                  if show_private then
                    match skloc with
                    | None ->
                        return_unit
                    | Some skloc ->
                        Secret_key.to_source skloc
                        >>=? fun skloc ->
                        cctxt#message "Secret Key: %s" skloc
                        >>= fun () -> return_unit
                  else return_unit ));
      command
        ~group
        ~desc:"Forget one address."
        (args1
           (Clic.switch
              ~long:"force"
              ~short:'f'
              ~doc:"delete associated keys when present"
              ()))
        (prefixes ["forget"; "address"] @@ Public_key_hash.alias_param @@ stop)
        (fun force (name, _pkh) (cctxt : Client_context.full) ->
          Secret_key.mem cctxt name
          >>=? fun has_secret_key ->
          Public_key.mem cctxt name
          >>=? fun has_public_key ->
          fail_when
            ((not force) && (has_secret_key || has_public_key))
            (failure
               "secret or public key present for %s, use --force to delete"
               name)
          >>=? fun () ->
          Secret_key.del cctxt name
          >>=? fun () ->
          Public_key.del cctxt name
          >>=? fun () -> Public_key_hash.del cctxt name);
      command
        ~group
        ~desc:"Forget the entire wallet of keys."
        (args1
           (Clic.switch
              ~long:"force"
              ~short:'f'
              ~doc:"you got to use the force for that"
              ()))
        (fixed ["forget"; "all"; "keys"])
        (fun force (cctxt : Client_context.full) ->
          fail_unless
            force
            (failure "this can only be used with option --force")
          >>=? fun () ->
          Public_key.set cctxt []
          >>=? fun () ->
          Secret_key.set cctxt [] >>=? fun () -> Public_key_hash.set cctxt []);
      command
        ~group
        ~desc:"Compute deterministic nonce."
        no_options
        ( prefixes ["generate"; "nonce"; "for"]
        @@ Public_key_hash.alias_param
        @@ prefixes ["from"]
        @@ string
             ~name:"data"
             ~desc:"string from which to deterministically generate the nonce"
        @@ stop )
        (fun () (name, _pkh) data (cctxt : Client_context.full) ->
          let data = Bytes.of_string data in
          Secret_key.mem cctxt name
          >>=? fun sk_present ->
          fail_unless sk_present (failure "secret key not present for %s" name)
          >>=? fun () ->
          Secret_key.find cctxt name
          >>=? fun sk_uri ->
          Client_keys.deterministic_nonce sk_uri data
          >>=? fun nonce ->
          cctxt#message "%a" Hex.pp (Hex.of_bytes (Bigstring.to_bytes nonce))
          >>= fun () -> return_unit);
      command
        ~group
        ~desc:"Compute deterministic nonce hash."
        no_options
        ( prefixes ["generate"; "nonce"; "hash"; "for"]
        @@ Public_key_hash.alias_param
        @@ prefixes ["from"]
        @@ string
             ~name:"data"
             ~desc:
               "string from which to deterministically generate the nonce hash"
        @@ stop )
        (fun () (name, _pkh) data (cctxt : Client_context.full) ->
          let data = Bytes.of_string data in
          Secret_key.mem cctxt name
          >>=? fun sk_present ->
          fail_unless sk_present (failure "secret key not present for %s" name)
          >>=? fun () ->
          Secret_key.find cctxt name
          >>=? fun sk_uri ->
          Client_keys.deterministic_nonce_hash sk_uri data
          >>=? fun nonce_hash ->
          cctxt#message "%a" Hex.pp (Hex.of_bytes nonce_hash)
          >>= fun () -> return_unit) ]
src/lib_client_commands/client_keys_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base.Client_keys.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "keys" % string;
    Clic.title :=
      "Commands for managing the wallet of cryptographic keys" % string |}.

Definition algo_param {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_base__TzPervasives.Signature.algo A :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.parameter
      (Some
        (fun function_parameter =>
          match function_parameter with
          | _ =>
            Tezos_base__TzPervasives._return
              (cons "ed25519" % string
                (cons "secp256k1" % string (cons "p256" % string [])))
          end))
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun name =>
            match name with
            | "ed25519" % string =>
              Tezos_base__TzPervasives._return Signature.Ed25519
            | "secp256k1" % string =>
              Tezos_base__TzPervasives._return Signature.Secp256k1
            | "p256" % string => Tezos_base__TzPervasives._return Signature.P256
            | name =>
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Unknown signature algorithm (" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        "). Available: 'ed25519', 'secp256k1' or 'p256'" %
                          string CamlinternalFormatBasics.End_of_format)))
                  "Unknown signature algorithm (%s). Available: 'ed25519', 'secp256k1' or 'p256'"
                    % string) name
            end
        end)
  end.

Definition sig_algo_arg
  : Tezos_base__TzPervasives.Clic.arg Tezos_base__TzPervasives.Signature.algo
    Tezos_client_base.Client_context.full :=
  Tezos_base__TzPervasives.Clic.default_arg
    "use custom signature algorithm" % string (Some "s" % char) "sig" % string
    "ed25519|secp256k1|p256" % string "ed25519" % string (algo_param tt).

Definition gen_keys_containing {C a b : Type} (op_star_o_p_t_star : option bool)
  : (option bool) ->
    (option bool) ->
      (list string) ->
        string ->
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        (((string ->
                          (Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) *
                            ((((Tezos_client_base.Client_context.lwt_format a
                              (Tezos_base__TzPervasives.tzresult string)) -> a)
                              * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                (Tezos_base__TzPervasives.tzresult Bigstring.t))
                                -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) * C)))))))))))) * C) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let encrypted :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun op_star_o_p_t_star =>
    let prefix :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun op_star_o_p_t_star =>
      let force :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => false
        end in
      fun containing =>
        fun name =>
          fun cctxt =>
            let unrepresentable :=
              Tezos_base__TzPervasives.List.filter
                (fun s =>
                  apply negb
                    (Tezos_base__TzPervasives.Base58.Alphabet.all_in_alphabet
                      Tezos_base__TzPervasives.Base58.Alphabet.bitcoin s))
                containing in
            let good_initial_char := "KLMNPQRSTUVWXYZabcdefghi" % string in
            let bad_initial_char :=
              "123456789ABCDEFGHJjkmnopqrstuvwxyz" % string in
            match unrepresentable with
            | cons _ _ =>
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 0>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 0>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "The following words can't be written in the key alphabet: "
                        % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "." % char
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "Valid characters: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "Extra restriction for the first character: "
                                      % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format)))))))))))
                  "@[<v 0>The following words can't be written in the key alphabet: %a.@,Valid characters: %a@,Extra restriction for the first character: %s@]"
                    % string)
                (Stdlib.Format.pp_print_list
                  (Some
                    (fun ppf =>
                      fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                ", " % string
                                CamlinternalFormatBasics.End_of_format)
                              ", " % string)
                        end))
                  (fun ppf =>
                    fun s =>
                      Stdlib.Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Char_literal "'" % char
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.Char_literal "'" % char
                                CamlinternalFormatBasics.End_of_format)))
                          "'%s'" % string) s)) unrepresentable
                Tezos_base__TzPervasives.Base58.Alphabet.pp
                Tezos_base__TzPervasives.Base58.Alphabet.bitcoin
                good_initial_char
            | [] =>
              let unrepresentable :=
                Tezos_base__TzPervasives.List.filter
                  (fun s =>
                    andb prefix
                      (Tezos_base__TzPervasives.String.contains bad_initial_char
                        (Tezos_base__TzPervasives.String.get s 0))) containing
                in
              match unrepresentable with
              | cons _ _ =>
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "The following words don't respect the first character restriction: "
                          % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "." % char
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "Valid characters: " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "Extra restriction for the first character: "
                                        % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format)))))))))))
                    "@[<v 0>The following words don't respect the first character restriction: %a.@,Valid characters: %a@,Extra restriction for the first character: %s@]"
                      % string)
                  (Stdlib.Format.pp_print_list
                    (Some
                      (fun ppf =>
                        fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Stdlib.Format.fprintf ppf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  ", " % string
                                  CamlinternalFormatBasics.End_of_format)
                                ", " % string)
                          end))
                    (fun ppf =>
                      fun s =>
                        Stdlib.Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Char_literal "'" % char
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Char_literal
                                  "'" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "'%s'" % string) s)) unrepresentable
                  Tezos_base__TzPervasives.Base58.Alphabet.pp
                  Tezos_base__TzPervasives.Base58.Alphabet.bitcoin
                  good_initial_char
              | [] =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_client_base.Client_keys.Public_key_hash.mem cctxt name)
                  (fun name_exists =>
                    if andb name_exists (negb force) then
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Key for name '" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  "' already exists. Use --force to update." %
                                    string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Key for name '%s' already exists. Use --force to update."
                              % string) name) Tezos_base__TzPervasives._return
                    else
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "This process uses a brute force search and may take a long time to find a key."
                                % string CamlinternalFormatBasics.End_of_format)
                            "This process uses a brute force search and may take a long time to find a key."
                              % string))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            let matches :=
                              if prefix then
                                let containing_tz1 :=
                                  Tezos_base__TzPervasives.List.map
                                    (String.append "tz1" % string) containing in
                                fun key =>
                                  Tezos_base__TzPervasives.List._exists
                                    (fun containing =>
                                      equiv_decb
                                        (Tezos_base__TzPervasives.String.sub key
                                          0
                                          (Tezos_base__TzPervasives.String.length
                                            containing)) containing)
                                    containing_tz1
                              else
                                let re :=
                                  Re.Str.regexp
                                    (Tezos_base__TzPervasives.String.concat
                                      "\|" % string containing) in
                                fun key => try in
                            let fix loop (attempts : Z)
                              : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
                              match
                                Tezos_base__TzPervasives.Signature.generate_key
                                  None None tt with
                              | (public_key_hash, public_key, secret_key) =>
                                let hash :=
                                  apply
                                    Tezos_base__TzPervasives.Signature.Public_key_hash.to_b58check
                                    (Tezos_base__TzPervasives.Signature.Public_key.hash
                                      public_key) in
                                if matches hash then
                                  let pk_uri :=
                                    Tezos_signer_backends.Unencrypted.make_pk
                                      public_key in
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (if encrypted then
                                      Tezos_signer_backends.Encrypted.encrypt
                                        cctxt secret_key
                                    else
                                      Tezos_base__TzPervasives._return
                                        (Tezos_signer_backends.Unencrypted.make_sk
                                          secret_key))
                                    (fun sk_uri =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_client_base.Client_keys.register_key
                                          cctxt (Some force)
                                          (public_key_hash, pk_uri, sk_uri) None
                                          name)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives._return
                                              hash
                                          end))
                                else
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (if equiv_decb (Z.modulo attempts 25000) 0
                                      then
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Tried " % string
                                            (CamlinternalFormatBasics.Int
                                              CamlinternalFormatBasics.Int_d
                                              CamlinternalFormatBasics.No_padding
                                              CamlinternalFormatBasics.No_precision
                                              (CamlinternalFormatBasics.String_literal
                                                " keys without finding a match"
                                                  % string
                                                CamlinternalFormatBasics.End_of_format)))
                                          "Tried %d keys without finding a match"
                                            % string) attempts
                                    else
                                      Lwt.return_unit)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (Lwt_unix.yield tt)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt => loop (Z.add attempts 1)
                                            end)
                                      end)
                              end in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (loop 1)
                              (fun key_hash =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Generated '" % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          (CamlinternalFormatBasics.String_literal
                                            "' under the name '" % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.String_literal
                                                "'." % string
                                                CamlinternalFormatBasics.End_of_format)))))
                                      "Generated '%s' under the name '%s'." %
                                        string) key_hash name)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end))
                          end))
              end
            end.

Fixpoint input_fundraiser_params {C a b : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                  (a * b)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
                        *
                        ((((Tezos_client_base.Client_context.lwt_format a
                          (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
                          * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) * C)))))))))))) * C)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  let fix get_boolean_answer {D : Type}
    (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                  (a * b)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
                        *
                        ((((Tezos_client_base.Client_context.lwt_format a
                          (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
                          * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) * D)))))))))))) * D) (default : bool)
    (msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
    let prompt :=
      if default then
        "(Y/n/q)" % string
      else
        "(y/N/q)" % string in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal " " % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal ": " % string
                  CamlinternalFormatBasics.End_of_format)))) "%s %s: " % string)
        msg prompt)
      (fun gen =>
        match (default, (Tezos_base__TzPervasives.String.lowercase_ascii gen))
          with
        | (default, "" % string) => Tezos_base__TzPervasives._return default
        | (_, "y" % string) => Tezos_base__TzPervasives.return_true
        | (_, "n" % string) => Tezos_base__TzPervasives.return_false
        | (_, "q" % string) =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Exit by user request." % string
                CamlinternalFormatBasics.End_of_format)
              "Exit by user request." % string)
        | _ => get_boolean_answer cctxt default msg
        end) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Enter the e-mail used for the paper wallet: " % string
          CamlinternalFormatBasics.End_of_format)
        "Enter the e-mail used for the paper wallet: " % string))
    (fun email =>
      let fix loop_words (acc : list Z) (i : Z)
        : Lwt.t (Tezos_base__TzPervasives.tzresult (list Z)) :=
        if OCaml.Stdlib.gt i 14 then
          Tezos_base__TzPervasives._return
            (Tezos_base__TzPervasives.List.rev acc)
        else
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Enter word " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ": " % string
                      CamlinternalFormatBasics.End_of_format)))
                "Enter word %d: " % string) i)
            (fun word =>
              match Bip39.index_of_word (Bigstring.to_string word) with
              | None => loop_words acc i
              | Some wordidx => loop_words (cons wordidx acc) (Z.succ i)
              end) in
      Tezos_base__TzPervasives.op_gt_gt_eq_question (loop_words [] 0)
        (fun words =>
          match Bip39.of_indices words with
          | None => false
          | Some t =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Enter the password used for the paper wallet: " % string
                    CamlinternalFormatBasics.End_of_format)
                  "Enter the password used for the paper wallet: " % string))
              (fun password =>
                let passphrase :=
                  Bigstring.concat "" % string
                    (cons (Bigstring.of_string email) (cons password [])) in
                let sk := Bip39.to_seed (Some passphrase) t in
                let sk := Bigstring.sub_bytes sk 0 32 in
                let sk :=
                  Ed25519
                    (Tezos_data_encoding.Data_encoding.Binary.of_bytes_exn
                      Tezos_base__TzPervasives.Ed25519.Secret_key.encoding sk)
                  in
                let pk :=
                  Tezos_base__TzPervasives.Signature.Secret_key.to_public_key sk
                  in
                let pkh := Tezos_base__TzPervasives.Signature.Public_key.hash pk
                  in
                let msg :=
                  Stdlib.Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Your public Tezos address is " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " is that correct?" % string
                            CamlinternalFormatBasics.End_of_format)))
                      "Your public Tezos address is %a is that correct?" %
                        string)
                    Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh in
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (get_boolean_answer cctxt true msg)
                  (fun function_parameter =>
                    match function_parameter with
                    | true => Tezos_base__TzPervasives._return sk
                    | false => input_fundraiser_params cctxt
                    end))
          end)).

Definition commands (version : option variant)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  let encrypted_switch {A : Type} (function_parameter : unit)
    : Tezos_base__TzPervasives.Clic.arg bool A :=
    match function_parameter with
    | tt =>
      if
        Tezos_base__TzPervasives.List._exists
          (fun function_parameter =>
            match function_parameter with
            | (scheme, _) =>
              equiv_decb scheme Tezos_signer_backends.Unencrypted.scheme
            end) (Tezos_client_base.Client_keys.registered_signers tt) then
        Tezos_base__TzPervasives.Clic.switch "Encrypt the key on-disk" % string
          None "encrypted" % string tt
      else
        Tezos_base__TzPervasives.Clic.constant true
    end in
  let show_private_switch :=
    Tezos_base__TzPervasives.Clic.switch "show the private key" % string
      (Some "S" % char) "show-secret" % string tt in
  OCaml.Stdlib.app
    (cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "List supported signing schemes.
Signing schemes are identifiers for signer modules: the built-in signing routines, a hardware wallet, an external agent, etc.
Each signer has its own format for describing secret keys, such a raw secret key for the default `unencrypted` scheme, the path on a hardware security module, an alias for an external agent, etc.
This command gives the list of signer modules that this version of the tezos client supports."
          % string Tezos_base__TzPervasives.Clic.no_options
        (Tezos_base__TzPervasives.Clic.fixed
          (cons "list" % string
            (cons "signing" % string (cons "schemes" % string []))))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun cctxt =>
              let signers :=
                Tezos_base__TzPervasives.List.sort
                  (fun function_parameter =>
                    match function_parameter with
                    | (ka, _) =>
                      fun function_parameter =>
                        match function_parameter with
                        | (kb, _) =>
                          Tezos_base__TzPervasives.String.compare ka kb
                        end
                    end) (Tezos_client_base.Client_keys.registered_signers tt)
                in
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Lwt_list.iter_s
                  (fun function_parameter =>
                    match function_parameter with
                    | (n, _ as S) =>
                      let S := projT2 S in
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_box
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<v 2>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<v 2>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "Scheme `" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  "`: " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<hov 0>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<hov 0>" % string))
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format))))))))))
                          "@[<v 2>Scheme `%s`: %s@,@[<hov 0>%a@]@]" % string) n
                        S.(Tezos_client_base.Client_keys.SIGNER.title)
                        Stdlib.Format.pp_print_text
                        S.(Tezos_client_base.Client_keys.SIGNER.description)
                    end) signers) Tezos_base__TzPervasives._return
          end))
      (cons
        match version with
        | Some Mainnet =>
          Tezos_base__TzPervasives.Clic.command (Some group)
            "Generate a pair of keys." % string
            (Tezos_base__TzPervasives.Clic.args2
              (Tezos_client_base.Client_keys.Secret_key.force_switch tt)
              sig_algo_arg)
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "gen" % string (cons "keys" % string [])))
              (apply
                (let arg :=
                  Tezos_client_base.Client_keys.Secret_key.fresh_alias_param in
                fun eta => arg None None eta) Tezos_base__TzPervasives.Clic.stop))
            (fun function_parameter =>
              match function_parameter with
              | (force, algo) =>
                fun name =>
                  fun cctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_client_base.Client_keys.Secret_key.of_fresh cctxt
                        force name)
                      (fun name =>
                        match
                          Tezos_base__TzPervasives.Signature.generate_key
                            (Some algo) None tt with
                        | (pkh, pk, sk) =>
                          let pk_uri :=
                            Tezos_signer_backends.Unencrypted.make_pk pk in
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_signer_backends.Encrypted.encrypt cctxt sk)
                            (fun sk_uri =>
                              Tezos_client_base.Client_keys.register_key cctxt
                                (Some force) (pkh, pk_uri, sk_uri) None name)
                        end)
              end)
        | _ =>
          Tezos_base__TzPervasives.Clic.command (Some group)
            "Generate a pair of keys." % string
            (Tezos_base__TzPervasives.Clic.args3
              (Tezos_client_base.Client_keys.Secret_key.force_switch tt)
              sig_algo_arg (encrypted_switch tt))
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "gen" % string (cons "keys" % string [])))
              (apply
                (let arg :=
                  Tezos_client_base.Client_keys.Secret_key.fresh_alias_param in
                fun eta => arg None None eta) Tezos_base__TzPervasives.Clic.stop))
            (fun function_parameter =>
              match function_parameter with
              | (force, algo, encrypted) =>
                fun name =>
                  fun cctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_client_base.Client_keys.Secret_key.of_fresh cctxt
                        force name)
                      (fun name =>
                        match
                          Tezos_base__TzPervasives.Signature.generate_key
                            (Some algo) None tt with
                        | (pkh, pk, sk) =>
                          let pk_uri :=
                            Tezos_signer_backends.Unencrypted.make_pk pk in
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (if encrypted then
                              Tezos_signer_backends.Encrypted.encrypt cctxt sk
                            else
                              Tezos_base__TzPervasives._return
                                (Tezos_signer_backends.Unencrypted.make_sk sk))
                            (fun sk_uri =>
                              Tezos_client_base.Client_keys.register_key cctxt
                                (Some force) (pkh, pk_uri, sk_uri) None name)
                        end)
              end)
        end
        (cons
          match version with
          | Some Mainnet =>
            Tezos_base__TzPervasives.Clic.command (Some group)
              "Generate keys including the given string." % string
              (Tezos_base__TzPervasives.Clic.args2
                (Tezos_base__TzPervasives.Clic.switch
                  "the key must begin with tz1[word]" % string (Some "P" % char)
                  "prefix" % string tt)
                (Tezos_client_base.Client_keys.force_switch tt))
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "gen" % string
                    (cons "vanity" % string (cons "keys" % string []))))
                (apply
                  (let arg :=
                    Tezos_client_base.Client_keys.Public_key_hash.fresh_alias_param
                    in
                  fun eta => arg None None eta)
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefix "matching" % string)
                    (apply Tezos_base__TzPervasives.Clic.seq_of_param
                      (Tezos_base__TzPervasives.Clic.string "words" % string
                        "string key must contain one of these words" % string)))))
              (fun function_parameter =>
                match function_parameter with
                | (prefix, force) =>
                  fun name =>
                    fun containing =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_base.Client_keys.Public_key_hash.of_fresh
                            cctxt force name)
                          (fun name =>
                            gen_keys_containing (Some true) (Some prefix)
                              (Some force) containing name cctxt)
                end)
          | _ =>
            Tezos_base__TzPervasives.Clic.command (Some group)
              "Generate keys including the given string." % string
              (Tezos_base__TzPervasives.Clic.args3
                (Tezos_base__TzPervasives.Clic.switch
                  "the key must begin with tz1[word]" % string (Some "P" % char)
                  "prefix" % string tt)
                (Tezos_client_base.Client_keys.force_switch tt)
                (encrypted_switch tt))
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "gen" % string
                    (cons "vanity" % string (cons "keys" % string []))))
                (apply
                  (let arg :=
                    Tezos_client_base.Client_keys.Public_key_hash.fresh_alias_param
                    in
                  fun eta => arg None None eta)
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefix "matching" % string)
                    (apply Tezos_base__TzPervasives.Clic.seq_of_param
                      (Tezos_base__TzPervasives.Clic.string "words" % string
                        "string key must contain one of these words" % string)))))
              (fun function_parameter =>
                match function_parameter with
                | (prefix, force, encrypted) =>
                  fun name =>
                    fun containing =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_base.Client_keys.Public_key_hash.of_fresh
                            cctxt force name)
                          (fun name =>
                            gen_keys_containing (Some encrypted) (Some prefix)
                              (Some force) containing name cctxt)
                end)
          end
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Encrypt an unencrypted secret key." % string
              Tezos_base__TzPervasives.Clic.no_options
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "encrypt" % string
                    (cons "secret" % string (cons "key" % string []))))
                Tezos_base__TzPervasives.Clic.stop)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun cctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Enter unencrypted secret key: " % string
                            CamlinternalFormatBasics.End_of_format)
                          "Enter unencrypted secret key: " % string))
                      (fun sk_uri =>
                        let sk_uri := Uri.of_string (Bigstring.to_string sk_uri)
                          in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          match Uri.scheme sk_uri with
                          | None | Some "unencrypted" % string =>
                            Tezos_base__TzPervasives.return_unit
                          | _ =>
                            Tezos_base__TzPervasives.failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "This command can only be used with the ""unencrypted"" scheme"
                                    % string
                                  CamlinternalFormatBasics.End_of_format)
                                "This command can only be used with the ""unencrypted"" scheme"
                                  % string)
                          end
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Lwt._return
                                  (Tezos_base__TzPervasives.Signature.Secret_key.of_b58check
                                    (Uri.path sk_uri)))
                                (fun sk =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_signer_backends.Encrypted.encrypt
                                      cctxt sk)
                                    (fun sk_uri =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Encrypted secret key " % string
                                              (CamlinternalFormatBasics.Alpha
                                                CamlinternalFormatBasics.End_of_format))
                                            "Encrypted secret key %a" % string)
                                          Uri.pp_hum sk_uri)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.return_unit
                                          end)))
                            end))
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Add a secret key to the wallet." % string
                (Tezos_base__TzPervasives.Clic.args1
                  (Tezos_client_base.Client_keys.Secret_key.force_switch tt))
                (apply (Tezos_base__TzPervasives.Clic.prefix "import" % string)
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "secret" % string (cons "key" % string [])))
                    (apply
                      (let arg :=
                        Tezos_client_base.Client_keys.Secret_key.fresh_alias_param
                        in
                      fun eta => arg None None eta)
                      (apply
                        (let arg := Tezos_client_base.Client_keys.sk_uri_param
                          in
                        fun eta => arg None None eta)
                        Tezos_base__TzPervasives.Clic.stop))))
                (fun force =>
                  fun name =>
                    fun sk_uri =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_base.Client_keys.Secret_key.of_fresh
                            cctxt force name)
                          (fun name =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_client_base.Client_keys.neuterize sk_uri)
                              (fun pk_uri =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_client_base.Client_keys.Public_key.find_opt
                                      cctxt name)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | None =>
                                        Tezos_base__TzPervasives.return_unit
                                      | Some (pk_uri_found, _) =>
                                        Tezos_base__TzPervasives.fail_unless
                                          (orb (equiv_decb pk_uri pk_uri_found)
                                            force)
                                          (Tezos_base__TzPervasives.failure
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "public and secret keys '" %
                                                  string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.String_literal
                                                    "' don't correspond, please don't use --force"
                                                      % string
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "public and secret keys '%s' don't correspond, please don't use --force"
                                                % string) name)
                                      end))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_client_base.Client_keys.import_secret_key
                                          cctxt pk_uri)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (pkh, public_key) =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Tezos address added: " %
                                                      string
                                                    (CamlinternalFormatBasics.Alpha
                                                      CamlinternalFormatBasics.End_of_format))
                                                  "Tezos address added: %a" %
                                                    string)
                                                Tezos_base__TzPervasives.Signature.Public_key_hash.pp
                                                pkh)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_client_base.Client_keys.register_key
                                                    cctxt (Some force)
                                                    (pkh, pk_uri, sk_uri)
                                                    public_key name
                                                end)
                                          end)
                                    end))))) [])))))
    (OCaml.Stdlib.app
      (if nequiv_decb version (Some variant) then
        []
      else
        cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Add a fundraiser secret key to the wallet." % string
            (Tezos_base__TzPervasives.Clic.args1
              (Tezos_client_base.Client_keys.Secret_key.force_switch tt))
            (apply (Tezos_base__TzPervasives.Clic.prefix "import" % string)
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "fundraiser" % string
                    (cons "secret" % string (cons "key" % string []))))
                (apply
                  (let arg :=
                    Tezos_client_base.Client_keys.Secret_key.fresh_alias_param
                    in
                  fun eta => arg None None eta)
                  Tezos_base__TzPervasives.Clic.stop)))
            (fun force =>
              fun name =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_client_base.Client_keys.Secret_key.of_fresh cctxt
                      force name)
                    (fun name =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (input_fundraiser_params cctxt)
                        (fun sk =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_signer_backends.Encrypted.encrypt cctxt sk)
                            (fun sk_uri =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_client_base.Client_keys.neuterize sk_uri)
                                (fun pk_uri =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_client_base.Client_keys.Public_key.find_opt
                                        cctxt name)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | None =>
                                          Tezos_base__TzPervasives.return_unit
                                        | Some (pk_uri_found, _) =>
                                          Tezos_base__TzPervasives.fail_unless
                                            (orb
                                              (equiv_decb pk_uri pk_uri_found)
                                              force)
                                            (Tezos_base__TzPervasives.failure
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "public and secret keys '" %
                                                    string
                                                  (CamlinternalFormatBasics.String
                                                    CamlinternalFormatBasics.No_padding
                                                    (CamlinternalFormatBasics.String_literal
                                                      "' don't correspond, please don't use --force"
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)))
                                                "public and secret keys '%s' don't correspond, please don't use --force"
                                                  % string) name)
                                        end))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_client_base.Client_keys.public_key_hash
                                            pk_uri)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (pkh, _public_key) =>
                                              Tezos_client_base.Client_keys.register_key
                                                cctxt (Some force)
                                                (pkh, pk_uri, sk_uri) None name
                                            end)
                                      end))))))) [])
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Add a public key to the wallet." % string
          (Tezos_base__TzPervasives.Clic.args1
            (Tezos_client_base.Client_keys.Public_key.force_switch tt))
          (apply (Tezos_base__TzPervasives.Clic.prefix "import" % string)
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "public" % string (cons "key" % string [])))
              (apply
                (let arg :=
                  Tezos_client_base.Client_keys.Public_key.fresh_alias_param in
                fun eta => arg None None eta)
                (apply
                  (let arg := Tezos_client_base.Client_keys.pk_uri_param in
                  fun eta => arg None None eta)
                  Tezos_base__TzPervasives.Clic.stop))))
          (fun force =>
            fun name =>
              fun pk_uri =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_client_base.Client_keys.Public_key.of_fresh cctxt
                      force name)
                    (fun name =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_client_base.Client_keys.public_key_hash pk_uri)
                        (fun function_parameter =>
                          match function_parameter with
                          | (pkh, public_key) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_client_base.Client_keys.Public_key_hash.add
                                force cctxt name pkh)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Tezos address added: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))
                                        "Tezos address added: %a" % string)
                                      Tezos_base__TzPervasives.Signature.Public_key_hash.pp
                                      pkh)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_client_base.Client_keys.Public_key.add
                                          force cctxt name (pk_uri, public_key)
                                      end)
                                end)
                          end))))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Add an address to the wallet." % string
            (Tezos_base__TzPervasives.Clic.args1
              (Tezos_client_base.Client_keys.Public_key.force_switch tt))
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "add" % string (cons "address" % string [])))
              (apply
                (let arg :=
                  Tezos_client_base.Client_keys.Public_key_hash.fresh_alias_param
                  in
                fun eta => arg None None eta)
                (apply
                  (let arg :=
                    Tezos_client_base.Client_keys.Public_key_hash.source_param
                    in
                  fun eta => arg None None eta)
                  Tezos_base__TzPervasives.Clic.stop)))
            (fun force =>
              fun name =>
                fun hash =>
                  fun cctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_client_base.Client_keys.Public_key_hash.of_fresh
                        cctxt force name)
                      (fun name =>
                        Tezos_client_base.Client_keys.Public_key_hash.add force
                          cctxt name hash)))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "List all addresses and associated keys." % string
              Tezos_base__TzPervasives.Clic.no_options
              (Tezos_base__TzPervasives.Clic.fixed
                (cons "list" % string
                  (cons "known" % string (cons "addresses" % string []))))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun cctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_client_base.Client_keys.list_keys cctxt)
                      (fun l =>
                        Tezos_base__TzPervasives.iter_s
                          (fun function_parameter =>
                            match function_parameter with
                            | (name, pkh, pk, sk) =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_client_base.Client_keys.Public_key_hash.to_source
                                  pkh)
                                (fun v =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    match (pk, sk) with
                                    | (None, None) =>
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              ": " % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.End_of_format)))
                                          "%s: %s" % string) name v
                                    | (_, Some uri) =>
                                      let scheme :=
                                        apply
                                          (Tezos_base__TzPervasives.Option.unopt
                                            "unencrypted" % string)
                                          (Uri.scheme uri) in
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              ": " % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                (CamlinternalFormatBasics.String_literal
                                                  " (" % string
                                                  (CamlinternalFormatBasics.String
                                                    CamlinternalFormatBasics.No_padding
                                                    (CamlinternalFormatBasics.String_literal
                                                      " sk known)" % string
                                                      CamlinternalFormatBasics.End_of_format))))))
                                          "%s: %s (%s sk known)" % string) name
                                        v scheme
                                    | (Some _, _) =>
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              ": " % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                (CamlinternalFormatBasics.String_literal
                                                  " (pk known)" % string
                                                  CamlinternalFormatBasics.End_of_format))))
                                          "%s: %s (pk known)" % string) name v
                                    end
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.return_unit
                                      end))
                            end) l)
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Show the keys associated with an implicit account." % string
                (Tezos_base__TzPervasives.Clic.args1 show_private_switch)
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "show" % string (cons "address" % string [])))
                  (apply
                    (let arg :=
                      Tezos_client_base.Client_keys.Public_key_hash.alias_param
                      in
                    fun eta => arg None None eta)
                    Tezos_base__TzPervasives.Clic.stop))
                (fun show_private =>
                  fun function_parameter =>
                    match function_parameter with
                    | (name, _) =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_base.Client_keys.alias_keys cctxt name)
                          (fun key_info =>
                            match key_info with
                            | None =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "No keys found for address" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "No keys found for address" % string))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                            | Some (pkh, pk, skloc) =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Hash: " % string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))
                                    "Hash: %a" % string)
                                  Tezos_base__TzPervasives.Signature.Public_key_hash.pp
                                  pkh)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    match pk with
                                    | None =>
                                      Tezos_base__TzPervasives.return_unit
                                    | Some pk =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Public Key: " % string
                                              (CamlinternalFormatBasics.Alpha
                                                CamlinternalFormatBasics.End_of_format))
                                            "Public Key: %a" % string)
                                          Tezos_base__TzPervasives.Signature.Public_key.pp
                                          pk)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            if show_private then
                                              match skloc with
                                              | None =>
                                                Tezos_base__TzPervasives.return_unit
                                              | Some skloc =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_client_base.Client_keys.Secret_key.to_source
                                                    skloc)
                                                  (fun skloc =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (send
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Secret Key: " %
                                                              string
                                                            (CamlinternalFormatBasics.String
                                                              CamlinternalFormatBasics.No_padding
                                                              CamlinternalFormatBasics.End_of_format))
                                                          "Secret Key: %s" %
                                                            string) skloc)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.return_unit
                                                        end))
                                              end
                                            else
                                              Tezos_base__TzPervasives.return_unit
                                          end)
                                    end
                                  end)
                            end)
                    end))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some group)
                  "Forget one address." % string
                  (Tezos_base__TzPervasives.Clic.args1
                    (Tezos_base__TzPervasives.Clic.switch
                      "delete associated keys when present" % string
                      (Some "f" % char) "force" % string tt))
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "forget" % string (cons "address" % string [])))
                    (apply
                      (let arg :=
                        Tezos_client_base.Client_keys.Public_key_hash.alias_param
                        in
                      fun eta => arg None None eta)
                      Tezos_base__TzPervasives.Clic.stop))
                  (fun force =>
                    fun function_parameter =>
                      match function_parameter with
                      | (name, _pkh) =>
                        fun cctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_client_base.Client_keys.Secret_key.mem cctxt
                              name)
                            (fun has_secret_key =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_client_base.Client_keys.Public_key.mem
                                  cctxt name)
                                (fun has_public_key =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_base__TzPervasives.fail_when
                                      (andb (negb force)
                                        (orb has_secret_key has_public_key))
                                      (Tezos_base__TzPervasives.failure
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "secret or public key present for "
                                              % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.String_literal
                                                ", use --force to delete" %
                                                  string
                                                CamlinternalFormatBasics.End_of_format)))
                                          "secret or public key present for %s, use --force to delete"
                                            % string) name))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_client_base.Client_keys.Secret_key.del
                                            cctxt name)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_client_base.Client_keys.Public_key.del
                                                  cctxt name)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_client_base.Client_keys.Public_key_hash.del
                                                      cctxt name
                                                  end)
                                            end)
                                      end)))
                      end))
                (cons
                  (Tezos_base__TzPervasives.Clic.command (Some group)
                    "Forget the entire wallet of keys." % string
                    (Tezos_base__TzPervasives.Clic.args1
                      (Tezos_base__TzPervasives.Clic.switch
                        "you got to use the force for that" % string
                        (Some "f" % char) "force" % string tt))
                    (Tezos_base__TzPervasives.Clic.fixed
                      (cons "forget" % string
                        (cons "all" % string (cons "keys" % string []))))
                    (fun force =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base__TzPervasives.fail_unless force
                            (Tezos_base__TzPervasives.failure
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "this can only be used with option --force" %
                                    string
                                  CamlinternalFormatBasics.End_of_format)
                                "this can only be used with option --force" %
                                  string)))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_client_base.Client_keys.Public_key.set
                                  cctxt [])
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_client_base.Client_keys.Secret_key.set
                                        cctxt [])
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_client_base.Client_keys.Public_key_hash.set
                                            cctxt []
                                        end)
                                  end)
                            end)))
                  (cons
                    (Tezos_base__TzPervasives.Clic.command (Some group)
                      "Compute deterministic nonce." % string
                      Tezos_base__TzPervasives.Clic.no_options
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "generate" % string
                            (cons "nonce" % string (cons "for" % string []))))
                        (apply
                          (let arg :=
                            Tezos_client_base.Client_keys.Public_key_hash.alias_param
                            in
                          fun eta => arg None None eta)
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefixes
                              (cons "from" % string []))
                            (apply
                              (Tezos_base__TzPervasives.Clic.string
                                "data" % string
                                "string from which to deterministically generate the nonce"
                                  % string) Tezos_base__TzPervasives.Clic.stop))))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          fun function_parameter =>
                            match function_parameter with
                            | (name, _pkh) =>
                              fun data =>
                                fun cctxt =>
                                  let data := Stdlib.Bytes.of_string data in
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_client_base.Client_keys.Secret_key.mem
                                      cctxt name)
                                    (fun sk_present =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_base__TzPervasives.fail_unless
                                          sk_present
                                          (Tezos_base__TzPervasives.failure
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "secret key not present for " %
                                                  string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.End_of_format))
                                              "secret key not present for %s" %
                                                string) name))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                              (Tezos_client_base.Client_keys.Secret_key.find
                                                cctxt name)
                                              (fun sk_uri =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_client_base.Client_keys.deterministic_nonce
                                                    sk_uri data)
                                                  (fun nonce =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (send
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.Alpha
                                                            CamlinternalFormatBasics.End_of_format)
                                                          "%a" % string) Hex.pp
                                                        (Hex.of_bytes None
                                                          (Bigstring.to_bytes
                                                            nonce)))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.return_unit
                                                        end)))
                                          end))
                            end
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Clic.command (Some group)
                        "Compute deterministic nonce hash." % string
                        Tezos_base__TzPervasives.Clic.no_options
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "generate" % string
                              (cons "nonce" % string
                                (cons "hash" % string (cons "for" % string [])))))
                          (apply
                            (let arg :=
                              Tezos_client_base.Client_keys.Public_key_hash.alias_param
                              in
                            fun eta => arg None None eta)
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "from" % string []))
                              (apply
                                (Tezos_base__TzPervasives.Clic.string
                                  "data" % string
                                  "string from which to deterministically generate the nonce hash"
                                    % string) Tezos_base__TzPervasives.Clic.stop))))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            fun function_parameter =>
                              match function_parameter with
                              | (name, _pkh) =>
                                fun data =>
                                  fun cctxt =>
                                    let data := Stdlib.Bytes.of_string data in
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_client_base.Client_keys.Secret_key.mem
                                        cctxt name)
                                      (fun sk_present =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_base__TzPervasives.fail_unless
                                            sk_present
                                            (Tezos_base__TzPervasives.failure
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "secret key not present for "
                                                    % string
                                                  (CamlinternalFormatBasics.String
                                                    CamlinternalFormatBasics.No_padding
                                                    CamlinternalFormatBasics.End_of_format))
                                                "secret key not present for %s"
                                                  % string) name))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_client_base.Client_keys.Secret_key.find
                                                  cctxt name)
                                                (fun sk_uri =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    (Tezos_client_base.Client_keys.deterministic_nonce_hash
                                                      sk_uri data)
                                                    (fun nonce_hash =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.Alpha
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "%a" % string)
                                                          Hex.pp
                                                          (Hex.of_bytes None
                                                            nonce_hash))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)))
                                            end))
                              end
                          end)) []))))))))).
src/lib_client_commands/client_keys_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands :
  [`Zeronet | `Alphanet | `Mainnet | `Sandbox] option ->
  Client_context.full Clic.command list
src/lib_client_commands/client_keys_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands : forall {variant : Type},
(option variant) ->
  list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full).
src/lib_client_commands/client_p2p_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let group =
  {
    Clic.name = "p2p";
    title = "Commands for monitoring and controlling p2p-layer state";
  }

let pp_connection_info ppf conn =
  P2p_connection.Info.pp (fun _ _ -> ()) ppf conn

let addr_parameter =
  let open Clic in
  param
    ~name:"address"
    ~desc:"<IPv4>:PORT or <IPV6>:PORT address (PORT defaults to 9732)."
    (parameter (fun _ x ->
         return (P2p_point.Id.of_string_exn ~default_port:9732 x)))

let p2p_peer_id_param ~name ~desc t =
  Clic.param
    ~name
    ~desc
    (Clic.parameter (fun _ str -> Lwt.return (P2p_peer.Id.of_b58check str)))
    t

let commands () =
  let open Clic in
  [ command
      ~group
      ~desc:"show global network status"
      no_options
      (prefixes ["p2p"; "stat"] stop)
      (fun () (cctxt : #Client_context.full) ->
        Shell_services.P2p.stat cctxt
        >>=? fun stat ->
        Shell_services.P2p.Connections.list cctxt
        >>=? fun conns ->
        Shell_services.P2p.Peers.list cctxt
        >>=? fun peers ->
        Shell_services.P2p.Points.list cctxt
        >>=? fun points ->
        cctxt#message "GLOBAL STATS"
        >>= fun () ->
        cctxt#message "  %a" P2p_stat.pp stat
        >>= fun () ->
        cctxt#message "CONNECTIONS"
        >>= fun () ->
        let (incoming, outgoing) =
          List.partition (fun c -> c.P2p_connection.Info.incoming) conns
        in
        Lwt_list.iter_s
          (fun conn -> cctxt#message "  %a" pp_connection_info conn)
          incoming
        >>= fun () ->
        Lwt_list.iter_s
          (fun conn -> cctxt#message "  %a" pp_connection_info conn)
          outgoing
        >>= fun () ->
        cctxt#message "KNOWN PEERS"
        >>= fun () ->
        Lwt_list.iter_s
          (fun (p, pi) ->
            cctxt#message
              "  %a  %.0f %a %a %s"
              P2p_peer.State.pp_digram
              pi.P2p_peer.Info.state
              pi.score
              P2p_peer.Id.pp
              p
              P2p_stat.pp
              pi.stat
              (if pi.trusted then "★" else " "))
          peers
        >>= fun () ->
        cctxt#message "KNOWN POINTS"
        >>= fun () ->
        Lwt_list.iter_s
          (fun (p, pi) ->
            match pi.P2p_point.Info.state with
            | Running peer_id ->
                cctxt#message
                  "  %a  %a %a %s"
                  P2p_point.State.pp_digram
                  pi.state
                  P2p_point.Id.pp
                  p
                  P2p_peer.Id.pp
                  peer_id
                  (if pi.trusted then "★" else " ")
            | _ -> (
              match pi.last_seen with
              | Some (peer_id, ts) ->
                  cctxt#message
                    "  %a  %a (last seen: %a %a) %s"
                    P2p_point.State.pp_digram
                    pi.state
                    P2p_point.Id.pp
                    p
                    P2p_peer.Id.pp
                    peer_id
                    Time.System.pp_hum
                    ts
                    (if pi.trusted then "★" else " ")
              | None ->
                  cctxt#message
                    "  %a  %a %s"
                    P2p_point.State.pp_digram
                    pi.state
                    P2p_point.Id.pp
                    p
                    (if pi.trusted then "★" else " ") ))
          points
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Connect to a new point."
      no_options
      (prefixes ["connect"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, port) (cctxt : #Client_context.full) ->
        let timeout = Time.System.Span.of_seconds_exn 10. in
        P2p_services.connect cctxt ~timeout (address, port)
        >>= function
        | Ok () ->
            cctxt#message
              "Connection to %a:%d established."
              P2p_addr.pp
              address
              port
            >>= fun () -> return_unit
        | Error (Tezos_p2p.P2p_errors.Pending_connection :: _) ->
            cctxt#warning "Already connecting to peer %a" P2p_addr.pp address
            >>= fun () -> return_unit
        | Error (Tezos_p2p.P2p_errors.Connected :: _) ->
            cctxt#warning "Already connected to peer %a" P2p_addr.pp address
            >>= fun () -> return_unit
        | Error _ as e ->
            Lwt.return e);
    command
      ~group
      ~desc:"Kick a peer."
      no_options
      ( prefixes ["kick"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Connections.kick cctxt peer
        >>=? fun () ->
        cctxt#message "Connection to %a interrupted." P2p_peer.Id.pp peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Add an IP address and all its ports to the blacklist and kicks it. \
         Remove the address from the whitelist if it was previously in it."
      no_options
      (prefixes ["ban"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, _port) (cctxt : #Client_context.full) ->
        P2p_services.Points.ban cctxt (address, 0)
        >>=? fun () ->
        cctxt#message "Address %a:* is now banned." P2p_addr.pp address
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Remove an IP address and all its ports from the blacklist."
      no_options
      (prefixes ["unban"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, _port) (cctxt : #Client_context.full) ->
        P2p_services.Points.unban cctxt (address, 0)
        >>=? fun () ->
        cctxt#message "Address %a:* is now unbanned." P2p_addr.pp address
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Add an IP address to the whitelist. Remove the address from the \
         blacklist if it was previously in it."
      no_options
      (prefixes ["trust"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, port) (cctxt : #Client_context.full) ->
        P2p_services.Points.trust cctxt (address, port)
        >>=? fun () ->
        cctxt#message "Address %a:%d is now trusted." P2p_addr.pp address port
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Removes an IP address from the whitelist."
      no_options
      (prefixes ["untrust"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, port) (cctxt : #Client_context.full) ->
        P2p_services.Points.untrust cctxt (address, port)
        >>=? fun () ->
        cctxt#message
          "Address %a:%d is now untrusted."
          P2p_addr.pp
          address
          port
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Check if an IP address is banned."
      no_options
      (prefixes ["is"; "address"; "banned"] @@ addr_parameter @@ stop)
      (fun () (address, port) (cctxt : #Client_context.full) ->
        P2p_services.Points.banned cctxt (address, port)
        >>=? fun banned ->
        cctxt#message
          "The given ip address is %s"
          (if banned then "banned" else "not banned")
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Check if a peer ID is banned."
      no_options
      ( prefixes ["is"; "peer"; "banned"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.banned cctxt peer
        >>=? fun banned ->
        cctxt#message
          "The given peer ID is %s"
          (if banned then "banned" else "not banned")
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Add a peer ID to the blacklist and kicks it. Remove the peer ID from \
         the blacklist if was previously in it."
      no_options
      ( prefixes ["ban"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.ban cctxt peer
        >>=? fun () ->
        cctxt#message "The peer %a is now banned." P2p_peer.Id.pp_short peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Removes a peer ID from the blacklist."
      no_options
      ( prefixes ["unban"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.unban cctxt peer
        >>=? fun () ->
        cctxt#message "The peer %a is now unbanned." P2p_peer.Id.pp_short peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Add a peer ID to the whitelist. Remove the peer ID from the \
         blacklist if it was previously in it."
      no_options
      ( prefixes ["trust"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.trust cctxt peer
        >>=? fun () ->
        cctxt#message "The peer %a is now trusted." P2p_peer.Id.pp_short peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Remove a peer ID from the whitelist."
      no_options
      ( prefixes ["untrust"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.untrust cctxt peer
        >>=? fun () ->
        cctxt#message "The peer %a is now untrusted." P2p_peer.Id.pp_short peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Clear all access control rules."
      no_options
      (prefixes ["clear"; "acls"] @@ stop)
      (fun () (cctxt : #Client_context.full) ->
        P2p_services.ACL.clear cctxt ()
        >>=? fun () ->
        cctxt#message "The access control rules are now cleared."
        >>= fun () -> return_unit) ]
src/lib_client_commands/client_p2p_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "p2p" % string;
    Clic.title :=
      "Commands for monitoring and controlling p2p-layer state" % string |}.

Definition pp_connection_info {A : Type}
  (ppf : Stdlib.Format.formatter)
  (conn : Tezos_base__TzPervasives.P2p_connection.Info.t A) : unit :=
  Tezos_base__TzPervasives.P2p_connection.Info.pp
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => tt
          end
      end) ppf conn.

Definition addr_parameter {F G I a b i o p q : Type}
  : (Tezos_base__TzPervasives.Clic.params
    ((((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
    (((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I)) ->
    Tezos_base__TzPervasives.Clic.params
      (Tezos_base__TzPervasives.P2p_point.Id.t ->
        (((float -> Lwt.t unit) *
          ((unit -> Ptime.t) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (F * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (G * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * I)))))))))))))))))))))
          * I) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I) :=
  Tezos_base__TzPervasives.Clic.param "address" % string
    "<IPv4>:PORT or <IPV6>:PORT address (PORT defaults to 9732)." % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun x =>
            Tezos_base__TzPervasives._return
              (Tezos_base__TzPervasives.P2p_point.Id.of_string_exn (Some 9732) x)
        end)).

Definition p2p_peer_id_param {A B : Type}
  (name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.P2p_peer.Id.t -> A) B :=
  Tezos_base__TzPervasives.Clic.param name desc
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun str =>
            Lwt._return (Tezos_base__TzPervasives.P2p_peer.Id.of_b58check str)
        end)) t.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  match function_parameter with
  | tt =>
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "show global network status" % string
        Tezos_base__TzPervasives.Clic.no_options
        (Tezos_base__TzPervasives.Clic.prefixes
          (cons "p2p" % string (cons "stat" % string []))
          Tezos_base__TzPervasives.Clic.stop)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun cctxt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell_services.Shell_services.P2p.stat cctxt)
                (fun stat =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_shell_services.Shell_services.P2p.Connections.list
                      cctxt)
                    (fun conns =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_shell_services.Shell_services.P2p.Peers.list None
                          cctxt)
                        (fun peers =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_shell_services.Shell_services.P2p.Points.list
                              None cctxt)
                            (fun points =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "GLOBAL STATS" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "GLOBAL STATS" % string))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "  " % string
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format))
                                          "  %a" % string)
                                        Tezos_base__TzPervasives.P2p_stat.pp
                                        stat)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "CONNECTIONS" % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "CONNECTIONS" % string))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                match
                                                  Tezos_base__TzPervasives.List.partition
                                                    (fun c =>
                                                      P2p_connection.Info.incoming
                                                        c) conns with
                                                | (incoming, outgoing) =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                    (Lwt_list.iter_s
                                                      (fun conn =>
                                                        send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "  " % string
                                                              (CamlinternalFormatBasics.Alpha
                                                                CamlinternalFormatBasics.End_of_format))
                                                            "  %a" % string)
                                                          pp_connection_info
                                                          conn) incoming)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (Lwt_list.iter_s
                                                            (fun conn =>
                                                              send
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "  " %
                                                                      string
                                                                    (CamlinternalFormatBasics.Alpha
                                                                      CamlinternalFormatBasics.End_of_format))
                                                                  "  %a" %
                                                                    string)
                                                                pp_connection_info
                                                                conn) outgoing)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (send
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "KNOWN PEERS"
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "KNOWN PEERS"
                                                                      % string))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                      (Lwt_list.iter_s
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          |
                                                                            (p,
                                                                              pi)
                                                                            =>
                                                                            send
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "  "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      "  "
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Float
                                                                                        CamlinternalFormatBasics.Float_f
                                                                                        CamlinternalFormatBasics.No_padding
                                                                                        (CamlinternalFormatBasics.Lit_precision
                                                                                          0)
                                                                                        (CamlinternalFormatBasics.Char_literal
                                                                                          " "
                                                                                            %
                                                                                            char
                                                                                          (CamlinternalFormatBasics.Alpha
                                                                                            (CamlinternalFormatBasics.Char_literal
                                                                                              " "
                                                                                                %
                                                                                                char
                                                                                              (CamlinternalFormatBasics.Alpha
                                                                                                (CamlinternalFormatBasics.Char_literal
                                                                                                  " "
                                                                                                    %
                                                                                                    char
                                                                                                  (CamlinternalFormatBasics.String
                                                                                                    CamlinternalFormatBasics.No_padding
                                                                                                    CamlinternalFormatBasics.End_of_format))))))))))
                                                                                "  %a  %.0f %a %a %s"
                                                                                  %
                                                                                  string)
                                                                              Tezos_base__TzPervasives.P2p_peer.State.pp_digram
                                                                              (P2p_peer.Info.state
                                                                                pi)
                                                                              (score
                                                                                pi)
                                                                              Tezos_base__TzPervasives.P2p_peer.Id.pp
                                                                              p
                                                                              Tezos_base__TzPervasives.P2p_stat.pp
                                                                              (stat
                                                                                pi)
                                                                              (if
                                                                                trusted
                                                                                  pi
                                                                                then
                                                                                "★"
                                                                                  %
                                                                                  string
                                                                              else
                                                                                " "
                                                                                  %
                                                                                  string)
                                                                          end)
                                                                        peers)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                            (send
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "KNOWN POINTS"
                                                                                    %
                                                                                    string
                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                "KNOWN POINTS"
                                                                                  %
                                                                                  string))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                  (Lwt_list.iter_s
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        (p,
                                                                                          pi)
                                                                                        =>
                                                                                        match
                                                                                          P2p_point.Info.state
                                                                                            pi
                                                                                          with
                                                                                        |
                                                                                          Running
                                                                                            peer_id
                                                                                          =>
                                                                                          send
                                                                                            (CamlinternalFormatBasics.Format
                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                "  "
                                                                                                  %
                                                                                                  string
                                                                                                (CamlinternalFormatBasics.Alpha
                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                    "  "
                                                                                                      %
                                                                                                      string
                                                                                                    (CamlinternalFormatBasics.Alpha
                                                                                                      (CamlinternalFormatBasics.Char_literal
                                                                                                        " "
                                                                                                          %
                                                                                                          char
                                                                                                        (CamlinternalFormatBasics.Alpha
                                                                                                          (CamlinternalFormatBasics.Char_literal
                                                                                                            " "
                                                                                                              %
                                                                                                              char
                                                                                                            (CamlinternalFormatBasics.String
                                                                                                              CamlinternalFormatBasics.No_padding
                                                                                                              CamlinternalFormatBasics.End_of_format))))))))
                                                                                              "  %a  %a %a %s"
                                                                                                %
                                                                                                string)
                                                                                            Tezos_base__TzPervasives.P2p_point.State.pp_digram
                                                                                            (state
                                                                                              pi)
                                                                                            Tezos_base__TzPervasives.P2p_point.Id.pp
                                                                                            p
                                                                                            Tezos_base__TzPervasives.P2p_peer.Id.pp
                                                                                            peer_id
                                                                                            (if
                                                                                              trusted
                                                                                                pi
                                                                                              then
                                                                                              "★"
                                                                                                %
                                                                                                string
                                                                                            else
                                                                                              " "
                                                                                                %
                                                                                                string)
                                                                                        |
                                                                                          _
                                                                                          =>
                                                                                          match
                                                                                            last_seen
                                                                                              pi
                                                                                            with
                                                                                          |
                                                                                            Some
                                                                                              (peer_id,
                                                                                                ts)
                                                                                            =>
                                                                                            send
                                                                                              (CamlinternalFormatBasics.Format
                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                  "  "
                                                                                                    %
                                                                                                    string
                                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                                      "  "
                                                                                                        %
                                                                                                        string
                                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                                          " (last seen: "
                                                                                                            %
                                                                                                            string
                                                                                                          (CamlinternalFormatBasics.Alpha
                                                                                                            (CamlinternalFormatBasics.Char_literal
                                                                                                              " "
                                                                                                                %
                                                                                                                char
                                                                                                              (CamlinternalFormatBasics.Alpha
                                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                                  ") "
                                                                                                                    %
                                                                                                                    string
                                                                                                                  (CamlinternalFormatBasics.String
                                                                                                                    CamlinternalFormatBasics.No_padding
                                                                                                                    CamlinternalFormatBasics.End_of_format))))))))))
                                                                                                "  %a  %a (last seen: %a %a) %s"
                                                                                                  %
                                                                                                  string)
                                                                                              Tezos_base__TzPervasives.P2p_point.State.pp_digram
                                                                                              (state
                                                                                                pi)
                                                                                              Tezos_base__TzPervasives.P2p_point.Id.pp
                                                                                              p
                                                                                              Tezos_base__TzPervasives.P2p_peer.Id.pp
                                                                                              peer_id
                                                                                              Tezos_base__TzPervasives.Time.System.pp_hum
                                                                                              ts
                                                                                              (if
                                                                                                trusted
                                                                                                  pi
                                                                                                then
                                                                                                "★"
                                                                                                  %
                                                                                                  string
                                                                                              else
                                                                                                " "
                                                                                                  %
                                                                                                  string)
                                                                                          |
                                                                                            None
                                                                                            =>
                                                                                            send
                                                                                              (CamlinternalFormatBasics.Format
                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                  "  "
                                                                                                    %
                                                                                                    string
                                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                                      "  "
                                                                                                        %
                                                                                                        string
                                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                                        (CamlinternalFormatBasics.Char_literal
                                                                                                          " "
                                                                                                            %
                                                                                                            char
                                                                                                          (CamlinternalFormatBasics.String
                                                                                                            CamlinternalFormatBasics.No_padding
                                                                                                            CamlinternalFormatBasics.End_of_format))))))
                                                                                                "  %a  %a %s"
                                                                                                  %
                                                                                                  string)
                                                                                              Tezos_base__TzPervasives.P2p_point.State.pp_digram
                                                                                              (state
                                                                                                pi)
                                                                                              Tezos_base__TzPervasives.P2p_point.Id.pp
                                                                                              p
                                                                                              (if
                                                                                                trusted
                                                                                                  pi
                                                                                                then
                                                                                                "★"
                                                                                                  %
                                                                                                  string
                                                                                              else
                                                                                                " "
                                                                                                  %
                                                                                                  string)
                                                                                          end
                                                                                        end
                                                                                      end)
                                                                                    points)
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      Tezos_base__TzPervasives.return_unit
                                                                                    end)
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end)
                                                end
                                              end)
                                        end)
                                  end)))))
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Connect to a new point." % string
          Tezos_base__TzPervasives.Clic.no_options
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "connect" % string (cons "address" % string [])))
            (apply addr_parameter Tezos_base__TzPervasives.Clic.stop))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (address, port) =>
                  fun cctxt =>
                    let timeout :=
                      Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn
                        10 in
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell_services.P2p_services.connect cctxt timeout
                        (address, port))
                      (fun function_parameter =>
                        match function_parameter with
                        | inl tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Connection to " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      ":" % char
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.String_literal
                                          " established." % string
                                          CamlinternalFormatBasics.End_of_format)))))
                                "Connection to %a:%d established." % string)
                              Tezos_base__TzPervasives.P2p_addr.pp address port)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        | inr (cons Tezos_p2p.P2p_errors.Pending_connection _)
                          =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Already connecting to peer " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))
                                "Already connecting to peer %a" % string)
                              Tezos_base__TzPervasives.P2p_addr.pp address)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        | inr (cons Tezos_p2p.P2p_errors.Connected _) =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Already connected to peer " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))
                                "Already connected to peer %a" % string)
                              Tezos_base__TzPervasives.P2p_addr.pp address)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        | (inr _) as e => Lwt._return e
                        end)
                end
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Kick a peer." % string Tezos_base__TzPervasives.Clic.no_options
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "kick" % string (cons "peer" % string [])))
              (apply
                (p2p_peer_id_param "peer" % string
                  "peer network identity" % string)
                Tezos_base__TzPervasives.Clic.stop))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun peer =>
                  fun cctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell_services.P2p_services.Connections.kick cctxt
                        None peer)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Connection to " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " interrupted." % string
                                      CamlinternalFormatBasics.End_of_format)))
                                "Connection to %a interrupted." % string)
                              Tezos_base__TzPervasives.P2p_peer.Id.pp peer)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        end)
              end))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Add an IP address and all its ports to the blacklist and kicks it. Remove the address from the whitelist if it was previously in it."
                % string Tezos_base__TzPervasives.Clic.no_options
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "ban" % string (cons "address" % string [])))
                (apply addr_parameter Tezos_base__TzPervasives.Clic.stop))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun function_parameter =>
                    match function_parameter with
                    | (address, _port) =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_shell_services.P2p_services.Points.ban cctxt
                            (address, 0))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Address " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          ":* is now banned." % string
                                          CamlinternalFormatBasics.End_of_format)))
                                    "Address %a:* is now banned." % string)
                                  Tezos_base__TzPervasives.P2p_addr.pp address)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                            end)
                    end
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Remove an IP address and all its ports from the blacklist." %
                  string Tezos_base__TzPervasives.Clic.no_options
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "unban" % string (cons "address" % string [])))
                  (apply addr_parameter Tezos_base__TzPervasives.Clic.stop))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    fun function_parameter =>
                      match function_parameter with
                      | (address, _port) =>
                        fun cctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_shell_services.P2p_services.Points.unban
                              cctxt (address, 0))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Address " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            ":* is now unbanned." % string
                                            CamlinternalFormatBasics.End_of_format)))
                                      "Address %a:* is now unbanned." % string)
                                    Tezos_base__TzPervasives.P2p_addr.pp address)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end)
                              end)
                      end
                  end))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some group)
                  "Add an IP address to the whitelist. Remove the address from the blacklist if it was previously in it."
                    % string Tezos_base__TzPervasives.Clic.no_options
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "trust" % string (cons "address" % string [])))
                    (apply addr_parameter Tezos_base__TzPervasives.Clic.stop))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      fun function_parameter =>
                        match function_parameter with
                        | (address, port) =>
                          fun cctxt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_shell_services.P2p_services.Points.trust
                                cctxt (address, port))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Address " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Char_literal
                                              ":" % char
                                              (CamlinternalFormatBasics.Int
                                                CamlinternalFormatBasics.Int_d
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.No_precision
                                                (CamlinternalFormatBasics.String_literal
                                                  " is now trusted." % string
                                                  CamlinternalFormatBasics.End_of_format)))))
                                        "Address %a:%d is now trusted." % string)
                                      Tezos_base__TzPervasives.P2p_addr.pp
                                      address port)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.return_unit
                                      end)
                                end)
                        end
                    end))
                (cons
                  (Tezos_base__TzPervasives.Clic.command (Some group)
                    "Removes an IP address from the whitelist." % string
                    Tezos_base__TzPervasives.Clic.no_options
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "untrust" % string (cons "address" % string [])))
                      (apply addr_parameter Tezos_base__TzPervasives.Clic.stop))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        fun function_parameter =>
                          match function_parameter with
                          | (address, port) =>
                            fun cctxt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_shell_services.P2p_services.Points.untrust
                                  cctxt (address, port))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Address " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                ":" % char
                                                (CamlinternalFormatBasics.Int
                                                  CamlinternalFormatBasics.Int_d
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.No_precision
                                                  (CamlinternalFormatBasics.String_literal
                                                    " is now untrusted." %
                                                      string
                                                    CamlinternalFormatBasics.End_of_format)))))
                                          "Address %a:%d is now untrusted." %
                                            string)
                                        Tezos_base__TzPervasives.P2p_addr.pp
                                        address port)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.return_unit
                                        end)
                                  end)
                          end
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Clic.command (Some group)
                      "Check if an IP address is banned." % string
                      Tezos_base__TzPervasives.Clic.no_options
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "is" % string
                            (cons "address" % string (cons "banned" % string []))))
                        (apply addr_parameter Tezos_base__TzPervasives.Clic.stop))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          fun function_parameter =>
                            match function_parameter with
                            | (address, port) =>
                              fun cctxt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_shell_services.P2p_services.Points.banned
                                    cctxt (address, port))
                                  (fun banned =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "The given ip address is " % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              CamlinternalFormatBasics.End_of_format))
                                          "The given ip address is %s" % string)
                                        (if banned then
                                          "banned" % string
                                        else
                                          "not banned" % string))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.return_unit
                                        end))
                            end
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Clic.command (Some group)
                        "Check if a peer ID is banned." % string
                        Tezos_base__TzPervasives.Clic.no_options
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "is" % string
                              (cons "peer" % string (cons "banned" % string []))))
                          (apply
                            (p2p_peer_id_param "peer" % string
                              "peer network identity" % string)
                            Tezos_base__TzPervasives.Clic.stop))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            fun peer =>
                              fun cctxt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_shell_services.P2p_services.Peers.banned
                                    cctxt peer)
                                  (fun banned =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "The given peer ID is " % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              CamlinternalFormatBasics.End_of_format))
                                          "The given peer ID is %s" % string)
                                        (if banned then
                                          "banned" % string
                                        else
                                          "not banned" % string))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.return_unit
                                        end))
                          end))
                      (cons
                        (Tezos_base__TzPervasives.Clic.command (Some group)
                          "Add a peer ID to the blacklist and kicks it. Remove the peer ID from the blacklist if was previously in it."
                            % string Tezos_base__TzPervasives.Clic.no_options
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefixes
                              (cons "ban" % string (cons "peer" % string [])))
                            (apply
                              (p2p_peer_id_param "peer" % string
                                "peer network identity" % string)
                              Tezos_base__TzPervasives.Clic.stop))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              fun peer =>
                                fun cctxt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_shell_services.P2p_services.Peers.ban
                                      cctxt peer)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "The peer " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.String_literal
                                                    " is now banned." % string
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "The peer %a is now banned." %
                                                string)
                                            Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                                            peer)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.return_unit
                                            end)
                                      end)
                            end))
                        (cons
                          (Tezos_base__TzPervasives.Clic.command (Some group)
                            "Removes a peer ID from the blacklist." % string
                            Tezos_base__TzPervasives.Clic.no_options
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "unban" % string (cons "peer" % string [])))
                              (apply
                                (p2p_peer_id_param "peer" % string
                                  "peer network identity" % string)
                                Tezos_base__TzPervasives.Clic.stop))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                fun peer =>
                                  fun cctxt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_shell_services.P2p_services.Peers.unban
                                        cctxt peer)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "The peer " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.String_literal
                                                      " is now unbanned." %
                                                        string
                                                      CamlinternalFormatBasics.End_of_format)))
                                                "The peer %a is now unbanned." %
                                                  string)
                                              Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                                              peer)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.return_unit
                                              end)
                                        end)
                              end))
                          (cons
                            (Tezos_base__TzPervasives.Clic.command (Some group)
                              "Add a peer ID to the whitelist. Remove the peer ID from the blacklist if it was previously in it."
                                % string
                              Tezos_base__TzPervasives.Clic.no_options
                              (apply
                                (Tezos_base__TzPervasives.Clic.prefixes
                                  (cons "trust" % string
                                    (cons "peer" % string [])))
                                (apply
                                  (p2p_peer_id_param "peer" % string
                                    "peer network identity" % string)
                                  Tezos_base__TzPervasives.Clic.stop))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  fun peer =>
                                    fun cctxt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_shell_services.P2p_services.Peers.trust
                                          cctxt peer)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "The peer " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        " is now trusted." %
                                                          string
                                                        CamlinternalFormatBasics.End_of_format)))
                                                  "The peer %a is now trusted."
                                                    % string)
                                                Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                                                peer)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.return_unit
                                                end)
                                          end)
                                end))
                            (cons
                              (Tezos_base__TzPervasives.Clic.command
                                (Some group)
                                "Remove a peer ID from the whitelist." % string
                                Tezos_base__TzPervasives.Clic.no_options
                                (apply
                                  (Tezos_base__TzPervasives.Clic.prefixes
                                    (cons "untrust" % string
                                      (cons "peer" % string [])))
                                  (apply
                                    (p2p_peer_id_param "peer" % string
                                      "peer network identity" % string)
                                    Tezos_base__TzPervasives.Clic.stop))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    fun peer =>
                                      fun cctxt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_shell_services.P2p_services.Peers.untrust
                                            cctxt peer)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "The peer " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.String_literal
                                                          " is now untrusted." %
                                                            string
                                                          CamlinternalFormatBasics.End_of_format)))
                                                    "The peer %a is now untrusted."
                                                      % string)
                                                  Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                                                  peer)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.return_unit
                                                  end)
                                            end)
                                  end))
                              (cons
                                (Tezos_base__TzPervasives.Clic.command
                                  (Some group)
                                  "Clear all access control rules." % string
                                  Tezos_base__TzPervasives.Clic.no_options
                                  (apply
                                    (Tezos_base__TzPervasives.Clic.prefixes
                                      (cons "clear" % string
                                        (cons "acls" % string [])))
                                    Tezos_base__TzPervasives.Clic.stop)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      fun cctxt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_shell_services.P2p_services.ACL.clear
                                            cctxt tt)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "The access control rules are now cleared."
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "The access control rules are now cleared."
                                                      % string))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.return_unit
                                                  end)
                                            end)
                                    end)) [])))))))))))))
  end.
src/lib_client_commands/client_p2p_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> Client_commands.command list
src/lib_client_commands/client_p2p_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands : unit -> list Tezos_client_commands.Client_commands.command.
src/lib_client_commands/client_report_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Commands used to introspect the node's state *)

let print_invalid_blocks ppf (b : Shell_services.Chain.invalid_block) =
  Format.fprintf
    ppf
    "@[<v 2>Hash: %a@ Level: %ld@ %a@]"
    Block_hash.pp
    b.hash
    b.level
    pp_print_error
    b.errors

let commands () =
  let open Clic in
  let group =
    {name = "report"; title = "Commands to report the node's status"}
  in
  let output_arg =
    default_arg
      ~doc:"write to a file"
      ~long:"output"
      ~short:'o'
      ~placeholder:"path"
      ~default:"-"
      (parameter (fun _ ->
         function
         | "-" ->
             return Format.std_formatter
         | file ->
             let ppf = Format.formatter_of_out_channel (open_out file) in
             ignore Clic.(setup_formatter ppf Plain Full) ;
             return ppf))
  in
  [ command
      ~group
      ~desc:"The last heads that have been considered by the node."
      (args1 output_arg)
      (fixed ["list"; "heads"])
      (fun ppf cctxt ->
        Shell_services.Blocks.list cctxt ()
        >>=? fun heads ->
        Format.fprintf
          ppf
          "@[<v>%a@]@."
          (Format.pp_print_list Block_hash.pp)
          (List.concat heads) ;
        return_unit);
    command
      ~group
      ~desc:"The blocks that have been marked invalid by the node."
      (args1 output_arg)
      (fixed ["list"; "rejected"; "blocks"])
      (fun ppf cctxt ->
        Shell_services.Invalid_blocks.list cctxt ()
        >>=? function
        | [] ->
            Format.fprintf ppf "No invalid blocks.@." ;
            return_unit
        | _ :: _ as invalid ->
            Format.fprintf
              ppf
              "@[<v>%a@]@."
              (Format.pp_print_list print_invalid_blocks)
              invalid ;
            return_unit) ]
src/lib_client_commands/client_report_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition print_invalid_blocks
  (ppf : Stdlib.Format.formatter)
  (b : Tezos_shell_services.Shell_services.Chain.invalid_block) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 2>" % string
              CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
        (CamlinternalFormatBasics.String_literal "Hash: " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String_literal "Level: " % string
                (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[<v 2>Hash: %a@ Level: %ld@ %a@]" % string)
    Tezos_base__TzPervasives.Block_hash.pp (hash b) (level b)
    Tezos_base__TzPervasives.pp_print_error (errors b).

Definition commands {E F i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)) :=
  match function_parameter with
  | tt =>
    let group :=
      {| name := "report" % string;
        title := "Commands to report the node's status" % string |} in
    let output_arg :=
      Tezos_base__TzPervasives.Clic.default_arg "write to a file" % string
        (Some "o" % char) "output" % string "path" % string "-" % string
        (Tezos_base__TzPervasives.Clic.parameter None
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              fun function_parameter =>
                match function_parameter with
                | "-" % string =>
                  Tezos_base__TzPervasives._return Stdlib.Format.std_formatter
                | file =>
                  let ppf :=
                    Stdlib.Format.formatter_of_out_channel
                      (Stdlib.open_out file) in
                  OCaml.Stdlib.ignore
                    (Tezos_base__TzPervasives.Clic.setup_formatter ppf Plain
                      Full);
                  Tezos_base__TzPervasives._return ppf
                end
            end)) in
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "The last heads that have been considered by the node." % string
        (Tezos_base__TzPervasives.Clic.args1 output_arg)
        (Tezos_base__TzPervasives.Clic.fixed
          (cons "list" % string (cons "heads" % string [])))
        (fun ppf =>
          fun cctxt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_shell_services.Shell_services.Blocks.list cctxt None None
                None None tt)
              (fun heads =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v>" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))
                    "@[<v>%a@]@." % string)
                  (Stdlib.Format.pp_print_list None
                    Tezos_base__TzPervasives.Block_hash.pp)
                  (Tezos_base__TzPervasives.List.concat heads);
                Tezos_base__TzPervasives.return_unit)))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "The blocks that have been marked invalid by the node." % string
          (Tezos_base__TzPervasives.Clic.args1 output_arg)
          (Tezos_base__TzPervasives.Clic.fixed
            (cons "list" % string
              (cons "rejected" % string (cons "blocks" % string []))))
          (fun ppf =>
            fun cctxt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell_services.Shell_services.Invalid_blocks.list cctxt
                  None tt)
                (fun function_parameter =>
                  match function_parameter with
                  | [] =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "No invalid blocks." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))
                        "No invalid blocks.@." % string);
                    Tezos_base__TzPervasives.return_unit
                  | (cons _ _) as invalid =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v>" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                CamlinternalFormatBasics.End_of_format))))
                        "@[<v>%a@]@." % string)
                      (Stdlib.Format.pp_print_list None print_invalid_blocks)
                      invalid;
                    Tezos_base__TzPervasives.return_unit
                  end))) [])
  end.
src/lib_client_commands/client_report_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> #Client_context.full Clic.command list
src/lib_client_commands/client_report_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands : forall {_ a b i o p q variant : Type},
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command
      (((float -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (_ * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (_ * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * _)))))))))))))))))))))
        * _)).
src/lib_crypto/base58.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

let base = 58

let zbase = Z.of_int base

module Alphabet = struct
  type t = {encode : string; decode : string}

  let make alphabet =
    if String.length alphabet <> base then
      invalid_arg "Base58: invalid alphabet (length)" ;
    let str = Bytes.make 256 '\255' in
    for i = 0 to String.length alphabet - 1 do
      let char = int_of_char alphabet.[i] in
      if Bytes.get str char <> '\255' then
        Format.kasprintf
          invalid_arg
          "Base58: invalid alphabet (dup '%c' %d %d)"
          (char_of_int char)
          (int_of_char @@ Bytes.get str char)
          i ;
      Bytes.set str char (char_of_int i)
    done ;
    {encode = alphabet; decode = Bytes.to_string str}

  let bitcoin =
    make "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"

  let ripple =
    make "rpshnaf39wBUDNEGHJKLM4PQRST7VWXYZ2bcdeCg65jkm8oFqi1tuvAxyz"

  let flickr =
    make "123456789abcdefghijkmnopqrstuvwxyzABCDEFGHJKLMNPQRSTUVWXYZ"

  let default = bitcoin

  let all_in_alphabet alphabet string =
    let ok = Array.make 256 false in
    String.iter (fun x -> ok.(Char.code x) <- true) alphabet.encode ;
    let res = ref true in
    for i = 0 to String.length string - 1 do
      res := !res && ok.(Char.code string.[i])
    done ;
    !res

  let pp ppf {encode; _} = Format.fprintf ppf "%s" encode
end

let count_trailing_char s c =
  let len = String.length s in
  let rec loop i =
    if i < 0 then len else if s.[i] <> c then len - i - 1 else loop (i - 1)
  in
  loop (len - 1)

let count_leading_char s c =
  let len = String.length s in
  let rec loop i =
    if i = len then len else if s.[i] <> c then i else loop (i + 1)
  in
  loop 0

let of_char ?(alphabet = Alphabet.default) x =
  let pos = alphabet.decode.[int_of_char x] in
  match pos with '\255' -> None | _ -> Some (int_of_char pos)

let to_char ?(alphabet = Alphabet.default) x = alphabet.encode.[x]

let raw_encode ?(alphabet = Alphabet.default) s =
  let len = String.length s in
  let s = String.init len (fun i -> s.[len - i - 1]) in
  let zero = alphabet.encode.[0] in
  let zeros = count_trailing_char s '\000' in
  let res_len = ((len * 8) + 4) / 5 in
  let res = Bytes.make res_len '\000' in
  let s = Z.of_bits s in
  let rec loop s i =
    if s = Z.zero then i
    else
      let (s, r) = Z.div_rem s zbase in
      Bytes.set res i (to_char ~alphabet (Z.to_int r)) ;
      loop s (i - 1)
  in
  let i = loop s (res_len - 1) in
  let ress = Bytes.sub_string res (i + 1) (res_len - i - 1) in
  String.make zeros zero ^ ress

let raw_decode ?(alphabet = Alphabet.default) s =
  TzString.fold_left
    (fun a c ->
      match (a, of_char ~alphabet c) with
      | (Some a, Some i) ->
          Some Z.(add (of_int i) (mul a zbase))
      | _ ->
          None)
    (Some Z.zero)
    s
  |> Option.map ~f:(fun res ->
         let res = Z.to_bits res in
         let res_tzeros = count_trailing_char res '\000' in
         let len = String.length res - res_tzeros in
         let zeros = count_leading_char s alphabet.encode.[0] in
         String.make zeros '\000'
         ^ String.init len (fun i -> res.[len - i - 1]))

let checksum s =
  let hash = Hacl.Hash.SHA256.(digest (digest (Bigstring.of_string s))) in
  let res = Bytes.make 4 '\000' in
  Bigstring.blit_to_bytes hash 0 res 0 4 ;
  Bytes.to_string res

(* Append a 4-bytes cryptographic checksum before encoding string s *)
let safe_encode ?alphabet s = raw_encode ?alphabet (s ^ checksum s)

let safe_decode ?alphabet s =
  raw_decode ?alphabet s
  |> Option.apply ~f:(fun s ->
         let len = String.length s in
         if len < 4 then None
         else
           (* only if the string is long enough to extract a checksum do we check it *)
           let msg = String.sub s 0 (len - 4) in
           let msg_hash = String.sub s (len - 4) 4 in
           if msg_hash <> checksum msg then None else Some msg)

type data = ..

type 'a encoding = {
  prefix : string;
  length : int;
  encoded_prefix : string;
  encoded_length : int;
  to_raw : 'a -> string;
  of_raw : string -> 'a option;
  wrap : 'a -> data;
}

let prefix {prefix; _} = prefix

let simple_decode ?alphabet {prefix; of_raw; _} s =
  safe_decode ?alphabet s
  |> Option.apply ~f:(TzString.remove_prefix ~prefix)
  |> Option.apply ~f:of_raw

let simple_encode ?alphabet {prefix; to_raw; _} d =
  safe_encode ?alphabet (prefix ^ to_raw d)

type registered_encoding = Encoding : 'a encoding -> registered_encoding

module MakeEncodings (E : sig
  val encodings : registered_encoding list
end) =
struct
  let encodings = ref E.encodings

  let check_ambiguous_prefix prefix length encodings =
    List.iter
      (fun (Encoding {encoded_prefix = s; length = l; _}) ->
        if
          length = l
          && ( TzString.remove_prefix ~prefix:s prefix <> None
             || TzString.remove_prefix ~prefix s <> None )
        then
          Format.ksprintf
            invalid_arg
            "Base58.register_encoding: duplicate prefix: %S, %S."
            s
            prefix)
      encodings

  let make_encoded_prefix prefix len =
    let zeros = safe_encode (prefix ^ String.make len '\000')
    and ones = safe_encode (prefix ^ String.make len '\255') in
    let len = String.length zeros in
    if String.length ones <> len then
      Format.ksprintf
        invalid_arg
        "Base58.registered_encoding: variable length encoding." ;
    let rec loop i =
      if i = len then len else if zeros.[i] = ones.[i] then loop (i + 1) else i
    in
    let len = loop 0 in
    if len = 0 then
      invalid_arg "Base58.register_encoding: not a unique prefix." ;
    (String.sub zeros 0 len, String.length zeros)

  let register_encoding ~prefix ~length ~to_raw ~of_raw ~wrap =
    let to_raw x =
      let s = to_raw x in
      assert (String.length s = length) ;
      s
    in
    let of_raw s =
      assert (String.length s = length) ;
      of_raw s
    in
    let (encoded_prefix, encoded_length) = make_encoded_prefix prefix length in
    check_ambiguous_prefix encoded_prefix encoded_length !encodings ;
    let encoding =
      {prefix; length; encoded_prefix; encoded_length; to_raw; of_raw; wrap}
    in
    encodings := Encoding encoding :: !encodings ;
    encoding

  let check_encoded_prefix enc p l =
    if enc.encoded_prefix <> p then
      Format.kasprintf
        Pervasives.failwith
        "Unexpected prefix %s (expected %s)"
        p
        enc.encoded_prefix ;
    if enc.encoded_length <> l then
      Format.kasprintf
        Pervasives.failwith
        "Unexpected encoded length %d for %s (expected %d)"
        l
        p
        enc.encoded_length

  let decode ?alphabet s =
    let rec find s = function
      | [] ->
          None
      | Encoding {prefix; of_raw; wrap; _} :: encodings -> (
        match TzString.remove_prefix ~prefix s with
        | None ->
            find s encodings
        | Some msg ->
            of_raw msg |> Option.map ~f:wrap )
    in
    safe_decode ?alphabet s |> Option.apply ~f:(fun s -> find s !encodings)
end

type 'a resolver =
  | Resolver : {
      encoding : 'h encoding;
      resolver : 'a -> string -> 'h list Lwt.t;
    }
      -> 'a resolver

module MakeResolvers (R : sig
  type context
end) =
struct
  let resolvers = ref []

  let register_resolver (type a) (encoding : a encoding)
      (resolver : R.context -> string -> a list Lwt.t) =
    resolvers := Resolver {encoding; resolver} :: !resolvers

  let partial_decode ?(alphabet = Alphabet.default) request len =
    let zero = alphabet.encode.[0] in
    let last = alphabet.encode.[base - 1] in
    let n = String.length request in
    let min = raw_decode ~alphabet (request ^ String.make (len - n) zero) in
    let max = raw_decode ~alphabet (request ^ String.make (len - n) last) in
    match (min, max) with
    | (Some min, Some max) ->
        let prefix_len = TzString.common_prefix min max in
        Some (String.sub min 0 prefix_len)
    | _ ->
        None

  let complete ?alphabet context request =
    let rec find s = function
      | [] ->
          Lwt.return_nil
      | Resolver {encoding; resolver} :: resolvers -> (
          if not (TzString.has_prefix ~prefix:encoding.encoded_prefix s) then
            find s resolvers
          else
            match partial_decode ?alphabet request encoding.encoded_length with
            | None ->
                find s resolvers
            | Some prefix ->
                let len = String.length prefix in
                let ignored = String.length encoding.prefix in
                let msg =
                  if len <= ignored then ""
                  else (
                    assert (String.sub prefix 0 ignored = encoding.prefix) ;
                    String.sub prefix ignored (len - ignored) )
                in
                resolver context msg
                >|= fun msgs ->
                TzList.filter_map
                  (fun msg ->
                    let res = simple_encode encoding ?alphabet msg in
                    TzString.remove_prefix ~prefix:request res
                    |> Option.map ~f:(fun _ -> res))
                  msgs )
    in
    find request !resolvers
end

include MakeEncodings (struct
  let encodings = []
end)

include MakeResolvers (struct
  type context = unit
end)

let register_resolver enc f = register_resolver enc (fun () s -> f s)

let complete ?alphabet s = complete ?alphabet () s

module Make (C : sig
  type context
end) =
struct
  include MakeEncodings (struct
    let encodings = !encodings
  end)

  include MakeResolvers (struct
    type context = C.context
  end)
end

module Prefix = struct
  (* 32 *)
  let block_hash = "\001\052" (* B(51) *)

  let operation_hash = "\005\116" (* o(51) *)

  let operation_list_hash = "\133\233" (* Lo(52) *)

  let operation_list_list_hash = "\029\159\109" (* LLo(53) *)

  let protocol_hash = "\002\170" (* P(51) *)

  let context_hash = "\079\199" (* Co(52) *)

  (* 20 *)
  let ed25519_public_key_hash = "\006\161\159" (* tz1(36) *)

  let secp256k1_public_key_hash = "\006\161\161" (* tz2(36) *)

  let p256_public_key_hash = "\006\161\164" (* tz3(36) *)

  (* 16 *)
  let cryptobox_public_key_hash = "\153\103" (* id(30) *)

  (* 32 *)
  let ed25519_seed = "\013\015\058\007" (* edsk(54) *)

  let ed25519_public_key = "\013\015\037\217" (* edpk(54) *)

  let secp256k1_secret_key = "\017\162\224\201" (* spsk(54) *)

  let p256_secret_key = "\016\081\238\189" (* p2sk(54) *)

  (* 56 *)
  let ed25519_encrypted_seed = "\007\090\060\179\041" (* edesk(88) *)

  let secp256k1_encrypted_secret_key = "\009\237\241\174\150" (* spesk(88) *)

  let p256_encrypted_secret_key = "\009\048\057\115\171" (* p2esk(88) *)

  (* 33 *)
  let secp256k1_public_key = "\003\254\226\086" (* sppk(55) *)

  let p256_public_key = "\003\178\139\127" (* p2pk(55) *)

  let secp256k1_scalar = "\038\248\136" (* SSp(53) *)

  let secp256k1_element = "\005\092\000" (* GSp(54) *)

  (* 64 *)
  let ed25519_secret_key = "\043\246\078\007" (* edsk(98) *)

  let ed25519_signature = "\009\245\205\134\018" (* edsig(99) *)

  let secp256k1_signature = "\013\115\101\019\063" (* spsig1(99) *)

  let p256_signature = "\054\240\044\052" (* p2sig(98) *)

  let generic_signature = "\004\130\043" (* sig(96) *)

  (* 4 *)
  let chain_id = "\087\082\000"

  (* Net(15) *)
end
src/lib_crypto/base58.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Definition base : Z := 58.

Definition zbase : Z.t := Z.of_int base.

Module Alphabet.
  Record t := {
    encode : string;
    decode : string }.
  
  Definition make (alphabet : string) : t :=
    if nequiv_decb (OCaml.String.length alphabet) base then
      OCaml.Stdlib.invalid_arg "Base58: invalid alphabet (length)" % string
    else
      tt;
    let str := Stdlib.Bytes.make 256 "ÿ" % char in
    for;
    {| encode := alphabet; decode := Stdlib.Bytes.to_string str |}.
  
  Definition bitcoin : t :=
    make "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" % string.
  
  Definition ripple : t :=
    make "rpshnaf39wBUDNEGHJKLM4PQRST7VWXYZ2bcdeCg65jkm8oFqi1tuvAxyz" % string.
  
  Definition flickr : t :=
    make "123456789abcdefghijkmnopqrstuvwxyzABCDEFGHJKLMNPQRSTUVWXYZ" % string.
  
  Definition default : t := bitcoin.
  
  Definition all_in_alphabet (alphabet : t) (string : string) : bool :=
    let ok := Stdlib.Array.make 256 false in
    Stdlib.String.iter (fun x => Stdlib.Array.set ok (Stdlib.Char.code x) true)
      (encode alphabet);
    let res := Stdlib.ref true in
    for;
    Stdlib.op_exclamation res.
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | {| encode := encode |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) encode
    end.
End Alphabet.

Definition count_trailing_char (s : string) (c : ascii) : Z :=
  let len := OCaml.String.length s in
  let fix loop (i : Z) : Z :=
    if OCaml.Stdlib.lt i 0 then
      len
    else
      if nequiv_decb (Stdlib.String.get s i) c then
        Z.sub (Z.sub len i) 1
      else
        loop (Z.sub i 1) in
  loop (Z.sub len 1).

Definition count_leading_char (s : string) (c : ascii) : Z :=
  let len := OCaml.String.length s in
  let fix loop (i : Z) : Z :=
    if equiv_decb i len then
      len
    else
      if nequiv_decb (Stdlib.String.get s i) c then
        i
      else
        loop (Z.add i 1) in
  loop 0.

Definition of_char (op_star_o_p_t_star : option Alphabet.t)
  : ascii -> option Z :=
  let alphabet :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Alphabet.default
    end in
  fun x =>
    let pos := Stdlib.String.get (decode alphabet) (OCaml.Stdlib.int_of_char x)
      in
    match pos with
    | "ÿ" % char => None
    | _ => Some (OCaml.Stdlib.int_of_char pos)
    end.

Definition to_char (op_star_o_p_t_star : option Alphabet.t) : Z -> ascii :=
  let alphabet :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Alphabet.default
    end in
  fun x => Stdlib.String.get (encode alphabet) x.

Definition raw_encode (op_star_o_p_t_star : option Alphabet.t)
  : string -> string :=
  let alphabet :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Alphabet.default
    end in
  fun s =>
    let len := OCaml.String.length s in
    let s :=
      Stdlib.String.init len
        (fun i => Stdlib.String.get s (Z.sub (Z.sub len i) 1)) in
    let zero := Stdlib.String.get (encode alphabet) 0 in
    let zeros := count_trailing_char s "000" % char in
    let res_len := Z.div (Z.add (Z.mul len 8) 4) 5 in
    let res := Stdlib.Bytes.make res_len "000" % char in
    let s := Z.of_bits s in
    let fix loop (s : Z.t) (i : Z) : Z :=
      if equiv_decb s Z.zero then
        i
      else
        match Z.div_rem s zbase with
        | (s, r) =>
          Stdlib.Bytes.set res i (to_char (Some alphabet) (Z.to_int r));
          loop s (Z.sub i 1)
        end in
    let i := loop s (Z.sub res_len 1) in
    let ress :=
      Stdlib.Bytes.sub_string res (Z.add i 1) (Z.sub (Z.sub res_len i) 1) in
    String.append (Stdlib.String.make zeros zero) ress.

Definition raw_decode (op_star_o_p_t_star : option Alphabet.t)
  : string -> option string :=
  let alphabet :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Alphabet.default
    end in
  fun s =>
    OCaml.Stdlib.reverse_apply
      (Tezos_stdlib.TzString.fold_left
        (fun a =>
          fun c =>
            match (a, (of_char (Some alphabet) c)) with
            | (Some a, Some i) => Some (Z.add (Z.of_int i) (Z.mul a zbase))
            | _ => None
            end) (Some Z.zero) s)
      (Tezos_stdlib.Option.map
        (fun res =>
          let res := Z.to_bits res in
          let res_tzeros := count_trailing_char res "000" % char in
          let len := Z.sub (OCaml.String.length res) res_tzeros in
          let zeros :=
            count_leading_char s (Stdlib.String.get (encode alphabet) 0) in
          String.append (Stdlib.String.make zeros "000" % char)
            (Stdlib.String.init len
              (fun i => Stdlib.String.get res (Z.sub (Z.sub len i) 1))))).

Definition checksum (s : string) : string :=
  let hash :=
    Hacl.Hash.SHA256.(Hacl.S.Hash.digest)
      (Hacl.Hash.SHA256.(Hacl.S.Hash.digest) (Bigstring.of_string s)) in
  let res := Stdlib.Bytes.make 4 "000" % char in
  Bigstring.blit_to_bytes hash 0 res 0 4;
  Stdlib.Bytes.to_string res.

Definition safe_encode (alphabet : option Alphabet.t) (s : string) : string :=
  raw_encode alphabet (String.append s (checksum s)).

Definition safe_decode (alphabet : option Alphabet.t) (s : string)
  : option string :=
  OCaml.Stdlib.reverse_apply (raw_decode alphabet s)
    (Tezos_stdlib.Option.apply
      (fun s =>
        let len := OCaml.String.length s in
        if OCaml.Stdlib.lt len 4 then
          None
        else
          let msg := Stdlib.String.sub s 0 (Z.sub len 4) in
          let msg_hash := Stdlib.String.sub s (Z.sub len 4) 4 in
          if nequiv_decb msg_hash (checksum msg) then
            None
          else
            Some msg)).

Definition data := False.

Record encoding {a : Type} := {
  prefix : string;
  length : Z;
  encoded_prefix : string;
  encoded_length : Z;
  to_raw : a -> string;
  of_raw : string -> option a;
  wrap : a -> data }.
Arguments encoding : clear implicits.

Definition prefix {A : Type} (function_parameter : encoding A) : string :=
  match function_parameter with
  | {| prefix := prefix |} => prefix
  end.

Definition simple_decode {A : Type}
  (alphabet : option Alphabet.t) (function_parameter : encoding A)
  : string -> option A :=
  match function_parameter with
  | {| prefix := prefix; of_raw := of_raw |} =>
    fun s =>
      OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply (safe_decode alphabet s)
          (Tezos_stdlib.Option.apply
            (Tezos_stdlib.TzString.remove_prefix prefix)))
        (Tezos_stdlib.Option.apply of_raw)
  end.

Definition simple_encode {A : Type}
  (alphabet : option Alphabet.t) (function_parameter : encoding A)
  : A -> string :=
  match function_parameter with
  | {| prefix := prefix; to_raw := to_raw |} =>
    fun d => safe_encode alphabet (String.append prefix (to_raw d))
  end.

Inductive registered_encoding : Type :=
| Encoding : forall {a : Type}, (encoding a) -> registered_encoding.

Inductive resolver (a : Type) : Type :=
| Resolver : forall {h : Type}, (encoding h) -> (a -> string -> Lwt.t (list h))
  -> resolver a.

Arguments Resolver {_}.

Definition register_resolver {A : Type}
  (enc : encoding A) (f : string -> Lwt.t (list A)) : unit :=
  register_resolver enc
    (fun function_parameter =>
      match function_parameter with
      | tt => fun s => f s
      end).

Definition complete (alphabet : option Alphabet.t) (s : string)
  : Lwt.t (list string) := complete alphabet tt s.

Module Prefix.
  Definition block_hash : string := "4" % string.
  
  Definition operation_hash : string := "t" % string.
  
  Definition operation_list_hash : string := "…é" % string.
  
  Definition operation_list_list_hash : string := "Ÿm" % string.
  
  Definition protocol_hash : string := "ª" % string.
  
  Definition context_hash : string := "OÇ" % string.
  
  Definition ed25519_public_key_hash : string := "¡Ÿ" % string.
  
  Definition secp256k1_public_key_hash : string := "¡¡" % string.
  
  Definition p256_public_key_hash : string := "¡¤" % string.
  
  Definition cryptobox_public_key_hash : string := "™g" % string.
  
  Definition ed25519_seed : string := "
:" % string.
  
  Definition ed25519_public_key : string := "
%Ù" % string.
  
  Definition secp256k1_secret_key : string := "¢àÉ" % string.
  
  Definition p256_secret_key : string := "Qî½" % string.
  
  Definition ed25519_encrypted_seed : string := "Z<³)" % string.
  
  Definition secp256k1_encrypted_secret_key : string := "	íñ®–" % string.
  
  Definition p256_encrypted_secret_key : string := "	09s«" % string.
  
  Definition secp256k1_public_key : string := "þâV" % string.
  
  Definition p256_public_key : string := "²‹" % string.
  
  Definition secp256k1_scalar : string := "&øˆ" % string.
  
  Definition secp256k1_element : string := "\" % string.
  
  Definition ed25519_secret_key : string := "+öN" % string.
  
  Definition ed25519_signature : string := "	õ͆" % string.
  
  Definition secp256k1_signature : string := "
se?" % string.
  
  Definition p256_signature : string := "6ð,4" % string.
  
  Definition generic_signature : string := "‚+" % string.
  
  Definition chain_id : string := "WR" % string.
End Prefix.
src/lib_crypto/base58.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {1 Prefixed Base58Check encodings} *)

module Prefix : sig
  val block_hash : string

  val operation_hash : string

  val operation_list_hash : string

  val operation_list_list_hash : string

  val protocol_hash : string

  val context_hash : string

  val ed25519_public_key_hash : string

  val secp256k1_public_key_hash : string

  val p256_public_key_hash : string

  val cryptobox_public_key_hash : string

  val ed25519_seed : string

  val ed25519_public_key : string

  val ed25519_secret_key : string

  val ed25519_signature : string

  val secp256k1_public_key : string

  val secp256k1_secret_key : string

  val secp256k1_signature : string

  val p256_public_key : string

  val p256_secret_key : string

  val p256_signature : string

  val ed25519_encrypted_seed : string

  val secp256k1_encrypted_secret_key : string

  val p256_encrypted_secret_key : string

  val generic_signature : string

  val chain_id : string

  val secp256k1_element : string

  val secp256k1_scalar : string
end

(** An extensible sum-type for decoded data: one case per known
    "prefix". See for instance [Hash.Block_hash.Hash] or
    [Environment.Ed25519.Public_key_hash]. *)
type data = ..

(** Abstract representation of registered encodings. The type paramater
    is the type of the encoded data, for instance [Hash.Block_hash.t]. *)
type 'a encoding = private {
  prefix : string;
  length : int;
  encoded_prefix : string;
  encoded_length : int;
  to_raw : 'a -> string;
  of_raw : string -> 'a option;
  wrap : 'a -> data;
}

(** Register a new encoding. The function might raise `Invalid_arg` if
    the provided [prefix] overlap with a previously registered
    prefix. The [to_raw] and [of_raw] are the ad-hoc
    serialisation/deserialisation for the data. The [wrap] should wrap
    the deserialised value into the extensible sum-type [data] (see
    the generic function [decode]). *)
val register_encoding :
  prefix:string ->
  length:int ->
  to_raw:('a -> string) ->
  of_raw:(string -> 'a option) ->
  wrap:('a -> data) ->
  'a encoding

(** Checks that an encoding has a certain prefix and length. *)
val check_encoded_prefix : 'a encoding -> string -> int -> unit

module Alphabet : sig
  type t

  val bitcoin : t

  val ripple : t

  val flickr : t

  val make : string -> t

  val all_in_alphabet : t -> string -> bool

  val pp : Format.formatter -> t -> unit
end

(** Encoder for a given kind of data. *)
val simple_encode : ?alphabet:Alphabet.t -> 'a encoding -> 'a -> string

(** Decoder for a given kind of data. It returns [None] when
    the decoded data does not start with the expected prefix. *)
val simple_decode : ?alphabet:Alphabet.t -> 'a encoding -> string -> 'a option

(** Generic decoder. It returns [None] when the decoded data does
    not start with a registered prefix. *)
val decode : ?alphabet:Alphabet.t -> string -> data option

(** {2 Completion of partial Base58Check value} *)

(** Register a (global) resolver for a previsously
    registered kind af data. *)
val register_resolver : 'a encoding -> (string -> 'a list Lwt.t) -> unit

(** Try to complete a prefix of a Base58Check encoded data, by using
    the previously registered resolver associated to this kind of
    data. Note that a prefix of [n] characters of a Base58-encoded
    value provides at least [n/2] bytes of a prefix of the original value. *)
val complete : ?alphabet:Alphabet.t -> string -> string list Lwt.t

(** {1 Low-level: distinct registering function for economic protocol} *)

(** See [src/environment/v1/base58.mli] for an inlined
    documentation. *)
module Make (C : sig
  type context
end) : sig
  val register_encoding :
    prefix:string ->
    length:int ->
    to_raw:('a -> string) ->
    of_raw:(string -> 'a option) ->
    wrap:('a -> data) ->
    'a encoding

  val decode : ?alphabet:Alphabet.t -> string -> data option

  val register_resolver :
    'a encoding -> (C.context -> string -> 'a list Lwt.t) -> unit

  val complete :
    ?alphabet:Alphabet.t -> C.context -> string -> string list Lwt.t
end

(** {2 Low-level Base58Check encodings} *)

(** Base58Check-encoding/decoding functions (with error detections). *)
val safe_encode : ?alphabet:Alphabet.t -> string -> string

val safe_decode : ?alphabet:Alphabet.t -> string -> string option

(** Base58-encoding/decoding functions (without error detections). *)
val raw_encode : ?alphabet:Alphabet.t -> string -> string

val raw_decode : ?alphabet:Alphabet.t -> string -> string option

(**/**)

val partial_decode : ?alphabet:Alphabet.t -> string -> int -> string option

val make_encoded_prefix : string -> int -> string * int

val prefix : 'a encoding -> string
src/lib_crypto/base58.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Prefix.
  Parameter block_hash : string.
  
  Parameter operation_hash : string.
  
  Parameter operation_list_hash : string.
  
  Parameter operation_list_list_hash : string.
  
  Parameter protocol_hash : string.
  
  Parameter context_hash : string.
  
  Parameter ed25519_public_key_hash : string.
  
  Parameter secp256k1_public_key_hash : string.
  
  Parameter p256_public_key_hash : string.
  
  Parameter cryptobox_public_key_hash : string.
  
  Parameter ed25519_seed : string.
  
  Parameter ed25519_public_key : string.
  
  Parameter ed25519_secret_key : string.
  
  Parameter ed25519_signature : string.
  
  Parameter secp256k1_public_key : string.
  
  Parameter secp256k1_secret_key : string.
  
  Parameter secp256k1_signature : string.
  
  Parameter p256_public_key : string.
  
  Parameter p256_secret_key : string.
  
  Parameter p256_signature : string.
  
  Parameter ed25519_encrypted_seed : string.
  
  Parameter secp256k1_encrypted_secret_key : string.
  
  Parameter p256_encrypted_secret_key : string.
  
  Parameter generic_signature : string.
  
  Parameter chain_id : string.
  
  Parameter secp256k1_element : string.
  
  Parameter secp256k1_scalar : string.
End Prefix.

Definition data := False.

Record encoding {a : Type} := {
  prefix : string;
  length : Z;
  encoded_prefix : string;
  encoded_length : Z;
  to_raw : a -> string;
  of_raw : string -> option a;
  wrap : a -> data }.
Arguments encoding : clear implicits.

Parameter register_encoding : forall {a : Type},
string ->
  Z -> (a -> string) -> (string -> option a) -> (a -> data) -> encoding a.

Parameter check_encoded_prefix : forall {a : Type},
(encoding a) -> string -> Z -> unit.

Module Alphabet.
  Parameter t : Type.
  
  Parameter bitcoin : t.
  
  Parameter ripple : t.
  
  Parameter flickr : t.
  
  Parameter make : string -> t.
  
  Parameter all_in_alphabet : t -> string -> bool.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
End Alphabet.

Parameter simple_encode : forall {a : Type},
(option Alphabet.t) -> (encoding a) -> a -> string.

Parameter simple_decode : forall {a : Type},
(option Alphabet.t) -> (encoding a) -> string -> option a.

Parameter decode : (option Alphabet.t) -> string -> option data.

Parameter register_resolver : forall {a : Type},
(encoding a) -> (string -> Lwt.t (list a)) -> unit.

Parameter complete : (option Alphabet.t) -> string -> Lwt.t (list string).

unhandled_module

Parameter safe_encode : (option Alphabet.t) -> string -> string.

Parameter safe_decode : (option Alphabet.t) -> string -> option string.

Parameter raw_encode : (option Alphabet.t) -> string -> string.

Parameter raw_decode : (option Alphabet.t) -> string -> option string.

Parameter partial_decode : (option Alphabet.t) -> string -> Z -> option string.

Parameter make_encoded_prefix : string -> Z -> string * Z.

Parameter prefix : forall {a : Type}, (encoding a) -> string.
src/lib_crypto/blake2B.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

(*-- Type specific Hash builder ---------------------------------------------*)

module type Name = sig
  val name : string

  val title : string

  val size : int option
end

module type PrefixedName = sig
  include Name

  val b58check_prefix : string
end

module Make_minimal (K : Name) = struct
  open Blake2

  type t = Blake2b.hash

  include K

  let size = match K.size with None -> 32 | Some x -> x

  let of_string_opt s =
    if String.length s <> size then None
    else Some (Blake2b.Hash (Bytes.of_string s))

  let of_string s =
    match of_string_opt s with
    | None ->
        generic_error
          "%s.of_string: wrong string size (%d)"
          K.name
          (String.length s)
    | Some h ->
        Ok h

  let of_string_exn s =
    match of_string_opt s with
    | None ->
        Format.kasprintf
          invalid_arg
          "%s.of_string: wrong string size (%d)"
          K.name
          (String.length s)
    | Some h ->
        h

  let to_string (Blake2b.Hash h) = Bytes.to_string h

  let of_hex s = of_string (Hex.to_string s)

  let of_hex_opt s = of_string_opt (Hex.to_string s)

  let of_hex_exn s = of_string_exn (Hex.to_string s)

  let to_hex s = Hex.of_string (to_string s)

  let pp ppf h =
    let (`Hex h) = to_hex h in
    Format.pp_print_string ppf h

  let pp_short ppf h =
    let (`Hex h) = to_hex h in
    Format.pp_print_string ppf (String.sub h 0 8)

  let of_bytes_opt b =
    if Bytes.length b <> size then None else Some (Blake2b.Hash b)

  let of_bytes_exn b =
    match of_bytes_opt b with
    | None ->
        let msg =
          Printf.sprintf
            "%s.of_bytes: wrong string size (%d)"
            K.name
            (Bytes.length b)
        in
        raise (Invalid_argument msg)
    | Some h ->
        h

  let of_bytes s =
    match of_bytes_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error "Failed to deserialize a hash (%s)" K.name

  let to_bytes (Blake2b.Hash h) = h

  let hash_bytes ?key l =
    let state = Blake2b.init ?key size in
    List.iter (fun b -> Blake2b.update state b) l ;
    Blake2b.final state

  let hash_string ?key l =
    let key = Option.map ~f:Bytes.of_string key in
    let state = Blake2b.init ?key size in
    List.iter (fun s -> Blake2b.update state (Bytes.of_string s)) l ;
    Blake2b.final state

  let path_length = 6

  (** Converts [key] to hex thus doubling its size then splits it into a list of
      length [path_length] where each element is one byte, or two characters,
      except the last one which contains the rest. *)
  let to_path key l =
    let (`Hex key) = to_hex key in
    String.sub key 0 2 :: String.sub key 2 2 :: String.sub key 4 2
    :: String.sub key 6 2 :: String.sub key 8 2
    :: String.sub key 10 ((size * 2) - 10)
    :: l

  let of_path path =
    let path = String.concat "" path in
    of_hex_opt (`Hex path)

  let of_path_exn path =
    let path = String.concat "" path in
    of_hex_exn (`Hex path)

  let prefix_path p =
    let (`Hex p) = Hex.of_string p in
    let len = String.length p in
    let p1 = if len >= 2 then String.sub p 0 2 else ""
    and p2 = if len >= 4 then String.sub p 2 2 else ""
    and p3 = if len >= 6 then String.sub p 4 2 else ""
    and p4 = if len >= 8 then String.sub p 6 2 else ""
    and p5 = if len >= 10 then String.sub p 8 2 else ""
    and p6 =
      if len > 10 then String.sub p 10 (min (len - 10) ((size * 2) - 10))
      else ""
    in
    [p1; p2; p3; p4; p5; p6]

  let zero = of_hex_exn (`Hex (String.make (size * 2) '0'))

  include Compare.Make (struct
    type nonrec t = t

    let compare (Blake2b.Hash h1) (Blake2b.Hash h2) = Bytes.compare h1 h2
  end)
end

module Make (R : sig
  val register_encoding :
    prefix:string ->
    length:int ->
    to_raw:('a -> string) ->
    of_raw:(string -> 'a option) ->
    wrap:('a -> Base58.data) ->
    'a Base58.encoding
end)
(K : PrefixedName) =
struct
  include Make_minimal (K)

  (* Serializers *)

  let raw_encoding =
    let open Data_encoding in
    conv to_bytes of_bytes_exn (Fixed.bytes size)

  let hash =
    if Compare.Int.(size >= 8) then fun h ->
      Int64.to_int (TzEndian.get_int64 (to_bytes h) 0)
    else if Compare.Int.(size >= 4) then fun h ->
      Int32.to_int (TzEndian.get_int32 (to_bytes h) 0)
    else fun h ->
      let r = ref 0 in
      let h = to_bytes h in
      for i = 0 to size - 1 do
        r := TzEndian.get_uint8 h i + (8 * !r)
      done ;
      !r

  type Base58.data += Data of t

  let b58check_encoding =
    R.register_encoding
      ~prefix:K.b58check_prefix
      ~length:size
      ~wrap:(fun s -> Data s)
      ~of_raw:of_string_opt
      ~to_raw:to_string

  include Helpers.Make (struct
    type nonrec t = t

    let title = title

    let name = name

    let b58check_encoding = b58check_encoding

    let raw_encoding = raw_encoding

    let compare = compare

    let equal = equal

    let hash = hash
  end)
end

module Generic_Merkle_tree (H : sig
  type t

  type elt

  val empty : t

  val leaf : elt -> t

  val node : t -> t -> t
end) =
struct
  let rec step a n =
    let m = (n + 1) / 2 in
    for i = 0 to m - 1 do
      a.(i) <- H.node a.(2 * i) a.((2 * i) + 1)
    done ;
    a.(m) <- H.node a.(n) a.(n) ;
    if m = 1 then a.(0)
    else if m mod 2 = 0 then step a m
    else (
      a.(m + 1) <- a.(m) ;
      step a (m + 1) )

  let empty = H.empty

  let compute xs =
    match xs with
    | [] ->
        H.empty
    | [x] ->
        H.leaf x
    | _ :: _ :: _ ->
        let last = TzList.last_exn xs in
        let n = List.length xs in
        let a = Array.make (n + 1) (H.leaf last) in
        List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
        step a n

  type path = Left of path * H.t | Right of H.t * path | Op

  let rec step_path a n p j =
    let m = (n + 1) / 2 in
    let p =
      if j mod 2 = 0 then Left (p, a.(j + 1)) else Right (a.(j - 1), p)
    in
    for i = 0 to m - 1 do
      a.(i) <- H.node a.(2 * i) a.((2 * i) + 1)
    done ;
    a.(m) <- H.node a.(n) a.(n) ;
    if m = 1 then p
    else if m mod 2 = 0 then step_path a m p (j / 2)
    else (
      a.(m + 1) <- a.(m) ;
      step_path a (m + 1) p (j / 2) )

  let compute_path xs i =
    match xs with
    | [] ->
        invalid_arg "compute_path"
    | [_] ->
        Op
    | _ :: _ :: _ ->
        let last = TzList.last_exn xs in
        let n = List.length xs in
        if i < 0 || n <= i then invalid_arg "compute_path" ;
        let a = Array.make (n + 1) (H.leaf last) in
        List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
        step_path a n Op i

  let rec check_path p h =
    match p with
    | Op ->
        (H.leaf h, 1, 0)
    | Left (p, r) ->
        let (l, s, pos) = check_path p h in
        (H.node l r, s * 2, pos)
    | Right (l, p) ->
        let (r, s, pos) = check_path p h in
        (H.node l r, s * 2, pos + s)

  let check_path p h =
    let (h, _, pos) = check_path p h in
    (h, pos)
end

let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2)

module Make_merkle_tree (R : sig
  val register_encoding :
    prefix:string ->
    length:int ->
    to_raw:('a -> string) ->
    of_raw:(string -> 'a option) ->
    wrap:('a -> Base58.data) ->
    'a Base58.encoding
end)
(K : PrefixedName) (Contents : sig
  type t

  val to_bytes : t -> Bytes.t
end) =
struct
  include Make (R) (K)

  type elt = Contents.t

  let elt_bytes = Contents.to_bytes

  let empty = hash_bytes []

  include Generic_Merkle_tree (struct
    type nonrec t = t

    type nonrec elt = elt

    let empty = empty

    let leaf x = hash_bytes [Contents.to_bytes x]

    let node x y = hash_bytes [to_bytes x; to_bytes y]
  end)

  let path_encoding =
    let open Data_encoding in
    mu "path" (fun path_encoding ->
        union
          [ case
              (Tag 240)
              ~title:"Left"
              (obj2 (req "path" path_encoding) (req "right" encoding))
              (function Left (p, r) -> Some (p, r) | _ -> None)
              (fun (p, r) -> Left (p, r));
            case
              (Tag 15)
              ~title:"Right"
              (obj2 (req "left" encoding) (req "path" path_encoding))
              (function Right (r, p) -> Some (r, p) | _ -> None)
              (fun (r, p) -> Right (r, p));
            case
              (Tag 0)
              ~title:"Op"
              unit
              (function Op -> Some () | _ -> None)
              (fun () -> Op) ])

  let bounded_path_encoding ?max_length () =
    match max_length with
    | None ->
        path_encoding
    | Some max_length ->
        let max_depth = log2 max_length in
        Data_encoding.check_size ((max_depth * (size + 1)) + 1) path_encoding
end

include Make_minimal (struct
  let name = "Generic_hash"

  let title = ""

  let size = None
end)

let pp ppf h =
  let (`Hex h) = to_hex h in
  Format.pp_print_string ppf h

let pp_short ppf h =
  let (`Hex h) = to_hex h in
  Format.pp_print_string ppf (String.sub h 0 8)
src/lib_crypto/blake2B.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Module Name.
  Record signature := {
    name : string;
    title : string;
    size : option Z;
  }.
End Name.

Module PrefixedName.
  Record signature := {
    include;
    b58check_prefix : string;
  }.
End PrefixedName.

Fixpoint log2 (x : Z) : Z :=
  if OCaml.Stdlib.le x 1 then
    0
  else
    Z.add 1 (log2 (Z.div (Z.add x 1) 2)).

Definition pp (ppf : Stdlib.Format.formatter) (h : Blake2.Blake2b.hash)
  : unit :=
  match to_hex h with
  | Hex h => Stdlib.Format.pp_print_string ppf h
  end.

Definition pp_short (ppf : Stdlib.Format.formatter) (h : Blake2.Blake2b.hash)
  : unit :=
  match to_hex h with
  | Hex h => Stdlib.Format.pp_print_string ppf (Stdlib.String.sub h 0 8)
  end.
src/lib_crypto/blake2B.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - Manipulation and creation of hashes *)

(** {2 Predefined Hashes } *)

include S.MINIMAL_HASH

include S.RAW_DATA with type t := t

(** {2 Building Hashes} *)

(** The parameters for creating a new Hash type using
    {!Make_Blake2B}. Both {!name} and {!title} are only informative,
    used in error messages and serializers. *)

module type Name = sig
  val name : string

  val title : string

  val size : int option
end

module type PrefixedName = sig
  include Name

  val b58check_prefix : string
end

(** Builds a new Hash type using Blake2B. *)
module Make_minimal (Name : Name) : S.MINIMAL_HASH

module Make (Register : sig
  val register_encoding :
    prefix:string ->
    length:int ->
    to_raw:('a -> string) ->
    of_raw:(string -> 'a option) ->
    wrap:('a -> Base58.data) ->
    'a Base58.encoding
end)
(Name : PrefixedName) : S.HASH

(**/**)

module Make_merkle_tree (R : sig
  val register_encoding :
    prefix:string ->
    length:int ->
    to_raw:('a -> string) ->
    of_raw:(string -> 'a option) ->
    wrap:('a -> Base58.data) ->
    'a Base58.encoding
end)
(K : PrefixedName) (Contents : sig
  type t

  val to_bytes : t -> Bytes.t
end) : S.MERKLE_TREE with type elt = Contents.t

module Generic_Merkle_tree (H : sig
  type t

  type elt

  val empty : t

  val leaf : elt -> t

  val node : t -> t -> t
end) : sig
  val compute : H.elt list -> H.t

  type path = Left of path * H.t | Right of H.t * path | Op

  val compute_path : H.elt list -> int -> path

  val check_path : path -> H.elt -> H.t * int
end
src/lib_crypto/blake2B.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

include

module_type

module_type

unhandled_module

unhandled_module

unhandled_module

unhandled_module
src/lib_crypto/block_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make
          (Base58)
          (struct
            let name = "block_hash"

            let title = "A block identifier"

            let b58check_prefix = Base58.Prefix.block_hash

            let size = None
          end)

module Logging = struct
  let tag = Tag.def ~doc:"Block Hash" "block_hash" pp_short

  let predecessor_tag =
    Tag.def ~doc:"Block Predecessor Hash" "predecessor_hash" pp_short
end

let () = Base58.check_encoded_prefix b58check_encoding "B" 51
src/lib_crypto/block_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Logging.
  Definition tag : Tezos_stdlib.Tag.def t :=
    Tezos_stdlib.Tag.def (Some "Block Hash" % string) "block_hash" % string
      pp_short.
  
  Definition predecessor_tag : Tezos_stdlib.Tag.def t :=
    Tezos_stdlib.Tag.def (Some "Block Predecessor Hash" % string)
      "predecessor_hash" % string pp_short.
End Logging.
src/lib_crypto/block_hash.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.HASH

module Logging : sig
  val tag : t Tag.def

  val predecessor_tag : t Tag.def
end
src/lib_crypto/block_hash.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Module Logging.
  Parameter tag : Tezos_stdlib.Tag.def t.
  
  Parameter predecessor_tag : Tezos_stdlib.Tag.def t.
End Logging.
src/lib_crypto/chain_id.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

type t = string

let name = "Chain_id"

let title = "Network identifier"

let extract bh = Bytes.sub_string (Block_hash.to_bytes bh) 0 4

let hash_bytes ?key l = extract (Block_hash.hash_bytes ?key l)

let hash_string ?key l = extract (Block_hash.hash_string ?key l)

let size = 4

let of_string_opt s = if String.length s <> size then None else Some s

let of_string s =
  match of_string_opt s with
  | None ->
      generic_error
        "%s.of_string: wrong string size (%d)"
        name
        (String.length s)
  | Some h ->
      Ok h

let of_string_exn s =
  match of_string_opt s with
  | None ->
      Format.kasprintf
        invalid_arg
        "%s.of_string_exn: wrong string size (%d)"
        name
        (String.length s)
  | Some h ->
      h

let to_string s = s

let of_hex s = of_string (Hex.to_string s)

let of_hex_opt s = of_string_opt (Hex.to_string s)

let of_hex_exn s = of_string_exn (Hex.to_string s)

let to_hex s = Hex.of_string (to_string s)

let of_bytes_opt b =
  if Bytes.length b <> size then None else Some (Bytes.to_string b)

let of_bytes_exn b =
  match of_bytes_opt b with
  | None ->
      let msg =
        Printf.sprintf
          "%s.of_bytes: wrong string size (%d)"
          name
          (Bytes.length b)
      in
      raise (Invalid_argument msg)
  | Some h ->
      h

let of_bytes s =
  match of_bytes_opt s with
  | Some x ->
      Ok x
  | None ->
      generic_error "Failed to deserialize a hash (%s)" name

let to_bytes = Bytes.of_string

let path_length = 1

let to_path key l =
  let (`Hex h) = to_hex key in
  h :: l

let of_path path =
  let path = String.concat "" path in
  of_hex_opt (`Hex path)

let of_path_exn path =
  let path = String.concat "" path in
  of_hex_exn (`Hex path)

let prefix_path p =
  let (`Hex p) = Hex.of_string p in
  [p]

let zero = of_hex_exn (`Hex (String.make (size * 2) '0'))

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.chain_id
    ~length:size
    ~wrap:(fun s -> Data s)
    ~of_raw:of_string_opt
    ~to_raw:to_string

let raw_encoding =
  let open Data_encoding in
  conv to_bytes of_bytes_exn (Fixed.bytes size)

let hash h = Int32.to_int (TzEndian.get_int32 (to_bytes h) 0)

let of_block_hash bh = hash_bytes [Block_hash.to_bytes bh]

include Compare.Make (struct
  type nonrec t = t

  let compare = String.compare
end)

include Helpers.Make (struct
  type nonrec t = t

  let title = title

  let name = name

  let b58check_encoding = b58check_encoding

  let raw_encoding = raw_encoding

  let compare = compare

  let equal = equal

  let hash = hash
end)
src/lib_crypto/chain_id.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Definition t := string.

Definition name : string := "Chain_id" % string.

Definition title : string := "Network identifier" % string.

Definition extract (bh : Tezos_crypto.Block_hash.t) : string :=
  Stdlib.Bytes.sub_string (Tezos_crypto.Block_hash.to_bytes bh) 0 4.

Definition hash_bytes (key : option Stdlib.Bytes.t) (l : list Stdlib.Bytes.t)
  : string := extract (Tezos_crypto.Block_hash.hash_bytes key l).

Definition hash_string (key : option string) (l : list string) : string :=
  extract (Tezos_crypto.Block_hash.hash_string key l).

Definition size : Z := 4.

Definition of_string_opt (s : string) : option string :=
  if nequiv_decb (OCaml.String.length s) size then
    None
  else
    Some s.

Definition of_string (s : string)
  : Tezos_error_monad.Error_monad.tzresult string :=
  match of_string_opt s with
  | None =>
    Tezos_error_monad.Error_monad.generic_error
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal
            ".of_string: wrong string size (" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))))
        "%s.of_string: wrong string size (%d)" % string) name
      (OCaml.String.length s)
  | Some h => inl h
  end.

Definition of_string_exn (s : string) : string :=
  match of_string_opt s with
  | None =>
    Stdlib.Format.kasprintf OCaml.Stdlib.invalid_arg
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal
            ".of_string_exn: wrong string size (" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))))
        "%s.of_string_exn: wrong string size (%d)" % string) name
      (OCaml.String.length s)
  | Some h => h
  end.

Definition to_string {A : Type} (s : A) : A := s.

Definition of_hex (s : Hex.t) : Tezos_error_monad.Error_monad.tzresult string :=
  of_string (Hex.to_string s).

Definition of_hex_opt (s : Hex.t) : option string :=
  of_string_opt (Hex.to_string s).

Definition of_hex_exn (s : Hex.t) : string := of_string_exn (Hex.to_string s).

Definition to_hex (s : string) : Hex.t := Hex.of_string None (to_string s).

Definition of_bytes_opt (b : string) : option string :=
  if nequiv_decb (String.length b) size then
    None
  else
    Some (Stdlib.Bytes.to_string b).

Definition of_bytes_exn (b : string) : string :=
  match of_bytes_opt b with
  | None =>
    let msg :=
      Stdlib.Printf.sprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal
              ".of_bytes: wrong string size (" % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))
          "%s.of_bytes: wrong string size (%d)" % string) name (String.length b)
      in
    Stdlib.raise (OCaml.Invalid_argument msg)
  | Some h => h
  end.

Definition of_bytes (s : string)
  : sum string (list Tezos_error_monad.Error_monad.error) :=
  match of_bytes_opt s with
  | Some x => inl x
  | None =>
    Tezos_error_monad.Error_monad.generic_error
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to deserialize a hash (" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Failed to deserialize a hash (%s)" % string) name
  end.

Definition to_bytes : string -> string := Stdlib.Bytes.of_string.

Definition path_length : Z := 1.

Definition to_path (key : string) (l : list string) : list string :=
  match to_hex key with
  | Hex h => cons h l
  end.

Definition of_path (path : list string) : option string :=
  let path := Stdlib.String.concat "" % string path in
  of_hex_opt variant.

Definition of_path_exn (path : list string) : string :=
  let path := Stdlib.String.concat "" % string path in
  of_hex_exn variant.

Definition prefix_path (p : string) : list string :=
  match Hex.of_string None p with
  | Hex p => cons p []
  end.

Definition zero : string := of_hex_exn variant.

Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
  Tezos_crypto.Base58.register_encoding Tezos_crypto.Base58.Prefix.chain_id size
    to_string of_string_opt (fun s => Data s).

Definition raw_encoding : Tezos_data_encoding.Data_encoding.encoding string :=
  Tezos_data_encoding.Data_encoding.conv to_bytes of_bytes_exn None
    (Tezos_data_encoding.Data_encoding.Fixed.bytes size).

Definition hash (h : string) : Z :=
  Stdlib.Int32.to_int (Tezos_data_encoding.TzEndian.get_int32 (to_bytes h) 0).

Definition of_block_hash (bh : Tezos_crypto.Block_hash.t) : string :=
  hash_bytes None (cons (Tezos_crypto.Block_hash.to_bytes bh) []).
src/lib_crypto/chain_id.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.HASH

val of_block_hash : Block_hash.t -> t
src/lib_crypto/chain_id.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter of_block_hash : Tezos_crypto.Block_hash.t -> t.
src/lib_crypto/context_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make
          (Base58)
          (struct
            let name = "Context_hash"

            let title = "A hash of context"

            let b58check_prefix = Base58.Prefix.context_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "Co" 52
src/lib_crypto/context_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_crypto/context_hash.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.HASH
src/lib_crypto/context_hash.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_crypto/crypto_box.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - X25519/XSalsa20-Poly1305 cryptography *)

open Hacl

type secret_key = secret Box.key

type public_key = public Box.key

type channel_key = Box.combined Box.key

type nonce = Bigstring.t

type target = Z.t

module Secretbox = struct
  include Secretbox

  let box_noalloc key nonce msg = box ~key ~nonce ~msg ~cmsg:msg

  let box_open_noalloc key nonce cmsg = box_open ~key ~nonce ~cmsg ~msg:cmsg

  let box key msg nonce =
    let msglen = Bytes.length msg in
    let cmsg = Bigstring.make (msglen + zerobytes) '\x00' in
    Bigstring.blit_of_bytes msg 0 cmsg zerobytes msglen ;
    box ~key ~nonce ~msg:cmsg ~cmsg ;
    Bigstring.sub cmsg boxzerobytes (msglen + zerobytes - boxzerobytes)

  let box_open key cmsg nonce =
    let cmsglen = Bigstring.length cmsg in
    let msg = Bigstring.make (cmsglen + boxzerobytes) '\x00' in
    Bigstring.blit cmsg 0 msg boxzerobytes cmsglen ;
    match box_open ~key ~nonce ~cmsg:msg ~msg with
    | false ->
        None
    | true ->
        Some (Bigstring.sub_bytes msg zerobytes (cmsglen - boxzerobytes))
end

module Public_key_hash =
  Blake2B.Make
    (Base58)
    (struct
      let name = "Crypto_box.Public_key_hash"

      let title = "A Cryptobox public key ID"

      let b58check_prefix = Base58.Prefix.cryptobox_public_key_hash

      let size = Some 16
    end)

let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "id" 30

let hash pk =
  Public_key_hash.hash_bytes [Bigstring.to_bytes (Box.unsafe_to_bytes pk)]

let zerobytes = Box.zerobytes

let boxzerobytes = Box.boxzerobytes

let random_keypair () =
  let (pk, sk) = Box.keypair () in
  (sk, pk, hash pk)

let zero_nonce = Bigstring.make Nonce.bytes '\x00'

let random_nonce = Nonce.gen

let increment_nonce = Nonce.increment

let generate_nonce bytes_list =
  let hash = Blake2B.hash_bytes bytes_list in
  let s = Bigstring.of_bytes (Blake2B.to_bytes hash) in
  Nonce.of_bytes_exn @@ Bigstring.sub s 0 Nonce.bytes

let init_to_resp_seed = Bytes.of_string "Init -> Resp"

let resp_to_init_seed = Bytes.of_string "Resp -> Init"

let generate_nonces ~incoming ~sent_msg ~recv_msg =
  let ((init_msg, resp_msg, false) | (resp_msg, init_msg, true)) =
    (sent_msg, recv_msg, incoming)
  in
  let nonce_init_to_resp =
    generate_nonce [init_msg; resp_msg; init_to_resp_seed]
  in
  let nonce_resp_to_init =
    generate_nonce [init_msg; resp_msg; resp_to_init_seed]
  in
  if incoming then (nonce_init_to_resp, nonce_resp_to_init)
  else (nonce_resp_to_init, nonce_init_to_resp)

let precompute sk pk = Box.dh pk sk

let fast_box_noalloc k nonce bmsg =
  let msg = Bigstring.of_bytes bmsg in
  Box.box ~k ~nonce ~msg ~cmsg:msg ;
  Bigstring.blit_to_bytes msg 0 bmsg 0 (Bytes.length bmsg)

let fast_box_open_noalloc k nonce bcmsg =
  let cmsg = Bigstring.of_bytes bcmsg in
  if Box.box_open ~k ~nonce ~cmsg ~msg:cmsg then (
    Bigstring.blit_to_bytes cmsg 0 bcmsg 0 (Bytes.length bcmsg) ;
    true )
  else false

let fast_box k msg nonce =
  let msglen = Bigstring.length msg in
  let cmsg = Bigstring.make (msglen + zerobytes) '\x00' in
  Bigstring.blit msg 0 cmsg zerobytes msglen ;
  Box.box ~k ~nonce ~msg:cmsg ~cmsg ;
  cmsg

let fast_box_open k cmsg nonce =
  let cmsglen = Bigstring.length cmsg in
  let msg = Bigstring.make cmsglen '\x00' in
  match Box.box_open ~k ~nonce ~cmsg ~msg with
  | false ->
      None
  | true ->
      Some (Bigstring.sub msg zerobytes (cmsglen - zerobytes))

let compare_target hash target =
  let hash = Z.of_bits (Blake2B.to_string hash) in
  Z.compare hash target <= 0

let make_target f =
  if f < 0. || 256. < f then invalid_arg "Cryptobox.target_of_float" ;
  let (frac, shift) = modf f in
  let shift = int_of_float shift in
  let m =
    Z.of_int64
    @@
    if frac = 0. then Int64.(pred (shift_left 1L 54))
    else Int64.of_float (2. ** (54. -. frac))
  in
  if shift < 202 then
    Z.logor
      (Z.shift_left m (202 - shift))
      (Z.pred @@ Z.shift_left Z.one (202 - shift))
  else Z.shift_right m (shift - 202)

let default_target = make_target 24.

let check_proof_of_work pk nonce target =
  let hash =
    Blake2B.hash_bytes
      [Bigstring.to_bytes (Box.unsafe_to_bytes pk); Bigstring.to_bytes nonce]
  in
  compare_target hash target

let generate_proof_of_work ?max pk target =
  let may_interupt =
    match max with
    | None ->
        fun _ -> ()
    | Some max ->
        fun cpt -> if max < cpt then raise Not_found
  in
  let rec loop nonce cpt =
    may_interupt cpt ;
    if check_proof_of_work pk nonce target then nonce
    else loop (Nonce.increment nonce) (cpt + 1)
  in
  loop (random_nonce ()) 0

let public_key_to_bytes pk = Bigstring.to_bytes (Box.unsafe_to_bytes pk)

let public_key_of_bytes buf = Box.unsafe_pk_of_bytes (Bigstring.of_bytes buf)

let public_key_size = Box.pkbytes

let secret_key_to_bytes sk = Bigstring.to_bytes (Box.unsafe_to_bytes sk)

let secret_key_of_bytes buf = Box.unsafe_sk_of_bytes (Bigstring.of_bytes buf)

let secret_key_size = Box.skbytes

let nonce_size = Nonce.bytes

let public_key_encoding =
  let open Data_encoding in
  conv public_key_to_bytes public_key_of_bytes (Fixed.bytes public_key_size)

let secret_key_encoding =
  let open Data_encoding in
  conv secret_key_to_bytes secret_key_of_bytes (Fixed.bytes secret_key_size)

let nonce_encoding =
  let open Data_encoding in
  conv Bigstring.to_bytes Bigstring.of_bytes (Fixed.bytes nonce_size)

let neuterize : secret_key -> public_key = Box.neuterize

let equal : public_key -> public_key -> bool = Box.equal

let pp_pk ppf pk = Hex.pp ppf (Hex.of_bytes (public_key_to_bytes pk))
src/lib_crypto/crypto_box.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Hacl.

Definition secret_key := Hacl.Box.key Hacl.secret.

Definition public_key := Hacl.Box.key Hacl.public.

Definition channel_key := Hacl.Box.key Hacl.Box.combined.

Definition nonce := Bigstring.t.

Definition target := Z.t.

Module Secretbox.
  Definition box_noalloc (key : key) (nonce : Bigstring.t) (msg : Bigstring.t)
    : unit := box key nonce msg msg.
  
  Definition box_open_noalloc
    (key : key) (nonce : Bigstring.t) (cmsg : Bigstring.t) : bool :=
    box_open key nonce cmsg cmsg.
  
  Definition box (key : key) (msg : Stdlib.Bytes.t) (nonce : Bigstring.t)
    : Bigstring.t :=
    let msglen := String.length msg in
    let cmsg := Bigstring.make (Z.add msglen zerobytes) "000" % char in
    Bigstring.blit_of_bytes msg 0 cmsg zerobytes msglen;
    box key nonce cmsg cmsg;
    Bigstring.sub cmsg boxzerobytes
      (Z.sub (Z.add msglen zerobytes) boxzerobytes).
  
  Definition box_open (key : key) (cmsg : Bigstring.t) (nonce : Bigstring.t)
    : option Stdlib.Bytes.t :=
    let cmsglen := Bigstring.length cmsg in
    let msg := Bigstring.make (Z.add cmsglen boxzerobytes) "000" % char in
    Bigstring.blit cmsg 0 msg boxzerobytes cmsglen;
    match box_open key nonce msg msg with
    | false => None
    | true =>
      Some (Bigstring.sub_bytes msg zerobytes (Z.sub cmsglen boxzerobytes))
    end.
End Secretbox.

Definition hash {A : Type} (pk : Hacl.Box.key A)
  : Public_key_hash.(Tezos_crypto__S.HASH.t) :=
  Public_key_hash.(Tezos_crypto__S.HASH.hash_bytes) None
    (cons (Bigstring.to_bytes (Hacl.Box.unsafe_to_bytes pk)) []).

Definition zerobytes : Z := Hacl.Box.zerobytes.

Definition boxzerobytes : Z := Hacl.Box.boxzerobytes.

Definition random_keypair (function_parameter : unit)
  : (Hacl.Box.key Hacl.secret) * (Hacl.Box.key Hacl.public) *
    Public_key_hash.(Tezos_crypto__S.HASH.t) :=
  match function_parameter with
  | tt =>
    match Hacl.Box.keypair tt with
    | (pk, sk) => (sk, pk, (hash pk))
    end
  end.

Definition zero_nonce : Bigstring.t :=
  Bigstring.make Hacl.Nonce.bytes "000" % char.

Definition random_nonce : unit -> Hacl.Nonce.t := Hacl.Nonce.gen.

Definition increment_nonce : (option Z) -> Hacl.Nonce.t -> Hacl.Nonce.t :=
  Hacl.Nonce.increment.

Definition generate_nonce (bytes_list : list Stdlib.Bytes.t) : Hacl.Nonce.t :=
  let hash := Tezos_crypto.Blake2B.hash_bytes None bytes_list in
  let s := Bigstring.of_bytes (Tezos_crypto.Blake2B.to_bytes hash) in
  apply Hacl.Nonce.of_bytes_exn (Bigstring.sub s 0 Hacl.Nonce.bytes).

Definition init_to_resp_seed : string :=
  Stdlib.Bytes.of_string "Init -> Resp" % string.

Definition resp_to_init_seed : string :=
  Stdlib.Bytes.of_string "Resp -> Init" % string.

Definition generate_nonces
  (incoming : bool) (sent_msg : Stdlib.Bytes.t) (recv_msg : Stdlib.Bytes.t)
  : Hacl.Nonce.t * Hacl.Nonce.t :=
  match (sent_msg, recv_msg, incoming) with
  | (init_msg, resp_msg, false) | (resp_msg, init_msg, true) =>
    let nonce_init_to_resp :=
      generate_nonce (cons init_msg (cons resp_msg (cons init_to_resp_seed [])))
      in
    let nonce_resp_to_init :=
      generate_nonce (cons init_msg (cons resp_msg (cons resp_to_init_seed [])))
      in
    if incoming then
      (nonce_init_to_resp, nonce_resp_to_init)
    else
      (nonce_resp_to_init, nonce_init_to_resp)
  end.

Definition precompute
  (sk : Hacl.Box.key Hacl.secret) (pk : Hacl.Box.key Hacl.public)
  : Hacl.Box.key Hacl.Box.combined := Hacl.Box.dh pk sk.

Definition fast_box_noalloc
  (k : Hacl.Box.key Hacl.Box.combined) (nonce : Bigstring.t)
  (bmsg : Stdlib.Bytes.t) : unit :=
  let msg := Bigstring.of_bytes bmsg in
  Hacl.Box.box k nonce msg msg;
  Bigstring.blit_to_bytes msg 0 bmsg 0 (String.length bmsg).

Definition fast_box_open_noalloc
  (k : Hacl.Box.key Hacl.Box.combined) (nonce : Bigstring.t)
  (bcmsg : Stdlib.Bytes.t) : bool :=
  let cmsg := Bigstring.of_bytes bcmsg in
  if Hacl.Box.box_open k nonce cmsg cmsg then
    Bigstring.blit_to_bytes cmsg 0 bcmsg 0 (String.length bcmsg);
    true
  else
    false.

Definition fast_box
  (k : Hacl.Box.key Hacl.Box.combined) (msg : Bigstring.t) (nonce : Bigstring.t)
  : Bigstring.t :=
  let msglen := Bigstring.length msg in
  let cmsg := Bigstring.make (Z.add msglen zerobytes) "000" % char in
  Bigstring.blit msg 0 cmsg zerobytes msglen;
  Hacl.Box.box k nonce cmsg cmsg;
  cmsg.

Definition fast_box_open
  (k : Hacl.Box.key Hacl.Box.combined) (cmsg : Bigstring.t)
  (nonce : Bigstring.t) : option Bigstring.t :=
  let cmsglen := Bigstring.length cmsg in
  let msg := Bigstring.make cmsglen "000" % char in
  match Hacl.Box.box_open k nonce cmsg msg with
  | false => None
  | true => Some (Bigstring.sub msg zerobytes (Z.sub cmsglen zerobytes))
  end.

Definition compare_target (hash : Tezos_crypto.Blake2B.t) (target : Z.t)
  : bool :=
  let hash := Z.of_bits (Tezos_crypto.Blake2B.to_string hash) in
  OCaml.Stdlib.le (Z.compare hash target) 0.

Definition make_target (f : float) : Z.t :=
  if orb (OCaml.Stdlib.lt f 0) (OCaml.Stdlib.lt 256 f) then
    OCaml.Stdlib.invalid_arg "Cryptobox.target_of_float" % string
  else
    tt;
  match Stdlib.modf f with
  | (frac, shift) =>
    let shift := Stdlib.int_of_float shift in
    let m :=
      apply Z.of_int64
        (if equiv_decb frac 0 then
          Stdlib.Int64.pred (Stdlib.Int64.shift_left 1 54)
        else
          Stdlib.Int64.of_float
            (Stdlib.op_star_star 2 (Stdlib.op_minus_point 54 frac))) in
    if OCaml.Stdlib.lt shift 202 then
      Z.logor (Z.shift_left m (Z.sub 202 shift))
        (apply Z.pred (Z.shift_left Z.one (Z.sub 202 shift)))
    else
      Z.shift_right m (Z.sub shift 202)
  end.

Definition default_target : Z.t := make_target 24.

Definition check_proof_of_work {A : Type}
  (pk : Hacl.Box.key A) (nonce : Bigstring.t) (target : Z.t) : bool :=
  let hash :=
    Tezos_crypto.Blake2B.hash_bytes None
      (cons (Bigstring.to_bytes (Hacl.Box.unsafe_to_bytes pk))
        (cons (Bigstring.to_bytes nonce) [])) in
  compare_target hash target.

Definition generate_proof_of_work {A : Type}
  (max : option Z) (pk : Hacl.Box.key A) (target : Z.t) : Bigstring.t :=
  let may_interupt :=
    match max with
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => tt
        end
    | Some max =>
      fun cpt =>
        if OCaml.Stdlib.lt max cpt then
          Stdlib.raise OCaml.Not_found
        else
          tt
    end in
  let fix loop (nonce : Bigstring.t) (cpt : Z) : Bigstring.t :=
    may_interupt cpt;
    if check_proof_of_work pk nonce target then
      nonce
    else
      loop (Hacl.Nonce.increment None nonce) (Z.add cpt 1) in
  loop (random_nonce tt) 0.

Definition public_key_to_bytes {A : Type} (pk : Hacl.Box.key A)
  : Stdlib.Bytes.t := Bigstring.to_bytes (Hacl.Box.unsafe_to_bytes pk).

Definition public_key_of_bytes (buf : Stdlib.Bytes.t)
  : Hacl.Box.key Hacl.public :=
  Hacl.Box.unsafe_pk_of_bytes (Bigstring.of_bytes buf).

Definition public_key_size : Z := Hacl.Box.pkbytes.

Definition secret_key_to_bytes {A : Type} (sk : Hacl.Box.key A)
  : Stdlib.Bytes.t := Bigstring.to_bytes (Hacl.Box.unsafe_to_bytes sk).

Definition secret_key_of_bytes (buf : Stdlib.Bytes.t)
  : Hacl.Box.key Hacl.secret :=
  Hacl.Box.unsafe_sk_of_bytes (Bigstring.of_bytes buf).

Definition secret_key_size : Z := Hacl.Box.skbytes.

Definition nonce_size : Z := Hacl.Nonce.bytes.

Definition public_key_encoding
  : Tezos_data_encoding.Data_encoding.encoding (Hacl.Box.key Hacl.public) :=
  Tezos_data_encoding.Data_encoding.conv public_key_to_bytes public_key_of_bytes
    None (Tezos_data_encoding.Data_encoding.Fixed.bytes public_key_size).

Definition secret_key_encoding
  : Tezos_data_encoding.Data_encoding.encoding (Hacl.Box.key Hacl.secret) :=
  Tezos_data_encoding.Data_encoding.conv secret_key_to_bytes secret_key_of_bytes
    None (Tezos_data_encoding.Data_encoding.Fixed.bytes secret_key_size).

Definition nonce_encoding
  : Tezos_data_encoding.Data_encoding.encoding Bigstring.t :=
  Tezos_data_encoding.Data_encoding.conv Bigstring.to_bytes Bigstring.of_bytes
    None (Tezos_data_encoding.Data_encoding.Fixed.bytes nonce_size).

Definition neuterize : secret_key -> public_key := Hacl.Box.neuterize.

Definition equal : public_key -> public_key -> bool := Hacl.Box.equal.

Definition pp_pk {A : Type}
  (ppf : Stdlib.Format.formatter) (pk : Hacl.Box.key A) : unit :=
  Hex.pp ppf (Hex.of_bytes None (public_key_to_bytes pk)).
src/lib_crypto/crypto_box.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - X25519/XSalsa20-Poly1305 cryptography *)

type nonce = Bigstring.t

val nonce_size : int

val zero_nonce : nonce

val random_nonce : unit -> nonce

val increment_nonce : ?step:int -> nonce -> nonce

(** [generate_nonces ~incoming ~sent_msg ~recv_msg] generates two
    nonces by hashing (Blake2B) the arguments. The nonces should be
    used to initialize the encryption on the communication
    channels. Because an attacker cannot control both messages,
    it cannot determine the nonces that will be used to encrypt
    the messages. The sent message should contains a random nonce,
    and we should never send the exact same message twice. *)
val generate_nonces :
  incoming:bool -> sent_msg:Bytes.t -> recv_msg:Bytes.t -> nonce * nonce

module Secretbox : sig
  type key

  val unsafe_of_bytes : Bigstring.t -> key

  val box_noalloc : key -> nonce -> Bigstring.t -> unit

  val box_open_noalloc : key -> nonce -> Bigstring.t -> bool

  val box : key -> Bytes.t -> nonce -> Bigstring.t

  val box_open : key -> Bigstring.t -> nonce -> Bytes.t option
end

type target

val default_target : target

val make_target : float -> target

type secret_key

type public_key

module Public_key_hash : S.HASH

type channel_key

val hash : public_key -> Public_key_hash.t

val zerobytes : int

val boxzerobytes : int

val random_keypair : unit -> secret_key * public_key * Public_key_hash.t

val precompute : secret_key -> public_key -> channel_key

val fast_box : channel_key -> Bigstring.t -> nonce -> Bigstring.t

val fast_box_open : channel_key -> Bigstring.t -> nonce -> Bigstring.t option

val fast_box_noalloc : channel_key -> nonce -> Bytes.t -> unit

val fast_box_open_noalloc : channel_key -> nonce -> Bytes.t -> bool

val check_proof_of_work : public_key -> nonce -> target -> bool

val generate_proof_of_work : ?max:int -> public_key -> target -> nonce

val public_key_to_bytes : public_key -> Bytes.t

val public_key_of_bytes : Bytes.t -> public_key

val public_key_size : int

val secret_key_size : int

val public_key_encoding : public_key Data_encoding.t

val secret_key_encoding : secret_key Data_encoding.t

val nonce_encoding : nonce Data_encoding.t

val neuterize : secret_key -> public_key

val equal : public_key -> public_key -> bool

val pp_pk : Format.formatter -> public_key -> unit
src/lib_crypto/crypto_box.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition nonce := Bigstring.t.

Parameter nonce_size : Z.

Parameter zero_nonce : nonce.

Parameter random_nonce : unit -> nonce.

Parameter increment_nonce : (option Z) -> nonce -> nonce.

Parameter generate_nonces :
bool -> Stdlib.Bytes.t -> Stdlib.Bytes.t -> nonce * nonce.

Module Secretbox.
  Parameter key : Type.
  
  Parameter unsafe_of_bytes : Bigstring.t -> key.
  
  Parameter box_noalloc : key -> nonce -> Bigstring.t -> unit.
  
  Parameter box_open_noalloc : key -> nonce -> Bigstring.t -> bool.
  
  Parameter box : key -> Stdlib.Bytes.t -> nonce -> Bigstring.t.
  
  Parameter box_open : key -> Bigstring.t -> nonce -> option Stdlib.Bytes.t.
End Secretbox.

Parameter target : Type.

Parameter default_target : target.

Parameter make_target : float -> target.

Parameter secret_key : Type.

Parameter public_key : Type.

unhandled_module

Parameter channel_key : Type.

Parameter hash : public_key -> Public_key_hash.(Tezos_crypto__S.HASH.t).

Parameter zerobytes : Z.

Parameter boxzerobytes : Z.

Parameter random_keypair :
unit -> secret_key * public_key * Public_key_hash.(Tezos_crypto__S.HASH.t).

Parameter precompute : secret_key -> public_key -> channel_key.

Parameter fast_box : channel_key -> Bigstring.t -> nonce -> Bigstring.t.

Parameter fast_box_open :
channel_key -> Bigstring.t -> nonce -> option Bigstring.t.

Parameter fast_box_noalloc : channel_key -> nonce -> Stdlib.Bytes.t -> unit.

Parameter fast_box_open_noalloc :
channel_key -> nonce -> Stdlib.Bytes.t -> bool.

Parameter check_proof_of_work : public_key -> nonce -> target -> bool.

Parameter generate_proof_of_work : (option Z) -> public_key -> target -> nonce.

Parameter public_key_to_bytes : public_key -> Stdlib.Bytes.t.

Parameter public_key_of_bytes : Stdlib.Bytes.t -> public_key.

Parameter public_key_size : Z.

Parameter secret_key_size : Z.

Parameter public_key_encoding : Tezos_data_encoding.Data_encoding.t public_key.

Parameter secret_key_encoding : Tezos_data_encoding.Data_encoding.t secret_key.

Parameter nonce_encoding : Tezos_data_encoding.Data_encoding.t nonce.

Parameter neuterize : secret_key -> public_key.

Parameter equal : public_key -> public_key -> bool.

Parameter pp_pk : Stdlib.Format.formatter -> public_key -> unit.
src/lib_crypto/ed25519.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module Public_key_hash = struct
  include Blake2B.Make
            (Base58)
            (struct
              let name = "Ed25519.Public_key_hash"

              let title = "An Ed25519 public key hash"

              let b58check_prefix = Base58.Prefix.ed25519_public_key_hash

              let size = Some 20
            end)

  module Logging = struct
    let tag = Tag.def ~doc:title name pp
  end
end

let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz1" 36

open Hacl

module Public_key = struct
  type t = public Sign.key

  let name = "Ed25519.Public_key"

  let title = "Ed25519 public key"

  let to_string s = Bigstring.to_string (Sign.unsafe_to_bytes s)

  let of_string_opt s =
    if String.length s < Sign.pkbytes then None
    else
      let pk = Bigstring.create Sign.pkbytes in
      Bigstring.blit_of_string s 0 pk 0 Sign.pkbytes ;
      Some (Sign.unsafe_pk_of_bytes pk)

  let to_bytes pk = Bigstring.to_bytes (Sign.unsafe_to_bytes pk)

  let of_bytes_opt buf =
    let buflen = Bytes.length buf in
    if buflen < Sign.pkbytes then None
    else
      let pk = Bigstring.create Sign.pkbytes in
      Bigstring.blit_of_bytes buf 0 pk 0 Sign.pkbytes ;
      Some (Sign.unsafe_pk_of_bytes pk)

  let size = Sign.pkbytes

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.ed25519_public_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "edpk" 54

  let hash v =
    Public_key_hash.hash_bytes [Bigstring.to_bytes (Sign.unsafe_to_bytes v)]

  include Compare.Make (struct
    type nonrec t = t

    let compare a b =
      Bigstring.compare (Sign.unsafe_to_bytes a) (Sign.unsafe_to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

module Secret_key = struct
  type t = secret Sign.key

  let name = "Ed25519.Secret_key"

  let title = "An Ed25519 secret key"

  let size = Sign.skbytes

  let to_bigstring sk = Sign.unsafe_to_bytes sk

  let to_bytes sk = Bigstring.to_bytes (to_bigstring sk)

  let of_bytes_opt s =
    if Bytes.length s > 64 then None
    else
      let sk = Bigstring.create Sign.skbytes in
      Bigstring.blit_of_bytes s 0 sk 0 Sign.skbytes ;
      Some (Sign.unsafe_sk_of_bytes sk)

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let to_public_key = Sign.neuterize

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.ed25519_seed
      ~length:size
      ~to_raw:(fun sk -> Bigstring.to_string (Sign.unsafe_to_bytes sk))
      ~of_raw:(fun buf ->
        if String.length buf <> Sign.skbytes then None
        else Some (Sign.unsafe_sk_of_bytes (Bigstring.of_string buf)))
      ~wrap:(fun sk -> Data sk)

  (* Legacy NaCl secret key encoding. Used to store both sk and pk. *)
  let secret_key_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.ed25519_secret_key
      ~length:Sign.(skbytes + pkbytes)
      ~to_raw:(fun sk ->
        let pk = Sign.neuterize sk in
        let buf = Bigstring.create Sign.(skbytes + pkbytes) in
        Sign.blit_to_bytes sk buf ;
        Sign.blit_to_bytes pk ~pos:Sign.skbytes buf ;
        Bigstring.to_string buf)
      ~of_raw:(fun buf ->
        if String.length buf <> Sign.(skbytes + pkbytes) then None
        else
          let sk = Bigstring.create Sign.skbytes in
          Bigstring.blit_of_string buf 0 sk 0 Sign.skbytes ;
          Some (Sign.unsafe_sk_of_bytes sk))
      ~wrap:(fun x -> Data x)

  let of_b58check_opt s =
    match Base58.simple_decode b58check_encoding s with
    | Some x ->
        Some x
    | None ->
        Base58.simple_decode secret_key_encoding s

  let of_b58check_exn s =
    match of_b58check_opt s with
    | Some x ->
        x
    | None ->
        Format.kasprintf Pervasives.failwith "Unexpected data (%s)" name

  let of_b58check s =
    match of_b58check_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error "Failed to read a b58check_encoding data (%s): %S" name s

  let to_b58check s = Base58.simple_encode b58check_encoding s

  let to_short_b58check s =
    String.sub
      (to_b58check s)
      0
      (10 + String.length (Base58.prefix b58check_encoding))

  let () =
    Base58.check_encoded_prefix b58check_encoding "edsk" 54 ;
    Base58.check_encoded_prefix secret_key_encoding "edsk" 98

  include Compare.Make (struct
    type nonrec t = t

    let compare a b =
      Bigstring.compare (Sign.unsafe_to_bytes a) (Sign.unsafe_to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

type t = Bigstring.t

type watermark = Bytes.t

let name = "Ed25519"

let title = "An Ed25519 signature"

let size = Sign.bytes

let of_bytes_opt s =
  if Bytes.length s = size then Some (Bigstring.of_bytes s) else None

let to_bytes x = Bigstring.to_bytes x

let to_string s = Bytes.to_string (to_bytes s)

let of_string_opt s = of_bytes_opt (Bytes.of_string s)

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.ed25519_signature
    ~length:size
    ~to_raw:Bigstring.to_string
    ~of_raw:(fun s -> Some (Bigstring.of_string s))
    ~wrap:(fun x -> Data x)

let () = Base58.check_encoded_prefix b58check_encoding "edsig" 99

include Helpers.MakeRaw (struct
  type nonrec t = t

  let name = name

  let of_bytes_opt = of_bytes_opt

  let of_string_opt = of_string_opt

  let to_string = to_string
end)

include Helpers.MakeB58 (struct
  type nonrec t = t

  let name = name

  let b58check_encoding = b58check_encoding
end)

include Helpers.MakeEncoder (struct
  type nonrec t = t

  let name = name

  let title = title

  let raw_encoding =
    let open Data_encoding in
    conv to_bytes of_bytes_exn (Fixed.bytes size)

  let of_b58check = of_b58check

  let of_b58check_opt = of_b58check_opt

  let of_b58check_exn = of_b58check_exn

  let to_b58check = to_b58check

  let to_short_b58check = to_short_b58check
end)

let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)

let zero = Bigstring.make size '\000'

let sign ?watermark sk msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  let signature = Bigstring.create Sign.bytes in
  Sign.sign ~sk ~msg:(Bigstring.of_bytes msg) ~signature ;
  signature

let check ?watermark pk signature msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  Sign.verify ~pk ~signature ~msg:(Bigstring.of_bytes msg)

let generate_key ?seed () =
  match seed with
  | None ->
      let (pk, sk) = Sign.keypair () in
      (Public_key.hash pk, pk, sk)
  | Some seed ->
      let seedlen = Bigstring.length seed in
      if seedlen < Sign.skbytes then
        invalid_arg
          (Printf.sprintf
             "Ed25519.generate_key: seed must be at least %d bytes long (got \
              %d)"
             Sign.skbytes
             seedlen) ;
      let sk = Bigstring.create Sign.skbytes in
      Bigstring.blit seed 0 sk 0 Sign.skbytes ;
      let sk = Sign.unsafe_sk_of_bytes sk in
      let pk = Sign.neuterize sk in
      (Public_key.hash pk, pk, sk)

let deterministic_nonce sk msg =
  let msg = Bigstring.of_bytes msg in
  let key = Secret_key.to_bigstring sk in
  Hash.SHA256.HMAC.digest ~key ~msg

let deterministic_nonce_hash sk msg =
  Blake2B.to_bytes
    (Blake2B.hash_bytes [Bigstring.to_bytes (deterministic_nonce sk msg)])

include Compare.Make (struct
  type nonrec t = t

  let compare = Bigstring.compare
end)
src/lib_crypto/ed25519.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Module Public_key_hash.
  Module Logging.
    Definition tag : Tezos_stdlib.Tag.def t :=
      Tezos_stdlib.Tag.def (Some title) name pp.
  End Logging.
End Public_key_hash.

Import Hacl.

Module Public_key.
  Definition t := Hacl.Sign.key Hacl.public.
  
  Definition name : string := "Ed25519.Public_key" % string.
  
  Definition title : string := "Ed25519 public key" % string.
  
  Definition to_string {A : Type} (s : Hacl.Sign.key A) : string :=
    Bigstring.to_string (Hacl.Sign.unsafe_to_bytes s).
  
  Definition of_string_opt (s : string) : option (Hacl.Sign.key Hacl.public) :=
    if OCaml.Stdlib.lt (OCaml.String.length s) Hacl.Sign.pkbytes then
      None
    else
      let pk := Bigstring.create Hacl.Sign.pkbytes in
      Bigstring.blit_of_string s 0 pk 0 Hacl.Sign.pkbytes;
      Some (Hacl.Sign.unsafe_pk_of_bytes pk).
  
  Definition to_bytes {A : Type} (pk : Hacl.Sign.key A) : Stdlib.Bytes.t :=
    Bigstring.to_bytes (Hacl.Sign.unsafe_to_bytes pk).
  
  Definition of_bytes_opt (buf : Stdlib.Bytes.t)
    : option (Hacl.Sign.key Hacl.public) :=
    let buflen := String.length buf in
    if OCaml.Stdlib.lt buflen Hacl.Sign.pkbytes then
      None
    else
      let pk := Bigstring.create Hacl.Sign.pkbytes in
      Bigstring.blit_of_bytes buf 0 pk 0 Hacl.Sign.pkbytes;
      Some (Hacl.Sign.unsafe_pk_of_bytes pk).
  
  Definition size : Z := Hacl.Sign.pkbytes.
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Tezos_crypto.Base58.register_encoding
      Tezos_crypto.Base58.Prefix.ed25519_public_key size to_string of_string_opt
      (fun x => Data x).
  
  Definition hash {A : Type} (v : Hacl.Sign.key A) : Public_key_hash.t :=
    Public_key_hash.hash_bytes None
      (cons (Bigstring.to_bytes (Hacl.Sign.unsafe_to_bytes v)) []).
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.

Module Secret_key.
  Definition t := Hacl.Sign.key Hacl.secret.
  
  Definition name : string := "Ed25519.Secret_key" % string.
  
  Definition title : string := "An Ed25519 secret key" % string.
  
  Definition size : Z := Hacl.Sign.skbytes.
  
  Definition to_bigstring {A : Type} (sk : Hacl.Sign.key A) : Bigstring.t :=
    Hacl.Sign.unsafe_to_bytes sk.
  
  Definition to_bytes {A : Type} (sk : Hacl.Sign.key A) : Stdlib.Bytes.t :=
    Bigstring.to_bytes (to_bigstring sk).
  
  Definition of_bytes_opt (s : Stdlib.Bytes.t)
    : option (Hacl.Sign.key Hacl.secret) :=
    if OCaml.Stdlib.gt (String.length s) 64 then
      None
    else
      let sk := Bigstring.create Hacl.Sign.skbytes in
      Bigstring.blit_of_bytes s 0 sk 0 Hacl.Sign.skbytes;
      Some (Hacl.Sign.unsafe_sk_of_bytes sk).
  
  Definition to_string {A : Type} (s : Hacl.Sign.key A) : string :=
    Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string) : option (Hacl.Sign.key Hacl.secret) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition to_public_key {A : Type}
    : (Hacl.Sign.key A) -> Hacl.Sign.key Hacl.public := Hacl.Sign.neuterize.
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Tezos_crypto.Base58.register_encoding
      Tezos_crypto.Base58.Prefix.ed25519_seed size
      (fun sk => Bigstring.to_string (Hacl.Sign.unsafe_to_bytes sk))
      (fun buf =>
        if nequiv_decb (OCaml.String.length buf) Hacl.Sign.skbytes then
          None
        else
          Some (Hacl.Sign.unsafe_sk_of_bytes (Bigstring.of_string buf)))
      (fun sk => Data sk).
  
  Definition secret_key_encoding : Tezos_crypto.Base58.encoding t :=
    Tezos_crypto.Base58.register_encoding
      Tezos_crypto.Base58.Prefix.ed25519_secret_key
      (Z.add Hacl.Sign.skbytes Hacl.Sign.pkbytes)
      (fun sk =>
        let pk := Hacl.Sign.neuterize sk in
        let buf := Bigstring.create (Z.add Hacl.Sign.skbytes Hacl.Sign.pkbytes)
          in
        Hacl.Sign.blit_to_bytes sk None buf;
        Hacl.Sign.blit_to_bytes pk (Some Hacl.Sign.skbytes) buf;
        Bigstring.to_string buf)
      (fun buf =>
        if
          nequiv_decb (OCaml.String.length buf)
            (Z.add Hacl.Sign.skbytes Hacl.Sign.pkbytes) then
          None
        else
          let sk := Bigstring.create Hacl.Sign.skbytes in
          Bigstring.blit_of_string buf 0 sk 0 Hacl.Sign.skbytes;
          Some (Hacl.Sign.unsafe_sk_of_bytes sk)) (fun x => Data x).
  
  Definition of_b58check_opt (s : string) : option t :=
    match Tezos_crypto.Base58.simple_decode None b58check_encoding s with
    | Some x => Some x
    | None => Tezos_crypto.Base58.simple_decode None secret_key_encoding s
    end.
  
  Definition of_b58check_exn (s : string) : t :=
    match of_b58check_opt s with
    | Some x => x
    | None =>
      Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Unexpected data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))
          "Unexpected data (%s)" % string) name
    end.
  
  Definition of_b58check (s : string)
    : sum t (list Tezos_error_monad.Error_monad.error) :=
    match of_b58check_opt s with
    | Some x => inl x
    | None =>
      Tezos_error_monad.Error_monad.generic_error
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Failed to read a b58check_encoding data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "): " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "Failed to read a b58check_encoding data (%s): %S" % string) name s
    end.
  
  Definition to_b58check (s : t) : string :=
    Tezos_crypto.Base58.simple_encode None b58check_encoding s.
  
  Definition to_short_b58check (s : t) : string :=
    Stdlib.String.sub (to_b58check s) 0
      (Z.add 10
        (OCaml.String.length (Tezos_crypto.Base58.prefix b58check_encoding))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.

Definition t := Bigstring.t.

Definition watermark := Stdlib.Bytes.t.

Definition name : string := "Ed25519" % string.

Definition title : string := "An Ed25519 signature" % string.

Definition size : Z := Hacl.Sign.bytes.

Definition of_bytes_opt (s : Stdlib.Bytes.t) : option Bigstring.t :=
  if equiv_decb (String.length s) size then
    Some (Bigstring.of_bytes s)
  else
    None.

Definition to_bytes (x : Bigstring.t) : Stdlib.Bytes.t := Bigstring.to_bytes x.

Definition to_string (s : Bigstring.t) : string :=
  Stdlib.Bytes.to_string (to_bytes s).

Definition of_string_opt (s : string) : option Bigstring.t :=
  of_bytes_opt (Stdlib.Bytes.of_string s).

Definition b58check_encoding : Tezos_crypto.Base58.encoding Bigstring.t :=
  Tezos_crypto.Base58.register_encoding
    Tezos_crypto.Base58.Prefix.ed25519_signature size Bigstring.to_string
    (fun s => Some (Bigstring.of_string s)) (fun x => Data x).

Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).

Definition zero : Bigstring.t := Bigstring.make size "000" % char.

Definition sign
  (watermark : option Stdlib.Bytes.t) (sk : Hacl.Sign.key Hacl.secret)
  (msg : Stdlib.Bytes.t) : Bigstring.t :=
  let msg :=
    apply Tezos_crypto.Blake2B.to_bytes
      (apply
        (let arg := Tezos_crypto.Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  let signature := Bigstring.create Hacl.Sign.bytes in
  Hacl.Sign.sign sk (Bigstring.of_bytes msg) signature;
  signature.

Definition check
  (watermark : option Stdlib.Bytes.t) (pk : Hacl.Sign.key Hacl.public)
  (signature : Bigstring.t) (msg : Stdlib.Bytes.t) : bool :=
  let msg :=
    apply Tezos_crypto.Blake2B.to_bytes
      (apply
        (let arg := Tezos_crypto.Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  Hacl.Sign.verify pk (Bigstring.of_bytes msg) signature.

Definition generate_key (seed : option Bigstring.t) (function_parameter : unit)
  : Public_key_hash.t * (Hacl.Sign.key Hacl.public) *
    (Hacl.Sign.key Hacl.secret) :=
  match function_parameter with
  | tt =>
    match seed with
    | None =>
      match Hacl.Sign.keypair tt with
      | (pk, sk) => ((Public_key.hash pk), pk, sk)
      end
    | Some seed =>
      let seedlen := Bigstring.length seed in
      if OCaml.Stdlib.lt seedlen Hacl.Sign.skbytes then
        OCaml.Stdlib.invalid_arg
          (Stdlib.Printf.sprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Ed25519.generate_key: seed must be at least " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal
                    " bytes long (got " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))))
              "Ed25519.generate_key: seed must be at least %d bytes long (got %d)"
                % string) Hacl.Sign.skbytes seedlen)
      else
        tt;
      let sk := Bigstring.create Hacl.Sign.skbytes in
      Bigstring.blit seed 0 sk 0 Hacl.Sign.skbytes;
      let sk := Hacl.Sign.unsafe_sk_of_bytes sk in
      let pk := Hacl.Sign.neuterize sk in
      ((Public_key.hash pk), pk, sk)
    end
  end.

Definition deterministic_nonce {A : Type}
  (sk : Hacl.Sign.key A) (msg : Stdlib.Bytes.t) : Bigstring.t :=
  let msg := Bigstring.of_bytes msg in
  let key := Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest key msg.

Definition deterministic_nonce_hash {A : Type}
  (sk : Hacl.Sign.key A) (msg : Stdlib.Bytes.t) : Stdlib.Bytes.t :=
  Tezos_crypto.Blake2B.to_bytes
    (Tezos_crypto.Blake2B.hash_bytes None
      (cons (Bigstring.to_bytes (deterministic_nonce sk msg)) [])).
src/lib_crypto/ed25519.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - Ed25519 cryptography *)

include S.SIGNATURE with type watermark = Bytes.t

include S.RAW_DATA with type t := t
src/lib_crypto/ed25519.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

include
src/lib_crypto/helpers.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module MakeRaw (H : sig
  type t

  val name : string

  val of_bytes_opt : Bytes.t -> t option

  val to_string : t -> string

  val of_string_opt : string -> t option
end) =
struct
  let of_bytes_exn s =
    match H.of_bytes_opt s with
    | None ->
        Format.kasprintf invalid_arg "of_bytes_exn (%s)" H.name
    | Some pk ->
        pk

  let of_bytes s =
    match H.of_bytes_opt s with
    | None ->
        generic_error "of_bytes (%s)" H.name
    | Some pk ->
        Ok pk

  let of_string_exn s =
    match H.of_string_opt s with
    | None ->
        Format.kasprintf invalid_arg "of_string_exn (%s)" H.name
    | Some pk ->
        pk

  let of_string s =
    match H.of_string_opt s with
    | None ->
        generic_error "of_string (%s)" H.name
    | Some pk ->
        Ok pk

  let to_hex s = Hex.of_string (H.to_string s)

  let of_hex_opt s = H.of_string_opt (Hex.to_string s)

  let of_hex_exn s =
    match H.of_string_opt (Hex.to_string s) with
    | Some x ->
        x
    | None ->
        Format.kasprintf invalid_arg "of_hex_exn (%s)" H.name

  let of_hex s =
    match of_hex_opt s with
    | None ->
        generic_error "of_hex (%s)" H.name
    | Some pk ->
        ok pk
end

module MakeB58 (H : sig
  type t

  val name : string

  val b58check_encoding : t Base58.encoding
end) =
struct
  let of_b58check_opt s = Base58.simple_decode H.b58check_encoding s

  let of_b58check_exn s =
    match of_b58check_opt s with
    | Some x ->
        x
    | None ->
        Format.kasprintf Pervasives.failwith "Unexpected data (%s)" H.name

  let of_b58check s =
    match of_b58check_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error
          "Failed to read a b58check_encoding data (%s): %S"
          H.name
          s

  let to_b58check s = Base58.simple_encode H.b58check_encoding s

  let to_short_b58check s =
    String.sub
      (to_b58check s)
      0
      (10 + String.length (Base58.prefix H.b58check_encoding))
end

module MakeEncoder (H : sig
  type t

  val title : string

  val name : string

  val to_b58check : t -> string

  val to_short_b58check : t -> string

  val of_b58check : string -> t tzresult

  val of_b58check_exn : string -> t

  val of_b58check_opt : string -> t option

  val raw_encoding : t Data_encoding.t
end) =
struct
  let pp ppf t = Format.pp_print_string ppf (H.to_b58check t)

  let pp_short ppf t = Format.pp_print_string ppf (H.to_short_b58check t)

  let encoding =
    let open Data_encoding in
    splitted
      ~binary:(obj1 (req H.name H.raw_encoding))
      ~json:
        ( def H.name ~title:(H.title ^ " (Base58Check-encoded)")
        @@ conv
             H.to_b58check
             (Data_encoding.Json.wrap_error H.of_b58check_exn)
             string )

  let of_b58check = H.of_b58check

  let rpc_arg =
    RPC_arg.make
      ~name:H.name
      ~descr:(Format.asprintf "%s (Base58Check-encoded)" H.name)
      ~destruct:(fun s ->
        match H.of_b58check_opt s with
        | None ->
            Error
              (Format.asprintf
                 "failed to decode Base58Check-encoded data (%s): %S"
                 H.name
                 s)
        | Some v ->
            Ok v)
      ~construct:H.to_b58check
      ()
end

module MakeIterator (H : sig
  type t

  val encoding : t Data_encoding.t

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val hash : t -> int
end) =
struct
  module Set = struct
    include Set.Make (struct
      type t = H.t

      let compare = H.compare
    end)

    exception Found of elt

    let random_elt s =
      let n = Random.int (cardinal s) in
      try
        ignore
          ( fold
              (fun x i ->
                if i = n then raise (Found x) ;
                i + 1)
              s
              0
            : int ) ;
        assert false
      with Found x -> x

    let encoding =
      Data_encoding.conv
        elements
        (fun l -> List.fold_left (fun m x -> add x m) empty l)
        Data_encoding.(list H.encoding)
  end

  module Table = struct
    include Hashtbl.Make (struct
      type t = H.t

      let hash = H.hash

      let equal = H.equal
    end)

    let encoding arg_encoding =
      Data_encoding.conv
        (fun h -> fold (fun k v l -> (k, v) :: l) h [])
        (fun l ->
          let h = create (List.length l) in
          List.iter (fun (k, v) -> add h k v) l ;
          h)
        Data_encoding.(list (tup2 H.encoding arg_encoding))
  end

  module Map = struct
    include Map.Make (struct
      type t = H.t

      let compare = H.compare
    end)

    let encoding arg_encoding =
      Data_encoding.conv
        bindings
        (fun l -> List.fold_left (fun m (k, v) -> add k v m) empty l)
        Data_encoding.(list (tup2 H.encoding arg_encoding))
  end

  module Error_table = struct
    include Error_table.Make (Table)
  end

  module WeakRingTable = struct
    include WeakRingTable.Make (struct
      type t = H.t

      let hash = H.hash

      let equal = H.equal
    end)

    let encoding arg_encoding =
      Data_encoding.conv
        (fun h -> fold (fun k v l -> (k, v) :: l) h [])
        (fun l ->
          let h = create (List.length l) in
          List.iter (fun (k, v) -> add h k v) l ;
          h)
        Data_encoding.(list (tup2 H.encoding arg_encoding))
  end
end

module Make (H : sig
  type t

  val title : string

  val name : string

  val b58check_encoding : t Base58.encoding

  val raw_encoding : t Data_encoding.t

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val hash : t -> int
end) =
struct
  include MakeB58 (H)

  include MakeEncoder (struct
    include H

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn
  end)

  include MakeIterator (struct
    include H

    let encoding = encoding
  end)
end
src/lib_crypto/helpers.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.
src/lib_crypto/operation_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make
          (Base58)
          (struct
            let name = "Operation_hash"

            let title = "A Tezos operation ID"

            let b58check_prefix = Base58.Prefix.operation_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "o" 51

module Logging = struct
  let tag = Tag.def ~doc:title name pp
end
src/lib_crypto/operation_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Logging.
  Definition tag : Tezos_stdlib.Tag.def t :=
    Tezos_stdlib.Tag.def (Some title) name pp.
End Logging.
src/lib_crypto/operation_hash.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.HASH

module Logging : sig
  val tag : t Tag.def
end
src/lib_crypto/operation_hash.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Module Logging.
  Parameter tag : Tezos_stdlib.Tag.def t.
End Logging.
src/lib_crypto/operation_list_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make_merkle_tree
          (Base58)
          (struct
            let name = "Operation_list_hash"

            let title = "A list of operations"

            let b58check_prefix = Base58.Prefix.operation_list_hash

            let size = None
          end)
          (Operation_hash)

let () = Base58.check_encoded_prefix b58check_encoding "Lo" 52
src/lib_crypto/operation_list_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_crypto/operation_list_hash.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.MERKLE_TREE with type elt = Operation_hash.t
src/lib_crypto/operation_list_hash.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_crypto/operation_list_list_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make_merkle_tree
          (Base58)
          (struct
            let name = "Operation_list_list_hash"

            let title = "A list of list of operations"

            let b58check_prefix = Base58.Prefix.operation_list_list_hash

            let size = None
          end)
          (Operation_list_hash)

let () = Base58.check_encoded_prefix b58check_encoding "LLo" 53
src/lib_crypto/operation_list_list_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_crypto/operation_list_list_hash.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.MERKLE_TREE with type elt = Operation_list_hash.t
src/lib_crypto/operation_list_list_hash.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_crypto/p256.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Public_key_hash = struct
  include Blake2B.Make
            (Base58)
            (struct
              let name = "P256.Public_key_hash"

              let title = "A P256 public key hash"

              let b58check_prefix = Base58.Prefix.p256_public_key_hash

              let size = Some 20
            end)

  module Logging = struct
    let tag = Tag.def ~doc:title name pp
  end
end

let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz3" 36

open Uecc

module Public_key = struct
  type t = (secp256r1, public) key

  let name = "P256.Public_key"

  let title = "A P256 public key"

  let to_bigstring = to_bytes ~compress:true

  let to_bytes b = Bigstring.to_bytes (to_bigstring b)

  let to_string s = Bytes.to_string (to_bytes s)

  let of_bytes_opt b = pk_of_bytes secp256r1 (Bigstring.of_bytes b)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let size = compressed_size secp256r1

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.p256_public_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "p2pk" 55

  let hash v = Public_key_hash.hash_bytes [to_bytes v]

  include Compare.Make (struct
    type nonrec t = t

    let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

module Secret_key = struct
  type t = (secp256r1, secret) key

  let name = "P256.Secret_key"

  let title = "A P256 secret key"

  let size = sk_size secp256r1

  let of_bytes_opt buf =
    Option.map ~f:fst (sk_of_bytes secp256r1 (Bigstring.of_bytes buf))

  let to_bigstring = to_bytes ~compress:true

  let to_bytes t = Bigstring.to_bytes (to_bigstring t)

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let to_public_key = neuterize

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.p256_secret_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "p2sk" 54

  include Compare.Make (struct
    type nonrec t = t

    let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

type t = Bigstring.t

type watermark = Bytes.t

let name = "P256"

let title = "A P256 signature"

let size = pk_size secp256r1

let of_bytes_opt s =
  if Bytes.length s = size then Some (Bigstring.of_bytes s) else None

let to_bytes s = Bigstring.to_bytes s

let to_string s = Bytes.to_string (to_bytes s)

let of_string_opt s = of_bytes_opt (Bytes.of_string s)

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.p256_signature
    ~length:size
    ~to_raw:to_string
    ~of_raw:of_string_opt
    ~wrap:(fun x -> Data x)

let () = Base58.check_encoded_prefix b58check_encoding "p2sig" 98

include Helpers.MakeRaw (struct
  type nonrec t = t

  let name = name

  let of_bytes_opt = of_bytes_opt

  let of_string_opt = of_string_opt

  let to_string = to_string
end)

include Helpers.MakeB58 (struct
  type nonrec t = t

  let name = name

  let b58check_encoding = b58check_encoding
end)

include Helpers.MakeEncoder (struct
  type nonrec t = t

  let name = name

  let title = title

  let raw_encoding =
    let open Data_encoding in
    conv to_bytes of_bytes_exn (Fixed.bytes size)

  let of_b58check = of_b58check

  let of_b58check_opt = of_b58check_opt

  let of_b58check_exn = of_b58check_exn

  let to_b58check = to_b58check

  let to_short_b58check = to_short_b58check
end)

let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)

let zero = of_bytes_exn (Bytes.make size '\000')

let sign ?watermark sk msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  match sign sk (Bigstring.of_bytes msg) with
  | None ->
      (* Will never happen in practice. This can only happen in case
         of RNG error. *)
      invalid_arg "P256.sign: internal error"
  | Some signature ->
      signature

let check ?watermark public_key signature msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  verify public_key ~msg:(Bigstring.of_bytes msg) ~signature

let generate_key ?(seed = Hacl.Rand.gen 32) () =
  let seedlen = Bigstring.length seed in
  if seedlen < 32 then
    invalid_arg
      (Printf.sprintf
         "P256.generate_key: seed must be at least 32 bytes long (was %d)"
         seedlen) ;
  match sk_of_bytes secp256r1 seed with
  | None ->
      invalid_arg "P256.generate_key: invalid seed (very rare!)"
  | Some (sk, pk) ->
      let pkh = Public_key.hash pk in
      (pkh, pk, sk)

let deterministic_nonce sk msg =
  let msg = Bigstring.of_bytes msg in
  let key = Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest ~key ~msg

let deterministic_nonce_hash sk msg =
  let nonce = deterministic_nonce sk msg in
  Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce])

include Compare.Make (struct
  type nonrec t = t

  let compare = Bigstring.compare
end)
src/lib_crypto/p256.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Public_key_hash.
  Module Logging.
    Definition tag : Tezos_stdlib.Tag.def t :=
      Tezos_stdlib.Tag.def (Some title) name pp.
  End Logging.
End Public_key_hash.

Import Uecc.

Module Public_key.
  Definition t := Uecc.key Uecc.secp256r1 Uecc.public.
  
  Definition name : string := "P256.Public_key" % string.
  
  Definition title : string := "A P256 public key" % string.
  
  Definition to_bigstring
    : (Uecc.key Uecc.secp256r1 Uecc.public) -> Bigstring.t :=
    Uecc.to_bytes (Some true).
  
  Definition to_bytes (b : Uecc.key Uecc.secp256r1 Uecc.public)
    : Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring b).
  
  Definition to_string (s : Uecc.key Uecc.secp256r1 Uecc.public) : string :=
    Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_bytes_opt (b : Stdlib.Bytes.t)
    : option (Uecc.key Uecc.secp256r1 Uecc.public) :=
    Uecc.pk_of_bytes Uecc.secp256r1 (Bigstring.of_bytes b).
  
  Definition of_string_opt (s : string)
    : option (Uecc.key Uecc.secp256r1 Uecc.public) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition size : Z := Uecc.compressed_size Uecc.secp256r1.
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Tezos_crypto.Base58.register_encoding
      Tezos_crypto.Base58.Prefix.p256_public_key size to_string of_string_opt
      (fun x => Data x).
  
  Definition hash (v : Uecc.key Uecc.secp256r1 Uecc.public)
    : Public_key_hash.t :=
    Public_key_hash.hash_bytes None (cons (to_bytes v) []).
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.

Module Secret_key.
  Definition t := Uecc.key Uecc.secp256r1 Uecc.secret.
  
  Definition name : string := "P256.Secret_key" % string.
  
  Definition title : string := "A P256 secret key" % string.
  
  Definition size : Z := Uecc.sk_size Uecc.secp256r1.
  
  Definition of_bytes_opt (buf : Stdlib.Bytes.t)
    : option (Uecc.key Uecc.secp256r1 Uecc.secret) :=
    Tezos_stdlib.Option.map fst
      (Uecc.sk_of_bytes Uecc.secp256r1 (Bigstring.of_bytes buf)).
  
  Definition to_bigstring
    : (Uecc.key Uecc.secp256r1 Uecc.secret) -> Bigstring.t :=
    Uecc.to_bytes (Some true).
  
  Definition to_bytes (t : Uecc.key Uecc.secp256r1 Uecc.secret)
    : Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring t).
  
  Definition to_string (s : Uecc.key Uecc.secp256r1 Uecc.secret) : string :=
    Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string)
    : option (Uecc.key Uecc.secp256r1 Uecc.secret) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition to_public_key {A B : Type}
    : (Uecc.key A B) -> Uecc.key A Uecc.public := Uecc.neuterize.
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Tezos_crypto.Base58.register_encoding
      Tezos_crypto.Base58.Prefix.p256_secret_key size to_string of_string_opt
      (fun x => Data x).
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.

Definition t := Bigstring.t.

Definition watermark := Stdlib.Bytes.t.

Definition name : string := "P256" % string.

Definition title : string := "A P256 signature" % string.

Definition size : Z := Uecc.pk_size Uecc.secp256r1.

Definition of_bytes_opt (s : Stdlib.Bytes.t) : option Bigstring.t :=
  if equiv_decb (String.length s) size then
    Some (Bigstring.of_bytes s)
  else
    None.

Definition to_bytes (s : Bigstring.t) : Stdlib.Bytes.t := Bigstring.to_bytes s.

Definition to_string (s : Bigstring.t) : string :=
  Stdlib.Bytes.to_string (to_bytes s).

Definition of_string_opt (s : string) : option Bigstring.t :=
  of_bytes_opt (Stdlib.Bytes.of_string s).

Definition b58check_encoding : Tezos_crypto.Base58.encoding Bigstring.t :=
  Tezos_crypto.Base58.register_encoding
    Tezos_crypto.Base58.Prefix.p256_signature size to_string of_string_opt
    (fun x => Data x).

Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).

Definition zero : t := of_bytes_exn (Stdlib.Bytes.make size "000" % char).

Definition sign {A : Type}
  (watermark : option Stdlib.Bytes.t) (sk : Uecc.key A Uecc.secret)
  (msg : Stdlib.Bytes.t) : Bigstring.t :=
  let msg :=
    apply Tezos_crypto.Blake2B.to_bytes
      (apply
        (let arg := Tezos_crypto.Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  match Uecc.sign sk (Bigstring.of_bytes msg) with
  | None => OCaml.Stdlib.invalid_arg "P256.sign: internal error" % string
  | Some signature => signature
  end.

Definition check {A : Type}
  (watermark : option Stdlib.Bytes.t) (public_key : Uecc.key A Uecc.public)
  (signature : Bigstring.t) (msg : Stdlib.Bytes.t) : bool :=
  let msg :=
    apply Tezos_crypto.Blake2B.to_bytes
      (apply
        (let arg := Tezos_crypto.Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  Uecc.verify public_key (Bigstring.of_bytes msg) signature.

Definition generate_key (op_star_o_p_t_star : option Bigstring.t)
  : unit ->
    Public_key_hash.t * (Uecc.key Uecc.secp256r1 Uecc.public) *
      (Uecc.key Uecc.secp256r1 Uecc.secret) :=
  let seed :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Hacl.Rand.gen 32
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      let seedlen := Bigstring.length seed in
      if OCaml.Stdlib.lt seedlen 32 then
        OCaml.Stdlib.invalid_arg
          (Stdlib.Printf.sprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "P256.generate_key: seed must be at least 32 bytes long (was " %
                  string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))
              "P256.generate_key: seed must be at least 32 bytes long (was %d)"
                % string) seedlen)
      else
        tt;
      match Uecc.sk_of_bytes Uecc.secp256r1 seed with
      | None =>
        OCaml.Stdlib.invalid_arg
          "P256.generate_key: invalid seed (very rare!)" % string
      | Some (sk, pk) =>
        let pkh := Public_key.hash pk in
        (pkh, pk, sk)
      end
    end.

Definition deterministic_nonce
  (sk : Uecc.key Uecc.secp256r1 Uecc.secret) (msg : Stdlib.Bytes.t)
  : Bigstring.t :=
  let msg := Bigstring.of_bytes msg in
  let key := Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest key msg.

Definition deterministic_nonce_hash
  (sk : Uecc.key Uecc.secp256r1 Uecc.secret) (msg : Stdlib.Bytes.t)
  : Stdlib.Bytes.t :=
  let nonce := deterministic_nonce sk msg in
  Tezos_crypto.Blake2B.to_bytes
    (Tezos_crypto.Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])).
src/lib_crypto/p256.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - P256 cryptography *)

include S.SIGNATURE with type watermark = Bytes.t

include S.RAW_DATA with type t := t
src/lib_crypto/p256.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

include
src/lib_crypto/protocol_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make
          (Base58)
          (struct
            let name = "Protocol_hash"

            let title = "A Tezos protocol ID"

            let b58check_prefix = Base58.Prefix.protocol_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "P" 51

module Logging = struct
  let tag = Tag.def ~doc:title name pp
end
src/lib_crypto/protocol_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Logging.
  Definition tag : Tezos_stdlib.Tag.def t :=
    Tezos_stdlib.Tag.def (Some title) name pp.
End Logging.
src/lib_crypto/protocol_hash.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.HASH

module Logging : sig
  val tag : t Tag.def
end
src/lib_crypto/protocol_hash.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Module Logging.
  Parameter tag : Tezos_stdlib.Tag.def t.
End Logging.
src/lib_crypto/pvss.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** PVSS protocol, following

    see Schoenmakers, B., 1999:
    A simple publicly verifiable secret sharing scheme
    and its application to electronic voting. Lecture Notes in Computer Science,
    pp.148-164.

    see https://www.win.tue.nl/~berry/papers/crypto99.pdf

    The protocol is expressed as a functor parametrized by a cyclic group
    of prime order. Algebraic properties are enforced at the type level,
    whenever reasonably possible.

*)

module type CYCLIC_GROUP = sig
  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val name : string

  module Z_m : Znz.ZN

  val e : t

  val g1 : t

  val g2 : t

  val ( * ) : t -> t -> t

  val ( = ) : t -> t -> bool

  val pow : t -> Z_m.t -> t

  (** Binary representation *)
  val to_bits : t -> String.t

  val of_bits : String.t -> t option
end

(** PVSS construction, based on a cyclic group G of prime order *)
module type PVSS = sig
  module type ENCODED = sig
    type t

    include S.B58_DATA with type t := t

    include S.ENCODER with type t := t
  end

  module Commitment : ENCODED

  module Encrypted_share : ENCODED

  module Clear_share : ENCODED

  module Public_key : ENCODED

  module Secret_key : sig
    include ENCODED

    val to_public_key : t -> Public_key.t
  end

  type proof

  val proof_encoding : proof Data_encoding.t

  (** Lets a dealer share a secret with a set of participant by breaking it into
      pieces, encrypting it with the participant's public keys, and publishing
      these encrypted shares. Any t participants can reconstruct the secret. A
      zero-knowledge proof is produced showing that the  dealer correctly
      followed the protocol, making the protocol publicly verifiable. *)
  val dealer_shares_and_proof :
    secret:Secret_key.t ->
    t:int ->
    public_keys:Public_key.t list ->
    Encrypted_share.t list * Commitment.t list * proof

  (** Checks the proof produced by the dealer, given the encrypted shares,
      the commitment list, the proof, and the participant's public keys. *)
  val check_dealer_proof :
    Encrypted_share.t list ->
    Commitment.t list ->
    proof:proof ->
    public_keys:Public_key.t list ->
    bool

  (** Lets a participant provably decrypt an encrypted share. *)
  val reveal_share :
    Encrypted_share.t ->
    secret_key:Secret_key.t ->
    public_key:Public_key.t ->
    Clear_share.t * proof

  (** Checks that the participant honestly decrypted its share. *)
  val check_revealed_share :
    Encrypted_share.t ->
    Clear_share.t ->
    public_key:Public_key.t ->
    proof ->
    bool

  val reconstruct : Clear_share.t list -> int list -> Public_key.t
end

module MakePvss (G : CYCLIC_GROUP) : PVSS
src/lib_crypto/pvss.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

unhandled_module
src/lib_crypto/pvss_secp256k1.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Secp256k1_group

module G : Pvss.CYCLIC_GROUP = struct
  module Z_m = struct
    include Group.Scalar

    let n = Group.order

    let ( + ) = Group.Scalar.add

    let ( * ) = Group.Scalar.mul

    let ( - ) = Group.Scalar.sub

    let ( = ) = Group.Scalar.equal

    let inv = Group.Scalar.inverse
  end

  include Group

  let name = "secp256k1"

  (* This pvss algorithm assumes the public keys of the participants receiving
     shares are based on g2, so we set g2 to Group.g to match regular Secp256k1
     public keys.
  *)
  let g1 = Group.h

  let g2 = Group.g

  (* We use a multiplicative notation in the pvss module, but
     secp256k1 usually uses an additive notation. *)
  let ( * ) = Group.(( + ))

  let pow x n = Group.mul n x

  let of_bits b = try Some (Group.of_bits_exn b) with _ -> None
end

include Pvss.MakePvss (G)
src/lib_crypto/pvss_secp256k1.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_crypto.Secp256k1_group.

Module G.
  Module Z_m.
    Definition n : Z.t := Tezos_crypto.Secp256k1_group.Group.order.
    
    Definition op_plus
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
          Tezos_crypto.Secp256k1_group.Group.Scalar.t :=
      Tezos_crypto.Secp256k1_group.Group.Scalar.add.
    
    Definition op_star
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
          Tezos_crypto.Secp256k1_group.Group.Scalar.t :=
      Tezos_crypto.Secp256k1_group.Group.Scalar.mul.
    
    Definition op_minus
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
          Tezos_crypto.Secp256k1_group.Group.Scalar.t :=
      Tezos_crypto.Secp256k1_group.Group.Scalar.sub.
    
    Definition op_eq
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        Tezos_crypto.Secp256k1_group.Group.Scalar.t -> bool :=
      Tezos_crypto.Secp256k1_group.Group.Scalar.equal.
    
    Definition inv
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        option Tezos_crypto.Secp256k1_group.Group.Scalar.t :=
      Tezos_crypto.Secp256k1_group.Group.Scalar.inverse.
  End Z_m.
  
  Definition name : string := "secp256k1" % string.
  
  Definition g1 : Tezos_crypto.Secp256k1_group.Group.t :=
    Tezos_crypto.Secp256k1_group.Group.h.
  
  Definition g2 : Tezos_crypto.Secp256k1_group.Group.t :=
    Tezos_crypto.Secp256k1_group.Group.g.
  
  Definition op_star
    : Tezos_crypto.Secp256k1_group.Group.t ->
      Tezos_crypto.Secp256k1_group.Group.t ->
        Tezos_crypto.Secp256k1_group.Group.t :=
    Tezos_crypto.Secp256k1_group.Group.op_plus.
  
  Definition pow
    (x : Tezos_crypto.Secp256k1_group.Group.t)
    (n : Tezos_crypto.Secp256k1_group.Group.Scalar.t)
    : Tezos_crypto.Secp256k1_group.Group.t :=
    Tezos_crypto.Secp256k1_group.Group.mul n x.
  
  Definition of_bits (b : string)
    : option Tezos_crypto.Secp256k1_group.Group.t := try.
End G.
src/lib_crypto/pvss_secp256k1.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Pvss.PVSS
src/lib_crypto/pvss_secp256k1.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_crypto/rand.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let generate len = Bigstring.to_bytes (Hacl.Rand.gen len)

let generate_into ?(pos = 0) ?len buf =
  let buflen = Bytes.length buf in
  let len = match len with Some len -> len | None -> buflen - pos in
  if pos < 0 || len < 0 || pos + len > buflen then
    invalid_arg
      (Printf.sprintf
         "Rand.generate_into: invalid slice (pos=%d len=%d)"
         pos
         len) ;
  let rand = Hacl.Rand.gen len in
  Bigstring.blit_to_bytes rand 0 buf pos len
src/lib_crypto/rand.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition generate (len : Z) : Stdlib.Bytes.t :=
  Bigstring.to_bytes (Hacl.Rand.gen len).

Definition generate_into (op_star_o_p_t_star : option Z)
  : (option Z) -> Stdlib.Bytes.t -> unit :=
  let pos :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun len =>
    fun buf =>
      let buflen := String.length buf in
      let len :=
        match len with
        | Some len => len
        | None => Z.sub buflen pos
        end in
      if
        orb (OCaml.Stdlib.lt pos 0)
          (orb (OCaml.Stdlib.lt len 0) (OCaml.Stdlib.gt (Z.add pos len) buflen))
        then
        OCaml.Stdlib.invalid_arg
          (Stdlib.Printf.sprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Rand.generate_into: invalid slice (pos=" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal " len=" % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))))
              "Rand.generate_into: invalid slice (pos=%d len=%d)" % string) pos
            len)
      else
        tt;
      let rand := Hacl.Rand.gen len in
      Bigstring.blit_to_bytes rand 0 buf pos len.
src/lib_crypto/rand.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** [generate len] is [len] random bytes. *)
val generate : int -> Bytes.t

(** [generate_into ?pos ?len buf] writes [len] (default:
    [Bigstring.length buf]) bytes in [buf] starting at [pos] (default:
    [0]). *)
val generate_into : ?pos:int -> ?len:int -> Bytes.t -> unit
src/lib_crypto/rand.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter generate : Z -> Stdlib.Bytes.t.

Parameter generate_into : (option Z) -> (option Z) -> Stdlib.Bytes.t -> unit.
src/lib_crypto/s.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

(** {2 Hash Types} *)

(** The signature of an abstract hash type, as produced by functor
    {!Make_Blake2B}. The {!t} type is abstracted for separating the
    various kinds of hashes in the system at typing time. Each type is
    equipped with functions to use it as is of as keys in the database
    or in memory sets and maps. *)

module type MINIMAL_HASH = sig
  type t

  val name : string

  val title : string

  val pp : Format.formatter -> t -> unit

  val pp_short : Format.formatter -> t -> unit

  include Compare.S with type t := t

  val hash_bytes : ?key:Bytes.t -> Bytes.t list -> t

  val hash_string : ?key:string -> string list -> t

  val zero : t
end

module type RAW_DATA = sig
  type t

  val size : int (* in bytes *)

  val to_hex : t -> Hex.t

  val of_hex : Hex.t -> t tzresult

  val of_hex_opt : Hex.t -> t option

  val of_hex_exn : Hex.t -> t

  val to_string : t -> string

  val of_string : string -> t tzresult

  val of_string_opt : string -> t option

  val of_string_exn : string -> t

  val to_bytes : t -> Bytes.t

  val of_bytes : Bytes.t -> t tzresult

  val of_bytes_opt : Bytes.t -> t option

  val of_bytes_exn : Bytes.t -> t
end

module type B58_DATA = sig
  type t

  val to_b58check : t -> string

  val to_short_b58check : t -> string

  val of_b58check : string -> t tzresult

  val of_b58check_exn : string -> t

  val of_b58check_opt : string -> t option

  type Base58.data += Data of t

  val b58check_encoding : t Base58.encoding
end

module type ENCODER = sig
  type t

  val encoding : t Data_encoding.t

  val rpc_arg : t RPC_arg.t
end

module type PVSS = sig
  type proof

  module Clear_share : sig
    type t
  end

  module Commitment : sig
    type t
  end

  module Encrypted_share : sig
    type t
  end

  module Public_key : sig
    type t

    include B58_DATA with type t := t

    include ENCODER with type t := t
  end
end

module type INDEXES = sig
  type t

  val hash : t -> int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  val of_path_exn : string list -> t

  val prefix_path : string -> string list

  val path_length : int

  module Set : sig
    include Set.S with type elt = t

    val random_elt : t -> elt

    val encoding : t Data_encoding.t
  end

  module Map : sig
    include Map.S with type key = t

    val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
  end

  module Table : sig
    include Hashtbl.S with type key = t

    val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
  end

  module Error_table : sig
    include Error_table.S with type key = t
  end

  module WeakRingTable : sig
    include WeakRingTable.S with type key = t

    val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
  end
end

module type HASH = sig
  include MINIMAL_HASH

  include RAW_DATA with type t := t

  include B58_DATA with type t := t

  include ENCODER with type t := t

  include INDEXES with type t := t
end

module type MERKLE_TREE = sig
  type elt

  val elt_bytes : elt -> Bytes.t

  include HASH

  val compute : elt list -> t

  val empty : t

  type path = Left of path * t | Right of t * path | Op

  val path_encoding : path Data_encoding.t

  val bounded_path_encoding : ?max_length:int -> unit -> path Data_encoding.t

  val compute_path : elt list -> int -> path

  val check_path : path -> elt -> t * int
end

module type SIGNATURE = sig
  module Public_key_hash : sig
    type t

    val pp : Format.formatter -> t -> unit

    val pp_short : Format.formatter -> t -> unit

    include Compare.S with type t := t

    include RAW_DATA with type t := t

    include B58_DATA with type t := t

    include ENCODER with type t := t

    include INDEXES with type t := t

    val zero : t

    module Logging : sig
      val tag : t Tag.def
    end
  end

  module Public_key : sig
    type t

    val pp : Format.formatter -> t -> unit

    include Compare.S with type t := t

    include B58_DATA with type t := t

    include ENCODER with type t := t

    val hash : t -> Public_key_hash.t
  end

  module Secret_key : sig
    type t

    val pp : Format.formatter -> t -> unit

    include Compare.S with type t := t

    include B58_DATA with type t := t

    include ENCODER with type t := t

    val to_public_key : t -> Public_key.t
  end

  type t

  val pp : Format.formatter -> t -> unit

  include Compare.S with type t := t

  include B58_DATA with type t := t

  include ENCODER with type t := t

  val zero : t

  type watermark

  val sign : ?watermark:watermark -> Secret_key.t -> Bytes.t -> t

  val check : ?watermark:watermark -> Public_key.t -> t -> Bytes.t -> bool

  val generate_key :
    ?seed:Bigstring.t ->
    unit ->
    Public_key_hash.t * Public_key.t * Secret_key.t

  val deterministic_nonce : Secret_key.t -> Bytes.t -> Bigstring.t

  val deterministic_nonce_hash : Secret_key.t -> Bytes.t -> Bytes.t
end
src/lib_crypto/s.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Module MINIMAL_HASH.
  Record signature {t : Type} := {
    t := t;
    name : string;
    title : string;
    pp : Stdlib.Format.formatter -> t -> unit;
    pp_short : Stdlib.Format.formatter -> t -> unit;
    include;
    hash_bytes : (option Stdlib.Bytes.t) -> (list Stdlib.Bytes.t) -> t;
    hash_string : (option string) -> (list string) -> t;
    zero : t;
  }.
  Arguments signature : clear implicits.
End MINIMAL_HASH.

Module RAW_DATA.
  Record signature {t : Type} := {
    t := t;
    size : Z;
    to_hex : t -> Hex.t;
    of_hex : Hex.t -> Tezos_error_monad.Error_monad.tzresult t;
    of_hex_opt : Hex.t -> option t;
    of_hex_exn : Hex.t -> t;
    to_string : t -> string;
    of_string : string -> Tezos_error_monad.Error_monad.tzresult t;
    of_string_opt : string -> option t;
    of_string_exn : string -> t;
    to_bytes : t -> Stdlib.Bytes.t;
    of_bytes : Stdlib.Bytes.t -> Tezos_error_monad.Error_monad.tzresult t;
    of_bytes_opt : Stdlib.Bytes.t -> option t;
    of_bytes_exn : Stdlib.Bytes.t -> t;
  }.
  Arguments signature : clear implicits.
End RAW_DATA.

Module B58_DATA.
  Record signature {t : Type} := {
    t := t;
    to_b58check : t -> string;
    to_short_b58check : t -> string;
    of_b58check : string -> Tezos_error_monad.Error_monad.tzresult t;
    of_b58check_exn : string -> t;
    of_b58check_opt : string -> option t;
    extensible_type;
    b58check_encoding : Tezos_crypto.Base58.encoding t;
  }.
  Arguments signature : clear implicits.
End B58_DATA.

Module ENCODER.
  Record signature {t : Type} := {
    t := t;
    encoding : Tezos_data_encoding.Data_encoding.t t;
    rpc_arg : Tezos_rpc.RPC_arg.t t;
  }.
  Arguments signature : clear implicits.
End ENCODER.

Module PVSS.
  Record signature {proof Clear_share_t Commitment_t Encrypted_share_t
    Public_key_t : Type} := {
    proof := proof;
    Clear_share : signature;
    Commitment : signature;
    Encrypted_share : signature;
    Public_key : signature;
  }.
  Arguments signature : clear implicits.
End PVSS.

Module INDEXES.
  Record signature {t Set_t Map_t Table_t Error_table_t WeakRingTable_t : Type}
    := {
    t := t;
    hash : t -> Z;
    to_path : t -> (list string) -> list string;
    of_path : (list string) -> option t;
    of_path_exn : (list string) -> t;
    prefix_path : string -> list string;
    path_length : Z;
    Set : signature;
    Map : signature;
    Table : signature;
    Error_table : signature;
    WeakRingTable : signature;
  }.
  Arguments signature : clear implicits.
End INDEXES.

Module HASH.
  Record signature {t Set_t Map_t Table_t Error_table_t WeakRingTable_t : Type}
    := {
    include;
    include;
    include;
    include;
    include;
  }.
  Arguments signature : clear implicits.
End HASH.

Module MERKLE_TREE.
  Record signature {elt t Set_t Map_t Table_t Error_table_t WeakRingTable_t path
    : Type} := {
    elt := elt;
    elt_bytes : elt -> Stdlib.Bytes.t;
    include;
    compute : (list elt) -> t;
    empty : t;
    path := path;
    path_encoding : Tezos_data_encoding.Data_encoding.t path;
    bounded_path_encoding : (option Z) ->
      unit -> Tezos_data_encoding.Data_encoding.t path;
    compute_path : (list elt) -> Z -> path;
    check_path : path -> elt -> t * Z;
  }.
  Arguments signature : clear implicits.
End MERKLE_TREE.

Module SIGNATURE.
  Record signature {Public_key_hash_t Public_key_hash_Set_t
    Public_key_hash_Map_t Public_key_hash_Table_t Public_key_hash_Error_table_t
    Public_key_hash_WeakRingTable_t Public_key_t Secret_key_t t watermark :
    Type} := {
    Public_key_hash : signature;
    Public_key : signature;
    Secret_key : signature;
    t := t;
    pp : Stdlib.Format.formatter -> t -> unit;
    include;
    include;
    include;
    zero : t;
    watermark := watermark;
    sign : (option watermark) -> Secret_key.t -> Stdlib.Bytes.t -> t;
    check : (option watermark) -> Public_key.t -> t -> Stdlib.Bytes.t -> bool;
    generate_key : (option Bigstring.t) ->
      unit -> Public_key_hash.t * Public_key.t * Secret_key.t;
    deterministic_nonce : Secret_key.t -> Stdlib.Bytes.t -> Bigstring.t;
    deterministic_nonce_hash : Secret_key.t -> Stdlib.Bytes.t -> Stdlib.Bytes.t;
  }.
  Arguments signature : clear implicits.
End SIGNATURE.
src/lib_crypto/secp256k1.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Public_key_hash = struct
  include Blake2B.Make
            (Base58)
            (struct
              let name = "Secp256k1.Public_key_hash"

              let title = "A Secp256k1 public key hash"

              let b58check_prefix = Base58.Prefix.secp256k1_public_key_hash

              let size = Some 20
            end)

  module Logging = struct
    let tag = Tag.def ~doc:title name pp
  end
end

let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz2" 36

open Libsecp256k1.External

let context =
  let ctx = Context.create () in
  match Context.randomize ctx (Hacl.Rand.gen 32) with
  | false ->
      failwith "Secp256k1 context randomization failed. Aborting."
  | true ->
      ctx

module Public_key = struct
  type t = Key.public Key.t

  let name = "Secp256k1.Public_key"

  let title = "A Secp256k1 public key"

  let to_bytes pk = Bigstring.to_bytes (Key.to_bytes context pk)

  let of_bytes_opt s =
    try Some (Key.read_pk_exn context (Bigstring.of_bytes s)) with _ -> None

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let size = Key.compressed_pk_bytes

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.secp256k1_public_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "sppk" 55

  let hash v = Public_key_hash.hash_bytes [to_bytes v]

  include Compare.Make (struct
    type nonrec t = t

    let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

module Secret_key = struct
  type t = Key.secret Key.t

  let name = "Secp256k1.Secret_key"

  let title = "A Secp256k1 secret key"

  let size = Key.secret_bytes

  let of_bytes_opt s =
    match Key.read_sk context (Bigstring.of_bytes s) with
    | Ok x ->
        Some x
    | _ ->
        None

  let to_bigstring = Key.to_bytes context

  let to_bytes x = Bigstring.to_bytes (to_bigstring x)

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let to_public_key key = Key.neuterize_exn context key

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.secp256k1_secret_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "spsk" 54

  include Compare.Make (struct
    type nonrec t = t

    let compare a b = Bigstring.compare (Key.buffer a) (Key.buffer b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

type t = Sign.plain Sign.t

type watermark = Bytes.t

let name = "Secp256k1"

let title = "A Secp256k1 signature"

let size = Sign.plain_bytes

let of_bytes_opt s =
  match Sign.read context (Bigstring.of_bytes s) with
  | Ok s ->
      Some s
  | Error _ ->
      None

let to_bytes t = Bigstring.to_bytes (Sign.to_bytes ~der:false context t)

let to_string s = Bytes.to_string (to_bytes s)

let of_string_opt s = of_bytes_opt (Bytes.of_string s)

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.secp256k1_signature
    ~length:size
    ~to_raw:to_string
    ~of_raw:of_string_opt
    ~wrap:(fun x -> Data x)

let () = Base58.check_encoded_prefix b58check_encoding "spsig1" 99

include Compare.Make (struct
  type nonrec t = t

  let compare a b = Bigstring.compare (Sign.buffer a) (Sign.buffer b)
end)

include Helpers.MakeRaw (struct
  type nonrec t = t

  let name = name

  let of_bytes_opt = of_bytes_opt

  let of_string_opt = of_string_opt

  let to_string = to_string
end)

include Helpers.MakeB58 (struct
  type nonrec t = t

  let name = name

  let b58check_encoding = b58check_encoding
end)

include Helpers.MakeEncoder (struct
  type nonrec t = t

  let name = name

  let title = title

  let raw_encoding =
    let open Data_encoding in
    conv to_bytes of_bytes_exn (Fixed.bytes size)

  let of_b58check = of_b58check

  let of_b58check_opt = of_b58check_opt

  let of_b58check_exn = of_b58check_exn

  let to_b58check = to_b58check

  let to_short_b58check = to_short_b58check
end)

let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)

let zero = of_bytes_exn (Bytes.make size '\000')

let sign ?watermark sk msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  Sign.sign_exn context ~sk (Bigstring.of_bytes msg)

let check ?watermark public_key signature msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  Sign.verify_exn
    context
    ~pk:public_key
    ~msg:(Bigstring.of_bytes msg)
    ~signature

let generate_key ?(seed = Hacl.Rand.gen 32) () =
  let sk = Key.read_sk_exn context seed in
  let pk = Key.neuterize_exn context sk in
  let pkh = Public_key.hash pk in
  (pkh, pk, sk)

let deterministic_nonce sk msg =
  let msg = Bigstring.of_bytes msg in
  let key = Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest ~key ~msg

let deterministic_nonce_hash sk msg =
  let nonce = deterministic_nonce sk msg in
  Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce])
src/lib_crypto/secp256k1.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Public_key_hash.
  Module Logging.
    Definition tag : Tezos_stdlib.Tag.def t :=
      Tezos_stdlib.Tag.def (Some title) name pp.
  End Logging.
End Public_key_hash.

Import Libsecp256k1.External.

Definition context : Libsecp256k1.External.Context.t :=
  let ctx := Libsecp256k1.External.Context.create None None tt in
  match Libsecp256k1.External.Context.randomize ctx (Hacl.Rand.gen 32) with
  | false =>
    OCaml.Stdlib.failwith
      "Secp256k1 context randomization failed. Aborting." % string
  | true => ctx
  end.

Module Public_key.
  Definition t := Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public.
  
  Definition name : string := "Secp256k1.Public_key" % string.
  
  Definition title : string := "A Secp256k1 public key" % string.
  
  Definition to_bytes {A : Type} (pk : Libsecp256k1.External.Key.t A)
    : Stdlib.Bytes.t :=
    Bigstring.to_bytes (Libsecp256k1.External.Key.to_bytes None context pk).
  
  Definition of_bytes_opt (s : Stdlib.Bytes.t)
    : option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
    try.
  
  Definition to_string {A : Type} (s : Libsecp256k1.External.Key.t A)
    : string := Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string)
    : option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition size : Z := Libsecp256k1.External.Key.compressed_pk_bytes.
  
  Definition b58check_encoding
    : Tezos_crypto.Base58.encoding
      (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
    Tezos_crypto.Base58.register_encoding
      Tezos_crypto.Base58.Prefix.secp256k1_public_key size to_string
      of_string_opt (fun x => Data x).
  
  Definition hash {A : Type} (v : Libsecp256k1.External.Key.t A)
    : Public_key_hash.t :=
    Public_key_hash.hash_bytes None (cons (to_bytes v) []).
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.

Module Secret_key.
  Definition t := Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret.
  
  Definition name : string := "Secp256k1.Secret_key" % string.
  
  Definition title : string := "A Secp256k1 secret key" % string.
  
  Definition size : Z := Libsecp256k1.External.Key.secret_bytes.
  
  Definition of_bytes_opt (s : Stdlib.Bytes.t)
    : option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
    match Libsecp256k1.External.Key.read_sk context (Bigstring.of_bytes s) with
    | inl x => Some x
    | _ => None
    end.
  
  Definition to_bigstring
    : (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) ->
      Bigstring.t := Libsecp256k1.External.Key.to_bytes None context.
  
  Definition to_bytes
    (x : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
    : Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring x).
  
  Definition to_string
    (s : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
    : string := Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string)
    : option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition to_public_key {A : Type} (key : Libsecp256k1.External.Key.t A)
    : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public :=
    Libsecp256k1.External.Key.neuterize_exn context key.
  
  Definition b58check_encoding
    : Tezos_crypto.Base58.encoding
      (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
    Tezos_crypto.Base58.register_encoding
      Tezos_crypto.Base58.Prefix.secp256k1_secret_key size to_string
      of_string_opt (fun x => Data x).
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.

Definition t := Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain.

Definition watermark := Stdlib.Bytes.t.

Definition name : string := "Secp256k1" % string.

Definition title : string := "A Secp256k1 signature" % string.

Definition size : Z := Libsecp256k1.External.Sign.plain_bytes.

Definition of_bytes_opt (s : Stdlib.Bytes.t)
  : option (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
  match Libsecp256k1.External.Sign.read context (Bigstring.of_bytes s) with
  | inl s => Some s
  | inr _ => None
  end.

Definition to_bytes {A : Type} (t : Libsecp256k1.External.Sign.t A)
  : Stdlib.Bytes.t :=
  Bigstring.to_bytes
    (Libsecp256k1.External.Sign.to_bytes (Some false) context t).

Definition to_string {A : Type} (s : Libsecp256k1.External.Sign.t A) : string :=
  Stdlib.Bytes.to_string (to_bytes s).

Definition of_string_opt (s : string)
  : option (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
  of_bytes_opt (Stdlib.Bytes.of_string s).

Definition b58check_encoding
  : Tezos_crypto.Base58.encoding
    (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
  Tezos_crypto.Base58.register_encoding
    Tezos_crypto.Base58.Prefix.secp256k1_signature size to_string of_string_opt
    (fun x => Data x).

Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).

Definition zero : t := of_bytes_exn (Stdlib.Bytes.make size "000" % char).

Definition sign
  (watermark : option Stdlib.Bytes.t)
  (sk : Libsecp256k1__External.Key.t Libsecp256k1__External.Key.secret)
  (msg : Stdlib.Bytes.t)
  : Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain :=
  let msg :=
    apply Tezos_crypto.Blake2B.to_bytes
      (apply
        (let arg := Tezos_crypto.Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  Libsecp256k1.External.Sign.sign_exn context sk (Bigstring.of_bytes msg).

Definition check {A : Type}
  (watermark : option Stdlib.Bytes.t)
  (public_key : Libsecp256k1__External.Key.t Libsecp256k1__External.Key.public)
  (signature : Libsecp256k1.External.Sign.t A) (msg : Stdlib.Bytes.t) : bool :=
  let msg :=
    apply Tezos_crypto.Blake2B.to_bytes
      (apply
        (let arg := Tezos_crypto.Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  Libsecp256k1.External.Sign.verify_exn context public_key
    (Bigstring.of_bytes msg) signature.

Definition generate_key (op_star_o_p_t_star : option Bigstring.t)
  : unit ->
    Public_key_hash.t *
      (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) *
      (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
  let seed :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Hacl.Rand.gen 32
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      let sk := Libsecp256k1.External.Key.read_sk_exn context seed in
      let pk := Libsecp256k1.External.Key.neuterize_exn context sk in
      let pkh := Public_key.hash pk in
      (pkh, pk, sk)
    end.

Definition deterministic_nonce
  (sk : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
  (msg : Stdlib.Bytes.t) : Bigstring.t :=
  let msg := Bigstring.of_bytes msg in
  let key := Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest key msg.

Definition deterministic_nonce_hash
  (sk : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
  (msg : Stdlib.Bytes.t) : Stdlib.Bytes.t :=
  let nonce := deterministic_nonce sk msg in
  Tezos_crypto.Blake2B.to_bytes
    (Tezos_crypto.Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])).
src/lib_crypto/secp256k1.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - Secp256k1 cryptography *)

include S.SIGNATURE with type watermark = Bytes.t

include S.RAW_DATA with type t := t
src/lib_crypto/secp256k1.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

include
src/lib_crypto/secp256k1_group.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Sp = Libsecp256k1.Internal

module type SCALAR_SIG = sig
  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val zero : t

  val one : t

  val of_Z : Z.t -> t

  val to_Z : t -> Z.t

  val of_int : int -> t

  val add : t -> t -> t

  val mul : t -> t -> t

  val negate : t -> t

  val sub : t -> t -> t

  val of_bits_exn : string -> t

  val to_bits : t -> string

  val inverse : t -> t option

  val pow : t -> Z.t -> t

  val equal : t -> t -> bool
end

module Group : sig
  val order : Z.t

  module Scalar : SCALAR_SIG

  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val e : t

  val g : t

  val h : t

  val of_coordinates : x:Z.t -> y:Z.t -> t

  val of_bits_exn : string -> t

  val to_bits : t -> string

  val mul : Scalar.t -> t -> t

  val ( + ) : t -> t -> t

  val ( - ) : t -> t -> t

  val ( = ) : t -> t -> bool
end = struct
  let order =
    Z.of_string_base
      16
      "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141"

  let string_rev s =
    let len = String.length s in
    String.init len (fun i -> s.[len - 1 - i])

  let b32_of_Z z =
    let cs = Cstruct.create 32 in
    let bits = Z.to_bits z in
    let length = min 32 (String.length bits) in
    let bits = String.sub bits 0 length in
    let bits = string_rev bits in
    Cstruct.blit_from_string bits 0 cs (32 - length) length ;
    cs

  let z_of_b32 b = b |> Cstruct.to_string |> string_rev |> Z.of_bits

  module Scalar : SCALAR_SIG with type t = Sp.Scalar.t = struct
    type t = Sp.Scalar.t

    let zero = Sp.Scalar.zero ()

    let one = Sp.Scalar.one ()

    let equal x y = Sp.Scalar.equal x y

    let of_Z z =
      let z = Z.erem z order in
      let r = Sp.Scalar.const () in
      let cs = b32_of_Z z in
      let _ = Sp.Scalar.set_b32 r cs in
      r

    let to_Z s =
      let cs = Cstruct.create 32 in
      Sp.Scalar.get_b32 cs s ; cs |> z_of_b32

    let of_int i = i |> Z.of_int |> of_Z

    let pow t n = Z.powm (to_Z t) n order |> of_Z

    let add x y =
      let r = Sp.Scalar.const () in
      let _ = Sp.Scalar.add r x y in
      r

    let mul x y =
      let r = Sp.Scalar.const () in
      Sp.Scalar.mul r x y ; r

    let negate x =
      let r = Sp.Scalar.const () in
      Sp.Scalar.negate r x ; r

    let sub x y = add x (negate y)

    let of_bits_exn bits =
      let r = Sp.Scalar.const () in
      (* trim to 32 bytes *)
      let cs = Cstruct.create 32 in
      Cstruct.blit_from_string bits 0 cs 0 (min (String.length bits) 32) ;
      (* ignore overflow condition, it's always 0 based on the c-code *)
      let _ = Sp.Scalar.set_b32 r cs in
      r

    (* TODO, check that we are less than the order *)

    let to_bits x =
      let c = Cstruct.create 32 in
      Sp.Scalar.get_b32 c x ; Cstruct.to_string c

    let inverse x =
      if x = zero then None
      else
        let r = Sp.Scalar.const () in
        Sp.Scalar.inverse r x ; Some r

    type Base58.data += Data of t

    let b58check_encoding =
      Base58.register_encoding
        ~prefix:Base58.Prefix.secp256k1_scalar
        ~length:32
        ~to_raw:to_bits
        ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
        ~wrap:(fun x -> Data x)

    let title = "Secp256k1_group.Scalar"

    let name = "Anscalar for the secp256k1 group"

    include Helpers.MakeB58 (struct
      type nonrec t = t

      let name = name

      let b58check_encoding = b58check_encoding
    end)

    include Helpers.MakeEncoder (struct
      type nonrec t = t

      let name = name

      let title = title

      let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)

      let to_b58check = to_b58check

      let to_short_b58check = to_short_b58check

      let of_b58check = of_b58check

      let of_b58check_opt = of_b58check_opt

      let of_b58check_exn = of_b58check_exn
    end)
  end

  type t = Sp.Group.Jacobian.t

  (* type ge = Sp.Group.ge *)

  let field_of_Z z =
    let fe = Sp.Field.const () in
    let cs = b32_of_Z z in
    let _ = Sp.Field.set_b32 fe cs in
    fe

  let group_of_jacobian j =
    let r = Sp.Group.of_fields () in
    Sp.Group.Jacobian.get_ge r j ;
    r

  let jacobian_of_group g =
    let j = Sp.Group.Jacobian.of_fields () in
    Sp.Group.Jacobian.set_ge j g ;
    j

  let of_coordinates ~x ~y =
    Sp.Group.of_fields ~x:(field_of_Z x) ~y:(field_of_Z y) ()
    |> jacobian_of_group

  let e = Sp.Group.Jacobian.of_fields ~infinity:true ()

  let g =
    let gx =
      Z.of_string
        "55066263022277343669578718895168534326250603453777594175500187360389116729240"
    and gy =
      Z.of_string
        "32670510020758816978083085130507043184471273380659243275938904335757337482424"
    in
    of_coordinates ~x:gx ~y:gy

  (* To obtain the second generator, take the sha256 hash of the decimal representation of g1_y
       python -c "import hashlib;print int(hashlib.sha256('32670510020758816978083085130507043184471273380659243275938904335757337482424').hexdigest(),16)"
  *)
  let h =
    let hx =
      Z.of_string
        "54850469061264194188802857211425616972714231399857248865148107587305936171824"
    and hy =
      Z.of_string
        "6558914719042992724977242403721980463337660510165027616783569279181206179101"
    in
    of_coordinates ~x:hx ~y:hy

  let ( + ) x y =
    let r = Sp.Group.Jacobian.of_fields () in
    Sp.Group.Jacobian.add_var r x y ;
    r

  let ( - ) x y =
    let neg_y = Sp.Group.Jacobian.of_fields () in
    Sp.Group.Jacobian.neg neg_y y ;
    x + neg_y

  let ( = ) x y = Sp.Group.Jacobian.is_infinity (x - y)

  let mul s g =
    let r = Sp.Group.Jacobian.of_fields () in
    Sp.Group.Jacobian.mul r (group_of_jacobian g) s ;
    r

  let to_bits j =
    let x = group_of_jacobian j and buf = Cstruct.create 33 in
    let cs = Sp.Group.to_pubkey ~compress:true buf x in
    Cstruct.to_string cs

  let of_bits_exn bits =
    let buf = Cstruct.of_string bits and x = Sp.Group.of_fields () in
    Sp.Group.from_pubkey x buf ; x |> jacobian_of_group

  module Encoding = struct
    type Base58.data += Data of t

    let title = "Secp256k1_group.Group"

    let name = "An element of secp256k1"

    let b58check_encoding =
      Base58.register_encoding
        ~prefix:Base58.Prefix.secp256k1_element
        ~length:33
        ~to_raw:to_bits
        ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
        ~wrap:(fun x -> Data x)

    include Helpers.MakeB58 (struct
      type nonrec t = t

      let name = name

      let b58check_encoding = b58check_encoding
    end)

    include Helpers.MakeEncoder (struct
      type nonrec t = t

      let name = name

      let title = title

      let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)

      let to_b58check = to_b58check

      let to_short_b58check = to_short_b58check

      let of_b58check = of_b58check

      let of_b58check_opt = of_b58check_opt

      let of_b58check_exn = of_b58check_exn
    end)
  end

  include Encoding
end
src/lib_crypto/secp256k1_group.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module SCALAR_SIG.
  Record signature {t : Type} := {
    t := t;
    include;
    include;
    zero : t;
    one : t;
    of_Z : Z.t -> t;
    to_Z : t -> Z.t;
    of_int : Z -> t;
    add : t -> t -> t;
    mul : t -> t -> t;
    negate : t -> t;
    sub : t -> t -> t;
    of_bits_exn : string -> t;
    to_bits : t -> string;
    inverse : t -> option t;
    pow : t -> Z.t -> t;
    equal : t -> t -> bool;
  }.
  Arguments signature : clear implicits.
End SCALAR_SIG.

Module Group.
  Definition order : Z.t :=
    Z.of_string_base 16
      "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141" %
        string.
  
  Definition string_rev (s : string) : string :=
    let len := OCaml.String.length s in
    Stdlib.String.init len
      (fun i => Stdlib.String.get s (Z.sub (Z.sub len 1) i)).
  
  Definition b32_of_Z (z : Z.t) : Cstruct.t :=
    let cs := Cstruct.create 32 in
    let bits := Z.to_bits z in
    let length := OCaml.Stdlib.min 32 (OCaml.String.length bits) in
    let bits := Stdlib.String.sub bits 0 length in
    let bits := string_rev bits in
    Cstruct.blit_from_string bits 0 cs (Z.sub 32 length) length;
    cs.
  
  Definition z_of_b32 (b : Cstruct.t) : Z.t :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply b Cstruct.to_string) string_rev) Z.of_bits.
  
  Definition t := Sp.Group.Jacobian.t.
  
  Definition field_of_Z (z : Z.t) : Sp.Field.t :=
    let fe := Sp.Field.const None None None None None None None None tt in
    let cs := b32_of_Z z in
    match Sp.Field.set_b32 fe cs with
    | _ => fe
    end.
  
  Definition group_of_jacobian (j : Sp.Group.Jacobian.t) : Sp.Group.t :=
    let r := Sp.Group.of_fields None None None tt in
    Sp.Group.Jacobian.get_ge r j;
    r.
  
  Definition jacobian_of_group (g : Libsecp256k1__Internal.Group.ge)
    : Sp.Group.Jacobian.t :=
    let j := Sp.Group.Jacobian.of_fields None None None None tt in
    Sp.Group.Jacobian.set_ge j g;
    j.
  
  Definition of_coordinates (x : Z.t) (y : Z.t) : Sp.Group.Jacobian.t :=
    OCaml.Stdlib.reverse_apply
      (Sp.Group.of_fields (Some (field_of_Z x)) (Some (field_of_Z y)) None tt)
      jacobian_of_group.
  
  Definition e : Sp.Group.Jacobian.t :=
    Sp.Group.Jacobian.of_fields None None None (Some true) tt.
  
  Definition g : Sp.Group.Jacobian.t :=
    let gx : Z.t :=
      Z.of_string
        "55066263022277343669578718895168534326250603453777594175500187360389116729240"
          % string
    with gy : Z.t :=
      Z.of_string
        "32670510020758816978083085130507043184471273380659243275938904335757337482424"
          % string in
    of_coordinates gx gy.
  
  Definition h : Sp.Group.Jacobian.t :=
    let hx : Z.t :=
      Z.of_string
        "54850469061264194188802857211425616972714231399857248865148107587305936171824"
          % string
    with hy : Z.t :=
      Z.of_string
        "6558914719042992724977242403721980463337660510165027616783569279181206179101"
          % string in
    of_coordinates hx hy.
  
  Definition op_plus (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t)
    : Sp.Group.Jacobian.t :=
    let r := Sp.Group.Jacobian.of_fields None None None None tt in
    Sp.Group.Jacobian.add_var None r x y;
    r.
  
  Definition op_minus (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t)
    : Sp.Group.Jacobian.t :=
    let neg_y := Sp.Group.Jacobian.of_fields None None None None tt in
    Sp.Group.Jacobian.neg neg_y y;
    op_plus x neg_y.
  
  Definition op_eq (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t) : bool :=
    Sp.Group.Jacobian.is_infinity (op_minus x y).
  
  Definition mul (s : Libsecp256k1__Internal.Scalar.t) (g : Sp.Group.Jacobian.t)
    : Sp.Group.Jacobian.t :=
    let r := Sp.Group.Jacobian.of_fields None None None None tt in
    Sp.Group.Jacobian.mul r (group_of_jacobian g) s;
    r.
  
  Definition to_bits (j : Sp.Group.Jacobian.t) : string :=
    let x : Sp.Group.t :=
      group_of_jacobian j
    with buf : Cstruct.t :=
      Cstruct.create 33 in
    let cs := Sp.Group.to_pubkey (Some true) buf x in
    Cstruct.to_string cs.
  
  Definition of_bits_exn (bits : string) : Sp.Group.Jacobian.t :=
    let buf : Cstruct.t :=
      Cstruct.of_string None None None bits
    with x : Sp.Group.t :=
      Sp.Group.of_fields None None None tt in
    Sp.Group.from_pubkey x buf;
    OCaml.Stdlib.reverse_apply x jacobian_of_group.
  
  Module Encoding.
    Definition title : string := "Secp256k1_group.Group" % string.
    
    Definition name : string := "An element of secp256k1" % string.
    
    Definition b58check_encoding
      : Tezos_crypto.Base58.encoding Sp.Group.Jacobian.t :=
      Tezos_crypto.Base58.register_encoding
        Tezos_crypto.Base58.Prefix.secp256k1_element 33 to_bits (fun s => try)
        (fun x => Data x).
  End Encoding.
End Group.
src/lib_crypto/secp256k1_group.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Type for the group of integers modulo the order of the curve ℤ/pℤ *)
module type SCALAR_SIG = sig
  (** Element of the scalar group *)
  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val zero : t

  val one : t

  val of_Z : Z.t -> t

  val to_Z : t -> Z.t

  val of_int : int -> t

  val add : t -> t -> t

  val mul : t -> t -> t

  val negate : t -> t

  val sub : t -> t -> t

  val of_bits_exn : string -> t

  val to_bits : t -> string

  val inverse : t -> t option

  (** Modular exponentiation*)
  val pow : t -> Z.t -> t

  val equal : t -> t -> bool
end

module Group : sig
  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val order : Z.t

  module Scalar : SCALAR_SIG

  val e : t

  val g : t

  val h : t

  val of_coordinates : x:Z.t -> y:Z.t -> t

  val of_bits_exn : string -> t

  val to_bits : t -> string

  val mul : Scalar.t -> t -> t

  val ( + ) : t -> t -> t

  val ( - ) : t -> t -> t

  val ( = ) : t -> t -> bool
end
src/lib_crypto/secp256k1_group.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

Module Group.
  Parameter t : Type.
  
  include
  
  include
  
  Parameter order : Z.t.
  
  unhandled_module
  
  Parameter e : t.
  
  Parameter g : t.
  
  Parameter h : t.
  
  Parameter of_coordinates : Z.t -> Z.t -> t.
  
  Parameter of_bits_exn : string -> t.
  
  Parameter to_bits : t -> string.
  
  Parameter mul : Scalar.(SCALAR_SIG.t) -> t -> t.
  
  Parameter op_plus : t -> t -> t.
  
  Parameter op_minus : t -> t -> t.
  
  Parameter op_eq : t -> t -> bool.
End Group.
src/lib_crypto/signature.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

type public_key_hash =
  | Ed25519 of Ed25519.Public_key_hash.t
  | Secp256k1 of Secp256k1.Public_key_hash.t
  | P256 of P256.Public_key_hash.t

type public_key =
  | Ed25519 of Ed25519.Public_key.t
  | Secp256k1 of Secp256k1.Public_key.t
  | P256 of P256.Public_key.t

type secret_key =
  | Ed25519 of Ed25519.Secret_key.t
  | Secp256k1 of Secp256k1.Secret_key.t
  | P256 of P256.Secret_key.t

type watermark =
  | Block_header of Chain_id.t
  | Endorsement of Chain_id.t
  | Generic_operation
  | Custom of Bytes.t

module Public_key_hash = struct
  type t = public_key_hash =
    | Ed25519 of Ed25519.Public_key_hash.t
    | Secp256k1 of Secp256k1.Public_key_hash.t
    | P256 of P256.Public_key_hash.t

  let name = "Signature.Public_key_hash"

  let title = "A Ed25519, Secp256k1, or P256 public key hash"

  type Base58.data += Data of t (* unused *)

  let b58check_encoding =
    (* unused *)
    Base58.register_encoding
      ~prefix:"\255\255"
      ~length:2
      ~to_raw:(fun _ -> assert false)
      ~of_raw:(fun _ -> assert false)
      ~wrap:(fun x -> Data x)

  let raw_encoding =
    let open Data_encoding in
    def "public_key_hash" ~description:title
    @@ union
         [ case
             (Tag 0)
             Ed25519.Public_key_hash.encoding
             ~title:"Ed25519"
             (function Ed25519 x -> Some x | _ -> None)
             (function x -> Ed25519 x);
           case
             (Tag 1)
             Secp256k1.Public_key_hash.encoding
             ~title:"Secp256k1"
             (function Secp256k1 x -> Some x | _ -> None)
             (function x -> Secp256k1 x);
           case
             (Tag 2)
             ~title:"P256"
             P256.Public_key_hash.encoding
             (function P256 x -> Some x | _ -> None)
             (function x -> P256 x) ]

  let to_bytes s = Data_encoding.Binary.to_bytes_exn raw_encoding s

  let of_bytes_opt s = Data_encoding.Binary.of_bytes raw_encoding s

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let size = 1 + Ed25519.size

  let zero = Ed25519 Ed25519.Public_key_hash.zero

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  let of_b58check_opt s =
    match Base58.decode s with
    | Some (Ed25519.Public_key_hash.Data pkh) ->
        Some (Ed25519 pkh)
    | Some (Secp256k1.Public_key_hash.Data pkh) ->
        Some (Secp256k1 pkh)
    | Some (P256.Public_key_hash.Data pkh) ->
        Some (P256 pkh)
    | _ ->
        None

  let of_b58check_exn s =
    match of_b58check_opt s with
    | Some x ->
        x
    | None ->
        Format.kasprintf Pervasives.failwith "Unexpected data (%s)" name

  let of_b58check s =
    match of_b58check_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error "Failed to read a b58check_encoding data (%s): %S" name s

  let to_b58check = function
    | Ed25519 pkh ->
        Ed25519.Public_key_hash.to_b58check pkh
    | Secp256k1 pkh ->
        Secp256k1.Public_key_hash.to_b58check pkh
    | P256 pkh ->
        P256.Public_key_hash.to_b58check pkh

  let to_short_b58check = function
    | Ed25519 pkh ->
        Ed25519.Public_key_hash.to_short_b58check pkh
    | Secp256k1 pkh ->
        Secp256k1.Public_key_hash.to_short_b58check pkh
    | P256 pkh ->
        P256.Public_key_hash.to_short_b58check pkh

  let to_path key l =
    match key with
    | Ed25519 h ->
        "ed25519" :: Ed25519.Public_key_hash.to_path h l
    | Secp256k1 h ->
        "secp256k1" :: Secp256k1.Public_key_hash.to_path h l
    | P256 h ->
        "p256" :: P256.Public_key_hash.to_path h l

  let of_path = function
    | "ed25519" :: q -> (
      match Ed25519.Public_key_hash.of_path q with
      | Some pkh ->
          Some (Ed25519 pkh)
      | None ->
          None )
    | "secp256k1" :: q -> (
      match Secp256k1.Public_key_hash.of_path q with
      | Some pkh ->
          Some (Secp256k1 pkh)
      | None ->
          None )
    | "p256" :: q -> (
      match P256.Public_key_hash.of_path q with
      | Some pkh ->
          Some (P256 pkh)
      | None ->
          None )
    | _ ->
        assert false

  (* FIXME classification des erreurs *)

  let of_path_exn = function
    | "ed25519" :: q ->
        Ed25519 (Ed25519.Public_key_hash.of_path_exn q)
    | "secp256k1" :: q ->
        Secp256k1 (Secp256k1.Public_key_hash.of_path_exn q)
    | "p256" :: q ->
        P256 (P256.Public_key_hash.of_path_exn q)
    | _ ->
        assert false

  (* FIXME classification des erreurs *)

  let path_length =
    let l1 = Ed25519.Public_key_hash.path_length
    and l2 = Secp256k1.Public_key_hash.path_length
    and l3 = P256.Public_key_hash.path_length in
    assert (Compare.Int.(l1 = l2)) ;
    assert (Compare.Int.(l1 = l3)) ;
    1 + l1

  let prefix_path _ = assert false (* unused *)

  let hash = Hashtbl.hash

  include Compare.Make (struct
    type nonrec t = t

    let compare a b =
      match (a, b) with
      | (Ed25519 x, Ed25519 y) ->
          Ed25519.Public_key_hash.compare x y
      | (Secp256k1 x, Secp256k1 y) ->
          Secp256k1.Public_key_hash.compare x y
      | (P256 x, P256 y) ->
          P256.Public_key_hash.compare x y
      | _ ->
          Pervasives.compare a b
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding = raw_encoding

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  include Helpers.MakeIterator (struct
    type nonrec t = t

    let hash = hash

    let compare = compare

    let equal = equal

    let encoding = encoding
  end)

  let rpc_arg =
    RPC_arg.like
      rpc_arg
      ~descr:"A Secp256k1 of a Ed25519 public key hash (Base58Check-encoded)"
      "pkh"

  module Logging = struct
    let tag = Tag.def ~doc:title name pp
  end
end

module Public_key = struct
  type t = public_key =
    | Ed25519 of Ed25519.Public_key.t
    | Secp256k1 of Secp256k1.Public_key.t
    | P256 of P256.Public_key.t

  let name = "Signature.Public_key"

  let title = "A Ed25519, Secp256k1, or P256 public key"

  let hash pk =
    match pk with
    | Ed25519 pk ->
        Public_key_hash.Ed25519 (Ed25519.Public_key.hash pk)
    | Secp256k1 pk ->
        Public_key_hash.Secp256k1 (Secp256k1.Public_key.hash pk)
    | P256 pk ->
        Public_key_hash.P256 (P256.Public_key.hash pk)

  include Compare.Make (struct
    type nonrec t = t

    let compare a b =
      match (a, b) with
      | (Ed25519 x, Ed25519 y) ->
          Ed25519.Public_key.compare x y
      | (Secp256k1 x, Secp256k1 y) ->
          Secp256k1.Public_key.compare x y
      | (P256 x, P256 y) ->
          P256.Public_key.compare x y
      | _ ->
          Pervasives.compare a b
  end)

  type Base58.data += Data of t (* unused *)

  let b58check_encoding =
    (* unused *)
    Base58.register_encoding
      ~prefix:"\255\255"
      ~length:2
      ~to_raw:(fun _ -> assert false)
      ~of_raw:(fun _ -> assert false)
      ~wrap:(fun x -> Data x)

  let of_b58check_opt s =
    match Base58.decode s with
    | Some (Ed25519.Public_key.Data public_key) ->
        Some (Ed25519 public_key)
    | Some (Secp256k1.Public_key.Data public_key) ->
        Some (Secp256k1 public_key)
    | Some (P256.Public_key.Data public_key) ->
        Some (P256 public_key)
    | _ ->
        None

  let of_b58check_exn s =
    match of_b58check_opt s with
    | Some x ->
        x
    | None ->
        Format.kasprintf Pervasives.failwith "Unexpected data (%s)" name

  let of_b58check s =
    match of_b58check_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error "Failed to read a b58check_encoding data (%s): %S" name s

  let to_b58check = function
    | Ed25519 pk ->
        Ed25519.Public_key.to_b58check pk
    | Secp256k1 pk ->
        Secp256k1.Public_key.to_b58check pk
    | P256 pk ->
        P256.Public_key.to_b58check pk

  let to_short_b58check = function
    | Ed25519 pk ->
        Ed25519.Public_key.to_short_b58check pk
    | Secp256k1 pk ->
        Secp256k1.Public_key.to_short_b58check pk
    | P256 pk ->
        P256.Public_key.to_short_b58check pk

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      def "public_key" ~description:title
      @@ union
           [ case
               (Tag 0)
               Ed25519.Public_key.encoding
               ~title:"Ed25519"
               (function Ed25519 x -> Some x | _ -> None)
               (function x -> Ed25519 x);
             case
               (Tag 1)
               Secp256k1.Public_key.encoding
               ~title:"Secp256k1"
               (function Secp256k1 x -> Some x | _ -> None)
               (function x -> Secp256k1 x);
             case
               ~title:"P256"
               (Tag 2)
               P256.Public_key.encoding
               (function P256 x -> Some x | _ -> None)
               (function x -> P256 x) ]

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

module Secret_key = struct
  type t = secret_key =
    | Ed25519 of Ed25519.Secret_key.t
    | Secp256k1 of Secp256k1.Secret_key.t
    | P256 of P256.Secret_key.t

  let name = "Signature.Secret_key"

  let title = "A Ed25519, Secp256k1 or P256 secret key"

  let to_public_key = function
    | Ed25519 sk ->
        Public_key.Ed25519 (Ed25519.Secret_key.to_public_key sk)
    | Secp256k1 sk ->
        Public_key.Secp256k1 (Secp256k1.Secret_key.to_public_key sk)
    | P256 sk ->
        Public_key.P256 (P256.Secret_key.to_public_key sk)

  include Compare.Make (struct
    type nonrec t = t

    let compare a b =
      match (a, b) with
      | (Ed25519 x, Ed25519 y) ->
          Ed25519.Secret_key.compare x y
      | (Secp256k1 x, Secp256k1 y) ->
          Secp256k1.Secret_key.compare x y
      | (P256 x, P256 y) ->
          P256.Secret_key.compare x y
      | _ ->
          Pervasives.compare a b
  end)

  type Base58.data += Data of t (* unused *)

  let b58check_encoding =
    (* unused *)
    Base58.register_encoding
      ~prefix:"\255\255"
      ~length:2
      ~to_raw:(fun _ -> assert false)
      ~of_raw:(fun _ -> assert false)
      ~wrap:(fun x -> Data x)

  let of_b58check_opt b =
    match Base58.decode b with
    | Some (Ed25519.Secret_key.Data sk) ->
        Some (Ed25519 sk)
    | Some (Secp256k1.Secret_key.Data sk) ->
        Some (Secp256k1 sk)
    | Some (P256.Secret_key.Data sk) ->
        Some (P256 sk)
    | _ ->
        None

  let of_b58check_exn s =
    match of_b58check_opt s with
    | Some x ->
        x
    | None ->
        Format.kasprintf Pervasives.failwith "Unexpected data (%s)" name

  let of_b58check s =
    match of_b58check_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error "Failed to read a b58check_encoding data (%s): %S" name s

  let to_b58check = function
    | Ed25519 sk ->
        Ed25519.Secret_key.to_b58check sk
    | Secp256k1 sk ->
        Secp256k1.Secret_key.to_b58check sk
    | P256 sk ->
        P256.Secret_key.to_b58check sk

  let to_short_b58check = function
    | Ed25519 sk ->
        Ed25519.Secret_key.to_short_b58check sk
    | Secp256k1 sk ->
        Secp256k1.Secret_key.to_short_b58check sk
    | P256 sk ->
        P256.Secret_key.to_short_b58check sk

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      def "secret_key" ~description:title
      @@ union
           [ case
               (Tag 0)
               Ed25519.Secret_key.encoding
               ~title:"Ed25519"
               (function Ed25519 x -> Some x | _ -> None)
               (function x -> Ed25519 x);
             case
               (Tag 1)
               Secp256k1.Secret_key.encoding
               ~title:"Secp256k1"
               (function Secp256k1 x -> Some x | _ -> None)
               (function x -> Secp256k1 x);
             case
               (Tag 2)
               ~title:"P256"
               P256.Secret_key.encoding
               (function P256 x -> Some x | _ -> None)
               (function x -> P256 x) ]

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

type t =
  | Ed25519 of Ed25519.t
  | Secp256k1 of Secp256k1.t
  | P256 of P256.t
  | Unknown of Bytes.t

let name = "Signature"

let title = "A Ed25519, Secp256k1 or P256 signature"

let size =
  assert (Ed25519.size = Secp256k1.size && Secp256k1.size = P256.size) ;
  Ed25519.size

let to_bytes = function
  | Ed25519 b ->
      Ed25519.to_bytes b
  | Secp256k1 b ->
      Secp256k1.to_bytes b
  | P256 b ->
      P256.to_bytes b
  | Unknown b ->
      b

let of_bytes_opt s = if Bytes.length s = size then Some (Unknown s) else None

let to_string s = Bytes.to_string (to_bytes s)

let of_string_opt s = of_bytes_opt (Bytes.of_string s)

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.generic_signature
    ~length:Ed25519.size
    ~to_raw:to_string
    ~of_raw:of_string_opt
    ~wrap:(fun x -> Data x)

let () = Base58.check_encoded_prefix b58check_encoding "sig" 96

include Helpers.MakeRaw (struct
  type nonrec t = t

  let name = name

  let of_bytes_opt = of_bytes_opt

  let of_string_opt = of_string_opt

  let to_string = to_string
end)

include Compare.Make (struct
  type nonrec t = t

  let compare a b =
    let a = to_bytes a and b = to_bytes b in
    Bytes.compare a b
end)

let of_b58check_opt s =
  if TzString.has_prefix ~prefix:Ed25519.b58check_encoding.encoded_prefix s
  then Option.map (Ed25519.of_b58check_opt s) ~f:(fun x -> Ed25519 x)
  else if
    TzString.has_prefix ~prefix:Secp256k1.b58check_encoding.encoded_prefix s
  then Option.map (Secp256k1.of_b58check_opt s) ~f:(fun x -> Secp256k1 x)
  else if TzString.has_prefix ~prefix:P256.b58check_encoding.encoded_prefix s
  then Option.map (P256.of_b58check_opt s) ~f:(fun x -> P256 x)
  else Base58.simple_decode b58check_encoding s

let of_b58check_exn s =
  match of_b58check_opt s with
  | Some x ->
      x
  | None ->
      Format.kasprintf Pervasives.failwith "Unexpected data (%s)" name

let of_b58check s =
  match of_b58check_opt s with
  | Some x ->
      Ok x
  | None ->
      generic_error "Failed to read a b58check_encoding data (%s): %S" name s

let to_b58check = function
  | Ed25519 b ->
      Ed25519.to_b58check b
  | Secp256k1 b ->
      Secp256k1.to_b58check b
  | P256 b ->
      P256.to_b58check b
  | Unknown b ->
      Base58.simple_encode b58check_encoding (Unknown b)

let to_short_b58check = function
  | Ed25519 b ->
      Ed25519.to_short_b58check b
  | Secp256k1 b ->
      Secp256k1.to_short_b58check b
  | P256 b ->
      P256.to_short_b58check b
  | Unknown b ->
      Base58.simple_encode b58check_encoding (Unknown b)

include Helpers.MakeEncoder (struct
  type nonrec t = t

  let name = name

  let title = title

  let raw_encoding =
    Data_encoding.conv to_bytes of_bytes_exn (Data_encoding.Fixed.bytes size)

  let of_b58check = of_b58check

  let of_b58check_opt = of_b58check_opt

  let of_b58check_exn = of_b58check_exn

  let to_b58check = to_b58check

  let to_short_b58check = to_short_b58check
end)

let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)

let of_ed25519 s = Ed25519 s

let of_secp256k1 s = Secp256k1 s

let of_p256 s = P256 s

let zero = of_ed25519 Ed25519.zero

let bytes_of_watermark = function
  | Block_header chain_id ->
      Bytes.cat (Bytes.of_string "\x01") (Chain_id.to_bytes chain_id)
  | Endorsement chain_id ->
      Bytes.cat (Bytes.of_string "\x02") (Chain_id.to_bytes chain_id)
  | Generic_operation ->
      Bytes.of_string "\x03"
  | Custom bytes ->
      bytes

let pp_watermark ppf =
  let open Format in
  function
  | Block_header chain_id ->
      fprintf ppf "Block-header: %a" Chain_id.pp chain_id
  | Endorsement chain_id ->
      fprintf ppf "Endorsement: %a" Chain_id.pp chain_id
  | Generic_operation ->
      pp_print_string ppf "Generic-operation"
  | Custom bytes ->
      let hexed = Hex.of_bytes bytes |> Hex.show in
      fprintf
        ppf
        "Custom: 0x%s"
        (try String.sub hexed 0 10 ^ "..." with _ -> hexed)

let sign ?watermark secret_key message =
  let watermark = Option.map ~f:bytes_of_watermark watermark in
  match secret_key with
  | Secret_key.Ed25519 sk ->
      of_ed25519 (Ed25519.sign ?watermark sk message)
  | Secp256k1 sk ->
      of_secp256k1 (Secp256k1.sign ?watermark sk message)
  | P256 sk ->
      of_p256 (P256.sign ?watermark sk message)

let check ?watermark public_key signature message =
  let watermark = Option.map ~f:bytes_of_watermark watermark in
  match (public_key, signature) with
  | (Public_key.Ed25519 pk, Unknown signature) -> (
    match Ed25519.of_bytes_opt signature with
    | Some s ->
        Ed25519.check ?watermark pk s message
    | None ->
        false )
  | (Public_key.Secp256k1 pk, Unknown signature) -> (
    match Secp256k1.of_bytes_opt signature with
    | Some s ->
        Secp256k1.check ?watermark pk s message
    | None ->
        false )
  | (Public_key.P256 pk, Unknown signature) -> (
    match P256.of_bytes_opt signature with
    | Some s ->
        P256.check ?watermark pk s message
    | None ->
        false )
  | (Public_key.Ed25519 pk, Ed25519 signature) ->
      Ed25519.check ?watermark pk signature message
  | (Public_key.Secp256k1 pk, Secp256k1 signature) ->
      Secp256k1.check ?watermark pk signature message
  | (Public_key.P256 pk, P256 signature) ->
      P256.check ?watermark pk signature message
  | _ ->
      false

let append ?watermark sk msg =
  Bytes.cat msg (to_bytes (sign ?watermark sk msg))

let concat msg signature = Bytes.cat msg (to_bytes signature)

type algo = Ed25519 | Secp256k1 | P256

let generate_key ?(algo = Ed25519) ?seed () =
  match algo with
  | Ed25519 ->
      let (pkh, pk, sk) = Ed25519.generate_key ?seed () in
      ( Public_key_hash.Ed25519 pkh,
        Public_key.Ed25519 pk,
        Secret_key.Ed25519 sk )
  | Secp256k1 ->
      let (pkh, pk, sk) = Secp256k1.generate_key ?seed () in
      ( Public_key_hash.Secp256k1 pkh,
        Public_key.Secp256k1 pk,
        Secret_key.Secp256k1 sk )
  | P256 ->
      let (pkh, pk, sk) = P256.generate_key ?seed () in
      (Public_key_hash.P256 pkh, Public_key.P256 pk, Secret_key.P256 sk)

let deterministic_nonce sk msg =
  match sk with
  | Secret_key.Ed25519 sk ->
      Ed25519.deterministic_nonce sk msg
  | Secret_key.Secp256k1 sk ->
      Secp256k1.deterministic_nonce sk msg
  | Secret_key.P256 sk ->
      P256.deterministic_nonce sk msg

let deterministic_nonce_hash sk msg =
  match sk with
  | Secret_key.Ed25519 sk ->
      Ed25519.deterministic_nonce_hash sk msg
  | Secret_key.Secp256k1 sk ->
      Secp256k1.deterministic_nonce_hash sk msg
  | Secret_key.P256 sk ->
      P256.deterministic_nonce_hash sk msg
src/lib_crypto/signature.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Inductive public_key_hash : Type :=
| Ed25519 : Tezos_crypto.Ed25519.Public_key_hash.t -> public_key_hash
| Secp256k1 : Tezos_crypto.Secp256k1.Public_key_hash.t -> public_key_hash
| P256 : Tezos_crypto.P256.Public_key_hash.t -> public_key_hash.

Inductive public_key : Type :=
| Ed25519 : Tezos_crypto.Ed25519.Public_key.t -> public_key
| Secp256k1 : Tezos_crypto.Secp256k1.Public_key.t -> public_key
| P256 : Tezos_crypto.P256.Public_key.t -> public_key.

Inductive secret_key : Type :=
| Ed25519 : Tezos_crypto.Ed25519.Secret_key.t -> secret_key
| Secp256k1 : Tezos_crypto.Secp256k1.Secret_key.t -> secret_key
| P256 : Tezos_crypto.P256.Secret_key.t -> secret_key.

Inductive watermark : Type :=
| Block_header : Tezos_crypto.Chain_id.t -> watermark
| Endorsement : Tezos_crypto.Chain_id.t -> watermark
| Generic_operation : watermark
| Custom : Stdlib.Bytes.t -> watermark.

Module Public_key_hash.
  Inductive t : Type :=
  | Ed25519 : Tezos_crypto.Ed25519.Public_key_hash.t -> t
  | Secp256k1 : Tezos_crypto.Secp256k1.Public_key_hash.t -> t
  | P256 : Tezos_crypto.P256.Public_key_hash.t -> t.
  
  Definition name : string := "Signature.Public_key_hash" % string.
  
  Definition title : string :=
    "A Ed25519, Secp256k1, or P256 public key hash" % string.
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Tezos_crypto.Base58.register_encoding "ÿÿ" % string 2
      (fun function_parameter =>
        match function_parameter with
        | _ => false
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ => false
        end) (fun x => Data x).
  
  Definition raw_encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg :=
        Tezos_data_encoding.Data_encoding.def "public_key_hash" % string
          expected_argument (Some title) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Data_encoding.union None
        (cons
          (Tezos_data_encoding.Data_encoding.case "Ed25519" % string None
            (Tag 0) Tezos_crypto.Ed25519.Public_key_hash.encoding
            (fun function_parameter =>
              match function_parameter with
              | Ed25519 x => Some x
              | _ => None
              end) (fun x => Ed25519 x))
          (cons
            (Tezos_data_encoding.Data_encoding.case "Secp256k1" % string None
              (Tag 1) Tezos_crypto.Secp256k1.Public_key_hash.encoding
              (fun function_parameter =>
                match function_parameter with
                | Secp256k1 x => Some x
                | _ => None
                end) (fun x => Secp256k1 x))
            (cons
              (Tezos_data_encoding.Data_encoding.case "P256" % string None
                (Tag 2) Tezos_crypto.P256.Public_key_hash.encoding
                (fun function_parameter =>
                  match function_parameter with
                  | P256 x => Some x
                  | _ => None
                  end) (fun x => P256 x)) [])))).
  
  Definition to_bytes (s : t) : Stdlib.Bytes.t :=
    Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn raw_encoding s.
  
  Definition of_bytes_opt (s : Stdlib.Bytes.t) : option t :=
    Tezos_data_encoding.Data_encoding.Binary.of_bytes raw_encoding s.
  
  Definition to_string (s : t) : string := Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string) : option t :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition size : Z := Z.add 1 Tezos_crypto.Ed25519.size.
  
  Definition zero : t := Ed25519 Tezos_crypto.Ed25519.Public_key_hash.zero.
  
  Definition of_b58check_opt (s : string) : option t :=
    match Tezos_crypto.Base58.decode None s with
    | Some (Ed25519.Public_key_hash.Data pkh) => Some (Ed25519 pkh)
    | Some (Secp256k1.Public_key_hash.Data pkh) => Some (Secp256k1 pkh)
    | Some (P256.Public_key_hash.Data pkh) => Some (P256 pkh)
    | _ => None
    end.
  
  Definition of_b58check_exn (s : string) : t :=
    match of_b58check_opt s with
    | Some x => x
    | None =>
      Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Unexpected data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))
          "Unexpected data (%s)" % string) name
    end.
  
  Definition of_b58check (s : string)
    : sum t (list Tezos_error_monad.Error_monad.error) :=
    match of_b58check_opt s with
    | Some x => inl x
    | None =>
      Tezos_error_monad.Error_monad.generic_error
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Failed to read a b58check_encoding data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "): " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "Failed to read a b58check_encoding data (%s): %S" % string) name s
    end.
  
  Definition to_b58check (function_parameter : t) : string :=
    match function_parameter with
    | Ed25519 pkh => Tezos_crypto.Ed25519.Public_key_hash.to_b58check pkh
    | Secp256k1 pkh => Tezos_crypto.Secp256k1.Public_key_hash.to_b58check pkh
    | P256 pkh => Tezos_crypto.P256.Public_key_hash.to_b58check pkh
    end.
  
  Definition to_short_b58check (function_parameter : t) : string :=
    match function_parameter with
    | Ed25519 pkh => Tezos_crypto.Ed25519.Public_key_hash.to_short_b58check pkh
    | Secp256k1 pkh =>
      Tezos_crypto.Secp256k1.Public_key_hash.to_short_b58check pkh
    | P256 pkh => Tezos_crypto.P256.Public_key_hash.to_short_b58check pkh
    end.
  
  Definition to_path (key : t) (l : list string) : list string :=
    match key with
    | Ed25519 h =>
      cons "ed25519" % string (Tezos_crypto.Ed25519.Public_key_hash.to_path h l)
    | Secp256k1 h =>
      cons "secp256k1" % string
        (Tezos_crypto.Secp256k1.Public_key_hash.to_path h l)
    | P256 h =>
      cons "p256" % string (Tezos_crypto.P256.Public_key_hash.to_path h l)
    end.
  
  Definition of_path (function_parameter : list string) : option t :=
    match function_parameter with
    | cons "ed25519" % string q =>
      match Tezos_crypto.Ed25519.Public_key_hash.of_path q with
      | Some pkh => Some (Ed25519 pkh)
      | None => None
      end
    | cons "secp256k1" % string q =>
      match Tezos_crypto.Secp256k1.Public_key_hash.of_path q with
      | Some pkh => Some (Secp256k1 pkh)
      | None => None
      end
    | cons "p256" % string q =>
      match Tezos_crypto.P256.Public_key_hash.of_path q with
      | Some pkh => Some (P256 pkh)
      | None => None
      end
    | _ => false
    end.
  
  Definition of_path_exn (function_parameter : list string) : t :=
    match function_parameter with
    | cons "ed25519" % string q =>
      Ed25519 (Tezos_crypto.Ed25519.Public_key_hash.of_path_exn q)
    | cons "secp256k1" % string q =>
      Secp256k1 (Tezos_crypto.Secp256k1.Public_key_hash.of_path_exn q)
    | cons "p256" % string q =>
      P256 (Tezos_crypto.P256.Public_key_hash.of_path_exn q)
    | _ => false
    end.
  
  Definition path_length : Z :=
    let l1 : Z :=
      Tezos_crypto.Ed25519.Public_key_hash.path_length
    with l2 : Z :=
      Tezos_crypto.Secp256k1.Public_key_hash.path_length
    with l3 : Z :=
      Tezos_crypto.P256.Public_key_hash.path_length in
    Tezos_stdlib.Compare.Int.op_eq l1 l2;
    Tezos_stdlib.Compare.Int.op_eq l1 l3;
    Z.add 1 l1.
  
  Definition prefix_path {A B : Type} (function_parameter : A) : B :=
    match function_parameter with
    | _ => false
    end.
  
  Definition hash {A : Type} : A -> Z := Stdlib.Hashtbl.hash.
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
    Tezos_rpc.RPC_arg.like rpc_arg
      (Some
        "A Secp256k1 of a Ed25519 public key hash (Base58Check-encoded)" %
          string) "pkh" % string.
  
  Module Logging.
    Definition tag : Tezos_stdlib.Tag.def t :=
      Tezos_stdlib.Tag.def (Some title) name pp.
  End Logging.
End Public_key_hash.

Module Public_key.
  Inductive t : Type :=
  | Ed25519 : Tezos_crypto.Ed25519.Public_key.t -> t
  | Secp256k1 : Tezos_crypto.Secp256k1.Public_key.t -> t
  | P256 : Tezos_crypto.P256.Public_key.t -> t.
  
  Definition name : string := "Signature.Public_key" % string.
  
  Definition title : string :=
    "A Ed25519, Secp256k1, or P256 public key" % string.
  
  Definition hash (pk : t) : Public_key_hash.t :=
    match pk with
    | Ed25519 pk =>
      Public_key_hash.Ed25519 (Tezos_crypto.Ed25519.Public_key.hash pk)
    | Secp256k1 pk =>
      Public_key_hash.Secp256k1 (Tezos_crypto.Secp256k1.Public_key.hash pk)
    | P256 pk => Public_key_hash.P256 (Tezos_crypto.P256.Public_key.hash pk)
    end.
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Tezos_crypto.Base58.register_encoding "ÿÿ" % string 2
      (fun function_parameter =>
        match function_parameter with
        | _ => false
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ => false
        end) (fun x => Data x).
  
  Definition of_b58check_opt (s : string) : option t :=
    match Tezos_crypto.Base58.decode None s with
    | Some (Ed25519.Public_key.Data public_key) => Some (Ed25519 public_key)
    | Some (Secp256k1.Public_key.Data public_key) => Some (Secp256k1 public_key)
    | Some (P256.Public_key.Data public_key) => Some (P256 public_key)
    | _ => None
    end.
  
  Definition of_b58check_exn (s : string) : t :=
    match of_b58check_opt s with
    | Some x => x
    | None =>
      Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Unexpected data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))
          "Unexpected data (%s)" % string) name
    end.
  
  Definition of_b58check (s : string)
    : sum t (list Tezos_error_monad.Error_monad.error) :=
    match of_b58check_opt s with
    | Some x => inl x
    | None =>
      Tezos_error_monad.Error_monad.generic_error
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Failed to read a b58check_encoding data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "): " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "Failed to read a b58check_encoding data (%s): %S" % string) name s
    end.
  
  Definition to_b58check (function_parameter : t) : string :=
    match function_parameter with
    | Ed25519 pk => Tezos_crypto.Ed25519.Public_key.to_b58check pk
    | Secp256k1 pk => Tezos_crypto.Secp256k1.Public_key.to_b58check pk
    | P256 pk => Tezos_crypto.P256.Public_key.to_b58check pk
    end.
  
  Definition to_short_b58check (function_parameter : t) : string :=
    match function_parameter with
    | Ed25519 pk => Tezos_crypto.Ed25519.Public_key.to_short_b58check pk
    | Secp256k1 pk => Tezos_crypto.Secp256k1.Public_key.to_short_b58check pk
    | P256 pk => Tezos_crypto.P256.Public_key.to_short_b58check pk
    end.
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.

Module Secret_key.
  Inductive t : Type :=
  | Ed25519 : Tezos_crypto.Ed25519.Secret_key.t -> t
  | Secp256k1 : Tezos_crypto.Secp256k1.Secret_key.t -> t
  | P256 : Tezos_crypto.P256.Secret_key.t -> t.
  
  Definition name : string := "Signature.Secret_key" % string.
  
  Definition title : string :=
    "A Ed25519, Secp256k1 or P256 secret key" % string.
  
  Definition to_public_key (function_parameter : t) : Public_key.t :=
    match function_parameter with
    | Ed25519 sk =>
      Public_key.Ed25519 (Tezos_crypto.Ed25519.Secret_key.to_public_key sk)
    | Secp256k1 sk =>
      Public_key.Secp256k1 (Tezos_crypto.Secp256k1.Secret_key.to_public_key sk)
    | P256 sk => Public_key.P256 (Tezos_crypto.P256.Secret_key.to_public_key sk)
    end.
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Tezos_crypto.Base58.register_encoding "ÿÿ" % string 2
      (fun function_parameter =>
        match function_parameter with
        | _ => false
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ => false
        end) (fun x => Data x).
  
  Definition of_b58check_opt (b : string) : option t :=
    match Tezos_crypto.Base58.decode None b with
    | Some (Ed25519.Secret_key.Data sk) => Some (Ed25519 sk)
    | Some (Secp256k1.Secret_key.Data sk) => Some (Secp256k1 sk)
    | Some (P256.Secret_key.Data sk) => Some (P256 sk)
    | _ => None
    end.
  
  Definition of_b58check_exn (s : string) : t :=
    match of_b58check_opt s with
    | Some x => x
    | None =>
      Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Unexpected data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))
          "Unexpected data (%s)" % string) name
    end.
  
  Definition of_b58check (s : string)
    : sum t (list Tezos_error_monad.Error_monad.error) :=
    match of_b58check_opt s with
    | Some x => inl x
    | None =>
      Tezos_error_monad.Error_monad.generic_error
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Failed to read a b58check_encoding data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "): " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "Failed to read a b58check_encoding data (%s): %S" % string) name s
    end.
  
  Definition to_b58check (function_parameter : t) : string :=
    match function_parameter with
    | Ed25519 sk => Tezos_crypto.Ed25519.Secret_key.to_b58check sk
    | Secp256k1 sk => Tezos_crypto.Secp256k1.Secret_key.to_b58check sk
    | P256 sk => Tezos_crypto.P256.Secret_key.to_b58check sk
    end.
  
  Definition to_short_b58check (function_parameter : t) : string :=
    match function_parameter with
    | Ed25519 sk => Tezos_crypto.Ed25519.Secret_key.to_short_b58check sk
    | Secp256k1 sk => Tezos_crypto.Secp256k1.Secret_key.to_short_b58check sk
    | P256 sk => Tezos_crypto.P256.Secret_key.to_short_b58check sk
    end.
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.

Inductive t : Type :=
| Ed25519 : Tezos_crypto.Ed25519.t -> t
| Secp256k1 : Tezos_crypto.Secp256k1.t -> t
| P256 : Tezos_crypto.P256.t -> t
| Unknown : Stdlib.Bytes.t -> t.

Definition name : string := "Signature" % string.

Definition title : string := "A Ed25519, Secp256k1 or P256 signature" % string.

Definition size : Z :=
  andb (equiv_decb Tezos_crypto.Ed25519.size Tezos_crypto.Secp256k1.size)
    (equiv_decb Tezos_crypto.Secp256k1.size Tezos_crypto.P256.size);
  Tezos_crypto.Ed25519.size.

Definition to_bytes (function_parameter : t) : Stdlib.Bytes.t :=
  match function_parameter with
  | Ed25519 b => Tezos_crypto.Ed25519.to_bytes b
  | Secp256k1 b => Tezos_crypto.Secp256k1.to_bytes b
  | P256 b => Tezos_crypto.P256.to_bytes b
  | Unknown b => b
  end.

Definition of_bytes_opt (s : Stdlib.Bytes.t) : option t :=
  if equiv_decb (String.length s) size then
    Some (Unknown s)
  else
    None.

Definition to_string (s : t) : string := Stdlib.Bytes.to_string (to_bytes s).

Definition of_string_opt (s : string) : option t :=
  of_bytes_opt (Stdlib.Bytes.of_string s).

Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
  Tezos_crypto.Base58.register_encoding
    Tezos_crypto.Base58.Prefix.generic_signature Tezos_crypto.Ed25519.size
    to_string of_string_opt (fun x => Data x).

Definition of_b58check_opt (s : string) : option t :=
  if
    Tezos_stdlib.TzString.has_prefix
      (encoded_prefix Tezos_crypto.Ed25519.b58check_encoding) s then
    Tezos_stdlib.Option.map (fun x => Ed25519 x)
      (Tezos_crypto.Ed25519.of_b58check_opt s)
  else
    if
      Tezos_stdlib.TzString.has_prefix
        (encoded_prefix Tezos_crypto.Secp256k1.b58check_encoding) s then
      Tezos_stdlib.Option.map (fun x => Secp256k1 x)
        (Tezos_crypto.Secp256k1.of_b58check_opt s)
    else
      if
        Tezos_stdlib.TzString.has_prefix
          (encoded_prefix Tezos_crypto.P256.b58check_encoding) s then
        Tezos_stdlib.Option.map (fun x => P256 x)
          (Tezos_crypto.P256.of_b58check_opt s)
      else
        Tezos_crypto.Base58.simple_decode None b58check_encoding s.

Definition of_b58check_exn (s : string) : t :=
  match of_b58check_opt s with
  | Some x => x
  | None =>
    Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Unexpected data (" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Unexpected data (%s)" % string) name
  end.

Definition of_b58check (s : string)
  : sum t (list Tezos_error_monad.Error_monad.error) :=
  match of_b58check_opt s with
  | Some x => inl x
  | None =>
    Tezos_error_monad.Error_monad.generic_error
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to read a b58check_encoding data (" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "): " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))))
        "Failed to read a b58check_encoding data (%s): %S" % string) name s
  end.

Definition to_b58check (function_parameter : t) : string :=
  match function_parameter with
  | Ed25519 b => Tezos_crypto.Ed25519.to_b58check b
  | Secp256k1 b => Tezos_crypto.Secp256k1.to_b58check b
  | P256 b => Tezos_crypto.P256.to_b58check b
  | Unknown b =>
    Tezos_crypto.Base58.simple_encode None b58check_encoding (Unknown b)
  end.

Definition to_short_b58check (function_parameter : t) : string :=
  match function_parameter with
  | Ed25519 b => Tezos_crypto.Ed25519.to_short_b58check b
  | Secp256k1 b => Tezos_crypto.Secp256k1.to_short_b58check b
  | P256 b => Tezos_crypto.P256.to_short_b58check b
  | Unknown b =>
    Tezos_crypto.Base58.simple_encode None b58check_encoding (Unknown b)
  end.

Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).

Definition of_ed25519 (s : Tezos_crypto.Ed25519.t) : t := Ed25519 s.

Definition of_secp256k1 (s : Tezos_crypto.Secp256k1.t) : t := Secp256k1 s.

Definition of_p256 (s : Tezos_crypto.P256.t) : t := P256 s.

Definition zero : t := of_ed25519 Tezos_crypto.Ed25519.zero.

Definition bytes_of_watermark (function_parameter : watermark)
  : Stdlib.Bytes.t :=
  match function_parameter with
  | Block_header chain_id =>
    String.append (Stdlib.Bytes.of_string "" % string)
      (Tezos_crypto.Chain_id.to_bytes chain_id)
  | Endorsement chain_id =>
    String.append (Stdlib.Bytes.of_string "" % string)
      (Tezos_crypto.Chain_id.to_bytes chain_id)
  | Generic_operation => Stdlib.Bytes.of_string "" % string
  | Custom bytes => string
  end.

Definition pp_watermark
  (ppf : Stdlib.Format.formatter) (function_parameter : watermark) : unit :=
  match function_parameter with
  | Block_header chain_id =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Block-header: " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Block-header: %a" % string) Tezos_crypto.Chain_id.pp chain_id
  | Endorsement chain_id =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Endorsement: " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Endorsement: %a" % string) Tezos_crypto.Chain_id.pp chain_id
  | Generic_operation =>
    Stdlib.Format.pp_print_string ppf "Generic-operation" % string
  | Custom bytes =>
    let hexed := OCaml.Stdlib.reverse_apply (Hex.of_bytes None string) Hex.show
      in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Custom: 0x" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "Custom: 0x%s" % string)
      try
  end.

Definition sign
  (watermark : option watermark) (secret_key : Secret_key.t)
  (message : Stdlib.Bytes.t) : t :=
  let watermark := Tezos_stdlib.Option.map bytes_of_watermark watermark in
  match secret_key with
  | Secret_key.Ed25519 sk =>
    of_ed25519 (Tezos_crypto.Ed25519.sign watermark sk message)
  | Secp256k1 sk =>
    of_secp256k1 (Tezos_crypto.Secp256k1.sign watermark sk message)
  | P256 sk => of_p256 (Tezos_crypto.P256.sign watermark sk message)
  end.

Definition check
  (watermark : option watermark) (public_key : Public_key.t) (signature : t)
  (message : Stdlib.Bytes.t) : bool :=
  let watermark := Tezos_stdlib.Option.map bytes_of_watermark watermark in
  match (public_key, signature) with
  | (Public_key.Ed25519 pk, Unknown signature) =>
    match Tezos_crypto.Ed25519.of_bytes_opt signature with
    | Some s => Tezos_crypto.Ed25519.check watermark pk s message
    | None => false
    end
  | (Public_key.Secp256k1 pk, Unknown signature) =>
    match Tezos_crypto.Secp256k1.of_bytes_opt signature with
    | Some s => Tezos_crypto.Secp256k1.check watermark pk s message
    | None => false
    end
  | (Public_key.P256 pk, Unknown signature) =>
    match Tezos_crypto.P256.of_bytes_opt signature with
    | Some s => Tezos_crypto.P256.check watermark pk s message
    | None => false
    end
  | (Public_key.Ed25519 pk, Ed25519 signature) =>
    Tezos_crypto.Ed25519.check watermark pk signature message
  | (Public_key.Secp256k1 pk, Secp256k1 signature) =>
    Tezos_crypto.Secp256k1.check watermark pk signature message
  | (Public_key.P256 pk, P256 signature) =>
    Tezos_crypto.P256.check watermark pk signature message
  | _ => false
  end.

Definition append
  (watermark : option watermark) (sk : Secret_key.t) (msg : Stdlib.Bytes.t)
  : string := String.append msg (to_bytes (sign watermark sk msg)).

Definition concat (msg : string) (signature : t) : string :=
  String.append msg (to_bytes signature).

Inductive algo : Type :=
| Ed25519 : algo
| Secp256k1 : algo
| P256 : algo.

Definition generate_key (op_star_o_p_t_star : option algo)
  : (option Bigstring.t) ->
    unit -> Public_key_hash.t * Public_key.t * Secret_key.t :=
  let algo :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Ed25519
    end in
  fun seed =>
    fun function_parameter =>
      match function_parameter with
      | tt =>
        match algo with
        | Ed25519 =>
          match Tezos_crypto.Ed25519.generate_key seed tt with
          | (pkh, pk, sk) =>
            ((Public_key_hash.Ed25519 pkh), (Public_key.Ed25519 pk),
              (Secret_key.Ed25519 sk))
          end
        | Secp256k1 =>
          match Tezos_crypto.Secp256k1.generate_key seed tt with
          | (pkh, pk, sk) =>
            ((Public_key_hash.Secp256k1 pkh), (Public_key.Secp256k1 pk),
              (Secret_key.Secp256k1 sk))
          end
        | P256 =>
          match Tezos_crypto.P256.generate_key seed tt with
          | (pkh, pk, sk) =>
            ((Public_key_hash.P256 pkh), (Public_key.P256 pk),
              (Secret_key.P256 sk))
          end
        end
      end.

Definition deterministic_nonce (sk : Secret_key.t) (msg : Stdlib.Bytes.t)
  : Bigstring.t :=
  match sk with
  | Secret_key.Ed25519 sk => Tezos_crypto.Ed25519.deterministic_nonce sk msg
  | Secret_key.Secp256k1 sk => Tezos_crypto.Secp256k1.deterministic_nonce sk msg
  | Secret_key.P256 sk => Tezos_crypto.P256.deterministic_nonce sk msg
  end.

Definition deterministic_nonce_hash (sk : Secret_key.t) (msg : Stdlib.Bytes.t)
  : Stdlib.Bytes.t :=
  match sk with
  | Secret_key.Ed25519 sk =>
    Tezos_crypto.Ed25519.deterministic_nonce_hash sk msg
  | Secret_key.Secp256k1 sk =>
    Tezos_crypto.Secp256k1.deterministic_nonce_hash sk msg
  | Secret_key.P256 sk => Tezos_crypto.P256.deterministic_nonce_hash sk msg
  end.
src/lib_crypto/signature.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type public_key_hash =
  | Ed25519 of Ed25519.Public_key_hash.t
  | Secp256k1 of Secp256k1.Public_key_hash.t
  | P256 of P256.Public_key_hash.t

type public_key =
  | Ed25519 of Ed25519.Public_key.t
  | Secp256k1 of Secp256k1.Public_key.t
  | P256 of P256.Public_key.t

type secret_key =
  | Ed25519 of Ed25519.Secret_key.t
  | Secp256k1 of Secp256k1.Secret_key.t
  | P256 of P256.Secret_key.t

type watermark =
  | Block_header of Chain_id.t
  | Endorsement of Chain_id.t
  | Generic_operation
  | Custom of Bytes.t

val bytes_of_watermark : watermark -> Bytes.t

val pp_watermark : Format.formatter -> watermark -> unit

include
  S.SIGNATURE
    with type Public_key_hash.t = public_key_hash
     and type Public_key.t = public_key
     and type Secret_key.t = secret_key
     and type watermark := watermark

(** [append sk buf] is the concatenation of [buf] and the
    serialization of the signature of [buf] signed by [sk]. *)
val append : ?watermark:watermark -> secret_key -> Bytes.t -> Bytes.t

(** [concat buf t] is the concatenation of [buf] and the serialization
    of [t]. *)
val concat : Bytes.t -> t -> Bytes.t

include S.RAW_DATA with type t := t

val of_secp256k1 : Secp256k1.t -> t

val of_ed25519 : Ed25519.t -> t

val of_p256 : P256.t -> t

type algo = Ed25519 | Secp256k1 | P256

val generate_key :
  ?algo:algo ->
  ?seed:Bigstring.t ->
  unit ->
  public_key_hash * public_key * secret_key
src/lib_crypto/signature.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive public_key_hash : Type :=
| Ed25519 : Tezos_crypto.Ed25519.Public_key_hash.t -> public_key_hash
| Secp256k1 : Tezos_crypto.Secp256k1.Public_key_hash.t -> public_key_hash
| P256 : Tezos_crypto.P256.Public_key_hash.t -> public_key_hash.

Inductive public_key : Type :=
| Ed25519 : Tezos_crypto.Ed25519.Public_key.t -> public_key
| Secp256k1 : Tezos_crypto.Secp256k1.Public_key.t -> public_key
| P256 : Tezos_crypto.P256.Public_key.t -> public_key.

Inductive secret_key : Type :=
| Ed25519 : Tezos_crypto.Ed25519.Secret_key.t -> secret_key
| Secp256k1 : Tezos_crypto.Secp256k1.Secret_key.t -> secret_key
| P256 : Tezos_crypto.P256.Secret_key.t -> secret_key.

Inductive watermark : Type :=
| Block_header : Tezos_crypto.Chain_id.t -> watermark
| Endorsement : Tezos_crypto.Chain_id.t -> watermark
| Generic_operation : watermark
| Custom : Stdlib.Bytes.t -> watermark.

Parameter bytes_of_watermark : watermark -> Stdlib.Bytes.t.

Parameter pp_watermark : Stdlib.Format.formatter -> watermark -> unit.

include

Parameter append :
(option watermark) -> secret_key -> Stdlib.Bytes.t -> Stdlib.Bytes.t.

Parameter concat : Stdlib.Bytes.t -> t -> Stdlib.Bytes.t.

include

Parameter of_secp256k1 : Tezos_crypto.Secp256k1.t -> t.

Parameter of_ed25519 : Tezos_crypto.Ed25519.t -> t.

Parameter of_p256 : Tezos_crypto.P256.t -> t.

Inductive algo : Type :=
| Ed25519 : algo
| Secp256k1 : algo
| P256 : algo.

Parameter generate_key :
(option algo) ->
  (option Bigstring.t) -> unit -> public_key_hash * public_key * secret_key.
src/lib_crypto/test/roundtrips.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let test_rt_opt name testable enc dec input =
  try
    let roundtripped = dec (enc input) in
    Alcotest.check (Alcotest.option testable) name (Some input) roundtripped
  with exc ->
    Alcotest.failf
      "%s failed for %a: exception whilst decoding: %s"
      name
      (Alcotest.pp testable)
      input
      (Printexc.to_string exc)

let test_decode_opt_safe name testable dec encoded =
  match dec encoded with
  | Some _ | None ->
      ()
  | exception exc ->
      Alcotest.failf
        "%s failed for %a: exception whilst decoding: %s"
        name
        (Alcotest.pp testable)
        encoded
        (Printexc.to_string exc)

let test_decode_opt_fail name testable dec encoded =
  try
    let decoded = dec encoded in
    Alcotest.check (Alcotest.option testable) name None decoded
  with exc ->
    Alcotest.failf
      "%s failed: exception whilst decoding: %s"
      name
      (Printexc.to_string exc)
src/lib_crypto/test/roundtrips.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_rt_opt {A B C D E F : Type}
  (name : A) (testable : B) (enc : C -> D) (dec : D -> E) (input : C) : F := try.

Definition test_decode_opt_safe {A B C D : Type}
  (name : A) (testable : B) (dec : C -> option D) (encoded : C) : unit :=
  match dec encoded with
  | Some _ | None => tt
  end.

Definition test_decode_opt_fail {A B C D E : Type}
  (name : A) (testable : B) (dec : C -> D) (encoded : C) : E := try.
src/lib_crypto/test/test_base58.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let test_roundtrip_safe input =
  Roundtrips.test_rt_opt
    "safe base58"
    Alcotest.string
    Base58.safe_encode
    Base58.safe_decode
    input

let test_roundtrip_raw input =
  Roundtrips.test_rt_opt
    "raw base58"
    Alcotest.string
    Base58.raw_encode
    Base58.raw_decode
    input

let inputs =
  [ "abc";
    string_of_int max_int;
    "0";
    "00";
    "000";
    "0000";
    "0000000000000000";
    String.make 64 '0';
    "1";
    "11";
    "111";
    "1111";
    String.make 2048 '0';
    "2";
    "22";
    "5";
    "Z";
    String.make 2048 'Z';
    "z";
    "zz";
    "zzzzzzzz";
    String.make 2048 'z';
    (*loads of ascii characters: codes between 32 and 126 *)
    String.init 1000 (fun i -> Char.chr (32 + (i mod (126 - 32))));
    "" ]

let test_roundtrip_safes () = List.iter test_roundtrip_safe inputs

let test_roundtrip_raws () = List.iter test_roundtrip_raw inputs

let test_safety input =
  Roundtrips.test_decode_opt_safe
    "safe base58"
    Alcotest.string
    Base58.safe_decode
    input

let test_safetys () = List.iter test_safety inputs

let tests =
  [ ("safe decoding", `Quick, test_safetys);
    ("safe encoding/decoding", `Quick, test_roundtrip_safes);
    ("raw encoding/decoding", `Quick, test_roundtrip_raws) ]

let () = Alcotest.run "tezos-crypto" [("base58", tests)]
src/lib_crypto/test/test_base58.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_roundtrip_safe {A B : Type} (input : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star "safe base58" % string
    op_star_t_y_p_e_minus_e_r_r_o_r_star Tezos_crypto.Base58.safe_encode
    Tezos_crypto.Base58.safe_decode input.

Definition test_roundtrip_raw {A B : Type} (input : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star "raw base58" % string
    op_star_t_y_p_e_minus_e_r_r_o_r_star Tezos_crypto.Base58.raw_encode
    Tezos_crypto.Base58.raw_decode input.

Definition inputs : list string :=
  cons "abc" % string
    (cons (OCaml.Stdlib.string_of_int Stdlib.max_int)
      (cons "0" % string
        (cons "00" % string
          (cons "000" % string
            (cons "0000" % string
              (cons "0000000000000000" % string
                (cons (Stdlib.String.make 64 "0" % char)
                  (cons "1" % string
                    (cons "11" % string
                      (cons "111" % string
                        (cons "1111" % string
                          (cons (Stdlib.String.make 2048 "0" % char)
                            (cons "2" % string
                              (cons "22" % string
                                (cons "5" % string
                                  (cons "Z" % string
                                    (cons (Stdlib.String.make 2048 "Z" % char)
                                      (cons "z" % string
                                        (cons "zz" % string
                                          (cons "zzzzzzzz" % string
                                            (cons
                                              (Stdlib.String.make 2048
                                                "z" % char)
                                              (cons
                                                (Stdlib.String.init 1000
                                                  (fun i =>
                                                    Stdlib.Char.chr
                                                      (Z.add 32
                                                        (Z.modulo i
                                                          (Z.sub 126 32)))))
                                                (cons "" % string []))))))))))))))))))))))).

Definition test_roundtrip_safes (function_parameter : unit) : unit :=
  match function_parameter with
  | tt => Stdlib.List.iter test_roundtrip_safe inputs
  end.

Definition test_roundtrip_raws (function_parameter : unit) : unit :=
  match function_parameter with
  | tt => Stdlib.List.iter test_roundtrip_raw inputs
  end.

Definition test_safety {A B : Type} (input : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star "safe base58" % string
    op_star_t_y_p_e_minus_e_r_r_o_r_star Tezos_crypto.Base58.safe_decode input.

Definition test_safetys (function_parameter : unit) : unit :=
  match function_parameter with
  | tt => Stdlib.List.iter test_safety inputs
  end.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons ("safe decoding" % string, variant, test_safetys)
    (cons ("safe encoding/decoding" % string, variant, test_roundtrip_safes)
      (cons ("raw encoding/decoding" % string, variant, test_roundtrip_raws) [])).
src/lib_crypto/test/test_blake2b.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let test_hashed_roundtrip name enc dec input =
  (* this wrapper to start with hashing *)
  Roundtrips.test_rt_opt
    name
    (Alcotest.testable
       (fun fmt (input, _) -> Format.fprintf fmt "%s" input)
       (fun (_, hashed) (_, decoded) -> hashed = decoded))
    (fun (_, hashed) -> enc hashed)
    (fun encoded ->
      match dec encoded with
      | None ->
          None
      | Some decoded ->
          Some (input, decoded))
    (input, Blake2B.hash_string [input])

let test_roundtrip_hex input =
  test_hashed_roundtrip "Hex" Blake2B.to_hex Blake2B.of_hex_opt input

let test_roundtrip_string input =
  test_hashed_roundtrip "String" Blake2B.to_string Blake2B.of_string_opt input

let inputs =
  [ "abc";
    string_of_int max_int;
    "0";
    "00";
    String.make 64 '0';
    (*loads of ascii characters: codes between 32 and 126 *)
    String.init 1000 (fun i -> Char.chr (32 + (i mod (126 - 32))));
    "" ]

let test_roundtrip_hexs () = List.iter test_roundtrip_hex inputs

let test_roundtrip_strings () = List.iter test_roundtrip_string inputs

let tests =
  [ ("hash hex/dehex", `Quick, test_roundtrip_hexs);
    ("hash print/parse", `Quick, test_roundtrip_strings) ]

let () = Alcotest.run "tezos-crypto" [("blake2b", tests)]
src/lib_crypto/test/test_blake2b.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_hashed_roundtrip {A B C D E F : Type}
  (name : A) (enc : B -> C) (dec : D -> option E) (input : string) : F :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star name
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun fmt =>
        fun function_parameter =>
          match function_parameter with
          | (input, _) =>
            Stdlib.Format.fprintf fmt
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format) "%s" % string) input
          end)
      (fun function_parameter =>
        match function_parameter with
        | (_, hashed) =>
          fun function_parameter =>
            match function_parameter with
            | (_, decoded) => equiv_decb hashed decoded
            end
        end))
    (fun function_parameter =>
      match function_parameter with
      | (_, hashed) => enc hashed
      end)
    (fun encoded =>
      match dec encoded with
      | None => None
      | Some decoded => Some (input, decoded)
      end) (input, (Tezos_crypto.Blake2B.hash_string None (cons input []))).

Definition test_roundtrip_hex {A : Type} (input : string) : A :=
  test_hashed_roundtrip "Hex" % string Tezos_crypto.Blake2B.to_hex
    Tezos_crypto.Blake2B.of_hex_opt input.

Definition test_roundtrip_string {A : Type} (input : string) : A :=
  test_hashed_roundtrip "String" % string Tezos_crypto.Blake2B.to_string
    Tezos_crypto.Blake2B.of_string_opt input.

Definition inputs : list string :=
  cons "abc" % string
    (cons (OCaml.Stdlib.string_of_int Stdlib.max_int)
      (cons "0" % string
        (cons "00" % string
          (cons (Stdlib.String.make 64 "0" % char)
            (cons
              (Stdlib.String.init 1000
                (fun i => Stdlib.Char.chr (Z.add 32 (Z.modulo i (Z.sub 126 32)))))
              (cons "" % string [])))))).

Definition test_roundtrip_hexs (function_parameter : unit) : unit :=
  match function_parameter with
  | tt => Stdlib.List.iter test_roundtrip_hex inputs
  end.

Definition test_roundtrip_strings (function_parameter : unit) : unit :=
  match function_parameter with
  | tt => Stdlib.List.iter test_roundtrip_string inputs
  end.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons ("hash hex/dehex" % string, variant, test_roundtrip_hexs)
    (cons ("hash print/parse" % string, variant, test_roundtrip_strings) []).
src/lib_crypto/test/test_crypto_box.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let (sk, pk, pkh) = Crypto_box.random_keypair ()

let zero_nonce = Crypto_box.zero_nonce

let chkey = Crypto_box.precompute sk pk

let test_check_pow () =
  let target = Crypto_box.make_target 2. in
  let pow = Crypto_box.generate_proof_of_work pk target in
  Alcotest.(check bool)
    "check_pow"
    (Crypto_box.check_proof_of_work pk pow target)
    true

let test_neutrize sk pk () =
  Alcotest.check
    (Alcotest.testable Crypto_box.pp_pk Crypto_box.equal)
    "neuterize"
    (Crypto_box.neuterize sk)
    pk

let test_hash pk pkh () =
  Alcotest.check
    (Alcotest.testable
       Crypto_box.Public_key_hash.pp
       Crypto_box.Public_key_hash.equal)
    "test_hash"
    (Crypto_box.hash pk)
    pkh

let test_fast_box msg () =
  let msglen = Bytes.length msg in
  let buf_length = msglen + Crypto_box.zerobytes in
  let buf = Bytes.make buf_length '\x00' in
  Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
  (* encryption / decryption *)
  Crypto_box.fast_box_noalloc chkey zero_nonce buf ;
  ignore (Crypto_box.fast_box_open_noalloc chkey zero_nonce buf) ;
  let res =
    Bytes.sub buf Crypto_box.zerobytes (buf_length - Crypto_box.zerobytes)
  in
  Alcotest.check
    Alcotest.(testable (fun fmt x -> Hex.pp fmt (Hex.of_bytes x)) Bytes.equal)
    "test_fastbox enc/dec"
    res
    msg

let tests =
  [ ("Neutrize Secret roundtrip", `Quick, test_neutrize sk pk);
    ("Public Key Hash roundtrip", `Quick, test_hash pk pkh);
    ("Check PoW", `Slow, test_check_pow);
    ("Test hacl fastbox", `Quick, test_fast_box (Bytes.of_string "test")) ]

let () = Alcotest.run "tezos-crypto" [("crypto_box", tests)]
src/lib_crypto/test/test_crypto_box.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition zero_nonce : Tezos_crypto.Crypto_box.nonce :=
  Tezos_crypto.Crypto_box.zero_nonce.

Definition chkey : Tezos_crypto.Crypto_box.channel_key :=
  Tezos_crypto.Crypto_box.precompute sk pk.

Definition test_check_pow {A : Type} (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    let target := Tezos_crypto.Crypto_box.make_target 2 in
    let pow := Tezos_crypto.Crypto_box.generate_proof_of_work None pk target in
    op_star_t_y_p_e_minus_e_r_r_o_r_star "check_pow" % string
      (Tezos_crypto.Crypto_box.check_proof_of_work pk pow target) true
  end.

Definition test_neutrize {A B : Type}
  (sk : Tezos_crypto.Crypto_box.secret_key) (pk : A) (function_parameter : unit)
  : B :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star Tezos_crypto.Crypto_box.pp_pk
        Tezos_crypto.Crypto_box.equal) "neuterize" % string
      (Tezos_crypto.Crypto_box.neuterize sk) pk
  end.

Definition test_hash {A B : Type}
  (pk : Tezos_crypto.Crypto_box.public_key) (pkh : A)
  (function_parameter : unit) : B :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        Tezos_crypto.Crypto_box.Public_key_hash.pp
        Tezos_crypto.Crypto_box.Public_key_hash.equal) "test_hash" % string
      (Tezos_crypto.Crypto_box.hash pk) pkh
  end.

Definition test_fast_box {A : Type} (msg : string) (function_parameter : unit)
  : A :=
  match function_parameter with
  | tt =>
    let msglen := String.length msg in
    let buf_length := Z.add msglen Tezos_crypto.Crypto_box.zerobytes in
    let buf := Stdlib.Bytes.make buf_length "000" % char in
    Stdlib.Bytes.blit msg 0 buf Tezos_crypto.Crypto_box.zerobytes msglen;
    Tezos_crypto.Crypto_box.fast_box_noalloc chkey zero_nonce buf;
    OCaml.Stdlib.ignore
      (Tezos_crypto.Crypto_box.fast_box_open_noalloc chkey zero_nonce buf);
    let res :=
      String.sub buf Tezos_crypto.Crypto_box.zerobytes
        (Z.sub buf_length Tezos_crypto.Crypto_box.zerobytes) in
    op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
      "test_fastbox enc/dec" % string res msg
  end.

Definition tests {A : Type} : list (string * variant * (unit -> A)) :=
  cons ("Neutrize Secret roundtrip" % string, variant, (test_neutrize sk pk))
    (cons ("Public Key Hash roundtrip" % string, variant, (test_hash pk pkh))
      (cons ("Check PoW" % string, variant, test_check_pow)
        (cons
          ("Test hacl fastbox" % string, variant,
            (test_fast_box (Stdlib.Bytes.of_string "test" % string))) []))).
src/lib_crypto/test/test_deterministic_nonce.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let test_hash_matches (module X : S.SIGNATURE) () =
  let (_, _, sk) = X.generate_key () in
  let data = Bytes.of_string "ce input sa pun eu aici oare?" in
  let nonce = X.deterministic_nonce sk data in
  let nonce_hash = X.deterministic_nonce_hash sk data in
  let hashed_nonce = Blake2B.hash_bytes [Bigstring.to_bytes nonce] in
  if nonce_hash <> Blake2B.to_bytes hashed_nonce then
    Alcotest.failf
      "the hash of deterministic_nonce is NOT deterministic_nonce_hash"

let ed25519 = (module Ed25519 : S.SIGNATURE)

let p256 = (module P256 : S.SIGNATURE)

let secp256k1 = (module Secp256k1 : S.SIGNATURE)

let tests =
  [ ("hash_matches_ed25519", `Quick, test_hash_matches ed25519);
    ("hash_matches_p256", `Quick, test_hash_matches p256);
    ("hash_matches_secp256k1", `Quick, test_hash_matches secp256k1) ]

let () = Alcotest.run "tezos-crypto" [("deterministic_nonce", tests)]
src/lib_crypto/test/test_deterministic_nonce.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_hash_matches
  (X :
    {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
      Public_key_hash_Table_t, Public_key_hash_Error_table_t,
      Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark)
      : _ &
      Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
        Public_key_hash_Map_t Public_key_hash_Table_t
        Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t
        Public_key_t Secret_key_t t watermark}) : unit -> unit :=
  let X := projT2 X in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      match X.(Tezos_crypto__S.SIGNATURE.generate_key) None tt with
      | (_, _, sk) =>
        let data :=
          Stdlib.Bytes.of_string "ce input sa pun eu aici oare?" % string in
        let nonce := X.(Tezos_crypto__S.SIGNATURE.deterministic_nonce) sk data
          in
        let nonce_hash :=
          X.(Tezos_crypto__S.SIGNATURE.deterministic_nonce_hash) sk data in
        let hashed_nonce :=
          Tezos_crypto.Blake2B.hash_bytes None
            (cons (Bigstring.to_bytes nonce) []) in
        if nequiv_decb nonce_hash (Tezos_crypto.Blake2B.to_bytes hashed_nonce)
          then
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            "the hash of deterministic_nonce is NOT deterministic_nonce_hash" %
              string
        else
          tt
      end
    end.

Definition ed25519
  : {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
    Public_key_hash_Table_t, Public_key_hash_Error_table_t,
    Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
    _ &
    Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
      Public_key_hash_Map_t Public_key_hash_Table_t
      Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
      Secret_key_t t watermark} := Tezos_crypto.Ed25519.

Definition p256
  : {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
    Public_key_hash_Table_t, Public_key_hash_Error_table_t,
    Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
    _ &
    Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
      Public_key_hash_Map_t Public_key_hash_Table_t
      Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
      Secret_key_t t watermark} := Tezos_crypto.P256.

Definition secp256k1
  : {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
    Public_key_hash_Table_t, Public_key_hash_Error_table_t,
    Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
    _ &
    Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
      Public_key_hash_Map_t Public_key_hash_Table_t
      Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
      Secret_key_t t watermark} := Tezos_crypto.Secp256k1.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons ("hash_matches_ed25519" % string, variant, (test_hash_matches ed25519))
    (cons ("hash_matches_p256" % string, variant, (test_hash_matches p256))
      (cons
        ("hash_matches_secp256k1" % string, variant,
          (test_hash_matches secp256k1)) [])).
src/lib_crypto/test/test_ed25519.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type B58CHECK = sig
  type t

  val pp : Format.formatter -> t -> unit

  include S.B58_DATA with type t := t
end

let test_b58check_roundtrip :
    type t. (module B58CHECK with type t = t) -> t -> unit =
 fun m input ->
  let module M = (val m) in
  let testable = Alcotest.testable M.pp ( = ) in
  Roundtrips.test_rt_opt
    "b58check"
    testable
    M.to_b58check
    M.of_b58check_opt
    input

let test_b58check_roundtrips () =
  let (pubkey_hash, pubkey, seckey) = Ed25519.generate_key () in
  test_b58check_roundtrip (module Ed25519.Public_key_hash) pubkey_hash ;
  test_b58check_roundtrip (module Ed25519.Public_key) pubkey ;
  test_b58check_roundtrip (module Ed25519.Secret_key) seckey

let test_b58check_invalid input =
  Roundtrips.test_decode_opt_fail
    "b58check"
    (Alcotest.testable Ed25519.Public_key_hash.pp Ed25519.Public_key_hash.( = ))
    Ed25519.Public_key_hash.of_b58check_opt
    input

let test_b58check_invalids () =
  List.iter
    test_b58check_invalid
    [ "ThisIsGarbageNotACheck";
      "\x00";
      String.make 1000 '\x00';
      String.make 2048 'a';
      String.init 2048 (fun _ -> Char.chr (Random.int 256));
      "" ]

let tests =
  [ ("b58check.roundtrip", `Quick, test_b58check_roundtrips);
    ("b58check.invalid", `Slow, test_b58check_invalids) ]

let () = Alcotest.run "tezos-crypto" [("ed25519", tests)]
src/lib_crypto/test/test_ed25519.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module B58CHECK.
  Record signature {t : Type} := {
    t := t;
    pp : Stdlib.Format.formatter -> t -> unit;
    include;
  }.
  Arguments signature : clear implicits.
End B58CHECK.

Definition test_b58check_roundtrip {t : Type}
  (m : {_ : unit & B58CHECK.signature t}) (input : t) : unit :=
  let M := projT2 m in
  let testable :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star M.(B58CHECK.pp) equiv_decb in
  op_star_t_y_p_e_minus_e_r_r_o_r_star "b58check" % string testable
    M.(B58CHECK.to_b58check) M.(B58CHECK.of_b58check_opt) input.

Definition test_b58check_roundtrips (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    match Tezos_crypto.Ed25519.generate_key None tt with
    | (pubkey_hash, pubkey, seckey) =>
      test_b58check_roundtrip Tezos_crypto.Ed25519.Public_key_hash pubkey_hash;
      test_b58check_roundtrip Tezos_crypto.Ed25519.Public_key pubkey;
      test_b58check_roundtrip Tezos_crypto.Ed25519.Secret_key seckey
    end
  end.

Definition test_b58check_invalid {A B : Type} (input : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star "b58check" % string
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      Tezos_crypto.Ed25519.Public_key_hash.pp
      Tezos_crypto.Ed25519.Public_key_hash.op_eq)
    Tezos_crypto.Ed25519.Public_key_hash.of_b58check_opt input.

Definition test_b58check_invalids (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    Stdlib.List.iter test_b58check_invalid
      (cons "ThisIsGarbageNotACheck" % string
        (cons "" % string
          (cons (Stdlib.String.make 1000 "000" % char)
            (cons (Stdlib.String.make 2048 "a" % char)
              (cons
                (Stdlib.String.init 2048
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => Stdlib.Char.chr (Stdlib.Random.int 256)
                    end)) (cons "" % string []))))))
  end.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons ("b58check.roundtrip" % string, variant, test_b58check_roundtrips)
    (cons ("b58check.invalid" % string, variant, test_b58check_invalids) []).
src/lib_crypto/test/test_merkle.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Utils.Infix

type tree = Empty | Leaf of int | Node of tree * tree

let rec list_of_tree = function
  | Empty ->
      ([], 0)
  | Leaf x ->
      ([x], 1)
  | Node (x, y) ->
      let (x, sx) = list_of_tree x and (y, sy) = list_of_tree y in
      assert (sx = sy) ;
      (x @ y, sx + sy)

module Merkle = Blake2B.Generic_Merkle_tree (struct
  type t = tree

  type elt = int

  let empty = Empty

  let leaf i = Leaf i

  let node x y = Node (x, y)
end)

let rec compare_list xs ys =
  match (xs, ys) with
  | ([], []) ->
      true
  | ([x], y :: ys) when x = y ->
      ys = [] || compare_list xs ys
  | (x :: xs, y :: ys) when x = y ->
      compare_list xs ys
  | (_, _) ->
      false

let check_size i =
  let l = 0 -- i in
  let (l2, _) = list_of_tree (Merkle.compute l) in
  if compare_list l l2 then ()
  else
    Format.kasprintf
      failwith
      "Failed for %d: %a"
      i
      (Format.pp_print_list
         ~pp_sep:(fun ppf () -> Format.pp_print_string ppf ";")
         Format.pp_print_int)
      l2

let test_compute _ = List.iter check_size (0 -- 99)

let check_path i =
  let l = 0 -- i in
  let orig = Merkle.compute l in
  List.iter
    (fun j ->
      let path = Merkle.compute_path l j in
      let (found, pos) = Merkle.check_path path j in
      if found = orig && j = pos then ()
      else Format.kasprintf failwith "Failed for %d in %d." j i)
    l

let test_path _ = List.iter check_path (0 -- 128)

let tests = [("compute", `Quick, test_compute); ("path", `Quick, test_path)]

let () = Alcotest.run "tezos-crypto" [("merkel", tests)]
src/lib_crypto/test/test_merkle.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_stdlib.Utils.Infix.

Inductive tree : Type :=
| Empty : tree
| Leaf : Z -> tree
| Node : tree -> tree -> tree.

Fixpoint list_of_tree (function_parameter : tree) : (list Z) * Z :=
  match function_parameter with
  | Empty => ([], 0)
  | Leaf x => ((cons x []), 1)
  | Node x y =>
    in
    equiv_decb sx sy;
    ((OCaml.Stdlib.app x y), (Z.add sx sy))
  end.

Fixpoint compare_list {A : Type} (xs : list A) (ys : list A) : bool :=
  match (xs, ys) with
  | ([], []) => true
  | (_, _) => false
  end.

Definition check_size (i : Z) : unit :=
  let l := Tezos_stdlib.Utils.Infix.op_minus_minus 0 i in
  match list_of_tree (Merkle.compute l) with
  | (l2, _) =>
    if compare_list l l2 then
      tt
    else
      Stdlib.Format.kasprintf OCaml.Stdlib.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Failed for " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal ": " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))))
          "Failed for %d: %a" % string) i
        (Stdlib.Format.pp_print_list
          (Some
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | tt => Stdlib.Format.pp_print_string ppf ";" % string
                end)) Stdlib.Format.pp_print_int) l2
  end.

Definition test_compute {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    Stdlib.List.iter check_size (Tezos_stdlib.Utils.Infix.op_minus_minus 0 99)
  end.

Definition check_path (i : Z) : unit :=
  let l := Tezos_stdlib.Utils.Infix.op_minus_minus 0 i in
  let orig := Merkle.compute l in
  Stdlib.List.iter
    (fun j =>
      let path := Merkle.compute_path l j in
      match Merkle.check_path path j with
      | (found, pos) =>
        if andb (equiv_decb found orig) (equiv_decb j pos) then
          tt
        else
          Stdlib.Format.kasprintf OCaml.Stdlib.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Failed for " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal " in " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal "." % char
                        CamlinternalFormatBasics.End_of_format)))))
              "Failed for %d in %d." % string) j i
      end) l.

Definition test_path {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    Stdlib.List.iter check_path (Tezos_stdlib.Utils.Infix.op_minus_minus 0 128)
  end.

Definition tests {A : Type} : list (string * variant * (A -> unit)) :=
  cons ("compute" % string, variant, test_compute)
    (cons ("path" % string, variant, test_path) []).
src/lib_crypto/test/test_pvss.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* pvss tests here *)

module Pvss = Pvss_secp256k1
module Sp = Secp256k1_group

module Setup : sig
  val shares : Pvss.Encrypted_share.t list

  val commitments : Pvss.Commitment.t list

  val proof : Pvss.proof

  val secret_scalar : Sp.Group.Scalar.t

  val secret : Pvss.Secret_key.t

  val public_secret : Pvss.Public_key.t

  val other_shares : Pvss.Encrypted_share.t list

  val other_commitments : Pvss.Commitment.t list

  val other_proof : Pvss.proof

  val other_secret : Pvss.Secret_key.t

  type keypair = {
    secret_key : Pvss.Secret_key.t;
    public_key : Pvss.Public_key.t;
  }

  val public_keys : Pvss.Public_key.t list

  val keypairs : keypair list

  val reveals :
    (Pvss.Encrypted_share.t * (Pvss.Clear_share.t * Pvss.proof)) list

  val convert_encoding : 'a Data_encoding.t -> 'b Data_encoding.t -> 'a -> 'b

  val group_encoding : Sp.Group.t Data_encoding.t
end = struct
  type keypair = {
    secret_key : Pvss.Secret_key.t;
    public_key : Pvss.Public_key.t;
  }

  let group_encoding =
    Data_encoding.(conv Sp.Group.to_bits Sp.Group.of_bits_exn string)

  let scalar_encoding =
    Data_encoding.(
      conv Sp.Group.Scalar.to_bits Sp.Group.Scalar.of_bits_exn string)

  let convert_encoding de1 de2 x =
    Data_encoding.Binary.of_bytes_exn
      de2
      (Data_encoding.Binary.to_bytes_exn de1 x)

  (** Random value of Z in the range [0,2^256] *)
  let rand_Z () =
    [Random.int64 Int64.max_int |> Z.of_int64 |> Z.to_bits]
    |> Blake2B.hash_string |> Blake2B.to_string |> Z.of_bits

  (** Generates n random keypairs *)
  let random_keypairs n =
    List.init n (fun _ ->
        let s = Sp.Group.Scalar.of_Z (rand_Z ()) in
        let secret_key =
          convert_encoding scalar_encoding Pvss.Secret_key.encoding s
        in
        {secret_key; public_key = Pvss.Secret_key.to_public_key secret_key})

  let t = 5

  let n = 8

  let random_scalar () = Sp.Group.Scalar.of_Z (rand_Z ())

  let secret_of_scalar s =
    convert_encoding scalar_encoding Pvss.Secret_key.encoding s

  let secret_scalar = random_scalar ()

  let secret = secret_of_scalar secret_scalar

  let public_secret = Pvss.Secret_key.to_public_key secret

  let other_secret = secret_of_scalar (random_scalar ())

  let keypairs = random_keypairs n

  let public_keys = List.map (fun {public_key; _} -> public_key) keypairs

  let ( (shares, commitments, proof),
        (other_shares, other_commitments, other_proof) ) =
    ( Pvss.dealer_shares_and_proof ~secret ~t ~public_keys,
      Pvss.dealer_shares_and_proof ~secret:other_secret ~t ~public_keys )

  let reveals =
    List.map2
      (fun share keypair ->
        ( share,
          Pvss.reveal_share
            share
            ~secret_key:keypair.secret_key
            ~public_key:keypair.public_key ))
      shares
      keypairs
end

let test_dealer_proof () =
  let shr = (Setup.shares, Setup.other_shares)
  and cmt = (Setup.commitments, Setup.other_commitments)
  and prf = (Setup.proof, Setup.other_proof) in
  for i = 0 to 1 do
    for j = 0 to 1 do
      for k = 0 to 1 do
        let pick = function 0 -> fst | _ -> snd in
        assert (
          Pvss.check_dealer_proof
            (pick i shr)
            (pick j cmt)
            ~proof:(pick k prf)
            ~public_keys:Setup.public_keys
          = (i = j && j = k) )
      done
    done
  done

let test_share_reveal () =
  (* check reveal shares *)
  let shares_valid =
    List.map2
      (fun (share, (reveal, proof)) public_key ->
        Pvss.check_revealed_share share reveal ~public_key proof)
      Setup.reveals
      Setup.public_keys
  in
  List.iteri
    (fun i b ->
      print_endline (string_of_int i) ;
      assert b)
    shares_valid

let test_reconstruct () =
  let indices = [0; 1; 2; 3; 4] in
  let reconstructed =
    Pvss.reconstruct
      (List.map
         (fun n ->
           let (_, (r, _)) = List.nth Setup.reveals n in
           r)
         indices)
      indices
  in
  assert (
    Sp.Group.(( = ))
      (Setup.convert_encoding
         Pvss.Public_key.encoding
         Setup.group_encoding
         reconstructed)
      (Setup.convert_encoding
         Pvss.Public_key.encoding
         Setup.group_encoding
         Setup.public_secret) )

let tests =
  [ ("dealer_proof", `Quick, test_dealer_proof);
    ("reveal", `Quick, test_share_reveal);
    ("recontruct", `Quick, test_reconstruct) ]

let () = Alcotest.run "test-pvss" [("pvss", tests)]
src/lib_crypto/test/test_pvss.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Setup.
  Record keypair := {
    secret_key : Pvss.Secret_key.t;
    public_key : Pvss.Public_key.t }.
  
  Definition group_encoding
    : Tezos_data_encoding.Data_encoding.encoding Sp.Group.t :=
    Tezos_data_encoding.Data_encoding.conv Sp.Group.to_bits Sp.Group.of_bits_exn
      None Tezos_data_encoding.Data_encoding.string.
  
  Definition scalar_encoding
    : Tezos_data_encoding.Data_encoding.encoding Sp.Group.Scalar.t :=
    Tezos_data_encoding.Data_encoding.conv Sp.Group.Scalar.to_bits
      Sp.Group.Scalar.of_bits_exn None Tezos_data_encoding.Data_encoding.string.
  
  Definition convert_encoding {A B : Type}
    (de1 : Tezos_data_encoding__Data_encoding.Encoding.t A)
    (de2 : Tezos_data_encoding__Data_encoding.Encoding.t B) (x : A) : B :=
    Tezos_data_encoding.Data_encoding.Binary.of_bytes_exn de2
      (Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn de1 x).
  
  Definition rand_Z (function_parameter : unit) : Z.t :=
    match function_parameter with
    | tt =>
      OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (cons
              (OCaml.Stdlib.reverse_apply
                (OCaml.Stdlib.reverse_apply
                  (Stdlib.Random.int64 Stdlib.Int64.max_int) Z.of_int64)
                Z.to_bits) [])
            (let arg := Tezos_crypto.Blake2B.hash_string in
            fun eta => arg None eta)) Tezos_crypto.Blake2B.to_string) Z.of_bits
    end.
  
  Definition random_keypairs (n : Z) : list keypair :=
    Stdlib.List.init n
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          let s := Sp.Group.Scalar.of_Z (rand_Z tt) in
          let secret_key :=
            convert_encoding scalar_encoding Pvss.Secret_key.encoding s in
          {| secret_key := secret_key;
            public_key := Pvss.Secret_key.to_public_key secret_key |}
        end).
  
  Definition t : Z := 5.
  
  Definition n : Z := 8.
  
  Definition random_scalar (function_parameter : unit) : Sp.Group.Scalar.t :=
    match function_parameter with
    | tt => Sp.Group.Scalar.of_Z (rand_Z tt)
    end.
  
  Definition secret_of_scalar (s : Sp.Group.Scalar.t) : Pvss.Secret_key.t :=
    convert_encoding scalar_encoding Pvss.Secret_key.encoding s.
  
  Definition secret_scalar : Sp.Group.Scalar.t := random_scalar tt.
  
  Definition secret : Pvss.Secret_key.t := secret_of_scalar secret_scalar.
  
  Definition public_secret
    : Tezos_crypto__Pvss_secp256k1.Public_key.(Tezos_crypto__Pvss_secp256k1.ENCODED.t) :=
    Pvss.Secret_key.to_public_key secret.
  
  Definition other_secret : Pvss.Secret_key.t :=
    secret_of_scalar (random_scalar tt).
  
  Definition keypairs : list keypair := random_keypairs n.
  
  Definition public_keys : list Pvss.Public_key.t :=
    List.map
      (fun function_parameter =>
        match function_parameter with
        | {| public_key := public_key |} => public_key
        end) keypairs.
  
  Definition reveals
    : list (Pvss.Encrypted_share.t * (Pvss.Clear_share.t * Pvss.proof)) :=
    Stdlib.List.map2
      (fun share =>
        fun keypair =>
          (share,
            (Pvss.reveal_share share (secret_key keypair) (public_key keypair))))
      shares keypairs.
End Setup.

Definition test_dealer_proof (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let shr : (list Pvss.Encrypted_share.t) * (list Pvss.Encrypted_share.t) :=
      (Setup.shares, Setup.other_shares)
    with cmt : (list Pvss.Commitment.t) * (list Pvss.Commitment.t) :=
      (Setup.commitments, Setup.other_commitments)
    with prf : Pvss.proof * Pvss.proof :=
      (Setup.proof, Setup.other_proof) in
    for
  end.

Definition test_share_reveal (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let shares_valid :=
      Stdlib.List.map2
        (fun function_parameter =>
          match function_parameter with
          | (share, (reveal, proof)) =>
            fun public_key =>
              Pvss.check_revealed_share share reveal public_key proof
          end) Setup.reveals Setup.public_keys in
    Stdlib.List.iteri
      (fun i =>
        fun b =>
          OCaml.Stdlib.print_endline (OCaml.Stdlib.string_of_int i);
          b) shares_valid
  end.

Definition test_reconstruct (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let indices := cons 0 (cons 1 (cons 2 (cons 3 (cons 4 [])))) in
    let reconstructed :=
      Pvss.reconstruct
        (List.map
          (fun n =>
            match Stdlib.List.nth Setup.reveals n with
            | (_, (r, _)) => r
            end) indices) indices in
    Sp.Group.op_eq
      (Setup.convert_encoding Pvss.Public_key.encoding Setup.group_encoding
        reconstructed)
      (Setup.convert_encoding Pvss.Public_key.encoding Setup.group_encoding
        Setup.public_secret)
  end.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons ("dealer_proof" % string, variant, test_dealer_proof)
    (cons ("reveal" % string, variant, test_share_reveal)
      (cons ("recontruct" % string, variant, test_reconstruct) [])).
src/lib_crypto/znz.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type ZN = sig
  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val zero : t

  val one : t

  val n : Z.t

  val ( + ) : t -> t -> t

  val ( * ) : t -> t -> t

  val ( - ) : t -> t -> t

  val ( = ) : t -> t -> bool

  val of_int : int -> t

  val of_Z : Z.t -> t

  val to_Z : t -> Z.t

  val of_bits_exn : String.t -> t

  val to_bits : t -> String.t

  val pow : t -> Z.t -> t

  val inv : t -> t option
end

module type INT = sig
  val n : Z.t
end

module MakeZn
    (N : INT) (B : sig
      val b58_prefix : string
    end) : ZN = struct
  type t = Z.t

  let n = N.n

  let max_char_length = 2 * Z.numbits n

  let zero = Z.zero

  let one = Z.one

  let of_Z r = Z.(erem r n)

  let to_Z a = a

  let of_int u = u |> Z.of_int |> of_Z

  let to_bits h =
    h |> Zplus.serialize |> fun s -> String.sub s 0 (String.length s - 1)

  let of_bits_exn bits =
    (* Do not process oversized inputs. *)
    if Compare.Int.(String.length bits > max_char_length) then
      failwith "input too long"
    else
      (* Make sure the input is in the range [0, N.n-1]. Do not reduce modulo
         N.n for free! *)
      let x = Zplus.deserialize bits in
      if Zplus.(x < zero || x >= N.n) then failwith "out of range" else of_Z x

  let pow a x = Z.powm a Z.(erem x (sub n one)) n

  let ( + ) x y = Z.(erem (add x y) n)

  let ( * ) x y = Z.(erem (mul x y) n)

  let ( - ) x y = Z.(erem (sub x y) n)

  let ( = ) x y = Z.equal x y

  let inv a = Zplus.invert a n

  let title = Format.sprintf "Znz.Make(%s)" (Z.to_string N.n)

  let name = Format.sprintf "An element of Z/nZ for n = %s" (Z.to_string N.n)

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:B.b58_prefix
      ~length:32
      ~to_raw:to_bits
      ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
      ~wrap:(fun x -> Data x)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn
  end)
end
src/lib_crypto/znz.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module ZN.
  Record signature {t : Type} := {
    t := t;
    include;
    include;
    zero : t;
    one : t;
    n : Z.t;
    op_plus : t -> t -> t;
    op_star : t -> t -> t;
    op_minus : t -> t -> t;
    op_eq : t -> t -> bool;
    of_int : Z -> t;
    of_Z : Z.t -> t;
    to_Z : t -> Z.t;
    of_bits_exn : Stdlib.String.t -> t;
    to_bits : t -> Stdlib.String.t;
    pow : t -> Z.t -> t;
    inv : t -> option t;
  }.
  Arguments signature : clear implicits.
End ZN.

Module INT.
  Record signature := {
    n : Z.t;
  }.
End INT.
src/lib_crypto/znz.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Type for a module representing the ℤ/nℤ ring*)
module type ZN = sig
  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val zero : t

  val one : t

  val n : Z.t

  val ( + ) : t -> t -> t

  val ( * ) : t -> t -> t

  val ( - ) : t -> t -> t

  val ( = ) : t -> t -> bool

  (** Converts an integer to a ring element *)
  val of_int : int -> t

  (** Converts a [Zarith] integer to a ring element *)
  val of_Z : Z.t -> t

  (** Provides an integer representation between 0 and n-1 of an element *)
  val to_Z : t -> Z.t

  (** Converts a string of bytes to an integer modulo n, requires the string of
      byte to represent an integer between 0 and n-1 and checks the length of
      the string for sanity*)
  val of_bits_exn : String.t -> t

  (** Converts a ring element to a byte representation *)
  val to_bits : t -> String.t

  (** Modular exponentiation *)
  val pow : t -> Z.t -> t

  (** Returns the inverse of a in ℤ/nℤ, maybe *)
  val inv : t -> t option
end

(** Type of a module wrapping an integer. *)
module type INT = sig
  val n : Z.t
end

(** Functor to build the ℤ/nℤ ring given n*)
module MakeZn
    (N : INT) (B : sig
      val b58_prefix : string
    end) : ZN
src/lib_crypto/znz.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

unhandled_module
src/lib_crypto/zplus.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* let re_trailing_null =
   Re_pcre.regexp "^(.*?)\000*$"

   let remove_trailing_null s =
   Re.get (Re.exec re_trailing_null s) 1 *)

let remove_trailing_null s =
  let n = String.length s in
  let i = ref (n - 1) in
  while !i >= 0 && s.[!i] = '\000' do
    i := !i - 1
  done ;
  String.sub s 0 (!i + 1)

let serialize z =
  let n = if Z.(lt z zero) then Z.(neg (add (add z z) one)) else Z.(add z z) in
  n |> Z.to_bits |> remove_trailing_null

let deserialize z =
  let n = Z.of_bits z in
  let z = Z.shift_right_trunc n 1 in
  if Z.(n land one = zero) then z else Z.neg z

let leq a b = Z.compare a b <= 0

let geq a b = Z.compare a b >= 0

let lt a b = Z.compare a b < 0

let gt a b = Z.compare a b > 0

let ( < ) = lt

let ( > ) = gt

let ( <= ) = leq

let ( >= ) = geq

let zero = Z.zero

let one = Z.one

let invert a n = try Some (Z.invert a n) with Division_by_zero -> None
src/lib_crypto/zplus.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition remove_trailing_null (s : string) : string :=
  let n := OCaml.String.length s in
  let i := Stdlib.ref (Z.sub n 1) in
  while;
  Stdlib.String.sub s 0 (Z.add (Stdlib.op_exclamation i) 1).

Definition serialize (z : Z.t) : string :=
  let n :=
    if Z.lt z Z.zero then
      Z.neg (Z.add (Z.add z z) Z.one)
    else
      Z.add z z in
  OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply n Z.to_bits)
    remove_trailing_null.

Definition deserialize (z : string) : Z.t :=
  let n := Z.of_bits z in
  let z := Z.shift_right_trunc n 1 in
  if equiv_decb (Z.land n Z.one) Z.zero then
    z
  else
    Z.neg z.

Definition leq (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.le (Z.compare a b) 0.

Definition geq (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.ge (Z.compare a b) 0.

Definition lt (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.lt (Z.compare a b) 0.

Definition gt (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.gt (Z.compare a b) 0.

Definition op_lt : Z.t -> Z.t -> bool := lt.

Definition op_gt : Z.t -> Z.t -> bool := gt.

Definition op_lt_eq : Z.t -> Z.t -> bool := leq.

Definition op_gt_eq : Z.t -> Z.t -> bool := geq.

Definition zero : Z.t := Z.zero.

Definition one : Z.t := Z.one.

Definition invert (a : Z.t) (n : Z.t) : option Z.t := try.
src/lib_crypto/zplus.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val serialize : Z.t -> string

val deserialize : string -> Z.t

(** Less than or equal. *)
val leq : Z.t -> Z.t -> bool

(** Greater than or equal. *)
val geq : Z.t -> Z.t -> bool

(** Less than (and not equal). *)
val lt : Z.t -> Z.t -> bool

(** Greater than (and not equal). *)
val gt : Z.t -> Z.t -> bool

(** Less than or equal. *)
val ( <= ) : Z.t -> Z.t -> bool

(** Greater than or equal. *)
val ( >= ) : Z.t -> Z.t -> bool

(** Less than (and not equal). *)
val ( < ) : Z.t -> Z.t -> bool

(** Greater than (and not equal). *)
val ( > ) : Z.t -> Z.t -> bool

val zero : Z.t

val one : Z.t

(** Invert the first argument modulo the second. Returns
    none if there is no inverse *)
val invert : Z.t -> Z.t -> Z.t option
src/lib_crypto/zplus.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter serialize : Z.t -> string.

Parameter deserialize : string -> Z.t.

Parameter leq : Z.t -> Z.t -> bool.

Parameter geq : Z.t -> Z.t -> bool.

Parameter lt : Z.t -> Z.t -> bool.

Parameter gt : Z.t -> Z.t -> bool.

Parameter op_lt_eq : Z.t -> Z.t -> bool.

Parameter op_gt_eq : Z.t -> Z.t -> bool.

Parameter op_lt : Z.t -> Z.t -> bool.

Parameter op_gt : Z.t -> Z.t -> bool.

Parameter zero : Z.t.

Parameter one : Z.t.

Parameter invert : Z.t -> Z.t -> option Z.t.
src/lib_data_encoding/binary_description.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type recursives = string list

type references = {
  descriptions : (string * Binary_schema.toplevel_encoding) list;
}
[@@unwrapped]

(* Simple Union find implementation, there are several optimizations
   that give UF it's usual time complexity that could be added.
   If this is a bottleneck, they're easy to add. *)
module UF : sig
  type t

  val add : t -> Binary_schema.description -> unit

  val find : t -> string -> Binary_schema.description

  val union :
    t -> new_cannonical:Binary_schema.description -> existing:string -> unit

  val empty : unit -> t
end = struct
  open Binary_schema

  type ele = Ref of string | Root of description

  type t = (string, ele) Hashtbl.t

  let add t x = Hashtbl.replace t x.title (Root x)

  let rec find tbl key =
    match Hashtbl.find tbl key with Ref s -> find tbl s | Root desc -> desc

  let union tbl ~new_cannonical ~existing =
    add tbl new_cannonical ;
    let root = find tbl existing in
    if root.title = new_cannonical.title then ()
    else Hashtbl.replace tbl root.title (Ref new_cannonical.title)

  let empty () = Hashtbl.create 128
end

let fixup_references uf =
  let open Binary_schema in
  let rec fixup_layout = function
    | Ref s ->
        Ref (UF.find uf s).title
    | Enum (i, name) ->
        Enum (i, (UF.find uf name).title)
    | Seq (layout, len) ->
        Seq (fixup_layout layout, len)
    | ( Zero_width
      | Int _
      | Bool
      | RangedInt (_, _)
      | RangedFloat (_, _)
      | Float
      | Bytes
      | String
      | Padding ) as enc ->
        enc
  in
  let field = function
    | Named_field (name, kind, layout) ->
        Named_field (name, kind, fixup_layout layout)
    | Anonymous_field (kind, layout) ->
        Anonymous_field (kind, fixup_layout layout)
    | (Dynamic_size_field _ | Optional_field _) as field ->
        field
  in
  function
  | Obj {fields} ->
      Obj {fields = List.map field fields}
  | Cases ({cases; _} as x) ->
      Cases
        {
          x with
          cases =
            List.map
              (fun (i, name, fields) -> (i, name, List.map field fields))
              cases;
        }
  | Int_enum _ as ie ->
      ie

let z_reference_name = "Z.t"

let z_reference_description =
  "A variable length sequence of bytes, encoding a Zarith number. Each byte \
   has a running unary size bit: the most significant bit of each byte tells \
   is this is the last byte in the sequence (0) or if there is more to read \
   (1). The second most significant bit of the first byte is reserved for the \
   sign (positive if zero). Size and sign bits ignored, data is then the \
   binary representation of the absolute value of the number in little endian \
   order."

let z_encoding =
  Binary_schema.Obj {fields = [Named_field ("Z.t", `Dynamic, Bytes)]}

let add_z_reference uf {descriptions} =
  UF.add
    uf
    {title = z_reference_name; description = Some z_reference_description} ;
  {descriptions = (z_reference_name, z_encoding) :: descriptions}

let n_reference_name = "N.t"

let n_reference_description =
  "A variable length sequence of bytes, encoding a Zarith number. Each byte \
   has a running unary size bit: the most significant bit of each byte tells \
   is this is the last byte in the sequence (0) or if there is more to read \
   (1). Size bits ignored, data is then the binary representation of the \
   absolute value of the number in little endian order."

let n_encoding =
  Binary_schema.Obj {fields = [Named_field ("N.t", `Dynamic, Bytes)]}

let add_n_reference uf {descriptions} =
  UF.add
    uf
    {title = n_reference_name; description = Some n_reference_description} ;
  {descriptions = (n_reference_name, n_encoding) :: descriptions}

let dedup_canonicalize uf =
  let tbl :
      (Binary_schema.toplevel_encoding, Binary_schema.description) Hashtbl.t =
    Hashtbl.create 100
  in
  let rec help prev_len acc = function
    | [] ->
        let fixedup =
          List.map
            (fun (desc, layout) -> (desc, fixup_references uf layout))
            acc
        in
        if List.length fixedup = prev_len then
          List.map (fun (name, layout) -> (UF.find uf name, layout)) fixedup
        else (
          Hashtbl.clear tbl ;
          help (List.length fixedup) [] fixedup )
    | (name, layout) :: tl -> (
      match Hashtbl.find_opt tbl layout with
      | None ->
          let desc = UF.find uf name in
          Hashtbl.add tbl layout desc ;
          help prev_len ((desc.title, layout) :: acc) tl
      | Some original_desc ->
          UF.union uf ~new_cannonical:original_desc ~existing:name ;
          help prev_len acc tl )
  in
  help 0 []

type pdesc = P : 'x Encoding.desc -> pdesc

let describe (type x) (encoding : x Encoding.t) =
  let open Encoding in
  let uf = UF.empty () in
  let uf_add_name title = UF.add uf {title; description = None} in
  let add_reference name description {descriptions} =
    {descriptions = (name, description) :: descriptions}
  in
  let new_reference =
    let x = ref ~-1 in
    fun () ->
      x := !x + 1 ;
      let name = "X_" ^ string_of_int !x in
      uf_add_name name ; name
  in
  let may_new_reference = function
    | None ->
        new_reference ()
    | Some name ->
        uf_add_name name ; name
  in
  let rec extract_dynamic :
      type x.
      string option ->
      x Encoding.desc ->
      Binary_size.unsigned_integer option * string option * pdesc =
   fun ref_name -> function
    | Conv {encoding; _} ->
        extract_dynamic ref_name encoding.encoding
    | Describe {id = ref_name; encoding; _} ->
        extract_dynamic (Some ref_name) encoding.encoding
    | Splitted {encoding; _} ->
        extract_dynamic ref_name encoding.encoding
    | Delayed f ->
        extract_dynamic ref_name (f ()).encoding
    | Dynamic_size {kind; encoding} ->
        (Some kind, ref_name, P encoding.encoding)
    | enc ->
        (None, ref_name, P enc)
  in
  let rec field_descr :
      type a.
      recursives ->
      references ->
      a Encoding.field ->
      Binary_schema.field_descr list * references =
   fun recursives references -> function
    | Req {name; encoding = {encoding; _}; _}
    | Dft {name; encoding = {encoding; _}; _} -> (
        let (dynamics, ref_name, P field) = extract_dynamic None encoding in
        let (layout, references) =
          layout ref_name recursives references field
        in
        if layout = Zero_width then ([], references)
        else
          let field_descr =
            Binary_schema.Named_field (name, classify_desc field, layout)
          in
          match dynamics with
          | Some kind ->
              ( [Dynamic_size_field (ref_name, 1, kind); field_descr],
                references )
          | None ->
              ([field_descr], references) )
    | Opt {kind = `Variable; name; encoding = {encoding; _}; _} ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Named_field (name, `Variable, layout)], references)
    | Opt {kind = `Dynamic; name; encoding = {encoding; _}; _} ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ( [ Binary_schema.Optional_field name;
            Named_field (name, classify_desc encoding, layout) ],
          references )
  and obj fields = Binary_schema.Obj {fields}
  and union :
      type a.
      string option ->
      recursives ->
      references ->
      Kind.t ->
      Binary_size.tag_size ->
      a case list ->
      string * references =
   fun ref_name recursives references kind size cases ->
    let cases =
      List.sort (fun (t1, _) (t2, _) -> (compare : int -> int -> int) t1 t2)
      @@ List.fold_left
           (fun acc case ->
             match case with
             | Case {tag = Json_only; _} ->
                 acc
             | Case {tag = Tag tag; _} ->
                 (tag, case) :: acc)
           []
           cases
    in
    let tag_field =
      Binary_schema.Named_field
        ( "Tag",
          `Fixed (Binary_size.tag_size size),
          Int (size :> Binary_schema.integer_extended) )
    in
    let (cases, references) =
      List.fold_right
        (fun (tag, Case case) (cases, references) ->
          let (fields, references) =
            fields None recursives references case.encoding.encoding
          in
          ((tag, Some case.title, tag_field :: fields) :: cases, references))
        cases
        ([], references)
    in
    let name = may_new_reference ref_name in
    let references =
      add_reference name (Cases {kind; tag_size = size; cases}) references
    in
    (name, references)
  and describe :
      type b.
      ?description:string ->
      title:string ->
      string ->
      recursives ->
      references ->
      b desc ->
      string * references =
   fun ?description ~title name recursives references encoding ->
    let new_cannonical = {Binary_schema.title; description} in
    UF.add uf new_cannonical ;
    let (layout, references) = layout None recursives references encoding in
    match layout with
    | Ref ref_name ->
        UF.union uf ~existing:ref_name ~new_cannonical ;
        (ref_name, references)
    | layout ->
        UF.add uf new_cannonical ;
        ( name,
          add_reference
            name
            (obj [Anonymous_field (classify_desc encoding, layout)])
            references )
  and enum : type a. (a, _) Hashtbl.t -> a array -> _ =
   fun tbl encoding_array ->
    ( Binary_size.range_to_size
        ~minimum:0
        ~maximum:(Array.length encoding_array),
      List.map
        (fun i -> (i, fst @@ Hashtbl.find tbl encoding_array.(i)))
        (List.init (Array.length encoding_array) (fun i -> i)) )
  and fields :
      type b.
      string option ->
      recursives ->
      references ->
      b Encoding.desc ->
      Binary_schema.fields * references =
   fun ref_name recursives references -> function
    | Obj field ->
        field_descr recursives references field
    | Objs {left; right; _} ->
        let (left_fields, references) =
          fields None recursives references left.encoding
        in
        let (right_fields, references) =
          fields None recursives references right.encoding
        in
        (left_fields @ right_fields, references)
    | Null ->
        ([Anonymous_field (`Fixed 0, Zero_width)], references)
    | Empty ->
        ([Anonymous_field (`Fixed 0, Zero_width)], references)
    | Ignore ->
        ([Anonymous_field (`Fixed 0, Zero_width)], references)
    | Constant _ ->
        ([Anonymous_field (`Fixed 0, Zero_width)], references)
    | Dynamic_size {kind; encoding} ->
        let (fields, refs) =
          fields None recursives references encoding.encoding
        in
        (Dynamic_size_field (None, List.length fields, kind) :: fields, refs)
    | Check_size {encoding; _} ->
        fields ref_name recursives references encoding.encoding
    | Conv {encoding; _} ->
        fields ref_name recursives references encoding.encoding
    | Describe {id = name; encoding; _} ->
        fields (Some name) recursives references encoding.encoding
    | Splitted {encoding; _} ->
        fields ref_name recursives references encoding.encoding
    | Delayed func ->
        fields ref_name recursives references (func ()).encoding
    | List (len, {encoding; _}) ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (`Variable, Seq (layout, len))], references)
    | Array (len, {encoding; _}) ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (`Variable, Seq (layout, len))], references)
    | Bytes kind ->
        ([Anonymous_field ((kind :> Kind.t), Bytes)], references)
    | String kind ->
        ([Anonymous_field ((kind :> Kind.t), String)], references)
    | Padded ({encoding = e; _}, n) ->
        let (fields, references) = fields ref_name recursives references e in
        (fields @ [Named_field ("padding", `Fixed n, Padding)], references)
    | String_enum (tbl, encoding_array) as encoding ->
        let (size, cases) = enum tbl encoding_array in
        let name = may_new_reference ref_name in
        ( [Anonymous_field (classify_desc encoding, Ref name)],
          add_reference name (Int_enum {size; cases}) references )
    | Tup {encoding; _} ->
        let (layout, references) =
          layout ref_name recursives references encoding
        in
        if layout = Zero_width then ([], references)
        else ([Anonymous_field (classify_desc encoding, layout)], references)
    | Tups {left; right; _} ->
        let (fields1, references) =
          fields None recursives references left.encoding
        in
        let (fields2, references) =
          fields None recursives references right.encoding
        in
        (fields1 @ fields2, references)
    | Union {kind; tag_size; cases} ->
        let (name, references) =
          union None recursives references kind tag_size cases
        in
        ([Anonymous_field (kind, Ref name)], references)
    | Mu {kind; name; title; description; fix} as encoding ->
        let kind = (kind :> Kind.t) in
        let title = match title with Some title -> title | None -> name in
        if List.mem name recursives then
          ([Anonymous_field (kind, Ref name)], references)
        else
          let {encoding; _} = fix {encoding; json_encoding = None} in
          let (name, references) =
            describe
              ~title
              ?description
              name
              (name :: recursives)
              references
              encoding
          in
          ([Anonymous_field (kind, Ref name)], references)
    | Bool as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int8 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Uint8 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int16 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Uint16 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int31 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int32 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int64 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | N as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Z as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | RangedInt _ as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | RangedFloat _ as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Float as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
  and layout :
      type c.
      string option ->
      recursives ->
      references ->
      c Encoding.desc ->
      Binary_schema.layout * references =
   fun ref_name recursives references -> function
    | Null ->
        (Zero_width, references)
    | Empty ->
        (Zero_width, references)
    | Ignore ->
        (Zero_width, references)
    | Constant _ ->
        (Zero_width, references)
    | Bool ->
        (Bool, references)
    | Int8 ->
        (Int `Int8, references)
    | Uint8 ->
        (Int `Uint8, references)
    | Int16 ->
        (Int `Int16, references)
    | Uint16 ->
        (Int `Uint16, references)
    | Int31 ->
        (RangedInt (~-1073741824, 1073741823), references)
    | Int32 ->
        (Int `Int32, references)
    | Int64 ->
        (Int `Int64, references)
    | N ->
        (Ref n_reference_name, add_n_reference uf references)
    | Z ->
        (Ref z_reference_name, add_z_reference uf references)
    | RangedInt {minimum; maximum} ->
        (RangedInt (minimum, maximum), references)
    | RangedFloat {minimum; maximum} ->
        (RangedFloat (minimum, maximum), references)
    | Float ->
        (Float, references)
    | Bytes _kind ->
        (Bytes, references)
    | String _kind ->
        (String, references)
    | Padded _ as enc ->
        let name = may_new_reference ref_name in
        let (fields, references) = fields None recursives references enc in
        let references = add_reference name (obj fields) references in
        (Ref name, references)
    | String_enum (tbl, encoding_array) ->
        let name = may_new_reference ref_name in
        let (size, cases) = enum tbl encoding_array in
        let references =
          add_reference name (Int_enum {size; cases}) references
        in
        (Enum (size, name), references)
    | Array (len, data) ->
        let (descr, references) =
          layout None recursives references data.encoding
        in
        (Seq (descr, len), references)
    | List (len, data) ->
        let (layout, references) =
          layout None recursives references data.encoding
        in
        (Seq (layout, len), references)
    | Obj (Req {encoding = {encoding; _}; _})
    | Obj (Dft {encoding = {encoding; _}; _}) ->
        layout ref_name recursives references encoding
    | Obj (Opt _) as enc ->
        let name = may_new_reference ref_name in
        let (fields, references) = fields None recursives references enc in
        let references = add_reference name (obj fields) references in
        (Ref name, references)
    | Objs {left; right; _} ->
        let name = may_new_reference ref_name in
        let (fields1, references) =
          fields None recursives references left.encoding
        in
        let (fields2, references) =
          fields None recursives references right.encoding
        in
        let references =
          add_reference name (obj (fields1 @ fields2)) references
        in
        (Ref name, references)
    | Tup {encoding; _} ->
        layout ref_name recursives references encoding
    | Tups _ as descr ->
        let name = may_new_reference ref_name in
        let (fields, references) = fields None recursives references descr in
        let references = add_reference name (obj fields) references in
        (Ref name, references)
    | Union {kind; tag_size; cases} ->
        let (name, references) =
          union ref_name recursives references kind tag_size cases
        in
        (Ref name, references)
    | Mu {name; title; description; fix; _} as encoding ->
        let title = match title with Some title -> title | None -> name in
        if List.mem name recursives then (Ref name, references)
        else
          let {encoding; _} = fix {encoding; json_encoding = None} in
          let (name, references) =
            describe
              name
              ~title
              ?description
              (name :: recursives)
              references
              encoding
          in
          (Ref name, references)
    | Conv {encoding; _} ->
        layout ref_name recursives references encoding.encoding
    | Describe {id = name; encoding; _} ->
        layout (Some name) recursives references encoding.encoding
    | Splitted {encoding; _} ->
        layout ref_name recursives references encoding.encoding
    | Dynamic_size _ as encoding ->
        let name = may_new_reference ref_name in
        let (fields, references) =
          fields None recursives references encoding
        in
        UF.add uf {title = name; description = None} ;
        (Ref name, add_reference name (obj fields) references)
    | Check_size {encoding; _} ->
        layout ref_name recursives references encoding.encoding
    | Delayed func ->
        layout ref_name recursives references (func ()).encoding
  in
  let (fields, references) =
    fields None [] {descriptions = []} encoding.encoding
  in
  uf_add_name "" ;
  let (_, toplevel) = List.hd (dedup_canonicalize uf [("", obj fields)]) in
  let filtered =
    List.filter
      (fun (name, encoding) ->
        match encoding with
        | Binary_schema.Obj {fields = [Anonymous_field (_, Ref reference)]} ->
            UF.union uf ~new_cannonical:(UF.find uf name) ~existing:reference ;
            false
        | _ ->
            true)
      references.descriptions
  in
  let fields = List.rev (dedup_canonicalize uf filtered) in
  {Binary_schema.toplevel; fields}
src/lib_data_encoding/binary_description.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition recursives := list string.

Record references := {
  descriptions :
    list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding) }.

Module UF.
  Import Tezos_data_encoding.Binary_schema.
  
  Inductive ele : Type :=
  | Ref : string -> ele
  | Root : Tezos_data_encoding.Binary_schema.description -> ele.
  
  Definition t := Stdlib.Hashtbl.t string ele.
  
  Definition add
    (t : Stdlib.Hashtbl.t string ele)
    (x : Tezos_data_encoding.Binary_schema.description) : unit :=
    Stdlib.Hashtbl.replace t (title x) (Root x).
  
  Fixpoint find (tbl : Stdlib.Hashtbl.t string ele) (key : string)
    : Tezos_data_encoding.Binary_schema.description :=
    match Stdlib.Hashtbl.find tbl key with
    | Ref s => find tbl s
    | Root desc => desc
    end.
  
  Definition union
    (tbl : Stdlib.Hashtbl.t string ele)
    (new_cannonical : Tezos_data_encoding.Binary_schema.description)
    (existing : string) : unit :=
    add tbl new_cannonical;
    let root := find tbl existing in
    if equiv_decb (title root) (title new_cannonical) then
      tt
    else
      Stdlib.Hashtbl.replace tbl (title root) (Ref (title new_cannonical)).
  
  Definition empty {A B : Type} (function_parameter : unit)
    : Stdlib.Hashtbl.t A B :=
    match function_parameter with
    | tt => Stdlib.Hashtbl.create None 128
    end.
End UF.

Definition fixup_references (uf : UF.t)
  : Tezos_data_encoding.Binary_schema.toplevel_encoding ->
    Tezos_data_encoding.Binary_schema.toplevel_encoding :=
  let fix fixup_layout
    (function_parameter : Tezos_data_encoding.Binary_schema.layout)
    : Tezos_data_encoding.Binary_schema.layout :=
    match function_parameter with
    | Ref s => Ref (title (UF.find uf s))
    | Enum i name => Enum i (title (UF.find uf name))
    | Seq layout len => Seq (fixup_layout layout) len
    |
      (Zero_width | Int _ | Bool | RangedInt _ _ | RangedFloat _ _ | Float |
        Bytes | String | Padding) as enc => enc
    end in
  let field (function_parameter : Tezos_data_encoding.Binary_schema.field_descr)
    : Tezos_data_encoding.Binary_schema.field_descr :=
    match function_parameter with
    | Named_field name kind layout =>
      Named_field name kind (fixup_layout layout)
    | Anonymous_field kind layout => Anonymous_field kind (fixup_layout layout)
    | (Dynamic_size_field _ _ _ | Optional_field _) as field => field
    end in
  fun function_parameter =>
    match function_parameter with
    | Obj {| fields := fields |} => Obj {| fields := List.map field fields |}
    | Cases ({| cases := cases |} as x) => Cases record
    | (Int_enum _) as ie => ie
    end.

Definition z_reference_name : string := "Z.t" % string.

Definition z_reference_description : string :=
  "A variable length sequence of bytes, encoding a Zarith number. Each byte has a running unary size bit: the most significant bit of each byte tells is this is the last byte in the sequence (0) or if there is more to read (1). The second most significant bit of the first byte is reserved for the sign (positive if zero). Size and sign bits ignored, data is then the binary representation of the absolute value of the number in little endian order."
    % string.

Definition z_encoding : Tezos_data_encoding.Binary_schema.toplevel_encoding :=
  Binary_schema.Obj
    {| fields := cons (Named_field "Z.t" % string variant Bytes) [] |}.

Definition add_z_reference (uf : UF.t) (function_parameter : references)
  : references :=
  match function_parameter with
  | {| descriptions := descriptions |} =>
    UF.add uf
      {| title := z_reference_name; description := Some z_reference_description
        |};
    {| descriptions := cons (z_reference_name, z_encoding) descriptions |}
  end.

Definition n_reference_name : string := "N.t" % string.

Definition n_reference_description : string :=
  "A variable length sequence of bytes, encoding a Zarith number. Each byte has a running unary size bit: the most significant bit of each byte tells is this is the last byte in the sequence (0) or if there is more to read (1). Size bits ignored, data is then the binary representation of the absolute value of the number in little endian order."
    % string.

Definition n_encoding : Tezos_data_encoding.Binary_schema.toplevel_encoding :=
  Binary_schema.Obj
    {| fields := cons (Named_field "N.t" % string variant Bytes) [] |}.

Definition add_n_reference (uf : UF.t) (function_parameter : references)
  : references :=
  match function_parameter with
  | {| descriptions := descriptions |} =>
    UF.add uf
      {| title := n_reference_name; description := Some n_reference_description
        |};
    {| descriptions := cons (n_reference_name, n_encoding) descriptions |}
  end.

Definition dedup_canonicalize (uf : UF.t)
  : (list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding)) ->
    list
      (Tezos_data_encoding.Binary_schema.description *
        Tezos_data_encoding.Binary_schema.toplevel_encoding) :=
  let tbl := Stdlib.Hashtbl.create None 100 in
  let fix help
    (prev_len : Z) (acc :
    list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding))
    (function_parameter :
    list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding))
    : list
      (Tezos_data_encoding.Binary_schema.description *
        Tezos_data_encoding.Binary_schema.toplevel_encoding) :=
    match function_parameter with
    | [] =>
      let fixedup :=
        List.map
          (fun function_parameter =>
            match function_parameter with
            | (desc, layout) => (desc, (fixup_references uf layout))
            end) acc in
      if equiv_decb (OCaml.List.length fixedup) prev_len then
        List.map
          (fun function_parameter =>
            match function_parameter with
            | (name, layout) => ((UF.find uf name), layout)
            end) fixedup
      else
        Stdlib.Hashtbl.clear tbl;
        help (OCaml.List.length fixedup) [] fixedup
    | cons (name, layout) tl =>
      match Stdlib.Hashtbl.find_opt tbl layout with
      | None =>
        let desc := UF.find uf name in
        Stdlib.Hashtbl.add tbl layout desc;
        help prev_len (cons ((title desc), layout) acc) tl
      | Some original_desc =>
        UF.union uf original_desc name;
        help prev_len acc tl
      end
    end in
  help 0 [].

Inductive pdesc : Type :=
| P : forall {x : Type}, (Tezos_data_encoding.Encoding.desc x) -> pdesc.

Definition describe {A : Type} (encoding : Tezos_data_encoding.Encoding.t A)
  : Tezos_data_encoding.Binary_schema.t :=
  let uf := UF.empty tt in
  let uf_add_name (title : string) : unit :=
    UF.add uf {| title := title; description := None |} in
  let add_reference
    (name : string) (description :
    Tezos_data_encoding.Binary_schema.toplevel_encoding) (function_parameter :
    references) : references :=
    match function_parameter with
    | {| descriptions := descriptions |} =>
      {| descriptions := cons (name, description) descriptions |}
    end in
  let new_reference :=
    let x := Stdlib.ref (Z.opp 1) in
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Stdlib.op_colon_eq x (Z.add (Stdlib.op_exclamation x) 1);
        let name :=
          String.append "X_" % string
            (OCaml.Stdlib.string_of_int (Stdlib.op_exclamation x)) in
        uf_add_name name;
        name
      end in
  let may_new_reference (function_parameter : option string) : string :=
    match function_parameter with
    | None => new_reference tt
    | Some name =>
      uf_add_name name;
      name
    end in
  let fix extract_dynamic {x : Type}
    (ref_name : option string) (function_parameter :
    Tezos_data_encoding.Encoding.desc x)
    : (option Tezos_data_encoding.Binary_size.unsigned_integer) *
      (option string) * pdesc :=
    match function_parameter with
    | Conv {| encoding := encoding |} =>
      extract_dynamic ref_name (encoding encoding)
    | Describe {| id := ref_name; encoding := encoding |} =>
      extract_dynamic (Some ref_name) (encoding encoding)
    | Splitted {| encoding := encoding |} =>
      extract_dynamic ref_name (encoding encoding)
    | Delayed f => extract_dynamic ref_name (encoding (f tt))
    | Dynamic_size {| kind := kind; encoding := encoding |} =>
      ((Some kind), ref_name, (P (encoding encoding)))
    | enc => (None, ref_name, (P enc))
    end in
  let fix field_descr {a : Type}
    (recursives : recursives) (references : references) (function_parameter :
    Tezos_data_encoding.Encoding.field a)
    : (list Tezos_data_encoding.Binary_schema.field_descr) * references :=
    match function_parameter with
    |
      Req {| name := name; encoding := {| encoding := encoding |} |} |
        Dft {| name := name; encoding := {| encoding := encoding |} |} =>
      match extract_dynamic None encoding with
      | (dynamics, ref_name, P field) =>
        match layout ref_name recursives references field with
        | (layout, references) =>
          if equiv_decb layout Zero_width then
            ([], references)
          else
            let field_descr :=
              Binary_schema.Named_field name
                (Tezos_data_encoding.Encoding.classify_desc field) layout in
            match dynamics with
            | Some kind =>
              ((cons (Dynamic_size_field ref_name 1 kind) (cons field_descr [])),
                references)
            | None => ((cons field_descr []), references)
            end
        end
      end
    |
      Opt {|
        name := name;
          kind := Variable;
          encoding := {| encoding := encoding |}
          |} =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons (Named_field name variant layout) []), references)
      end
    |
      Opt {|
        name := name;
          kind := Dynamic;
          encoding := {| encoding := encoding |}
          |} =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons (Binary_schema.Optional_field name)
          (cons
            (Named_field name
              (Tezos_data_encoding.Encoding.classify_desc encoding) layout) [])),
          references)
      end
    end
  with obj (fields : Tezos_data_encoding.Binary_schema.fields)
    : Tezos_data_encoding.Binary_schema.toplevel_encoding :=
    Binary_schema.Obj {| fields := fields |}
  with union {a : Type}
    (ref_name : option string) (recursives : recursives) (references :
    references) (kind : Tezos_data_encoding.Encoding.Kind.t) (size :
    Tezos_data_encoding.Binary_size.tag_size) (cases :
    list (Tezos_data_encoding.Encoding.case a)) : string * references :=
    let cases :=
      apply
        (Stdlib.List.sort
          (fun function_parameter =>
            match function_parameter with
            | (t1, _) =>
              fun function_parameter =>
                match function_parameter with
                | (t2, _) => OCaml.Stdlib.compare t1 t2
                end
            end))
        (Stdlib.List.fold_left
          (fun acc =>
            fun case =>
              match case with
              | Case {| tag := Json_only |} => acc
              | Case {| tag := Tag tag |} => cons (tag, case) acc
              end) [] cases) in
    let tag_field := Binary_schema.Named_field "Tag" % string variant (Int size)
      in
    match
      Stdlib.List.fold_right
        (fun function_parameter =>
          match function_parameter with
          | (tag, Case case) =>
            fun function_parameter =>
              match function_parameter with
              | (cases, references) =>
                match
                  fields None recursives references (encoding (encoding case))
                  with
                | (fields, references) =>
                  ((cons (tag, (Some (title case)), (cons tag_field fields))
                    cases), references)
                end
              end
          end) cases ([], references) with
    | (cases, references) =>
      let name := may_new_reference ref_name in
      let references :=
        add_reference name
          (Cases {| kind := kind; tag_size := size; cases := cases |})
          references in
      (name, references)
    end
  with describe {b : Type}
    (description : option string) (title : string) (name : string) (recursives :
    recursives) (references : references) (encoding :
    Tezos_data_encoding.Encoding.desc b) : string * references :=
    let new_cannonical :=
      {| Binary_schema.title := title; Binary_schema.description := description
        |} in
    UF.add uf new_cannonical;
    match layout None recursives references encoding with
    | (layout, references) =>
      match layout with
      | Ref ref_name =>
        UF.union uf new_cannonical ref_name;
        (ref_name, references)
      | layout =>
        UF.add uf new_cannonical;
        (name,
          (add_reference name
            (obj
              (cons
                (Anonymous_field
                  (Tezos_data_encoding.Encoding.classify_desc encoding) layout)
                [])) references))
      end
    end
  with enum {a : Type}
    (tbl : Stdlib.Hashtbl.t a (string * Z)) (encoding_array : array a)
    : Tezos_data_encoding.Binary_size.integer * (list (Z * string)) :=
    ((Tezos_data_encoding.Binary_size.range_to_size 0
      (Stdlib.Array.length encoding_array)),
      (List.map
        (fun i =>
          (i,
            (apply fst
              (Stdlib.Hashtbl.find tbl (Stdlib.Array.get encoding_array i)))))
        (Stdlib.List.init (Stdlib.Array.length encoding_array) (fun i => i))))
  with fields {b : Type}
    (ref_name : option string) (recursives : recursives) (references :
    references) (function_parameter : Tezos_data_encoding.Encoding.desc b)
    : Tezos_data_encoding.Binary_schema.fields * references :=
    match function_parameter with
    | Obj field => field_descr recursives references field
    | Objs {| left := left; right := right |} =>
      match fields None recursives references (encoding left) with
      | (left_fields, references) =>
        match fields None recursives references (encoding right) with
        | (right_fields, references) =>
          ((OCaml.Stdlib.app left_fields right_fields), references)
        end
      end
    | Null => ((cons (Anonymous_field variant Zero_width) []), references)
    | Empty => ((cons (Anonymous_field variant Zero_width) []), references)
    | Ignore => ((cons (Anonymous_field variant Zero_width) []), references)
    | Constant _ => ((cons (Anonymous_field variant Zero_width) []), references)
    | Dynamic_size {| kind := kind; encoding := encoding |} =>
      match fields None recursives references (encoding encoding) with
      | (fields, refs) =>
        ((cons (Dynamic_size_field None (OCaml.List.length fields) kind) fields),
          refs)
      end
    | Check_size {| encoding := encoding |} =>
      fields ref_name recursives references (encoding encoding)
    | Conv {| encoding := encoding |} =>
      fields ref_name recursives references (encoding encoding)
    | Describe {| id := name; encoding := encoding |} =>
      fields (Some name) recursives references (encoding encoding)
    | Splitted {| encoding := encoding |} =>
      fields ref_name recursives references (encoding encoding)
    | Delayed func => fields ref_name recursives references (encoding (func tt))
    | List len {| encoding := encoding |} =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons (Anonymous_field variant (Seq layout len)) []), references)
      end
    | Array len {| encoding := encoding |} =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons (Anonymous_field variant (Seq layout len)) []), references)
      end
    | Bytes kind => ((cons (Anonymous_field kind Bytes) []), references)
    | String kind => ((cons (Anonymous_field kind String) []), references)
    | Padded {| encoding := e |} n =>
      match fields ref_name recursives references e with
      | (fields, references) =>
        ((OCaml.Stdlib.app fields
          (cons (Named_field "padding" % string variant Padding) [])),
          references)
      end
    | (String_enum tbl encoding_array) as encoding =>
      match enum tbl encoding_array with
      | (size, cases) =>
        let name := may_new_reference ref_name in
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            (Ref name)) []),
          (add_reference name (Int_enum {| size := size; cases := cases |})
            references))
      end
    | Tup {| encoding := encoding |} =>
      match layout ref_name recursives references encoding with
      | (layout, references) =>
        if equiv_decb layout Zero_width then
          ([], references)
        else
          ((cons
            (Anonymous_field
              (Tezos_data_encoding.Encoding.classify_desc encoding) layout) []),
            references)
      end
    | Tups {| left := left; right := right |} =>
      match fields None recursives references (encoding left) with
      | (fields1, references) =>
        match fields None recursives references (encoding right) with
        | (fields2, references) =>
          ((OCaml.Stdlib.app fields1 fields2), references)
        end
      end
    | Union {| kind := kind; tag_size := tag_size; cases := cases |} =>
      match union None recursives references kind tag_size cases with
      | (name, references) =>
        ((cons (Anonymous_field kind (Ref name)) []), references)
      end
    |
      (Mu {|
        kind := kind;
          name := name;
          title := title;
          description := description;
          fix := fix
          |}) as encoding =>
      let kind := kind in
      let title :=
        match title with
        | Some title => title
        | None => name
        end in
      if Stdlib.List.mem name recursives then
        ((cons (Anonymous_field kind (Ref name)) []), references)
      else
        match fix {| encoding := encoding; json_encoding := None |} with
        | {| encoding := encoding |} =>
          match
            describe description title name (cons name recursives) references
              encoding with
          | (name, references) =>
            ((cons (Anonymous_field kind (Ref name)) []), references)
          end
        end
    | Bool as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Int8 as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Uint8 as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Int16 as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Uint16 as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Int31 as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Int32 as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Int64 as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | N as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Z as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | (RangedInt _) as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | (RangedFloat _) as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    | Float as encoding =>
      match layout None recursives references encoding with
      | (layout, references) =>
        ((cons
          (Anonymous_field (Tezos_data_encoding.Encoding.classify_desc encoding)
            layout) []), references)
      end
    end
  with layout {c : Type}
    (ref_name : option string) (recursives : recursives) (references :
    references) (function_parameter : Tezos_data_encoding.Encoding.desc c)
    : Tezos_data_encoding.Binary_schema.layout * references :=
    match function_parameter with
    | Null => (Zero_width, references)
    | Empty => (Zero_width, references)
    | Ignore => (Zero_width, references)
    | Constant _ => (Zero_width, references)
    | Bool => (Bool, references)
    | Int8 => ((Int variant), references)
    | Uint8 => ((Int variant), references)
    | Int16 => ((Int variant), references)
    | Uint16 => ((Int variant), references)
    | Int31 => ((RangedInt (Z.opp 1073741824) 1073741823), references)
    | Int32 => ((Int variant), references)
    | Int64 => ((Int variant), references)
    | N => ((Ref n_reference_name), (add_n_reference uf references))
    | Z => ((Ref z_reference_name), (add_z_reference uf references))
    | RangedInt {| minimum := minimum; maximum := maximum |} =>
      ((RangedInt minimum maximum), references)
    | RangedFloat {| minimum := minimum; maximum := maximum |} =>
      ((RangedFloat minimum maximum), references)
    | Float => (Float, references)
    | Bytes _kind => (Bytes, references)
    | String _kind => (String, references)
    | (Padded _ _) as enc =>
      let name := may_new_reference ref_name in
      match fields None recursives references enc with
      | (fields, references) =>
        let references := add_reference name (obj fields) references in
        ((Ref name), references)
      end
    | String_enum tbl encoding_array =>
      let name := may_new_reference ref_name in
      match enum tbl encoding_array with
      | (size, cases) =>
        let references :=
          add_reference name (Int_enum {| size := size; cases := cases |})
            references in
        ((Enum size name), references)
      end
    | Array len data =>
      match layout None recursives references (encoding data) with
      | (descr, references) => ((Seq descr len), references)
      end
    | List len data =>
      match layout None recursives references (encoding data) with
      | (layout, references) => ((Seq layout len), references)
      end
    |
      Obj (Req {| encoding := {| encoding := encoding |} |}) |
        Obj (Dft {| encoding := {| encoding := encoding |} |}) =>
      layout ref_name recursives references encoding
    | (Obj (Opt _)) as enc =>
      let name := may_new_reference ref_name in
      match fields None recursives references enc with
      | (fields, references) =>
        let references := add_reference name (obj fields) references in
        ((Ref name), references)
      end
    | Objs {| left := left; right := right |} =>
      let name := may_new_reference ref_name in
      match fields None recursives references (encoding left) with
      | (fields1, references) =>
        match fields None recursives references (encoding right) with
        | (fields2, references) =>
          let references :=
            add_reference name (obj (OCaml.Stdlib.app fields1 fields2))
              references in
          ((Ref name), references)
        end
      end
    | Tup {| encoding := encoding |} =>
      layout ref_name recursives references encoding
    | (Tups _) as descr =>
      let name := may_new_reference ref_name in
      match fields None recursives references descr with
      | (fields, references) =>
        let references := add_reference name (obj fields) references in
        ((Ref name), references)
      end
    | Union {| kind := kind; tag_size := tag_size; cases := cases |} =>
      match union ref_name recursives references kind tag_size cases with
      | (name, references) => ((Ref name), references)
      end
    |
      (Mu {|
        name := name;
          title := title;
          description := description;
          fix := fix
          |}) as encoding =>
      let title :=
        match title with
        | Some title => title
        | None => name
        end in
      if Stdlib.List.mem name recursives then
        ((Ref name), references)
      else
        match fix {| encoding := encoding; json_encoding := None |} with
        | {| encoding := encoding |} =>
          match
            describe description title name (cons name recursives) references
              encoding with
          | (name, references) => ((Ref name), references)
          end
        end
    | Conv {| encoding := encoding |} =>
      layout ref_name recursives references (encoding encoding)
    | Describe {| id := name; encoding := encoding |} =>
      layout (Some name) recursives references (encoding encoding)
    | Splitted {| encoding := encoding |} =>
      layout ref_name recursives references (encoding encoding)
    | (Dynamic_size _) as encoding =>
      let name := may_new_reference ref_name in
      match fields None recursives references encoding with
      | (fields, references) =>
        UF.add uf {| title := name; description := None |};
        ((Ref name), (add_reference name (obj fields) references))
      end
    | Check_size {| encoding := encoding |} =>
      layout ref_name recursives references (encoding encoding)
    | Delayed func => layout ref_name recursives references (encoding (func tt))
    end in
  match fields None [] {| descriptions := [] |} (encoding encoding) with
  | (fields, references) =>
    uf_add_name "" % string;
    match
      Stdlib.List.hd
        (dedup_canonicalize uf (cons ("" % string, (obj fields)) [])) with
    | (_, toplevel) =>
      let filtered :=
        Stdlib.List.filter
          (fun function_parameter =>
            match function_parameter with
            | (name, encoding) =>
              match encoding with
              |
                Binary_schema.Obj {|
                  fields := cons (Anonymous_field _ (Ref reference)) [] |}
                =>
                UF.union uf (UF.find uf name) reference;
                false
              | _ => true
              end
            end) (descriptions references) in
      let fields := List.rev (dedup_canonicalize uf filtered) in
      {| Binary_schema.toplevel := toplevel; Binary_schema.fields := fields |}
    end
  end.
src/lib_data_encoding/binary_description.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val describe : 'a Encoding.t -> Binary_schema.t
src/lib_data_encoding/binary_description.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter describe : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> Tezos_data_encoding.Binary_schema.t.
src/lib_data_encoding/binary_error.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type read_error =
  | Not_enough_data
  | Extra_bytes
  | No_case_matched
  | Unexpected_tag of int
  | Invalid_size of int
  | Invalid_int of {min : int; v : int; max : int}
  | Invalid_float of {min : float; v : float; max : float}
  | Trailing_zero
  | Size_limit_exceeded
  | List_too_long
  | Array_too_long

let pp_read_error ppf = function
  | Not_enough_data ->
      Format.fprintf ppf "Not enough data"
  | Extra_bytes ->
      Format.fprintf ppf "Extra bytes"
  | No_case_matched ->
      Format.fprintf ppf "No case matched"
  | Unexpected_tag tag ->
      Format.fprintf ppf "Unexpected tag %d" tag
  | Invalid_size sz ->
      Format.fprintf ppf "Invalid size %d" sz
  | Invalid_int {min; v; max} ->
      Format.fprintf ppf "Invalid int (%d <= %d <= %d) " min v max
  | Invalid_float {min; v; max} ->
      Format.fprintf ppf "Invalid float (%f <= %f <= %f) " min v max
  | Trailing_zero ->
      Format.fprintf ppf "Trailing zero in Z"
  | Size_limit_exceeded ->
      Format.fprintf ppf "Size limit exceeded"
  | List_too_long ->
      Format.fprintf ppf "List length limit exceeded"
  | Array_too_long ->
      Format.fprintf ppf "Array length limit exceeded"

exception Read_error of read_error

type write_error =
  | Size_limit_exceeded
  | No_case_matched
  | Invalid_int of {min : int; v : int; max : int}
  | Invalid_float of {min : float; v : float; max : float}
  | Invalid_bytes_length of {expected : int; found : int}
  | Invalid_string_length of {expected : int; found : int}
  | Invalid_natural
  | List_too_long
  | Array_too_long

let pp_write_error ppf = function
  | Size_limit_exceeded ->
      Format.fprintf ppf "Size limit exceeded"
  | No_case_matched ->
      Format.fprintf ppf "No case matched"
  | Invalid_int {min; v; max} ->
      Format.fprintf ppf "Invalid int (%d <= %d <= %d) " min v max
  | Invalid_float {min; v; max} ->
      Format.fprintf ppf "Invalid float (%f <= %f <= %f) " min v max
  | Invalid_bytes_length {expected; found} ->
      Format.fprintf
        ppf
        "Invalid bytes length (expected: %d ; found %d)"
        expected
        found
  | Invalid_string_length {expected; found} ->
      Format.fprintf
        ppf
        "Invalid string length (expected: %d ; found %d)"
        expected
        found
  | Invalid_natural ->
      Format.fprintf ppf "Negative natural"
  | List_too_long ->
      Format.fprintf ppf "List length limit exceeded"
  | Array_too_long ->
      Format.fprintf ppf "Array length limit exceeded"

exception Write_error of write_error
src/lib_data_encoding/binary_error.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive read_error : Type :=
| Not_enough_data : read_error
| Extra_bytes : read_error
| No_case_matched : read_error
| Unexpected_tag : Z -> read_error
| Invalid_size : Z -> read_error
| Invalid_int : Z -> Z -> Z -> read_error
| Invalid_float : float -> float -> float -> read_error
| Trailing_zero : read_error
| Size_limit_exceeded : read_error
| List_too_long : read_error
| Array_too_long : read_error.

Definition pp_read_error
  (ppf : Stdlib.Format.formatter) (function_parameter : read_error) : unit :=
  match function_parameter with
  | Not_enough_data =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Not enough data" % string
          CamlinternalFormatBasics.End_of_format) "Not enough data" % string)
  | Extra_bytes =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Extra bytes" % string
          CamlinternalFormatBasics.End_of_format) "Extra bytes" % string)
  | No_case_matched =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "No case matched" % string
          CamlinternalFormatBasics.End_of_format) "No case matched" % string)
  | Unexpected_tag tag =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Unexpected tag " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format))
        "Unexpected tag %d" % string) tag
  | Invalid_size sz =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid size " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "Invalid size %d" % string)
      sz
  | Invalid_int {| min := min; v := v; max := max |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid int (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " <= " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " <= " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") " % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid int (%d <= %d <= %d) " % string) min v max
  | Invalid_float {| min := min; v := v; max := max |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid float (" % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " <= " % string
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " <= " % string
                  (CamlinternalFormatBasics.Float
                    CamlinternalFormatBasics.Float_f
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") " % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid float (%f <= %f <= %f) " % string) min v max
  | Trailing_zero =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Trailing zero in Z" % string
          CamlinternalFormatBasics.End_of_format) "Trailing zero in Z" % string)
  | Size_limit_exceeded =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Size limit exceeded" % string
          CamlinternalFormatBasics.End_of_format) "Size limit exceeded" % string)
  | List_too_long =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "List length limit exceeded" % string
          CamlinternalFormatBasics.End_of_format)
        "List length limit exceeded" % string)
  | Array_too_long =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Array length limit exceeded" % string
          CamlinternalFormatBasics.End_of_format)
        "Array length limit exceeded" % string)
  end.

Inductive write_error : Type :=
| Size_limit_exceeded : write_error
| No_case_matched : write_error
| Invalid_int : Z -> Z -> Z -> write_error
| Invalid_float : float -> float -> float -> write_error
| Invalid_bytes_length : Z -> Z -> write_error
| Invalid_string_length : Z -> Z -> write_error
| Invalid_natural : write_error
| List_too_long : write_error
| Array_too_long : write_error.

Definition pp_write_error
  (ppf : Stdlib.Format.formatter) (function_parameter : write_error) : unit :=
  match function_parameter with
  | Size_limit_exceeded =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Size limit exceeded" % string
          CamlinternalFormatBasics.End_of_format) "Size limit exceeded" % string)
  | No_case_matched =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "No case matched" % string
          CamlinternalFormatBasics.End_of_format) "No case matched" % string)
  | Invalid_int {| min := min; v := v; max := max |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid int (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " <= " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " <= " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") " % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid int (%d <= %d <= %d) " % string) min v max
  | Invalid_float {| min := min; v := v; max := max |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid float (" % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " <= " % string
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " <= " % string
                  (CamlinternalFormatBasics.Float
                    CamlinternalFormatBasics.Float_f
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") " % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid float (%f <= %f <= %f) " % string) min v max
  | Invalid_bytes_length {| expected := expected; found := found |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Invalid bytes length (expected: " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " ; found " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "Invalid bytes length (expected: %d ; found %d)" % string) expected
      found
  | Invalid_string_length {| expected := expected; found := found |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Invalid string length (expected: " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " ; found " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "Invalid string length (expected: %d ; found %d)" % string) expected
      found
  | Invalid_natural =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Negative natural" % string
          CamlinternalFormatBasics.End_of_format) "Negative natural" % string)
  | List_too_long =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "List length limit exceeded" % string
          CamlinternalFormatBasics.End_of_format)
        "List length limit exceeded" % string)
  | Array_too_long =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Array length limit exceeded" % string
          CamlinternalFormatBasics.End_of_format)
        "Array length limit exceeded" % string)
  end.
src/lib_data_encoding/binary_error.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Binary}. *)

type read_error =
  | Not_enough_data
  | Extra_bytes
  | No_case_matched
  | Unexpected_tag of int
  | Invalid_size of int
  | Invalid_int of {min : int; v : int; max : int}
  | Invalid_float of {min : float; v : float; max : float}
  | Trailing_zero
  | Size_limit_exceeded
  | List_too_long
  | Array_too_long

exception Read_error of read_error

val pp_read_error : Format.formatter -> read_error -> unit

type write_error =
  | Size_limit_exceeded
  | No_case_matched
  | Invalid_int of {min : int; v : int; max : int}
  | Invalid_float of {min : float; v : float; max : float}
  | Invalid_bytes_length of {expected : int; found : int}
  | Invalid_string_length of {expected : int; found : int}
  | Invalid_natural
  | List_too_long
  | Array_too_long

val pp_write_error : Format.formatter -> write_error -> unit

exception Write_error of write_error
src/lib_data_encoding/binary_error.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive read_error : Type :=
| Not_enough_data : read_error
| Extra_bytes : read_error
| No_case_matched : read_error
| Unexpected_tag : Z -> read_error
| Invalid_size : Z -> read_error
| Invalid_int : Z -> Z -> Z -> read_error
| Invalid_float : float -> float -> float -> read_error
| Trailing_zero : read_error
| Size_limit_exceeded : read_error
| List_too_long : read_error
| Array_too_long : read_error.

exception

Parameter pp_read_error : Stdlib.Format.formatter -> read_error -> unit.

Inductive write_error : Type :=
| Size_limit_exceeded : write_error
| No_case_matched : write_error
| Invalid_int : Z -> Z -> Z -> write_error
| Invalid_float : float -> float -> float -> write_error
| Invalid_bytes_length : Z -> Z -> write_error
| Invalid_string_length : Z -> Z -> write_error
| Invalid_natural : write_error
| List_too_long : write_error
| Array_too_long : write_error.

Parameter pp_write_error : Stdlib.Format.formatter -> write_error -> unit.

exception
src/lib_data_encoding/binary_length.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Binary_error

let n_length value =
  let bits = Z.numbits value in
  if bits = 0 then 1 else (bits + 6) / 7

let z_length value = (Z.numbits value + 1 + 6) / 7

let rec length : type x. x Encoding.t -> x -> int =
 fun e value ->
  let open Encoding in
  match e.encoding with
  (* Fixed *)
  | Null ->
      0
  | Empty ->
      0
  | Constant _ ->
      0
  | Bool ->
      Binary_size.bool
  | Int8 ->
      Binary_size.int8
  | Uint8 ->
      Binary_size.uint8
  | Int16 ->
      Binary_size.int16
  | Uint16 ->
      Binary_size.uint16
  | Int31 ->
      Binary_size.int31
  | Int32 ->
      Binary_size.int32
  | Int64 ->
      Binary_size.int64
  | N ->
      n_length value
  | Z ->
      z_length value
  | RangedInt {minimum; maximum} ->
      Binary_size.integer_to_size
      @@ Binary_size.range_to_size ~minimum ~maximum
  | Float ->
      Binary_size.float
  | RangedFloat _ ->
      Binary_size.float
  | Bytes (`Fixed n) ->
      n
  | String (`Fixed n) ->
      n
  | Padded (e, n) ->
      length e value + n
  | String_enum (_, arr) ->
      Binary_size.integer_to_size @@ Binary_size.enum_size arr
  | Objs {kind = `Fixed n; _} ->
      n
  | Tups {kind = `Fixed n; _} ->
      n
  | Union {kind = `Fixed n; _} ->
      n
  (* Dynamic *)
  | Objs {kind = `Dynamic; left; right} ->
      let (v1, v2) = value in
      length left v1 + length right v2
  | Tups {kind = `Dynamic; left; right} ->
      let (v1, v2) = value in
      length left v1 + length right v2
  | Union {kind = `Dynamic; tag_size; cases} ->
      let rec length_case = function
        | [] ->
            raise (Write_error No_case_matched)
        | Case {tag = Json_only; _} :: tl ->
            length_case tl
        | Case {encoding = e; proj; _} :: tl -> (
          match proj value with
          | None ->
              length_case tl
          | Some value ->
              Binary_size.tag_size tag_size + length e value )
      in
      length_case cases
  | Mu {kind = `Dynamic; fix; _} ->
      length (fix e) value
  | Obj (Opt {kind = `Dynamic; encoding = e; _}) -> (
    match value with None -> 1 | Some value -> 1 + length e value )
  (* Variable *)
  | Ignore ->
      0
  | Bytes `Variable ->
      Bytes.length value
  | String `Variable ->
      String.length value
  | Array (Some max_length, _e) when Array.length value > max_length ->
      raise (Write_error Array_too_long)
  | Array (_, e) ->
      Array.fold_left (fun acc v -> length e v + acc) 0 value
  | List (Some max_length, _e) when List.length value > max_length ->
      raise (Write_error List_too_long)
  | List (_, e) ->
      List.fold_left (fun acc v -> length e v + acc) 0 value
  | Objs {kind = `Variable; left; right} ->
      let (v1, v2) = value in
      length left v1 + length right v2
  | Tups {kind = `Variable; left; right} ->
      let (v1, v2) = value in
      length left v1 + length right v2
  | Obj (Opt {kind = `Variable; encoding = e; _}) -> (
    match value with None -> 0 | Some value -> length e value )
  | Union {kind = `Variable; tag_size; cases} ->
      let rec length_case = function
        | [] ->
            raise (Write_error No_case_matched)
        | Case {tag = Json_only; _} :: tl ->
            length_case tl
        | Case {encoding = e; proj; _} :: tl -> (
          match proj value with
          | None ->
              length_case tl
          | Some value ->
              Binary_size.tag_size tag_size + length e value )
      in
      length_case cases
  | Mu {kind = `Variable; fix; _} ->
      length (fix e) value
  (* Recursive*)
  | Obj (Req {encoding = e; _}) ->
      length e value
  | Obj (Dft {encoding = e; _}) ->
      length e value
  | Tup e ->
      length e value
  | Conv {encoding = e; proj; _} ->
      length e (proj value)
  | Describe {encoding = e; _} ->
      length e value
  | Splitted {encoding = e; _} ->
      length e value
  | Dynamic_size {kind; encoding = e} ->
      let length = length e value in
      Binary_size.integer_to_size kind + length
  | Check_size {limit; encoding = e} ->
      let length = length e value in
      if length > limit then raise (Write_error Size_limit_exceeded) ;
      length
  | Delayed f ->
      length (f ()) value

let fixed_length e =
  match Encoding.classify e with
  | `Fixed n ->
      Some n
  | `Dynamic | `Variable ->
      None

let fixed_length_exn e =
  match fixed_length e with
  | Some n ->
      n
  | None ->
      invalid_arg "Data_encoding.Binary.fixed_length_exn"
src/lib_data_encoding/binary_length.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Binary_error.

Definition n_length (value : Z.t) : Z :=
  let bits := Z.numbits value in
  if equiv_decb bits 0 then
    1
  else
    Z.div (Z.add bits 6) 7.

Definition z_length (value : Z.t) : Z :=
  Z.div (Z.add (Z.add (Z.numbits value) 1) 6) 7.

Fixpoint length {x : Type} (e : Tezos_data_encoding.Encoding.t x) (value : x)
  : Z :=
  match encoding e with
  | Null => 0
  | Empty => 0
  | Constant _ => 0
  | Bool => Tezos_data_encoding.Binary_size.bool
  | Int8 => Tezos_data_encoding.Binary_size.int8
  | Uint8 => Tezos_data_encoding.Binary_size.uint8
  | Int16 => Tezos_data_encoding.Binary_size.int16
  | Uint16 => Tezos_data_encoding.Binary_size.uint16
  | Int31 => Tezos_data_encoding.Binary_size.int31
  | Int32 => Tezos_data_encoding.Binary_size.int32
  | Int64 => Tezos_data_encoding.Binary_size.int64
  | N => n_length value
  | Z => z_length value
  | RangedInt {| minimum := minimum; maximum := maximum |} =>
    apply Tezos_data_encoding.Binary_size.integer_to_size
      (Tezos_data_encoding.Binary_size.range_to_size minimum maximum)
  | Float => Tezos_data_encoding.Binary_size.float
  | RangedFloat _ => Tezos_data_encoding.Binary_size.float
  | Bytes (Fixed n) => n
  | String (Fixed n) => n
  | Padded e n => Z.add (length e value) n
  | String_enum _ arr =>
    apply Tezos_data_encoding.Binary_size.integer_to_size
      (Tezos_data_encoding.Binary_size.enum_size arr)
  | Objs {| kind := Fixed n |} => n
  | Tups {| kind := Fixed n |} => n
  | Union {| kind := Fixed n |} => n
  | Objs {| kind := Dynamic; left := left; right := right |} =>
    match value with
    | (v1, v2) => Z.add (length left v1) (length right v2)
    end
  | Tups {| kind := Dynamic; left := left; right := right |} =>
    match value with
    | (v1, v2) => Z.add (length left v1) (length right v2)
    end
  | Union {| kind := Dynamic; tag_size := tag_size; cases := cases |} =>
    let fix length_case
      (function_parameter : list (Tezos_data_encoding.Encoding.case x)) : Z :=
      match function_parameter with
      | [] => Stdlib.raise (Write_error No_case_matched)
      | cons (Case {| tag := Json_only |}) tl => length_case tl
      | cons (Case {| encoding := e; proj := proj |}) tl =>
        match proj value with
        | None => length_case tl
        | Some value =>
          Z.add (Tezos_data_encoding.Binary_size.tag_size tag_size)
            (length e value)
        end
      end in
    length_case cases
  | Mu {| kind := Dynamic; fix := fix |} => length (fix e) value
  | Obj (Opt {| kind := Dynamic; encoding := e |}) =>
    match value with
    | None => 1
    | Some value => Z.add 1 (length e value)
    end
  | Ignore => 0
  | Bytes Variable => String.length value
  | String Variable => OCaml.String.length value
  | Array _ e =>
    Stdlib.Array.fold_left (fun acc => fun v => Z.add (length e v) acc) 0 value
  | List _ e =>
    Stdlib.List.fold_left (fun acc => fun v => Z.add (length e v) acc) 0 value
  | Objs {| kind := Variable; left := left; right := right |} =>
    match value with
    | (v1, v2) => Z.add (length left v1) (length right v2)
    end
  | Tups {| kind := Variable; left := left; right := right |} =>
    match value with
    | (v1, v2) => Z.add (length left v1) (length right v2)
    end
  | Obj (Opt {| kind := Variable; encoding := e |}) =>
    match value with
    | None => 0
    | Some value => length e value
    end
  | Union {| kind := Variable; tag_size := tag_size; cases := cases |} =>
    let fix length_case
      (function_parameter : list (Tezos_data_encoding.Encoding.case x)) : Z :=
      match function_parameter with
      | [] => Stdlib.raise (Write_error No_case_matched)
      | cons (Case {| tag := Json_only |}) tl => length_case tl
      | cons (Case {| encoding := e; proj := proj |}) tl =>
        match proj value with
        | None => length_case tl
        | Some value =>
          Z.add (Tezos_data_encoding.Binary_size.tag_size tag_size)
            (length e value)
        end
      end in
    length_case cases
  | Mu {| kind := Variable; fix := fix |} => length (fix e) value
  | Obj (Req {| encoding := e |}) => length e value
  | Obj (Dft {| encoding := e |}) => length e value
  | Tup e => length e value
  | Conv {| proj := proj; encoding := e |} => length e (proj value)
  | Describe {| encoding := e |} => length e value
  | Splitted {| encoding := e |} => length e value
  | Dynamic_size {| kind := kind; encoding := e |} =>
    let length := length e value in
    Z.add (Tezos_data_encoding.Binary_size.integer_to_size kind) length
  | Check_size {| limit := limit; encoding := e |} =>
    let length := length e value in
    if OCaml.Stdlib.gt length limit then
      Stdlib.raise (Write_error Size_limit_exceeded)
    else
      tt;
    length
  | Delayed f => length (f tt) value
  end.

Definition fixed_length {A : Type} (e : Tezos_data_encoding.Encoding.encoding A)
  : option Z :=
  match Tezos_data_encoding.Encoding.classify e with
  | Fixed n => Some n
  | Dynamic | Variable => None
  end.

Definition fixed_length_exn {A : Type}
  (e : Tezos_data_encoding.Encoding.encoding A) : Z :=
  match fixed_length e with
  | Some n => n
  | None =>
    OCaml.Stdlib.invalid_arg "Data_encoding.Binary.fixed_length_exn" % string
  end.
src/lib_data_encoding/binary_length.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Binary}. *)

val length : 'a Encoding.t -> 'a -> int

val fixed_length : 'a Encoding.t -> int option

val fixed_length_exn : 'a Encoding.t -> int

val z_length : Z.t -> int

val n_length : Z.t -> int
src/lib_data_encoding/binary_length.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter length : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> a -> Z.

Parameter fixed_length : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> option Z.

Parameter fixed_length_exn : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> Z.

Parameter z_length : Z.t -> Z.

Parameter n_length : Z.t -> Z.
src/lib_data_encoding/binary_reader.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Binary_error

let raise e = raise (Read_error e)

type state = {
  buffer : Bytes.t;
  mutable offset : int;
  mutable remaining_bytes : int;
  mutable allowed_bytes : int option;
}

let check_allowed_bytes state size =
  match state.allowed_bytes with
  | Some len when len < size ->
      raise Size_limit_exceeded
  | Some len ->
      Some (len - size)
  | None ->
      None

let check_remaining_bytes state size =
  if state.remaining_bytes < size then raise Not_enough_data ;
  state.remaining_bytes - size

let read_atom size conv state =
  let offset = state.offset in
  state.remaining_bytes <- check_remaining_bytes state size ;
  state.allowed_bytes <- check_allowed_bytes state size ;
  state.offset <- state.offset + size ;
  conv state.buffer offset

(** Reader for all the atomic types. *)
module Atom = struct
  let uint8 = read_atom Binary_size.uint8 TzEndian.get_uint8

  let uint16 = read_atom Binary_size.int16 TzEndian.get_uint16

  let int8 = read_atom Binary_size.int8 TzEndian.get_int8

  let int16 = read_atom Binary_size.int16 TzEndian.get_int16

  let int32 = read_atom Binary_size.int32 TzEndian.get_int32

  let int64 = read_atom Binary_size.int64 TzEndian.get_int64

  let float = read_atom Binary_size.float TzEndian.get_double

  let bool state = int8 state <> 0

  let uint30 =
    read_atom Binary_size.uint30
    @@ fun buffer ofs ->
    let v = Int32.to_int (TzEndian.get_int32 buffer ofs) in
    if v < 0 then raise (Invalid_int {min = 0; v; max = (1 lsl 30) - 1}) ;
    v

  let int31 =
    read_atom Binary_size.int31
    @@ fun buffer ofs -> Int32.to_int (TzEndian.get_int32 buffer ofs)

  let int = function
    | `Int31 ->
        int31
    | `Int16 ->
        int16
    | `Int8 ->
        int8
    | `Uint30 ->
        uint30
    | `Uint16 ->
        uint16
    | `Uint8 ->
        uint8

  let ranged_int ~minimum ~maximum state =
    let read_int =
      match Binary_size.range_to_size ~minimum ~maximum with
      | `Int8 ->
          int8
      | `Int16 ->
          int16
      | `Int31 ->
          int31
      | `Uint8 ->
          uint8
      | `Uint16 ->
          uint16
      | `Uint30 ->
          uint30
    in
    let ranged = read_int state in
    let ranged = if minimum > 0 then ranged + minimum else ranged in
    if not (minimum <= ranged && ranged <= maximum) then
      raise (Invalid_int {min = minimum; v = ranged; max = maximum}) ;
    ranged

  let ranged_float ~minimum ~maximum state =
    let ranged = float state in
    if not (minimum <= ranged && ranged <= maximum) then
      raise (Invalid_float {min = minimum; v = ranged; max = maximum}) ;
    ranged

  let rec read_z res value bit_in_value state =
    let byte = uint8 state in
    let value = value lor ((byte land 0x7F) lsl bit_in_value) in
    let bit_in_value = bit_in_value + 7 in
    let (bit_in_value, value) =
      if bit_in_value < 8 then (bit_in_value, value)
      else (
        Buffer.add_char res (Char.unsafe_chr (value land 0xFF)) ;
        (bit_in_value - 8, value lsr 8) )
    in
    if byte land 0x80 = 0x80 then read_z res value bit_in_value state
    else (
      if bit_in_value > 0 then Buffer.add_char res (Char.unsafe_chr value) ;
      if byte = 0x00 then raise Trailing_zero ;
      Z.of_bits (Buffer.contents res) )

  let n state =
    let first = uint8 state in
    let first_value = first land 0x7F in
    if first land 0x80 = 0x80 then
      read_z (Buffer.create 100) first_value 7 state
    else Z.of_int first_value

  let z state =
    let first = uint8 state in
    let first_value = first land 0x3F in
    let sign = first land 0x40 <> 0 in
    if first land 0x80 = 0x80 then
      let n = read_z (Buffer.create 100) first_value 6 state in
      if sign then Z.neg n else n
    else
      let n = Z.of_int first_value in
      if sign then Z.neg n else n

  let string_enum arr state =
    let read_index =
      match Binary_size.enum_size arr with
      | `Uint8 ->
          uint8
      | `Uint16 ->
          uint16
      | `Uint30 ->
          uint30
    in
    let index = read_index state in
    if index >= Array.length arr then raise No_case_matched ;
    arr.(index)

  let fixed_length_bytes length =
    read_atom length @@ fun buf ofs -> Bytes.sub buf ofs length

  let fixed_length_string length =
    read_atom length @@ fun buf ofs -> Bytes.sub_string buf ofs length

  let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end

(** Main recursive reading function, in continuation passing style. *)
let rec read_rec : type ret. ret Encoding.t -> state -> ret =
 fun e state ->
  let open Encoding in
  match e.encoding with
  | Null ->
      ()
  | Empty ->
      ()
  | Constant _ ->
      ()
  | Ignore ->
      ()
  | Bool ->
      Atom.bool state
  | Int8 ->
      Atom.int8 state
  | Uint8 ->
      Atom.uint8 state
  | Int16 ->
      Atom.int16 state
  | Uint16 ->
      Atom.uint16 state
  | Int31 ->
      Atom.int31 state
  | Int32 ->
      Atom.int32 state
  | Int64 ->
      Atom.int64 state
  | N ->
      Atom.n state
  | Z ->
      Atom.z state
  | Float ->
      Atom.float state
  | Bytes (`Fixed n) ->
      Atom.fixed_length_bytes n state
  | Bytes `Variable ->
      Atom.fixed_length_bytes state.remaining_bytes state
  | String (`Fixed n) ->
      Atom.fixed_length_string n state
  | String `Variable ->
      Atom.fixed_length_string state.remaining_bytes state
  | Padded (e, n) ->
      let v = read_rec e state in
      ignore (Atom.fixed_length_string n state : string) ;
      v
  | RangedInt {minimum; maximum} ->
      Atom.ranged_int ~minimum ~maximum state
  | RangedFloat {minimum; maximum} ->
      Atom.ranged_float ~minimum ~maximum state
  | String_enum (_, arr) ->
      Atom.string_enum arr state
  | Array (max_length, e) ->
      let max_length = match max_length with Some l -> l | None -> max_int in
      let l = read_list List_too_long max_length e state in
      Array.of_list l
  | List (max_length, e) ->
      let max_length = match max_length with Some l -> l | None -> max_int in
      read_list Array_too_long max_length e state
  | Obj (Req {encoding = e; _}) ->
      read_rec e state
  | Obj (Dft {encoding = e; _}) ->
      read_rec e state
  | Obj (Opt {kind = `Dynamic; encoding = e; _}) ->
      let present = Atom.bool state in
      if not present then None else Some (read_rec e state)
  | Obj (Opt {kind = `Variable; encoding = e; _}) ->
      if state.remaining_bytes = 0 then None else Some (read_rec e state)
  | Objs {kind = `Fixed sz; left; right} ->
      ignore (check_remaining_bytes state sz : int) ;
      ignore (check_allowed_bytes state sz : int option) ;
      let left = read_rec left state in
      let right = read_rec right state in
      (left, right)
  | Objs {kind = `Dynamic; left; right} ->
      let left = read_rec left state in
      let right = read_rec right state in
      (left, right)
  | Objs {kind = `Variable; left; right} ->
      read_variable_pair left right state
  | Tup e ->
      read_rec e state
  | Tups {kind = `Fixed sz; left; right} ->
      ignore (check_remaining_bytes state sz : int) ;
      ignore (check_allowed_bytes state sz : int option) ;
      let left = read_rec left state in
      let right = read_rec right state in
      (left, right)
  | Tups {kind = `Dynamic; left; right} ->
      let left = read_rec left state in
      let right = read_rec right state in
      (left, right)
  | Tups {kind = `Variable; left; right} ->
      read_variable_pair left right state
  | Conv {inj; encoding; _} ->
      inj (read_rec encoding state)
  | Union {tag_size; cases; _} ->
      let ctag = Atom.tag tag_size state in
      let (Case {encoding; inj; _}) =
        try
          List.find
            (function
              | Case {tag = Tag tag; _} ->
                  tag = ctag
              | Case {tag = Json_only; _} ->
                  false)
            cases
        with Not_found -> raise (Unexpected_tag ctag)
      in
      inj (read_rec encoding state)
  | Dynamic_size {kind; encoding = e} ->
      let sz = Atom.int kind state in
      let remaining = check_remaining_bytes state sz in
      state.remaining_bytes <- sz ;
      ignore (check_allowed_bytes state sz : int option) ;
      let v = read_rec e state in
      if state.remaining_bytes <> 0 then raise Extra_bytes ;
      state.remaining_bytes <- remaining ;
      v
  | Check_size {limit; encoding = e} ->
      let old_allowed_bytes = state.allowed_bytes in
      let limit =
        match state.allowed_bytes with
        | None ->
            limit
        | Some current_limit ->
            min current_limit limit
      in
      state.allowed_bytes <- Some limit ;
      let v = read_rec e state in
      let allowed_bytes =
        match old_allowed_bytes with
        | None ->
            None
        | Some old_limit ->
            let remaining =
              match state.allowed_bytes with
              | None ->
                  assert false
              | Some remaining ->
                  remaining
            in
            let read = limit - remaining in
            Some (old_limit - read)
      in
      state.allowed_bytes <- allowed_bytes ;
      v
  | Describe {encoding = e; _} ->
      read_rec e state
  | Splitted {encoding = e; _} ->
      read_rec e state
  | Mu {fix; _} ->
      read_rec (fix e) state
  | Delayed f ->
      read_rec (f ()) state

and read_variable_pair :
    type left right.
    left Encoding.t -> right Encoding.t -> state -> left * right =
 fun e1 e2 state ->
  match (Encoding.classify e1, Encoding.classify e2) with
  | ((`Dynamic | `Fixed _), `Variable) ->
      let left = read_rec e1 state in
      let right = read_rec e2 state in
      (left, right)
  | (`Variable, `Fixed n) ->
      if n > state.remaining_bytes then raise Not_enough_data ;
      state.remaining_bytes <- state.remaining_bytes - n ;
      let left = read_rec e1 state in
      assert (state.remaining_bytes = 0) ;
      state.remaining_bytes <- n ;
      let right = read_rec e2 state in
      assert (state.remaining_bytes = 0) ;
      (left, right)
  | _ ->
      assert false

(* Should be rejected by [Encoding.Kind.combine] *)
and read_list : type a. read_error -> int -> a Encoding.t -> state -> a list =
 fun error max_length e state ->
  let rec loop max_length acc =
    if state.remaining_bytes = 0 then List.rev acc
    else if max_length = 0 then raise error
    else
      let v = read_rec e state in
      loop (max_length - 1) (v :: acc)
  in
  loop max_length []

(** ******************** *)

(** Various entry points *)

let read encoding buffer ofs len =
  let state =
    {buffer; offset = ofs; remaining_bytes = len; allowed_bytes = None}
  in
  match read_rec encoding state with
  | exception Read_error _ ->
      None
  | v ->
      Some (state.offset, v)

let of_bytes_exn encoding buffer =
  let len = Bytes.length buffer in
  let state =
    {buffer; offset = 0; remaining_bytes = len; allowed_bytes = None}
  in
  let v = read_rec encoding state in
  if state.offset <> len then raise Extra_bytes ;
  v

let of_bytes encoding buffer =
  try Some (of_bytes_exn encoding buffer) with Read_error _ -> None
src/lib_data_encoding/binary_reader.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Binary_error.

Definition raise {A : Type} (e : Tezos_data_encoding.Binary_error.read_error)
  : A := Stdlib.raise (Read_error e).

Record state := {
  buffer : Stdlib.Bytes.t;
  offset : Z;
  remaining_bytes : Z;
  allowed_bytes : option Z }.

Definition check_allowed_bytes (state : state) (size : Z) : option Z :=
  match allowed_bytes state with
  | Some len => Some (Z.sub len size)
  | None => None
  end.

Definition check_remaining_bytes (state : state) (size : Z) : Z :=
  if OCaml.Stdlib.lt (remaining_bytes state) size then
    raise Not_enough_data
  else
    tt;
  Z.sub (remaining_bytes state) size.

Definition read_atom {A : Type}
  (size : Z) (conv : Stdlib.Bytes.t -> Z -> A) (state : state) : A :=
  let offset := offset state in
  set_field;
  set_field;
  set_field;
  conv (buffer state) offset.

Module Atom.
  Definition uint8 : state -> Z :=
    read_atom Tezos_data_encoding.Binary_size.uint8
      Tezos_data_encoding.TzEndian.get_uint8.
  
  Definition uint16 : state -> Z :=
    read_atom Tezos_data_encoding.Binary_size.int16
      Tezos_data_encoding.TzEndian.get_uint16.
  
  Definition int8 : state -> Z :=
    read_atom Tezos_data_encoding.Binary_size.int8
      Tezos_data_encoding.TzEndian.get_int8.
  
  Definition int16 : state -> Z :=
    read_atom Tezos_data_encoding.Binary_size.int16
      Tezos_data_encoding.TzEndian.get_int16.
  
  Definition int32 : state -> int32 :=
    read_atom Tezos_data_encoding.Binary_size.int32
      Tezos_data_encoding.TzEndian.get_int32.
  
  Definition int64 : state -> int64 :=
    read_atom Tezos_data_encoding.Binary_size.int64
      Tezos_data_encoding.TzEndian.get_int64.
  
  Definition float : state -> float :=
    read_atom Tezos_data_encoding.Binary_size.float
      Tezos_data_encoding.TzEndian.get_double.
  
  Definition bool (state : state) : bool := nequiv_decb (int8 state) 0.
  
  Definition uint30 : state -> Z :=
    apply (read_atom Tezos_data_encoding.Binary_size.uint30)
      (fun buffer =>
        fun ofs =>
          let v :=
            Stdlib.Int32.to_int
              (Tezos_data_encoding.TzEndian.get_int32 buffer ofs) in
          if OCaml.Stdlib.lt v 0 then
            raise
              (Invalid_int
                {| min := 0; v := v; max := Z.sub (Z.shiftl 1 30) 1 |})
          else
            tt;
          v).
  
  Definition int31 : state -> Z :=
    apply (read_atom Tezos_data_encoding.Binary_size.int31)
      (fun buffer =>
        fun ofs =>
          Stdlib.Int32.to_int
            (Tezos_data_encoding.TzEndian.get_int32 buffer ofs)).
  
  Definition int (function_parameter : variant) : state -> Z :=
    match function_parameter with
    | Int31 => int31
    | Int16 => int16
    | Int8 => int8
    | Uint30 => uint30
    | Uint16 => uint16
    | Uint8 => uint8
    end.
  
  Definition ranged_int (minimum : Z) (maximum : Z) (state : state) : Z :=
    let read_int :=
      match Tezos_data_encoding.Binary_size.range_to_size minimum maximum with
      | Int8 => int8
      | Int16 => int16
      | Int31 => int31
      | Uint8 => uint8
      | Uint16 => uint16
      | Uint30 => uint30
      end in
    let ranged := read_int state in
    let ranged :=
      if OCaml.Stdlib.gt minimum 0 then
        Z.add ranged minimum
      else
        ranged in
    if
      negb
        (andb (OCaml.Stdlib.le minimum ranged) (OCaml.Stdlib.le ranged maximum))
      then
      raise (Invalid_int {| min := minimum; v := ranged; max := maximum |})
    else
      tt;
    ranged.
  
  Definition ranged_float (minimum : float) (maximum : float) (state : state)
    : float :=
    let ranged := float state in
    if
      negb
        (andb (OCaml.Stdlib.le minimum ranged) (OCaml.Stdlib.le ranged maximum))
      then
      raise (Invalid_float {| min := minimum; v := ranged; max := maximum |})
    else
      tt;
    ranged.
  
  Fixpoint read_z
    (res : Stdlib.Buffer.t) (value : Z) (bit_in_value : Z) (state : state)
    : Z.t :=
    let byte := uint8 state in
    let value := Z.lor value (Z.shiftl (Z.land byte 127) bit_in_value) in
    let bit_in_value := Z.add bit_in_value 7 in
    match
      if OCaml.Stdlib.lt bit_in_value 8 then
        (bit_in_value, value)
      else
        Stdlib.Buffer.add_char res (Stdlib.Char.unsafe_chr (Z.land value 255));
        ((Z.sub bit_in_value 8), (Z.shiftr value 8)) with
    | (bit_in_value, value) =>
      if equiv_decb (Z.land byte 128) 128 then
        read_z res value bit_in_value state
      else
        if OCaml.Stdlib.gt bit_in_value 0 then
          Stdlib.Buffer.add_char res (Stdlib.Char.unsafe_chr value)
        else
          tt;
        if equiv_decb byte 0 then
          raise Trailing_zero
        else
          tt;
        Z.of_bits (Stdlib.Buffer.contents res)
    end.
  
  Definition n (state : state) : Z.t :=
    let first := uint8 state in
    let first_value := Z.land first 127 in
    if equiv_decb (Z.land first 128) 128 then
      read_z (Stdlib.Buffer.create 100) first_value 7 state
    else
      Z.of_int first_value.
  
  Definition z (state : state) : Z.t :=
    let first := uint8 state in
    let first_value := Z.land first 63 in
    let sign := nequiv_decb (Z.land first 64) 0 in
    if equiv_decb (Z.land first 128) 128 then
      let n := read_z (Stdlib.Buffer.create 100) first_value 6 state in
      if sign then
        Z.neg n
      else
        n
    else
      let n := Z.of_int first_value in
      if sign then
        Z.neg n
      else
        n.
  
  Definition string_enum {A : Type} (arr : array A) (state : state) : A :=
    let read_index :=
      match Tezos_data_encoding.Binary_size.enum_size arr with
      | Uint8 => uint8
      | Uint16 => uint16
      | Uint30 => uint30
      end in
    let index := read_index state in
    if OCaml.Stdlib.ge index (Stdlib.Array.length arr) then
      raise No_case_matched
    else
      tt;
    Stdlib.Array.get arr index.
  
  Definition fixed_length_bytes (length : Z) : state -> string :=
    apply (read_atom length) (fun buf => fun ofs => String.sub buf ofs length).
  
  Definition fixed_length_string (length : Z) : state -> string :=
    apply (read_atom length)
      (fun buf => fun ofs => Stdlib.Bytes.sub_string buf ofs length).
  
  Definition tag (function_parameter : variant) : state -> Z :=
    match function_parameter with
    | Uint8 => uint8
    | Uint16 => uint16
    end.
End Atom.

Fixpoint read_rec {ret : Type}
  (e : Tezos_data_encoding.Encoding.t ret) (state : state) : ret :=
  match encoding e with
  | Null => tt
  | Empty => tt
  | Constant _ => tt
  | Ignore => tt
  | Bool => Atom.bool state
  | Int8 => Atom.int8 state
  | Uint8 => Atom.uint8 state
  | Int16 => Atom.int16 state
  | Uint16 => Atom.uint16 state
  | Int31 => Atom.int31 state
  | Int32 => Atom.int32 state
  | Int64 => Atom.int64 state
  | N => Atom.n state
  | Z => Atom.z state
  | Float => Atom.float state
  | Bytes (Fixed n) => Atom.fixed_length_bytes n state
  | Bytes Variable => Atom.fixed_length_bytes (remaining_bytes state) state
  | String (Fixed n) => Atom.fixed_length_string n state
  | String Variable => Atom.fixed_length_string (remaining_bytes state) state
  | Padded e n =>
    let v := read_rec e state in
    OCaml.Stdlib.ignore (Atom.fixed_length_string n state);
    v
  | RangedInt {| minimum := minimum; maximum := maximum |} =>
    Atom.ranged_int minimum maximum state
  | RangedFloat {| minimum := minimum; maximum := maximum |} =>
    Atom.ranged_float minimum maximum state
  | String_enum _ arr => Atom.string_enum arr state
  | Array max_length e =>
    let max_length :=
      match max_length with
      | Some l => l
      | None => Stdlib.max_int
      end in
    let l := read_list List_too_long max_length e state in
    Stdlib.Array.of_list l
  | List max_length e =>
    let max_length :=
      match max_length with
      | Some l => l
      | None => Stdlib.max_int
      end in
    read_list Array_too_long max_length e state
  | Obj (Req {| encoding := e |}) => read_rec e state
  | Obj (Dft {| encoding := e |}) => read_rec e state
  | Obj (Opt {| kind := Dynamic; encoding := e |}) =>
    let present := Atom.bool state in
    if negb present then
      None
    else
      Some (read_rec e state)
  | Obj (Opt {| kind := Variable; encoding := e |}) =>
    if equiv_decb (remaining_bytes state) 0 then
      None
    else
      Some (read_rec e state)
  | Objs {| kind := Fixed sz; left := left; right := right |} =>
    OCaml.Stdlib.ignore (check_remaining_bytes state sz);
    OCaml.Stdlib.ignore (check_allowed_bytes state sz);
    let left := read_rec left state in
    let right := read_rec right state in
    (left, right)
  | Objs {| kind := Dynamic; left := left; right := right |} =>
    let left := read_rec left state in
    let right := read_rec right state in
    (left, right)
  | Objs {| kind := Variable; left := left; right := right |} =>
    read_variable_pair left right state
  | Tup e => read_rec e state
  | Tups {| kind := Fixed sz; left := left; right := right |} =>
    OCaml.Stdlib.ignore (check_remaining_bytes state sz);
    OCaml.Stdlib.ignore (check_allowed_bytes state sz);
    let left := read_rec left state in
    let right := read_rec right state in
    (left, right)
  | Tups {| kind := Dynamic; left := left; right := right |} =>
    let left := read_rec left state in
    let right := read_rec right state in
    (left, right)
  | Tups {| kind := Variable; left := left; right := right |} =>
    read_variable_pair left right state
  | Conv {| inj := inj; encoding := encoding |} => inj (read_rec encoding state)
  | Union {| tag_size := tag_size; cases := cases |} =>
    let ctag := Atom.tag tag_size state in
    match try with
    | Case {| encoding := encoding; inj := inj |} =>
      inj (read_rec encoding state)
    end
  | Dynamic_size {| kind := kind; encoding := e |} =>
    let sz := Atom.int kind state in
    let remaining := check_remaining_bytes state sz in
    set_field;
    OCaml.Stdlib.ignore (check_allowed_bytes state sz);
    let v := read_rec e state in
    if nequiv_decb (remaining_bytes state) 0 then
      raise Extra_bytes
    else
      tt;
    set_field;
    v
  | Check_size {| limit := limit; encoding := e |} =>
    let old_allowed_bytes := allowed_bytes state in
    let limit :=
      match allowed_bytes state with
      | None => limit
      | Some current_limit => OCaml.Stdlib.min current_limit limit
      end in
    set_field;
    let v := read_rec e state in
    let allowed_bytes :=
      match old_allowed_bytes with
      | None => None
      | Some old_limit =>
        let remaining :=
          match allowed_bytes state with
          | None => false
          | Some remaining => remaining
          end in
        let read := Z.sub limit remaining in
        Some (Z.sub old_limit read)
      end in
    set_field;
    v
  | Describe {| encoding := e |} => read_rec e state
  | Splitted {| encoding := e |} => read_rec e state
  | Mu {| fix := fix |} => read_rec (fix e) state
  | Delayed f => read_rec (f tt) state
  end

with read_variable_pair {left right : Type}
  (e1 : Tezos_data_encoding.Encoding.t left)
  (e2 : Tezos_data_encoding.Encoding.t right) (state : state) : left * right :=
  match
    ((Tezos_data_encoding.Encoding.classify e1),
      (Tezos_data_encoding.Encoding.classify e2)) with
  | (Dynamic | Fixed _, Variable) =>
    let left := read_rec e1 state in
    let right := read_rec e2 state in
    (left, right)
  | (Variable, Fixed n) =>
    if OCaml.Stdlib.gt n (remaining_bytes state) then
      raise Not_enough_data
    else
      tt;
    set_field;
    let left := read_rec e1 state in
    equiv_decb (remaining_bytes state) 0;
    set_field;
    let right := read_rec e2 state in
    equiv_decb (remaining_bytes state) 0;
    (left, right)
  | _ => false
  end

with read_list {a : Type}
  (error : Tezos_data_encoding.Binary_error.read_error) (max_length : Z)
  (e : Tezos_data_encoding.Encoding.t a) (state : state) : list a :=
  let fix loop (max_length : Z) (acc : list a) : list a :=
    if equiv_decb (remaining_bytes state) 0 then
      List.rev acc
    else
      if equiv_decb max_length 0 then
        raise error
      else
        let v := read_rec e state in
        loop (Z.sub max_length 1) (cons v acc) in
  loop max_length [].

Definition read {A : Type}
  (encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t)
  (ofs : Z) (len : Z) : option (Z * A) :=
  let state :=
    {| buffer := buffer; offset := ofs; remaining_bytes := len;
      allowed_bytes := None |} in
  match read_rec encoding state with
  | v => Some ((offset state), v)
  end.

Definition of_bytes_exn {A : Type}
  (encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t) : A :=
  let len := String.length buffer in
  let state :=
    {| buffer := buffer; offset := 0; remaining_bytes := len;
      allowed_bytes := None |} in
  let v := read_rec encoding state in
  if nequiv_decb (offset state) len then
    raise Extra_bytes
  else
    tt;
  v.

Definition of_bytes {A : Type}
  (encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t)
  : option A := try.
src/lib_data_encoding/binary_reader.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Binary}. *)

val read : 'a Encoding.t -> Bytes.t -> int -> int -> (int * 'a) option

val of_bytes : 'a Encoding.t -> Bytes.t -> 'a option

val of_bytes_exn : 'a Encoding.t -> Bytes.t -> 'a
src/lib_data_encoding/binary_reader.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter read : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> Stdlib.Bytes.t -> Z -> Z -> option (Z * a).

Parameter of_bytes : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> Stdlib.Bytes.t -> option a.

Parameter of_bytes_exn : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> Stdlib.Bytes.t -> a.
src/lib_data_encoding/binary_schema.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Encoding

type integer_extended = [Binary_size.integer | `Int32 | `Int64]

type field_descr =
  | Named_field of string * Kind.t * layout
  | Anonymous_field of Kind.t * layout
  | Dynamic_size_field of string option * int * Binary_size.unsigned_integer
  | Optional_field of string

and layout =
  | Zero_width
  | Int of integer_extended
  | Bool
  | RangedInt of int * int
  | RangedFloat of float * float
  | Float
  | Bytes
  | String
  | Enum of Binary_size.integer * string
  | Seq of layout * int option (* For arrays and lists *)
  | Ref of string
  | Padding

and fields = field_descr list

and toplevel_encoding =
  | Obj of {fields : fields}
  | Cases of {
      kind : Kind.t;
      tag_size : Binary_size.tag_size;
      cases : (int * string option * fields) list;
    }
  | Int_enum of {size : Binary_size.integer; cases : (int * string) list}

and description = {title : string; description : string option}

type t = {
  toplevel : toplevel_encoding;
  fields : (description * toplevel_encoding) list;
}

module Printer_ast = struct
  type table = {headers : string list; body : string list list}

  type t =
    | Table of table
    | Union of Binary_size.tag_size * (description * table) list

  let pp_size ppf = function
    | `Fixed size ->
        Format.fprintf ppf "%d byte%s" size (if size = 1 then "" else "s")
    | `Variable ->
        Format.fprintf ppf "Variable"
    | `Dynamic ->
        Format.fprintf ppf "Determined from data"

  let pp_int ppf (int : integer_extended) =
    Format.fprintf
      ppf
      "%s"
      ( match int with
      | `Int16 ->
          "signed 16-bit integer"
      | `Int31 ->
          "signed 31-bit integer"
      | `Uint30 ->
          "unsigned 30-bit integer"
      | `Int32 ->
          "signed 32-bit integer"
      | `Int64 ->
          "signed 64-bit integer"
      | `Int8 ->
          "signed 8-bit integer"
      | `Uint16 ->
          "unsigned 16-bit integer"
      | `Uint8 ->
          "unsigned 8-bit integer" )

  let rec pp_layout ppf = function
    | Zero_width ->
        Format.fprintf ppf "placeholder (not actually present in the encoding)"
    | Int integer ->
        Format.fprintf ppf "%a" pp_int integer
    | Bool ->
        Format.fprintf ppf "boolean (0 for false, 255 for true)"
    | RangedInt (minimum, maximum) when minimum <= 0 ->
        Format.fprintf
          ppf
          "%a in the range %d to %d"
          pp_int
          (Binary_size.range_to_size ~minimum ~maximum :> integer_extended)
          minimum
          maximum
    | RangedInt (minimum, maximum) (* when minimum > 0 *) ->
        Format.fprintf
          ppf
          "%a in the range %d to %d (shifted by %d)"
          pp_int
          (Binary_size.range_to_size ~minimum ~maximum :> integer_extended)
          minimum
          maximum
          minimum
    | RangedFloat (minimum, maximum) ->
        Format.fprintf
          ppf
          "double-precision floating-point number, in the range %f to %f"
          minimum
          maximum
    | Float ->
        Format.fprintf ppf "double-precision floating-point number"
    | Bytes ->
        Format.fprintf ppf "bytes"
    | String ->
        Format.fprintf ppf "bytes"
    | Ref reference ->
        Format.fprintf ppf "$%s" reference
    | Padding ->
        Format.fprintf ppf "padding"
    | Enum (size, reference) ->
        Format.fprintf
          ppf
          "%a encoding an enumeration (see %s)"
          pp_int
          (size :> integer_extended)
          reference
    | Seq (data, len) -> (
        Format.fprintf ppf "sequence of " ;
        ( match len with
        | None ->
            ()
        | Some len ->
            Format.fprintf ppf "at most %d " len ) ;
        match data with
        | Ref reference ->
            Format.fprintf ppf "$%s" reference
        | _ ->
            pp_layout ppf data )

  let pp_tag_size ppf tag =
    Format.fprintf ppf "%s"
    @@ match tag with `Uint8 -> "8-bit" | `Uint16 -> "16-bit"

  let field_descr () =
    let reference = ref 0 in
    let string_of_layout = Format.asprintf "%a" pp_layout in
    let anon_num () =
      let value = !reference in
      reference := value + 1 ;
      string_of_int value
    in
    function
    | Named_field (name, kind, desc) ->
        [name; Format.asprintf "%a" pp_size kind; string_of_layout desc]
    | Dynamic_size_field (Some name, 1, size) ->
        [ Format.asprintf "# bytes in field \"%s\"" name;
          Format.asprintf
            "%a"
            pp_size
            (`Fixed (Binary_size.integer_to_size size));
          string_of_layout (Int (size :> integer_extended)) ]
    | Dynamic_size_field (None, 1, size) ->
        [ Format.asprintf "# bytes in next field";
          Format.asprintf
            "%a"
            pp_size
            (`Fixed (Binary_size.integer_to_size size));
          string_of_layout (Int (size :> integer_extended)) ]
    | Dynamic_size_field (_, i, size) ->
        [ Format.asprintf "# bytes in next %d fields" i;
          Format.asprintf
            "%a"
            pp_size
            (`Fixed (Binary_size.integer_to_size size));
          string_of_layout (Int (size :> integer_extended)) ]
    | Anonymous_field (kind, desc) ->
        [ "Unnamed field " ^ anon_num ();
          Format.asprintf "%a" pp_size kind;
          string_of_layout desc ]
    | Optional_field name ->
        [ Format.asprintf "? presence of field \"%s\"" name;
          Format.asprintf "%a" pp_size (`Fixed 1);
          string_of_layout Bool ]

  let binary_table_headers = ["Name"; "Size"; "Contents"]

  let enum_headers = ["Case number"; "Encoded string"]

  let toplevel (descr, encoding) =
    match encoding with
    | Obj {fields} ->
        ( descr,
          Table
            {
              headers = binary_table_headers;
              body = List.map (field_descr ()) fields;
            } )
    | Cases {kind; tag_size; cases} ->
        ( {
            title =
              Format.asprintf
                "%s (%a, %a tag)"
                descr.title
                pp_size
                kind
                pp_tag_size
                tag_size;
            description = descr.description;
          },
          Union
            ( tag_size,
              List.map
                (fun (tag, name, fields) ->
                  ( {
                      title =
                        ( match name with
                        | Some name ->
                            Format.asprintf "%s (tag %d)" name tag
                        | None ->
                            Format.asprintf "Tag %d" tag );
                      description = None;
                    },
                    {
                      headers = binary_table_headers;
                      body = List.map (field_descr ()) fields;
                    } ))
                cases ) )
    | Int_enum {size; cases} ->
        ( {
            title =
              Format.asprintf
                "%s (Enumeration: %a):"
                descr.title
                pp_int
                (size :> integer_extended);
            description = descr.description;
          },
          Table
            {
              headers = enum_headers;
              body =
                List.map (fun (num, str) -> [string_of_int num; str]) cases;
            } )
end

module Printer = struct
  let rec pad char ppf = function
    | 0 ->
        ()
    | n ->
        Format.pp_print_char ppf char ;
        pad char ppf (n - 1)

  let pp_title level ppf title =
    let char = if level = 1 then '*' else if level = 2 then '=' else '`' in
    let sub = String.map (fun _ -> char) title in
    Format.fprintf ppf "%s@ %s@\n@\n" title sub

  let pp_table ppf {Printer_ast.headers; body} =
    let max_widths =
      List.fold_left
        (List.map2 (fun len str -> max (String.length str) len))
        (List.map String.length headers)
        body
    in
    let pp_row pad_char ppf =
      Format.fprintf ppf "|%a" (fun ppf ->
          List.iter2
            (fun width str ->
              Format.fprintf
                ppf
                " %s%a |"
                str
                (pad pad_char)
                (width - String.length str))
            max_widths)
    in
    let pp_line c ppf =
      Format.fprintf ppf "+%a" (fun ppf ->
          List.iter2
            (fun width _str -> Format.fprintf ppf "%a+" (pad c) (width + 2))
            max_widths)
    in
    Format.fprintf
      ppf
      "%a@\n%a@\n%a@\n%a@\n@\n"
      (pp_line '-')
      headers
      (pp_row ' ')
      headers
      (pp_line '=')
      headers
      (Format.pp_print_list
         ~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
         (fun ppf s ->
           Format.fprintf ppf "%a@\n%a" (pp_row ' ') s (pp_line '-') s))
      body

  let pp_option_nl ppf = function
    | Some s ->
        Format.fprintf ppf "%s@\n@\n" s
    | None ->
        ()

  let pp_toplevel ppf = function
    | Printer_ast.Table table ->
        pp_table ppf table
    | Union (_tag_size, tables) ->
        Format.fprintf
          ppf
          "%a"
          (fun ppf ->
            Format.pp_print_list
              ~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
              (fun ppf (descr, table) ->
                Format.fprintf
                  ppf
                  "%a%a%a"
                  (pp_title 2)
                  descr.title
                  pp_option_nl
                  descr.description
                  pp_table
                  table)
              ppf)
          tables

  let pp ppf {toplevel; fields} =
    let (_, toplevel) =
      Printer_ast.toplevel ({title = ""; description = None}, toplevel)
    in
    Format.fprintf
      ppf
      "%a@\n%a"
      pp_toplevel
      toplevel
      (Format.pp_print_list
         ~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
         (fun ppf (descr, toplevel) ->
           Format.fprintf
             ppf
             "%a%a%a"
             (pp_title 1)
             descr.title
             pp_option_nl
             descr.description
             pp_toplevel
             toplevel))
      (List.map Printer_ast.toplevel fields)
end

module Encoding = struct
  let description_encoding =
    conv
      (fun {title; description} -> (title, description))
      (fun (title, description) -> {title; description})
      (obj2 (req "title" string) (opt "description" string))

  let integer_cases =
    [("Int16", `Int16); ("Int8", `Int8); ("Uint16", `Uint16); ("Uint8", `Uint8)]

  let integer_encoding : Binary_size.integer encoding =
    string_enum integer_cases

  let integer_extended_encoding =
    string_enum (("Int64", `Int64) :: ("Int32", `Int32) :: integer_cases)

  let layout_encoding =
    mu "layout" (fun layout ->
        union
          [ case
              ~title:"Zero_width"
              (Tag 0)
              (obj1 (req "kind" (constant "Zero_width")))
              (function Zero_width -> Some () | _ -> None)
              (fun () -> Zero_width);
            case
              ~title:"Int"
              (Tag 1)
              (obj2
                 (req "size" integer_extended_encoding)
                 (req "kind" (constant "Int")))
              (function Int integer -> Some (integer, ()) | _ -> None)
              (fun (integer, _) -> Int integer);
            case
              ~title:"Bool"
              (Tag 2)
              (obj1 (req "kind" (constant "Bool")))
              (function Bool -> Some () | _ -> None)
              (fun () -> Bool);
            case
              ~title:"RangedInt"
              (Tag 3)
              (obj3
                 (req "min" int31)
                 (req "max" int31)
                 (req "kind" (constant "RangedInt")))
              (function
                | RangedInt (min, max) -> Some (min, max, ()) | _ -> None)
              (fun (min, max, _) -> RangedInt (min, max));
            case
              ~title:"RangedFloat"
              (Tag 4)
              (obj3
                 (req "min" float)
                 (req "max" float)
                 (req "kind" (constant "RangedFloat")))
              (function
                | RangedFloat (min, max) -> Some (min, max, ()) | _ -> None)
              (fun (min, max, ()) -> RangedFloat (min, max));
            case
              ~title:"Float"
              (Tag 5)
              (obj1 (req "kind" (constant "Float")))
              (function Float -> Some () | _ -> None)
              (fun () -> Float);
            case
              ~title:"Bytes"
              (Tag 6)
              (obj1 (req "kind" (constant "Bytes")))
              (function Bytes -> Some () | _ -> None)
              (fun () -> Bytes);
            case
              ~title:"String"
              (Tag 7)
              (obj1 (req "kind" (constant "String")))
              (function String -> Some () | _ -> None)
              (fun () -> String);
            case
              ~title:"Enum"
              (Tag 8)
              (obj3
                 (req "size" integer_encoding)
                 (req "reference" string)
                 (req "kind" (constant "Enum")))
              (function
                | Enum (size, cases) -> Some (size, cases, ()) | _ -> None)
              (fun (size, cases, _) -> Enum (size, cases));
            case
              ~title:"Seq"
              (Tag 9)
              (obj3
                 (req "layout" layout)
                 (req "kind" (constant "Seq"))
                 (opt "max_length" int31))
              (function
                | Seq (layout, len) -> Some (layout, (), len) | _ -> None)
              (fun (layout, (), len) -> Seq (layout, len));
            case
              ~title:"Ref"
              (Tag 10)
              (obj2 (req "name" string) (req "kind" (constant "Ref")))
              (function Ref layout -> Some (layout, ()) | _ -> None)
              (fun (name, ()) -> Ref name);
            case
              ~title:"Padding"
              (Tag 11)
              (obj1 (req "kind" (constant "Padding")))
              (function Padding -> Some () | _ -> None)
              (fun () -> Padding) ])

  let kind_enum_cases () =
    [ case
        ~title:"Dynamic"
        (Tag 0)
        (obj1 (req "kind" (constant "Dynamic")))
        (function `Dynamic -> Some () | _ -> None)
        (fun () -> `Dynamic);
      case
        ~title:"Variable"
        (Tag 1)
        (obj1 (req "kind" (constant "Variable")))
        (function `Variable -> Some () | _ -> None)
        (fun () -> `Variable) ]

  let kind_t_encoding =
    def "schema.kind"
    @@ union
         ( case
             ~title:"Fixed"
             (Tag 2)
             (obj2 (req "size" int31) (req "kind" (constant "Float")))
             (function `Fixed n -> Some (n, ()) | _ -> None)
             (fun (n, _) -> `Fixed n)
         :: kind_enum_cases () )

  let unsigned_integer_encoding =
    string_enum [("Uint30", `Uint30); ("Uint16", `Uint16); ("Uint8", `Uint8)]

  let field_descr_encoding =
    let dynamic_layout_encoding = dynamic_size layout_encoding in
    def "schema.field"
    @@ union
         [ case
             ~title:"Named_field"
             (Tag 0)
             (obj4
                (req "name" string)
                (req "layout" dynamic_layout_encoding)
                (req "data_kind" kind_t_encoding)
                (req "kind" (constant "named")))
             (function
               | Named_field (name, kind, layout) ->
                   Some (name, layout, kind, ())
               | _ ->
                   None)
             (fun (name, kind, layout, _) -> Named_field (name, layout, kind));
           case
             ~title:"Anonymous_field"
             (Tag 1)
             (obj3
                (req "layout" dynamic_layout_encoding)
                (req "kind" (constant "anon"))
                (req "data_kind" kind_t_encoding))
             (function
               | Anonymous_field (kind, layout) ->
                   Some (layout, (), kind)
               | _ ->
                   None)
             (fun (kind, _, layout) -> Anonymous_field (layout, kind));
           case
             ~title:"Dynamic_field"
             (Tag 2)
             (obj4
                (req "kind" (constant "dyn"))
                (opt "name" string)
                (req "num_fields" int31)
                (req "size" unsigned_integer_encoding))
             (function
               | Dynamic_size_field (name, i, size) ->
                   Some ((), name, i, size)
               | _ ->
                   None)
             (fun ((), name, i, size) -> Dynamic_size_field (name, i, size));
           case
             ~title:"Optional_field"
             (Tag 3)
             (obj2
                (req "kind" (constant "option_indicator"))
                (req "name" string))
             (function Optional_field s -> Some ((), s) | _ -> None)
             (fun ((), s) -> Optional_field s) ]

  let tag_size_encoding = string_enum [("Uint16", `Uint16); ("Uint8", `Uint8)]

  let binary_description_encoding =
    union
      [ case
          ~title:"Obj"
          (Tag 0)
          (obj1 (req "fields" (list (dynamic_size field_descr_encoding))))
          (function Obj {fields} -> Some fields | _ -> None)
          (fun fields -> Obj {fields});
        case
          ~title:"Cases"
          (Tag 1)
          (obj3
             (req "tag_size" tag_size_encoding)
             (req "kind" (dynamic_size kind_t_encoding))
             (req
                "cases"
                (list
                   ( def "union case"
                   @@ conv
                        (fun (tag, name, fields) -> (tag, fields, name))
                        (fun (tag, fields, name) -> (tag, name, fields))
                   @@ obj3
                        (req "tag" int31)
                        (req
                           "fields"
                           (list (dynamic_size field_descr_encoding)))
                        (opt "name" string) ))))
          (function
            | Cases {kind; tag_size; cases} ->
                Some (tag_size, kind, cases)
            | _ ->
                None)
          (fun (tag_size, kind, cases) -> Cases {kind; tag_size; cases});
        case
          ~title:"Int_enum"
          (Tag 2)
          (obj2
             (req "size" integer_encoding)
             (req "cases" (list (tup2 int31 string))))
          (function Int_enum {size; cases} -> Some (size, cases) | _ -> None)
          (fun (size, cases) -> Int_enum {size; cases}) ]

  let encoding =
    conv
      (fun {toplevel; fields} -> (toplevel, fields))
      (fun (toplevel, fields) -> {toplevel; fields})
    @@ obj2
         (req "toplevel" binary_description_encoding)
         (req
            "fields"
            (list
               (obj2
                  (req "description" description_encoding)
                  (req "encoding" binary_description_encoding))))
end

let encoding = Encoding.encoding

let pp = Printer.pp
src/lib_data_encoding/binary_schema.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Encoding.

Definition integer_extended := variant.

Reserved Notation "'fields".

Inductive field_descr : Type :=
| Named_field : string -> Tezos_data_encoding.Encoding.Kind.t -> layout ->
  field_descr
| Anonymous_field : Tezos_data_encoding.Encoding.Kind.t -> layout -> field_descr
| Dynamic_size_field : (option string) -> Z ->
  Tezos_data_encoding.Binary_size.unsigned_integer -> field_descr
| Optional_field : string -> field_descr

with layout : Type :=
| Zero_width : layout
| Int : integer_extended -> layout
| Bool : layout
| RangedInt : Z -> Z -> layout
| RangedFloat : float -> float -> layout
| Float : layout
| Bytes : layout
| String : layout
| Enum : Tezos_data_encoding.Binary_size.integer -> string -> layout
| Seq : layout -> (option Z) -> layout
| Ref : string -> layout
| Padding : layout

with toplevel_encoding : Type :=
| Obj : 'fields -> toplevel_encoding
| Cases : Tezos_data_encoding.Encoding.Kind.t ->
  Tezos_data_encoding.Binary_size.tag_size ->
  (list (Z * (option string) * 'fields)) -> toplevel_encoding
| Int_enum : Tezos_data_encoding.Binary_size.integer -> (list (Z * string)) ->
  toplevel_encoding

where "'fields" := ( list field_descr).

Definition fields := 'fields.

Record t := {
  toplevel : toplevel_encoding;
  fields : list (description * toplevel_encoding) }.

Module Printer_ast.
  Record table := {
    headers : list string;
    body : list (list string) }.
  
  Inductive t : Type :=
  | Table : table -> t
  | Union : Tezos_data_encoding.Binary_size.tag_size ->
    (list (description * table)) -> t.
  
  Definition pp_size
    (ppf : Stdlib.Format.formatter) (function_parameter : variant) : unit :=
    match function_parameter with
    | Fixed size =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " byte" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))) "%d byte%s" % string)
        size
        (if equiv_decb size 1 then
          "" % string
        else
          "s" % string)
    | Variable =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Variable" % string
            CamlinternalFormatBasics.End_of_format) "Variable" % string)
    | Dynamic =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Determined from data" % string
            CamlinternalFormatBasics.End_of_format)
          "Determined from data" % string)
    end.
  
  Definition pp_int (ppf : Stdlib.Format.formatter) (int : integer_extended)
    : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string)
      match Z with
      | Int16 => "signed 16-bit integer" % string
      | Int31 => "signed 31-bit integer" % string
      | Uint30 => "unsigned 30-bit integer" % string
      | Int32 => "signed 32-bit integer" % string
      | Int64 => "signed 64-bit integer" % string
      | Int8 => "signed 8-bit integer" % string
      | Uint16 => "unsigned 16-bit integer" % string
      | Uint8 => "unsigned 8-bit integer" % string
      end.
  
  Fixpoint pp_layout
    (ppf : Stdlib.Format.formatter) (function_parameter : layout) : unit :=
    match function_parameter with
    | Zero_width =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "placeholder (not actually present in the encoding)" % string
            CamlinternalFormatBasics.End_of_format)
          "placeholder (not actually present in the encoding)" % string)
    | Int integer =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) pp_int integer
    | Bool =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "boolean (0 for false, 255 for true)" % string
            CamlinternalFormatBasics.End_of_format)
          "boolean (0 for false, 255 for true)" % string)
    | RangedInt minimum maximum =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " in the range " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " to " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format)))))
          "%a in the range %d to %d" % string) pp_int
        (Tezos_data_encoding.Binary_size.range_to_size minimum maximum) minimum
        maximum
    | RangedInt minimum maximum =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " in the range " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " to " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal
                      " (shifted by " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format))))))))
          "%a in the range %d to %d (shifted by %d)" % string) pp_int
        (Tezos_data_encoding.Binary_size.range_to_size minimum maximum) minimum
        maximum minimum
    | RangedFloat minimum maximum =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "double-precision floating-point number, in the range " % string
            (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " to " % string
                (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))))
          "double-precision floating-point number, in the range %f to %f" %
            string) minimum maximum
    | Float =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "double-precision floating-point number" % string
            CamlinternalFormatBasics.End_of_format)
          "double-precision floating-point number" % string)
    | Bytes =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "bytes" % string
            CamlinternalFormatBasics.End_of_format) "bytes" % string)
    | String =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "bytes" % string
            CamlinternalFormatBasics.End_of_format) "bytes" % string)
    | Ref reference =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "$" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)) "$%s" % string) reference
    | Padding =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "padding" % string
            CamlinternalFormatBasics.End_of_format) "padding" % string)
    | Enum size reference =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " encoding an enumeration (see " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))
          "%a encoding an enumeration (see %s)" % string) pp_int size reference
    | Seq data len =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "sequence of " % string
            CamlinternalFormatBasics.End_of_format) "sequence of " % string);
      match len with
      | None => tt
      | Some len =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "at most " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal " " % char
                  CamlinternalFormatBasics.End_of_format)))
            "at most %d " % string) len
      end;
      match data with
      | Ref reference =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "$" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "$%s" % string)
          reference
      | _ => pp_layout ppf data
      end
    end.
  
  Definition pp_tag_size (ppf : Stdlib.Format.formatter) (tag : variant)
    : unit :=
    apply
      (Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string))
      match tag with
      | Uint8 => "8-bit" % string
      | Uint16 => "16-bit" % string
      end.
  
  Definition field_descr (function_parameter : unit)
    : field_descr -> list string :=
    match function_parameter with
    | tt =>
      let reference := Stdlib.ref 0 in
      let string_of_layout :=
        Stdlib.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string) pp_layout
        in
      let anon_num (function_parameter : unit) : string :=
        match function_parameter with
        | tt =>
          let value := Stdlib.op_exclamation reference in
          Stdlib.op_colon_eq reference (Z.add value 1);
          OCaml.Stdlib.string_of_int value
        end in
      fun function_parameter =>
        match function_parameter with
        | Named_field name kind desc =>
          cons name
            (cons
              (Stdlib.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                pp_size kind) (cons (string_of_layout desc) []))
        | Dynamic_size_field (Some name) 1 size =>
          cons
            (Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "# bytes in field """ % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal """" % char
                      CamlinternalFormatBasics.End_of_format)))
                "# bytes in field ""%s""" % string) name)
            (cons
              (Stdlib.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                pp_size variant) (cons (string_of_layout (Int size)) []))
        | Dynamic_size_field None 1 size =>
          cons
            (Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "# bytes in next field" % string
                  CamlinternalFormatBasics.End_of_format)
                "# bytes in next field" % string))
            (cons
              (Stdlib.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                pp_size variant) (cons (string_of_layout (Int size)) []))
        | Dynamic_size_field _ i size =>
          cons
            (Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "# bytes in next " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal " fields" % string
                      CamlinternalFormatBasics.End_of_format)))
                "# bytes in next %d fields" % string) i)
            (cons
              (Stdlib.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                pp_size variant) (cons (string_of_layout (Int size)) []))
        | Anonymous_field kind desc =>
          cons (String.append "Unnamed field " % string (anon_num tt))
            (cons
              (Stdlib.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                pp_size kind) (cons (string_of_layout desc) []))
        | Optional_field name =>
          cons
            (Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "? presence of field """ % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal """" % char
                      CamlinternalFormatBasics.End_of_format)))
                "? presence of field ""%s""" % string) name)
            (cons
              (Stdlib.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                pp_size variant) (cons (string_of_layout Bool) []))
        end
    end.
  
  Definition binary_table_headers : list string :=
    cons "Name" % string (cons "Size" % string (cons "Contents" % string [])).
  
  Definition enum_headers : list string :=
    cons "Case number" % string (cons "Encoded string" % string []).
  
  Definition toplevel (function_parameter : description * toplevel_encoding)
    : description * t :=
    match function_parameter with
    | (descr, encoding) =>
      match encoding with
      | Obj {| fields := fields |} =>
        (descr,
          (Table
            {| headers := binary_table_headers;
              body := List.map (field_descr tt) fields |}))
      | Cases {| kind := kind; tag_size := tag_size; cases := cases |} =>
        ({|
          title :=
            Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " (" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal ", " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " tag)" % string
                            CamlinternalFormatBasics.End_of_format))))))
                "%s (%a, %a tag)" % string) (title descr) pp_size kind
              pp_tag_size tag_size; description := description descr |},
          (Union tag_size
            (List.map
              (fun function_parameter =>
                match function_parameter with
                | (tag, name, fields) =>
                  ({|
                    title :=
                      match name with
                      | Some name =>
                        Stdlib.Format.asprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                " (tag " % string
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.Char_literal
                                    ")" % char
                                    CamlinternalFormatBasics.End_of_format))))
                            "%s (tag %d)" % string) name tag
                      | None =>
                        Stdlib.Format.asprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Tag " % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                CamlinternalFormatBasics.End_of_format))
                            "Tag %d" % string) tag
                      end; description := None |},
                    {| headers := binary_table_headers;
                      body := List.map (field_descr tt) fields |})
                end) cases)))
      | Int_enum {| size := size; cases := cases |} =>
        ({|
          title :=
            Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " (Enumeration: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal "):" % string
                        CamlinternalFormatBasics.End_of_format))))
                "%s (Enumeration: %a):" % string) (title descr) pp_int size;
          description := description descr |},
          (Table
            {| headers := enum_headers;
              body :=
                List.map
                  (fun function_parameter =>
                    match function_parameter with
                    | (num, str) =>
                      cons (OCaml.Stdlib.string_of_int num) (cons str [])
                    end) cases |}))
      end
    end.
End Printer_ast.

Module Printer.
  Fixpoint pad
    (char : ascii) (ppf : Stdlib.Format.formatter) (function_parameter : Z)
    : unit :=
    match function_parameter with
    | 0 => tt
    | n =>
      Stdlib.Format.pp_print_char ppf ascii;
      pad ascii ppf (Z.sub n 1)
    end.
  
  Definition pp_title
    (level : Z) (ppf : Stdlib.Format.formatter) (title : string) : unit :=
    let char :=
      if equiv_decb level 1 then
        "*" % char
      else
        if equiv_decb level 2 then
          "=" % char
        else
          "`" % char in
    let sub :=
      Stdlib.String.map
        (fun function_parameter =>
          match function_parameter with
          | _ => ascii
          end) title in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Force_newline
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Force_newline
                  CamlinternalFormatBasics.End_of_format)))))
        "%s@ %s@
@
" % string) title sub.
  
  Definition pp_table
    (ppf : Stdlib.Format.formatter) (function_parameter : Printer_ast.table)
    : unit :=
    match function_parameter with
    | {| Printer_ast.headers := headers; Printer_ast.body := body |} =>
      let max_widths :=
        Stdlib.List.fold_left
          (Stdlib.List.map2
            (fun len =>
              fun str => OCaml.Stdlib.max (OCaml.String.length str) len))
          (List.map OCaml.String.length headers) body in
      let pp_row (pad_char : ascii) (ppf : Stdlib.Format.formatter)
        : (list string) -> unit :=
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "|" % char
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "|%a" % string)
          (fun ppf =>
            Stdlib.List.iter2
              (fun width =>
                fun str =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Char_literal " " % char
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " |" % string
                              CamlinternalFormatBasics.End_of_format))))
                      " %s%a |" % string) str (pad pad_char)
                    (Z.sub width (OCaml.String.length str))) max_widths) in
      let pp_line {A : Type} (c : ascii) (ppf : Stdlib.Format.formatter)
        : (list A) -> unit :=
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "+" % char
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "+%a" % string)
          (fun ppf =>
            Stdlib.List.iter2
              (fun width =>
                fun _str =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "+" % char
                          CamlinternalFormatBasics.End_of_format))
                      "%a+" % string) (pad c) (Z.add width 2)) max_widths) in
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Force_newline
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Force_newline
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Force_newline
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Force_newline
                            CamlinternalFormatBasics.End_of_format)))))))))
          "%a@
%a@
%a@
%a@
@
" % string) (pp_line "-" % char) headers
        (pp_row " " % char) headers (pp_line "=" % char) headers
        (Stdlib.Format.pp_print_list
          (Some
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        CamlinternalFormatBasics.End_of_format) "@
" % string)
                end))
          (fun ppf =>
            fun s =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Force_newline
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)))
                  "%a@
%a" % string) (pp_row " " % char) s (pp_line "-" % char)
                s)) body
    end.
  
  Definition pp_option_nl
    (ppf : Stdlib.Format.formatter) (function_parameter : option string)
    : unit :=
    match function_parameter with
    | Some s =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Force_newline
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Force_newline
                CamlinternalFormatBasics.End_of_format))) "%s@
@
" % string) s
    | None => tt
    end.
  
  Definition pp_toplevel
    (ppf : Stdlib.Format.formatter) (function_parameter : Printer_ast.t)
    : unit :=
    match function_parameter with
    | Printer_ast.Table table => pp_table ppf table
    | Union _tag_size tables =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string)
        (fun ppf =>
          Stdlib.Format.pp_print_list
            (Some
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          CamlinternalFormatBasics.End_of_format) "@
" % string)
                  end))
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | (descr, table) =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)))
                      "%a%a%a" % string) (pp_title 2) (title descr) pp_option_nl
                    (description descr) pp_table table
                end) ppf) tables
    end.
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | {| toplevel := toplevel; fields := fields |} =>
      match
        Printer_ast.toplevel
          ({| title := "" % string; description := None |}, toplevel) with
      | (_, toplevel) =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Force_newline
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))) "%a@
%a" % string)
          pp_toplevel toplevel
          (Stdlib.Format.pp_print_list
            (Some
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          CamlinternalFormatBasics.End_of_format) "@
" % string)
                  end))
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | (descr, toplevel) =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)))
                      "%a%a%a" % string) (pp_title 1) (title descr) pp_option_nl
                    (description descr) pp_toplevel toplevel
                end)) (List.map Printer_ast.toplevel fields)
      end
    end.
End Printer.

Module Encoding.
  Definition description_encoding
    : Tezos_data_encoding.Encoding.encoding description :=
    Tezos_data_encoding.Encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| title := title; description := description |} =>
          (title, description)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (title, description) =>
          {| title := title; description := description |}
        end) None
      (Tezos_data_encoding.Encoding.obj2
        (Tezos_data_encoding.Encoding.req None None "title" % string
          Tezos_data_encoding.Encoding.string)
        (Tezos_data_encoding.Encoding.opt None None "description" % string
          Tezos_data_encoding.Encoding.string)).
  
  Definition integer_cases : list (string * variant) :=
    cons ("Int16" % string, variant)
      (cons ("Int8" % string, variant)
        (cons ("Uint16" % string, variant) (cons ("Uint8" % string, variant) []))).
  
  Definition integer_encoding
    : Tezos_data_encoding.Encoding.encoding
      Tezos_data_encoding.Binary_size.integer :=
    Tezos_data_encoding.Encoding.string_enum integer_cases.
  
  Definition integer_extended_encoding
    : Tezos_data_encoding.Encoding.encoding variant :=
    Tezos_data_encoding.Encoding.string_enum
      (cons ("Int64" % string, variant)
        (cons ("Int32" % string, variant) integer_cases)).
  
  Definition layout_encoding : Tezos_data_encoding.Encoding.encoding layout :=
    Tezos_data_encoding.Encoding.mu "layout" % string None None
      (fun layout =>
        Tezos_data_encoding.Encoding.union None
          (cons
            (Tezos_data_encoding.Encoding.case "Zero_width" % string None
              (Tag 0)
              (Tezos_data_encoding.Encoding.obj1
                (Tezos_data_encoding.Encoding.req None None "kind" % string
                  (Tezos_data_encoding.Encoding.constant "Zero_width" % string)))
              (fun function_parameter =>
                match function_parameter with
                | Zero_width => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | tt => Zero_width
                end))
            (cons
              (Tezos_data_encoding.Encoding.case "Int" % string None (Tag 1)
                (Tezos_data_encoding.Encoding.obj2
                  (Tezos_data_encoding.Encoding.req None None "size" % string
                    integer_extended_encoding)
                  (Tezos_data_encoding.Encoding.req None None "kind" % string
                    (Tezos_data_encoding.Encoding.constant "Int" % string)))
                (fun function_parameter =>
                  match function_parameter with
                  | Int integer => Some (integer, tt)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (integer, _) => Int integer
                  end))
              (cons
                (Tezos_data_encoding.Encoding.case "Bool" % string None (Tag 2)
                  (Tezos_data_encoding.Encoding.obj1
                    (Tezos_data_encoding.Encoding.req None None "kind" % string
                      (Tezos_data_encoding.Encoding.constant "Bool" % string)))
                  (fun function_parameter =>
                    match function_parameter with
                    | Bool => Some tt
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Bool
                    end))
                (cons
                  (Tezos_data_encoding.Encoding.case "RangedInt" % string None
                    (Tag 3)
                    (Tezos_data_encoding.Encoding.obj3
                      (Tezos_data_encoding.Encoding.req None None "min" % string
                        Tezos_data_encoding.Encoding.int31)
                      (Tezos_data_encoding.Encoding.req None None "max" % string
                        Tezos_data_encoding.Encoding.int31)
                      (Tezos_data_encoding.Encoding.req None None
                        "kind" % string
                        (Tezos_data_encoding.Encoding.constant
                          "RangedInt" % string)))
                    (fun function_parameter =>
                      match function_parameter with
                      | RangedInt min max => Some (min, max, tt)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | (min, max, _) => RangedInt min max
                      end))
                  (cons
                    (Tezos_data_encoding.Encoding.case "RangedFloat" % string
                      None (Tag 4)
                      (Tezos_data_encoding.Encoding.obj3
                        (Tezos_data_encoding.Encoding.req None None
                          "min" % string Tezos_data_encoding.Encoding.float)
                        (Tezos_data_encoding.Encoding.req None None
                          "max" % string Tezos_data_encoding.Encoding.float)
                        (Tezos_data_encoding.Encoding.req None None
                          "kind" % string
                          (Tezos_data_encoding.Encoding.constant
                            "RangedFloat" % string)))
                      (fun function_parameter =>
                        match function_parameter with
                        | RangedFloat min max => Some (min, max, tt)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | (min, max, tt) => RangedFloat min max
                        end))
                    (cons
                      (Tezos_data_encoding.Encoding.case "Float" % string None
                        (Tag 5)
                        (Tezos_data_encoding.Encoding.obj1
                          (Tezos_data_encoding.Encoding.req None None
                            "kind" % string
                            (Tezos_data_encoding.Encoding.constant
                              "Float" % string)))
                        (fun function_parameter =>
                          match function_parameter with
                          | Float => Some tt
                          | _ => None
                          end)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Float
                          end))
                      (cons
                        (Tezos_data_encoding.Encoding.case "Bytes" % string None
                          (Tag 6)
                          (Tezos_data_encoding.Encoding.obj1
                            (Tezos_data_encoding.Encoding.req None None
                              "kind" % string
                              (Tezos_data_encoding.Encoding.constant
                                "Bytes" % string)))
                          (fun function_parameter =>
                            match function_parameter with
                            | Bytes => Some tt
                            | _ => None
                            end)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Bytes
                            end))
                        (cons
                          (Tezos_data_encoding.Encoding.case "String" % string
                            None (Tag 7)
                            (Tezos_data_encoding.Encoding.obj1
                              (Tezos_data_encoding.Encoding.req None None
                                "kind" % string
                                (Tezos_data_encoding.Encoding.constant
                                  "String" % string)))
                            (fun function_parameter =>
                              match function_parameter with
                              | String => Some tt
                              | _ => None
                              end)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => String
                              end))
                          (cons
                            (Tezos_data_encoding.Encoding.case "Enum" % string
                              None (Tag 8)
                              (Tezos_data_encoding.Encoding.obj3
                                (Tezos_data_encoding.Encoding.req None None
                                  "size" % string integer_encoding)
                                (Tezos_data_encoding.Encoding.req None None
                                  "reference" % string
                                  Tezos_data_encoding.Encoding.string)
                                (Tezos_data_encoding.Encoding.req None None
                                  "kind" % string
                                  (Tezos_data_encoding.Encoding.constant
                                    "Enum" % string)))
                              (fun function_parameter =>
                                match function_parameter with
                                | Enum size cases => Some (size, cases, tt)
                                | _ => None
                                end)
                              (fun function_parameter =>
                                match function_parameter with
                                | (size, cases, _) => Enum size cases
                                end))
                            (cons
                              (Tezos_data_encoding.Encoding.case "Seq" % string
                                None (Tag 9)
                                (Tezos_data_encoding.Encoding.obj3
                                  (Tezos_data_encoding.Encoding.req None None
                                    "layout" % string layout)
                                  (Tezos_data_encoding.Encoding.req None None
                                    "kind" % string
                                    (Tezos_data_encoding.Encoding.constant
                                      "Seq" % string))
                                  (Tezos_data_encoding.Encoding.opt None None
                                    "max_length" % string
                                    Tezos_data_encoding.Encoding.int31))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Seq layout len => Some (layout, tt, len)
                                  | _ => None
                                  end)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (layout, tt, len) => Seq layout len
                                  end))
                              (cons
                                (Tezos_data_encoding.Encoding.case
                                  "Ref" % string None (Tag 10)
                                  (Tezos_data_encoding.Encoding.obj2
                                    (Tezos_data_encoding.Encoding.req None None
                                      "name" % string
                                      Tezos_data_encoding.Encoding.string)
                                    (Tezos_data_encoding.Encoding.req None None
                                      "kind" % string
                                      (Tezos_data_encoding.Encoding.constant
                                        "Ref" % string)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Ref layout => Some (layout, tt)
                                    | _ => None
                                    end)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (name, tt) => Ref name
                                    end))
                                (cons
                                  (Tezos_data_encoding.Encoding.case
                                    "Padding" % string None (Tag 11)
                                    (Tezos_data_encoding.Encoding.obj1
                                      (Tezos_data_encoding.Encoding.req None
                                        None "kind" % string
                                        (Tezos_data_encoding.Encoding.constant
                                          "Padding" % string)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | Padding => Some tt
                                      | _ => None
                                      end)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt => Padding
                                      end)) []))))))))))))).
  
  Definition kind_enum_cases (function_parameter : unit)
    : list (Tezos_data_encoding.Encoding.case variant) :=
    match function_parameter with
    | tt =>
      cons
        (Tezos_data_encoding.Encoding.case "Dynamic" % string None (Tag 0)
          (Tezos_data_encoding.Encoding.obj1
            (Tezos_data_encoding.Encoding.req None None "kind" % string
              (Tezos_data_encoding.Encoding.constant "Dynamic" % string)))
          (fun function_parameter =>
            match function_parameter with
            | Dynamic => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | tt => variant
            end))
        (cons
          (Tezos_data_encoding.Encoding.case "Variable" % string None (Tag 1)
            (Tezos_data_encoding.Encoding.obj1
              (Tezos_data_encoding.Encoding.req None None "kind" % string
                (Tezos_data_encoding.Encoding.constant "Variable" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Variable => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => variant
              end)) [])
    end.
  
  Definition kind_t_encoding : Tezos_data_encoding.Encoding.encoding variant :=
    apply
      (let arg := Tezos_data_encoding.Encoding.def "schema.kind" % string in
      fun eta => arg None None eta)
      (Tezos_data_encoding.Encoding.union None
        (cons
          (Tezos_data_encoding.Encoding.case "Fixed" % string None (Tag 2)
            (Tezos_data_encoding.Encoding.obj2
              (Tezos_data_encoding.Encoding.req None None "size" % string
                Tezos_data_encoding.Encoding.int31)
              (Tezos_data_encoding.Encoding.req None None "kind" % string
                (Tezos_data_encoding.Encoding.constant "Float" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Fixed n => Some (n, tt)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (n, _) => variant
              end)) (kind_enum_cases tt))).
  
  Definition unsigned_integer_encoding
    : Tezos_data_encoding.Encoding.encoding variant :=
    Tezos_data_encoding.Encoding.string_enum
      (cons ("Uint30" % string, variant)
        (cons ("Uint16" % string, variant) (cons ("Uint8" % string, variant) []))).
  
  Definition field_descr_encoding
    : Tezos_data_encoding.Encoding.encoding field_descr :=
    let dynamic_layout_encoding :=
      Tezos_data_encoding.Encoding.dynamic_size None layout_encoding in
    apply
      (let arg := Tezos_data_encoding.Encoding.def "schema.field" % string in
      fun eta => arg None None eta)
      (Tezos_data_encoding.Encoding.union None
        (cons
          (Tezos_data_encoding.Encoding.case "Named_field" % string None (Tag 0)
            (Tezos_data_encoding.Encoding.obj4
              (Tezos_data_encoding.Encoding.req None None "name" % string
                Tezos_data_encoding.Encoding.string)
              (Tezos_data_encoding.Encoding.req None None "layout" % string
                dynamic_layout_encoding)
              (Tezos_data_encoding.Encoding.req None None "data_kind" % string
                kind_t_encoding)
              (Tezos_data_encoding.Encoding.req None None "kind" % string
                (Tezos_data_encoding.Encoding.constant "named" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Named_field name kind layout => Some (name, layout, kind, tt)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (name, kind, layout, _) => Named_field name layout kind
              end))
          (cons
            (Tezos_data_encoding.Encoding.case "Anonymous_field" % string None
              (Tag 1)
              (Tezos_data_encoding.Encoding.obj3
                (Tezos_data_encoding.Encoding.req None None "layout" % string
                  dynamic_layout_encoding)
                (Tezos_data_encoding.Encoding.req None None "kind" % string
                  (Tezos_data_encoding.Encoding.constant "anon" % string))
                (Tezos_data_encoding.Encoding.req None None "data_kind" % string
                  kind_t_encoding))
              (fun function_parameter =>
                match function_parameter with
                | Anonymous_field kind layout => Some (layout, tt, kind)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (kind, _, layout) => Anonymous_field layout kind
                end))
            (cons
              (Tezos_data_encoding.Encoding.case "Dynamic_field" % string None
                (Tag 2)
                (Tezos_data_encoding.Encoding.obj4
                  (Tezos_data_encoding.Encoding.req None None "kind" % string
                    (Tezos_data_encoding.Encoding.constant "dyn" % string))
                  (Tezos_data_encoding.Encoding.opt None None "name" % string
                    Tezos_data_encoding.Encoding.string)
                  (Tezos_data_encoding.Encoding.req None None
                    "num_fields" % string Tezos_data_encoding.Encoding.int31)
                  (Tezos_data_encoding.Encoding.req None None "size" % string
                    unsigned_integer_encoding))
                (fun function_parameter =>
                  match function_parameter with
                  | Dynamic_size_field name i size => Some (tt, name, i, size)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (tt, name, i, size) => Dynamic_size_field name i size
                  end))
              (cons
                (Tezos_data_encoding.Encoding.case "Optional_field" % string
                  None (Tag 3)
                  (Tezos_data_encoding.Encoding.obj2
                    (Tezos_data_encoding.Encoding.req None None "kind" % string
                      (Tezos_data_encoding.Encoding.constant
                        "option_indicator" % string))
                    (Tezos_data_encoding.Encoding.req None None "name" % string
                      Tezos_data_encoding.Encoding.string))
                  (fun function_parameter =>
                    match function_parameter with
                    | Optional_field s => Some (tt, s)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | (tt, s) => Optional_field s
                    end)) []))))).
  
  Definition tag_size_encoding
    : Tezos_data_encoding.Encoding.encoding variant :=
    Tezos_data_encoding.Encoding.string_enum
      (cons ("Uint16" % string, variant) (cons ("Uint8" % string, variant) [])).
  
  Definition binary_description_encoding
    : Tezos_data_encoding.Encoding.encoding toplevel_encoding :=
    Tezos_data_encoding.Encoding.union None
      (cons
        (Tezos_data_encoding.Encoding.case "Obj" % string None (Tag 0)
          (Tezos_data_encoding.Encoding.obj1
            (Tezos_data_encoding.Encoding.req None None "fields" % string
              (Tezos_data_encoding.Encoding.list None
                (Tezos_data_encoding.Encoding.dynamic_size None
                  field_descr_encoding))))
          (fun function_parameter =>
            match function_parameter with
            | Obj {| fields := fields |} => Some fields
            | _ => None
            end) (fun fields => Obj {| fields := fields |}))
        (cons
          (Tezos_data_encoding.Encoding.case "Cases" % string None (Tag 1)
            (Tezos_data_encoding.Encoding.obj3
              (Tezos_data_encoding.Encoding.req None None "tag_size" % string
                tag_size_encoding)
              (Tezos_data_encoding.Encoding.req None None "kind" % string
                (Tezos_data_encoding.Encoding.dynamic_size None kind_t_encoding))
              (Tezos_data_encoding.Encoding.req None None "cases" % string
                (Tezos_data_encoding.Encoding.list None
                  (apply
                    (let arg :=
                      Tezos_data_encoding.Encoding.def "union case" % string in
                    fun eta => arg None None eta)
                    (apply
                      (let arg :=
                        Tezos_data_encoding.Encoding.conv
                          (fun function_parameter =>
                            match function_parameter with
                            | (tag, name, fields) => (tag, fields, name)
                            end)
                          (fun function_parameter =>
                            match function_parameter with
                            | (tag, fields, name) => (tag, name, fields)
                            end) in
                      fun eta => arg None eta)
                      (Tezos_data_encoding.Encoding.obj3
                        (Tezos_data_encoding.Encoding.req None None
                          "tag" % string Tezos_data_encoding.Encoding.int31)
                        (Tezos_data_encoding.Encoding.req None None
                          "fields" % string
                          (Tezos_data_encoding.Encoding.list None
                            (Tezos_data_encoding.Encoding.dynamic_size None
                              field_descr_encoding)))
                        (Tezos_data_encoding.Encoding.opt None None
                          "name" % string Tezos_data_encoding.Encoding.string)))))))
            (fun function_parameter =>
              match function_parameter with
              | Cases {| kind := kind; tag_size := tag_size; cases := cases |}
                => Some (tag_size, kind, cases)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tag_size, kind, cases) =>
                Cases {| kind := kind; tag_size := tag_size; cases := cases |}
              end))
          (cons
            (Tezos_data_encoding.Encoding.case "Int_enum" % string None (Tag 2)
              (Tezos_data_encoding.Encoding.obj2
                (Tezos_data_encoding.Encoding.req None None "size" % string
                  integer_encoding)
                (Tezos_data_encoding.Encoding.req None None "cases" % string
                  (Tezos_data_encoding.Encoding.list None
                    (Tezos_data_encoding.Encoding.tup2
                      Tezos_data_encoding.Encoding.int31
                      Tezos_data_encoding.Encoding.string))))
              (fun function_parameter =>
                match function_parameter with
                | Int_enum {| size := size; cases := cases |} =>
                  Some (size, cases)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (size, cases) => Int_enum {| size := size; cases := cases |}
                end)) []))).
  
  Definition encoding : Tezos_data_encoding.Encoding.encoding t :=
    apply
      (let arg :=
        Tezos_data_encoding.Encoding.conv
          (fun function_parameter =>
            match function_parameter with
            | {| toplevel := toplevel; fields := fields |} => (toplevel, fields)
            end)
          (fun function_parameter =>
            match function_parameter with
            | (toplevel, fields) => {| toplevel := toplevel; fields := fields |}
            end) in
      fun eta => arg None eta)
      (Tezos_data_encoding.Encoding.obj2
        (Tezos_data_encoding.Encoding.req None None "toplevel" % string
          binary_description_encoding)
        (Tezos_data_encoding.Encoding.req None None "fields" % string
          (Tezos_data_encoding.Encoding.list None
            (Tezos_data_encoding.Encoding.obj2
              (Tezos_data_encoding.Encoding.req None None "description" % string
                description_encoding)
              (Tezos_data_encoding.Encoding.req None None "encoding" % string
                binary_description_encoding))))).
End Encoding.

Definition encoding : Tezos_data_encoding.Encoding.encoding t :=
  Encoding.encoding.

Definition pp : Stdlib.Format.formatter -> t -> unit := Printer.pp.
src/lib_data_encoding/binary_schema.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. *)

type integer_extended = [Binary_size.integer | `Int32 | `Int64]

type field_descr =
  | Named_field of string * Encoding.Kind.t * layout
  | Anonymous_field of Encoding.Kind.t * layout
  | Dynamic_size_field of string option * int * Binary_size.unsigned_integer
  | Optional_field of string

and layout =
  | Zero_width
  | Int of integer_extended
  | Bool
  | RangedInt of int * int
  | RangedFloat of float * float
  | Float
  | Bytes
  | String
  | Enum of Binary_size.integer * string
  | Seq of layout * int option (* For arrays and lists *)
  | Ref of string
  | Padding

and fields = field_descr list

and toplevel_encoding =
  | Obj of {fields : fields}
  | Cases of {
      kind : Encoding.Kind.t;
      tag_size : Binary_size.tag_size;
      cases : (int * string option * fields) list;
    }
  | Int_enum of {size : Binary_size.integer; cases : (int * string) list}

and description = {title : string; description : string option}

type t = {
  toplevel : toplevel_encoding;
  fields : (description * toplevel_encoding) list;
}

val pp : Format.formatter -> t -> unit

val encoding : t Encoding.t
src/lib_data_encoding/binary_schema.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition integer_extended := variant.

Reserved Notation "'fields".

Inductive field_descr : Type :=
| Named_field : string -> Tezos_data_encoding.Encoding.Kind.t -> layout ->
  field_descr
| Anonymous_field : Tezos_data_encoding.Encoding.Kind.t -> layout -> field_descr
| Dynamic_size_field : (option string) -> Z ->
  Tezos_data_encoding.Binary_size.unsigned_integer -> field_descr
| Optional_field : string -> field_descr

with layout : Type :=
| Zero_width : layout
| Int : integer_extended -> layout
| Bool : layout
| RangedInt : Z -> Z -> layout
| RangedFloat : float -> float -> layout
| Float : layout
| Bytes : layout
| String : layout
| Enum : Tezos_data_encoding.Binary_size.integer -> string -> layout
| Seq : layout -> (option Z) -> layout
| Ref : string -> layout
| Padding : layout

with toplevel_encoding : Type :=
| Obj : 'fields -> toplevel_encoding
| Cases : Tezos_data_encoding.Encoding.Kind.t ->
  Tezos_data_encoding.Binary_size.tag_size ->
  (list (Z * (option string) * 'fields)) -> toplevel_encoding
| Int_enum : Tezos_data_encoding.Binary_size.integer -> (list (Z * string)) ->
  toplevel_encoding

where "'fields" := ( list field_descr).

Definition fields := 'fields.

Record t := {
  toplevel : toplevel_encoding;
  fields : list (description * toplevel_encoding) }.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter encoding : Tezos_data_encoding.Encoding.t t.
src/lib_data_encoding/binary_size.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let bool = 1

let int8 = 1

let uint8 = 1

let char = 1

let int16 = 2

let uint16 = 2

let uint30 = 4

let uint32 = 4

let uint64 = 8

let int31 = 4

let int32 = 4

let int64 = 8

let float = 8

type tag_size = [`Uint8 | `Uint16]

let tag_size = function `Uint8 -> uint8 | `Uint16 -> uint16

type signed_integer = [`Int31 | `Int16 | `Int8]

type unsigned_integer = [`Uint30 | `Uint16 | `Uint8]

type integer = [signed_integer | unsigned_integer]

let signed_range_to_size min max : [> signed_integer] =
  if min >= ~-128 && max <= 127 then `Int8
  else if min >= ~-32_768 && max <= 32_767 then `Int16
  else `Int31

(* max should be centered at zero *)
let unsigned_range_to_size max : [> unsigned_integer] =
  assert (max >= 0) ;
  if max <= 255 then `Uint8 else if max <= 65535 then `Uint16 else `Uint30

let integer_to_size = function
  | `Int31 ->
      int31
  | `Int16 ->
      int16
  | `Int8 ->
      int8
  | `Uint30 ->
      uint30
  | `Uint16 ->
      uint16
  | `Uint8 ->
      uint8

let max_int = function
  | `Uint30 | `Int31 ->
      (1 lsl 30) - 1
  | `Int16 ->
      (1 lsl 15) - 1
  | `Int8 ->
      (1 lsl 7) - 1
  | `Uint16 ->
      (1 lsl 16) - 1
  | `Uint8 ->
      (1 lsl 8) - 1

let min_int = function
  | `Uint8 | `Uint16 | `Uint30 ->
      0
  | `Int31 ->
      -(1 lsl 30)
  | `Int16 ->
      -(1 lsl 15)
  | `Int8 ->
      -(1 lsl 7)

let range_to_size ~minimum ~maximum : integer =
  if minimum < 0 then signed_range_to_size minimum maximum
  else unsigned_range_to_size (maximum - minimum)

let enum_size arr = unsigned_range_to_size (Array.length arr)
src/lib_data_encoding/binary_size.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition bool : Z := 1.

Definition int8 : Z := 1.

Definition uint8 : Z := 1.

Definition char : Z := 1.

Definition int16 : Z := 2.

Definition uint16 : Z := 2.

Definition uint30 : Z := 4.

Definition uint32 : Z := 4.

Definition uint64 : Z := 8.

Definition int31 : Z := 4.

Definition int32 : Z := 4.

Definition int64 : Z := 8.

Definition float : Z := 8.

Definition tag_size := variant.

Definition tag_size (function_parameter : variant) : Z :=
  match function_parameter with
  | Uint8 => uint8
  | Uint16 => uint16
  end.

Definition signed_integer := variant.

Definition unsigned_integer := variant.

Definition integer := variant.

Definition signed_range_to_size (min : Z) (max : Z) : variant :=
  if andb (OCaml.Stdlib.ge min (Z.opp 128)) (OCaml.Stdlib.le max 127) then
    variant
  else
    if andb (OCaml.Stdlib.ge min (Z.opp 32768)) (OCaml.Stdlib.le max 32767) then
      variant
    else
      variant.

Definition unsigned_range_to_size (max : Z) : variant :=
  OCaml.Stdlib.ge max 0;
  if OCaml.Stdlib.le max 255 then
    variant
  else
    if OCaml.Stdlib.le max 65535 then
      variant
    else
      variant.

Definition integer_to_size (function_parameter : variant) : Z :=
  match function_parameter with
  | Int31 => int31
  | Int16 => int16
  | Int8 => int8
  | Uint30 => uint30
  | Uint16 => uint16
  | Uint8 => uint8
  end.

Definition max_int (function_parameter : variant) : Z :=
  match function_parameter with
  | Uint30 | Int31 => Z.sub (Z.shiftl 1 30) 1
  | Int16 => Z.sub (Z.shiftl 1 15) 1
  | Int8 => Z.sub (Z.shiftl 1 7) 1
  | Uint16 => Z.sub (Z.shiftl 1 16) 1
  | Uint8 => Z.sub (Z.shiftl 1 8) 1
  end.

Definition min_int (function_parameter : variant) : Z :=
  match function_parameter with
  | Uint8 | Uint16 | Uint30 => 0
  | Int31 => Z.opp (Z.shiftl 1 30)
  | Int16 => Z.opp (Z.shiftl 1 15)
  | Int8 => Z.opp (Z.shiftl 1 7)
  end.

Definition range_to_size (minimum : Z) (maximum : Z) : integer :=
  if OCaml.Stdlib.lt minimum 0 then
    signed_range_to_size minimum maximum
  else
    unsigned_range_to_size (Z.sub maximum minimum).

Definition enum_size {A : Type} (arr : array A) : variant :=
  unsigned_range_to_size (Stdlib.Array.length arr).
src/lib_data_encoding/binary_size.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. *)

val bool : int

val int8 : int

val uint8 : int

val char : int

val int16 : int

val uint16 : int

val uint30 : int

val uint32 : int

val uint64 : int

val int31 : int

val int32 : int

val int64 : int

val float : int

type tag_size = [`Uint8 | `Uint16]

val tag_size : tag_size -> int

type signed_integer = [`Int31 | `Int16 | `Int8]

type unsigned_integer = [`Uint30 | `Uint16 | `Uint8]

type integer = [signed_integer | unsigned_integer]

val integer_to_size : [< integer] -> int

val min_int : [< integer] -> int

val max_int : [< integer] -> int

val range_to_size : minimum:int -> maximum:int -> integer

val unsigned_range_to_size : int -> unsigned_integer

val enum_size : 'a array -> [> unsigned_integer]
src/lib_data_encoding/binary_size.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter bool : Z.

Parameter int8 : Z.

Parameter uint8 : Z.

Parameter char : Z.

Parameter int16 : Z.

Parameter uint16 : Z.

Parameter uint30 : Z.

Parameter uint32 : Z.

Parameter uint64 : Z.

Parameter int31 : Z.

Parameter int32 : Z.

Parameter int64 : Z.

Parameter float : Z.

Definition tag_size := variant.

Parameter tag_size : tag_size -> Z.

Definition signed_integer := variant.

Definition unsigned_integer := variant.

Definition integer := variant.

Parameter integer_to_size : forall {variant : Type}, variant -> Z.

Parameter min_int : forall {variant : Type}, variant -> Z.

Parameter max_int : forall {variant : Type}, variant -> Z.

Parameter range_to_size : Z -> Z -> integer.

Parameter unsigned_range_to_size : Z -> unsigned_integer.

Parameter enum_size : forall {a variant : Type}, (array a) -> variant.
src/lib_data_encoding/binary_stream.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Facilities to decode streams of binary data *)

type buffer = {buffer : Bytes.t; ofs : int; len : int}

type t = {
  current : buffer;
  (* buffer queue (classical double list implementation) *)
  pending : Bytes.t list;
  pending_rev : Bytes.t list;
  (* number unread bytes in 'current + pending + pending_rev' *)
  unread : int;
}

let is_empty {unread; _} = unread = 0

let of_buffer current =
  {current; pending = []; pending_rev = []; unread = current.len}

let of_bytes buffer =
  let len = Bytes.length buffer in
  of_buffer {buffer; ofs = 0; len}

let empty = of_bytes (Bytes.create 0)

let push buffer stream =
  {
    stream with
    pending_rev = buffer :: stream.pending_rev;
    unread = stream.unread + Bytes.length buffer;
  }

exception Need_more_data

let split buffer len =
  assert (len <= buffer.len) ;
  ( {buffer with len},
    {buffer with ofs = buffer.ofs + len; len = buffer.len - len} )

let read stream len =
  if len > stream.unread then raise Need_more_data ;
  if len <= stream.current.len then
    let (res, current) = split stream.current len in
    (res, {stream with current; unread = stream.unread - len})
  else
    let res = {buffer = Bytes.create len; ofs = 0; len} in
    Bytes.blit
      stream.current.buffer
      stream.current.ofs
      res.buffer
      0
      stream.current.len ;
    let rec loop ofs pending_rev = function
      | [] ->
          loop ofs [] (List.rev pending_rev)
      | buffer :: pending ->
          let current = {buffer; ofs = 0; len = Bytes.length buffer} in
          let to_read = len - ofs in
          if to_read <= current.len then (
            Bytes.blit current.buffer 0 res.buffer ofs to_read ;
            ( res,
              {
                current =
                  {current with ofs = to_read; len = current.len - to_read};
                pending;
                pending_rev;
                unread = stream.unread - len;
              } ) )
          else (
            Bytes.blit current.buffer 0 res.buffer ofs current.len ;
            loop (ofs + current.len) pending_rev pending )
    in
    loop stream.current.len stream.pending_rev stream.pending
src/lib_data_encoding/binary_stream.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record buffer := {
  buffer : Stdlib.Bytes.t;
  ofs : Z;
  len : Z }.

Record t := {
  current : buffer;
  pending : list Stdlib.Bytes.t;
  pending_rev : list Stdlib.Bytes.t;
  unread : Z }.

Definition is_empty (function_parameter : t) : bool :=
  match function_parameter with
  | {| unread := unread |} => equiv_decb unread 0
  end.

Definition of_buffer (current : buffer) : t :=
  {| current := current; pending := []; pending_rev := []; unread := len current
    |}.

Definition of_bytes (buffer : Stdlib.Bytes.t) : t :=
  let len := String.length buffer in
  of_buffer {| buffer := buffer; ofs := 0; len := len |}.

Definition empty : t := of_bytes (Stdlib.Bytes.create 0).

Definition push (buffer : Stdlib.Bytes.t) (stream : t) : t := record.

Definition split (buffer : buffer) (len : Z) : buffer * buffer :=
  OCaml.Stdlib.le len (len buffer);
  (record, record).

Definition read (stream : t) (len : Z) : buffer * t :=
  if OCaml.Stdlib.gt len (unread stream) then
    Stdlib.raise Need_more_data
  else
    tt;
  if OCaml.Stdlib.le len (len (current stream)) then
    match split (current stream) len with
    | (res, current) => (res, record)
    end
  else
    let res := {| buffer := Stdlib.Bytes.create len; ofs := 0; len := len |} in
    Stdlib.Bytes.blit (buffer (current stream)) (ofs (current stream))
      (buffer res) 0 (len (current stream));
    let fix loop
      (ofs : Z) (pending_rev : list Stdlib.Bytes.t) (function_parameter :
      list Stdlib.Bytes.t) : buffer * t :=
      match function_parameter with
      | [] => loop ofs [] (List.rev pending_rev)
      | cons buffer pending =>
        let current :=
          {| buffer := buffer; ofs := 0; len := String.length buffer |} in
        let to_read := Z.sub len ofs in
        if OCaml.Stdlib.le to_read (len current) then
          Stdlib.Bytes.blit (buffer current) 0 (buffer res) ofs to_read;
          (res,
            {| current := record; pending := pending;
              pending_rev := pending_rev; unread := Z.sub (unread stream) len |})
        else
          Stdlib.Bytes.blit (buffer current) 0 (buffer res) ofs (len current);
          loop (Z.add ofs (len current)) pending_rev pending
      end in
    loop (len (current stream)) (pending_rev stream) (pending stream).
src/lib_data_encoding/binary_stream.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type buffer = {buffer : Bytes.t; ofs : int; len : int}

exception Need_more_data

val is_empty : t -> bool

val empty : t

val of_buffer : buffer -> t

val read : t -> int -> buffer * t

val push : Bytes.t -> t -> t
src/lib_data_encoding/binary_stream.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Record buffer := {
  buffer : Stdlib.Bytes.t;
  ofs : Z;
  len : Z }.

exception

Parameter is_empty : t -> bool.

Parameter empty : t.

Parameter of_buffer : buffer -> t.

Parameter read : t -> Z -> buffer * t.

Parameter push : Stdlib.Bytes.t -> t -> t.
src/lib_data_encoding/binary_stream_reader.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Binary_error

let raise e = raise (Read_error e)

(** Persistent state of the binary reader. *)
type state = {
  stream : Binary_stream.t;  (** All the remaining data to be read. *)
  remaining_bytes : int option;
      (** Total number of bytes that should be from 'stream' (None =
      illimited). Reading less bytes should raise [Extra_bytes] and
      trying to read more bytes should raise [Not_enough_data]. *)
  allowed_bytes : int option;
      (** Maximum number of bytes that are allowed to be read from 'stream'
      before to fail (None = illimited). *)
  total_read : int;
      (** Total number of bytes that has been read from [stream] since the
      beginning. *)
}

(** Return type for the function [read_rec]. See [Data_encoding] for its
    description. *)
type 'ret status =
  | Success of {result : 'ret; size : int; stream : Binary_stream.t}
  | Await of (Bytes.t -> 'ret status)
  | Error of read_error

let check_remaining_bytes state size =
  match state.remaining_bytes with
  | Some len when len < size ->
      raise Not_enough_data
  | Some len ->
      Some (len - size)
  | None ->
      None

let check_allowed_bytes state size =
  match state.allowed_bytes with
  | Some len when len < size ->
      raise Size_limit_exceeded
  | Some len ->
      Some (len - size)
  | None ->
      None

(** [read_atom resume size conv state k] reads [size] bytes from [state],
    pass it to [conv] to be decoded, and finally call the continuation [k]
    with the decoded value and the updated state.

    The function [conv] is also allowed to raise [Read_error err].
    In that case the exception is catched and [Error err] is returned.

    If there is not enough [remaining_bytes] to be read in [state], the
    function returns [Error Not_enough_data] instead of calling
    the continuation.

    If there is not enough [allowed_bytes] to be read in [state], the
    function returns [Error Size_limit_exceeded] instead of calling
    the continuation.

    If there is not enough bytes to be read in [state], the function
    returns [Await resume] instead of calling the continuation. *)
let read_atom resume size conv state k =
  match
    let remaining_bytes = check_remaining_bytes state size in
    let allowed_bytes = check_allowed_bytes state size in
    let (res, stream) = Binary_stream.read state.stream size in
    ( conv res.buffer res.ofs,
      {
        remaining_bytes;
        allowed_bytes;
        stream;
        total_read = state.total_read + size;
      } )
  with
  | exception Read_error error ->
      Error error
  | exception Binary_stream.Need_more_data ->
      Await resume
  | v ->
      k v

(* tail call *)

(** Reader for all the atomic types. *)
module Atom = struct
  let uint8 r = read_atom r Binary_size.uint8 TzEndian.get_uint8

  let uint16 r = read_atom r Binary_size.int16 TzEndian.get_uint16

  let int8 r = read_atom r Binary_size.int8 TzEndian.get_int8

  let int16 r = read_atom r Binary_size.int16 TzEndian.get_int16

  let int32 r = read_atom r Binary_size.int32 TzEndian.get_int32

  let int64 r = read_atom r Binary_size.int64 TzEndian.get_int64

  let float r = read_atom r Binary_size.float TzEndian.get_double

  let bool resume state k =
    int8 resume state @@ fun (v, state) -> k (v <> 0, state)

  let uint30 r =
    read_atom r Binary_size.uint30
    @@ fun buffer ofs ->
    let v = Int32.to_int (TzEndian.get_int32 buffer ofs) in
    if v < 0 then raise (Invalid_int {min = 0; v; max = (1 lsl 30) - 1}) ;
    v

  let int31 r =
    read_atom r Binary_size.int31
    @@ fun buffer ofs -> Int32.to_int (TzEndian.get_int32 buffer ofs)

  let int = function
    | `Int31 ->
        int31
    | `Int16 ->
        int16
    | `Int8 ->
        int8
    | `Uint30 ->
        uint30
    | `Uint16 ->
        uint16
    | `Uint8 ->
        uint8

  let ranged_int ~minimum ~maximum resume state k =
    let read_int =
      match Binary_size.range_to_size ~minimum ~maximum with
      | `Int8 ->
          int8
      | `Int16 ->
          int16
      | `Int31 ->
          int31
      | `Uint8 ->
          uint8
      | `Uint16 ->
          uint16
      | `Uint30 ->
          uint30
    in
    read_int resume state
    @@ fun (ranged, state) ->
    let ranged = if minimum > 0 then ranged + minimum else ranged in
    if not (minimum <= ranged && ranged <= maximum) then
      Error (Invalid_int {min = minimum; v = ranged; max = maximum})
    else k (ranged, state)

  let ranged_float ~minimum ~maximum resume state k =
    float resume state
    @@ fun (ranged, state) ->
    if not (minimum <= ranged && ranged <= maximum) then
      Error (Invalid_float {min = minimum; v = ranged; max = maximum})
    else k (ranged, state)

  let rec read_z res value bit_in_value state k =
    let resume buffer =
      let stream = Binary_stream.push buffer state.stream in
      read_z res value bit_in_value {state with stream} k
    in
    uint8 resume state
    @@ fun (byte, state) ->
    let value = value lor ((byte land 0x7F) lsl bit_in_value) in
    let bit_in_value = bit_in_value + 7 in
    let (bit_in_value, value) =
      if bit_in_value < 8 then (bit_in_value, value)
      else (
        Buffer.add_char res (Char.unsafe_chr (value land 0xFF)) ;
        (bit_in_value - 8, value lsr 8) )
    in
    if byte land 0x80 = 0x80 then read_z res value bit_in_value state k
    else (
      if bit_in_value > 0 then Buffer.add_char res (Char.unsafe_chr value) ;
      if byte = 0x00 then raise Trailing_zero ;
      k (Z.of_bits (Buffer.contents res), state) )

  let n resume state k =
    uint8 resume state
    @@ fun (first, state) ->
    let first_value = first land 0x7F in
    if first land 0x80 = 0x80 then
      read_z (Buffer.create 100) first_value 7 state k
    else k (Z.of_int first_value, state)

  let z resume state k =
    uint8 resume state
    @@ fun (first, state) ->
    let first_value = first land 0x3F in
    let sign = first land 0x40 <> 0 in
    if first land 0x80 = 0x80 then
      read_z (Buffer.create 100) first_value 6 state
      @@ fun (n, state) -> k ((if sign then Z.neg n else n), state)
    else
      let n = Z.of_int first_value in
      k ((if sign then Z.neg n else n), state)

  let string_enum arr resume state k =
    let read_index =
      match Binary_size.enum_size arr with
      | `Uint8 ->
          uint8
      | `Uint16 ->
          uint16
      | `Uint30 ->
          uint30
    in
    read_index resume state
    @@ fun (index, state) ->
    if index >= Array.length arr then Error No_case_matched
    else k (arr.(index), state)

  let fixed_length_bytes length r =
    read_atom r length @@ fun buf ofs -> Bytes.sub buf ofs length

  let fixed_length_string length r =
    read_atom r length @@ fun buf ofs -> Bytes.sub_string buf ofs length

  let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end

let rec skip n state k =
  let resume buffer =
    let stream = Binary_stream.push buffer state.stream in
    try skip n {state with stream} k with Read_error err -> Error err
  in
  Atom.fixed_length_string n resume state
  @@ fun ((_, state) : string * _) -> k state

(** Main recursive reading function, in continuation passing style. *)
let rec read_rec :
    type next ret.
    bool ->
    next Encoding.t ->
    state ->
    (next * state -> ret status) ->
    ret status =
 fun whole e state k ->
  let resume buffer =
    let stream = Binary_stream.push buffer state.stream in
    try read_rec whole e {state with stream} k
    with Read_error err -> Error err
  in
  let open Encoding in
  assert (Encoding.classify e <> `Variable || state.remaining_bytes <> None) ;
  match e.encoding with
  | Null ->
      k ((), state)
  | Empty ->
      k ((), state)
  | Constant _ ->
      k ((), state)
  | Ignore ->
      k ((), state)
  | Bool ->
      Atom.bool resume state k
  | Int8 ->
      Atom.int8 resume state k
  | Uint8 ->
      Atom.uint8 resume state k
  | Int16 ->
      Atom.int16 resume state k
  | Uint16 ->
      Atom.uint16 resume state k
  | Int31 ->
      Atom.int31 resume state k
  | Int32 ->
      Atom.int32 resume state k
  | Int64 ->
      Atom.int64 resume state k
  | N ->
      Atom.n resume state k
  | Z ->
      Atom.z resume state k
  | Float ->
      Atom.float resume state k
  | Bytes (`Fixed n) ->
      Atom.fixed_length_bytes n resume state k
  | Bytes `Variable ->
      let size = remaining_bytes state in
      Atom.fixed_length_bytes size resume state k
  | String (`Fixed n) ->
      Atom.fixed_length_string n resume state k
  | String `Variable ->
      let size = remaining_bytes state in
      Atom.fixed_length_string size resume state k
  | Padded (e, n) ->
      read_rec false e state
      @@ fun (v, state) -> skip n state @@ fun state -> k (v, state)
  | RangedInt {minimum; maximum} ->
      Atom.ranged_int ~minimum ~maximum resume state k
  | RangedFloat {minimum; maximum} ->
      Atom.ranged_float ~minimum ~maximum resume state k
  | String_enum (_, arr) ->
      Atom.string_enum arr resume state k
  | Array (max_length, e) ->
      let max_length = match max_length with Some l -> l | None -> max_int in
      read_list Array_too_long max_length e state
      @@ fun (l, state) -> k (Array.of_list l, state)
  | List (max_length, e) ->
      let max_length = match max_length with Some l -> l | None -> max_int in
      read_list List_too_long max_length e state k
  | Obj (Req {encoding = e; _}) ->
      read_rec whole e state k
  | Obj (Dft {encoding = e; _}) ->
      read_rec whole e state k
  | Obj (Opt {kind = `Dynamic; encoding = e; _}) ->
      Atom.bool resume state
      @@ fun (present, state) ->
      if not present then k (None, state)
      else read_rec whole e state @@ fun (v, state) -> k (Some v, state)
  | Obj (Opt {kind = `Variable; encoding = e; _}) ->
      let size = remaining_bytes state in
      if size = 0 then k (None, state)
      else read_rec whole e state @@ fun (v, state) -> k (Some v, state)
  | Objs {kind = `Fixed sz; left; right} ->
      ignore (check_remaining_bytes state sz : int option) ;
      ignore (check_allowed_bytes state sz : int option) ;
      read_rec false left state
      @@ fun (left, state) ->
      read_rec whole right state
      @@ fun (right, state) -> k ((left, right), state)
  | Objs {kind = `Dynamic; left; right} ->
      read_rec false left state
      @@ fun (left, state) ->
      read_rec whole right state
      @@ fun (right, state) -> k ((left, right), state)
  | Objs {kind = `Variable; left; right} ->
      read_variable_pair left right state k
  | Tup e ->
      read_rec whole e state k
  | Tups {kind = `Fixed sz; left; right} ->
      ignore (check_remaining_bytes state sz : int option) ;
      ignore (check_allowed_bytes state sz : int option) ;
      read_rec false left state
      @@ fun (left, state) ->
      read_rec whole right state
      @@ fun (right, state) -> k ((left, right), state)
  | Tups {kind = `Dynamic; left; right} ->
      read_rec false left state
      @@ fun (left, state) ->
      read_rec whole right state
      @@ fun (right, state) -> k ((left, right), state)
  | Tups {kind = `Variable; left; right} ->
      read_variable_pair left right state k
  | Conv {inj; encoding; _} ->
      read_rec whole encoding state @@ fun (v, state) -> k (inj v, state)
  | Union {tag_size; cases; _} -> (
      Atom.tag tag_size resume state
      @@ fun (ctag, state) ->
      match
        List.find_opt
          (function
            | Case {tag = Tag tag; _} ->
                tag = ctag
            | Case {tag = Json_only; _} ->
                false)
          cases
      with
      | None ->
          Error (Unexpected_tag ctag)
      | Some (Case {encoding; inj; _}) ->
          read_rec whole encoding state @@ fun (v, state) -> k (inj v, state) )
  | Dynamic_size {kind; encoding = e} ->
      Atom.int kind resume state
      @@ fun (sz, state) ->
      let remaining = check_remaining_bytes state sz in
      let state = {state with remaining_bytes = Some sz} in
      ignore (check_allowed_bytes state sz : int option) ;
      read_rec true e state
      @@ fun (v, state) ->
      if state.remaining_bytes <> Some 0 then Error Extra_bytes
      else k (v, {state with remaining_bytes = remaining})
  | Check_size {limit; encoding = e} ->
      let old_allowed_bytes = state.allowed_bytes in
      let limit =
        match state.allowed_bytes with
        | None ->
            limit
        | Some current_limit ->
            min current_limit limit
      in
      ( match state.remaining_bytes with
      | Some remaining when whole && limit < remaining ->
          raise Size_limit_exceeded
      | _ ->
          () ) ;
      let state = {state with allowed_bytes = Some limit} in
      read_rec whole e state
      @@ fun (v, state) ->
      let allowed_bytes =
        match old_allowed_bytes with
        | None ->
            None
        | Some old_limit ->
            let remaining =
              match state.allowed_bytes with
              | None ->
                  assert false
              | Some remaining ->
                  remaining
            in
            let read = limit - remaining in
            Some (old_limit - read)
      in
      k (v, {state with allowed_bytes})
  | Describe {encoding = e; _} ->
      read_rec whole e state k
  | Splitted {encoding = e; _} ->
      read_rec whole e state k
  | Mu {fix; _} ->
      read_rec whole (fix e) state k
  | Delayed f ->
      read_rec whole (f ()) state k

and remaining_bytes {remaining_bytes; _} =
  match remaining_bytes with
  | None ->
      (* This function should only be called with a variable encoding,
         for which the `remaining_bytes` should never be `None`. *)
      assert false
  | Some len ->
      len

and read_variable_pair :
    type left right ret.
    left Encoding.t ->
    right Encoding.t ->
    state ->
    ((left * right) * state -> ret status) ->
    ret status =
 fun e1 e2 state k ->
  let size = remaining_bytes state in
  match (Encoding.classify e1, Encoding.classify e2) with
  | ((`Dynamic | `Fixed _), `Variable) ->
      read_rec false e1 state
      @@ fun (left, state) ->
      read_rec true e2 state @@ fun (right, state) -> k ((left, right), state)
  | (`Variable, `Fixed n) ->
      if n > size then Error Not_enough_data
      else
        let state = {state with remaining_bytes = Some (size - n)} in
        read_rec true e1 state
        @@ fun (left, state) ->
        assert (state.remaining_bytes = Some 0) ;
        let state = {state with remaining_bytes = Some n} in
        read_rec true e2 state
        @@ fun (right, state) ->
        assert (state.remaining_bytes = Some 0) ;
        k ((left, right), state)
  | _ ->
      assert false

(* Should be rejected by [Encoding.Kind.combine] *)
and read_list :
    type a ret.
    read_error ->
    int ->
    a Encoding.t ->
    state ->
    (a list * state -> ret status) ->
    ret status =
 fun error max_length e state k ->
  let rec loop state acc max_length =
    let size = remaining_bytes state in
    if size = 0 then k (List.rev acc, state)
    else if max_length = 0 then raise error
    else
      read_rec false e state
      @@ fun (v, state) -> loop state (v :: acc) (max_length - 1)
  in
  loop state [] max_length

let read_rec e state k =
  try read_rec false e state k with Read_error err -> Error err

(** ******************** *)

(** Various entry points *)

let success (v, state) =
  Success {result = v; size = state.total_read; stream = state.stream}

let read_stream ?(init = Binary_stream.empty) encoding =
  match Encoding.classify encoding with
  | `Variable ->
      invalid_arg "Data_encoding.Binary.read_stream: variable encoding"
  | `Dynamic | `Fixed _ ->
      (* No hardcoded read limit in a stream. *)
      let state =
        {
          remaining_bytes = None;
          allowed_bytes = None;
          stream = init;
          total_read = 0;
        }
      in
      read_rec encoding state success
src/lib_data_encoding/binary_stream_reader.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Binary_error.

Definition raise {A : Type} (e : Tezos_data_encoding.Binary_error.read_error)
  : A := Stdlib.raise (Read_error e).

Record state := {
  stream : Tezos_data_encoding.Binary_stream.t;
  remaining_bytes : option Z;
  allowed_bytes : option Z;
  total_read : Z }.

Inductive status (ret : Type) : Type :=
| Success : ret -> Z -> Tezos_data_encoding.Binary_stream.t -> status ret
| Await : (Stdlib.Bytes.t -> status ret) -> status ret
| Error : Tezos_data_encoding.Binary_error.read_error -> status ret.

Arguments Success {_}.
Arguments Await {_}.
Arguments Error {_}.

Definition check_remaining_bytes (state : state) (size : Z) : option Z :=
  match remaining_bytes state with
  | Some len => Some (Z.sub len size)
  | None => None
  end.

Definition check_allowed_bytes (state : state) (size : Z) : option Z :=
  match allowed_bytes state with
  | Some len => Some (Z.sub len size)
  | None => None
  end.

Definition read_atom {A B : Type}
  (resume : Stdlib.Bytes.t -> status A) (size : Z)
  (conv : Stdlib.Bytes.t -> Z -> B) (state : state)
  (k : (B * state) -> status A) : status A :=
  match
    let remaining_bytes := check_remaining_bytes state size in
    let allowed_bytes := check_allowed_bytes state size in
    match Tezos_data_encoding.Binary_stream.read (stream state) size with
    | (res, stream) =>
      ((conv (buffer res) (ofs res)),
        {| stream := stream; remaining_bytes := remaining_bytes;
          allowed_bytes := allowed_bytes;
          total_read := Z.add (total_read state) size |})
    end with
  | v => k v
  end.

Module Atom.
  Definition uint8 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Tezos_data_encoding.Binary_size.uint8
      Tezos_data_encoding.TzEndian.get_uint8.
  
  Definition uint16 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Tezos_data_encoding.Binary_size.int16
      Tezos_data_encoding.TzEndian.get_uint16.
  
  Definition int8 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Tezos_data_encoding.Binary_size.int8
      Tezos_data_encoding.TzEndian.get_int8.
  
  Definition int16 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Tezos_data_encoding.Binary_size.int16
      Tezos_data_encoding.TzEndian.get_int16.
  
  Definition int32 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((int32 * state) -> status A) -> status A :=
    read_atom r Tezos_data_encoding.Binary_size.int32
      Tezos_data_encoding.TzEndian.get_int32.
  
  Definition int64 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((int64 * state) -> status A) -> status A :=
    read_atom r Tezos_data_encoding.Binary_size.int64
      Tezos_data_encoding.TzEndian.get_int64.
  
  Definition float {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((float * state) -> status A) -> status A :=
    read_atom r Tezos_data_encoding.Binary_size.float
      Tezos_data_encoding.TzEndian.get_double.
  
  Definition bool {A : Type}
    (resume : Stdlib.Bytes.t -> status A) (state : state)
    (k : (bool * state) -> status A) : status A :=
    apply (int8 resume state)
      (fun function_parameter =>
        match function_parameter with
        | (v, state) => k ((nequiv_decb v 0), state)
        end).
  
  Definition uint30 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    apply (read_atom r Tezos_data_encoding.Binary_size.uint30)
      (fun buffer =>
        fun ofs =>
          let v :=
            Stdlib.Int32.to_int
              (Tezos_data_encoding.TzEndian.get_int32 buffer ofs) in
          if OCaml.Stdlib.lt v 0 then
            raise
              (Invalid_int
                {| min := 0; v := v; max := Z.sub (Z.shiftl 1 30) 1 |})
          else
            tt;
          v).
  
  Definition int31 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    apply (read_atom r Tezos_data_encoding.Binary_size.int31)
      (fun buffer =>
        fun ofs =>
          Stdlib.Int32.to_int
            (Tezos_data_encoding.TzEndian.get_int32 buffer ofs)).
  
  Definition int {A : Type} (function_parameter : variant)
    : (Stdlib.Bytes.t -> status A) ->
      state -> ((Z * state) -> status A) -> status A :=
    match function_parameter with
    | Int31 => int31
    | Int16 => int16
    | Int8 => int8
    | Uint30 => uint30
    | Uint16 => uint16
    | Uint8 => uint8
    end.
  
  Definition ranged_int {A : Type}
    (minimum : Z) (maximum : Z) (resume : Stdlib.Bytes.t -> status A)
    (state : state) (k : (Z * state) -> status A) : status A :=
    let read_int :=
      match Tezos_data_encoding.Binary_size.range_to_size minimum maximum with
      | Int8 => int8
      | Int16 => int16
      | Int31 => int31
      | Uint8 => uint8
      | Uint16 => uint16
      | Uint30 => uint30
      end in
    apply (read_int resume state)
      (fun function_parameter =>
        match function_parameter with
        | (ranged, state) =>
          let ranged :=
            if OCaml.Stdlib.gt minimum 0 then
              Z.add ranged minimum
            else
              ranged in
          if
            negb
              (andb (OCaml.Stdlib.le minimum ranged)
                (OCaml.Stdlib.le ranged maximum)) then
            inr (Invalid_int {| min := minimum; v := ranged; max := maximum |})
          else
            k (ranged, state)
        end).
  
  Definition ranged_float {A : Type}
    (minimum : float) (maximum : float) (resume : Stdlib.Bytes.t -> status A)
    (state : state) (k : (float * state) -> status A) : status A :=
    apply (float resume state)
      (fun function_parameter =>
        match function_parameter with
        | (ranged, state) =>
          if
            negb
              (andb (OCaml.Stdlib.le minimum ranged)
                (OCaml.Stdlib.le ranged maximum)) then
            inr
              (Invalid_float {| min := minimum; v := ranged; max := maximum |})
          else
            k (ranged, state)
        end).
  
  Fixpoint read_z {A : Type}
    (res : Stdlib.Buffer.t) (value : Z) (bit_in_value : Z) (state : state)
    (k : (Z.t * state) -> status A) : status A :=
    let resume (buffer : Stdlib.Bytes.t) : status A :=
      let stream := Tezos_data_encoding.Binary_stream.push buffer (stream state)
        in
      read_z res value bit_in_value record k in
    apply (uint8 resume state)
      (fun function_parameter =>
        match function_parameter with
        | (byte, state) =>
          let value := Z.lor value (Z.shiftl (Z.land byte 127) bit_in_value) in
          let bit_in_value := Z.add bit_in_value 7 in
          match
            if OCaml.Stdlib.lt bit_in_value 8 then
              (bit_in_value, value)
            else
              Stdlib.Buffer.add_char res
                (Stdlib.Char.unsafe_chr (Z.land value 255));
              ((Z.sub bit_in_value 8), (Z.shiftr value 8)) with
          | (bit_in_value, value) =>
            if equiv_decb (Z.land byte 128) 128 then
              read_z res value bit_in_value state k
            else
              if OCaml.Stdlib.gt bit_in_value 0 then
                Stdlib.Buffer.add_char res (Stdlib.Char.unsafe_chr value)
              else
                tt;
              if equiv_decb byte 0 then
                raise Trailing_zero
              else
                tt;
              k ((Z.of_bits (Stdlib.Buffer.contents res)), state)
          end
        end).
  
  Definition n {A : Type}
    (resume : Stdlib.Bytes.t -> status A) (state : state)
    (k : (Z.t * state) -> status A) : status A :=
    apply (uint8 resume state)
      (fun function_parameter =>
        match function_parameter with
        | (first, state) =>
          let first_value := Z.land first 127 in
          if equiv_decb (Z.land first 128) 128 then
            read_z (Stdlib.Buffer.create 100) first_value 7 state k
          else
            k ((Z.of_int first_value), state)
        end).
  
  Definition z {A : Type}
    (resume : Stdlib.Bytes.t -> status A) (state : state)
    (k : (Z.t * state) -> status A) : status A :=
    apply (uint8 resume state)
      (fun function_parameter =>
        match function_parameter with
        | (first, state) =>
          let first_value := Z.land first 63 in
          let sign := nequiv_decb (Z.land first 64) 0 in
          if equiv_decb (Z.land first 128) 128 then
            apply (read_z (Stdlib.Buffer.create 100) first_value 6 state)
              (fun function_parameter =>
                match function_parameter with
                | (n, state) =>
                  k
                    ((if sign then
                      Z.neg n
                    else
                      n), state)
                end)
          else
            let n := Z.of_int first_value in
            k
              ((if sign then
                Z.neg n
              else
                n), state)
        end).
  
  Definition string_enum {A B : Type}
    (arr : array A) (resume : Stdlib.Bytes.t -> status B) (state : state)
    (k : (A * state) -> status B) : status B :=
    let read_index :=
      match Tezos_data_encoding.Binary_size.enum_size arr with
      | Uint8 => uint8
      | Uint16 => uint16
      | Uint30 => uint30
      end in
    apply (read_index resume state)
      (fun function_parameter =>
        match function_parameter with
        | (index, state) =>
          if OCaml.Stdlib.ge index (Stdlib.Array.length arr) then
            inr No_case_matched
          else
            k ((Stdlib.Array.get arr index), state)
        end).
  
  Definition fixed_length_bytes {A : Type}
    (length : Z) (r : Stdlib.Bytes.t -> status A)
    : state -> ((string * state) -> status A) -> status A :=
    apply (read_atom r length) (fun buf => fun ofs => String.sub buf ofs length).
  
  Definition fixed_length_string {A : Type}
    (length : Z) (r : Stdlib.Bytes.t -> status A)
    : state -> ((string * state) -> status A) -> status A :=
    apply (read_atom r length)
      (fun buf => fun ofs => Stdlib.Bytes.sub_string buf ofs length).
  
  Definition tag {A : Type} (function_parameter : variant)
    : (Stdlib.Bytes.t -> status A) ->
      state -> ((Z * state) -> status A) -> status A :=
    match function_parameter with
    | Uint8 => uint8
    | Uint16 => uint16
    end.
End Atom.

Fixpoint skip {A : Type} (n : Z) (state : state) (k : state -> status A)
  : status A :=
  let resume (buffer : Stdlib.Bytes.t) : status A :=
    let stream := Tezos_data_encoding.Binary_stream.push buffer (stream state)
      in
    try in
  apply (Atom.fixed_length_string n resume state)
    (fun function_parameter =>
      match function_parameter with
      | (_, state) => k state
      end).

Fixpoint read_rec {next ret : Type}
  (whole : bool) (e : Tezos_data_encoding.Encoding.t next) (state : state)
  (k : (next * state) -> status ret) : status ret :=
  let resume (buffer : Stdlib.Bytes.t) : status ret :=
    let stream := Tezos_data_encoding.Binary_stream.push buffer (stream state)
      in
    try in
  orb (nequiv_decb (Tezos_data_encoding.Encoding.classify e) variant)
    (nequiv_decb (remaining_bytes state) None);
  match encoding e with
  | Null => k (tt, state)
  | Empty => k (tt, state)
  | Constant _ => k (tt, state)
  | Ignore => k (tt, state)
  | Bool => Atom.bool resume state k
  | Int8 => Atom.int8 resume state k
  | Uint8 => Atom.uint8 resume state k
  | Int16 => Atom.int16 resume state k
  | Uint16 => Atom.uint16 resume state k
  | Int31 => Atom.int31 resume state k
  | Int32 => Atom.int32 resume state k
  | Int64 => Atom.int64 resume state k
  | N => Atom.n resume state k
  | Z => Atom.z resume state k
  | Float => Atom.float resume state k
  | Bytes (Fixed n) => Atom.fixed_length_bytes n resume state k
  | Bytes Variable =>
    let size := remaining_bytes state in
    Atom.fixed_length_bytes size resume state k
  | String (Fixed n) => Atom.fixed_length_string n resume state k
  | String Variable =>
    let size := remaining_bytes state in
    Atom.fixed_length_string size resume state k
  | Padded e n =>
    apply (read_rec false e state)
      (fun function_parameter =>
        match function_parameter with
        | (v, state) => apply (skip n state) (fun state => k (v, state))
        end)
  | RangedInt {| minimum := minimum; maximum := maximum |} =>
    Atom.ranged_int minimum maximum resume state k
  | RangedFloat {| minimum := minimum; maximum := maximum |} =>
    Atom.ranged_float minimum maximum resume state k
  | String_enum _ arr => Atom.string_enum arr resume state k
  | Array max_length e =>
    let max_length :=
      match max_length with
      | Some l => l
      | None => Stdlib.max_int
      end in
    apply (read_list Array_too_long max_length e state)
      (fun function_parameter =>
        match function_parameter with
        | (l, state) => k ((Stdlib.Array.of_list l), state)
        end)
  | List max_length e =>
    let max_length :=
      match max_length with
      | Some l => l
      | None => Stdlib.max_int
      end in
    read_list List_too_long max_length e state k
  | Obj (Req {| encoding := e |}) => read_rec whole e state k
  | Obj (Dft {| encoding := e |}) => read_rec whole e state k
  | Obj (Opt {| kind := Dynamic; encoding := e |}) =>
    apply (Atom.bool resume state)
      (fun function_parameter =>
        match function_parameter with
        | (present, state) =>
          if negb present then
            k (None, state)
          else
            apply (read_rec whole e state)
              (fun function_parameter =>
                match function_parameter with
                | (v, state) => k ((Some v), state)
                end)
        end)
  | Obj (Opt {| kind := Variable; encoding := e |}) =>
    let size := remaining_bytes state in
    if equiv_decb size 0 then
      k (None, state)
    else
      apply (read_rec whole e state)
        (fun function_parameter =>
          match function_parameter with
          | (v, state) => k ((Some v), state)
          end)
  | Objs {| kind := Fixed sz; left := left; right := right |} =>
    OCaml.Stdlib.ignore (check_remaining_bytes state sz);
    OCaml.Stdlib.ignore (check_allowed_bytes state sz);
    apply (read_rec false left state)
      (fun function_parameter =>
        match function_parameter with
        | (left, state) =>
          apply (read_rec whole right state)
            (fun function_parameter =>
              match function_parameter with
              | (right, state) => k ((left, right), state)
              end)
        end)
  | Objs {| kind := Dynamic; left := left; right := right |} =>
    apply (read_rec false left state)
      (fun function_parameter =>
        match function_parameter with
        | (left, state) =>
          apply (read_rec whole right state)
            (fun function_parameter =>
              match function_parameter with
              | (right, state) => k ((left, right), state)
              end)
        end)
  | Objs {| kind := Variable; left := left; right := right |} =>
    read_variable_pair left right state k
  | Tup e => read_rec whole e state k
  | Tups {| kind := Fixed sz; left := left; right := right |} =>
    OCaml.Stdlib.ignore (check_remaining_bytes state sz);
    OCaml.Stdlib.ignore (check_allowed_bytes state sz);
    apply (read_rec false left state)
      (fun function_parameter =>
        match function_parameter with
        | (left, state) =>
          apply (read_rec whole right state)
            (fun function_parameter =>
              match function_parameter with
              | (right, state) => k ((left, right), state)
              end)
        end)
  | Tups {| kind := Dynamic; left := left; right := right |} =>
    apply (read_rec false left state)
      (fun function_parameter =>
        match function_parameter with
        | (left, state) =>
          apply (read_rec whole right state)
            (fun function_parameter =>
              match function_parameter with
              | (right, state) => k ((left, right), state)
              end)
        end)
  | Tups {| kind := Variable; left := left; right := right |} =>
    read_variable_pair left right state k
  | Conv {| inj := inj; encoding := encoding |} =>
    apply (read_rec whole encoding state)
      (fun function_parameter =>
        match function_parameter with
        | (v, state) => k ((inj v), state)
        end)
  | Union {| tag_size := tag_size; cases := cases |} =>
    apply (Atom.tag tag_size resume state)
      (fun function_parameter =>
        match function_parameter with
        | (ctag, state) =>
          match
            Stdlib.List.find_opt
              (fun function_parameter =>
                match function_parameter with
                | Case {| tag := Tag tag |} => equiv_decb tag ctag
                | Case {| tag := Json_only |} => false
                end) cases with
          | None => inr (Unexpected_tag ctag)
          | Some (Case {| encoding := encoding; inj := inj |}) =>
            apply (read_rec whole encoding state)
              (fun function_parameter =>
                match function_parameter with
                | (v, state) => k ((inj v), state)
                end)
          end
        end)
  | Dynamic_size {| kind := kind; encoding := e |} =>
    apply (Atom.int kind resume state)
      (fun function_parameter =>
        match function_parameter with
        | (sz, state) =>
          let remaining := check_remaining_bytes state sz in
          let state := record in
          OCaml.Stdlib.ignore (check_allowed_bytes state sz);
          apply (read_rec true e state)
            (fun function_parameter =>
              match function_parameter with
              | (v, state) =>
                if nequiv_decb (remaining_bytes state) (Some 0) then
                  inr Extra_bytes
                else
                  k (v, record)
              end)
        end)
  | Check_size {| limit := limit; encoding := e |} =>
    let old_allowed_bytes := allowed_bytes state in
    let limit :=
      match allowed_bytes state with
      | None => limit
      | Some current_limit => OCaml.Stdlib.min current_limit limit
      end in
    match remaining_bytes state with
    | _ => tt
    end;
    let state := record in
    apply (read_rec whole e state)
      (fun function_parameter =>
        match function_parameter with
        | (v, state) =>
          let allowed_bytes :=
            match old_allowed_bytes with
            | None => None
            | Some old_limit =>
              let remaining :=
                match allowed_bytes state with
                | None => false
                | Some remaining => remaining
                end in
              let read := Z.sub limit remaining in
              Some (Z.sub old_limit read)
            end in
          k (v, record)
        end)
  | Describe {| encoding := e |} => read_rec whole e state k
  | Splitted {| encoding := e |} => read_rec whole e state k
  | Mu {| fix := fix |} => read_rec whole (fix e) state k
  | Delayed f => read_rec whole (f tt) state k
  end

with remaining_bytes (function_parameter : state) : Z :=
  match function_parameter with
  | {| remaining_bytes := remaining_bytes |} =>
    match remaining_bytes with
    | None => false
    | Some len => len
    end
  end

with read_variable_pair {left ret right : Type}
  (e1 : Tezos_data_encoding.Encoding.t left)
  (e2 : Tezos_data_encoding.Encoding.t right) (state : state)
  (k : ((left * right) * state) -> status ret) : status ret :=
  let size := remaining_bytes state in
  match
    ((Tezos_data_encoding.Encoding.classify e1),
      (Tezos_data_encoding.Encoding.classify e2)) with
  | (Dynamic | Fixed _, Variable) =>
    apply (read_rec false e1 state)
      (fun function_parameter =>
        match function_parameter with
        | (left, state) =>
          apply (read_rec true e2 state)
            (fun function_parameter =>
              match function_parameter with
              | (right, state) => k ((left, right), state)
              end)
        end)
  | (Variable, Fixed n) =>
    if OCaml.Stdlib.gt n size then
      inr Not_enough_data
    else
      let state := record in
      apply (read_rec true e1 state)
        (fun function_parameter =>
          match function_parameter with
          | (left, state) =>
            equiv_decb (remaining_bytes state) (Some 0);
            let state := record in
            apply (read_rec true e2 state)
              (fun function_parameter =>
                match function_parameter with
                | (right, state) =>
                  equiv_decb (remaining_bytes state) (Some 0);
                  k ((left, right), state)
                end)
          end)
  | _ => false
  end

with read_list {a ret : Type}
  (error : Tezos_data_encoding.Binary_error.read_error) (max_length : Z)
  (e : Tezos_data_encoding.Encoding.t a) (state : state)
  (k : ((list a) * state) -> status ret) : status ret :=
  let fix loop (state : state) (acc : list a) (max_length : Z) : status ret :=
    let size := remaining_bytes state in
    if equiv_decb size 0 then
      k ((List.rev acc), state)
    else
      if equiv_decb max_length 0 then
        raise error
      else
        apply (read_rec false e state)
          (fun function_parameter =>
            match function_parameter with
            | (v, state) => loop state (cons v acc) (Z.sub max_length 1)
            end) in
  loop state [] max_length.

Definition read_rec {A B : Type}
  (e : Tezos_data_encoding.Encoding.t A) (state : state)
  (k : (A * state) -> status B) : status B := try.

Definition success {A : Type} (function_parameter : A * state) : status A :=
  match function_parameter with
  | (v, state) =>
    Success {| result := v; size := total_read state; stream := stream state |}
  end.

Definition read_stream {A : Type}
  (op_star_o_p_t_star : option Tezos_data_encoding.Binary_stream.t)
  : (Tezos_data_encoding.Encoding.encoding A) -> status A :=
  let init :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_data_encoding.Binary_stream.empty
    end in
  fun encoding =>
    match Tezos_data_encoding.Encoding.classify encoding with
    | Variable =>
      OCaml.Stdlib.invalid_arg
        "Data_encoding.Binary.read_stream: variable encoding" % string
    | Dynamic | Fixed _ =>
      let state :=
        {| stream := init; remaining_bytes := None; allowed_bytes := None;
          total_read := 0 |} in
      read_rec encoding state success
    end.
src/lib_data_encoding/binary_stream_reader.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Binary}. *)

type 'ret status =
  | Success of {result : 'ret; size : int; stream : Binary_stream.t}
  | Await of (Bytes.t -> 'ret status)
  | Error of Binary_error.read_error

val read_stream : ?init:Binary_stream.t -> 'a Encoding.t -> 'a status
src/lib_data_encoding/binary_stream_reader.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive status (ret : Type) : Type :=
| Success : ret -> Z -> Tezos_data_encoding.Binary_stream.t -> status ret
| Await : (Stdlib.Bytes.t -> status ret) -> status ret
| Error : Tezos_data_encoding.Binary_error.read_error -> status ret.

Arguments Success {_}.
Arguments Await {_}.
Arguments Error {_}.

Parameter read_stream : forall {a : Type},
(option Tezos_data_encoding.Binary_stream.t) ->
  (Tezos_data_encoding.Encoding.t a) -> status a.
src/lib_data_encoding/binary_writer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Binary_error

let raise error = raise (Write_error error)

(** Imperative state of the binary writer. *)
type state = {
  mutable buffer : Bytes.t;  (** The buffer where to write. *)
  mutable offset : int;
      (** The offset of the next byte to be written in [buffer]. *)
  mutable allowed_bytes : int option;
      (** Maximum number of bytes that are allowed to be write in [buffer]
      (after [offset]) before to fail (None = illimited). *)
}

let check_allowed_bytes state size =
  match state.allowed_bytes with
  | Some len when len < size ->
      raise Size_limit_exceeded
  | Some len ->
      state.allowed_bytes <- Some (len - size)
  | None ->
      ()

(** [may_resize state size] will first ensure there is enough
    space in [state.buffer] for writing [size] bytes (starting at
    [state.offset]).

    When the buffer does not have enough space for writing [size] bytes,
    but still has enough [allowed_bytes], it will replace the buffer
    with a buffer large enough.

    @raise [Binary_error.Write_error Size_limit_exceeded] when there is
           not enough allowed bytes to write [size] bytes. *)
let may_resize state size =
  check_allowed_bytes state size ;
  let buffer_len = Bytes.length state.buffer in
  if buffer_len - state.offset < size then (
    let new_buffer = Bytes.create (max (2 * buffer_len) (buffer_len + size)) in
    Bytes.blit state.buffer 0 new_buffer 0 state.offset ;
    state.buffer <- new_buffer ) ;
  state.offset <- state.offset + size

(** Writer for all the atomic types. *)
module Atom = struct
  let check_int_range min v max =
    if v < min || max < v then raise (Invalid_int {min; v; max})

  let check_float_range min v max =
    if v < min || max < v then raise (Invalid_float {min; v; max})

  let set_int kind buffer ofs v =
    match kind with
    | `Int31 | `Uint30 ->
        TzEndian.set_int32 buffer ofs (Int32.of_int v)
    | `Int16 | `Uint16 ->
        TzEndian.set_int16 buffer ofs v
    | `Int8 | `Uint8 ->
        TzEndian.set_int8 buffer ofs v

  let int kind state v =
    check_int_range (Binary_size.min_int kind) v (Binary_size.max_int kind) ;
    let ofs = state.offset in
    may_resize state (Binary_size.integer_to_size kind) ;
    set_int kind state.buffer ofs v

  let int8 = int `Int8

  let uint8 = int `Uint8

  let int16 = int `Int16

  let uint16 = int `Uint16

  let uint30 = int `Uint30

  let int31 = int `Int31

  let bool state v = uint8 state (if v then 255 else 0)

  let int32 state v =
    let ofs = state.offset in
    may_resize state Binary_size.int32 ;
    TzEndian.set_int32 state.buffer ofs v

  let int64 state v =
    let ofs = state.offset in
    may_resize state Binary_size.int64 ;
    TzEndian.set_int64 state.buffer ofs v

  let ranged_int ~minimum ~maximum state v =
    check_int_range minimum v maximum ;
    let v = if minimum >= 0 then v - minimum else v in
    match Binary_size.range_to_size ~minimum ~maximum with
    | `Uint8 ->
        uint8 state v
    | `Uint16 ->
        uint16 state v
    | `Uint30 ->
        uint30 state v
    | `Int8 ->
        int8 state v
    | `Int16 ->
        int16 state v
    | `Int31 ->
        int31 state v

  let n state v =
    if Z.sign v < 0 then raise Invalid_natural ;
    if Z.equal v Z.zero then uint8 state 0x00
    else
      let bits = Z.numbits v in
      let get_chunk pos len = Z.to_int (Z.extract v pos len) in
      let length = Binary_length.n_length v in
      let offset = state.offset in
      may_resize state length ;
      for i = 0 to length - 1 do
        let pos = i * 7 in
        let chunk_len = if i = length - 1 then bits - pos else 7 in
        TzEndian.set_int8
          state.buffer
          (offset + i)
          ((if i = length - 1 then 0x00 else 0x80) lor get_chunk pos chunk_len)
      done

  let z state v =
    let sign = Z.sign v < 0 in
    let bits = Z.numbits v in
    if Z.equal v Z.zero then uint8 state 0x00
    else
      let v = Z.abs v in
      let get_chunk pos len = Z.to_int (Z.extract v pos len) in
      let length = Binary_length.z_length v in
      let offset = state.offset in
      may_resize state length ;
      TzEndian.set_int8
        state.buffer
        offset
        ( (if sign then 0x40 else 0x00)
        lor (if bits > 6 then 0x80 else 0x00)
        lor get_chunk 0 6 ) ;
      for i = 1 to length - 1 do
        let pos = 6 + ((i - 1) * 7) in
        let chunk_len = if i = length - 1 then bits - pos else 7 in
        TzEndian.set_int8
          state.buffer
          (offset + i)
          ((if i = length - 1 then 0x00 else 0x80) lor get_chunk pos chunk_len)
      done

  let float state v =
    let ofs = state.offset in
    may_resize state Binary_size.float ;
    TzEndian.set_double state.buffer ofs v

  let ranged_float ~minimum ~maximum state v =
    check_float_range minimum v maximum ;
    float state v

  let string_enum tbl arr state v =
    let value =
      try snd (Hashtbl.find tbl v) with Not_found -> raise No_case_matched
    in
    match Binary_size.enum_size arr with
    | `Uint30 ->
        uint30 state value
    | `Uint16 ->
        uint16 state value
    | `Uint8 ->
        uint8 state value

  let fixed_kind_bytes length state s =
    if Bytes.length s <> length then
      raise (Invalid_bytes_length {expected = length; found = Bytes.length s}) ;
    let ofs = state.offset in
    may_resize state length ;
    Bytes.blit s 0 state.buffer ofs length

  let fixed_kind_string length state s =
    if String.length s <> length then
      raise
        (Invalid_string_length {expected = length; found = String.length s}) ;
    let ofs = state.offset in
    may_resize state length ;
    Bytes.blit_string s 0 state.buffer ofs length

  let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end

(** Main recursive writing function. *)
let rec write_rec : type a. a Encoding.t -> state -> a -> unit =
 fun e state value ->
  let open Encoding in
  match e.encoding with
  | Null ->
      ()
  | Empty ->
      ()
  | Constant _ ->
      ()
  | Ignore ->
      ()
  | Bool ->
      Atom.bool state value
  | Int8 ->
      Atom.int8 state value
  | Uint8 ->
      Atom.uint8 state value
  | Int16 ->
      Atom.int16 state value
  | Uint16 ->
      Atom.uint16 state value
  | Int31 ->
      Atom.int31 state value
  | Int32 ->
      Atom.int32 state value
  | Int64 ->
      Atom.int64 state value
  | N ->
      Atom.n state value
  | Z ->
      Atom.z state value
  | Float ->
      Atom.float state value
  | Bytes (`Fixed n) ->
      Atom.fixed_kind_bytes n state value
  | Bytes `Variable ->
      let length = Bytes.length value in
      Atom.fixed_kind_bytes length state value
  | String (`Fixed n) ->
      Atom.fixed_kind_string n state value
  | String `Variable ->
      let length = String.length value in
      Atom.fixed_kind_string length state value
  | Padded (e, n) ->
      write_rec e state value ;
      Atom.fixed_kind_string n state (String.make n '\000')
  | RangedInt {minimum; maximum} ->
      Atom.ranged_int ~minimum ~maximum state value
  | RangedFloat {minimum; maximum} ->
      Atom.ranged_float ~minimum ~maximum state value
  | String_enum (tbl, arr) ->
      Atom.string_enum tbl arr state value
  | Array (Some max_length, _e) when Array.length value > max_length ->
      raise Array_too_long
  | Array (_, e) ->
      Array.iter (write_rec e state) value
  | List (Some max_length, _e) when List.length value > max_length ->
      raise List_too_long
  | List (_, e) ->
      List.iter (write_rec e state) value
  | Obj (Req {encoding = e; _}) ->
      write_rec e state value
  | Obj (Opt {kind = `Dynamic; encoding = e; _}) -> (
    match value with
    | None ->
        Atom.bool state false
    | Some value ->
        Atom.bool state true ; write_rec e state value )
  | Obj (Opt {kind = `Variable; encoding = e; _}) -> (
    match value with None -> () | Some value -> write_rec e state value )
  | Obj (Dft {encoding = e; _}) ->
      write_rec e state value
  | Objs {left; right; _} ->
      let (v1, v2) = value in
      write_rec left state v1 ; write_rec right state v2
  | Tup e ->
      write_rec e state value
  | Tups {left; right; _} ->
      let (v1, v2) = value in
      write_rec left state v1 ; write_rec right state v2
  | Conv {encoding = e; proj; _} ->
      write_rec e state (proj value)
  | Union {tag_size; cases; _} ->
      let rec write_case = function
        | [] ->
            raise No_case_matched
        | Case {tag = Json_only; _} :: tl ->
            write_case tl
        | Case {encoding = e; proj; tag = Tag tag; _} :: tl -> (
          match proj value with
          | None ->
              write_case tl
          | Some value ->
              Atom.tag tag_size state tag ;
              write_rec e state value )
      in
      write_case cases
  | Dynamic_size {kind; encoding = e} ->
      let initial_offset = state.offset in
      Atom.int kind state 0 ;
      (* place holder for [size] *)
      write_with_limit (Binary_size.max_int kind) e state value ;
      (* patch the written [size] *)
      Atom.set_int
        kind
        state.buffer
        initial_offset
        (state.offset - initial_offset - Binary_size.integer_to_size kind)
  | Check_size {limit; encoding = e} ->
      write_with_limit limit e state value
  | Describe {encoding = e; _} ->
      write_rec e state value
  | Splitted {encoding = e; _} ->
      write_rec e state value
  | Mu {fix; _} ->
      write_rec (fix e) state value
  | Delayed f ->
      write_rec (f ()) state value

and write_with_limit : type a. int -> a Encoding.t -> state -> a -> unit =
 fun limit e state value ->
  (* backup the current limit *)
  let old_limit = state.allowed_bytes in
  (* install the new limit (only if smaller than the current limit) *)
  let limit =
    match state.allowed_bytes with
    | None ->
        limit
    | Some old_limit ->
        min old_limit limit
  in
  state.allowed_bytes <- Some limit ;
  write_rec e state value ;
  (* restore the previous limit (minus the read bytes) *)
  match old_limit with
  | None ->
      state.allowed_bytes <- None
  | Some old_limit ->
      let remaining =
        match state.allowed_bytes with None -> assert false | Some len -> len
      in
      let read = limit - remaining in
      state.allowed_bytes <- Some (old_limit - read)

(** ******************** *)

(** Various entry points *)

let write e v buffer offset len =
  (* By harcoding [allowed_bytes] with the buffer length,
       we ensure that [write] will never reallocate the buffer. *)
  let state = {buffer; offset; allowed_bytes = Some len} in
  try write_rec e state v ; Some state.offset with Write_error _ -> None

let to_bytes_exn e v =
  match Encoding.classify e with
  | `Fixed n ->
      (* Preallocate the complete buffer *)
      let state =
        {buffer = Bytes.create n; offset = 0; allowed_bytes = Some n}
      in
      write_rec e state v ; state.buffer
  | `Dynamic | `Variable ->
      (* Preallocate a minimal buffer and let's not hardcode a
         limit to its extension. *)
      let state =
        {buffer = Bytes.create 128; offset = 0; allowed_bytes = None}
      in
      write_rec e state v ;
      Bytes.sub state.buffer 0 state.offset

let to_bytes e v = try Some (to_bytes_exn e v) with Write_error _ -> None
src/lib_data_encoding/binary_writer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Binary_error.

Definition raise {A : Type}
  (error : Tezos_data_encoding.Binary_error.write_error) : A :=
  Stdlib.raise (Write_error error).

Record state := {
  buffer : Stdlib.Bytes.t;
  offset : Z;
  allowed_bytes : option Z }.

Definition check_allowed_bytes (state : state) (size : Z) : unit :=
  match allowed_bytes state with
  | Some len => set_field
  | None => tt
  end.

Definition may_resize (state : state) (size : Z) : unit :=
  check_allowed_bytes state size;
  let buffer_len := String.length (buffer state) in
  if OCaml.Stdlib.lt (Z.sub buffer_len (offset state)) size then
    let new_buffer :=
      Stdlib.Bytes.create
        (OCaml.Stdlib.max (Z.mul 2 buffer_len) (Z.add buffer_len size)) in
    Stdlib.Bytes.blit (buffer state) 0 new_buffer 0 (offset state);
    set_field
  else
    tt;
  set_field.

Module Atom.
  Definition check_int_range (min : Z) (v : Z) (max : Z) : unit :=
    if orb (OCaml.Stdlib.lt v min) (OCaml.Stdlib.lt max v) then
      raise (Invalid_int {| min := min; v := v; max := max |})
    else
      tt.
  
  Definition check_float_range (min : float) (v : float) (max : float) : unit :=
    if orb (OCaml.Stdlib.lt v min) (OCaml.Stdlib.lt max v) then
      raise (Invalid_float {| min := min; v := v; max := max |})
    else
      tt.
  
  Definition set_int (kind : variant) (buffer : string) (ofs : Z) (v : Z)
    : unit :=
    match kind with
    | Int31 | Uint30 =>
      Tezos_data_encoding.TzEndian.set_int32 buffer ofs (Stdlib.Int32.of_int v)
    | Int16 | Uint16 => Tezos_data_encoding.TzEndian.set_int16 buffer ofs v
    | Int8 | Uint8 => Tezos_data_encoding.TzEndian.set_int8 buffer ofs v
    end.
  
  Definition int (kind : variant) (state : state) (v : Z) : unit :=
    check_int_range (Tezos_data_encoding.Binary_size.min_int kind) v
      (Tezos_data_encoding.Binary_size.max_int kind);
    let ofs := offset state in
    may_resize state (Tezos_data_encoding.Binary_size.integer_to_size kind);
    set_int kind (buffer state) ofs v.
  
  Definition int8 : state -> Z -> unit := Z variant.
  
  Definition uint8 : state -> Z -> unit := Z variant.
  
  Definition int16 : state -> Z -> unit := Z variant.
  
  Definition uint16 : state -> Z -> unit := Z variant.
  
  Definition uint30 : state -> Z -> unit := Z variant.
  
  Definition int31 : state -> Z -> unit := Z variant.
  
  Definition bool (state : state) (v : bool) : unit :=
    uint8 state
      (if v then
        255
      else
        0).
  
  Definition int32 (state : state) (v : int32) : unit :=
    let ofs := offset state in
    may_resize state Tezos_data_encoding.Binary_size.int32;
    Tezos_data_encoding.TzEndian.set_int32 (buffer state) ofs v.
  
  Definition int64 (state : state) (v : int64) : unit :=
    let ofs := offset state in
    may_resize state Tezos_data_encoding.Binary_size.int64;
    Tezos_data_encoding.TzEndian.set_int64 (buffer state) ofs v.
  
  Definition ranged_int (minimum : Z) (maximum : Z) (state : state) (v : Z)
    : unit :=
    check_int_range minimum v maximum;
    let v :=
      if OCaml.Stdlib.ge minimum 0 then
        Z.sub v minimum
      else
        v in
    match Tezos_data_encoding.Binary_size.range_to_size minimum maximum with
    | Uint8 => uint8 state v
    | Uint16 => uint16 state v
    | Uint30 => uint30 state v
    | Int8 => int8 state v
    | Int16 => int16 state v
    | Int31 => int31 state v
    end.
  
  Definition n (state : state) (v : Z.t) : unit :=
    if OCaml.Stdlib.lt (Z.sign v) 0 then
      raise Invalid_natural
    else
      tt;
    if Z.equal v Z.zero then
      uint8 state 0
    else
      let bits := Z.numbits v in
      let get_chunk (pos : Z) (len : Z) : Z :=
        Z.to_int (Z.extract v pos len) in
      let length := Tezos_data_encoding.Binary_length.n_length v in
      let offset := offset state in
      may_resize state length;
      for.
  
  Definition z (state : state) (v : Z.t) : unit :=
    let sign := OCaml.Stdlib.lt (Z.sign v) 0 in
    let bits := Z.numbits v in
    if Z.equal v Z.zero then
      uint8 state 0
    else
      let v := Z.abs v in
      let get_chunk (pos : Z) (len : Z) : Z :=
        Z.to_int (Z.extract v pos len) in
      let length := Tezos_data_encoding.Binary_length.z_length v in
      let offset := offset state in
      may_resize state length;
      Tezos_data_encoding.TzEndian.set_int8 (buffer state) offset
        (Z.lor
          (Z.lor
            (if sign then
              64
            else
              0)
            (if OCaml.Stdlib.gt bits 6 then
              128
            else
              0)) (get_chunk 0 6));
      for.
  
  Definition float (state : state) (v : float) : unit :=
    let ofs := offset state in
    may_resize state Tezos_data_encoding.Binary_size.float;
    Tezos_data_encoding.TzEndian.set_double (buffer state) ofs v.
  
  Definition ranged_float
    (minimum : float) (maximum : float) (state : state) (v : float) : unit :=
    check_float_range minimum v maximum;
    float state v.
  
  Definition string_enum {A B C : Type}
    (tbl : Stdlib.Hashtbl.t A (B * Z)) (arr : array C) (state : state) (v : A)
    : unit :=
    let value := try in
    match Tezos_data_encoding.Binary_size.enum_size arr with
    | Uint30 => uint30 state value
    | Uint16 => uint16 state value
    | Uint8 => uint8 state value
    end.
  
  Definition fixed_kind_bytes (length : Z) (state : state) (s : string)
    : unit :=
    if nequiv_decb (String.length s) length then
      raise
        (Invalid_bytes_length {| expected := length; found := String.length s |})
    else
      tt;
    let ofs := offset state in
    may_resize state length;
    Stdlib.Bytes.blit s 0 (buffer state) ofs length.
  
  Definition fixed_kind_string (length : Z) (state : state) (s : string)
    : unit :=
    if nequiv_decb (OCaml.String.length s) length then
      raise
        (Invalid_string_length
          {| expected := length; found := OCaml.String.length s |})
    else
      tt;
    let ofs := offset state in
    may_resize state length;
    Stdlib.Bytes.blit_string s 0 (buffer state) ofs length.
  
  Definition tag (function_parameter : variant) : state -> Z -> unit :=
    match function_parameter with
    | Uint8 => uint8
    | Uint16 => uint16
    end.
End Atom.

Fixpoint write_rec {a : Type}
  (e : Tezos_data_encoding.Encoding.t a) (state : state) (value : a) : unit :=
  match encoding e with
  | Null => tt
  | Empty => tt
  | Constant _ => tt
  | Ignore => tt
  | Bool => Atom.bool state value
  | Int8 => Atom.int8 state value
  | Uint8 => Atom.uint8 state value
  | Int16 => Atom.int16 state value
  | Uint16 => Atom.uint16 state value
  | Int31 => Atom.int31 state value
  | Int32 => Atom.int32 state value
  | Int64 => Atom.int64 state value
  | N => Atom.n state value
  | Z => Atom.z state value
  | Float => Atom.float state value
  | Bytes (Fixed n) => Atom.fixed_kind_bytes n state value
  | Bytes Variable =>
    let length := String.length value in
    Atom.fixed_kind_bytes length state value
  | String (Fixed n) => Atom.fixed_kind_string n state value
  | String Variable =>
    let length := OCaml.String.length value in
    Atom.fixed_kind_string length state value
  | Padded e n =>
    write_rec e state value;
    Atom.fixed_kind_string n state (Stdlib.String.make n "000" % char)
  | RangedInt {| minimum := minimum; maximum := maximum |} =>
    Atom.ranged_int minimum maximum state value
  | RangedFloat {| minimum := minimum; maximum := maximum |} =>
    Atom.ranged_float minimum maximum state value
  | String_enum tbl arr => Atom.string_enum tbl arr state value
  | Array _ e => Stdlib.Array.iter (write_rec e state) value
  | List _ e => Stdlib.List.iter (write_rec e state) value
  | Obj (Req {| encoding := e |}) => write_rec e state value
  | Obj (Opt {| kind := Dynamic; encoding := e |}) =>
    match value with
    | None => Atom.bool state false
    | Some value =>
      Atom.bool state true;
      write_rec e state value
    end
  | Obj (Opt {| kind := Variable; encoding := e |}) =>
    match value with
    | None => tt
    | Some value => write_rec e state value
    end
  | Obj (Dft {| encoding := e |}) => write_rec e state value
  | Objs {| left := left; right := right |} =>
    match value with
    | (v1, v2) =>
      write_rec left state v1;
      write_rec right state v2
    end
  | Tup e => write_rec e state value
  | Tups {| left := left; right := right |} =>
    match value with
    | (v1, v2) =>
      write_rec left state v1;
      write_rec right state v2
    end
  | Conv {| proj := proj; encoding := e |} => write_rec e state (proj value)
  | Union {| tag_size := tag_size; cases := cases |} =>
    let fix write_case
      (function_parameter : list (Tezos_data_encoding.Encoding.case a))
      : unit :=
      match function_parameter with
      | [] => raise No_case_matched
      | cons (Case {| tag := Json_only |}) tl => write_case tl
      | cons (Case {| encoding := e; proj := proj; tag := Tag tag |}) tl =>
        match proj value with
        | None => write_case tl
        | Some value =>
          Atom.tag tag_size state tag;
          write_rec e state value
        end
      end in
    write_case cases
  | Dynamic_size {| kind := kind; encoding := e |} =>
    let initial_offset := offset state in
    Atom.int kind state 0;
    write_with_limit (Tezos_data_encoding.Binary_size.max_int kind) e state
      value;
    Atom.set_int kind (buffer state) initial_offset
      (Z.sub (Z.sub (offset state) initial_offset)
        (Tezos_data_encoding.Binary_size.integer_to_size kind))
  | Check_size {| limit := limit; encoding := e |} =>
    write_with_limit limit e state value
  | Describe {| encoding := e |} => write_rec e state value
  | Splitted {| encoding := e |} => write_rec e state value
  | Mu {| fix := fix |} => write_rec (fix e) state value
  | Delayed f => write_rec (f tt) state value
  end

with write_with_limit {a : Type}
  (limit : Z) (e : Tezos_data_encoding.Encoding.t a) (state : state) (value : a)
  : unit :=
  let old_limit := allowed_bytes state in
  let limit :=
    match allowed_bytes state with
    | None => limit
    | Some old_limit => OCaml.Stdlib.min old_limit limit
    end in
  set_field;
  write_rec e state value;
  match old_limit with
  | None => set_field
  | Some old_limit =>
    let remaining :=
      match allowed_bytes state with
      | None => false
      | Some len => len
      end in
    let read := Z.sub limit remaining in
    set_field
  end.

Definition write {A : Type}
  (e : Tezos_data_encoding.Encoding.t A) (v : A) (buffer : Stdlib.Bytes.t)
  (offset : Z) (len : Z) : option Z :=
  let state :=
    {| buffer := buffer; offset := offset; allowed_bytes := Some len |} in
  try.

Definition to_bytes_exn {A : Type}
  (e : Tezos_data_encoding.Encoding.encoding A) (v : A) : Stdlib.Bytes.t :=
  match Tezos_data_encoding.Encoding.classify e with
  | Fixed n =>
    let state :=
      {| buffer := Stdlib.Bytes.create n; offset := 0; allowed_bytes := Some n
        |} in
    write_rec e state v;
    buffer state
  | Dynamic | Variable =>
    let state :=
      {| buffer := Stdlib.Bytes.create 128; offset := 0; allowed_bytes := None
        |} in
    write_rec e state v;
    String.sub (buffer state) 0 (offset state)
  end.

Definition to_bytes {A : Type}
  (e : Tezos_data_encoding.Encoding.encoding A) (v : A)
  : option Stdlib.Bytes.t := try.
src/lib_data_encoding/binary_writer.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Binary}. *)

val write : 'a Encoding.t -> 'a -> Bytes.t -> int -> int -> int option

val to_bytes_exn : 'a Encoding.t -> 'a -> Bytes.t

val to_bytes : 'a Encoding.t -> 'a -> Bytes.t option
src/lib_data_encoding/binary_writer.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter write : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> a -> Stdlib.Bytes.t -> Z -> Z -> option Z.

Parameter to_bytes_exn : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> a -> Stdlib.Bytes.t.

Parameter to_bytes : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> a -> option Stdlib.Bytes.t.
src/lib_data_encoding/bson.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type bson = Json_repr_bson.bson

type t = bson

let construct e v = Json_repr_bson.Json_encoding.construct (Json.convert e) v

let destruct e v = Json_repr_bson.Json_encoding.destruct (Json.convert e) v
src/lib_data_encoding/bson.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition bson := Json_repr_bson.bson.

Definition t := bson.

Definition construct {A : Type} (e : Tezos_data_encoding.Encoding.t A) (v : A)
  : Json_repr_bson.Repr.value :=
  Json_repr_bson.Json_encoding.construct (Tezos_data_encoding.Json.convert e) v.

Definition destruct {A : Type}
  (e : Tezos_data_encoding.Encoding.t A) (v : Json_repr_bson.Repr.value) : A :=
  Json_repr_bson.Json_encoding.destruct (Tezos_data_encoding.Json.convert e) v.
src/lib_data_encoding/bson.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Bson}. *)

type bson = Json_repr_bson.bson

type t = bson

val construct : 't Encoding.t -> 't -> bson

val destruct : 't Encoding.t -> bson -> 't
src/lib_data_encoding/bson.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition bson := Json_repr_bson.bson.

Definition t := bson.

Parameter construct : forall {t : Type},
(Tezos_data_encoding.Encoding.t t) -> t -> bson.

Parameter destruct : forall {t : Type},
(Tezos_data_encoding.Encoding.t t) -> bson -> t.
src/lib_data_encoding/bytes_encodings.ml 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* this module is a temporary fix waiting for ocaml 4.08 *)

(** {1 Binary encoding/decoding of integers} *)

external get_uint8 : bytes -> int -> int = "%bytes_safe_get"

external get_uint16_ne : bytes -> int -> int = "%caml_bytes_get16"

external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"

external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64"

external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"

external set_int16_ne : bytes -> int -> int -> unit = "%caml_bytes_set16"

external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32"

external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_bytes_set64"

external swap16 : int -> int = "%bswap16"

external swap32 : int32 -> int32 = "%bswap_int32"

external swap64 : int64 -> int64 = "%bswap_int64"

let get_int8 b i = (get_uint8 b i lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)

let get_uint16_le b i =
  if Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i

let get_uint16_be b i =
  if not Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i

let get_int16_ne b i =
  (get_uint16_ne b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_le b i =
  (get_uint16_le b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_be b i =
  (get_uint16_be b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int32_le b i =
  if Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i

let get_int32_be b i =
  if not Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i

let get_int64_le b i =
  if Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i

let get_int64_be b i =
  if not Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i

let set_int16_le b i x =
  if Sys.big_endian then set_int16_ne b i (swap16 x) else set_int16_ne b i x

let set_int16_be b i x =
  if not Sys.big_endian then set_int16_ne b i (swap16 x)
  else set_int16_ne b i x

let set_int32_le b i x =
  if Sys.big_endian then set_int32_ne b i (swap32 x) else set_int32_ne b i x

let set_int32_be b i x =
  if not Sys.big_endian then set_int32_ne b i (swap32 x)
  else set_int32_ne b i x

let set_int64_le b i x =
  if Sys.big_endian then set_int64_ne b i (swap64 x) else set_int64_ne b i x

let set_int64_be b i x =
  if not Sys.big_endian then set_int64_ne b i (swap64 x)
  else set_int64_ne b i x

let set_uint8 = set_int8

let set_uint16_ne = set_int16_ne

let set_uint16_be = set_int16_be

let set_uint16_le = set_int16_le

module type S = sig
  (** {1 Binary encoding/decoding of integers} *)

  (** The functions in this section binary encode and decode integers to
      and from byte sequences.
      All following functions raise [Invalid_argument] if the space
      needed at index [i] to decode or encode the integer is not
      available.
      Little-endian (resp. big-endian) encoding means that least
      (resp. most) significant bytes are stored first.  Big-endian is
      also known as network byte order.  Native-endian encoding is
      either little-endian or big-endian depending on {!Sys.big_endian}.
      32-bit and 64-bit integers are represented by the [int32] and
      [int64] types, which can be interpreted either as signed or
      unsigned numbers.
      8-bit and 16-bit integers are represented by the [int] type,
      which has more bits than the binary encoding.  These extra bits
      are handled as follows:
        {ul
          {- Functions that decode signed (resp. unsigned) 8-bit or 16-bit
          integers represented by [int] values sign-extend
          (resp. zero-extend) their result.}
          {- Functions that encode 8-bit or 16-bit integers represented by
          [int] values truncate their input to their least significant
          bytes.}
        }
  *)

  (** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at byte index [i].
      @since 4.08
  *)
  val get_uint8 : bytes -> int -> int

  (** [get_int8 b i] is [b]'s signed 8-bit integer starting at byte index [i].
      @since 4.08
  *)
  val get_int8 : bytes -> int -> int

  (** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_ne : bytes -> int -> int

  (** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_be : bytes -> int -> int

  (** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_le : bytes -> int -> int

  (** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_ne : bytes -> int -> int

  (** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_be : bytes -> int -> int

  (** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_le : bytes -> int -> int

  (** [get_int32_ne b i] is [b]'s native-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_ne : bytes -> int -> int32

  (** [get_int32_be b i] is [b]'s big-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_be : bytes -> int -> int32

  (** [get_int32_le b i] is [b]'s little-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_le : bytes -> int -> int32

  (** [get_int64_ne b i] is [b]'s native-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_ne : bytes -> int -> int64

  (** [get_int64_be b i] is [b]'s big-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_be : bytes -> int -> int64

  (** [get_int64_le b i] is [b]'s little-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_le : bytes -> int -> int64

  (** [set_uint8 b i v] sets [b]'s unsigned 8-bit integer starting at byte index
      [i] to [v].
      @since 4.08
  *)
  val set_uint8 : bytes -> int -> int -> unit

  (** [set_int8 b i v] sets [b]'s signed 8-bit integer starting at byte index
      [i] to [v].
      @since 4.08
  *)
  val set_int8 : bytes -> int -> int -> unit

  (** [set_uint16_ne b i v] sets [b]'s native-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_ne : bytes -> int -> int -> unit

  (** [set_uint16_be b i v] sets [b]'s big-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_be : bytes -> int -> int -> unit

  (** [set_uint16_le b i v] sets [b]'s little-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_le : bytes -> int -> int -> unit

  (** [set_int16_ne b i v] sets [b]'s native-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_ne : bytes -> int -> int -> unit

  (** [set_int16_be b i v] sets [b]'s big-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_be : bytes -> int -> int -> unit

  (** [set_int16_le b i v] sets [b]'s little-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_le : bytes -> int -> int -> unit

  (** [set_int32_ne b i v] sets [b]'s native-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_ne : bytes -> int -> int32 -> unit

  (** [set_int32_be b i v] sets [b]'s big-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_be : bytes -> int -> int32 -> unit

  (** [set_int32_le b i v] sets [b]'s little-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_le : bytes -> int -> int32 -> unit

  (** [set_int64_ne b i v] sets [b]'s native-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_ne : bytes -> int -> int64 -> unit

  (** [set_int64_be b i v] sets [b]'s big-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_be : bytes -> int -> int64 -> unit

  (** [set_int64_le b i v] sets [b]'s little-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_le : bytes -> int -> int64 -> unit
end
src/lib_data_encoding/bytes_encodings.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_uint8 : string -> Z -> Z.

Parameter get_uint16_ne : string -> Z -> Z.

Parameter get_int32_ne : string -> Z -> int32.

Parameter get_int64_ne : string -> Z -> int64.

Parameter set_int8 : string -> Z -> Z -> unit.

Parameter set_int16_ne : string -> Z -> Z -> unit.

Parameter set_int32_ne : string -> Z -> int32 -> unit.

Parameter set_int64_ne : string -> Z -> int64 -> unit.

Parameter swap16 : Z -> Z.

Parameter swap32 : int32 -> int32.

Parameter swap64 : int64 -> int64.

Definition get_int8 (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint8 b i) (Z.sub Stdlib.Sys.int_size 8))
    (Z.sub Stdlib.Sys.int_size 8).

Definition get_uint16_le (b : string) (i : Z) : Z :=
  if Stdlib.Sys.big_endian then
    swap16 (get_uint16_ne b i)
  else
    get_uint16_ne b i.

Definition get_uint16_be (b : string) (i : Z) : Z :=
  if negb Stdlib.Sys.big_endian then
    swap16 (get_uint16_ne b i)
  else
    get_uint16_ne b i.

Definition get_int16_ne (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_ne b i) (Z.sub Stdlib.Sys.int_size 16))
    (Z.sub Stdlib.Sys.int_size 16).

Definition get_int16_le (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_le b i) (Z.sub Stdlib.Sys.int_size 16))
    (Z.sub Stdlib.Sys.int_size 16).

Definition get_int16_be (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_be b i) (Z.sub Stdlib.Sys.int_size 16))
    (Z.sub Stdlib.Sys.int_size 16).

Definition get_int32_le (b : string) (i : Z) : int32 :=
  if Stdlib.Sys.big_endian then
    swap32 (get_int32_ne b i)
  else
    get_int32_ne b i.

Definition get_int32_be (b : string) (i : Z) : int32 :=
  if negb Stdlib.Sys.big_endian then
    swap32 (get_int32_ne b i)
  else
    get_int32_ne b i.

Definition get_int64_le (b : string) (i : Z) : int64 :=
  if Stdlib.Sys.big_endian then
    swap64 (get_int64_ne b i)
  else
    get_int64_ne b i.

Definition get_int64_be (b : string) (i : Z) : int64 :=
  if negb Stdlib.Sys.big_endian then
    swap64 (get_int64_ne b i)
  else
    get_int64_ne b i.

Definition set_int16_le (b : string) (i : Z) (x : Z) : unit :=
  if Stdlib.Sys.big_endian then
    set_int16_ne b i (swap16 x)
  else
    set_int16_ne b i x.

Definition set_int16_be (b : string) (i : Z) (x : Z) : unit :=
  if negb Stdlib.Sys.big_endian then
    set_int16_ne b i (swap16 x)
  else
    set_int16_ne b i x.

Definition set_int32_le (b : string) (i : Z) (x : int32) : unit :=
  if Stdlib.Sys.big_endian then
    set_int32_ne b i (swap32 x)
  else
    set_int32_ne b i x.

Definition set_int32_be (b : string) (i : Z) (x : int32) : unit :=
  if negb Stdlib.Sys.big_endian then
    set_int32_ne b i (swap32 x)
  else
    set_int32_ne b i x.

Definition set_int64_le (b : string) (i : Z) (x : int64) : unit :=
  if Stdlib.Sys.big_endian then
    set_int64_ne b i (swap64 x)
  else
    set_int64_ne b i x.

Definition set_int64_be (b : string) (i : Z) (x : int64) : unit :=
  if negb Stdlib.Sys.big_endian then
    set_int64_ne b i (swap64 x)
  else
    set_int64_ne b i x.

Definition set_uint8 : string -> Z -> Z -> unit := set_int8.

Definition set_uint16_ne : string -> Z -> Z -> unit := set_int16_ne.

Definition set_uint16_be : string -> Z -> Z -> unit := set_int16_be.

Definition set_uint16_le : string -> Z -> Z -> unit := set_int16_le.

Module S.
  Record signature := {
    get_uint8 : string -> Z -> Z;
    get_int8 : string -> Z -> Z;
    get_uint16_ne : string -> Z -> Z;
    get_uint16_be : string -> Z -> Z;
    get_uint16_le : string -> Z -> Z;
    get_int16_ne : string -> Z -> Z;
    get_int16_be : string -> Z -> Z;
    get_int16_le : string -> Z -> Z;
    get_int32_ne : string -> Z -> int32;
    get_int32_be : string -> Z -> int32;
    get_int32_le : string -> Z -> int32;
    get_int64_ne : string -> Z -> int64;
    get_int64_be : string -> Z -> int64;
    get_int64_le : string -> Z -> int64;
    set_uint8 : string -> Z -> Z -> unit;
    set_int8 : string -> Z -> Z -> unit;
    set_uint16_ne : string -> Z -> Z -> unit;
    set_uint16_be : string -> Z -> Z -> unit;
    set_uint16_le : string -> Z -> Z -> unit;
    set_int16_ne : string -> Z -> Z -> unit;
    set_int16_be : string -> Z -> Z -> unit;
    set_int16_le : string -> Z -> Z -> unit;
    set_int32_ne : string -> Z -> int32 -> unit;
    set_int32_be : string -> Z -> int32 -> unit;
    set_int32_le : string -> Z -> int32 -> unit;
    set_int64_ne : string -> Z -> int64 -> unit;
    set_int64_be : string -> Z -> int64 -> unit;
    set_int64_le : string -> Z -> int64 -> unit;
  }.
End S.
src/lib_data_encoding/data_encoding.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Encoding = struct
  include Encoding

  let splitted ~json ~binary = raw_splitted ~json:(Json.convert json) ~binary

  let assoc enc =
    let json = Json_encoding.assoc (Json.convert enc) in
    let binary = list (tup2 string enc) in
    raw_splitted ~json ~binary

  module Bounded = struct
    let string length =
      raw_splitted
        ~binary:
          (let kind = Binary_size.unsigned_range_to_size length in
           check_size (length + Binary_size.integer_to_size kind)
           @@ dynamic_size ~kind Variable.string)
        ~json:
          (let open Json_encoding in
          conv
            (fun s ->
              if String.length s > length then invalid_arg "oversized string" ;
              s)
            (fun s ->
              if String.length s > length then
                raise
                  (Cannot_destruct ([], Invalid_argument "oversized string")) ;
              s)
            string)

    let bytes length =
      raw_splitted
        ~binary:
          (let kind = Binary_size.unsigned_range_to_size length in
           check_size (length + Binary_size.integer_to_size kind)
           @@ dynamic_size ~kind Variable.bytes)
        ~json:
          (let open Json_encoding in
          conv
            (fun s ->
              if Bytes.length s > length then invalid_arg "oversized string" ;
              s)
            (fun s ->
              if Bytes.length s > length then
                raise
                  (Cannot_destruct ([], Invalid_argument "oversized string")) ;
              s)
            Json.bytes_jsont)
  end

  type 'a lazy_state = Value of 'a | Bytes of Bytes.t | Both of Bytes.t * 'a

  type 'a lazy_t = {mutable state : 'a lazy_state; encoding : 'a t}

  let force_decode le =
    match le.state with
    | Value value ->
        Some value
    | Both (_, value) ->
        Some value
    | Bytes bytes -> (
      match Binary_reader.of_bytes le.encoding bytes with
      | Some expr ->
          le.state <- Both (bytes, expr) ;
          Some expr
      | None ->
          None )

  let force_bytes le =
    match le.state with
    | Bytes bytes ->
        bytes
    | Both (bytes, _) ->
        bytes
    | Value value ->
        let bytes = Binary_writer.to_bytes_exn le.encoding value in
        le.state <- Both (bytes, value) ;
        bytes

  let lazy_encoding encoding =
    let binary =
      Encoding.conv
        force_bytes
        (fun bytes -> {state = Bytes bytes; encoding})
        Encoding.bytes
    in
    let json =
      Encoding.conv
        (fun le ->
          match force_decode le with Some r -> r | None -> raise Exit)
        (fun value -> {state = Value value; encoding})
        encoding
    in
    splitted ~json ~binary

  let make_lazy encoding value = {encoding; state = Value value}

  let apply_lazy ~fun_value ~fun_bytes ~fun_combine le =
    match le.state with
    | Value value ->
        fun_value value
    | Bytes bytes ->
        fun_bytes bytes
    | Both (bytes, value) ->
        fun_combine (fun_value value) (fun_bytes bytes)
end

include Encoding
module With_version = With_version
module Registration = Registration
module Json = Json
module Bson = Bson
module Binary_schema = Binary_schema

module Binary = struct
  include Binary_error
  include Binary_length
  include Binary_writer
  include Binary_reader
  include Binary_stream_reader

  let describe = Binary_description.describe
end

type json = Json.t

let json = Json.encoding

type json_schema = Json.schema

let json_schema = Json.schema_encoding

type bson = Bson.t
src/lib_data_encoding/data_encoding.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Encoding.
  Definition splitted {A : Type}
    (json : Tezos_data_encoding.Encoding.t A) (binary : encoding A)
    : encoding A := raw_splitted (Tezos_data_encoding.Json.convert json) binary.
  
  Definition assoc {A : Type} (enc : Tezos_data_encoding.Encoding.t A)
    : encoding (list (string * A)) :=
    let json := Json_encoding.assoc (Tezos_data_encoding.Json.convert enc) in
    let binary := list None (tup2 string enc) in
    raw_splitted json binary.
  
  Module Bounded.
    Definition string (length : Z) : encoding string :=
      raw_splitted
        (Json_encoding.conv
          (fun s =>
            if OCaml.Stdlib.gt (OCaml.String.length s) length then
              OCaml.Stdlib.invalid_arg "oversized string" % string
            else
              tt;
            s)
          (fun s =>
            if OCaml.Stdlib.gt (OCaml.String.length s) length then
              Stdlib.raise
                (Cannot_destruct
                  ([], (OCaml.Invalid_argument "oversized string" % string)))
            else
              tt;
            s) None Json_encoding.string)
        (let kind :=
          Tezos_data_encoding.Binary_size.unsigned_range_to_size length in
        apply
          (check_size
            (Z.add length (Tezos_data_encoding.Binary_size.integer_to_size kind)))
          (dynamic_size (Some kind) Variable.string)).
    
    Definition bytes (length : Z) : encoding Stdlib.Bytes.t :=
      raw_splitted
        (Json_encoding.conv
          (fun s =>
            if OCaml.Stdlib.gt (String.length s) length then
              OCaml.Stdlib.invalid_arg "oversized string" % string
            else
              tt;
            s)
          (fun s =>
            if OCaml.Stdlib.gt (String.length s) length then
              Stdlib.raise
                (Cannot_destruct
                  ([], (OCaml.Invalid_argument "oversized string" % string)))
            else
              tt;
            s) None Tezos_data_encoding.Json.bytes_jsont)
        (let kind :=
          Tezos_data_encoding.Binary_size.unsigned_range_to_size length in
        apply
          (check_size
            (Z.add length (Tezos_data_encoding.Binary_size.integer_to_size kind)))
          (dynamic_size (Some kind) Variable.bytes)).
  End Bounded.
  
  Inductive lazy_state (a : Type) : Type :=
  | Value : a -> lazy_state a
  | Bytes : Stdlib.Bytes.t -> lazy_state a
  | Both : Stdlib.Bytes.t -> a -> lazy_state a.
  
  Arguments Value {_}.
  Arguments Bytes {_}.
  Arguments Both {_}.
  
  Record lazy_t {a : Type} := {
    state : lazy_state a;
    encoding : t a }.
  Arguments lazy_t : clear implicits.
  
  Definition force_decode {A : Type} (le : lazy_t A) : option A :=
    match state le with
    | Value value => Some value
    | Both _ value => Some value
    | Bytes bytes =>
      match Tezos_data_encoding.Binary_reader.of_bytes (encoding le) string with
      | Some expr =>
        set_field;
        Some expr
      | None => None
      end
    end.
  
  Definition force_bytes {A : Type} (le : lazy_t A) : Stdlib.Bytes.t :=
    match state le with
    | Bytes bytes => string
    | Both bytes _ => string
    | Value value =>
      let bytes :=
        Tezos_data_encoding.Binary_writer.to_bytes_exn (encoding le) value in
      set_field;
      string
    end.
  
  Definition lazy_encoding {A : Type} (encoding : t A) : encoding (lazy_t A) :=
    let binary :=
      Tezos_data_encoding.Encoding.conv force_bytes
        (fun bytes => {| state := Bytes string; encoding := encoding |}) None
        Tezos_data_encoding.Encoding.bytes in
    let json :=
      Tezos_data_encoding.Encoding.conv
        (fun le =>
          match force_decode le with
          | Some r => r
          | None => Stdlib.raise Exit
          end) (fun value => {| state := Value value; encoding := encoding |})
        None encoding in
    splitted json binary.
  
  Definition make_lazy {A : Type} (encoding : t A) (value : A) : lazy_t A :=
    {| state := Value value; encoding := encoding |}.
  
  Definition apply_lazy {A B : Type}
    (fun_value : A -> B) (fun_bytes : Stdlib.Bytes.t -> B)
    (fun_combine : B -> B -> B) (le : lazy_t A) : B :=
    match state le with
    | Value value => fun_value value
    | Bytes bytes => fun_bytes string
    | Both bytes value => fun_combine (fun_value value) (fun_bytes string)
    end.
End Encoding.

Module Binary.
  Definition describe {A : Type}
    : (Tezos_data_encoding.Encoding.t A) -> Tezos_data_encoding.Binary_schema.t :=
    Tezos_data_encoding.Binary_description.describe.
End Binary.

Definition json := Json.t.

Definition json : Tezos_data_encoding.Encoding.t Json.json := Json.encoding.

Definition json_schema := Json.schema.

Definition json_schema : Tezos_data_encoding.Encoding.t Json.schema :=
  Json.schema_encoding.

Definition bson := Bson.t.
src/lib_data_encoding/data_encoding.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Type-safe serialization and deserialization of data structures. *)

(** {1 Data Encoding} *)

(** {2 Overview}

    This module provides type-safe serialization and deserialization of
    data structures. Backends are provided to both /ad hoc/ binary, JSON
    and BSON.

    This works by writing type descriptors by hand, using the provided
    combinators. These combinators can fine-tune the binary
    representation to be compact and efficient, but also provide
    proper field names and meta information, so the API of Tezos can
    be automatically introspected and documented.

    Here is an example encoding for type [(int * string)].

    [let enc = obj2 (req "code" uint16) (req "message" string)]

    In JSON, this encoding maps values of type [int * string] to JSON
    objects with a field [code] whose value is a number and a field
    [message] whose value is a string.

    In binary, this encoding maps to two raw bytes for the [int]
    followed by the size of the string in bytes, and finally the raw
    contents of the string. This binary format is mostly tagless,
    meaning that serialized data cannot be interpreted without the
    encoding that was used for serialization.

    Regarding binary serialization, encodings are classified as either:
    - fixed size (booleans, integers, numbers)
      data is always the same size for that type ;
    - dynamically sized (arbitrary strings and bytes)
      data is of unknown size and requires an explicit length field ;
    - variable size (special case of strings, bytes, and arrays)
      data makes up the remainder of an object of known size,
      thus its size is given by the context, and does not
      have to be serialized.

    JSON operations are delegated to [ocplib-json-typed]. *)

(** {2 Module structure}

    This [Data_encoding] module provides multiple submodules:
    - [Encoding] contains the necessary types and constructors for making the
    type descriptors.
    - [Json], [Bson], and [Binary] contain functions to serialize and
    deserialize values.

*)

module Encoding : sig
  (** The type descriptors for values of type ['a]. *)
  type 'a t = 'a Encoding.t

  type 'a encoding = 'a t

  (** {3 Ground descriptors} *)

  (** Special value [null] in JSON, nothing in binary. *)
  val null : unit encoding

  (** Empty object (not included in binary, encoded as empty object in JSON). *)
  val empty : unit encoding

  (** Unit value, omitted in binary.
      Serialized as an empty object in JSON, accepts any object when deserializing. *)
  val unit : unit encoding

  (** Constant string (data is not included in the binary data). *)
  val constant : string -> unit encoding

  (** Signed 8 bit integer
      (data is encoded as a byte in binary and an integer in JSON). *)
  val int8 : int encoding

  (** Unsigned 8 bit integer
      (data is encoded as a byte in binary and an integer in JSON). *)
  val uint8 : int encoding

  (** Signed 16 bit integer
      (data is encoded as a short in binary and an integer in JSON). *)
  val int16 : int encoding

  (** Unsigned 16 bit integer
      (data is encoded as a short in binary and an integer in JSON). *)
  val uint16 : int encoding

  (** Signed 31 bit integer, which corresponds to type int on 32-bit OCaml systems
      (data is encoded as a 32 bit int in binary and an integer in JSON). *)
  val int31 : int encoding

  (** Signed 32 bit integer
      (data is encoded as a 32-bit int in binary and an integer in JSON). *)
  val int32 : int32 encoding

  (** Signed 64 bit integer
      (data is encoded as a 64-bit int in binary and a decimal string in JSON). *)
  val int64 : int64 encoding

  (** Integer with bounds in a given range. Both bounds are inclusive.

      @raise Invalid_argument if the bounds are beyond the interval
      [-2^30; 2^30-1]. These bounds are chosen to be compatible with all versions
      of OCaml.
  *)
  val ranged_int : int -> int -> int encoding

  (** Big number
      In JSON, data is encoded as a decimal string.
      In binary, data is encoded as a variable length sequence of
      bytes, with a running unary size bit: the most significant bit of
      each byte tells is this is the last byte in the sequence (0) or if
      there is more to read (1). The second most significant bit of the
      first byte is reserved for the sign (positive if zero). Binary_size and
      sign bits ignored, data is then the binary representation of the
      absolute value of the number in little-endian order. *)
  val z : Z.t encoding

  (** Positive big number, see [z]. *)
  val n : Z.t encoding

  (** Encoding of floating point number
      (encoded as a floating point number in JSON and a double in binary). *)
  val float : float encoding

  (** Float with bounds in a given range. Both bounds are inclusive *)
  val ranged_float : float -> float -> float encoding

  (** Encoding of a boolean
      (data is encoded as a byte in binary and a boolean in JSON). *)
  val bool : bool encoding

  (** Encoding of a string
      - encoded as a byte sequence in binary prefixed by the length
        of the string
      - encoded as a string in JSON. *)
  val string : string encoding

  (** Encoding of arbitrary bytes
      (encoded via hex in JSON and directly as a sequence byte in binary). *)
  val bytes : Bytes.t encoding

  (** {3 Descriptor combinators} *)

  (** Combinator to make an optional value
      (represented as a 1-byte tag followed by the data (or nothing) in binary
       and either the raw value or an empty object in JSON). *)
  val option : 'a encoding -> 'a option encoding

  (** Combinator to make a {!result} value
      (represented as a 1-byte tag followed by the data of either type in binary,
       and either unwrapped value in JSON (the caller must ensure that both
       encodings do not collide)). *)
  val result : 'a encoding -> 'b encoding -> ('a, 'b) result encoding

  (** Array combinator.
      - encoded as an array in JSON
      - encoded as the concatenation of all the element in binary
       prefixed its length in bytes

      If [max_length] is passed and the encoding of elements has fixed
      size, a {!check_size} is automatically added for earlier rejection.

      @raise Invalid_argument if the inner encoding is variable. *)
  val array : ?max_length:int -> 'a encoding -> 'a array encoding

  (** List combinator.
      - encoded as an array in JSON
      - encoded as the concatenation of all the element in binary
       prefixed its length in bytes

      If [max_length] is passed and the encoding of elements has fixed
      size, a {!check_size} is automatically added for earlier rejection.

      @raise Invalid_argument if the inner encoding is also variable. *)
  val list : ?max_length:int -> 'a encoding -> 'a list encoding

  (** Provide a transformer from one encoding to a different one.

      Used to simplify nested encodings or to change the generic tuples
      built by {!obj1}, {!tup1} and the like into proper records.

      A schema may optionally be provided as documentation of the new encoding. *)
  val conv :
    ('a -> 'b) ->
    ('b -> 'a) ->
    ?schema:Json_schema.schema ->
    'b encoding ->
    'a encoding

  (** Association list.
      An object in JSON, a list of pairs in binary. *)
  val assoc : 'a encoding -> (string * 'a) list encoding

  (** {3 Product descriptors} *)

  (** An enriched encoding to represent a component in a structured
      type, augmenting the encoding with a name and whether it is a
      required or optional. Fields are used to encode OCaml tuples as
      objects in JSON, and as sequences in binary, using combinator
      {!obj1} and the like. *)
  type 'a field

  (** Required field. *)
  val req :
    ?title:string -> ?description:string -> string -> 't encoding -> 't field

  (** Optional field. Omitted entirely in JSON encoding if None.
      Omitted in binary if the only optional field in a [`Variable]
      encoding, otherwise a 1-byte prefix (`0` or `255`) tells if the
      field is present or not. *)
  val opt :
    ?title:string ->
    ?description:string ->
    string ->
    't encoding ->
    't option field

  (** Optional field of variable length.
      Only one can be present in a given object. *)
  val varopt :
    ?title:string ->
    ?description:string ->
    string ->
    't encoding ->
    't option field

  (** Required field with a default value.
      If the default value is passed, the field is omitted in JSON.
      The value is always serialized in binary. *)
  val dft :
    ?title:string ->
    ?description:string ->
    string ->
    't encoding ->
    't ->
    't field

  (** {4 Constructors for objects with N fields} *)

  (** These are serialized to binary by converting each internal
      object to binary and placing them in the order of the original
      object. These are serialized to JSON as a JSON object with the
      field names. An object might only contains one 'variable'
      field, typically the last one. If the encoding of more than one
      field are 'variable', the first ones should be wrapped with
      [dynamic_size].

      @raise Invalid_argument if more than one field is a variable one. *)

  val obj1 : 'f1 field -> 'f1 encoding

  val obj2 : 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding

  val obj3 : 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding

  val obj4 :
    'f1 field ->
    'f2 field ->
    'f3 field ->
    'f4 field ->
    ('f1 * 'f2 * 'f3 * 'f4) encoding

  val obj5 :
    'f1 field ->
    'f2 field ->
    'f3 field ->
    'f4 field ->
    'f5 field ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding

  val obj6 :
    'f1 field ->
    'f2 field ->
    'f3 field ->
    'f4 field ->
    'f5 field ->
    'f6 field ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding

  val obj7 :
    'f1 field ->
    'f2 field ->
    'f3 field ->
    'f4 field ->
    'f5 field ->
    'f6 field ->
    'f7 field ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding

  val obj8 :
    'f1 field ->
    'f2 field ->
    'f3 field ->
    'f4 field ->
    'f5 field ->
    'f6 field ->
    'f7 field ->
    'f8 field ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding

  val obj9 :
    'f1 field ->
    'f2 field ->
    'f3 field ->
    'f4 field ->
    'f5 field ->
    'f6 field ->
    'f7 field ->
    'f8 field ->
    'f9 field ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding

  val obj10 :
    'f1 field ->
    'f2 field ->
    'f3 field ->
    'f4 field ->
    'f5 field ->
    'f6 field ->
    'f7 field ->
    'f8 field ->
    'f9 field ->
    'f10 field ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding

  (** Create a larger object from the encodings of two smaller ones.
      @raise Invalid_argument if both arguments are not objects  or if both
      tuples contains a variable field.. *)
  val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding

  (** {4 Constructors for tuples with N fields} *)

  (** These are serialized to binary by converting each internal
      object to binary and placing them in the order of the original
      object. These are serialized to JSON as JSON arrays/lists.  Like
      objects, a tuple might only contains one 'variable' field,
      typically the last one. If the encoding of more than one field
      are 'variable', the first ones should be wrapped with
      [dynamic_size].

      @raise Invalid_argument if more than one field is a variable one. *)

  val tup1 : 'f1 encoding -> 'f1 encoding

  val tup2 : 'f1 encoding -> 'f2 encoding -> ('f1 * 'f2) encoding

  val tup3 :
    'f1 encoding -> 'f2 encoding -> 'f3 encoding -> ('f1 * 'f2 * 'f3) encoding

  val tup4 :
    'f1 encoding ->
    'f2 encoding ->
    'f3 encoding ->
    'f4 encoding ->
    ('f1 * 'f2 * 'f3 * 'f4) encoding

  val tup5 :
    'f1 encoding ->
    'f2 encoding ->
    'f3 encoding ->
    'f4 encoding ->
    'f5 encoding ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding

  val tup6 :
    'f1 encoding ->
    'f2 encoding ->
    'f3 encoding ->
    'f4 encoding ->
    'f5 encoding ->
    'f6 encoding ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding

  val tup7 :
    'f1 encoding ->
    'f2 encoding ->
    'f3 encoding ->
    'f4 encoding ->
    'f5 encoding ->
    'f6 encoding ->
    'f7 encoding ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding

  val tup8 :
    'f1 encoding ->
    'f2 encoding ->
    'f3 encoding ->
    'f4 encoding ->
    'f5 encoding ->
    'f6 encoding ->
    'f7 encoding ->
    'f8 encoding ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding

  val tup9 :
    'f1 encoding ->
    'f2 encoding ->
    'f3 encoding ->
    'f4 encoding ->
    'f5 encoding ->
    'f6 encoding ->
    'f7 encoding ->
    'f8 encoding ->
    'f9 encoding ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding

  val tup10 :
    'f1 encoding ->
    'f2 encoding ->
    'f3 encoding ->
    'f4 encoding ->
    'f5 encoding ->
    'f6 encoding ->
    'f7 encoding ->
    'f8 encoding ->
    'f9 encoding ->
    'f10 encoding ->
    ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding

  (** Create a large tuple encoding from two smaller ones.
      @raise Invalid_argument if both values are not tuples or if both
      tuples contains a variable field. *)
  val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding

  (** {3 Sum descriptors} *)

  (** A partial encoding to represent a case in a variant type.  Hides
      the (existentially bound) type of the parameter to the specific
      case, providing its encoder, and converter functions to and from
      the union type. *)
  type 't case

  type case_tag = Tag of int | Json_only

  (** Encodes a variant constructor. Takes the encoding for the specific
      parameters, a recognizer function that will extract the parameters
      in case the expected case of the variant is being serialized, and
      a constructor function for deserialization.

      The tag must be less than the tag size of the union in which you use the case.
      An optional tag gives a name to a case and should be used to maintain
      compatibility.

      An optional name for the case can be provided,
      which is used in the binary documentation. *)
  val case :
    title:string ->
    ?description:string ->
    case_tag ->
    'a encoding ->
    ('t -> 'a option) ->
    ('a -> 't) ->
    't case

  (** Create a single encoding from a series of cases.

      In JSON, all cases are tried one after the other. The caller must
      check for collisions.

      In binary, a prefix tag is added to discriminate quickly between
      cases. The default is [`Uint8] and you must use a [`Uint16] if you are
      going to have more than 256 cases.

      @raise Invalid_argument if it is given the empty list
      or if there are more cases than can fit in the tag size. *)
  val union : ?tag_size:[`Uint8 | `Uint16] -> 't case list -> 't encoding

  (** {3 Predicates over descriptors} *)

  (** Is the given encoding serialized as a JSON object? *)
  val is_obj : 'a encoding -> bool

  (** Does the given encoding encode a tuple? *)
  val is_tup : 'a encoding -> bool

  (** Classify the binary serialization of an encoding as explained in the
      preamble. *)
  val classify : 'a encoding -> [`Fixed of int | `Dynamic | `Variable]

  (** {3 Specialized descriptors} *)

  (** Encode enumeration via association list
      - represented as a string in JSON and
      - represented as an integer representing the element's position
        in the list in binary. The integer size depends on the list size.*)
  val string_enum : (string * 'a) list -> 'a encoding

  (** Create encodings that produce data of a fixed length when binary encoded.
      See the preamble for an explanation. *)
  module Fixed : sig
    (** @raise Invalid_argument if the argument is less or equal to zero. *)
    val string : int -> string encoding

    (** @raise Invalid_argument if the argument is less or equal to zero. *)
    val bytes : int -> Bytes.t encoding

    (** [add_padding e n] is a padded version of the encoding [e]. In Binary,
        there are [n] null bytes ([\000]) added after the value encoded by [e].
        In JSON, padding is ignored.

        @raise Invalid_argument if [n <= 0]. *)
    val add_padding : 'a encoding -> int -> 'a encoding
  end

  (** Create encodings that produce data of a variable length when binary encoded.
      See the preamble for an explanation. *)
  module Variable : sig
    val string : string encoding

    val bytes : Bytes.t encoding

    (** @raise Invalid_argument if the encoding argument is variable length
        or may lead to zero-width representation in binary. *)
    val array : ?max_length:int -> 'a encoding -> 'a array encoding

    (** @raise Invalid_argument if the encoding argument is variable length
        or may lead to zero-width representation in binary. *)
    val list : ?max_length:int -> 'a encoding -> 'a list encoding
  end

  module Bounded : sig
    (** Encoding of a string whose length does not exceed the specified length.
        The size field uses the smallest integer that can accommodate the
        maximum size - e.g., [`Uint8] for very short strings, [`Uint16] for
        longer strings, etc.

        Attempting to construct a string with a length that is too long causes
        an [Invalid_argument] exception. *)
    val string : int -> string encoding

    (** See {!string} above. *)
    val bytes : int -> Bytes.t encoding
  end

  (** Mark an encoding as being of dynamic size.
      Forces the size to be stored alongside content when needed.
      Typically used to combine two variable encodings in a same
      objects or tuple, or to use a variable encoding in an array or a list. *)
  val dynamic_size :
    ?kind:[`Uint30 | `Uint16 | `Uint8] -> 'a encoding -> 'a encoding

  (** [check_size size encoding] ensures that the binary encoding
      of a value will not be allowed to exceed [size] bytes. The reader
      and the writer fails otherwise. This function do not modify
      the JSON encoding. *)
  val check_size : int -> 'a encoding -> 'a encoding

  (** Recompute the encoding definition each time it is used.
      Useful for dynamically updating the encoding of values of an extensible
      type via a global reference (e.g. exceptions). *)
  val delayed : (unit -> 'a encoding) -> 'a encoding

  (** Define different encodings for JSON and binary serialization. *)
  val splitted : json:'a encoding -> binary:'a encoding -> 'a encoding

  (** Combinator for recursive encodings. *)
  val mu :
    string ->
    ?title:string ->
    ?description:string ->
    ('a encoding -> 'a encoding) ->
    'a encoding

  (** {3 Documenting descriptors} *)

  (** Give a name to an encoding and optionally
      add documentation to an encoding. *)
  val def :
    string ->
    ?title:string ->
    ?description:string ->
    't encoding ->
    't encoding

  (** See {!lazy_encoding} below.*)
  type 'a lazy_t

  (** Combinator to have a part of the binary encoding lazily deserialized.
      This is transparent on the JSON side. *)
  val lazy_encoding : 'a encoding -> 'a lazy_t encoding

  (** Force the decoding (memoized for later calls), and return the
      value if successful. *)
  val force_decode : 'a lazy_t -> 'a option

  (** Obtain the bytes without actually deserializing.  Will serialize
      and memoize the result if the value is not the result of a lazy
      deserialization. *)
  val force_bytes : 'a lazy_t -> Bytes.t

  (** Make a lazy value from an immediate one. *)
  val make_lazy : 'a encoding -> 'a -> 'a lazy_t

  (** Apply on structure of lazy value, and combine results *)
  val apply_lazy :
    fun_value:('a -> 'b) ->
    fun_bytes:(Bytes.t -> 'b) ->
    fun_combine:('b -> 'b -> 'b) ->
    'a lazy_t ->
    'b

  (** Create a {!Data_encoding.t} value which records knowledge of
      older versions of a given encoding as long as one can "upgrade"
      from an older version to the next (if upgrade is impossible one
      should consider that the encoding is completely different).

      See the module [Documented_example] in ["./test/versioned.ml"]
      for a tutorial.
  *)
end

include module type of Encoding with type 'a t = 'a Encoding.t

module Registration : sig
  type id = string

  (** A encoding that has been {!register}ed. It can be retreived using either
      {!list} or {!find}. *)
  type t

  (** Descriptions and schemas of registered encodings. *)
  val binary_schema : t -> Binary_schema.t

  val json_schema : t -> Json.schema

  val description : t -> string option

  (** Printers for the encodings. *)
  val json_pretty_printer : t -> Format.formatter -> Json.t -> unit

  val binary_pretty_printer : t -> Format.formatter -> Bytes.t -> unit

  (** [register ~id encoding] registers the [encoding] with the [id]. It can
      later be found using {!find} and providing the matching [id]. It will
      also appear in the results of {!list}. *)
  val register : ?pp:(Format.formatter -> 'a -> unit) -> 'a Encoding.t -> unit

  (** [find id] is [Some r] if [register id e] has been called, in which
      case [r] matches [e]. Otherwise, it is [None]. *)
  val find : id -> t option

  (** [list ()] is a list of pairs [(id, r)] where [r] is
      a registered encoding for the [id]. *)
  val list : unit -> (id * t) list

  (** Conversion functions from/to json to/from bytes. *)
  val bytes_of_json : t -> Json.t -> Bytes.t option

  val json_of_bytes : t -> Bytes.t -> Json.t option
end

module With_version : sig
  (** An encapsulation of consecutive encoding versions. *)
  type _ t

  (** [first_version enc] records that [enc] is the first (known)
      version of the object. *)
  val first_version : 'a encoding -> 'a t

  (** [next_version enc upgrade prev] constructs a new version from
      the previous version [prev] and an [upgrade] function. *)
  val next_version : 'a encoding -> ('b -> 'a) -> 'b t -> 'a t

  (** Make an encoding from an encapsulation of versions; the
      argument [~name] is used to prefix the version "tag" in the
      encoding, it should not change from one version to the next. *)
  val encoding : name:string -> 'a t -> 'a encoding
end

module Json : sig
  (** In memory JSON data, compatible with [Ezjsonm]. *)
  type json =
    [ `O of (string * json) list
    | `Bool of bool
    | `Float of float
    | `A of json list
    | `Null
    | `String of string ]

  type t = json

  type schema = Json_schema.schema

  (** Encodes raw JSON data (BSON is used for binary). *)
  val encoding : json Encoding.t

  (** Encodes a JSON schema (BSON encoded for binary). *)
  val schema_encoding : schema Encoding.t

  (** Create a {!Json_encoding.encoding} from an {!encoding}. *)
  val convert : 'a Encoding.t -> 'a Json_encoding.encoding

  (** Generate a schema from an {!encoding}. *)
  val schema : ?definitions_path:string -> 'a Encoding.t -> schema

  (** Construct a JSON object from an encoding. *)
  val construct : 't Encoding.t -> 't -> json

  (** Destruct a JSON object into a value.
      Fail with an exception if the JSON object and encoding do not match.. *)
  val destruct : 't Encoding.t -> json -> 't

  (** JSON Error. *)

  type path = path_item list

  (** A set of accessors that point to a location in a JSON object. *)
  and path_item =
    [ `Field of string  (** A field in an object. *)
    | `Index of int  (** An index in an array. *)
    | `Star  (** Any / every field or index. *)
    | `Next  (** The next element after an array. *) ]

  (** Exception raised by destructors, with the location in the original
      JSON structure and the specific error. *)
  exception Cannot_destruct of (path * exn)

  (** Unexpected kind of data encountered, with the expectation. *)
  exception Unexpected of string * string

  (** Some {!union} couldn't be destructed, with the reasons for each {!case}. *)
  exception No_case_matched of exn list

  (** Array of unexpected size encountered, with the expectation. *)
  exception Bad_array_size of int * int

  (** Missing field in an object. *)
  exception Missing_field of string

  (** Supernumerary field in an object. *)
  exception Unexpected_field of string

  val print_error :
    ?print_unknown:(Format.formatter -> exn -> unit) ->
    Format.formatter ->
    exn ->
    unit

  (** Helpers for writing encoders. *)
  val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a

  val wrap_error : ('a -> 'b) -> 'a -> 'b

  (** Read a JSON document from a string. *)
  val from_string : string -> (json, string) result

  (** Read a stream of JSON documents from a stream of strings.
      A single JSON document may be represented in multiple consecutive
      strings. But only the first document of a string is considered. *)
  val from_stream : string Lwt_stream.t -> (json, string) result Lwt_stream.t

  (** Write a JSON document to a string. This goes via an intermediate
      buffer and so may be slow on large documents. *)
  val to_string : ?newline:bool -> ?minify:bool -> json -> string

  val pp : Format.formatter -> json -> unit
end

module Bson : sig
  type bson = Json_repr_bson.bson

  type t = bson

  (** Construct a BSON object from an encoding. *)
  val construct : 't Encoding.t -> 't -> bson

  (** Destruct a BSON object into a value.
      Fail with an exception if the JSON object and encoding do not match.. *)
  val destruct : 't Encoding.t -> bson -> 't
end

module Binary_schema : sig
  type t

  val pp : Format.formatter -> t -> unit

  val encoding : t Encoding.t
end

module Binary : sig
  (** All the errors that might be returned while reading a binary value *)
  type read_error =
    | Not_enough_data
    | Extra_bytes
    | No_case_matched
    | Unexpected_tag of int
    | Invalid_size of int
    | Invalid_int of {min : int; v : int; max : int}
    | Invalid_float of {min : float; v : float; max : float}
    | Trailing_zero
    | Size_limit_exceeded
    | List_too_long
    | Array_too_long

  exception Read_error of read_error

  val pp_read_error : Format.formatter -> read_error -> unit

  (** All the errors that might be returned while writing a binary value *)
  type write_error =
    | Size_limit_exceeded
    | No_case_matched
    | Invalid_int of {min : int; v : int; max : int}
    | Invalid_float of {min : float; v : float; max : float}
    | Invalid_bytes_length of {expected : int; found : int}
    | Invalid_string_length of {expected : int; found : int}
    | Invalid_natural
    | List_too_long
    | Array_too_long

  val pp_write_error : Format.formatter -> write_error -> unit

  exception Write_error of write_error

  (** Compute the expected length of the binary representation of a value *)
  val length : 'a Encoding.t -> 'a -> int

  (** Returns the size of the binary representation that the given
      encoding might produce, only when the size of the representation
      does not depends of the value itself. *)
  val fixed_length : 'a Encoding.t -> int option

  val fixed_length_exn : 'a Encoding.t -> int

  (** [read enc buf ofs len] tries to reconstruct a value from the
      bytes in [buf] starting at offset [ofs] and reading at most
      [len] bytes. This function also returns the offset of the first
      unread bytes in the [buf]. *)
  val read : 'a Encoding.t -> Bytes.t -> int -> int -> (int * 'a) option

  (** Return type for the function [read_stream]. *)
  type 'ret status =
    | Success of {result : 'ret; size : int; stream : Binary_stream.t}
        (** Fully decoded value, together with the total amount of bytes reads,
        and the remaining unread stream. *)
    | Await of (Bytes.t -> 'ret status)  (** Partially decoded value.*)
    | Error of read_error
        (** Failure. The stream is garbled and it should be dropped. *)

  (** Streamed equivalent of [read]. This variant cannot be called on
      variable-size encodings. *)
  val read_stream : ?init:Binary_stream.t -> 'a Encoding.t -> 'a status

  (** [write enc v buf ofs len] writes the binary representation of [v]
      as described by to [enc], in  [buf] starting at the offset [ofs]
      and writing at most [len] bytes. The function returns the offset
      of first unwritten bytes, or returns [None] in case of failure.
      In the latter case, some data might have been written on the buffer. *)
  val write : 'a Encoding.t -> 'a -> Bytes.t -> int -> int -> int option

  (** [of_bytes enc buf] is equivalent to [read enc buf 0 (length buf)].
      The function fails if the buffer is not fully read. *)
  val of_bytes : 'a Encoding.t -> Bytes.t -> 'a option

  (** [of_bytes_exn enc buf] is equivalent to [to_bytes], except
      @raise [Read_error] instead of returning [None] in case of error. *)
  val of_bytes_exn : 'a Encoding.t -> Bytes.t -> 'a

  (** [to_bytes enc v] is the equivalent of [write env buf 0 len]
      where [buf] is a newly allocated buffer of the expected
      length [len] (see [length env v]). *)
  val to_bytes : 'a Encoding.t -> 'a -> Bytes.t option

  (** [to_bytes_exn enc v] is equivalent to [to_bytes enc v], except
      @raise [Write_error] instead of returning [None] in case of error. *)
  val to_bytes_exn : 'a Encoding.t -> 'a -> Bytes.t

  val describe : 'a Encoding.t -> Binary_schema.t
end

type json = Json.t

val json : json Encoding.t

type json_schema = Json.schema

val json_schema : json_schema Encoding.t

type bson = Bson.t
src/lib_data_encoding/data_encoding.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Encoding.
  Definition t (a : Type) := Tezos_data_encoding.Encoding.t a.
  
  Definition encoding (a : Type) := t a.
  
  Parameter null : encoding unit.
  
  Parameter empty : encoding unit.
  
  Parameter unit : encoding unit.
  
  Parameter constant : string -> encoding unit.
  
  Parameter int8 : encoding Z.
  
  Parameter uint8 : encoding Z.
  
  Parameter int16 : encoding Z.
  
  Parameter uint16 : encoding Z.
  
  Parameter int31 : encoding Z.
  
  Parameter int32 : encoding int32.
  
  Parameter int64 : encoding int64.
  
  Parameter ranged_int : Z -> Z -> encoding Z.
  
  Parameter z : encoding Z.t.
  
  Parameter n : encoding Z.t.
  
  Parameter float : encoding float.
  
  Parameter ranged_float : float -> float -> encoding float.
  
  Parameter bool : encoding bool.
  
  Parameter string : encoding string.
  
  Parameter bytes : encoding Stdlib.Bytes.t.
  
  Parameter option : forall {a : Type}, (encoding a) -> encoding (option a).
  
  Parameter result : forall {a b : Type}, (encoding a) ->
    (encoding b) -> encoding (sum a b).
  
  Parameter array : forall {a : Type}, (option Z) ->
    (encoding a) -> encoding (array a).
  
  Parameter list : forall {a : Type}, (option Z) ->
    (encoding a) -> encoding (list a).
  
  Parameter conv : forall {a b : Type}, (a -> b) ->
    (b -> a) -> (option Json_schema.schema) -> (encoding b) -> encoding a.
  
  Parameter assoc : forall {a : Type}, (encoding a) ->
    encoding (list (string * a)).
  
  Parameter field : forall (a : Type), Type.
  
  Parameter req : forall {t : Type}, (option string) ->
    (option string) -> string -> (encoding t) -> field t.
  
  Parameter opt : forall {t : Type}, (option string) ->
    (option string) -> string -> (encoding t) -> field (option t).
  
  Parameter varopt : forall {t : Type}, (option string) ->
    (option string) -> string -> (encoding t) -> field (option t).
  
  Parameter dft : forall {t : Type}, (option string) ->
    (option string) -> string -> (encoding t) -> t -> field t.
  
  Parameter obj1 : forall {f1 : Type}, (field f1) -> encoding f1.
  
  Parameter obj2 : forall {f1 f2 : Type}, (field f1) ->
    (field f2) -> encoding (f1 * f2).
  
  Parameter obj3 : forall {f1 f2 f3 : Type}, (field f1) ->
    (field f2) -> (field f3) -> encoding (f1 * f2 * f3).
  
  Parameter obj4 : forall {f1 f2 f3 f4 : Type}, (field f1) ->
    (field f2) -> (field f3) -> (field f4) -> encoding (f1 * f2 * f3 * f4).
  
  Parameter obj5 : forall {f1 f2 f3 f4 f5 : Type}, (field f1) ->
    (field f2) ->
      (field f3) ->
        (field f4) -> (field f5) -> encoding (f1 * f2 * f3 * f4 * f5).
  
  Parameter obj6 : forall {f1 f2 f3 f4 f5 f6 : Type}, (field f1) ->
    (field f2) ->
      (field f3) ->
        (field f4) ->
          (field f5) -> (field f6) -> encoding (f1 * f2 * f3 * f4 * f5 * f6).
  
  Parameter obj7 : forall {f1 f2 f3 f4 f5 f6 f7 : Type}, (field f1) ->
    (field f2) ->
      (field f3) ->
        (field f4) ->
          (field f5) ->
            (field f6) ->
              (field f7) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7).
  
  Parameter obj8 : forall {f1 f2 f3 f4 f5 f6 f7 f8 : Type}, (field f1) ->
    (field f2) ->
      (field f3) ->
        (field f4) ->
          (field f5) ->
            (field f6) ->
              (field f7) ->
                (field f8) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8).
  
  Parameter obj9 : forall {f1 f2 f3 f4 f5 f6 f7 f8 f9 : Type}, (field f1) ->
    (field f2) ->
      (field f3) ->
        (field f4) ->
          (field f5) ->
            (field f6) ->
              (field f7) ->
                (field f8) ->
                  (field f9) ->
                    encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9).
  
  Parameter obj10 : forall {f1 f10 f2 f3 f4 f5 f6 f7 f8 f9 : Type}, (field f1)
    ->
    (field f2) ->
      (field f3) ->
        (field f4) ->
          (field f5) ->
            (field f6) ->
              (field f7) ->
                (field f8) ->
                  (field f9) ->
                    (field f10) ->
                      encoding
                        (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9 * f10).
  
  Parameter merge_objs : forall {o1 o2 : Type}, (encoding o1) ->
    (encoding o2) -> encoding (o1 * o2).
  
  Parameter tup1 : forall {f1 : Type}, (encoding f1) -> encoding f1.
  
  Parameter tup2 : forall {f1 f2 : Type}, (encoding f1) ->
    (encoding f2) -> encoding (f1 * f2).
  
  Parameter tup3 : forall {f1 f2 f3 : Type}, (encoding f1) ->
    (encoding f2) -> (encoding f3) -> encoding (f1 * f2 * f3).
  
  Parameter tup4 : forall {f1 f2 f3 f4 : Type}, (encoding f1) ->
    (encoding f2) ->
      (encoding f3) -> (encoding f4) -> encoding (f1 * f2 * f3 * f4).
  
  Parameter tup5 : forall {f1 f2 f3 f4 f5 : Type}, (encoding f1) ->
    (encoding f2) ->
      (encoding f3) ->
        (encoding f4) -> (encoding f5) -> encoding (f1 * f2 * f3 * f4 * f5).
  
  Parameter tup6 : forall {f1 f2 f3 f4 f5 f6 : Type}, (encoding f1) ->
    (encoding f2) ->
      (encoding f3) ->
        (encoding f4) ->
          (encoding f5) ->
            (encoding f6) -> encoding (f1 * f2 * f3 * f4 * f5 * f6).
  
  Parameter tup7 : forall {f1 f2 f3 f4 f5 f6 f7 : Type}, (encoding f1) ->
    (encoding f2) ->
      (encoding f3) ->
        (encoding f4) ->
          (encoding f5) ->
            (encoding f6) ->
              (encoding f7) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7).
  
  Parameter tup8 : forall {f1 f2 f3 f4 f5 f6 f7 f8 : Type}, (encoding f1) ->
    (encoding f2) ->
      (encoding f3) ->
        (encoding f4) ->
          (encoding f5) ->
            (encoding f6) ->
              (encoding f7) ->
                (encoding f8) ->
                  encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8).
  
  Parameter tup9 : forall {f1 f2 f3 f4 f5 f6 f7 f8 f9 : Type}, (encoding f1) ->
    (encoding f2) ->
      (encoding f3) ->
        (encoding f4) ->
          (encoding f5) ->
            (encoding f6) ->
              (encoding f7) ->
                (encoding f8) ->
                  (encoding f9) ->
                    encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9).
  
  Parameter tup10 : forall {f1 f10 f2 f3 f4 f5 f6 f7 f8 f9 : Type}, (encoding f1)
    ->
    (encoding f2) ->
      (encoding f3) ->
        (encoding f4) ->
          (encoding f5) ->
            (encoding f6) ->
              (encoding f7) ->
                (encoding f8) ->
                  (encoding f9) ->
                    (encoding f10) ->
                      encoding
                        (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9 * f10).
  
  Parameter merge_tups : forall {a1 a2 : Type}, (encoding a1) ->
    (encoding a2) -> encoding (a1 * a2).
  
  Parameter case : forall (t : Type), Type.
  
  Inductive case_tag : Type :=
  | Tag : Z -> case_tag
  | Json_only : case_tag.
  
  Parameter case : forall {a t : Type}, string ->
    (option string) ->
      case_tag -> (encoding a) -> (t -> option a) -> (a -> t) -> case t.
  
  Parameter union : forall {t variant : Type}, (option variant) ->
    (list (case t)) -> encoding t.
  
  Parameter is_obj : forall {a : Type}, (encoding a) -> bool.
  
  Parameter is_tup : forall {a : Type}, (encoding a) -> bool.
  
  Parameter classify : forall {a variant : Type}, (encoding a) -> variant.
  
  Parameter string_enum : forall {a : Type}, (list (string * a)) -> encoding a.
  
  Module Fixed.
    Parameter string : Z -> encoding string.
    
    Parameter bytes : Z -> encoding Stdlib.Bytes.t.
    
    Parameter add_padding : forall {a : Type}, (encoding a) -> Z -> encoding a.
  End Fixed.
  
  Module Variable.
    Parameter string : encoding string.
    
    Parameter bytes : encoding Stdlib.Bytes.t.
    
    Parameter array : forall {a : Type}, (option Z) ->
      (encoding a) -> encoding (array a).
    
    Parameter list : forall {a : Type}, (option Z) ->
      (encoding a) -> encoding (list a).
  End Variable.
  
  Module Bounded.
    Parameter string : Z -> encoding string.
    
    Parameter bytes : Z -> encoding Stdlib.Bytes.t.
  End Bounded.
  
  Parameter dynamic_size : forall {a variant : Type}, (option variant) ->
    (encoding a) -> encoding a.
  
  Parameter check_size : forall {a : Type}, Z -> (encoding a) -> encoding a.
  
  Parameter delayed : forall {a : Type}, (unit -> encoding a) -> encoding a.
  
  Parameter splitted : forall {a : Type}, (encoding a) ->
    (encoding a) -> encoding a.
  
  Parameter mu : forall {a : Type}, string ->
    (option string) ->
      (option string) -> ((encoding a) -> encoding a) -> encoding a.
  
  Parameter def : forall {t : Type}, string ->
    (option string) -> (option string) -> (encoding t) -> encoding t.
  
  Parameter lazy_t : forall (a : Type), Type.
  
  Parameter lazy_encoding : forall {a : Type}, (encoding a) ->
    encoding (lazy_t a).
  
  Parameter force_decode : forall {a : Type}, (lazy_t a) -> option a.
  
  Parameter force_bytes : forall {a : Type}, (lazy_t a) -> Stdlib.Bytes.t.
  
  Parameter make_lazy : forall {a : Type}, (encoding a) -> a -> lazy_t a.
  
  Parameter apply_lazy : forall {a b : Type}, (a -> b) ->
    (Stdlib.Bytes.t -> b) -> (b -> b -> b) -> (lazy_t a) -> b.
End Encoding.

include

Module Registration.
  Definition id := string.
  
  Parameter t : Type.
  
  Parameter binary_schema : t -> Tezos_data_encoding.Binary_schema.t.
  
  Parameter json_schema : t -> Tezos_data_encoding.Json.schema.
  
  Parameter description : t -> option string.
  
  Parameter json_pretty_printer : t ->
    Stdlib.Format.formatter -> Tezos_data_encoding.Json.t -> unit.
  
  Parameter binary_pretty_printer : t ->
    Stdlib.Format.formatter -> Stdlib.Bytes.t -> unit.
  
  Parameter register : forall {a : Type}, (option
    (Stdlib.Format.formatter -> a -> unit)) -> (Encoding.t a) -> unit.
  
  Parameter find : id -> option t.
  
  Parameter list : unit -> list (id * t).
  
  Parameter bytes_of_json : t ->
    Tezos_data_encoding.Json.t -> option Stdlib.Bytes.t.
  
  Parameter json_of_bytes : t ->
    Stdlib.Bytes.t -> option Tezos_data_encoding.Json.t.
End Registration.

Module With_version.
  Parameter t : forall (_ : Type), Type.
  
  Parameter first_version : forall {a : Type}, (encoding a) -> t a.
  
  Parameter next_version : forall {a b : Type}, (encoding a) ->
    (b -> a) -> (t b) -> t a.
  
  Parameter encoding : forall {a : Type}, string -> (t a) -> encoding a.
End With_version.

Module Json.
  Definition json := variant.
  
  Definition t := json.
  
  Definition schema := Json_schema.schema.
  
  Parameter encoding : Encoding.t json.
  
  Parameter schema_encoding : Encoding.t schema.
  
  Parameter convert : forall {a : Type}, (Encoding.t a) ->
    Json_encoding.encoding a.
  
  Parameter schema : forall {a : Type}, (option string) ->
    (Encoding.t a) -> schema.
  
  Parameter construct : forall {t : Type}, (Encoding.t t) -> t -> json.
  
  Parameter destruct : forall {t : Type}, (Encoding.t t) -> json -> t.
  
  Reserved Notation "'path".
  Reserved Notation "'path_item".
  
  
  
  where "'path" := ( list 'path_item)
  
  and "'path_item" := ( variant).
  
  Definition path := 'path.
  Definition path_item := 'path_item.
  
  exception
  
  exception
  
  exception
  
  exception
  
  exception
  
  exception
  
  Parameter print_error : (option (Stdlib.Format.formatter -> exn -> unit)) ->
    Stdlib.Format.formatter -> exn -> unit.
  
  Parameter cannot_destruct : forall {a b : Type}, (Stdlib.format4 a
    Stdlib.Format.formatter unit b) -> a.
  
  Parameter wrap_error : forall {a b : Type}, (a -> b) -> a -> b.
  
  Parameter from_string : string -> sum json string.
  
  Parameter from_stream : (Lwt_stream.t string) ->
    Lwt_stream.t (sum json string).
  
  Parameter to_string : (option bool) -> (option bool) -> json -> string.
  
  Parameter pp : Stdlib.Format.formatter -> json -> unit.
End Json.

Module Bson.
  Definition bson := Json_repr_bson.bson.
  
  Definition t := bson.
  
  Parameter construct : forall {t : Type}, (Encoding.t t) -> t -> bson.
  
  Parameter destruct : forall {t : Type}, (Encoding.t t) -> bson -> t.
End Bson.

Module Binary_schema.
  Parameter t : Type.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
  
  Parameter encoding : Encoding.t t.
End Binary_schema.

Module Binary.
  Inductive read_error : Type :=
  | Not_enough_data : read_error
  | Extra_bytes : read_error
  | No_case_matched : read_error
  | Unexpected_tag : Z -> read_error
  | Invalid_size : Z -> read_error
  | Invalid_int : Z -> Z -> Z -> read_error
  | Invalid_float : float -> float -> float -> read_error
  | Trailing_zero : read_error
  | Size_limit_exceeded : read_error
  | List_too_long : read_error
  | Array_too_long : read_error.
  
  exception
  
  Parameter pp_read_error : Stdlib.Format.formatter -> read_error -> unit.
  
  Inductive write_error : Type :=
  | Size_limit_exceeded : write_error
  | No_case_matched : write_error
  | Invalid_int : Z -> Z -> Z -> write_error
  | Invalid_float : float -> float -> float -> write_error
  | Invalid_bytes_length : Z -> Z -> write_error
  | Invalid_string_length : Z -> Z -> write_error
  | Invalid_natural : write_error
  | List_too_long : write_error
  | Array_too_long : write_error.
  
  Parameter pp_write_error : Stdlib.Format.formatter -> write_error -> unit.
  
  exception
  
  Parameter length : forall {a : Type}, (Encoding.t a) -> a -> Z.
  
  Parameter fixed_length : forall {a : Type}, (Encoding.t a) -> option Z.
  
  Parameter fixed_length_exn : forall {a : Type}, (Encoding.t a) -> Z.
  
  Parameter read : forall {a : Type}, (Encoding.t a) ->
    Stdlib.Bytes.t -> Z -> Z -> option (Z * a).
  
  Inductive status (ret : Type) : Type :=
  | Success : ret -> Z -> Tezos_data_encoding.Binary_stream.t -> status ret
  | Await : (Stdlib.Bytes.t -> status ret) -> status ret
  | Error : read_error -> status ret.
  
  Arguments Success {_}.
  Arguments Await {_}.
  Arguments Error {_}.
  
  Parameter read_stream : forall {a : Type}, (option
    Tezos_data_encoding.Binary_stream.t) -> (Encoding.t a) -> status a.
  
  Parameter write : forall {a : Type}, (Encoding.t a) ->
    a -> Stdlib.Bytes.t -> Z -> Z -> option Z.
  
  Parameter of_bytes : forall {a : Type}, (Encoding.t a) ->
    Stdlib.Bytes.t -> option a.
  
  Parameter of_bytes_exn : forall {a : Type}, (Encoding.t a) ->
    Stdlib.Bytes.t -> a.
  
  Parameter to_bytes : forall {a : Type}, (Encoding.t a) ->
    a -> option Stdlib.Bytes.t.
  
  Parameter to_bytes_exn : forall {a : Type}, (Encoding.t a) ->
    a -> Stdlib.Bytes.t.
  
  Parameter describe : forall {a : Type}, (Encoding.t a) -> Binary_schema.t.
End Binary.

Definition json := Json.t.

Parameter json : Encoding.t json.

Definition json_schema := Json.schema.

Parameter json_schema : Encoding.t json_schema.

Definition bson := Bson.t.
src/lib_data_encoding/encoding.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Kind = struct
  type t = [`Fixed of int | `Dynamic | `Variable]

  type length = [`Fixed of int | `Variable]

  type enum = [`Dynamic | `Variable]

  let combine name : t -> t -> t =
   fun k1 k2 ->
    match (k1, k2) with
    | (`Fixed n1, `Fixed n2) ->
        `Fixed (n1 + n2)
    | (`Dynamic, `Dynamic) | (`Fixed _, `Dynamic) | (`Dynamic, `Fixed _) ->
        `Dynamic
    | (`Variable, `Fixed _) | ((`Dynamic | `Fixed _), `Variable) ->
        `Variable
    | (`Variable, `Dynamic) ->
        Printf.ksprintf
          invalid_arg
          "Cannot merge two %s when the left element is of variable length \
           and the right one of dynamic length. You should use the reverse \
           order, or wrap the second one with Data_encoding.dynamic_size."
          name
    | (`Variable, `Variable) ->
        Printf.ksprintf
          invalid_arg
          "Cannot merge two %s with variable length. You should wrap one of \
           them with Data_encoding.dynamic_size."
          name

  let merge : t -> t -> t =
   fun k1 k2 ->
    match (k1, k2) with
    | (`Fixed n1, `Fixed n2) when n1 = n2 ->
        `Fixed n1
    | (`Fixed _, `Fixed _) ->
        `Dynamic
    | (`Dynamic, `Dynamic) | (`Fixed _, `Dynamic) | (`Dynamic, `Fixed _) ->
        `Dynamic
    | (`Variable, (`Dynamic | `Fixed _))
    | ((`Dynamic | `Fixed _), `Variable)
    | (`Variable, `Variable) ->
        `Variable

  let merge_list sz : t list -> t = function
    | [] ->
        assert false (* should be rejected by Data_encoding.union *)
    | k :: ks -> (
      match List.fold_left merge k ks with
      | `Fixed n ->
          `Fixed (n + Binary_size.tag_size sz)
      | k ->
          k )
end

type case_tag = Tag of int | Json_only

type 'a desc =
  | Null : unit desc
  | Empty : unit desc
  | Ignore : unit desc
  | Constant : string -> unit desc
  | Bool : bool desc
  | Int8 : int desc
  | Uint8 : int desc
  | Int16 : int desc
  | Uint16 : int desc
  | Int31 : int desc
  | Int32 : Int32.t desc
  | Int64 : Int64.t desc
  | N : Z.t desc
  | Z : Z.t desc
  | RangedInt : {minimum : int; maximum : int} -> int desc
  | RangedFloat : {minimum : float; maximum : float} -> float desc
  | Float : float desc
  | Bytes : Kind.length -> Bytes.t desc
  | String : Kind.length -> string desc
  | Padded : 'a t * int -> 'a desc
  | String_enum : ('a, string * int) Hashtbl.t * 'a array -> 'a desc
  | Array : int option * 'a t -> 'a array desc
  | List : int option * 'a t -> 'a list desc
  | Obj : 'a field -> 'a desc
  | Objs : {kind : Kind.t; left : 'a t; right : 'b t} -> ('a * 'b) desc
  | Tup : 'a t -> 'a desc
  | Tups : {kind : Kind.t; left : 'a t; right : 'b t} -> ('a * 'b) desc
  | Union : {
      kind : Kind.t;
      tag_size : Binary_size.tag_size;
      cases : 'a case list;
    }
      -> 'a desc
  | Mu : {
      kind : Kind.enum;
      name : string;
      title : string option;
      description : string option;
      fix : 'a t -> 'a t;
    }
      -> 'a desc
  | Conv : {
      proj : 'a -> 'b;
      inj : 'b -> 'a;
      encoding : 'b t;
      schema : Json_schema.schema option;
    }
      -> 'a desc
  | Describe : {
      id : string;
      title : string option;
      description : string option;
      encoding : 'a t;
    }
      -> 'a desc
  | Splitted : {
      encoding : 'a t;
      json_encoding : 'a Json_encoding.encoding;
      is_obj : bool;
      is_tup : bool;
    }
      -> 'a desc
  | Dynamic_size : {
      kind : Binary_size.unsigned_integer;
      encoding : 'a t;
    }
      -> 'a desc
  | Check_size : {limit : int; encoding : 'a t} -> 'a desc
  | Delayed : (unit -> 'a t) -> 'a desc

and _ field =
  | Req : {
      name : string;
      encoding : 'a t;
      title : string option;
      description : string option;
    }
      -> 'a field
  | Opt : {
      name : string;
      kind : Kind.enum;
      encoding : 'a t;
      title : string option;
      description : string option;
    }
      -> 'a option field
  | Dft : {
      name : string;
      encoding : 'a t;
      default : 'a;
      title : string option;
      description : string option;
    }
      -> 'a field

and 'a case =
  | Case : {
      title : string;
      description : string option;
      encoding : 'a t;
      proj : 't -> 'a option;
      inj : 'a -> 't;
      tag : case_tag;
    }
      -> 't case

and 'a t = {
  encoding : 'a desc;
  mutable json_encoding : 'a Json_encoding.encoding option;
}

type 'a encoding = 'a t

let rec classify : type a. a t -> Kind.t = fun e -> classify_desc e.encoding

and classify_desc : type a. a desc -> Kind.t =
 fun e ->
  match e with
  (* Fixed *)
  | Null ->
      `Fixed 0
  | Empty ->
      `Fixed 0
  | Constant _ ->
      `Fixed 0
  | Bool ->
      `Fixed Binary_size.bool
  | Int8 ->
      `Fixed Binary_size.int8
  | Uint8 ->
      `Fixed Binary_size.uint8
  | Int16 ->
      `Fixed Binary_size.int16
  | Uint16 ->
      `Fixed Binary_size.uint16
  | Int31 ->
      `Fixed Binary_size.int31
  | Int32 ->
      `Fixed Binary_size.int32
  | Int64 ->
      `Fixed Binary_size.int64
  | N ->
      `Dynamic
  | Z ->
      `Dynamic
  | RangedInt {minimum; maximum} ->
      `Fixed Binary_size.(integer_to_size @@ range_to_size ~minimum ~maximum)
  | Float ->
      `Fixed Binary_size.float
  | RangedFloat _ ->
      `Fixed Binary_size.float
  (* Tagged *)
  | Bytes kind ->
      (kind :> Kind.t)
  | String kind ->
      (kind :> Kind.t)
  | Padded ({encoding; _}, n) -> (
    match classify_desc encoding with
    | `Fixed m ->
        `Fixed (n + m)
    | _ ->
        assert false (* by construction (see [Fixed.padded]) *) )
  | String_enum (_, cases) ->
      `Fixed Binary_size.(integer_to_size @@ enum_size cases)
  | Obj (Opt {kind; _}) ->
      (kind :> Kind.t)
  | Objs {kind; _} ->
      kind
  | Tups {kind; _} ->
      kind
  | Union {kind; _} ->
      (kind :> Kind.t)
  | Mu {kind; _} ->
      (kind :> Kind.t)
  (* Variable *)
  | Ignore ->
      `Fixed 0
  | Array _ ->
      `Variable
  | List _ ->
      `Variable
  (* Recursive *)
  | Obj (Req {encoding; _}) ->
      classify encoding
  | Obj (Dft {encoding; _}) ->
      classify encoding
  | Tup encoding ->
      classify encoding
  | Conv {encoding; _} ->
      classify encoding
  | Describe {encoding; _} ->
      classify encoding
  | Splitted {encoding; _} ->
      classify encoding
  | Dynamic_size _ ->
      `Dynamic
  | Check_size {encoding; _} ->
      classify encoding
  | Delayed f ->
      classify (f ())

let make ?json_encoding encoding = {encoding; json_encoding}

module Fixed = struct
  let string n =
    if n <= 0 then
      invalid_arg
        "Cannot create a string encoding of negative or null fixed length." ;
    make @@ String (`Fixed n)

  let bytes n =
    if n <= 0 then
      invalid_arg
        "Cannot create a byte encoding of negative or null fixed length." ;
    make @@ Bytes (`Fixed n)

  let add_padding e n =
    if n <= 0 then
      invalid_arg "Cannot create a padding of negative or null fixed length." ;
    match classify e with
    | `Fixed _ ->
        make @@ Padded (e, n)
    | _ ->
        invalid_arg "Cannot pad non-fixed size encoding"
end

let rec is_zeroable : type t. t encoding -> bool =
 fun e ->
  (* Whether an encoding can ever produce zero-byte of encoding. It is dnagerous
     to place zero-size elements in a collection (list/array) because
     they are indistinguishable from the abscence of elements. *)
  match e.encoding with
  (* trivially true *)
  | Null ->
      true (* always true *)
  | Empty ->
      true (* always true *)
  | Ignore ->
      true (* always true *)
  | Constant _ ->
      true (* always true *)
  (* trivially false *)
  | Bool ->
      false
  | Int8 ->
      false
  | Uint8 ->
      false
  | Int16 ->
      false
  | Uint16 ->
      false
  | Int31 ->
      false
  | Int32 ->
      false
  | Int64 ->
      false
  | N ->
      false
  | Z ->
      false
  | RangedInt _ ->
      false
  | RangedFloat _ ->
      false
  | Float ->
      false
  | Bytes _ ->
      false
  | String _ ->
      false
  | Padded _ ->
      false
  | String_enum _ ->
      false
  (* true in some cases, but in practice always protected by Dynamic *)
  | Array _ ->
      true (* 0-element array *)
  | List _ ->
      true (* 0-element list *)
  (* represented as whatever is inside: truth mostly propagates *)
  | Obj (Req {encoding = e; _}) ->
      is_zeroable e (* represented as-is *)
  | Obj (Opt {kind = `Variable; _}) ->
      true (* optional field ommited *)
  | Obj (Dft {encoding = e; _}) ->
      is_zeroable e (* represented as-is *)
  | Obj _ ->
      false
  | Objs {left; right; _} ->
      is_zeroable left && is_zeroable right
  | Tup e ->
      is_zeroable e
  | Tups {left; right; _} ->
      is_zeroable left && is_zeroable right
  | Union _ ->
      false (* includes a tag *)
  (* other recursive cases: truth propagates *)
  | Mu {kind = `Dynamic; _} ->
      false (* size prefix *)
  | Mu {kind = `Variable; fix; _} ->
      is_zeroable (fix e)
  | Conv {encoding; _} ->
      is_zeroable encoding
  | Describe {encoding; _} ->
      is_zeroable encoding
  | Splitted {encoding; _} ->
      is_zeroable encoding
  | Check_size {encoding; _} ->
      is_zeroable encoding
  (* Unscrutable: true by default *)
  | Delayed f ->
      is_zeroable (f ())
  (* Protected against zeroable *)
  | Dynamic_size _ ->
      false

(* always some data for size *)

module Variable = struct
  let string = make @@ String `Variable

  let bytes = make @@ Bytes `Variable

  let check_not_variable name e =
    match classify e with
    | `Variable ->
        Printf.ksprintf
          invalid_arg
          "Cannot insert variable length element in %s. You should wrap the \
           contents using Data_encoding.dynamic_size."
          name
    | `Dynamic | `Fixed _ ->
        ()

  let check_not_zeroable name e =
    if is_zeroable e then
      Printf.ksprintf
        invalid_arg
        "Cannot insert potentially zero-sized element in %s."
        name
    else ()

  let array ?max_length e =
    check_not_variable "an array" e ;
    check_not_zeroable "an array" e ;
    let encoding = make @@ Array (max_length, e) in
    match (classify e, max_length) with
    | (`Fixed n, Some max_length) ->
        let limit = n * max_length in
        make @@ Check_size {limit; encoding}
    | (_, _) ->
        encoding

  let list ?max_length e =
    check_not_variable "a list" e ;
    check_not_zeroable "a list" e ;
    let encoding = make @@ List (max_length, e) in
    match (classify e, max_length) with
    | (`Fixed n, Some max_length) ->
        let limit = n * max_length in
        make @@ Check_size {limit; encoding}
    | (_, _) ->
        encoding
end

let dynamic_size ?(kind = `Uint30) e =
  make @@ Dynamic_size {kind; encoding = e}

let check_size limit encoding = make @@ Check_size {limit; encoding}

let delayed f = make @@ Delayed f

let null = make @@ Null

let empty = make @@ Empty

let unit = make @@ Ignore

let constant s = make @@ Constant s

let bool = make @@ Bool

let int8 = make @@ Int8

let uint8 = make @@ Uint8

let int16 = make @@ Int16

let uint16 = make @@ Uint16

let int31 = make @@ Int31

let int32 = make @@ Int32

let ranged_int minimum maximum =
  let minimum = min minimum maximum and maximum = max minimum maximum in
  if minimum < -(1 lsl 30) || (1 lsl 30) - 1 < maximum then
    invalid_arg "Data_encoding.ranged_int" ;
  make @@ RangedInt {minimum; maximum}

let ranged_float minimum maximum =
  let minimum = min minimum maximum and maximum = max minimum maximum in
  make @@ RangedFloat {minimum; maximum}

let int64 = make @@ Int64

let n = make @@ N

let z = make @@ Z

let float = make @@ Float

let string = dynamic_size Variable.string

let bytes = dynamic_size Variable.bytes

let array ?max_length e = dynamic_size (Variable.array ?max_length e)

let list ?max_length e = dynamic_size (Variable.list ?max_length e)

let string_enum = function
  | [] ->
      invalid_arg "data_encoding.string_enum: cannot have zero cases"
  | [_case] ->
      invalid_arg
        "data_encoding.string_enum: cannot have a single case, use constant \
         instead"
  | _ :: _ as cases ->
      let arr = Array.of_list (List.map snd cases) in
      let tbl = Hashtbl.create (Array.length arr) in
      List.iteri (fun ind (str, a) -> Hashtbl.add tbl a (str, ind)) cases ;
      make @@ String_enum (tbl, arr)

let conv proj inj ?schema encoding = make @@ Conv {proj; inj; encoding; schema}

let def id ?title ?description encoding =
  make @@ Describe {id; title; description; encoding}

let req ?title ?description n t =
  Req {name = n; encoding = t; title; description}

let opt ?title ?description n encoding =
  let kind =
    match classify encoding with
    | `Variable ->
        `Variable
    | `Fixed _ | `Dynamic ->
        `Dynamic
  in
  Opt {name = n; kind; encoding; title; description}

let varopt ?title ?description n encoding =
  Opt {name = n; kind = `Variable; encoding; title; description}

let dft ?title ?description n t d =
  Dft {name = n; encoding = t; default = d; title; description}

let raw_splitted ~json ~binary =
  make
  @@ Splitted
       {
         encoding = binary;
         json_encoding = json;
         is_obj = false;
         is_tup = false;
       }

let rec is_obj : type a. a t -> bool =
 fun e ->
  match e.encoding with
  | Obj _ ->
      true
  | Objs _ (* by construction *) ->
      true
  | Conv {encoding = e; _} ->
      is_obj e
  | Dynamic_size {encoding = e; _} ->
      is_obj e
  | Union {cases; _} ->
      List.for_all (fun (Case {encoding = e; _}) -> is_obj e) cases
  | Empty ->
      true
  | Ignore ->
      true
  | Mu {fix; _} ->
      is_obj (fix e)
  | Splitted {is_obj; _} ->
      is_obj
  | Delayed f ->
      is_obj (f ())
  | Describe {encoding; _} ->
      is_obj encoding
  | _ ->
      false

let rec is_tup : type a. a t -> bool =
 fun e ->
  match e.encoding with
  | Tup _ ->
      true
  | Tups _ (* by construction *) ->
      true
  | Conv {encoding = e; _} ->
      is_tup e
  | Dynamic_size {encoding = e; _} ->
      is_tup e
  | Union {cases; _} ->
      List.for_all (function Case {encoding = e; _} -> is_tup e) cases
  | Mu {fix; _} ->
      is_tup (fix e)
  | Splitted {is_tup; _} ->
      is_tup
  | Delayed f ->
      is_tup (f ())
  | Describe {encoding; _} ->
      is_tup encoding
  | _ ->
      false

let raw_merge_objs left right =
  let kind = Kind.combine "objects" (classify left) (classify right) in
  make @@ Objs {kind; left; right}

let obj1 f1 = make @@ Obj f1

let obj2 f2 f1 = raw_merge_objs (obj1 f2) (obj1 f1)

let obj3 f3 f2 f1 = raw_merge_objs (obj1 f3) (obj2 f2 f1)

let obj4 f4 f3 f2 f1 = raw_merge_objs (obj2 f4 f3) (obj2 f2 f1)

let obj5 f5 f4 f3 f2 f1 = raw_merge_objs (obj1 f5) (obj4 f4 f3 f2 f1)

let obj6 f6 f5 f4 f3 f2 f1 = raw_merge_objs (obj2 f6 f5) (obj4 f4 f3 f2 f1)

let obj7 f7 f6 f5 f4 f3 f2 f1 =
  raw_merge_objs (obj3 f7 f6 f5) (obj4 f4 f3 f2 f1)

let obj8 f8 f7 f6 f5 f4 f3 f2 f1 =
  raw_merge_objs (obj4 f8 f7 f6 f5) (obj4 f4 f3 f2 f1)

let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
  raw_merge_objs (obj1 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)

let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
  raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)

let merge_objs o1 o2 =
  if is_obj o1 && is_obj o2 then raw_merge_objs o1 o2
  else invalid_arg "Json_encoding.merge_objs"

let raw_merge_tups left right =
  let kind = Kind.combine "tuples" (classify left) (classify right) in
  make @@ Tups {kind; left; right}

let tup1 e1 = make @@ Tup e1

let tup2 e2 e1 = raw_merge_tups (tup1 e2) (tup1 e1)

let tup3 e3 e2 e1 = raw_merge_tups (tup1 e3) (tup2 e2 e1)

let tup4 e4 e3 e2 e1 = raw_merge_tups (tup2 e4 e3) (tup2 e2 e1)

let tup5 e5 e4 e3 e2 e1 = raw_merge_tups (tup1 e5) (tup4 e4 e3 e2 e1)

let tup6 e6 e5 e4 e3 e2 e1 = raw_merge_tups (tup2 e6 e5) (tup4 e4 e3 e2 e1)

let tup7 e7 e6 e5 e4 e3 e2 e1 =
  raw_merge_tups (tup3 e7 e6 e5) (tup4 e4 e3 e2 e1)

let tup8 e8 e7 e6 e5 e4 e3 e2 e1 =
  raw_merge_tups (tup4 e8 e7 e6 e5) (tup4 e4 e3 e2 e1)

let tup9 e9 e8 e7 e6 e5 e4 e3 e2 e1 =
  raw_merge_tups (tup1 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)

let tup10 e10 e9 e8 e7 e6 e5 e4 e3 e2 e1 =
  raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)

let merge_tups t1 t2 =
  if is_tup t1 && is_tup t2 then raw_merge_tups t1 t2
  else invalid_arg "Tezos_serial.Encoding.merge_tups"

let conv3 ty =
  conv (fun (c, b, a) -> (c, (b, a))) (fun (c, (b, a)) -> (c, b, a)) ty

let obj3 f3 f2 f1 = conv3 (obj3 f3 f2 f1)

let tup3 f3 f2 f1 = conv3 (tup3 f3 f2 f1)

let conv4 ty =
  conv
    (fun (d, c, b, a) -> ((d, c), (b, a)))
    (fun ((d, c), (b, a)) -> (d, c, b, a))
    ty

let obj4 f4 f3 f2 f1 = conv4 (obj4 f4 f3 f2 f1)

let tup4 f4 f3 f2 f1 = conv4 (tup4 f4 f3 f2 f1)

let conv5 ty =
  conv
    (fun (e, d, c, b, a) -> (e, ((d, c), (b, a))))
    (fun (e, ((d, c), (b, a))) -> (e, d, c, b, a))
    ty

let obj5 f5 f4 f3 f2 f1 = conv5 (obj5 f5 f4 f3 f2 f1)

let tup5 f5 f4 f3 f2 f1 = conv5 (tup5 f5 f4 f3 f2 f1)

let conv6 ty =
  conv
    (fun (f, e, d, c, b, a) -> ((f, e), ((d, c), (b, a))))
    (fun ((f, e), ((d, c), (b, a))) -> (f, e, d, c, b, a))
    ty

let obj6 f6 f5 f4 f3 f2 f1 = conv6 (obj6 f6 f5 f4 f3 f2 f1)

let tup6 f6 f5 f4 f3 f2 f1 = conv6 (tup6 f6 f5 f4 f3 f2 f1)

let conv7 ty =
  conv
    (fun (g, f, e, d, c, b, a) -> ((g, (f, e)), ((d, c), (b, a))))
    (fun ((g, (f, e)), ((d, c), (b, a))) -> (g, f, e, d, c, b, a))
    ty

let obj7 f7 f6 f5 f4 f3 f2 f1 = conv7 (obj7 f7 f6 f5 f4 f3 f2 f1)

let tup7 f7 f6 f5 f4 f3 f2 f1 = conv7 (tup7 f7 f6 f5 f4 f3 f2 f1)

let conv8 ty =
  conv
    (fun (h, g, f, e, d, c, b, a) -> (((h, g), (f, e)), ((d, c), (b, a))))
    (fun (((h, g), (f, e)), ((d, c), (b, a))) -> (h, g, f, e, d, c, b, a))
    ty

let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1)

let tup8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1)

let conv9 ty =
  conv
    (fun (i, h, g, f, e, d, c, b, a) ->
      (i, (((h, g), (f, e)), ((d, c), (b, a)))))
    (fun (i, (((h, g), (f, e)), ((d, c), (b, a)))) ->
      (i, h, g, f, e, d, c, b, a))
    ty

let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = conv9 (obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1)

let tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = conv9 (tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1)

let conv10 ty =
  conv
    (fun (j, i, h, g, f, e, d, c, b, a) ->
      ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))))
    (fun ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))) ->
      (j, i, h, g, f, e, d, c, b, a))
    ty

let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
  conv10 (obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1)

let tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
  conv10 (tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1)

let check_cases tag_size cases =
  if cases = [] then invalid_arg "Data_encoding.union: empty list of cases." ;
  let max_tag = match tag_size with `Uint8 -> 256 | `Uint16 -> 256 * 256 in
  ignore
  @@ List.fold_left
       (fun others (Case {tag; _}) ->
         match tag with
         | Json_only ->
             others
         | Tag tag ->
             if List.mem tag others then
               Format.kasprintf
                 invalid_arg
                 "The tag %d appears twice in an union."
                 tag ;
             if tag < 0 || max_tag <= tag then
               Format.kasprintf invalid_arg "The tag %d is invalid." tag ;
             tag :: others)
       []
       cases

let union ?(tag_size = `Uint8) cases =
  check_cases tag_size cases ;
  let kinds = List.map (fun (Case {encoding; _}) -> classify encoding) cases in
  let kind = Kind.merge_list tag_size kinds in
  make @@ Union {kind; tag_size; cases}

let case ~title ?description tag encoding proj inj =
  Case {title; description; encoding; proj; inj; tag}

let rec is_nullable : type t. t encoding -> bool =
 fun e ->
  match e.encoding with
  | Null ->
      true
  | Empty ->
      false
  | Ignore ->
      true
  | Constant _ ->
      false
  | Bool ->
      false
  | Int8 ->
      false
  | Uint8 ->
      false
  | Int16 ->
      false
  | Uint16 ->
      false
  | Int31 ->
      false
  | Int32 ->
      false
  | Int64 ->
      false
  | N ->
      false
  | Z ->
      false
  | RangedInt _ ->
      false
  | RangedFloat _ ->
      false
  | Float ->
      false
  | Bytes _ ->
      false
  | String _ ->
      false
  | Padded (e, _) ->
      is_nullable e
  | String_enum _ ->
      false
  | Array _ ->
      false
  | List _ ->
      false
  | Obj _ ->
      false
  | Objs _ ->
      false
  | Tup _ ->
      false
  | Tups _ ->
      false
  | Union {cases; _} ->
      List.exists (fun (Case {encoding = e; _}) -> is_nullable e) cases
  | Mu {fix; _} ->
      is_nullable (fix e)
  | Conv {encoding = e; _} ->
      is_nullable e
  | Describe {encoding = e; _} ->
      is_nullable e
  | Splitted {json_encoding; _} ->
      Json_encoding.is_nullable json_encoding
  | Dynamic_size {encoding = e; _} ->
      is_nullable e
  | Check_size {encoding = e; _} ->
      is_nullable e
  | Delayed _ ->
      true

let option ty =
  if is_nullable ty then
    invalid_arg "Data_encoding.option: cannot nest nullable encodings" ;
  (* TODO add a special construct `Option` in the GADT *)
  union
    ~tag_size:`Uint8
    [ case (Tag 1) ty ~title:"Some" (fun x -> x) (fun x -> Some x);
      case
        (Tag 0)
        null
        ~title:"None"
        (function None -> Some () | Some _ -> None)
        (fun () -> None) ]

let mu name ?title ?description fix =
  let kind =
    try
      let precursor =
        make @@ Mu {kind = `Dynamic; name; title; description; fix}
      in
      match classify @@ fix precursor with
      | `Fixed _ | `Dynamic ->
          `Dynamic
      | `Variable ->
          raise Exit
    with Exit | _ (* TODO variability error *) ->
      let precursor =
        make @@ Mu {kind = `Variable; name; title; description; fix}
      in
      ignore (classify @@ fix precursor) ;
      `Variable
  in
  make @@ Mu {kind; name; title; description; fix}

let result ok_enc error_enc =
  union
    ~tag_size:`Uint8
    [ case
        (Tag 1)
        ok_enc
        ~title:"Ok"
        (function Ok x -> Some x | Error _ -> None)
        (fun x -> Ok x);
      case
        (Tag 0)
        error_enc
        ~title:"Result"
        (function Ok _ -> None | Error x -> Some x)
        (fun x -> Error x) ]
src/lib_data_encoding/encoding.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Kind.
  Definition t := variant.
  
  Definition length := variant.
  
  Definition enum := variant.
  
  Definition combine (name : string) (k1 : t) (k2 : t) : t :=
    match (k1, k2) with
    | (Fixed n1, Fixed n2) => variant
    | (Dynamic, Dynamic) | (Fixed _, Dynamic) | (Dynamic, Fixed _) => variant
    | (Variable, Fixed _) | (Dynamic | Fixed _, Variable) => variant
    | (Variable, Dynamic) =>
      Stdlib.Printf.ksprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Cannot merge two " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " when the left element is of variable length and the right one of dynamic length. You should use the reverse order, or wrap the second one with Data_encoding.dynamic_size."
                  % string CamlinternalFormatBasics.End_of_format)))
          "Cannot merge two %s when the left element is of variable length and the right one of dynamic length. You should use the reverse order, or wrap the second one with Data_encoding.dynamic_size."
            % string) name
    | (Variable, Variable) =>
      Stdlib.Printf.ksprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Cannot merge two " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " with variable length. You should wrap one of them with Data_encoding.dynamic_size."
                  % string CamlinternalFormatBasics.End_of_format)))
          "Cannot merge two %s with variable length. You should wrap one of them with Data_encoding.dynamic_size."
            % string) name
    end.
  
  Definition merge (k1 : t) (k2 : t) : t :=
    match (k1, k2) with
    | (Fixed _, Fixed _) => variant
    | (Dynamic, Dynamic) | (Fixed _, Dynamic) | (Dynamic, Fixed _) => variant
    |
      (Variable, Dynamic | Fixed _) | (Dynamic | Fixed _, Variable) |
        (Variable, Variable) => variant
    end.
  
  Definition merge_list
    (sz : Tezos_data_encoding.Binary_size.tag_size)
    (function_parameter : list t) : t :=
    match function_parameter with
    | [] => false
    | cons k ks =>
      match Stdlib.List.fold_left merge k ks with
      | Fixed n => variant
      | k => k
      end
    end.
End Kind.

Inductive case_tag : Type :=
| Tag : Z -> case_tag
| Json_only : case_tag.

Inductive desc : forall (a : Type), Type :=
| Null : desc unit
| Empty : desc unit
| Ignore : desc unit
| Constant : string -> desc unit
| Bool : desc bool
| Int8 : desc Z
| Uint8 : desc Z
| Int16 : desc Z
| Uint16 : desc Z
| Int31 : desc Z
| Int32 : desc Stdlib.Int32.t
| Int64 : desc Stdlib.Int64.t
| N : desc Z.t
| Z : desc Z.t
| RangedInt : Z -> Z -> desc Z
| RangedFloat : float -> float -> desc float
| Float : desc float
| Bytes : Kind.length -> desc Stdlib.Bytes.t
| String : Kind.length -> desc string
| Padded : forall {a : Type}, (t a) -> Z -> desc a
| String_enum : forall {a : Type}, (Stdlib.Hashtbl.t a (string * Z)) ->
  (array a) -> desc a
| Array : forall {a : Type}, (option Z) -> (t a) -> desc (array a)
| List : forall {a : Type}, (option Z) -> (t a) -> desc (list a)
| Obj : forall {a : Type}, (field a) -> desc a
| Objs : forall {a b : Type}, Kind.t -> (t a) -> (t b) -> desc (a * b)
| Tup : forall {a : Type}, (t a) -> desc a
| Tups : forall {a b : Type}, Kind.t -> (t a) -> (t b) -> desc (a * b)
| Union : forall {a : Type}, Kind.t -> Tezos_data_encoding.Binary_size.tag_size
  -> (list (case a)) -> desc a
| Mu : forall {a : Type}, Kind.enum -> string -> (option string) ->
  (option string) -> ((t a) -> t a) -> desc a
| Conv : forall {a b : Type}, (a -> b) -> (b -> a) -> (t b) ->
  (option Json_schema.schema) -> desc a
| Describe : forall {a : Type}, string -> (option string) -> (option string) ->
  (t a) -> desc a
| Splitted : forall {a : Type}, (t a) -> (Json_encoding.encoding a) -> bool ->
  bool -> desc a
| Dynamic_size : forall {a : Type},
  Tezos_data_encoding.Binary_size.unsigned_integer -> (t a) -> desc a
| Check_size : forall {a : Type}, Z -> (t a) -> desc a
| Delayed : forall {a : Type}, (unit -> t a) -> desc a

with field : forall (_ : Type), Type :=
| Req : forall {a : Type}, string -> (t a) -> (option string) -> (option string)
  -> field a
| Opt : forall {a : Type}, string -> Kind.enum -> (t a) -> (option string) ->
  (option string) -> field (option a)
| Dft : forall {a : Type}, string -> (t a) -> a -> (option string) ->
  (option string) -> field a

with case : forall (a : Type), Type :=
| Case : forall {a t : Type}, string -> (option string) -> (t a) ->
  (t -> option a) -> (a -> t) -> case_tag -> case t.

Definition encoding (a : Type) := t a.

Fixpoint classify {a : Type} (e : t a) : Kind.t := classify_desc (encoding e)

with classify_desc {a : Type} (e : desc a) : Kind.t :=
  match e with
  | Null => variant
  | Empty => variant
  | Constant _ => variant
  | Bool => variant
  | Int8 => variant
  | Uint8 => variant
  | Int16 => variant
  | Uint16 => variant
  | Int31 => variant
  | Int32 => variant
  | Int64 => variant
  | N => variant
  | Z => variant
  | RangedInt {| minimum := minimum; maximum := maximum |} => variant
  | Float => variant
  | RangedFloat _ => variant
  | Bytes kind => kind
  | String kind => kind
  | Padded {| encoding := encoding |} n =>
    match classify_desc encoding with
    | Fixed m => variant
    | _ => false
    end
  | String_enum _ cases => variant
  | Obj (Opt {| kind := kind |}) => kind
  | Objs {| kind := kind |} => kind
  | Tups {| kind := kind |} => kind
  | Union {| kind := kind |} => kind
  | Mu {| kind := kind |} => kind
  | Ignore => variant
  | Array _ _ => variant
  | List _ _ => variant
  | Obj (Req {| encoding := encoding |}) => classify encoding
  | Obj (Dft {| encoding := encoding |}) => classify encoding
  | Tup encoding => classify encoding
  | Conv {| encoding := encoding |} => classify encoding
  | Describe {| encoding := encoding |} => classify encoding
  | Splitted {| encoding := encoding |} => classify encoding
  | Dynamic_size _ => variant
  | Check_size {| encoding := encoding |} => classify encoding
  | Delayed f => classify (f tt)
  end.

Definition make {A : Type}
  (json_encoding : option (Json_encoding.encoding A)) (encoding : desc A)
  : t A := {| encoding := encoding; json_encoding := json_encoding |}.

Module Fixed.
  Definition string (n : Z) : t string :=
    if OCaml.Stdlib.le n 0 then
      OCaml.Stdlib.invalid_arg
        "Cannot create a string encoding of negative or null fixed length." %
          string
    else
      tt;
    apply
      (let arg := make in
      fun eta => arg None eta) (String variant).
  
  Definition bytes (n : Z) : t Stdlib.Bytes.t :=
    if OCaml.Stdlib.le n 0 then
      OCaml.Stdlib.invalid_arg
        "Cannot create a byte encoding of negative or null fixed length." %
          string
    else
      tt;
    apply
      (let arg := make in
      fun eta => arg None eta) (Bytes variant).
  
  Definition add_padding {A : Type} (e : t A) (n : Z) : t A :=
    if OCaml.Stdlib.le n 0 then
      OCaml.Stdlib.invalid_arg
        "Cannot create a padding of negative or null fixed length." % string
    else
      tt;
    match classify e with
    | Fixed _ =>
      apply
        (let arg := make in
        fun eta => arg None eta) (Padded e n)
    | _ =>
      OCaml.Stdlib.invalid_arg "Cannot pad non-fixed size encoding" % string
    end.
End Fixed.

Fixpoint is_zeroable {t : Type} (e : encoding t) : bool :=
  match encoding e with
  | Null => true
  | Empty => true
  | Ignore => true
  | Constant _ => true
  | Bool => false
  | Int8 => false
  | Uint8 => false
  | Int16 => false
  | Uint16 => false
  | Int31 => false
  | Int32 => false
  | Int64 => false
  | N => false
  | Z => false
  | RangedInt _ => false
  | RangedFloat _ => false
  | Float => false
  | Bytes _ => false
  | String _ => false
  | Padded _ _ => false
  | String_enum _ _ => false
  | Array _ _ => true
  | List _ _ => true
  | Obj (Req {| encoding := e |}) => is_zeroable e
  | Obj (Opt {| kind := Variable |}) => true
  | Obj (Dft {| encoding := e |}) => is_zeroable e
  | Obj _ => false
  | Objs {| left := left; right := right |} =>
    andb (is_zeroable left) (is_zeroable right)
  | Tup e => is_zeroable e
  | Tups {| left := left; right := right |} =>
    andb (is_zeroable left) (is_zeroable right)
  | Union _ => false
  | Mu {| kind := Dynamic |} => false
  | Mu {| kind := Variable; fix := fix |} => is_zeroable (fix e)
  | Conv {| encoding := encoding |} => is_zeroable encoding
  | Describe {| encoding := encoding |} => is_zeroable encoding
  | Splitted {| encoding := encoding |} => is_zeroable encoding
  | Check_size {| encoding := encoding |} => is_zeroable encoding
  | Delayed f => is_zeroable (f tt)
  | Dynamic_size _ => false
  end.

Module Variable.
  Definition string : t string :=
    apply
      (let arg := make in
      fun eta => arg None eta) (String variant).
  
  Definition bytes : t Stdlib.Bytes.t :=
    apply
      (let arg := make in
      fun eta => arg None eta) (Bytes variant).
  
  Definition check_not_variable {A : Type} (name : string) (e : t A) : unit :=
    match classify e with
    | Variable =>
      Stdlib.Printf.ksprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cannot insert variable length element in " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                ". You should wrap the contents using Data_encoding.dynamic_size."
                  % string CamlinternalFormatBasics.End_of_format)))
          "Cannot insert variable length element in %s. You should wrap the contents using Data_encoding.dynamic_size."
            % string) name
    | Dynamic | Fixed _ => tt
    end.
  
  Definition check_not_zeroable {A : Type} (name : string) (e : encoding A)
    : unit :=
    if is_zeroable e then
      Stdlib.Printf.ksprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cannot insert potentially zero-sized element in " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "." % char
                CamlinternalFormatBasics.End_of_format)))
          "Cannot insert potentially zero-sized element in %s." % string) name
    else
      tt.
  
  Definition array {A : Type} (max_length : option Z) (e : encoding A)
    : t (array A) :=
    check_not_variable "an array" % string e;
    check_not_zeroable "an array" % string e;
    let encoding :=
      apply
        (let arg := make in
        fun eta => arg None eta) (Array max_length e) in
    match ((classify e), max_length) with
    | (Fixed n, Some max_length) =>
      let limit := Z.mul n max_length in
      apply
        (let arg := make in
        fun eta => arg None eta)
        (Check_size {| limit := limit; encoding := encoding |})
    | (_, _) => encoding
    end.
  
  Definition list {A : Type} (max_length : option Z) (e : encoding A)
    : t (list A) :=
    check_not_variable "a list" % string e;
    check_not_zeroable "a list" % string e;
    let encoding :=
      apply
        (let arg := make in
        fun eta => arg None eta) (List max_length e) in
    match ((classify e), max_length) with
    | (Fixed n, Some max_length) =>
      let limit := Z.mul n max_length in
      apply
        (let arg := make in
        fun eta => arg None eta)
        (Check_size {| limit := limit; encoding := encoding |})
    | (_, _) => encoding
    end.
End Variable.

Definition dynamic_size {A : Type}
  (op_star_o_p_t_star : option Tezos_data_encoding.Binary_size.unsigned_integer)
  : (t A) -> t A :=
  let kind :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end in
  fun e =>
    apply
      (let arg := make in
      fun eta => arg None eta) (Dynamic_size {| kind := kind; encoding := e |}).

Definition check_size {A : Type} (limit : Z) (encoding : t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Check_size {| limit := limit; encoding := encoding |}).

Definition delayed {A : Type} (f : unit -> t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta) (Delayed f).

Definition null : t unit :=
  apply
    (let arg := make in
    fun eta => arg None eta) Null.

Definition empty : t unit :=
  apply
    (let arg := make in
    fun eta => arg None eta) Empty.

Definition unit : t unit :=
  apply
    (let arg := make in
    fun eta => arg None eta) Ignore.

Definition constant (s : string) : t unit :=
  apply
    (let arg := make in
    fun eta => arg None eta) (Constant s).

Definition bool : t bool :=
  apply
    (let arg := make in
    fun eta => arg None eta) Bool.

Definition int8 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int8.

Definition uint8 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Uint8.

Definition int16 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int16.

Definition uint16 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Uint16.

Definition int31 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int31.

Definition int32 : t Stdlib.Int32.t :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int32.

Definition ranged_int (minimum : Z) (maximum : Z) : t Z :=
  let minimum : Z :=
    OCaml.Stdlib.min minimum maximum
  with maximum : Z :=
    OCaml.Stdlib.max minimum maximum in
  if
    orb (OCaml.Stdlib.lt minimum (Z.opp (Z.shiftl 1 30)))
      (OCaml.Stdlib.lt (Z.sub (Z.shiftl 1 30) 1) maximum) then
    OCaml.Stdlib.invalid_arg "Data_encoding.ranged_int" % string
  else
    tt;
  apply
    (let arg := make in
    fun eta => arg None eta)
    (RangedInt {| minimum := minimum; maximum := maximum |}).

Definition ranged_float (minimum : float) (maximum : float) : t float :=
  let minimum : float :=
    OCaml.Stdlib.min minimum maximum
  with maximum : float :=
    OCaml.Stdlib.max minimum maximum in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (RangedFloat {| minimum := minimum; maximum := maximum |}).

Definition int64 : t Stdlib.Int64.t :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int64.

Definition n : t Z.t :=
  apply
    (let arg := make in
    fun eta => arg None eta) N.

Definition z : t Z.t :=
  apply
    (let arg := make in
    fun eta => arg None eta) Z.

Definition float : t float :=
  apply
    (let arg := make in
    fun eta => arg None eta) Float.

Definition string : t string := dynamic_size None Variable.string.

Definition bytes : t Stdlib.Bytes.t := dynamic_size None Variable.bytes.

Definition array {A : Type} (max_length : option Z) (e : encoding A)
  : t (array A) := dynamic_size None (Variable.array max_length e).

Definition list {A : Type} (max_length : option Z) (e : encoding A)
  : t (list A) := dynamic_size None (Variable.list max_length e).

Definition string_enum {A : Type} (function_parameter : list (string * A))
  : t A :=
  match function_parameter with
  | [] =>
    OCaml.Stdlib.invalid_arg
      "data_encoding.string_enum: cannot have zero cases" % string
  | cons _case [] =>
    OCaml.Stdlib.invalid_arg
      "data_encoding.string_enum: cannot have a single case, use constant instead"
        % string
  | (cons _ _) as cases =>
    let arr := Stdlib.Array.of_list (List.map snd cases) in
    let tbl := Stdlib.Hashtbl.create None (Stdlib.Array.length arr) in
    Stdlib.List.iteri
      (fun ind =>
        fun function_parameter =>
          match function_parameter with
          | (str, a) => Stdlib.Hashtbl.add tbl a (str, ind)
          end) cases;
    apply
      (let arg := make in
      fun eta => arg None eta) (String_enum tbl arr)
  end.

Definition conv {A B : Type}
  (proj : A -> B) (inj : B -> A) (schema : option Json_schema.schema)
  (encoding : t B) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Conv {| proj := proj; inj := inj; encoding := encoding; schema := schema |}).

Definition def {A : Type}
  (id : string) (title : option string) (description : option string)
  (encoding : t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Describe
      {| id := id; title := title; description := description;
        encoding := encoding |}).

Definition req {A : Type}
  (title : option string) (description : option string) (n : string) (t : t A)
  : field A :=
  Req {| name := n; encoding := t; title := title; description := description |}.

Definition opt {A : Type}
  (title : option string) (description : option string) (n : string)
  (encoding : t A) : field (option A) :=
  let kind :=
    match classify encoding with
    | Variable => variant
    | Fixed _ | Dynamic => variant
    end in
  Opt
    {| name := n; kind := kind; encoding := encoding; title := title;
      description := description |}.

Definition varopt {A : Type}
  (title : option string) (description : option string) (n : string)
  (encoding : t A) : field (option A) :=
  Opt
    {| name := n; kind := variant; encoding := encoding; title := title;
      description := description |}.

Definition dft {A : Type}
  (title : option string) (description : option string) (n : string) (t : t A)
  (d : A) : field A :=
  Dft
    {| name := n; encoding := t; default := d; title := title;
      description := description |}.

Definition raw_splitted {A : Type}
  (json : Json_encoding.encoding A) (binary : t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Splitted
      {| encoding := binary; json_encoding := json; is_obj := false;
        is_tup := false |}).

Fixpoint is_obj {a : Type} (e : t a) : bool :=
  match encoding e with
  | Obj _ => true
  | Objs _ => true
  | Conv {| encoding := e |} => is_obj e
  | Dynamic_size {| encoding := e |} => is_obj e
  | Union {| cases := cases |} =>
    Stdlib.List.for_all
      (fun function_parameter =>
        match function_parameter with
        | Case {| encoding := e |} => is_obj e
        end) cases
  | Empty => true
  | Ignore => true
  | Mu {| fix := fix |} => is_obj (fix e)
  | Splitted {| is_obj := is_obj |} => is_obj
  | Delayed f => is_obj (f tt)
  | Describe {| encoding := encoding |} => is_obj encoding
  | _ => false
  end.

Fixpoint is_tup {a : Type} (e : t a) : bool :=
  match encoding e with
  | Tup _ => true
  | Tups _ => true
  | Conv {| encoding := e |} => is_tup e
  | Dynamic_size {| encoding := e |} => is_tup e
  | Union {| cases := cases |} =>
    Stdlib.List.for_all
      (fun function_parameter =>
        match function_parameter with
        | Case {| encoding := e |} => is_tup e
        end) cases
  | Mu {| fix := fix |} => is_tup (fix e)
  | Splitted {| is_tup := is_tup |} => is_tup
  | Delayed f => is_tup (f tt)
  | Describe {| encoding := encoding |} => is_tup encoding
  | _ => false
  end.

Definition raw_merge_objs {A B : Type} (left : t A) (right : t B) : t (A * B) :=
  let kind := Kind.combine "objects" % string (classify left) (classify right)
    in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Objs {| kind := kind; left := left; right := right |}).

Definition obj1 {A : Type} (f1 : field A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta) (Obj f1).

Definition obj2 {A B : Type} (f2 : field A) (f1 : field B) : t (A * B) :=
  raw_merge_objs (obj1 f2) (obj1 f1).

Definition obj3 {A B C : Type} (f3 : field A) (f2 : field B) (f1 : field C)
  : t (A * (B * C)) := raw_merge_objs (obj1 f3) (obj2 f2 f1).

Definition obj4 {A B C D : Type}
  (f4 : field A) (f3 : field B) (f2 : field C) (f1 : field D)
  : t ((A * B) * (C * D)) := raw_merge_objs (obj2 f4 f3) (obj2 f2 f1).

Definition obj5 {A B C D E : Type}
  (f5 : field A) (f4 : field B) (f3 : field C) (f2 : field D) (f1 : field E)
  : t (A * ((B * C) * (D * E))) := raw_merge_objs (obj1 f5) (obj4 f4 f3 f2 f1).

Definition obj6 {A B C D E F : Type}
  (f6 : field A) (f5 : field B) (f4 : field C) (f3 : field D) (f2 : field E)
  (f1 : field F) : t ((A * B) * ((C * D) * (E * F))) :=
  raw_merge_objs (obj2 f6 f5) (obj4 f4 f3 f2 f1).

Definition obj7 {A B C D E F G : Type}
  (f7 : field A) (f6 : field B) (f5 : field C) (f4 : field D) (f3 : field E)
  (f2 : field F) (f1 : field G) : t ((A * (B * C)) * ((D * E) * (F * G))) :=
  raw_merge_objs (obj3 f7 f6 f5) (obj4 f4 f3 f2 f1).

Definition obj8 {A B C D E F G H : Type}
  (f8 : field A) (f7 : field B) (f6 : field C) (f5 : field D) (f4 : field E)
  (f3 : field F) (f2 : field G) (f1 : field H)
  : t (((A * B) * (C * D)) * ((E * F) * (G * H))) :=
  raw_merge_objs (obj4 f8 f7 f6 f5) (obj4 f4 f3 f2 f1).

Definition obj9 {A B C D E F G H I : Type}
  (f9 : field A) (f8 : field B) (f7 : field C) (f6 : field D) (f5 : field E)
  (f4 : field F) (f3 : field G) (f2 : field H) (f1 : field I)
  : t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))) :=
  raw_merge_objs (obj1 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1).

Definition obj10 {A B C D E F G H I J : Type}
  (f10 : field A) (f9 : field B) (f8 : field C) (f7 : field D) (f6 : field E)
  (f5 : field F) (f4 : field G) (f3 : field H) (f2 : field I) (f1 : field J)
  : t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))) :=
  raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1).

Definition merge_objs {A B : Type} (o1 : t A) (o2 : t B) : t (A * B) :=
  if andb (is_obj o1) (is_obj o2) then
    raw_merge_objs o1 o2
  else
    OCaml.Stdlib.invalid_arg "Json_encoding.merge_objs" % string.

Definition raw_merge_tups {A B : Type} (left : t A) (right : t B) : t (A * B) :=
  let kind := Kind.combine "tuples" % string (classify left) (classify right) in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Tups {| kind := kind; left := left; right := right |}).

Definition tup1 {A : Type} (e1 : t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta) (Tup e1).

Definition tup2 {A B : Type} (e2 : t A) (e1 : t B) : t (A * B) :=
  raw_merge_tups (tup1 e2) (tup1 e1).

Definition tup3 {A B C : Type} (e3 : t A) (e2 : t B) (e1 : t C)
  : t (A * (B * C)) := raw_merge_tups (tup1 e3) (tup2 e2 e1).

Definition tup4 {A B C D : Type} (e4 : t A) (e3 : t B) (e2 : t C) (e1 : t D)
  : t ((A * B) * (C * D)) := raw_merge_tups (tup2 e4 e3) (tup2 e2 e1).

Definition tup5 {A B C D E : Type}
  (e5 : t A) (e4 : t B) (e3 : t C) (e2 : t D) (e1 : t E)
  : t (A * ((B * C) * (D * E))) := raw_merge_tups (tup1 e5) (tup4 e4 e3 e2 e1).

Definition tup6 {A B C D E F : Type}
  (e6 : t A) (e5 : t B) (e4 : t C) (e3 : t D) (e2 : t E) (e1 : t F)
  : t ((A * B) * ((C * D) * (E * F))) :=
  raw_merge_tups (tup2 e6 e5) (tup4 e4 e3 e2 e1).

Definition tup7 {A B C D E F G : Type}
  (e7 : t A) (e6 : t B) (e5 : t C) (e4 : t D) (e3 : t E) (e2 : t F) (e1 : t G)
  : t ((A * (B * C)) * ((D * E) * (F * G))) :=
  raw_merge_tups (tup3 e7 e6 e5) (tup4 e4 e3 e2 e1).

Definition tup8 {A B C D E F G H : Type}
  (e8 : t A) (e7 : t B) (e6 : t C) (e5 : t D) (e4 : t E) (e3 : t F) (e2 : t G)
  (e1 : t H) : t (((A * B) * (C * D)) * ((E * F) * (G * H))) :=
  raw_merge_tups (tup4 e8 e7 e6 e5) (tup4 e4 e3 e2 e1).

Definition tup9 {A B C D E F G H I : Type}
  (e9 : t A) (e8 : t B) (e7 : t C) (e6 : t D) (e5 : t E) (e4 : t F) (e3 : t G)
  (e2 : t H) (e1 : t I) : t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))) :=
  raw_merge_tups (tup1 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1).

Definition tup10 {A B C D E F G H I J : Type}
  (e10 : t A) (e9 : t B) (e8 : t C) (e7 : t D) (e6 : t E) (e5 : t F) (e4 : t G)
  (e3 : t H) (e2 : t I) (e1 : t J)
  : t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))) :=
  raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1).

Definition merge_tups {A B : Type} (t1 : t A) (t2 : t B) : t (A * B) :=
  if andb (is_tup t1) (is_tup t2) then
    raw_merge_tups t1 t2
  else
    OCaml.Stdlib.invalid_arg "Tezos_serial.Encoding.merge_tups" % string.

Definition conv3 {A B C : Type} (ty : t (A * (B * C))) : t (A * B * C) :=
  conv
    (fun function_parameter =>
      match function_parameter with
      | (c, b, a) => (c, (b, a))
      end)
    (fun function_parameter =>
      match function_parameter with
      | (c, (b, a)) => (c, b, a)
      end) None ty.

Definition obj3 {A B C : Type} (f3 : field A) (f2 : field B) (f1 : field C)
  : t (A * B * C) := conv3 (obj3 f3 f2 f1).

Definition tup3 {A B C : Type} (f3 : t A) (f2 : t B) (f1 : t C)
  : t (A * B * C) := conv3 (tup3 f3 f2 f1).

Definition conv4 {A B C D : Type} (ty : t ((A * B) * (C * D)))
  : t (A * B * C * D) :=
  conv
    (fun function_parameter =>
      match function_parameter with
      | (d, c, b, a) => ((d, c), (b, a))
      end)
    (fun function_parameter =>
      match function_parameter with
      | ((d, c), (b, a)) => (d, c, b, a)
      end) None ty.

Definition obj4 {A B C D : Type}
  (f4 : field A) (f3 : field B) (f2 : field C) (f1 : field D)
  : t (A * B * C * D) := conv4 (obj4 f4 f3 f2 f1).

Definition tup4 {A B C D : Type} (f4 : t A) (f3 : t B) (f2 : t C) (f1 : t D)
  : t (A * B * C * D) := conv4 (tup4 f4 f3 f2 f1).

Definition conv5 {A B C D E : Type} (ty : t (A * ((B * C) * (D * E))))
  : t (A * B * C * D * E) :=
  conv
    (fun function_parameter =>
      match function_parameter with
      | (e, d, c, b, a) => (e, ((d, c), (b, a)))
      end)
    (fun function_parameter =>
      match function_parameter with
      | (e, ((d, c), (b, a))) => (e, d, c, b, a)
      end) None ty.

Definition obj5 {A B C D E : Type}
  (f5 : field A) (f4 : field B) (f3 : field C) (f2 : field D) (f1 : field E)
  : t (A * B * C * D * E) := conv5 (obj5 f5 f4 f3 f2 f1).

Definition tup5 {A B C D E : Type}
  (f5 : t A) (f4 : t B) (f3 : t C) (f2 : t D) (f1 : t E)
  : t (A * B * C * D * E) := conv5 (tup5 f5 f4 f3 f2 f1).

Definition conv6 {A B C D E F : Type} (ty : t ((A * B) * ((C * D) * (E * F))))
  : t (A * B * C * D * E * F) :=
  conv
    (fun function_parameter =>
      match function_parameter with
      | (f, e, d, c, b, a) => ((f, e), ((d, c), (b, a)))
      end)
    (fun function_parameter =>
      match function_parameter with
      | ((f, e), ((d, c), (b, a))) => (f, e, d, c, b, a)
      end) None ty.

Definition obj6 {A B C D E F : Type}
  (f6 : field A) (f5 : field B) (f4 : field C) (f3 : field D) (f2 : field E)
  (f1 : field F) : t (A * B * C * D * E * F) := conv6 (obj6 f6 f5 f4 f3 f2 f1).

Definition tup6 {A B C D E F : Type}
  (f6 : t A) (f5 : t B) (f4 : t C) (f3 : t D) (f2 : t E) (f1 : t F)
  : t (A * B * C * D * E * F) := conv6 (tup6 f6 f5 f4 f3 f2 f1).

Definition conv7 {A B C D E F G : Type}
  (ty : t ((A * (B * C)) * ((D * E) * (F * G))))
  : t (A * B * C * D * E * F * G) :=
  conv
    (fun function_parameter =>
      match function_parameter with
      | (g, f, e, d, c, b, a) => ((g, (f, e)), ((d, c), (b, a)))
      end)
    (fun function_parameter =>
      match function_parameter with
      | ((g, (f, e)), ((d, c), (b, a))) => (g, f, e, d, c, b, a)
      end) None ty.

Definition obj7 {A B C D E F G : Type}
  (f7 : field A) (f6 : field B) (f5 : field C) (f4 : field D) (f3 : field E)
  (f2 : field F) (f1 : field G) : t (A * B * C * D * E * F * G) :=
  conv7 (obj7 f7 f6 f5 f4 f3 f2 f1).

Definition tup7 {A B C D E F G : Type}
  (f7 : t A) (f6 : t B) (f5 : t C) (f4 : t D) (f3 : t E) (f2 : t F) (f1 : t G)
  : t (A * B * C * D * E * F * G) := conv7 (tup7 f7 f6 f5 f4 f3 f2 f1).

Definition conv8 {A B C D E F G H : Type}
  (ty : t (((A * B) * (C * D)) * ((E * F) * (G * H))))
  : t (A * B * C * D * E * F * G * H) :=
  conv
    (fun function_parameter =>
      match function_parameter with
      | (h, g, f, e, d, c, b, a) => (((h, g), (f, e)), ((d, c), (b, a)))
      end)
    (fun function_parameter =>
      match function_parameter with
      | (((h, g), (f, e)), ((d, c), (b, a))) => (h, g, f, e, d, c, b, a)
      end) None ty.

Definition obj8 {A B C D E F G H : Type}
  (f8 : field A) (f7 : field B) (f6 : field C) (f5 : field D) (f4 : field E)
  (f3 : field F) (f2 : field G) (f1 : field H)
  : t (A * B * C * D * E * F * G * H) := conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1).

Definition tup8 {A B C D E F G H : Type}
  (f8 : t A) (f7 : t B) (f6 : t C) (f5 : t D) (f4 : t E) (f3 : t F) (f2 : t G)
  (f1 : t H) : t (A * B * C * D * E * F * G * H) :=
  conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1).

Definition conv9 {A B C D E F G H I : Type}
  (ty : t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))))
  : t (A * B * C * D * E * F * G * H * I) :=
  conv
    (fun function_parameter =>
      match function_parameter with
      | (i, h, g, f, e, d, c, b, a) => (i, (((h, g), (f, e)), ((d, c), (b, a))))
      end)
    (fun function_parameter =>
      match function_parameter with
      | (i, (((h, g), (f, e)), ((d, c), (b, a)))) => (i, h, g, f, e, d, c, b, a)
      end) None ty.

Definition obj9 {A B C D E F G H I : Type}
  (f9 : field A) (f8 : field B) (f7 : field C) (f6 : field D) (f5 : field E)
  (f4 : field F) (f3 : field G) (f2 : field H) (f1 : field I)
  : t (A * B * C * D * E * F * G * H * I) :=
  conv9 (obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1).

Definition tup9 {A B C D E F G H I : Type}
  (f9 : t A) (f8 : t B) (f7 : t C) (f6 : t D) (f5 : t E) (f4 : t F) (f3 : t G)
  (f2 : t H) (f1 : t I) : t (A * B * C * D * E * F * G * H * I) :=
  conv9 (tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1).

Definition conv10 {A B C D E F G H I J : Type}
  (ty : t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))))
  : t (A * B * C * D * E * F * G * H * I * J) :=
  conv
    (fun function_parameter =>
      match function_parameter with
      | (j, i, h, g, f, e, d, c, b, a) =>
        ((j, i), (((h, g), (f, e)), ((d, c), (b, a))))
      end)
    (fun function_parameter =>
      match function_parameter with
      | ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))) =>
        (j, i, h, g, f, e, d, c, b, a)
      end) None ty.

Definition obj10 {A B C D E F G H I J : Type}
  (f10 : field A) (f9 : field B) (f8 : field C) (f7 : field D) (f6 : field E)
  (f5 : field F) (f4 : field G) (f3 : field H) (f2 : field I) (f1 : field J)
  : t (A * B * C * D * E * F * G * H * I * J) :=
  conv10 (obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1).

Definition tup10 {A B C D E F G H I J : Type}
  (f10 : t A) (f9 : t B) (f8 : t C) (f7 : t D) (f6 : t E) (f5 : t F) (f4 : t G)
  (f3 : t H) (f2 : t I) (f1 : t J)
  : t (A * B * C * D * E * F * G * H * I * J) :=
  conv10 (tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1).

Definition check_cases {A : Type} (tag_size : variant) (cases : list (case A))
  : unit :=
  if equiv_decb cases [] then
    OCaml.Stdlib.invalid_arg
      "Data_encoding.union: empty list of cases." % string
  else
    tt;
  let max_tag :=
    match tag_size with
    | Uint8 => 256
    | Uint16 => Z.mul 256 256
    end in
  apply OCaml.Stdlib.ignore
    (Stdlib.List.fold_left
      (fun others =>
        fun function_parameter =>
          match function_parameter with
          | Case {| tag := tag |} =>
            match tag with
            | Json_only => others
            | Tag tag =>
              if Stdlib.List.mem tag others then
                Stdlib.Format.kasprintf OCaml.Stdlib.invalid_arg
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "The tag " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " appears twice in an union." % string
                          CamlinternalFormatBasics.End_of_format)))
                    "The tag %d appears twice in an union." % string) tag
              else
                tt;
              if orb (OCaml.Stdlib.lt tag 0) (OCaml.Stdlib.le max_tag tag) then
                Stdlib.Format.kasprintf OCaml.Stdlib.invalid_arg
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "The tag " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " is invalid." % string
                          CamlinternalFormatBasics.End_of_format)))
                    "The tag %d is invalid." % string) tag
              else
                tt;
              cons tag others
            end
          end) [] cases).

Definition union {A : Type}
  (op_star_o_p_t_star : option Tezos_data_encoding.Binary_size.tag_size)
  : (list (case A)) -> t A :=
  let tag_size :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end in
  fun cases =>
    check_cases tag_size cases;
    let kinds :=
      List.map
        (fun function_parameter =>
          match function_parameter with
          | Case {| encoding := encoding |} => classify encoding
          end) cases in
    let kind := Kind.merge_list tag_size kinds in
    apply
      (let arg := make in
      fun eta => arg None eta)
      (Union {| kind := kind; tag_size := tag_size; cases := cases |}).

Definition case {A B : Type}
  (title : string) (description : option string) (tag : case_tag)
  (encoding : t A) (proj : B -> option A) (inj : A -> B) : case B :=
  Case
    {| title := title; description := description; encoding := encoding;
      proj := proj; inj := inj; tag := tag |}.

Fixpoint is_nullable {t : Type} (e : encoding t) : bool :=
  match encoding e with
  | Null => true
  | Empty => false
  | Ignore => true
  | Constant _ => false
  | Bool => false
  | Int8 => false
  | Uint8 => false
  | Int16 => false
  | Uint16 => false
  | Int31 => false
  | Int32 => false
  | Int64 => false
  | N => false
  | Z => false
  | RangedInt _ => false
  | RangedFloat _ => false
  | Float => false
  | Bytes _ => false
  | String _ => false
  | Padded e _ => is_nullable e
  | String_enum _ _ => false
  | Array _ _ => false
  | List _ _ => false
  | Obj _ => false
  | Objs _ => false
  | Tup _ => false
  | Tups _ => false
  | Union {| cases := cases |} =>
    OCaml.List._exists
      (fun function_parameter =>
        match function_parameter with
        | Case {| encoding := e |} => is_nullable e
        end) cases
  | Mu {| fix := fix |} => is_nullable (fix e)
  | Conv {| encoding := e |} => is_nullable e
  | Describe {| encoding := e |} => is_nullable e
  | Splitted {| json_encoding := json_encoding |} =>
    Json_encoding.is_nullable json_encoding
  | Dynamic_size {| encoding := e |} => is_nullable e
  | Check_size {| encoding := e |} => is_nullable e
  | Delayed _ => true
  end.

Definition option {A : Type} (ty : encoding A) : t (option A) :=
  if is_nullable ty then
    OCaml.Stdlib.invalid_arg
      "Data_encoding.option: cannot nest nullable encodings" % string
  else
    tt;
  union (Some variant)
    (cons (case "Some" % string None (Tag 1) ty (fun x => x) (fun x => Some x))
      (cons
        (case "None" % string None (Tag 0) null
          (fun function_parameter =>
            match function_parameter with
            | None => Some tt
            | Some _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | tt => None
            end)) [])).

Definition mu {A : Type}
  (name : string) (title : option string) (description : option string)
  (fix : (t A) -> t A) : t A :=
  let kind := try in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Mu
      {| kind := kind; name := name; title := title; description := description;
        fix := fix |}).

Definition result {A B : Type} (ok_enc : t A) (error_enc : t B) : t (sum A B) :=
  union (Some variant)
    (cons
      (case "Ok" % string None (Tag 1) ok_enc
        (fun function_parameter =>
          match function_parameter with
          | inl x => Some x
          | inr _ => None
          end) (fun x => inl x))
      (cons
        (case "Result" % string None (Tag 0) error_enc
          (fun function_parameter =>
            match function_parameter with
            | inl _ => None
            | inr x => Some x
            end) (fun x => inr x)) [])).
src/lib_data_encoding/encoding.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Encoding}. *)

module Kind : sig
  type t = [`Fixed of int | `Dynamic | `Variable]

  type length = [`Fixed of int | `Variable]

  type enum = [`Dynamic | `Variable]

  val combine : string -> t -> t -> t

  val merge : t -> t -> t

  val merge_list : Binary_size.tag_size -> t list -> t
end

type case_tag = Tag of int | Json_only

type 'a desc =
  | Null : unit desc
  | Empty : unit desc
  | Ignore : unit desc
  | Constant : string -> unit desc
  | Bool : bool desc
  | Int8 : int desc
  | Uint8 : int desc
  | Int16 : int desc
  | Uint16 : int desc
  | Int31 : int desc
  | Int32 : Int32.t desc
  | Int64 : Int64.t desc
  | N : Z.t desc
  | Z : Z.t desc
  | RangedInt : {minimum : int; maximum : int} -> int desc
  | RangedFloat : {minimum : float; maximum : float} -> float desc
  | Float : float desc
  | Bytes : Kind.length -> Bytes.t desc
  | String : Kind.length -> string desc
  | Padded : 'a t * int -> 'a desc
  | String_enum : ('a, string * int) Hashtbl.t * 'a array -> 'a desc
  | Array : int option * 'a t -> 'a array desc
  | List : int option * 'a t -> 'a list desc
  | Obj : 'a field -> 'a desc
  | Objs : {kind : Kind.t; left : 'a t; right : 'b t} -> ('a * 'b) desc
  | Tup : 'a t -> 'a desc
  | Tups : {kind : Kind.t; left : 'a t; right : 'b t} -> ('a * 'b) desc
  | Union : {
      kind : Kind.t;
      tag_size : Binary_size.tag_size;
      cases : 'a case list;
    }
      -> 'a desc
  | Mu : {
      kind : Kind.enum;
      name : string;
      title : string option;
      description : string option;
      fix : 'a t -> 'a t;
    }
      -> 'a desc
  | Conv : {
      proj : 'a -> 'b;
      inj : 'b -> 'a;
      encoding : 'b t;
      schema : Json_schema.schema option;
    }
      -> 'a desc
  | Describe : {
      id : string;
      title : string option;
      description : string option;
      encoding : 'a t;
    }
      -> 'a desc
  | Splitted : {
      encoding : 'a t;
      json_encoding : 'a Json_encoding.encoding;
      is_obj : bool;
      is_tup : bool;
    }
      -> 'a desc
  | Dynamic_size : {
      kind : Binary_size.unsigned_integer;
      encoding : 'a t;
    }
      -> 'a desc
  | Check_size : {limit : int; encoding : 'a t} -> 'a desc
  | Delayed : (unit -> 'a t) -> 'a desc

and _ field =
  | Req : {
      name : string;
      encoding : 'a t;
      title : string option;
      description : string option;
    }
      -> 'a field
  | Opt : {
      name : string;
      kind : Kind.enum;
      encoding : 'a t;
      title : string option;
      description : string option;
    }
      -> 'a option field
  | Dft : {
      name : string;
      encoding : 'a t;
      default : 'a;
      title : string option;
      description : string option;
    }
      -> 'a field

and 'a case =
  | Case : {
      title : string;
      description : string option;
      encoding : 'a t;
      proj : 't -> 'a option;
      inj : 'a -> 't;
      tag : case_tag;
    }
      -> 't case

and 'a t = {
  encoding : 'a desc;
  mutable json_encoding : 'a Json_encoding.encoding option;
}

type 'a encoding = 'a t

val make : ?json_encoding:'a Json_encoding.encoding -> 'a desc -> 'a t

val null : unit encoding

val empty : unit encoding

val unit : unit encoding

val constant : string -> unit encoding

val int8 : int encoding

val uint8 : int encoding

val int16 : int encoding

val uint16 : int encoding

val int31 : int encoding

val int32 : int32 encoding

val int64 : int64 encoding

val n : Z.t encoding

val z : Z.t encoding

val ranged_int : int -> int -> int encoding

val ranged_float : float -> float -> float encoding

val bool : bool encoding

val string : string encoding

val bytes : Bytes.t encoding

val float : float encoding

val option : 'a encoding -> 'a option encoding

val result : 'a encoding -> 'b encoding -> ('a, 'b) result encoding

val string_enum : (string * 'a) list -> 'a encoding

val is_obj : 'a encoding -> bool

val is_tup : 'a encoding -> bool

module Fixed : sig
  val string : int -> string encoding

  val bytes : int -> Bytes.t encoding

  val add_padding : 'a encoding -> int -> 'a encoding
end

module Variable : sig
  val string : string encoding

  val bytes : Bytes.t encoding

  val array : ?max_length:int -> 'a encoding -> 'a array encoding

  val list : ?max_length:int -> 'a encoding -> 'a list encoding
end

val dynamic_size :
  ?kind:Binary_size.unsigned_integer -> 'a encoding -> 'a encoding

val check_size : int -> 'a encoding -> 'a encoding

val delayed : (unit -> 'a encoding) -> 'a encoding

val req :
  ?title:string -> ?description:string -> string -> 't encoding -> 't field

val opt :
  ?title:string ->
  ?description:string ->
  string ->
  't encoding ->
  't option field

val varopt :
  ?title:string ->
  ?description:string ->
  string ->
  't encoding ->
  't option field

val dft :
  ?title:string ->
  ?description:string ->
  string ->
  't encoding ->
  't ->
  't field

val obj1 : 'f1 field -> 'f1 encoding

val obj2 : 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding

val obj3 : 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding

val obj4 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  ('f1 * 'f2 * 'f3 * 'f4) encoding

val obj5 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding

val obj6 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding

val obj7 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  'f7 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding

val obj8 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  'f7 field ->
  'f8 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding

val obj9 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  'f7 field ->
  'f8 field ->
  'f9 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding

val obj10 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  'f7 field ->
  'f8 field ->
  'f9 field ->
  'f10 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding

val tup1 : 'f1 encoding -> 'f1 encoding

val tup2 : 'f1 encoding -> 'f2 encoding -> ('f1 * 'f2) encoding

val tup3 :
  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> ('f1 * 'f2 * 'f3) encoding

val tup4 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4) encoding

val tup5 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding

val tup6 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding

val tup7 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  'f7 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding

val tup8 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  'f7 encoding ->
  'f8 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding

val tup9 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  'f7 encoding ->
  'f8 encoding ->
  'f9 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding

val tup10 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  'f7 encoding ->
  'f8 encoding ->
  'f9 encoding ->
  'f10 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding

val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding

val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding

val array : ?max_length:int -> 'a encoding -> 'a array encoding

val list : ?max_length:int -> 'a encoding -> 'a list encoding

val case :
  title:string ->
  ?description:string ->
  case_tag ->
  'a encoding ->
  ('t -> 'a option) ->
  ('a -> 't) ->
  't case

val union : ?tag_size:[`Uint8 | `Uint16] -> 't case list -> 't encoding

val def :
  string -> ?title:string -> ?description:string -> 'a encoding -> 'a encoding

val conv :
  ('a -> 'b) ->
  ('b -> 'a) ->
  ?schema:Json_schema.schema ->
  'b encoding ->
  'a encoding

val mu :
  string ->
  ?title:string ->
  ?description:string ->
  ('a encoding -> 'a encoding) ->
  'a encoding

val classify : 'a encoding -> [`Fixed of int | `Dynamic | `Variable]

val classify_desc : 'a desc -> [`Fixed of int | `Dynamic | `Variable]

val raw_splitted :
  json:'a Json_encoding.encoding -> binary:'a encoding -> 'a encoding
src/lib_data_encoding/encoding.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Kind.
  Definition t := variant.
  
  Definition length := variant.
  
  Definition enum := variant.
  
  Parameter combine : string -> t -> t -> t.
  
  Parameter merge : t -> t -> t.
  
  Parameter merge_list : Tezos_data_encoding.Binary_size.tag_size ->
    (list t) -> t.
End Kind.

Inductive case_tag : Type :=
| Tag : Z -> case_tag
| Json_only : case_tag.

Inductive desc : forall (a : Type), Type :=
| Null : desc unit
| Empty : desc unit
| Ignore : desc unit
| Constant : string -> desc unit
| Bool : desc bool
| Int8 : desc Z
| Uint8 : desc Z
| Int16 : desc Z
| Uint16 : desc Z
| Int31 : desc Z
| Int32 : desc Stdlib.Int32.t
| Int64 : desc Stdlib.Int64.t
| N : desc Z.t
| Z : desc Z.t
| RangedInt : Z -> Z -> desc Z
| RangedFloat : float -> float -> desc float
| Float : desc float
| Bytes : Kind.length -> desc Stdlib.Bytes.t
| String : Kind.length -> desc string
| Padded : forall {a : Type}, (t a) -> Z -> desc a
| String_enum : forall {a : Type}, (Stdlib.Hashtbl.t a (string * Z)) ->
  (array a) -> desc a
| Array : forall {a : Type}, (option Z) -> (t a) -> desc (array a)
| List : forall {a : Type}, (option Z) -> (t a) -> desc (list a)
| Obj : forall {a : Type}, (field a) -> desc a
| Objs : forall {a b : Type}, Kind.t -> (t a) -> (t b) -> desc (a * b)
| Tup : forall {a : Type}, (t a) -> desc a
| Tups : forall {a b : Type}, Kind.t -> (t a) -> (t b) -> desc (a * b)
| Union : forall {a : Type}, Kind.t -> Tezos_data_encoding.Binary_size.tag_size
  -> (list (case a)) -> desc a
| Mu : forall {a : Type}, Kind.enum -> string -> (option string) ->
  (option string) -> ((t a) -> t a) -> desc a
| Conv : forall {a b : Type}, (a -> b) -> (b -> a) -> (t b) ->
  (option Json_schema.schema) -> desc a
| Describe : forall {a : Type}, string -> (option string) -> (option string) ->
  (t a) -> desc a
| Splitted : forall {a : Type}, (t a) -> (Json_encoding.encoding a) -> bool ->
  bool -> desc a
| Dynamic_size : forall {a : Type},
  Tezos_data_encoding.Binary_size.unsigned_integer -> (t a) -> desc a
| Check_size : forall {a : Type}, Z -> (t a) -> desc a
| Delayed : forall {a : Type}, (unit -> t a) -> desc a

with field : forall (_ : Type), Type :=
| Req : forall {a : Type}, string -> (t a) -> (option string) -> (option string)
  -> field a
| Opt : forall {a : Type}, string -> Kind.enum -> (t a) -> (option string) ->
  (option string) -> field (option a)
| Dft : forall {a : Type}, string -> (t a) -> a -> (option string) ->
  (option string) -> field a

with case : forall (a : Type), Type :=
| Case : forall {a t : Type}, string -> (option string) -> (t a) ->
  (t -> option a) -> (a -> t) -> case_tag -> case t.

Definition encoding (a : Type) := t a.

Parameter make : forall {a : Type},
(option (Json_encoding.encoding a)) -> (desc a) -> t a.

Parameter null : encoding unit.

Parameter empty : encoding unit.

Parameter unit : encoding unit.

Parameter constant : string -> encoding unit.

Parameter int8 : encoding Z.

Parameter uint8 : encoding Z.

Parameter int16 : encoding Z.

Parameter uint16 : encoding Z.

Parameter int31 : encoding Z.

Parameter int32 : encoding int32.

Parameter int64 : encoding int64.

Parameter n : encoding Z.t.

Parameter z : encoding Z.t.

Parameter ranged_int : Z -> Z -> encoding Z.

Parameter ranged_float : float -> float -> encoding float.

Parameter bool : encoding bool.

Parameter string : encoding string.

Parameter bytes : encoding Stdlib.Bytes.t.

Parameter float : encoding float.

Parameter option : forall {a : Type}, (encoding a) -> encoding (option a).

Parameter result : forall {a b : Type},
(encoding a) -> (encoding b) -> encoding (sum a b).

Parameter string_enum : forall {a : Type}, (list (string * a)) -> encoding a.

Parameter is_obj : forall {a : Type}, (encoding a) -> bool.

Parameter is_tup : forall {a : Type}, (encoding a) -> bool.

Module Fixed.
  Parameter string : Z -> encoding string.
  
  Parameter bytes : Z -> encoding Stdlib.Bytes.t.
  
  Parameter add_padding : forall {a : Type}, (encoding a) -> Z -> encoding a.
End Fixed.

Module Variable.
  Parameter string : encoding string.
  
  Parameter bytes : encoding Stdlib.Bytes.t.
  
  Parameter array : forall {a : Type}, (option Z) ->
    (encoding a) -> encoding (array a).
  
  Parameter list : forall {a : Type}, (option Z) ->
    (encoding a) -> encoding (list a).
End Variable.

Parameter dynamic_size : forall {a : Type},
(option Tezos_data_encoding.Binary_size.unsigned_integer) ->
  (encoding a) -> encoding a.

Parameter check_size : forall {a : Type}, Z -> (encoding a) -> encoding a.

Parameter delayed : forall {a : Type}, (unit -> encoding a) -> encoding a.

Parameter req : forall {t : Type},
(option string) -> (option string) -> string -> (encoding t) -> field t.

Parameter opt : forall {t : Type},
(option string) -> (option string) -> string -> (encoding t) -> field (option t).

Parameter varopt : forall {t : Type},
(option string) -> (option string) -> string -> (encoding t) -> field (option t).

Parameter dft : forall {t : Type},
(option string) -> (option string) -> string -> (encoding t) -> t -> field t.

Parameter obj1 : forall {f1 : Type}, (field f1) -> encoding f1.

Parameter obj2 : forall {f1 f2 : Type},
(field f1) -> (field f2) -> encoding (f1 * f2).

Parameter obj3 : forall {f1 f2 f3 : Type},
(field f1) -> (field f2) -> (field f3) -> encoding (f1 * f2 * f3).

Parameter obj4 : forall {f1 f2 f3 f4 : Type},
(field f1) ->
  (field f2) -> (field f3) -> (field f4) -> encoding (f1 * f2 * f3 * f4).

Parameter obj5 : forall {f1 f2 f3 f4 f5 : Type},
(field f1) ->
  (field f2) ->
    (field f3) -> (field f4) -> (field f5) -> encoding (f1 * f2 * f3 * f4 * f5).

Parameter obj6 : forall {f1 f2 f3 f4 f5 f6 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) -> (field f6) -> encoding (f1 * f2 * f3 * f4 * f5 * f6).

Parameter obj7 : forall {f1 f2 f3 f4 f5 f6 f7 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) ->
          (field f6) ->
            (field f7) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7).

Parameter obj8 : forall {f1 f2 f3 f4 f5 f6 f7 f8 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) ->
          (field f6) ->
            (field f7) ->
              (field f8) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8).

Parameter obj9 : forall {f1 f2 f3 f4 f5 f6 f7 f8 f9 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) ->
          (field f6) ->
            (field f7) ->
              (field f8) ->
                (field f9) ->
                  encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9).

Parameter obj10 : forall {f1 f10 f2 f3 f4 f5 f6 f7 f8 f9 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) ->
          (field f6) ->
            (field f7) ->
              (field f8) ->
                (field f9) ->
                  (field f10) ->
                    encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9 * f10).

Parameter tup1 : forall {f1 : Type}, (encoding f1) -> encoding f1.

Parameter tup2 : forall {f1 f2 : Type},
(encoding f1) -> (encoding f2) -> encoding (f1 * f2).

Parameter tup3 : forall {f1 f2 f3 : Type},
(encoding f1) -> (encoding f2) -> (encoding f3) -> encoding (f1 * f2 * f3).

Parameter tup4 : forall {f1 f2 f3 f4 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) -> (encoding f4) -> encoding (f1 * f2 * f3 * f4).

Parameter tup5 : forall {f1 f2 f3 f4 f5 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) -> (encoding f5) -> encoding (f1 * f2 * f3 * f4 * f5).

Parameter tup6 : forall {f1 f2 f3 f4 f5 f6 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) -> (encoding f6) -> encoding (f1 * f2 * f3 * f4 * f5 * f6).

Parameter tup7 : forall {f1 f2 f3 f4 f5 f6 f7 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) ->
          (encoding f6) ->
            (encoding f7) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7).

Parameter tup8 : forall {f1 f2 f3 f4 f5 f6 f7 f8 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) ->
          (encoding f6) ->
            (encoding f7) ->
              (encoding f8) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8).

Parameter tup9 : forall {f1 f2 f3 f4 f5 f6 f7 f8 f9 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) ->
          (encoding f6) ->
            (encoding f7) ->
              (encoding f8) ->
                (encoding f9) ->
                  encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9).

Parameter tup10 : forall {f1 f10 f2 f3 f4 f5 f6 f7 f8 f9 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) ->
          (encoding f6) ->
            (encoding f7) ->
              (encoding f8) ->
                (encoding f9) ->
                  (encoding f10) ->
                    encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9 * f10).

Parameter merge_objs : forall {o1 o2 : Type},
(encoding o1) -> (encoding o2) -> encoding (o1 * o2).

Parameter merge_tups : forall {a1 a2 : Type},
(encoding a1) -> (encoding a2) -> encoding (a1 * a2).

Parameter array : forall {a : Type},
(option Z) -> (encoding a) -> encoding (array a).

Parameter list : forall {a : Type},
(option Z) -> (encoding a) -> encoding (list a).

Parameter case : forall {a t : Type},
string ->
  (option string) ->
    case_tag -> (encoding a) -> (t -> option a) -> (a -> t) -> case t.

Parameter union : forall {t variant : Type},
(option variant) -> (list (case t)) -> encoding t.

Parameter def : forall {a : Type},
string -> (option string) -> (option string) -> (encoding a) -> encoding a.

Parameter conv : forall {a b : Type},
(a -> b) ->
  (b -> a) -> (option Json_schema.schema) -> (encoding b) -> encoding a.

Parameter mu : forall {a : Type},
string ->
  (option string) ->
    (option string) -> ((encoding a) -> encoding a) -> encoding a.

Parameter classify : forall {a variant : Type}, (encoding a) -> variant.

Parameter classify_desc : forall {a variant : Type}, (desc a) -> variant.

Parameter raw_splitted : forall {a : Type},
(Json_encoding.encoding a) -> (encoding a) -> encoding a.
src/lib_data_encoding/json.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type json =
  [ `O of (string * json) list
  | `Bool of bool
  | `Float of float
  | `A of json list
  | `Null
  | `String of string ]

type schema = Json_schema.schema

type pair_builder = {
  build :
    'a 'b. Encoding.Kind.t -> 'a Encoding.t -> 'b Encoding.t ->
    ('a * 'b) Encoding.t;
}

exception Parse_error of string

let wrap_error f str =
  try f str with exn -> raise (Json_encoding.Cannot_destruct ([], exn))

let int64_encoding =
  let open Json_encoding in
  def
    "int64"
    ~title:"64 bit integers"
    ~description:"Decimal representation of 64 bit integers"
  @@ conv Int64.to_string (wrap_error Int64.of_string) string

let n_encoding =
  let open Json_encoding in
  def
    "positive_bignum"
    ~title:"Positive big number"
    ~description:"Decimal representation of a positive big number"
  @@ conv
       (fun z ->
         if Z.sign z < 0 then invalid_arg "negative natural" ;
         Z.to_string z)
       (fun s ->
         let n = Z.of_string s in
         if Z.sign n < 0 then
           raise
             (Json_encoding.Cannot_destruct ([], Failure "negative natural")) ;
         n)
       string

let z_encoding =
  let open Json_encoding in
  def
    "bignum"
    ~title:"Big number"
    ~description:"Decimal representation of a big number"
  @@ conv Z.to_string Z.of_string string

let bytes_jsont =
  let open Json_encoding in
  let schema =
    let open Json_schema in
    create
      {
        title = None;
        description = None;
        default = None;
        enum = None;
        kind =
          String
            {
              pattern = Some "^[a-zA-Z0-9]+$";
              min_length = 0;
              max_length = None;
            };
        format = None;
        id = None;
      }
  in
  conv
    ~schema
    Hex.of_bytes
    (wrap_error Hex.to_bytes)
    (conv (fun (`Hex h) -> h) (fun h -> `Hex h) string)

let check_utf8 s =
  Uutf.String.fold_utf_8
    (fun valid _pos -> function `Uchar _ -> valid | `Malformed _ -> false)
    true
    s

let raw_string_encoding =
  let open Json_encoding in
  let utf8_case =
    case string (fun s -> if check_utf8 s then Some s else None) (fun s -> s)
  in
  let obj_case =
    case
      (obj1
         (req
            "invalid_utf8_string"
            (array (ranged_int ~minimum:0 ~maximum:255 "byte"))))
      (fun s -> Some (Array.init (String.length s) (fun i -> Char.code s.[i])))
      (fun a -> String.init (Array.length a) (fun i -> Char.chr a.(i)))
  in
  def
    "unistring"
    ~title:"Universal string representation"
    ~description:
      "Either a plain UTF8 string, or a sequence of bytes for strings that \
       contain invalid byte sequences."
    (union [utf8_case; obj_case])

let rec lift_union : type a. a Encoding.t -> a Encoding.t =
 fun e ->
  let open Encoding in
  match e.encoding with
  | Conv {proj; inj; encoding = e; schema} -> (
    match lift_union e with
    | {encoding = Union {kind; tag_size; cases}; _} ->
        make
        @@ Union
             {
               kind;
               tag_size;
               cases =
                 List.map
                   (fun (Case
                          { title;
                            description;
                            encoding;
                            proj = proj';
                            inj = inj';
                            tag }) ->
                     Case
                       {
                         encoding;
                         title;
                         description;
                         proj = (fun x -> proj' (proj x));
                         inj = (fun x -> inj (inj' x));
                         tag;
                       })
                   cases;
             }
    | e ->
        make @@ Conv {proj; inj; encoding = e; schema} )
  | Objs {kind; left; right} ->
      lift_union_in_pair
        {build = (fun kind left right -> make @@ Objs {kind; left; right})}
        kind
        left
        right
  | Tups {kind; left; right} ->
      lift_union_in_pair
        {build = (fun kind left right -> make @@ Tups {kind; left; right})}
        kind
        left
        right
  | _ ->
      e

and lift_union_in_pair :
    type a b.
    pair_builder ->
    Encoding.Kind.t ->
    a Encoding.t ->
    b Encoding.t ->
    (a * b) Encoding.t =
 fun b p e1 e2 ->
  let open Encoding in
  match (lift_union e1, lift_union e2) with
  | (e1, {encoding = Union {tag_size; cases; _}; _}) ->
      make
      @@ Union
           {
             kind = `Dynamic (* ignored *);
             tag_size;
             cases =
               List.map
                 (fun (Case
                        {title; description; encoding = e2; proj; inj; tag}) ->
                   Case
                     {
                       encoding = lift_union_in_pair b p e1 e2;
                       title;
                       description;
                       proj =
                         (fun (x, y) ->
                           match proj y with
                           | None ->
                               None
                           | Some y ->
                               Some (x, y));
                       inj = (fun (x, y) -> (x, inj y));
                       tag;
                     })
                 cases;
           }
  | ({encoding = Union {tag_size; cases; _}; _}, e2) ->
      make
      @@ Union
           {
             kind = `Dynamic (* ignored *);
             tag_size;
             cases =
               List.map
                 (fun (Case
                        {title; description; encoding = e1; proj; inj; tag}) ->
                   Case
                     {
                       encoding = lift_union_in_pair b p e1 e2;
                       title;
                       description;
                       proj =
                         (fun (x, y) ->
                           match proj x with
                           | None ->
                               None
                           | Some x ->
                               Some (x, y));
                       inj = (fun (x, y) -> (inj x, y));
                       tag;
                     })
                 cases;
           }
  | (e1, e2) ->
      b.build p e1 e2

let rec json : type a. a Encoding.desc -> a Json_encoding.encoding =
  let open Encoding in
  let open Json_encoding in
  function
  | Null ->
      null
  | Empty ->
      empty
  | Constant s ->
      constant s
  | Ignore ->
      unit
  | Int8 ->
      ranged_int ~minimum:~-(1 lsl 7) ~maximum:((1 lsl 7) - 1) "int8"
  | Uint8 ->
      ranged_int ~minimum:0 ~maximum:((1 lsl 8) - 1) "uint8"
  | Int16 ->
      ranged_int ~minimum:~-(1 lsl 15) ~maximum:((1 lsl 15) - 1) "int16"
  | Uint16 ->
      ranged_int ~minimum:0 ~maximum:((1 lsl 16) - 1) "uint16"
  | RangedInt {minimum; maximum} ->
      ranged_int ~minimum ~maximum "rangedInt"
  | Int31 ->
      int
  | Int32 ->
      int32
  | Int64 ->
      int64_encoding
  | N ->
      n_encoding
  | Z ->
      z_encoding
  | Bool ->
      bool
  | Float ->
      float
  | RangedFloat {minimum; maximum} ->
      ranged_float ~minimum ~maximum "rangedFloat"
  | String (`Fixed expected) ->
      let check s =
        let found = String.length s in
        if found <> expected then
          raise
            (Cannot_destruct
               ( [],
                 Unexpected
                   ( Format.asprintf "string (len %d)" found,
                     Format.asprintf "string (len %d)" expected ) )) ;
        s
      in
      conv check check raw_string_encoding
  | String _ ->
      raw_string_encoding
  | Padded (e, _) ->
      get_json e
  | Bytes (`Fixed expected) ->
      let check s =
        let found = Bytes.length s in
        if found <> expected then
          raise
            (Cannot_destruct
               ( [],
                 Unexpected
                   ( Format.asprintf "string (len %d)" found,
                     Format.asprintf "string (len %d)" expected ) )) ;
        s
      in
      conv check check bytes_jsont
  | Bytes _ ->
      bytes_jsont
  | String_enum (tbl, _) ->
      string_enum (Hashtbl.fold (fun a (str, _) acc -> (str, a) :: acc) tbl [])
  | Array (_, e) ->
      array (get_json e) (* FIXME TODO enforce max_length *)
  | List (_, e) ->
      list (get_json e)
  | Obj f ->
      obj1 (field_json f)
  | Objs {left; right; _} ->
      merge_objs (get_json left) (get_json right)
  | Tup e ->
      tup1 (get_json e)
  | Tups {left; right; _} ->
      merge_tups (get_json left) (get_json right)
  | Conv {proj; inj; encoding = e; schema} ->
      conv ?schema proj inj (get_json e)
  | Describe {id; title; description; encoding = e} ->
      def id ?title ?description (get_json e)
  | Mu {name; fix; _} as ty ->
      mu name (fun json_encoding -> get_json @@ fix (make ~json_encoding ty))
  | Union {cases; _} ->
      union (List.map case_json cases)
  | Splitted {json_encoding; _} ->
      json_encoding
  | Dynamic_size {encoding = e; _} ->
      get_json e
  | Check_size {encoding; _} ->
      get_json encoding
  | Delayed f ->
      get_json (f ())

and field_json : type a. a Encoding.field -> a Json_encoding.field =
  let open Json_encoding in
  function
  | Encoding.Req {name; encoding = e; _} ->
      req name (get_json e)
  | Encoding.Opt {name; encoding = e; _} ->
      opt name (get_json e)
  | Encoding.Dft {name; encoding = e; default = d; _} ->
      dft name (get_json e) d

and case_json : type a. a Encoding.case -> a Json_encoding.case =
  let open Json_encoding in
  function
  | Encoding.Case {encoding = e; proj; inj; _} -> case (get_json e) proj inj

and get_json : type a. a Encoding.t -> a Json_encoding.encoding =
 fun e ->
  match e.json_encoding with
  | None ->
      let json_encoding = json (lift_union e).encoding in
      e.json_encoding <- Some json_encoding ;
      json_encoding
  | Some json_encoding ->
      json_encoding

let convert = get_json

type path = path_item list

and path_item =
  [ `Field of string  (** A field in an object. *)
  | `Index of int  (** An index in an array. *)
  | `Star  (** Any / every field or index. *)
  | `Next  (** The next element after an array. *) ]

include Json_encoding

let construct e v = construct (get_json e) v

let destruct e v = destruct (get_json e) v

let schema ?definitions_path e = schema ?definitions_path (get_json e)

let cannot_destruct fmt =
  Format.kasprintf (fun msg -> raise (Cannot_destruct ([], Failure msg))) fmt

type t = json

let to_string ?(newline = false) ?minify j =
  Format.asprintf
    "%a%s"
    Json_repr.(pp ?compact:minify (module Ezjsonm))
    j
    (if newline then "\n" else "")

let pp = Json_repr.(pp (module Ezjsonm))

let from_string s =
  match Ezjsonm.from_string ("[" ^ s ^ "]") with
  | exception Ezjsonm.Parse_error (_, msg) ->
      Error msg
  | `A [json] ->
      Ok json
  | _ ->
      Error "Malformed value"

let from_stream (stream : string Lwt_stream.t) =
  let buffer = ref "" in
  Lwt_stream.filter_map
    (fun str ->
      buffer := !buffer ^ str ;
      try
        let json = Ezjsonm.from_string !buffer in
        buffer := "" ;
        Some (Ok json)
      with Ezjsonm.Parse_error _ -> None)
    stream

let encoding =
  let binary : Json_repr.ezjsonm Encoding.t =
    Encoding.conv
      (fun json ->
        Json_repr.convert
          (module Json_repr.Ezjsonm)
          (module Json_repr_bson.Repr)
          json
        |> Json_repr_bson.bson_to_bytes |> Bytes.to_string)
      (fun s ->
        try
          Bytes.of_string s
          |> Json_repr_bson.bytes_to_bson ~copy:false
          |> Json_repr.convert
               (module Json_repr_bson.Repr)
               (module Json_repr.Ezjsonm)
        with Json_repr_bson.Bson_decoding_error (msg, _, _) ->
          raise (Parse_error msg))
      Encoding.string
  in
  let json = Json_encoding.any_ezjson_value in
  Encoding.raw_splitted ~binary ~json

let schema_encoding =
  Encoding.conv Json_schema.to_json Json_schema.of_json encoding
src/lib_data_encoding/json.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition json := variant.

Definition schema := Json_schema.schema.

Record pair_builder := {
  build :
    (Tezos_data_encoding.Encoding.Kind.t ->
      (Tezos_data_encoding.Encoding.t a) ->
        (Tezos_data_encoding.Encoding.t b) ->
          Tezos_data_encoding.Encoding.t (a * b)) * (a * b) }.

Definition wrap_error {A B : Type} (f : A -> B) (str : A) : B := try.

Definition int64_encoding : Json_encoding.encoding int64 :=
  apply
    (Json_encoding.def "int64" % string (Some "64 bit integers" % string)
      (Some "Decimal representation of 64 bit integers" % string))
    (Json_encoding.conv Stdlib.Int64.to_string
      (wrap_error Stdlib.Int64.of_string) None Json_encoding.string).

Definition n_encoding : Json_encoding.encoding Z.t :=
  apply
    (Json_encoding.def "positive_bignum" % string
      (Some "Positive big number" % string)
      (Some "Decimal representation of a positive big number" % string))
    (Json_encoding.conv
      (fun z =>
        if OCaml.Stdlib.lt (Z.sign z) 0 then
          OCaml.Stdlib.invalid_arg "negative natural" % string
        else
          tt;
        Z.to_string z)
      (fun s =>
        let n := Z.of_string s in
        if OCaml.Stdlib.lt (Z.sign n) 0 then
          Stdlib.raise
            (Json_encoding.Cannot_destruct
              ([], (OCaml.Failure "negative natural" % string)))
        else
          tt;
        n) None Json_encoding.string).

Definition z_encoding : Json_encoding.encoding Z.t :=
  apply
    (Json_encoding.def "bignum" % string (Some "Big number" % string)
      (Some "Decimal representation of a big number" % string))
    (Json_encoding.conv Z.to_string Z.of_string None Json_encoding.string).

Definition bytes_jsont : Json_encoding.encoding string :=
  let schema :=
    Json_schema.create
      {| title := None; description := None; default := None; enum := None;
        kind :=
          String
            {| pattern := Some "^[a-zA-Z0-9]+$" % string; min_length := 0;
              max_length := None |}; format := None; id := None |} in
  Json_encoding.conv
    (let arg := Hex.of_bytes in
    fun eta => arg None eta) (wrap_error Hex.to_bytes) (Some schema)
    (Json_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | Hex h => h
        end) (fun h => variant) None Json_encoding.string).

Definition check_utf8 (s : string) : bool :=
  Uutf.String.fold_utf_8 None None
    (fun valid =>
      fun _pos =>
        fun function_parameter =>
          match function_parameter with
          | Uchar _ => valid
          | Malformed _ => false
          end) true s.

Definition raw_string_encoding : Json_encoding.encoding string :=
  let utf8_case :=
    Json_encoding.case Json_encoding.string
      (fun s =>
        if check_utf8 s then
          Some s
        else
          None) (fun s => s) in
  let obj_case :=
    Json_encoding.case
      (Json_encoding.obj1
        (Json_encoding.req None None "invalid_utf8_string" % string
          (Json_encoding.array (Json_encoding.ranged_int 0 255 "byte" % string))))
      (fun s =>
        Some
          (Stdlib.Array.init (OCaml.String.length s)
            (fun i => Stdlib.Char.code (Stdlib.String.get s i))))
      (fun a =>
        Stdlib.String.init (Stdlib.Array.length a)
          (fun i => Stdlib.Char.chr (Stdlib.Array.get a i))) in
  Json_encoding.def "unistring" % string
    (Some "Universal string representation" % string)
    (Some
      "Either a plain UTF8 string, or a sequence of bytes for strings that contain invalid byte sequences."
        % string) (Json_encoding.union (cons utf8_case (cons obj_case []))).

Fixpoint lift_union {a : Type} (e : Tezos_data_encoding.Encoding.t a)
  : Tezos_data_encoding.Encoding.t a :=
  match encoding e with
  | Conv {| proj := proj; inj := inj; encoding := e; schema := schema |} =>
    match lift_union e with
    | {|
      encoding := Union {| kind := kind; tag_size := tag_size; cases := cases |}
        |} =>
      apply
        (let arg := Tezos_data_encoding.Encoding.make in
        fun eta => arg None eta)
        (Union
          {| kind := kind; tag_size := tag_size;
            cases :=
              List.map
                (fun function_parameter =>
                  match function_parameter with
                  |
                    Case {|
                      title := title;
                        description := description;
                        encoding := encoding;
                        proj := proj';
                        inj := inj';
                        tag := tag
                        |} =>
                    Case
                      {| title := title; description := description;
                        encoding := encoding; proj := fun x => proj' (proj x);
                        inj := fun x => inj (inj' x); tag := tag |}
                  end) cases |})
    | e =>
      apply
        (let arg := Tezos_data_encoding.Encoding.make in
        fun eta => arg None eta)
        (Conv {| proj := proj; inj := inj; encoding := e; schema := schema |})
    end
  | Objs {| kind := kind; left := left; right := right |} =>
    lift_union_in_pair
      {|
        build :=
          fun kind =>
            fun left =>
              fun right =>
                apply
                  (let arg := Tezos_data_encoding.Encoding.make in
                  fun eta => arg None eta)
                  (Objs {| kind := kind; left := left; right := right |}) |}
      kind left right
  | Tups {| kind := kind; left := left; right := right |} =>
    lift_union_in_pair
      {|
        build :=
          fun kind =>
            fun left =>
              fun right =>
                apply
                  (let arg := Tezos_data_encoding.Encoding.make in
                  fun eta => arg None eta)
                  (Tups {| kind := kind; left := left; right := right |}) |}
      kind left right
  | _ => e
  end

with lift_union_in_pair {a b : Type}
  (b : pair_builder) (p : Tezos_data_encoding.Encoding.Kind.t)
  (e1 : Tezos_data_encoding.Encoding.t a)
  (e2 : Tezos_data_encoding.Encoding.t b)
  : Tezos_data_encoding.Encoding.t (a * b) :=
  match ((lift_union e1), (lift_union e2)) with
  | (e1, {| encoding := Union {| tag_size := tag_size; cases := cases |} |}) =>
    apply
      (let arg := Tezos_data_encoding.Encoding.make in
      fun eta => arg None eta)
      (Union
        {| kind := variant; tag_size := tag_size;
          cases :=
            List.map
              (fun function_parameter =>
                match function_parameter with
                |
                  Case {|
                    title := title;
                      description := description;
                      encoding := e2;
                      proj := proj;
                      inj := inj;
                      tag := tag
                      |} =>
                  Case
                    {| title := title; description := description;
                      encoding := lift_union_in_pair b p e1 e2;
                      proj :=
                        fun function_parameter =>
                          match function_parameter with
                          | (x, y) =>
                            match proj y with
                            | None => None
                            | Some y => Some (x, y)
                            end
                          end;
                      inj :=
                        fun function_parameter =>
                          match function_parameter with
                          | (x, y) => (x, (inj y))
                          end; tag := tag |}
                end) cases |})
  | ({| encoding := Union {| tag_size := tag_size; cases := cases |} |}, e2) =>
    apply
      (let arg := Tezos_data_encoding.Encoding.make in
      fun eta => arg None eta)
      (Union
        {| kind := variant; tag_size := tag_size;
          cases :=
            List.map
              (fun function_parameter =>
                match function_parameter with
                |
                  Case {|
                    title := title;
                      description := description;
                      encoding := e1;
                      proj := proj;
                      inj := inj;
                      tag := tag
                      |} =>
                  Case
                    {| title := title; description := description;
                      encoding := lift_union_in_pair b p e1 e2;
                      proj :=
                        fun function_parameter =>
                          match function_parameter with
                          | (x, y) =>
                            match proj x with
                            | None => None
                            | Some x => Some (x, y)
                            end
                          end;
                      inj :=
                        fun function_parameter =>
                          match function_parameter with
                          | (x, y) => ((inj x), y)
                          end; tag := tag |}
                end) cases |})
  | (e1, e2) => (build b) p e1 e2
  end.

Fixpoint json {a : Type}
  (function_parameter : Tezos_data_encoding.Encoding.desc a)
  : Json_encoding.encoding a :=
  match function_parameter with
  | Null => Json_encoding.null
  | Empty => Json_encoding.empty
  | Constant s => Json_encoding.constant s
  | Ignore => Json_encoding.unit
  | Int8 =>
    Json_encoding.ranged_int (Z.opp (Z.shiftl 1 7)) (Z.sub (Z.shiftl 1 7) 1)
      "int8" % string
  | Uint8 =>
    Json_encoding.ranged_int 0 (Z.sub (Z.shiftl 1 8) 1) "uint8" % string
  | Int16 =>
    Json_encoding.ranged_int (Z.opp (Z.shiftl 1 15)) (Z.sub (Z.shiftl 1 15) 1)
      "int16" % string
  | Uint16 =>
    Json_encoding.ranged_int 0 (Z.sub (Z.shiftl 1 16) 1) "uint16" % string
  | RangedInt {| minimum := minimum; maximum := maximum |} =>
    Json_encoding.ranged_int minimum maximum "rangedInt" % string
  | Int31 => Json_encoding.int
  | Int32 => Json_encoding.int32
  | Int64 => int64_encoding
  | N => n_encoding
  | Z => z_encoding
  | Bool => Json_encoding.bool
  | Float => Json_encoding.float
  | RangedFloat {| minimum := minimum; maximum := maximum |} =>
    Json_encoding.ranged_float minimum maximum "rangedFloat" % string
  | String (Fixed expected) =>
    let check (s : string) : string :=
      let found := OCaml.String.length s in
      if nequiv_decb found expected then
        Stdlib.raise
          (Cannot_destruct
            ([],
              (Unexpected
                (Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "string (len " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))
                    "string (len %d)" % string) found)
                (Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "string (len " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))
                    "string (len %d)" % string) expected))))
      else
        tt;
      s in
    Json_encoding.conv check check None raw_string_encoding
  | String _ => raw_string_encoding
  | Padded e _ => get_json e
  | Bytes (Fixed expected) =>
    let check (s : string) : string :=
      let found := String.length s in
      if nequiv_decb found expected then
        Stdlib.raise
          (Cannot_destruct
            ([],
              (Unexpected
                (Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "string (len " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))
                    "string (len %d)" % string) found)
                (Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "string (len " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))
                    "string (len %d)" % string) expected))))
      else
        tt;
      s in
    Json_encoding.conv check check None bytes_jsont
  | Bytes _ => bytes_jsont
  | String_enum tbl _ =>
    Json_encoding.string_enum
      (Stdlib.Hashtbl.fold
        (fun a =>
          fun function_parameter =>
            match function_parameter with
            | (str, _) => fun acc => cons (str, a) acc
            end) tbl [])
  | Array _ e => Json_encoding.array (get_json e)
  | List _ e => Json_encoding.list (get_json e)
  | Obj f => Json_encoding.obj1 (field_json f)
  | Objs {| left := left; right := right |} =>
    Json_encoding.merge_objs (get_json left) (get_json right)
  | Tup e => Json_encoding.tup1 (get_json e)
  | Tups {| left := left; right := right |} =>
    Json_encoding.merge_tups (get_json left) (get_json right)
  | Conv {| proj := proj; inj := inj; encoding := e; schema := schema |} =>
    Json_encoding.conv proj inj schema (get_json e)
  |
    Describe {|
      id := id; title := title; description := description; encoding := e |}
    => Json_encoding.def id title description (get_json e)
  | (Mu {| name := name; fix := fix |}) as ty =>
    Json_encoding.mu name None None
      (fun json_encoding =>
        apply get_json
          (fix (Tezos_data_encoding.Encoding.make (Some json_encoding) ty)))
  | Union {| cases := cases |} => Json_encoding.union (List.map case_json cases)
  | Splitted {| json_encoding := json_encoding |} => json_encoding
  | Dynamic_size {| encoding := e |} => get_json e
  | Check_size {| encoding := encoding |} => get_json encoding
  | Delayed f => get_json (f tt)
  end

with field_json {a : Type}
  (function_parameter : Tezos_data_encoding.Encoding.field a)
  : Json_encoding.field a :=
  match function_parameter with
  | Encoding.Req {| name := name; encoding := e |} =>
    Json_encoding.req None None name (get_json e)
  | Encoding.Opt {| name := name; encoding := e |} =>
    Json_encoding.opt None None name (get_json e)
  | Encoding.Dft {| name := name; encoding := e; default := d |} =>
    Json_encoding.dft None None name (get_json e) d
  end

with case_json {a : Type}
  (function_parameter : Tezos_data_encoding.Encoding.case a)
  : Json_encoding.case a :=
  match function_parameter with
  | Encoding.Case {| encoding := e; proj := proj; inj := inj |} =>
    Json_encoding.case (get_json e) proj inj
  end

with get_json {a : Type} (e : Tezos_data_encoding.Encoding.t a)
  : Json_encoding.encoding a :=
  match json_encoding e with
  | None =>
    let json_encoding := json (encoding (lift_union e)) in
    set_field;
    json_encoding
  | Some json_encoding => json_encoding
  end.

Definition convert {A : Type}
  : (Tezos_data_encoding.Encoding.t A) -> Json_encoding.encoding A := get_json.

Reserved Notation "'path".
Reserved Notation "'path_item".



where "'path" := ( list 'path_item)

and "'path_item" := ( variant).

Definition path := 'path.
Definition path_item := 'path_item.

Definition construct {A : Type} (e : Tezos_data_encoding.Encoding.t A) (v : A)
  : Json_repr.ezjsonm := construct (get_json e) v.

Definition destruct {A : Type}
  (e : Tezos_data_encoding.Encoding.t A) (v : Json_repr.ezjsonm) : A :=
  destruct (get_json e) v.

Definition schema {A : Type}
  (definitions_path : option string) (e : Tezos_data_encoding.Encoding.t A)
  : Json_schema.schema := schema definitions_path (get_json e).

Definition cannot_destruct {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Stdlib.Format.kasprintf
    (fun msg => Stdlib.raise (Cannot_destruct ([], (OCaml.Failure msg)))) fmt.

Definition t := json.

Definition to_string (op_star_o_p_t_star : option bool)
  : (option bool) -> Json_repr.Ezjsonm.(Json_repr.Repr.value) -> string :=
  let newline :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun minify =>
    fun j =>
      Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)) "%a%s" % string)
        (Json_repr.pp minify None Json_repr.Ezjsonm) j
        (if newline then
          "
" % string
        else
          "" % string).

Definition pp
  : Stdlib.Format.formatter -> Json_repr.Ezjsonm.(Json_repr.Repr.value) -> unit :=
  Json_repr.pp None None Json_repr.Ezjsonm.

Definition from_string (s : string) : sum Ezjsonm.value string :=
  match
    Ezjsonm.from_string
      (String.append "[" % string (String.append s "]" % string)) with
  | A (cons json []) => inl json
  | _ => inr "Malformed value" % string
  end.

Definition from_stream {A : Type} (stream : Lwt_stream.t string)
  : Lwt_stream.t (sum variant A) :=
  let buffer := Stdlib.ref "" % string in
  Lwt_stream.filter_map
    (fun str =>
      Stdlib.op_colon_eq buffer
        (String.append (Stdlib.op_exclamation buffer) str);
      try) stream.

Definition encoding : Tezos_data_encoding.Encoding.encoding Json_repr.ezjsonm :=
  let binary :=
    Tezos_data_encoding.Encoding.conv
      (fun json =>
        OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (Json_repr.convert Json_repr.Ezjsonm Json_repr_bson.Repr json)
            (let arg := Json_repr_bson.bson_to_bytes in
            fun eta => arg None None eta)) Stdlib.Bytes.to_string)
      (fun s => try) None Tezos_data_encoding.Encoding.string in
  let json := Json_encoding.any_ezjson_value in
  Tezos_data_encoding.Encoding.raw_splitted json binary.

Definition schema_encoding
  : Tezos_data_encoding.Encoding.encoding Json_schema.schema :=
  Tezos_data_encoding.Encoding.conv Json_schema.to_json Json_schema.of_json None
    encoding.
src/lib_data_encoding/json.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Json}. *)

type json =
  [ `O of (string * json) list
  | `Bool of bool
  | `Float of float
  | `A of json list
  | `Null
  | `String of string ]

type t = json

type schema = Json_schema.schema

val convert : 'a Encoding.t -> 'a Json_encoding.encoding

val schema : ?definitions_path:string -> 'a Encoding.t -> schema

val encoding : json Encoding.t

val schema_encoding : schema Encoding.t

val construct : 't Encoding.t -> 't -> json

val destruct : 't Encoding.t -> json -> 't

type path = path_item list

and path_item = [`Field of string | `Index of int | `Star | `Next]

exception Cannot_destruct of (path * exn)

exception Unexpected of string * string

exception No_case_matched of exn list

exception Bad_array_size of int * int

exception Missing_field of string

exception Unexpected_field of string

val print_error :
  ?print_unknown:(Format.formatter -> exn -> unit) ->
  Format.formatter ->
  exn ->
  unit

val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a

val wrap_error : ('a -> 'b) -> 'a -> 'b

val from_string : string -> (json, string) result

val from_stream : string Lwt_stream.t -> (json, string) result Lwt_stream.t

val to_string : ?newline:bool -> ?minify:bool -> json -> string

val pp : Format.formatter -> json -> unit

val bytes_jsont : Bytes.t Json_encoding.encoding
src/lib_data_encoding/json.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition json := variant.

Definition t := json.

Definition schema := Json_schema.schema.

Parameter convert : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> Json_encoding.encoding a.

Parameter schema : forall {a : Type},
(option string) -> (Tezos_data_encoding.Encoding.t a) -> schema.

Parameter encoding : Tezos_data_encoding.Encoding.t json.

Parameter schema_encoding : Tezos_data_encoding.Encoding.t schema.

Parameter construct : forall {t : Type},
(Tezos_data_encoding.Encoding.t t) -> t -> json.

Parameter destruct : forall {t : Type},
(Tezos_data_encoding.Encoding.t t) -> json -> t.

Reserved Notation "'path".
Reserved Notation "'path_item".



where "'path" := ( list 'path_item)

and "'path_item" := ( variant).

Definition path := 'path.
Definition path_item := 'path_item.

exception

exception

exception

exception

exception

exception

Parameter print_error :
(option (Stdlib.Format.formatter -> exn -> unit)) ->
  Stdlib.Format.formatter -> exn -> unit.

Parameter cannot_destruct : forall {a b : Type},
(Stdlib.format4 a Stdlib.Format.formatter unit b) -> a.

Parameter wrap_error : forall {a b : Type}, (a -> b) -> a -> b.

Parameter from_string : string -> sum json string.

Parameter from_stream : (Lwt_stream.t string) -> Lwt_stream.t (sum json string).

Parameter to_string : (option bool) -> (option bool) -> json -> string.

Parameter pp : Stdlib.Format.formatter -> json -> unit.

Parameter bytes_jsont : Json_encoding.encoding Stdlib.Bytes.t.
src/lib_data_encoding/registration.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type id = string

type t =
  | Record : {
      encoding : 'a Encoding.t;
      description : string option;
      pp : (Format.formatter -> 'a -> unit) option;
    }
      -> t

module EncodingTable = Map.Make (String)

let table = ref EncodingTable.empty

let description (Record {description; _}) = description

let json_schema (Record {encoding; _}) =
  let json_schema = Json.schema encoding in
  json_schema

let binary_schema (Record {encoding; _}) =
  let binary_schema = Binary_description.describe encoding in
  binary_schema

let json_pretty_printer (Record {encoding; pp; _}) fmt json =
  match pp with
  | Some pp ->
      let json = Json.destruct encoding json in
      Format.fprintf fmt "%a" pp json
  | None ->
      Format.fprintf fmt "%a" Json.pp json

let binary_pretty_printer (Record {encoding; pp; _}) fmt bytes =
  let data = Binary_reader.of_bytes_exn encoding bytes in
  match pp with
  | Some pp ->
      Format.fprintf fmt "%a" pp data
  | None ->
      let json = Json.construct encoding data in
      Format.fprintf fmt "%a" Json.pp json

let rec lookup_id_descr ({encoding; _} : 'a Encoding.t) =
  match encoding with
  | Splitted {encoding; _}
  | Dynamic_size {encoding; _}
  | Check_size {encoding; _} ->
      lookup_id_descr encoding
  | Describe {id; description; _} ->
      Some (id, description)
  | _ ->
      None

let register ?pp encoding =
  match lookup_id_descr encoding with
  | None ->
      invalid_arg "Data_encoding.Registration.register: non def(in)ed encoding"
  | Some (id, description) ->
      table :=
        EncodingTable.update
          id
          (function
            | None ->
                let record = Record {encoding; description; pp} in
                Some record
            | Some _ ->
                Format.kasprintf
                  Pervasives.invalid_arg
                  "Encoding %s previously registered"
                  id)
          !table

let find id = EncodingTable.find_opt id !table

let list () = EncodingTable.bindings !table

let bytes_of_json (Record {encoding; _}) json =
  let data = Json.destruct encoding json in
  Binary_writer.to_bytes encoding data

let json_of_bytes (Record {encoding; _}) bytes =
  match Binary_reader.of_bytes encoding bytes with
  | Some v ->
      Some (Json.construct encoding v)
  | None ->
      None
src/lib_data_encoding/registration.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition id := string.

Inductive t : Type :=
| Record : forall {a : Type}, (Tezos_data_encoding.Encoding.t a) ->
  (option string) -> (option (Stdlib.Format.formatter -> a -> unit)) -> t.

Definition table : Stdlib.ref (EncodingTable.t t) :=
  Stdlib.ref EncodingTable.empty.

Definition description (function_parameter : t) : option string :=
  match function_parameter with
  | Record {| description := description |} => description
  end.

Definition json_schema (function_parameter : t)
  : Tezos_data_encoding.Json.schema :=
  match function_parameter with
  | Record {| encoding := encoding |} =>
    let json_schema := Tezos_data_encoding.Json.schema None encoding in
    json_schema
  end.

Definition binary_schema (function_parameter : t)
  : Tezos_data_encoding.Binary_schema.t :=
  match function_parameter with
  | Record {| encoding := encoding |} =>
    let binary_schema :=
      Tezos_data_encoding.Binary_description.describe encoding in
    binary_schema
  end.

Definition json_pretty_printer (function_parameter : t)
  : Stdlib.Format.formatter -> Tezos_data_encoding.Json.json -> unit :=
  match function_parameter with
  | Record {| encoding := encoding; pp := pp |} =>
    fun fmt =>
      fun json =>
        match pp with
        | Some pp =>
          let json := Tezos_data_encoding.Json.destruct encoding json in
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string) pp json
        | None =>
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Tezos_data_encoding.Json.pp json
        end
  end.

Definition binary_pretty_printer (function_parameter : t)
  : Stdlib.Format.formatter -> Stdlib.Bytes.t -> unit :=
  match function_parameter with
  | Record {| encoding := encoding; pp := pp |} =>
    fun fmt =>
      fun bytes =>
        let data :=
          Tezos_data_encoding.Binary_reader.of_bytes_exn encoding string in
        match pp with
        | Some pp =>
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string) pp data
        | None =>
          let json := Tezos_data_encoding.Json.construct encoding data in
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Tezos_data_encoding.Json.pp json
        end
  end.

Fixpoint lookup_id_descr {a : Type}
  (function_parameter : Tezos_data_encoding.Encoding.t a)
  : option (string * (option string)) :=
  match function_parameter with
  | {| encoding := encoding |} =>
    match encoding with
    |
      Splitted {| encoding := encoding |} |
        Dynamic_size {| encoding := encoding |} |
        Check_size {| encoding := encoding |} => lookup_id_descr encoding
    | Describe {| id := id; description := description |} =>
      Some (id, description)
    | _ => None
    end
  end.

Definition register {A : Type}
  (pp : option (Stdlib.Format.formatter -> A -> unit))
  (encoding : Tezos_data_encoding.Encoding.t A) : unit :=
  match lookup_id_descr encoding with
  | None =>
    OCaml.Stdlib.invalid_arg
      "Data_encoding.Registration.register: non def(in)ed encoding" % string
  | Some (id, description) =>
    Stdlib.op_colon_eq table
      (EncodingTable.update id
        (fun function_parameter =>
          match function_parameter with
          | None =>
            let record :=
              Record
                {| encoding := encoding; description := description; pp := pp |}
              in
            Some record
          | Some _ =>
            Stdlib.Format.kasprintf Stdlib.Pervasives.invalid_arg
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Encoding " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " previously registered" % string
                      CamlinternalFormatBasics.End_of_format)))
                "Encoding %s previously registered" % string) id
          end) (Stdlib.op_exclamation table))
  end.

Definition find (id : EncodingTable.key) : option t :=
  EncodingTable.find_opt id (Stdlib.op_exclamation table).

Definition list (function_parameter : unit) : list (EncodingTable.key * t) :=
  match function_parameter with
  | tt => EncodingTable.bindings (Stdlib.op_exclamation table)
  end.

Definition bytes_of_json (function_parameter : t)
  : Tezos_data_encoding.Json.json -> option Stdlib.Bytes.t :=
  match function_parameter with
  | Record {| encoding := encoding |} =>
    fun json =>
      let data := Tezos_data_encoding.Json.destruct encoding json in
      Tezos_data_encoding.Binary_writer.to_bytes encoding data
  end.

Definition json_of_bytes (function_parameter : t)
  : Stdlib.Bytes.t -> option Tezos_data_encoding.Json.json :=
  match function_parameter with
  | Record {| encoding := encoding |} =>
    fun bytes =>
      match Tezos_data_encoding.Binary_reader.of_bytes encoding string with
      | Some v => Some (Tezos_data_encoding.Json.construct encoding v)
      | None => None
      end
  end.
src/lib_data_encoding/registration.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Encoding}. *)

type id = string

type t

val binary_schema : t -> Binary_schema.t

val json_schema : t -> Json.schema

val description : t -> string option

val json_pretty_printer : t -> Format.formatter -> Json.t -> unit

val binary_pretty_printer : t -> Format.formatter -> Bytes.t -> unit

val register : ?pp:(Format.formatter -> 'a -> unit) -> 'a Encoding.t -> unit

val find : id -> t option

val list : unit -> (id * t) list

val bytes_of_json : t -> Json.t -> Bytes.t option

val json_of_bytes : t -> Bytes.t -> Json.t option
src/lib_data_encoding/registration.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition id := string.

Parameter t : Type.

Parameter binary_schema : t -> Tezos_data_encoding.Binary_schema.t.

Parameter json_schema : t -> Tezos_data_encoding.Json.schema.

Parameter description : t -> option string.

Parameter json_pretty_printer :
t -> Stdlib.Format.formatter -> Tezos_data_encoding.Json.t -> unit.

Parameter binary_pretty_printer :
t -> Stdlib.Format.formatter -> Stdlib.Bytes.t -> unit.

Parameter register : forall {a : Type},
(option (Stdlib.Format.formatter -> a -> unit)) ->
  (Tezos_data_encoding.Encoding.t a) -> unit.

Parameter find : id -> option t.

Parameter list : unit -> list (id * t).

Parameter bytes_of_json :
t -> Tezos_data_encoding.Json.t -> option Stdlib.Bytes.t.

Parameter json_of_bytes :
t -> Stdlib.Bytes.t -> option Tezos_data_encoding.Json.t.
src/lib_data_encoding/test/bench_data_encoding.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let bench ?(num_iterations = 1000) name thunk =
  Gc.full_major () ;
  Gc.compact () ;
  let start_time = Sys.time () in
  for _i = 0 to num_iterations - 1 do
    thunk ()
  done ;
  let end_time = Sys.time () in
  Format.printf
    "Benchmark: %s took %f for %d iterations.@."
    name
    (end_time -. start_time)
    num_iterations

let read_stream encoding bytes =
  let rec loop bytes status =
    match (bytes, status) with
    | ([], Data_encoding.Binary.Success _) ->
        ()
    | (bytes :: bytess, Await f) ->
        loop bytess (f bytes)
    | (_, _) ->
        assert false
  in
  loop bytes (Data_encoding.Binary.read_stream encoding)

let bench_all ?(num_iterations = 1000) name encoding value =
  bench
    ~num_iterations
    ("writing " ^ name ^ " json")
    (fun () ->
      ignore @@ Data_encoding.Json.to_string
      @@ Data_encoding.Json.construct encoding value) ;
  bench
    ~num_iterations
    ("writing " ^ name ^ " binary")
    (fun () -> ignore @@ Data_encoding.Binary.to_bytes_exn encoding value) ;
  let encoded_json =
    Data_encoding.Json.to_string @@ Data_encoding.Json.construct encoding value
  in
  bench
    ~num_iterations
    ("reading " ^ name ^ " json")
    (fun () ->
      ignore
        (Data_encoding.Json.destruct
           encoding
           (Ezjsonm.from_string encoded_json))) ;
  let encoded_binary = Data_encoding.Binary.to_bytes_exn encoding value in
  bench
    ~num_iterations
    ("reading " ^ name ^ " binary")
    (fun () -> ignore @@ Data_encoding.Binary.of_bytes encoding encoded_binary) ;
  bench
    ~num_iterations
    ("reading " ^ name ^ " streamed binary (one chunk)")
    (fun () -> read_stream encoding [encoded_binary]) ;
  bench
    ~num_iterations
    ("reading " ^ name ^ " streamed binary (small chunks)")
    (fun () -> read_stream encoding (Helpers.cut 1 encoded_binary)) ;
  ()

type t = A of string | B of bool | I of int | F of float | R of t * t

let cases_encoding : t Data_encoding.t =
  let open Data_encoding in
  mu "recursive" (fun recursive ->
      union
        [ case
            (Tag 0)
            ~title:"A"
            string
            (function A s -> Some s | _ -> None)
            (fun s -> A s);
          case
            (Tag 1)
            ~title:"B"
            bool
            (function B bool -> Some bool | _ -> None)
            (fun bool -> B bool);
          case
            (Tag 2)
            ~title:"I"
            int31
            (function I int -> Some int | _ -> None)
            (fun int -> I int);
          case
            (Tag 3)
            ~title:"F"
            float
            (function F float -> Some float | _ -> None)
            (fun float -> F float);
          case
            (Tag 4)
            ~title:"R"
            (obj2 (req "field1" recursive) (req "field2" recursive))
            (function R (a, b) -> Some (a, b) | _ -> None)
            (fun (a, b) -> R (a, b)) ])

let () =
  bench_all
    "10000_element_int_list"
    Data_encoding.(list int31)
    ~num_iterations:1000
    (Array.to_list (Array.make 10000 0)) ;
  bench_all
    "option_element_int_list"
    Data_encoding.(list (option int31))
    (Array.to_list (Array.make 10000 (Some 0))) ;
  let encoding = Data_encoding.(list (result (option int31) string)) in
  let value = Array.to_list (Array.make 10000 (Error "hello")) in
  bench_all "option_result_element_list" encoding value ;
  let encoding = Data_encoding.(list cases_encoding) in
  let value =
    Array.to_list (Array.make 1000 (R (R (A "asdf", B true), F 1.0)))
  in
  bench ~num_iterations:1000 "binary_encoding" (fun () ->
      ignore @@ Data_encoding.Binary.to_bytes encoding value) ;
  bench_all
    "binary_encoding_large_list"
    Data_encoding.(list cases_encoding)
    (Array.to_list (Array.make 2000 (R (R (A "asdf", B true), F 1.0))))
src/lib_data_encoding/test/bench_data_encoding.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition bench (op_star_o_p_t_star : option Z)
  : string -> (unit -> unit) -> unit :=
  let num_iterations :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 1000
    end in
  fun name =>
    fun thunk =>
      Stdlib.Gc.full_major tt;
      Stdlib.Gc.compact tt;
      let start_time := Stdlib.Sys.time tt in
      for;
      let end_time := Stdlib.Sys.time tt in
      Stdlib.Format.printf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Benchmark: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal " took " % string
                (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal " for " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        " iterations." % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))))))
          "Benchmark: %s took %f for %d iterations.@." % string) name
        (Stdlib.op_minus_point end_time start_time) num_iterations.

Definition read_stream {A : Type}
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (bytes : list Stdlib.Bytes.t) : unit :=
  let fix loop {B : Type}
    (bytes : list Stdlib.Bytes.t) (status :
    Tezos_data_encoding.Data_encoding.Binary.status B) : unit :=
    match (string, status) with
    | ([], Data_encoding.Binary.Success _) => tt
    | (cons bytes bytess, Await f) => loop bytess (f string)
    | (_, _) => false
    end in
  loop string
    (Tezos_data_encoding.Data_encoding.Binary.read_stream None encoding).

Definition bench_all {A : Type} (op_star_o_p_t_star : option Z)
  : string -> (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit :=
  let num_iterations :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 1000
    end in
  fun name =>
    fun encoding =>
      fun value =>
        bench (Some num_iterations)
          (String.append "writing " % string
            (String.append name " json" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              apply OCaml.Stdlib.ignore
                (apply
                  (let arg := Tezos_data_encoding.Data_encoding.Json.to_string
                    in
                  fun eta => arg None None eta)
                  (Tezos_data_encoding.Data_encoding.Json.construct encoding
                    value))
            end);
        bench (Some num_iterations)
          (String.append "writing " % string
            (String.append name " binary" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              apply OCaml.Stdlib.ignore
                (Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn encoding
                  value)
            end);
        let encoded_json :=
          apply
            (let arg := Tezos_data_encoding.Data_encoding.Json.to_string in
            fun eta => arg None None eta)
            (Tezos_data_encoding.Data_encoding.Json.construct encoding value) in
        bench (Some num_iterations)
          (String.append "reading " % string
            (String.append name " json" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              OCaml.Stdlib.ignore
                (Tezos_data_encoding.Data_encoding.Json.destruct encoding
                  (Ezjsonm.from_string encoded_json))
            end);
        let encoded_binary :=
          Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn encoding value
          in
        bench (Some num_iterations)
          (String.append "reading " % string
            (String.append name " binary" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              apply OCaml.Stdlib.ignore
                (Tezos_data_encoding.Data_encoding.Binary.of_bytes encoding
                  encoded_binary)
            end);
        bench (Some num_iterations)
          (String.append "reading " % string
            (String.append name " streamed binary (one chunk)" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt => read_stream encoding (cons encoded_binary [])
            end);
        bench (Some num_iterations)
          (String.append "reading " % string
            (String.append name " streamed binary (small chunks)" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              read_stream encoding
                (op_star_t_y_p_e_minus_e_r_r_o_r_star 1 encoded_binary)
            end);
        tt.

Inductive t : Type :=
| A : string -> t
| B : bool -> t
| I : Z -> t
| F : float -> t
| R : t -> t -> t.

Definition cases_encoding : Tezos_data_encoding.Data_encoding.t t :=
  Tezos_data_encoding.Data_encoding.mu "recursive" % string None None
    (fun recursive =>
      Tezos_data_encoding.Data_encoding.union None
        (cons
          (Tezos_data_encoding.Data_encoding.case "A" % string None (Tag 0)
            Tezos_data_encoding.Data_encoding.string
            (fun function_parameter =>
              match function_parameter with
              | A s => Some s
              | _ => None
              end) (fun s => A s))
          (cons
            (Tezos_data_encoding.Data_encoding.case "B" % string None (Tag 1)
              Tezos_data_encoding.Data_encoding.bool
              (fun function_parameter =>
                match function_parameter with
                | B bool => Some bool
                | _ => None
                end) (fun bool => B bool))
            (cons
              (Tezos_data_encoding.Data_encoding.case "I" % string None (Tag 2)
                Tezos_data_encoding.Data_encoding.int31
                (fun function_parameter =>
                  match function_parameter with
                  | I int => Some Z
                  | _ => None
                  end) (fun int => I Z))
              (cons
                (Tezos_data_encoding.Data_encoding.case "F" % string None
                  (Tag 3) Tezos_data_encoding.Data_encoding.float
                  (fun function_parameter =>
                    match function_parameter with
                    | F float => Some float
                    | _ => None
                    end) (fun float => F float))
                (cons
                  (Tezos_data_encoding.Data_encoding.case "R" % string None
                    (Tag 4)
                    (Tezos_data_encoding.Data_encoding.obj2
                      (Tezos_data_encoding.Data_encoding.req None None
                        "field1" % string recursive)
                      (Tezos_data_encoding.Data_encoding.req None None
                        "field2" % string recursive))
                    (fun function_parameter =>
                      match function_parameter with
                      | R a b => Some (a, b)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | (a, b) => R a b
                      end)) [])))))).
src/lib_data_encoding/test/helpers.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

let cut ?(copy = false) sz bytes =
  let length = Bytes.length bytes in
  if length <= sz then [bytes] (* if the result fits in the given sz *)
  else
    let may_copy = if copy then Bytes.copy else fun t -> t in
    let nb_full = length / sz in
    (* nb of blocks of size sz *)
    let sz_full = nb_full * sz in
    (* size of the full part *)
    let acc =
      (* eventually init acc with a non-full block *)
      if sz_full = length then []
      else [may_copy (Bytes.sub bytes sz_full (length - sz_full))]
    in
    let rec split_full_blocks curr_upper_limit acc =
      let start = curr_upper_limit - sz in
      assert (start >= 0) ;
      (* copy the block [ start, curr_upper_limit [ of size sz *)
      let acc = may_copy (Bytes.sub bytes start sz) :: acc in
      if start = 0 then acc else split_full_blocks start acc
    in
    split_full_blocks sz_full acc

let no_exception f =
  try f () with
  | ( Json_encoding.Cannot_destruct _
    | Json_encoding.Unexpected _
    | Json_encoding.No_case_matched _
    | Json_encoding.Bad_array_size _
    | Json_encoding.Missing_field _
    | Json_encoding.Unexpected_field _
    | Json_encoding.Bad_schema _ ) as exn ->
      Alcotest.failf
        "@[v 2>json failed:@ %a@]"
        (fun ppf -> Json_encoding.print_error ppf)
        exn
  | Binary.Read_error error ->
      Alcotest.failf
        "@[v 2>bytes reading failed:@ %a@]"
        Binary.pp_read_error
        error
  | Binary.Write_error error ->
      Alcotest.failf
        "@[v 2>bytes writing failed:@ %a@]"
        Binary.pp_write_error
        error

let check_raises expected f =
  match f () with
  | exception exn when expected exn ->
      ()
  | exception exn ->
      Alcotest.failf "Unexpected exception: %s." (Printexc.to_string exn)
  | _ ->
      Alcotest.failf "Expecting exception, got success."

let chunked_read sz encoding bytes =
  let status =
    List.fold_left
      (fun status chunk ->
        match status with
        | Binary.Await f ->
            f chunk
        | Success _ when Bytes.length chunk <> 0 ->
            Error Extra_bytes
        | Success _ | Error _ ->
            status)
      (Binary.read_stream encoding)
      (cut sz bytes)
  in
  match status with
  | Success {stream; _} when not (Binary_stream.is_empty stream) ->
      Binary.Error Extra_bytes
  | _ ->
      status

let streamed_read encoding bytes =
  List.fold_left
    (fun ((status, count) as acc) chunk ->
      match status with
      | Binary.Await f ->
          (f chunk, succ count)
      | Success _ | Error _ ->
          acc)
    (Binary.read_stream encoding, 0)
    (cut 1 bytes)
src/lib_data_encoding/test/helpers.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Data_encoding.

Definition cut (op_star_o_p_t_star : option bool)
  : Z -> string -> list string :=
  let copy :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun sz =>
    fun bytes =>
      let length := String.length string in
      if OCaml.Stdlib.le length sz then
        cons string []
      else
        let may_copy :=
          if copy then
            Stdlib.Bytes.copy
          else
            fun t => t in
        let nb_full := Z.div length sz in
        let sz_full := Z.mul nb_full sz in
        let acc :=
          if equiv_decb sz_full length then
            []
          else
            cons (may_copy (String.sub string sz_full (Z.sub length sz_full)))
              [] in
        let fix split_full_blocks (curr_upper_limit : Z) (acc : list string)
          : list string :=
          let start := Z.sub curr_upper_limit sz in
          OCaml.Stdlib.ge start 0;
          let acc := cons (may_copy (String.sub string start sz)) acc in
          if equiv_decb start 0 then
            acc
          else
            split_full_blocks start acc in
        split_full_blocks sz_full acc.

Definition no_exception {A : Type} (f : unit -> A) : A := try.

Definition check_raises {A : Type} (expected : exn -> bool) (f : unit -> A)
  : unit :=
  match f tt with
  | _ =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      "Expecting exception, got success." % string
  end.

Definition chunked_read {A : Type}
  (sz : Z) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (bytes : Stdlib.Bytes.t)
  : Tezos_data_encoding.Data_encoding.Binary.status A :=
  let status :=
    Stdlib.List.fold_left
      (fun status =>
        fun chunk =>
          match status with
          | Binary.Await f => f chunk
          | Success _ | inr _ => status
          end)
      (Tezos_data_encoding.Data_encoding.Binary.read_stream None encoding)
      (cut None sz string) in
  match status with
  | _ => status
  end.

Definition streamed_read {A : Type}
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (bytes : Stdlib.Bytes.t)
  : (Tezos_data_encoding.Data_encoding.Binary.status A) * Z :=
  Stdlib.List.fold_left
    (fun function_parameter =>
      match function_parameter with
      | (status, count) as acc =>
        fun chunk =>
          match status with
          | Binary.Await f => ((f chunk), (Z.succ count))
          | Success _ | inr _ => acc
          end
      end)
    ((Tezos_data_encoding.Data_encoding.Binary.read_stream None encoding), 0)
    (cut None 1 string).
src/lib_data_encoding/test/invalid_encoding.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding
open Helpers

let test ?(expected = fun _ -> true) name f =
  (name, `Quick, fun () -> check_raises expected f)

let tests =
  [ test "multi_variable_tup" (fun () -> tup2 Variable.string Variable.string);
    test "variable_in_list" (fun () -> list Variable.string);
    test "nested_option" (fun () -> option (option int8));
    test "merge_non_objs" (fun () -> merge_objs int8 string);
    test "empty_union" (fun () -> union []);
    test "duplicated_tag" (fun () ->
        union
          [ case (Tag 0) ~title:"" empty (fun () -> None) (fun () -> ());
            case (Tag 0) ~title:"" empty (fun () -> None) (fun () -> ()) ]);
    test "fixed_negative_size" (fun () -> Fixed.string ~-1);
    test "fixed_null_size" (fun () -> Fixed.bytes 0);
    test "array_null_size" (fun () -> Variable.list empty);
    test "list_null_size" (fun () -> Variable.list null);
    test "zeroable_in_list" (fun () -> list (obj1 (varopt "x" int8))) ]
src/lib_data_encoding/test/invalid_encoding.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Data_encoding.

Definition test {A B C D : Type} (op_star_o_p_t_star : option (A -> bool))
  : B -> C -> B * variant * (unit -> D) :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun name =>
    fun f =>
      (name, variant,
        (fun function_parameter =>
          match function_parameter with
          | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star expected f
          end)).

Definition tests {A : Type} : list (string * variant * (unit -> A)) :=
  cons
    (test None "multi_variable_tup" % string
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_data_encoding.Data_encoding.tup2
            Tezos_data_encoding.Data_encoding.Variable.string
            Tezos_data_encoding.Data_encoding.Variable.string
        end))
    (cons
      (test None "variable_in_list" % string
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_data_encoding.Data_encoding.list None
              Tezos_data_encoding.Data_encoding.Variable.string
          end))
      (cons
        (test None "nested_option" % string
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_data_encoding.Data_encoding.option
                (Tezos_data_encoding.Data_encoding.option
                  Tezos_data_encoding.Data_encoding.int8)
            end))
        (cons
          (test None "merge_non_objs" % string
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_data_encoding.Data_encoding.merge_objs
                  Tezos_data_encoding.Data_encoding.int8
                  Tezos_data_encoding.Data_encoding.string
              end))
          (cons
            (test None "empty_union" % string
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_data_encoding.Data_encoding.union None []
                end))
            (cons
              (test None "duplicated_tag" % string
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_data_encoding.Data_encoding.union None
                      (cons
                        (Tezos_data_encoding.Data_encoding.case "" % string None
                          (Tag 0) Tezos_data_encoding.Data_encoding.empty
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => None
                            end)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => tt
                            end))
                        (cons
                          (Tezos_data_encoding.Data_encoding.case "" % string
                            None (Tag 0) Tezos_data_encoding.Data_encoding.empty
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => None
                              end)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => tt
                              end)) []))
                  end))
              (cons
                (test None "fixed_negative_size" % string
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_data_encoding.Data_encoding.Fixed.string (Z.opp 1)
                    end))
                (cons
                  (test None "fixed_null_size" % string
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_data_encoding.Data_encoding.Fixed.bytes 0
                      end))
                  (cons
                    (test None "array_null_size" % string
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_data_encoding.Data_encoding.Variable.list None
                            Tezos_data_encoding.Data_encoding.empty
                        end))
                    (cons
                      (test None "list_null_size" % string
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_data_encoding.Data_encoding.Variable.list None
                              Tezos_data_encoding.Data_encoding.null
                          end))
                      (cons
                        (test None "zeroable_in_list" % string
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_data_encoding.Data_encoding.list None
                                (Tezos_data_encoding.Data_encoding.obj1
                                  (Tezos_data_encoding.Data_encoding.varopt None
                                    None "x" % string
                                    Tezos_data_encoding.Data_encoding.int8))
                            end)) [])))))))))).
src/lib_data_encoding/test/randomized.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Various randomly generated data. *)

open Data_encoding

(** Generate encodings of the encoding and the randomized generator *)
let test_generator ?(iterations = 50) ty encoding generator =
  for _ = 0 to iterations - 1 do
    let value = generator () in
    Success.json ty encoding value () ;
    Success.bson ty encoding value () ;
    Success.binary ty encoding value () ;
    Success.stream ty encoding value ()
  done

let rec make_int_list acc len () =
  if len = 0 then acc
  else make_int_list (Random.int64 Int64.max_int :: acc) (len - 1) ()

let test_randomized_int_list () =
  test_generator Alcotest.(list int64) (list int64) (make_int_list [] 100)

let test_randomized_string_list () =
  test_generator
    Alcotest.(list string)
    (list string)
    (fun () -> List.map Int64.to_string (make_int_list [] 20 ()))

let test_randomized_variant_list () =
  test_generator
    Alcotest.(list (result (option string) string))
    (list (result (option string) (obj1 (req "failure" string))))
    (fun () ->
      List.map
        (fun x ->
          let str = Int64.to_string x in
          if Random.bool () then
            if Random.bool () then Ok (Some str) else Ok None
          else Error str)
        (make_int_list [] 20 ()))

let tests =
  [ ("int_list", `Quick, test_randomized_int_list);
    ("string_list", `Quick, test_randomized_string_list);
    ("variant_list", `Quick, test_randomized_variant_list) ]
src/lib_data_encoding/test/randomized.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Data_encoding.

Definition test_generator {A B C : Type} (op_star_o_p_t_star : option Z)
  : A -> B -> (unit -> C) -> unit :=
  let iterations :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 50
    end in
  fun ty => fun encoding => fun generator => for.

Fixpoint make_int_list
  (acc : list Stdlib.Int64.t) (len : Z) (function_parameter : unit)
  : list Stdlib.Int64.t :=
  match function_parameter with
  | tt =>
    if equiv_decb len 0 then
      acc
    else
      make_int_list (cons (Stdlib.Random.int64 Stdlib.Int64.max_int) acc)
        (Z.sub len 1) tt
  end.

Definition test_randomized_int_list (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    test_generator None op_star_t_y_p_e_minus_e_r_r_o_r_star
      (Tezos_data_encoding.Data_encoding.list None
        Tezos_data_encoding.Data_encoding.int64) (make_int_list [] 100)
  end.

Definition test_randomized_string_list (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    test_generator None op_star_t_y_p_e_minus_e_r_r_o_r_star
      (Tezos_data_encoding.Data_encoding.list None
        Tezos_data_encoding.Data_encoding.string)
      (fun function_parameter =>
        match function_parameter with
        | tt => List.map Stdlib.Int64.to_string (make_int_list [] 20 tt)
        end)
  end.

Definition test_randomized_variant_list (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    test_generator None op_star_t_y_p_e_minus_e_r_r_o_r_star
      (Tezos_data_encoding.Data_encoding.list None
        (Tezos_data_encoding.Data_encoding.result
          (Tezos_data_encoding.Data_encoding.option
            Tezos_data_encoding.Data_encoding.string)
          (Tezos_data_encoding.Data_encoding.obj1
            (Tezos_data_encoding.Data_encoding.req None None "failure" % string
              Tezos_data_encoding.Data_encoding.string))))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          List.map
            (fun x =>
              let str := Stdlib.Int64.to_string x in
              if Stdlib.Random.bool tt then
                if Stdlib.Random.bool tt then
                  inl (Some str)
                else
                  inl None
              else
                inr str) (make_int_list [] 20 tt)
        end)
  end.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons ("int_list" % string, variant, test_randomized_int_list)
    (cons ("string_list" % string, variant, test_randomized_string_list)
      (cons ("variant_list" % string, variant, test_randomized_variant_list) [])).
src/lib_data_encoding/test/read_failure.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Test expected errors while deserializing data. *)

open Data_encoding
open Helpers
open Types

let not_enough_data = function
  | Binary.Read_error Not_enough_data ->
      true
  | _ ->
      false

let extra_bytes = function Binary.Read_error Extra_bytes -> true | _ -> false

let trailing_zero = function
  | Binary.Read_error Trailing_zero ->
      true
  | _ ->
      false

let invalid_int = function
  | Binary.Read_error (Invalid_int _) ->
      true
  | Json_encoding.Cannot_destruct ([], Failure _) ->
      true
  | _ ->
      false

let invalid_string_length = function
  | Json_encoding.Cannot_destruct
      ([], Json_encoding.Unexpected ("string (len 9)", "string (len 4)")) ->
      true
  | Json_encoding.Cannot_destruct
      ([], Json_encoding.Unexpected ("bytes (len 9)", "bytes (len 4)")) ->
      true
  | Binary.Read_error Extra_bytes ->
      true
  | _ ->
      false

let missing_case = function
  | Json_encoding.Cannot_destruct ([], Json_encoding.No_case_matched _) ->
      true
  | Binary.Read_error (Unexpected_tag _) ->
      true
  | _ ->
      false

let missing_enum = function
  | Json_encoding.Cannot_destruct ([], Json_encoding.Unexpected _) ->
      true
  | Binary.Read_error No_case_matched ->
      true
  | _ ->
      false

let json ?(expected = fun _ -> true) read_encoding json () =
  check_raises expected (fun () -> ignore (Json.destruct read_encoding json))

let bson ?(expected = fun _ -> true) read_encoding bson () =
  check_raises expected (fun () -> ignore (Bson.destruct read_encoding bson))

let binary ?(expected = fun _ -> true) read_encoding bytes () =
  check_raises expected (fun () ->
      ignore (Binary.of_bytes_exn read_encoding bytes))

let stream ?(expected = fun _ -> true) read_encoding bytes () =
  let len_data = Bytes.length bytes in
  for sz = 1 to max 1 len_data do
    let name = Format.asprintf "stream (%d)" sz in
    match chunked_read sz read_encoding bytes with
    | Binary.Success _ ->
        Alcotest.failf "%s failed: expecting exception, got success." name
    | Binary.Await _ ->
        Alcotest.failf "%s failed: not enough data" name
    | Binary.Error error when expected (Binary.Read_error error) ->
        ()
    | Binary.Error error ->
        Alcotest.failf
          "@[<v 2>%s failed: read error@ %a@]"
          name
          Binary.pp_read_error
          error
  done

let minimal_stream ?(expected = fun _ -> true) expected_read read_encoding
    bytes () =
  let name = "minimal_stream" in
  match streamed_read read_encoding bytes with
  | (Binary.Success _, _) ->
      Alcotest.failf "%s failed: expecting exception, got success." name
  | (Binary.Await _, _) ->
      Alcotest.failf "%s failed: not enough data" name
  | (Binary.Error error, count)
    when expected (Binary.Read_error error) && count = expected_read ->
      ()
  | (Binary.Error error, count) ->
      Alcotest.failf
        "@[<v 2>%s failed: read error after reading %d. @ %a@]"
        name
        count
        Binary.pp_read_error
        error

let all ?expected name write_encoding read_encoding value =
  let json_value = Json.construct write_encoding value in
  let bson_value = Bson.construct write_encoding value in
  let bytes_value = Binary.to_bytes_exn write_encoding value in
  [ (name ^ ".json", `Quick, json ?expected read_encoding json_value);
    (name ^ ".bson", `Quick, bson ?expected read_encoding bson_value);
    (name ^ ".bytes", `Quick, binary ?expected read_encoding bytes_value);
    (name ^ ".stream", `Quick, stream ?expected read_encoding bytes_value) ]

let all_ranged_int minimum maximum =
  let encoding = ranged_int minimum maximum in
  let signed =
    match Binary_size.range_to_size ~minimum ~maximum with
    | `Int31 | `Int8 | `Int16 ->
        true
    | `Uint8 | `Uint16 | `Uint30 ->
        false
  in
  let write_encoding =
    splitted
      ~json:(ranged_int (minimum - 1) (maximum + 1))
      ~binary:
        ( if signed then ranged_int (minimum - 1) (maximum + 1)
        else ranged_int minimum (maximum + 1) )
  in
  let name = Format.asprintf "ranged_int.%d" minimum in
  all
    ~expected:invalid_int
    (name ^ ".max")
    write_encoding
    encoding
    (maximum + 1)
  @
  if signed then
    all
      ~expected:invalid_int
      (name ^ ".min")
      write_encoding
      encoding
      (minimum - 1)
  else
    let json_value = Json.construct write_encoding (minimum - 1) in
    let bson_value = Bson.construct write_encoding (minimum - 1) in
    [ ( name ^ "min.json",
        `Quick,
        json ~expected:invalid_int encoding json_value );
      ( name ^ "min..bson",
        `Quick,
        bson ~expected:invalid_int encoding bson_value ) ]

let all_ranged_float minimum maximum =
  let encoding = ranged_float minimum maximum in
  let name = Format.asprintf "ranged_float.%f" minimum in
  all (name ^ ".min") float encoding (minimum -. 1.)
  @ all (name ^ ".max") float encoding (maximum +. 1.)

let test_bounded_string_list =
  let expected = function
    | Binary_error.Read_error Size_limit_exceeded ->
        true
    | _ ->
        false
  in
  let test name ~total ~elements v expected_read expected_read' =
    let bytes = Binary.to_bytes_exn (Variable.list string) v in
    let vbytes = Binary.to_bytes_exn (list string) v in
    [ ( "bounded_string_list." ^ name,
        `Quick,
        binary ~expected (bounded_list ~total ~elements string) bytes );
      ( "bounded_string_list_stream." ^ name,
        `Quick,
        stream
          ~expected
          (dynamic_size (bounded_list ~total ~elements string))
          vbytes );
      ( "bounded_string_list_minimal_stream." ^ name,
        `Quick,
        minimal_stream
          ~expected
          expected_read
          (dynamic_size (bounded_list ~total ~elements string))
          vbytes );
      ( "bounded_string_list_minimal_stream." ^ name,
        `Quick,
        minimal_stream
          ~expected
          expected_read'
          (check_size
             (total + 4)
             (dynamic_size (Variable.list (check_size elements string))))
          vbytes ) ]
  in
  test "a" ~total:0 ~elements:0 [""] 4 4
  @ test "b1" ~total:3 ~elements:4 [""] 4 4
  @ test "b2" ~total:4 ~elements:3 [""] 4 4
  @ test "c1" ~total:19 ~elements:4 [""; ""; ""; ""; ""] 4 4
  @ test "c2" ~total:20 ~elements:3 [""; ""; ""; ""; ""] 4 4
  @ test "d1" ~total:20 ~elements:5 [""; ""; ""; ""; "a"] 4 4
  @ test "d2" ~total:21 ~elements:4 [""; ""; ""; ""; "a"] 24 24
  @ test "e" ~total:30 ~elements:10 ["ab"; "c"; "def"; "gh"; "ijk"] 4 4

let tests =
  all_ranged_int 100 400 @ all_ranged_int 19000 19253
  @ all_ranged_int ~-100 300
  @ all_ranged_int ~-300_000_000 300_000_000
  @ all_ranged_float ~-.100. 300.
  @ all
      "string.fixed"
      ~expected:invalid_string_length
      string
      (Fixed.string 4)
      "turlututu"
  @ all "string.bounded" string (Bounded.string 4) "turlututu"
  @ all
      "bytes.fixed"
      ~expected:invalid_string_length
      bytes
      (Fixed.bytes 4)
      (Bytes.of_string "turlututu")
  @ all "bytes.bounded" bytes (Bounded.bytes 4) (Bytes.of_string "turlututu")
  @ all
      "unknown_case.B"
      ~expected:missing_case
      union_enc
      mini_union_enc
      (B "2")
  @ all "unknown_case.E" ~expected:missing_case union_enc mini_union_enc E
  @ all "enum.missing" ~expected:missing_enum enum_enc mini_enum_enc 4
  @ test_bounded_string_list
  @ [ ( "n.truncated",
        `Quick,
        binary ~expected:not_enough_data n (Bytes.of_string "\x83") );
      ( "n.trailing_zero",
        `Quick,
        binary ~expected:trailing_zero n (Bytes.of_string "\x83\x00") );
      ( "n.trailing_zero2",
        `Quick,
        binary ~expected:trailing_zero n (Bytes.of_string "\x83\x00") );
      ( "z.truncated",
        `Quick,
        binary ~expected:not_enough_data z (Bytes.of_string "\x83") );
      ( "z.trailing_zero",
        `Quick,
        binary ~expected:trailing_zero z (Bytes.of_string "\x83\x00") );
      ( "z.trailing_zero2",
        `Quick,
        binary ~expected:trailing_zero z (Bytes.of_string "\x83\x80\x00") );
      ( "dynamic_size.empty",
        `Quick,
        binary
          ~expected:not_enough_data
          (dynamic_size Variable.string)
          (Bytes.of_string "") );
      ( "dynamic_size.partial_size",
        `Quick,
        binary
          ~expected:not_enough_data
          (dynamic_size Variable.string)
          (Bytes.of_string "\x00\x00") );
      ( "dynamic_size.incomplete_data",
        `Quick,
        binary
          ~expected:not_enough_data
          (dynamic_size Variable.string)
          (Bytes.of_string "\x00\x00\x00\x04\x00\x00") );
      ( "dynamic_size.outer-garbage",
        `Quick,
        binary
          ~expected:extra_bytes
          (dynamic_size Variable.string)
          (Bytes.of_string "\x00\x00\x00\x01\x00\x00") );
      ( "dynamic_size.inner-garbage",
        `Quick,
        binary
          ~expected:extra_bytes
          (dynamic_size uint8)
          (Bytes.of_string "\x00\x00\x00\x02\x00\x00") ) ]
src/lib_data_encoding/test/read_failure.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Data_encoding.

Definition not_enough_data (function_parameter : exn) : bool :=
  match function_parameter with
  | Binary.Read_error Not_enough_data => true
  | _ => false
  end.

Definition extra_bytes (function_parameter : exn) : bool :=
  match function_parameter with
  | Binary.Read_error Extra_bytes => true
  | _ => false
  end.

Definition trailing_zero (function_parameter : exn) : bool :=
  match function_parameter with
  | Binary.Read_error Trailing_zero => true
  | _ => false
  end.

Definition invalid_int (function_parameter : exn) : bool :=
  match function_parameter with
  | Binary.Read_error (Invalid_int _) => true
  | Json_encoding.Cannot_destruct ([], OCaml.Failure _) => true
  | _ => false
  end.

Definition invalid_string_length (function_parameter : exn) : bool :=
  match function_parameter with
  |
    Json_encoding.Cannot_destruct
      ([],
        Json_encoding.Unexpected "string (len 9)" % string
          "string (len 4)" % string) => true
  |
    Json_encoding.Cannot_destruct
      ([],
        Json_encoding.Unexpected "bytes (len 9)" % string
          "bytes (len 4)" % string) => true
  | Binary.Read_error Extra_bytes => true
  | _ => false
  end.

Definition missing_case (function_parameter : exn) : bool :=
  match function_parameter with
  | Json_encoding.Cannot_destruct ([], Json_encoding.No_case_matched _) => true
  | Binary.Read_error (Unexpected_tag _) => true
  | _ => false
  end.

Definition missing_enum (function_parameter : exn) : bool :=
  match function_parameter with
  | Json_encoding.Cannot_destruct ([], Json_encoding.Unexpected _ _) => true
  | Binary.Read_error No_case_matched => true
  | _ => false
  end.

Definition json {A B C : Type} (op_star_o_p_t_star : option (A -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t B) ->
    Tezos_data_encoding.Data_encoding.Json.json -> unit -> C :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun read_encoding =>
    fun json =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star expected
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                OCaml.Stdlib.ignore
                  (Tezos_data_encoding.Data_encoding.Json.destruct read_encoding
                    json)
              end)
        end.

Definition bson {A B C : Type} (op_star_o_p_t_star : option (A -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t B) ->
    Tezos_data_encoding.Data_encoding.Bson.bson -> unit -> C :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun read_encoding =>
    fun bson =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star expected
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                OCaml.Stdlib.ignore
                  (Tezos_data_encoding.Data_encoding.Bson.destruct read_encoding
                    bson)
              end)
        end.

Definition binary {A B C : Type} (op_star_o_p_t_star : option (A -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t B) ->
    Stdlib.Bytes.t -> unit -> C :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun read_encoding =>
    fun bytes =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star expected
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                OCaml.Stdlib.ignore
                  (Tezos_data_encoding.Data_encoding.Binary.of_bytes_exn
                    read_encoding string)
              end)
        end.

Definition stream {A : Type} (op_star_o_p_t_star : option (exn -> bool))
  : A -> string -> unit -> unit :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun read_encoding =>
    fun bytes =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          let len_data := String.length string in
          for
        end.

Definition minimal_stream {A B C : Type}
  (op_star_o_p_t_star : option (exn -> bool)) : A -> B -> C -> unit -> unit :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun expected_read =>
    fun read_encoding =>
      fun bytes =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            let name := "minimal_stream" % string in
            match op_star_t_y_p_e_minus_e_r_r_o_r_star read_encoding string with
            | (Binary.Success _, _) =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                "%s failed: expecting exception, got success." % string name
            | (Binary.Await _, _) =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                "%s failed: not enough data" % string name
            | (Binary.Error error, count) =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                "@[<v 2>%s failed: read error after reading %d. @ %a@]" % string
                name count
                Tezos_data_encoding.Data_encoding.Binary.pp_read_error error
            end
          end.

Definition all {A B : Type}
  (expected : option (exn -> bool)) (name : string)
  (write_encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (read_encoding : Tezos_data_encoding__Data_encoding.Encoding.t B) (value : A)
  : list (string * variant * (unit -> unit)) :=
  let json_value :=
    Tezos_data_encoding.Data_encoding.Json.construct write_encoding value in
  let bson_value :=
    Tezos_data_encoding.Data_encoding.Bson.construct write_encoding value in
  let bytes_value :=
    Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn write_encoding value
    in
  cons
    ((String.append name ".json" % string), variant,
      (json expected read_encoding json_value))
    (cons
      ((String.append name ".bson" % string), variant,
        (bson expected read_encoding bson_value))
      (cons
        ((String.append name ".bytes" % string), variant,
          (binary expected read_encoding bytes_value))
        (cons
          ((String.append name ".stream" % string), variant,
            (stream expected read_encoding bytes_value)) []))).

Definition all_ranged_int (minimum : Z) (maximum : Z)
  : list (string * variant * (unit -> unit)) :=
  let encoding := Tezos_data_encoding.Data_encoding.ranged_int minimum maximum
    in
  let signed :=
    match Tezos_data_encoding.Binary_size.range_to_size minimum maximum with
    | Int31 | Int8 | Int16 => true
    | Uint8 | Uint16 | Uint30 => false
    end in
  let write_encoding :=
    Tezos_data_encoding.Data_encoding.splitted
      (Tezos_data_encoding.Data_encoding.ranged_int (Z.sub minimum 1)
        (Z.add maximum 1))
      (if signed then
        Tezos_data_encoding.Data_encoding.ranged_int (Z.sub minimum 1)
          (Z.add maximum 1)
      else
        Tezos_data_encoding.Data_encoding.ranged_int minimum (Z.add maximum 1))
    in
  let name :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_int." % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_int.%d" % string)
      minimum in
  OCaml.Stdlib.app
    (all (Some invalid_int) (String.append name ".max" % string) write_encoding
      encoding (Z.add maximum 1))
    (if signed then
      all (Some invalid_int) (String.append name ".min" % string) write_encoding
        encoding (Z.sub minimum 1)
    else
      let json_value :=
        Tezos_data_encoding.Data_encoding.Json.construct write_encoding
          (Z.sub minimum 1) in
      let bson_value :=
        Tezos_data_encoding.Data_encoding.Bson.construct write_encoding
          (Z.sub minimum 1) in
      cons
        ((String.append name "min.json" % string), variant,
          (json (Some invalid_int) encoding json_value))
        (cons
          ((String.append name "min..bson" % string), variant,
            (bson (Some invalid_int) encoding bson_value)) [])).

Definition all_ranged_float (minimum : float) (maximum : float)
  : list (string * variant * (unit -> unit)) :=
  let encoding := Tezos_data_encoding.Data_encoding.ranged_float minimum maximum
    in
  let name :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_float." % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_float.%f" % string)
      minimum in
  OCaml.Stdlib.app
    (all None (String.append name ".min" % string)
      Tezos_data_encoding.Data_encoding.float encoding
      (Stdlib.op_minus_point minimum 1))
    (all None (String.append name ".max" % string)
      Tezos_data_encoding.Data_encoding.float encoding
      (Stdlib.op_plus_point maximum 1)).

Definition test_bounded_string_list
  : list (string * variant * (unit -> unit)) :=
  let expected (function_parameter : exn) : bool :=
    match function_parameter with
    | Binary_error.Read_error Size_limit_exceeded => true
    | _ => false
    end in
  let test {A B : Type}
    (name : string) (total : Z) (elements : Z) (v : list string) (expected_read
    : A) (expected_read' : B) : list (string * variant * (unit -> unit)) :=
    let bytes :=
      Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn
        (Tezos_data_encoding.Data_encoding.Variable.list None
          Tezos_data_encoding.Data_encoding.string) v in
    let vbytes :=
      Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn
        (Tezos_data_encoding.Data_encoding.list None
          Tezos_data_encoding.Data_encoding.string) v in
    cons
      ((String.append "bounded_string_list." % string name), variant,
        (binary (Some expected)
          (op_star_t_y_p_e_minus_e_r_r_o_r_star total elements
            Tezos_data_encoding.Data_encoding.string) string))
      (cons
        ((String.append "bounded_string_list_stream." % string name), variant,
          (stream (Some expected)
            (Tezos_data_encoding.Data_encoding.dynamic_size None
              (op_star_t_y_p_e_minus_e_r_r_o_r_star total elements
                Tezos_data_encoding.Data_encoding.string)) vbytes))
        (cons
          ((String.append "bounded_string_list_minimal_stream." % string name),
            variant,
            (minimal_stream (Some expected) expected_read
              (Tezos_data_encoding.Data_encoding.dynamic_size None
                (op_star_t_y_p_e_minus_e_r_r_o_r_star total elements
                  Tezos_data_encoding.Data_encoding.string)) vbytes))
          (cons
            ((String.append "bounded_string_list_minimal_stream." % string name),
              variant,
              (minimal_stream (Some expected) expected_read'
                (Tezos_data_encoding.Data_encoding.check_size (Z.add total 4)
                  (Tezos_data_encoding.Data_encoding.dynamic_size None
                    (Tezos_data_encoding.Data_encoding.Variable.list None
                      (Tezos_data_encoding.Data_encoding.check_size elements
                        Tezos_data_encoding.Data_encoding.string)))) vbytes)) [])))
    in
  OCaml.Stdlib.app (test "a" % string 0 0 (cons "" % string []) 4 4)
    (OCaml.Stdlib.app (test "b1" % string 3 4 (cons "" % string []) 4 4)
      (OCaml.Stdlib.app (test "b2" % string 4 3 (cons "" % string []) 4 4)
        (OCaml.Stdlib.app
          (test "c1" % string 19 4
            (cons "" % string
              (cons "" % string
                (cons "" % string (cons "" % string (cons "" % string []))))) 4
            4)
          (OCaml.Stdlib.app
            (test "c2" % string 20 3
              (cons "" % string
                (cons "" % string
                  (cons "" % string (cons "" % string (cons "" % string [])))))
              4 4)
            (OCaml.Stdlib.app
              (test "d1" % string 20 5
                (cons "" % string
                  (cons "" % string
                    (cons "" % string (cons "" % string (cons "a" % string [])))))
                4 4)
              (OCaml.Stdlib.app
                (test "d2" % string 21 4
                  (cons "" % string
                    (cons "" % string
                      (cons "" % string
                        (cons "" % string (cons "a" % string []))))) 24 24)
                (test "e" % string 30 10
                  (cons "ab" % string
                    (cons "c" % string
                      (cons "def" % string
                        (cons "gh" % string (cons "ijk" % string []))))) 4 4))))))).

Definition tests : list (string * variant * (unit -> unit)) :=
  OCaml.Stdlib.app (all_ranged_int 100 400)
    (OCaml.Stdlib.app (all_ranged_int 19000 19253)
      (OCaml.Stdlib.app (all_ranged_int (Z.opp 100) 300)
        (OCaml.Stdlib.app (all_ranged_int (Z.opp 300000000) 300000000)
          (OCaml.Stdlib.app
            (all_ranged_float (Stdlib.op_tilde_minus_point 100) 300)
            (OCaml.Stdlib.app
              (all (Some invalid_string_length) "string.fixed" % string
                Tezos_data_encoding.Data_encoding.string
                (Tezos_data_encoding.Data_encoding.Fixed.string 4)
                "turlututu" % string)
              (OCaml.Stdlib.app
                (all None "string.bounded" % string
                  Tezos_data_encoding.Data_encoding.string
                  (Tezos_data_encoding.Data_encoding.Bounded.string 4)
                  "turlututu" % string)
                (OCaml.Stdlib.app
                  (all (Some invalid_string_length) "bytes.fixed" % string
                    Tezos_data_encoding.Data_encoding.bytes
                    (Tezos_data_encoding.Data_encoding.Fixed.bytes 4)
                    (Stdlib.Bytes.of_string "turlututu" % string))
                  (OCaml.Stdlib.app
                    (all None "bytes.bounded" % string
                      Tezos_data_encoding.Data_encoding.bytes
                      (Tezos_data_encoding.Data_encoding.Bounded.bytes 4)
                      (Stdlib.Bytes.of_string "turlututu" % string))
                    (OCaml.Stdlib.app
                      (all (Some missing_case) "unknown_case.B" % string
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (OCaml.Stdlib.app
                        (all (Some missing_case) "unknown_case.E" % string
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (OCaml.Stdlib.app
                          (all (Some missing_enum) "enum.missing" % string
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star 4)
                          (OCaml.Stdlib.app test_bounded_string_list
                            (cons
                              ("n.truncated" % string, variant,
                                (binary (Some not_enough_data)
                                  Tezos_data_encoding.Data_encoding.n
                                  (Stdlib.Bytes.of_string "ƒ" % string)))
                              (cons
                                ("n.trailing_zero" % string, variant,
                                  (binary (Some trailing_zero)
                                    Tezos_data_encoding.Data_encoding.n
                                    (Stdlib.Bytes.of_string "ƒ" % string)))
                                (cons
                                  ("n.trailing_zero2" % string, variant,
                                    (binary (Some trailing_zero)
                                      Tezos_data_encoding.Data_encoding.n
                                      (Stdlib.Bytes.of_string "ƒ" % string)))
                                  (cons
                                    ("z.truncated" % string, variant,
                                      (binary (Some not_enough_data)
                                        Tezos_data_encoding.Data_encoding.z
                                        (Stdlib.Bytes.of_string "ƒ" % string)))
                                    (cons
                                      ("z.trailing_zero" % string, variant,
                                        (binary (Some trailing_zero)
                                          Tezos_data_encoding.Data_encoding.z
                                          (Stdlib.Bytes.of_string "ƒ" % string)))
                                      (cons
                                        ("z.trailing_zero2" % string, variant,
                                          (binary (Some trailing_zero)
                                            Tezos_data_encoding.Data_encoding.z
                                            (Stdlib.Bytes.of_string
                                              "ƒ€" % string)))
                                        (cons
                                          ("dynamic_size.empty" % string,
                                            variant,
                                            (binary (Some not_enough_data)
                                              (Tezos_data_encoding.Data_encoding.dynamic_size
                                                None
                                                Tezos_data_encoding.Data_encoding.Variable.string)
                                              (Stdlib.Bytes.of_string
                                                "" % string)))
                                          (cons
                                            ("dynamic_size.partial_size" %
                                              string, variant,
                                              (binary (Some not_enough_data)
                                                (Tezos_data_encoding.Data_encoding.dynamic_size
                                                  None
                                                  Tezos_data_encoding.Data_encoding.Variable.string)
                                                (Stdlib.Bytes.of_string
                                                  "" % string)))
                                            (cons
                                              ("dynamic_size.incomplete_data" %
                                                string, variant,
                                                (binary (Some not_enough_data)
                                                  (Tezos_data_encoding.Data_encoding.dynamic_size
                                                    None
                                                    Tezos_data_encoding.Data_encoding.Variable.string)
                                                  (Stdlib.Bytes.of_string
                                                    "" % string)))
                                              (cons
                                                ("dynamic_size.outer-garbage" %
                                                  string, variant,
                                                  (binary (Some extra_bytes)
                                                    (Tezos_data_encoding.Data_encoding.dynamic_size
                                                      None
                                                      Tezos_data_encoding.Data_encoding.Variable.string)
                                                    (Stdlib.Bytes.of_string
                                                      "" % string)))
                                                (cons
                                                  ("dynamic_size.inner-garbage"
                                                    % string, variant,
                                                    (binary (Some extra_bytes)
                                                      (Tezos_data_encoding.Data_encoding.dynamic_size
                                                        None
                                                        Tezos_data_encoding.Data_encoding.uint8)
                                                      (Stdlib.Bytes.of_string
                                                        "" % string))) []))))))))))))))))))))))).
src/lib_data_encoding/test/success.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Trivial back-and-forth test: a value is serialized, then
    unserialized and compared to the original value. All backend
    (json, bson, binary, and streamed binary) are tested for each of
    the basic encoding described here. No serialization or
    deserialization failure are expected in these tests. *)

(* TODO `varopt` ; `assoc` ; `Data_encoding.json` *)

open Data_encoding
open Helpers
open Types

let json ty encoding value () =
  no_exception (fun () ->
      let json = Json.construct encoding value in
      let result = Json.destruct encoding json in
      Alcotest.check ty "json" value result)

let bson ty encoding value () =
  no_exception (fun () ->
      let json = Bson.construct encoding value in
      let result = Bson.destruct encoding json in
      Alcotest.check ty "bson" value result)

let binary ty encoding value () =
  no_exception (fun () ->
      let bytes = Binary.to_bytes_exn encoding value in
      let result = Binary.of_bytes_exn encoding bytes in
      Alcotest.check ty "binary" value result)

let stream ty encoding value () =
  no_exception (fun () ->
      let bytes = Binary.to_bytes_exn encoding value in
      let len_data = Bytes.length bytes in
      for sz = 1 to max 1 len_data do
        let name = Format.asprintf "stream (%d)" sz in
        match chunked_read sz encoding bytes with
        | Binary.Success {result; size; stream} ->
            if
              size <> Bytes.length bytes || not (Binary_stream.is_empty stream)
            then Alcotest.failf "%s failed: remaining data" name ;
            Alcotest.check ty name value result
        | Binary.Await _ ->
            Alcotest.failf "%s failed: not enough data" name
        | Binary.Error error ->
            Alcotest.failf
              "@[<v 2>%s failed: read error@ %a@]"
              name
              Binary.pp_read_error
              error
      done)

let all name ty encoding value =
  let stream_encoding =
    match Data_encoding.classify encoding with
    | `Variable ->
        dynamic_size encoding
    | `Dynamic | `Fixed _ ->
        encoding
  in
  [ (name ^ ".json", `Quick, json ty encoding value);
    (name ^ ".bson", `Quick, bson ty encoding value);
    (name ^ ".binary", `Quick, binary ty encoding value);
    (name ^ ".binary_stream", `Quick, stream ty stream_encoding value) ]

let all_int encoding size =
  let name = Format.asprintf "int%d" size in
  all (name ^ ".min") Alcotest.int encoding ~-(1 lsl (size - 1))
  @ all (name ^ ".mean") Alcotest.int encoding 0
  @ all (name ^ ".max") Alcotest.int encoding ((1 lsl (size - 1)) - 1)

let all_uint encoding size =
  let name = Format.asprintf "uint%d" size in
  all (name ^ ".min") Alcotest.int encoding 0
  @ all (name ^ ".mean") Alcotest.int encoding (1 lsl (size - 1))
  @ all (name ^ ".max") Alcotest.int encoding ((1 lsl size) - 1)

let all_ranged_int minimum maximum =
  let encoding = ranged_int minimum maximum in
  let name = Format.asprintf "ranged_int.%d" minimum in
  all (name ^ ".min") Alcotest.int encoding minimum
  @ all (name ^ ".mean") Alcotest.int encoding ((minimum + maximum) / 2)
  @ all (name ^ ".max") Alcotest.int encoding maximum

let all_ranged_float minimum maximum =
  let encoding = ranged_float minimum maximum in
  let name = Format.asprintf "ranged_float.%f" minimum in
  all (name ^ ".min") Alcotest.float encoding minimum
  @ all (name ^ ".mean") Alcotest.float encoding ((minimum +. maximum) /. 2.)
  @ all (name ^ ".max") Alcotest.float encoding maximum

let test_n_sequence () =
  let test i = binary Alcotest.z z i () ; stream Alcotest.z z i () in
  for i = 0 to 10_000 do
    test (Z.of_int i)
  done ;
  for i = 100_000_000 to 100_010_000 do
    test (Z.of_int i)
  done

let test_z_sequence () =
  let test i = binary Alcotest.z z i () ; stream Alcotest.z z i () in
  for i = -10_000 to 10_000 do
    test (Z.of_int i)
  done ;
  for i = 100_000_000 to 100_010_000 do
    test (Z.of_int i)
  done ;
  for i = -100_000_000 downto -100_010_000 do
    test (Z.of_int i)
  done

let test_string_enum_boundary () =
  let entries =
    List.rev_map (fun x -> (string_of_int x, x)) (List.init 255 (fun i -> i))
  in
  let run_test cases =
    List.iter
      (fun (_, num) ->
        let enc = string_enum cases in
        json Alcotest.int enc num () ;
        bson Alcotest.int enc num () ;
        binary Alcotest.int enc num () ;
        stream Alcotest.int enc num ())
      cases
  in
  run_test entries ;
  let entries2 = ("255", 255) :: entries in
  run_test entries2 ;
  run_test (("256", 256) :: entries2)

let test_bounded_string_list =
  let test name ~total ~elements v =
    ( "bounded_string_list." ^ name,
      `Quick,
      binary Alcotest.(list string) (bounded_list ~total ~elements string) v )
  in
  [ test "a" ~total:0 ~elements:0 [];
    test "b" ~total:4 ~elements:4 [""];
    test "c" ~total:20 ~elements:4 [""; ""; ""; ""; ""];
    test "d" ~total:21 ~elements:5 [""; ""; ""; ""; "a"];
    test "e" ~total:31 ~elements:10 ["ab"; "c"; "def"; "gh"; "ijk"] ]

let tests =
  all "null" Alcotest.pass null ()
  @ all "empty" Alcotest.pass empty ()
  @ all "constant" Alcotest.pass (constant "toto") ()
  @ all_int int8 8 @ all_uint uint8 8 @ all_int int16 16 @ all_uint uint16 16
  @ all_int int31 31
  @ all "int32.min" Alcotest.int32 int32 Int32.min_int
  @ all "int32.max" Alcotest.int32 int32 Int32.max_int
  @ all "int64.min" Alcotest.int64 int64 Int64.min_int
  @ all "int64.max" Alcotest.int64 int64 Int64.max_int
  @ all_ranged_int 100 400 @ all_ranged_int 19000 19254
  @ all_ranged_int ~-100 300
  @ all_ranged_int ~-300_000_000 300_000_000
  @ all "bool.true" Alcotest.bool bool true
  @ all "bool.false" Alcotest.bool bool false
  @ all "string" Alcotest.string string "tutu"
  @ all "string.fixed" Alcotest.string (Fixed.string 4) "tutu"
  @ all "string.variable" Alcotest.string Variable.string "tutu"
  @ all "string.bounded1" Alcotest.string (Bounded.string 4) "tu"
  @ all "string.bounded2" Alcotest.string (Bounded.string 4) "tutu"
  @ all "bytes" Alcotest.bytes bytes (Bytes.of_string "titi")
  @ all "bytes.fixed" Alcotest.bytes (Fixed.bytes 4) (Bytes.of_string "titi")
  @ all "bytes.variable" Alcotest.bytes Variable.bytes (Bytes.of_string "titi")
  @ all
      "bytes.bounded1"
      Alcotest.bytes
      (Bounded.bytes 4)
      (Bytes.of_string "tu")
  @ all
      "bytes.bounded2"
      Alcotest.bytes
      (Bounded.bytes 4)
      (Bytes.of_string "tutu")
  @ all "float" Alcotest.float float 42.
  @ all "float.max" Alcotest.float float max_float
  @ all "float.min" Alcotest.float float min_float
  @ all "float.neg_zero" Alcotest.float float (-0.)
  @ all "float.zero" Alcotest.float float 0.
  @ all "float.infinity" Alcotest.float float infinity
  @ all "float.neg_infity" Alcotest.float float neg_infinity
  @ all "float.epsilon" Alcotest.float float epsilon_float
  @ all "float.nan" Alcotest.float float nan
  @ all_ranged_float ~-.100. 300.
  @ all "n.zero" Alcotest.n n Z.zero
  @ all "n.one" Alcotest.n n Z.one
  @ [("n.sequence", `Quick, test_n_sequence)]
  @
  let rec fact i l =
    if i < 1 then []
    else
      let l = Z.mul l (Z.of_int i) in
      fact (i - 1) l @ all (Format.asprintf "n.fact.%d" i) Alcotest.n n l
  in
  fact 35 Z.one
  @ all
      "n.a"
      Alcotest.n
      n
      (Z.of_string "123574503164821730218493275982143254986574985328")
  @ all "n.b" Alcotest.n n (Z.of_string "8493275982143254986574985328")
  @ all "n.c" Alcotest.n n (Z.of_string "123574503164821730218474985328")
  @ all
      "n.d"
      Alcotest.n
      n
      (Z.of_string
         "10000000000100000000001000003050000000060600000000000777000008")
  @ all "z.zero" Alcotest.z z Z.zero
  @ all "z.one" Alcotest.z z Z.one
  @ [("z.sequence", `Quick, test_z_sequence)]
  @
  let rec fact n l =
    if n < 1 then []
    else
      let l = Z.mul l (Z.of_int n) in
      fact (n - 1) l @ all (Format.asprintf "z.fact.%d" n) Alcotest.z z l
  in
  fact 35 Z.one
  @ all
      "z.a"
      Alcotest.z
      z
      (Z.of_string "123574503164821730218493275982143254986574985328")
  @ all "z.b" Alcotest.z z (Z.of_string "8493275982143254986574985328")
  @ all "z.c" Alcotest.z z (Z.of_string "123574503164821730218474985328")
  @ all
      "z.d"
      Alcotest.z
      z
      (Z.of_string
         "10000000000100000000001000003050000000060600000000000777000008")
  @ all
      "z.e"
      Alcotest.z
      z
      (Z.of_string "-123574503164821730218493275982143254986574985328")
  @ all "z.f" Alcotest.z z (Z.of_string "-8493275982143254986574985328")
  @ all "z.g" Alcotest.z z (Z.of_string "-123574503164821730218474985328")
  @ all
      "z.h"
      Alcotest.z
      z
      (Z.of_string
         "-10000000000100000000001000003050000000060600000000000777000008")
  @ all "none" Alcotest.(option string) (option string) None
  @ all "some.string" Alcotest.(option string) (option string) (Some "thing")
  @ all "enum" Alcotest.int enum_enc 4
  @ all "obj" Alcotest.record record_obj_enc default_record
  @ all
      "obj.dft"
      Alcotest.record
      record_obj_enc
      {default_record with b = false}
  @ all "obj.req" Alcotest.record record_obj_enc {default_record with c = None}
  @ all "tup" Alcotest.record record_tup_enc default_record
  @ all
      "obj.variable"
      Alcotest.variable_record
      variable_record_obj_enc
      default_variable_record
  @ all
      "tup.variable"
      Alcotest.variable_record
      variable_record_tup_enc
      default_variable_record
  @ all
      "obj.variable_left"
      Alcotest.variable_left_record
      variable_left_record_obj_enc
      default_variable_left_record
  @ all
      "tup.variable_left"
      Alcotest.variable_left_record
      variable_left_record_tup_enc
      default_variable_left_record
  @ all "union.A" Alcotest.union union_enc (A 1)
  @ all "union.B" Alcotest.union union_enc (B "2")
  @ all "union.C" Alcotest.union union_enc (C 3)
  @ all "union.D" Alcotest.union union_enc (D "4")
  @ all "union.E" Alcotest.union union_enc E
  @ all "variable_list.empty" Alcotest.(list int) (Variable.list int31) []
  @ all
      "variable_list"
      Alcotest.(list int)
      (Variable.list int31)
      [1; 2; 3; 4; 5]
  @ all "variable_array.empty" Alcotest.(array int) (Variable.array int31) [||]
  @ all
      "variable_array"
      Alcotest.(array int)
      (Variable.array int31)
      [|1; 2; 3; 4; 5|]
  @ all "list.empty" Alcotest.(list int) (list int31) []
  @ all "list" Alcotest.(list int) (list int31) [1; 2; 3; 4; 5]
  @ all "array.empty" Alcotest.(array int) (array int31) [||]
  @ all "array" Alcotest.(array int) (array int31) [|1; 2; 3; 4; 5|]
  @ all "mu_list.empty" Alcotest.(list int) (mu_list_enc int31) []
  @ all "mu_list" Alcotest.(list int) (mu_list_enc int31) [1; 2; 3; 4; 5]
  @ test_bounded_string_list
  @ [("string_enum_boundary", `Quick, test_string_enum_boundary)]
src/lib_data_encoding/test/success.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Data_encoding.

Definition json {A B C : Type}
  (ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
  (value : B) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let json :=
            Tezos_data_encoding.Data_encoding.Json.construct encoding value in
          let result :=
            Tezos_data_encoding.Data_encoding.Json.destruct encoding json in
          op_star_t_y_p_e_minus_e_r_r_o_r_star ty "json" % string value result
        end)
  end.

Definition bson {A B C : Type}
  (ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
  (value : B) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let json :=
            Tezos_data_encoding.Data_encoding.Bson.construct encoding value in
          let result :=
            Tezos_data_encoding.Data_encoding.Bson.destruct encoding json in
          op_star_t_y_p_e_minus_e_r_r_o_r_star ty "bson" % string value result
        end)
  end.

Definition binary {A B C : Type}
  (ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
  (value : B) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let bytes :=
            Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn encoding value
            in
          let result :=
            Tezos_data_encoding.Data_encoding.Binary.of_bytes_exn encoding
              string in
          op_star_t_y_p_e_minus_e_r_r_o_r_star ty "binary" % string value result
        end)
  end.

Definition stream {A B C : Type}
  (ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
  (value : B) (function_parameter : unit) : C :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let bytes :=
            Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn encoding value
            in
          let len_data := String.length string in
          for
        end)
  end.

Definition all {A B C : Type}
  (name : string) (ty : A)
  (encoding : Tezos_data_encoding.Data_encoding.encoding B) (value : B)
  : list (string * variant * (unit -> C)) :=
  let stream_encoding :=
    match Tezos_data_encoding.Data_encoding.classify encoding with
    | Variable => Tezos_data_encoding.Data_encoding.dynamic_size None encoding
    | Dynamic | Fixed _ => encoding
    end in
  cons
    ((String.append name ".json" % string), variant, (json ty encoding value))
    (cons
      ((String.append name ".bson" % string), variant, (bson ty encoding value))
      (cons
        ((String.append name ".binary" % string), variant,
          (binary ty encoding value))
        (cons
          ((String.append name ".binary_stream" % string), variant,
            (stream ty stream_encoding value)) []))).

Definition all_int {A : Type}
  (encoding : Tezos_data_encoding.Data_encoding.encoding Z) (size : Z)
  : list (string * variant * (unit -> A)) :=
  let name :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "int" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "int%d" % string) size in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string)
      op_star_t_y_p_e_minus_e_r_r_o_r_star encoding
      (Z.opp (Z.shiftl 1 (Z.sub size 1))))
    (OCaml.Stdlib.app
      (all (String.append name ".mean" % string)
        op_star_t_y_p_e_minus_e_r_r_o_r_star encoding 0)
      (all (String.append name ".max" % string)
        op_star_t_y_p_e_minus_e_r_r_o_r_star encoding
        (Z.sub (Z.shiftl 1 (Z.sub size 1)) 1))).

Definition all_uint {A : Type}
  (encoding : Tezos_data_encoding.Data_encoding.encoding Z) (size : Z)
  : list (string * variant * (unit -> A)) :=
  let name :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "uint" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "uint%d" % string) size in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string)
      op_star_t_y_p_e_minus_e_r_r_o_r_star encoding 0)
    (OCaml.Stdlib.app
      (all (String.append name ".mean" % string)
        op_star_t_y_p_e_minus_e_r_r_o_r_star encoding
        (Z.shiftl 1 (Z.sub size 1)))
      (all (String.append name ".max" % string)
        op_star_t_y_p_e_minus_e_r_r_o_r_star encoding
        (Z.sub (Z.shiftl 1 size) 1))).

Definition all_ranged_int {A : Type} (minimum : Z) (maximum : Z)
  : list (string * variant * (unit -> A)) :=
  let encoding := Tezos_data_encoding.Data_encoding.ranged_int minimum maximum
    in
  let name :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_int." % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_int.%d" % string)
      minimum in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string)
      op_star_t_y_p_e_minus_e_r_r_o_r_star encoding minimum)
    (OCaml.Stdlib.app
      (all (String.append name ".mean" % string)
        op_star_t_y_p_e_minus_e_r_r_o_r_star encoding
        (Z.div (Z.add minimum maximum) 2))
      (all (String.append name ".max" % string)
        op_star_t_y_p_e_minus_e_r_r_o_r_star encoding maximum)).

Definition all_ranged_float {A : Type} (minimum : float) (maximum : float)
  : list (string * variant * (unit -> A)) :=
  let encoding := Tezos_data_encoding.Data_encoding.ranged_float minimum maximum
    in
  let name :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_float." % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_float.%f" % string)
      minimum in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string)
      op_star_t_y_p_e_minus_e_r_r_o_r_star encoding minimum)
    (OCaml.Stdlib.app
      (all (String.append name ".mean" % string)
        op_star_t_y_p_e_minus_e_r_r_o_r_star encoding
        (Stdlib.op_div_point (Stdlib.op_plus_point minimum maximum) 2))
      (all (String.append name ".max" % string)
        op_star_t_y_p_e_minus_e_r_r_o_r_star encoding maximum)).

Definition test_n_sequence (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let test {A : Type} (i : Z.t) : A :=
      binary op_star_t_y_p_e_minus_e_r_r_o_r_star
        Tezos_data_encoding.Data_encoding.z i tt;
      stream op_star_t_y_p_e_minus_e_r_r_o_r_star
        Tezos_data_encoding.Data_encoding.z i tt in
    for;
    for
  end.

Definition test_z_sequence (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let test {A : Type} (i : Z.t) : A :=
      binary op_star_t_y_p_e_minus_e_r_r_o_r_star
        Tezos_data_encoding.Data_encoding.z i tt;
      stream op_star_t_y_p_e_minus_e_r_r_o_r_star
        Tezos_data_encoding.Data_encoding.z i tt in
    for;
    for;
    for
  end.

Definition test_string_enum_boundary (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let entries :=
      Stdlib.List.rev_map (fun x => ((OCaml.Stdlib.string_of_int x), x))
        (Stdlib.List.init 255 (fun i => i)) in
    let run_test {A : Type} (cases : list (string * A)) : unit :=
      Stdlib.List.iter
        (fun function_parameter =>
          match function_parameter with
          | (_, num) =>
            let enc := Tezos_data_encoding.Data_encoding.string_enum cases in
            json op_star_t_y_p_e_minus_e_r_r_o_r_star enc num tt;
            bson op_star_t_y_p_e_minus_e_r_r_o_r_star enc num tt;
            binary op_star_t_y_p_e_minus_e_r_r_o_r_star enc num tt;
            stream op_star_t_y_p_e_minus_e_r_r_o_r_star enc num tt
          end) cases in
    run_test entries;
    let entries2 := cons ("255" % string, 255) entries in
    run_test entries2;
    run_test (cons ("256" % string, 256) entries2)
  end.

Definition test_bounded_string_list {A : Type}
  : list (string * variant * (unit -> A)) :=
  let test {B C D E : Type} (name : string) (total : B) (elements : C) (v : D)
    : string * variant * (unit -> E) :=
    ((String.append "bounded_string_list." % string name), variant,
      (binary op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star total elements
          Tezos_data_encoding.Data_encoding.string) v)) in
  cons (test "a" % string 0 0 [])
    (cons (test "b" % string 4 4 (cons "" % string []))
      (cons
        (test "c" % string 20 4
          (cons "" % string
            (cons "" % string
              (cons "" % string (cons "" % string (cons "" % string []))))))
        (cons
          (test "d" % string 21 5
            (cons "" % string
              (cons "" % string
                (cons "" % string (cons "" % string (cons "a" % string []))))))
          (cons
            (test "e" % string 31 10
              (cons "ab" % string
                (cons "c" % string
                  (cons "def" % string
                    (cons "gh" % string (cons "ijk" % string [])))))) [])))).

Definition tests : list (string * variant * (unit -> unit)) :=
  OCaml.Stdlib.app
    (all "null" % string op_star_t_y_p_e_minus_e_r_r_o_r_star
      Tezos_data_encoding.Data_encoding.null tt)
    (OCaml.Stdlib.app
      (all "empty" % string op_star_t_y_p_e_minus_e_r_r_o_r_star
        Tezos_data_encoding.Data_encoding.empty tt)
      (OCaml.Stdlib.app
        (all "constant" % string op_star_t_y_p_e_minus_e_r_r_o_r_star
          (Tezos_data_encoding.Data_encoding.constant "toto" % string) tt)
        (OCaml.Stdlib.app (all_int Tezos_data_encoding.Data_encoding.int8 8)
          (OCaml.Stdlib.app (all_uint Tezos_data_encoding.Data_encoding.uint8 8)
            (OCaml.Stdlib.app
              (all_int Tezos_data_encoding.Data_encoding.int16 16)
              (OCaml.Stdlib.app
                (all_uint Tezos_data_encoding.Data_encoding.uint16 16)
                (OCaml.Stdlib.app
                  (all_int Tezos_data_encoding.Data_encoding.int31 31)
                  (OCaml.Stdlib.app
                    (all "int32.min" % string
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                      Tezos_data_encoding.Data_encoding.int32
                      Stdlib.Int32.min_int)
                    (OCaml.Stdlib.app
                      (all "int32.max" % string
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        Tezos_data_encoding.Data_encoding.int32
                        Stdlib.Int32.max_int)
                      (OCaml.Stdlib.app
                        (all "int64.min" % string
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_data_encoding.Data_encoding.int64
                          Stdlib.Int64.min_int)
                        (OCaml.Stdlib.app
                          (all "int64.max" % string
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            Tezos_data_encoding.Data_encoding.int64
                            Stdlib.Int64.max_int)
                          (OCaml.Stdlib.app (all_ranged_int 100 400)
                            (OCaml.Stdlib.app (all_ranged_int 19000 19254)
                              (OCaml.Stdlib.app (all_ranged_int (Z.opp 100) 300)
                                (OCaml.Stdlib.app
                                  (all_ranged_int (Z.opp 300000000) 300000000)
                                  (OCaml.Stdlib.app
                                    (all "bool.true" % string
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      Tezos_data_encoding.Data_encoding.bool
                                      true)
                                    (OCaml.Stdlib.app
                                      (all "bool.false" % string
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_data_encoding.Data_encoding.bool
                                        false)
                                      (OCaml.Stdlib.app
                                        (all "string" % string
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Tezos_data_encoding.Data_encoding.string
                                          "tutu" % string)
                                        (OCaml.Stdlib.app
                                          (all "string.fixed" % string
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (Tezos_data_encoding.Data_encoding.Fixed.string
                                              4) "tutu" % string)
                                          (OCaml.Stdlib.app
                                            (all "string.variable" % string
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_data_encoding.Data_encoding.Variable.string
                                              "tutu" % string)
                                            (OCaml.Stdlib.app
                                              (all "string.bounded1" % string
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (Tezos_data_encoding.Data_encoding.Bounded.string
                                                  4) "tu" % string)
                                              (OCaml.Stdlib.app
                                                (all "string.bounded2" % string
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (Tezos_data_encoding.Data_encoding.Bounded.string
                                                    4) "tutu" % string)
                                                (OCaml.Stdlib.app
                                                  (all "bytes" % string
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Tezos_data_encoding.Data_encoding.bytes
                                                    (Stdlib.Bytes.of_string
                                                      "titi" % string))
                                                  (OCaml.Stdlib.app
                                                    (all "bytes.fixed" % string
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (Tezos_data_encoding.Data_encoding.Fixed.bytes
                                                        4)
                                                      (Stdlib.Bytes.of_string
                                                        "titi" % string))
                                                    (OCaml.Stdlib.app
                                                      (all
                                                        "bytes.variable" %
                                                          string
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Tezos_data_encoding.Data_encoding.Variable.bytes
                                                        (Stdlib.Bytes.of_string
                                                          "titi" % string))
                                                      (OCaml.Stdlib.app
                                                        (all
                                                          "bytes.bounded1" %
                                                            string
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (Tezos_data_encoding.Data_encoding.Bounded.bytes
                                                            4)
                                                          (Stdlib.Bytes.of_string
                                                            "tu" % string))
                                                        (OCaml.Stdlib.app
                                                          (all
                                                            "bytes.bounded2" %
                                                              string
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (Tezos_data_encoding.Data_encoding.Bounded.bytes
                                                              4)
                                                            (Stdlib.Bytes.of_string
                                                              "tutu" % string))
                                                          (OCaml.Stdlib.app
                                                            (all
                                                              "float" % string
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              Tezos_data_encoding.Data_encoding.float
                                                              42)
                                                            (OCaml.Stdlib.app
                                                              (all
                                                                "float.max" %
                                                                  string
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                Tezos_data_encoding.Data_encoding.float
                                                                Stdlib.max_float)
                                                              (OCaml.Stdlib.app
                                                                (all
                                                                  "float.min" %
                                                                    string
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  Tezos_data_encoding.Data_encoding.float
                                                                  Stdlib.min_float)
                                                                (OCaml.Stdlib.app
                                                                  (all
                                                                    "float.neg_zero"
                                                                      % string
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    Tezos_data_encoding.Data_encoding.float
                                                                    0)
                                                                  (OCaml.Stdlib.app
                                                                    (all
                                                                      "float.zero"
                                                                        % string
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      Tezos_data_encoding.Data_encoding.float
                                                                      0)
                                                                    (OCaml.Stdlib.app
                                                                      (all
                                                                        "float.infinity"
                                                                          %
                                                                          string
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        Tezos_data_encoding.Data_encoding.float
                                                                        Stdlib.infinity)
                                                                      (OCaml.Stdlib.app
                                                                        (all
                                                                          "float.neg_infity"
                                                                            %
                                                                            string
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          Tezos_data_encoding.Data_encoding.float
                                                                          Stdlib.neg_infinity)
                                                                        (OCaml.Stdlib.app
                                                                          (all
                                                                            "float.epsilon"
                                                                              %
                                                                              string
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            Tezos_data_encoding.Data_encoding.float
                                                                            Stdlib.epsilon_float)
                                                                          (OCaml.Stdlib.app
                                                                            (all
                                                                              "float.nan"
                                                                                %
                                                                                string
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              Tezos_data_encoding.Data_encoding.float
                                                                              Stdlib.nan)
                                                                            (OCaml.Stdlib.app
                                                                              (all_ranged_float
                                                                                (Stdlib.op_tilde_minus_point
                                                                                  100)
                                                                                300)
                                                                              (OCaml.Stdlib.app
                                                                                (all
                                                                                  "n.zero"
                                                                                    %
                                                                                    string
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  Tezos_data_encoding.Data_encoding.n
                                                                                  Z.zero)
                                                                                (OCaml.Stdlib.app
                                                                                  (all
                                                                                    "n.one"
                                                                                      %
                                                                                      string
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    Tezos_data_encoding.Data_encoding.n
                                                                                    Z.one)
                                                                                  (OCaml.Stdlib.app
                                                                                    (cons
                                                                                      ("n.sequence"
                                                                                        %
                                                                                        string,
                                                                                        variant,
                                                                                        test_n_sequence)
                                                                                      [])
                                                                                    (let
                                                                                      fix
                                                                                      fact
                                                                                      {A
                                                                                      :
                                                                                      Type}
                                                                                      (i
                                                                                      :
                                                                                      Z)
                                                                                      (l
                                                                                      :
                                                                                      Z.t)
                                                                                      : list
                                                                                        (string
                                                                                          *
                                                                                          variant
                                                                                          *
                                                                                          (unit
                                                                                            ->
                                                                                            A)) :=
                                                                                      if
                                                                                        OCaml.Stdlib.lt
                                                                                          i
                                                                                          1
                                                                                        then
                                                                                        []
                                                                                      else
                                                                                        let
                                                                                          l :=
                                                                                          Z.mul
                                                                                            l
                                                                                            (Z.of_int
                                                                                              i)
                                                                                          in
                                                                                        OCaml.Stdlib.app
                                                                                          (fact
                                                                                            (Z.sub
                                                                                              i
                                                                                              1)
                                                                                            l)
                                                                                          (all
                                                                                            (Stdlib.Format.asprintf
                                                                                              (CamlinternalFormatBasics.Format
                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                  "n.fact."
                                                                                                    %
                                                                                                    string
                                                                                                  (CamlinternalFormatBasics.Int
                                                                                                    CamlinternalFormatBasics.Int_d
                                                                                                    CamlinternalFormatBasics.No_padding
                                                                                                    CamlinternalFormatBasics.No_precision
                                                                                                    CamlinternalFormatBasics.End_of_format))
                                                                                                "n.fact.%d"
                                                                                                  %
                                                                                                  string)
                                                                                              i)
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            Tezos_data_encoding.Data_encoding.n
                                                                                            l)
                                                                                      in
                                                                                    OCaml.Stdlib.app
                                                                                      (fact
                                                                                        35
                                                                                        Z.one)
                                                                                      (OCaml.Stdlib.app
                                                                                        (all
                                                                                          "n.a"
                                                                                            %
                                                                                            string
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          Tezos_data_encoding.Data_encoding.n
                                                                                          (Z.of_string
                                                                                            "123574503164821730218493275982143254986574985328"
                                                                                              %
                                                                                              string))
                                                                                        (OCaml.Stdlib.app
                                                                                          (all
                                                                                            "n.b"
                                                                                              %
                                                                                              string
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            Tezos_data_encoding.Data_encoding.n
                                                                                            (Z.of_string
                                                                                              "8493275982143254986574985328"
                                                                                                %
                                                                                                string))
                                                                                          (OCaml.Stdlib.app
                                                                                            (all
                                                                                              "n.c"
                                                                                                %
                                                                                                string
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              Tezos_data_encoding.Data_encoding.n
                                                                                              (Z.of_string
                                                                                                "123574503164821730218474985328"
                                                                                                  %
                                                                                                  string))
                                                                                            (OCaml.Stdlib.app
                                                                                              (all
                                                                                                "n.d"
                                                                                                  %
                                                                                                  string
                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                Tezos_data_encoding.Data_encoding.n
                                                                                                (Z.of_string
                                                                                                  "10000000000100000000001000003050000000060600000000000777000008"
                                                                                                    %
                                                                                                    string))
                                                                                              (OCaml.Stdlib.app
                                                                                                (all
                                                                                                  "z.zero"
                                                                                                    %
                                                                                                    string
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  Tezos_data_encoding.Data_encoding.z
                                                                                                  Z.zero)
                                                                                                (OCaml.Stdlib.app
                                                                                                  (all
                                                                                                    "z.one"
                                                                                                      %
                                                                                                      string
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    Tezos_data_encoding.Data_encoding.z
                                                                                                    Z.one)
                                                                                                  (OCaml.Stdlib.app
                                                                                                    (cons
                                                                                                      ("z.sequence"
                                                                                                        %
                                                                                                        string,
                                                                                                        variant,
                                                                                                        test_z_sequence)
                                                                                                      [])
                                                                                                    (let
                                                                                                      fix
                                                                                                      fact
                                                                                                      {A
                                                                                                      :
                                                                                                      Type}
                                                                                                      (n
                                                                                                      :
                                                                                                      Z)
                                                                                                      (l
                                                                                                      :
                                                                                                      Z.t)
                                                                                                      : list
                                                                                                        (string
                                                                                                          *
                                                                                                          variant
                                                                                                          *
                                                                                                          (unit
                                                                                                            ->
                                                                                                            A)) :=
                                                                                                      if
                                                                                                        OCaml.Stdlib.lt
                                                                                                          n
                                                                                                          1
                                                                                                        then
                                                                                                        []
                                                                                                      else
                                                                                                        let
                                                                                                          l :=
                                                                                                          Z.mul
                                                                                                            l
                                                                                                            (Z.of_int
                                                                                                              n)
                                                                                                          in
                                                                                                        OCaml.Stdlib.app
                                                                                                          (fact
                                                                                                            (Z.sub
                                                                                                              n
                                                                                                              1)
                                                                                                            l)
                                                                                                          (all
                                                                                                            (Stdlib.Format.asprintf
                                                                                                              (CamlinternalFormatBasics.Format
                                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                                  "z.fact."
                                                                                                                    %
                                                                                                                    string
                                                                                                                  (CamlinternalFormatBasics.Int
                                                                                                                    CamlinternalFormatBasics.Int_d
                                                                                                                    CamlinternalFormatBasics.No_padding
                                                                                                                    CamlinternalFormatBasics.No_precision
                                                                                                                    CamlinternalFormatBasics.End_of_format))
                                                                                                                "z.fact.%d"
                                                                                                                  %
                                                                                                                  string)
                                                                                                              n)
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            Tezos_data_encoding.Data_encoding.z
                                                                                                            l)
                                                                                                      in
                                                                                                    OCaml.Stdlib.app
                                                                                                      (fact
                                                                                                        35
                                                                                                        Z.one)
                                                                                                      (OCaml.Stdlib.app
                                                                                                        (all
                                                                                                          "z.a"
                                                                                                            %
                                                                                                            string
                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          Tezos_data_encoding.Data_encoding.z
                                                                                                          (Z.of_string
                                                                                                            "123574503164821730218493275982143254986574985328"
                                                                                                              %
                                                                                                              string))
                                                                                                        (OCaml.Stdlib.app
                                                                                                          (all
                                                                                                            "z.b"
                                                                                                              %
                                                                                                              string
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            Tezos_data_encoding.Data_encoding.z
                                                                                                            (Z.of_string
                                                                                                              "8493275982143254986574985328"
                                                                                                                %
                                                                                                                string))
                                                                                                          (OCaml.Stdlib.app
                                                                                                            (all
                                                                                                              "z.c"
                                                                                                                %
                                                                                                                string
                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              Tezos_data_encoding.Data_encoding.z
                                                                                                              (Z.of_string
                                                                                                                "123574503164821730218474985328"
                                                                                                                  %
                                                                                                                  string))
                                                                                                            (OCaml.Stdlib.app
                                                                                                              (all
                                                                                                                "z.d"
                                                                                                                  %
                                                                                                                  string
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                Tezos_data_encoding.Data_encoding.z
                                                                                                                (Z.of_string
                                                                                                                  "10000000000100000000001000003050000000060600000000000777000008"
                                                                                                                    %
                                                                                                                    string))
                                                                                                              (OCaml.Stdlib.app
                                                                                                                (all
                                                                                                                  "z.e"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                  Tezos_data_encoding.Data_encoding.z
                                                                                                                  (Z.of_string
                                                                                                                    "-123574503164821730218493275982143254986574985328"
                                                                                                                      %
                                                                                                                      string))
                                                                                                                (OCaml.Stdlib.app
                                                                                                                  (all
                                                                                                                    "z.f"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    Tezos_data_encoding.Data_encoding.z
                                                                                                                    (Z.of_string
                                                                                                                      "-8493275982143254986574985328"
                                                                                                                        %
                                                                                                                        string))
                                                                                                                  (OCaml.Stdlib.app
                                                                                                                    (all
                                                                                                                      "z.g"
                                                                                                                        %
                                                                                                                        string
                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      Tezos_data_encoding.Data_encoding.z
                                                                                                                      (Z.of_string
                                                                                                                        "-123574503164821730218474985328"
                                                                                                                          %
                                                                                                                          string))
                                                                                                                    (OCaml.Stdlib.app
                                                                                                                      (all
                                                                                                                        "z.h"
                                                                                                                          %
                                                                                                                          string
                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                        Tezos_data_encoding.Data_encoding.z
                                                                                                                        (Z.of_string
                                                                                                                          "-10000000000100000000001000003050000000060600000000000777000008"
                                                                                                                            %
                                                                                                                            string))
                                                                                                                      (OCaml.Stdlib.app
                                                                                                                        (all
                                                                                                                          "none"
                                                                                                                            %
                                                                                                                            string
                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                          (Tezos_data_encoding.Data_encoding.option
                                                                                                                            Tezos_data_encoding.Data_encoding.string)
                                                                                                                          None)
                                                                                                                        (OCaml.Stdlib.app
                                                                                                                          (all
                                                                                                                            "some.string"
                                                                                                                              %
                                                                                                                              string
                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                            (Tezos_data_encoding.Data_encoding.option
                                                                                                                              Tezos_data_encoding.Data_encoding.string)
                                                                                                                            (Some
                                                                                                                              "thing"
                                                                                                                                %
                                                                                                                                string))
                                                                                                                          (OCaml.Stdlib.app
                                                                                                                            (all
                                                                                                                              "enum"
                                                                                                                                %
                                                                                                                                string
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              4)
                                                                                                                            (OCaml.Stdlib.app
                                                                                                                              (all
                                                                                                                                "obj"
                                                                                                                                  %
                                                                                                                                  string
                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                              (OCaml.Stdlib.app
                                                                                                                                (all
                                                                                                                                  "obj.dft"
                                                                                                                                    %
                                                                                                                                    string
                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                (OCaml.Stdlib.app
                                                                                                                                  (all
                                                                                                                                    "obj.req"
                                                                                                                                      %
                                                                                                                                      string
                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                  (OCaml.Stdlib.app
                                                                                                                                    (all
                                                                                                                                      "tup"
                                                                                                                                        %
                                                                                                                                        string
                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                    (OCaml.Stdlib.app
                                                                                                                                      (all
                                                                                                                                        "obj.variable"
                                                                                                                                          %
                                                                                                                                          string
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                      (OCaml.Stdlib.app
                                                                                                                                        (all
                                                                                                                                          "tup.variable"
                                                                                                                                            %
                                                                                                                                            string
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                        (OCaml.Stdlib.app
                                                                                                                                          (all
                                                                                                                                            "obj.variable_left"
                                                                                                                                              %
                                                                                                                                              string
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                          (OCaml.Stdlib.app
                                                                                                                                            (all
                                                                                                                                              "tup.variable_left"
                                                                                                                                                %
                                                                                                                                                string
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                            (OCaml.Stdlib.app
                                                                                                                                              (all
                                                                                                                                                "union.A"
                                                                                                                                                  %
                                                                                                                                                  string
                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                              (OCaml.Stdlib.app
                                                                                                                                                (all
                                                                                                                                                  "union.B"
                                                                                                                                                    %
                                                                                                                                                    string
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                (OCaml.Stdlib.app
                                                                                                                                                  (all
                                                                                                                                                    "union.C"
                                                                                                                                                      %
                                                                                                                                                      string
                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                  (OCaml.Stdlib.app
                                                                                                                                                    (all
                                                                                                                                                      "union.D"
                                                                                                                                                        %
                                                                                                                                                        string
                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                    (OCaml.Stdlib.app
                                                                                                                                                      (all
                                                                                                                                                        "union.E"
                                                                                                                                                          %
                                                                                                                                                          string
                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                      (OCaml.Stdlib.app
                                                                                                                                                        (all
                                                                                                                                                          "variable_list.empty"
                                                                                                                                                            %
                                                                                                                                                            string
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                          (Tezos_data_encoding.Data_encoding.Variable.list
                                                                                                                                                            None
                                                                                                                                                            Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                          [])
                                                                                                                                                        (OCaml.Stdlib.app
                                                                                                                                                          (all
                                                                                                                                                            "variable_list"
                                                                                                                                                              %
                                                                                                                                                              string
                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                            (Tezos_data_encoding.Data_encoding.Variable.list
                                                                                                                                                              None
                                                                                                                                                              Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                            (cons
                                                                                                                                                              1
                                                                                                                                                              (cons
                                                                                                                                                                2
                                                                                                                                                                (cons
                                                                                                                                                                  3
                                                                                                                                                                  (cons
                                                                                                                                                                    4
                                                                                                                                                                    (cons
                                                                                                                                                                      5
                                                                                                                                                                      []))))))
                                                                                                                                                          (OCaml.Stdlib.app
                                                                                                                                                            (all
                                                                                                                                                              "variable_array.empty"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                              (Tezos_data_encoding.Data_encoding.Variable.array
                                                                                                                                                                None
                                                                                                                                                                Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                              tt)
                                                                                                                                                            (OCaml.Stdlib.app
                                                                                                                                                              (all
                                                                                                                                                                "variable_array"
                                                                                                                                                                  %
                                                                                                                                                                  string
                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                (Tezos_data_encoding.Data_encoding.Variable.array
                                                                                                                                                                  None
                                                                                                                                                                  Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                                (1,
                                                                                                                                                                  2,
                                                                                                                                                                  3,
                                                                                                                                                                  4,
                                                                                                                                                                  5))
                                                                                                                                                              (OCaml.Stdlib.app
                                                                                                                                                                (all
                                                                                                                                                                  "list.empty"
                                                                                                                                                                    %
                                                                                                                                                                    string
                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  (Tezos_data_encoding.Data_encoding.list
                                                                                                                                                                    None
                                                                                                                                                                    Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                                  [])
                                                                                                                                                                (OCaml.Stdlib.app
                                                                                                                                                                  (all
                                                                                                                                                                    "list"
                                                                                                                                                                      %
                                                                                                                                                                      string
                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                    (Tezos_data_encoding.Data_encoding.list
                                                                                                                                                                      None
                                                                                                                                                                      Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                                    (cons
                                                                                                                                                                      1
                                                                                                                                                                      (cons
                                                                                                                                                                        2
                                                                                                                                                                        (cons
                                                                                                                                                                          3
                                                                                                                                                                          (cons
                                                                                                                                                                            4
                                                                                                                                                                            (cons
                                                                                                                                                                              5
                                                                                                                                                                              []))))))
                                                                                                                                                                  (OCaml.Stdlib.app
                                                                                                                                                                    (all
                                                                                                                                                                      "array.empty"
                                                                                                                                                                        %
                                                                                                                                                                        string
                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                      (Tezos_data_encoding.Data_encoding.array
                                                                                                                                                                        None
                                                                                                                                                                        Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                                      tt)
                                                                                                                                                                    (OCaml.Stdlib.app
                                                                                                                                                                      (all
                                                                                                                                                                        "array"
                                                                                                                                                                          %
                                                                                                                                                                          string
                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                        (Tezos_data_encoding.Data_encoding.array
                                                                                                                                                                          None
                                                                                                                                                                          Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                                        (1,
                                                                                                                                                                          2,
                                                                                                                                                                          3,
                                                                                                                                                                          4,
                                                                                                                                                                          5))
                                                                                                                                                                      (OCaml.Stdlib.app
                                                                                                                                                                        (all
                                                                                                                                                                          "mu_list.empty"
                                                                                                                                                                            %
                                                                                                                                                                            string
                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                            Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                                          [])
                                                                                                                                                                        (OCaml.Stdlib.app
                                                                                                                                                                          (all
                                                                                                                                                                            "mu_list"
                                                                                                                                                                              %
                                                                                                                                                                              string
                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                              Tezos_data_encoding.Data_encoding.int31)
                                                                                                                                                                            (cons
                                                                                                                                                                              1
                                                                                                                                                                              (cons
                                                                                                                                                                                2
                                                                                                                                                                                (cons
                                                                                                                                                                                  3
                                                                                                                                                                                  (cons
                                                                                                                                                                                    4
                                                                                                                                                                                    (cons
                                                                                                                                                                                      5
                                                                                                                                                                                      []))))))
                                                                                                                                                                          (OCaml.Stdlib.app
                                                                                                                                                                            test_bounded_string_list
                                                                                                                                                                            (cons
                                                                                                                                                                              ("string_enum_boundary"
                                                                                                                                                                                %
                                                                                                                                                                                string,
                                                                                                                                                                                variant,
                                                                                                                                                                                test_string_enum_boundary)
                                                                                                                                                                              []))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).
src/lib_data_encoding/test/test.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Random.init 100 ;
  Alcotest.run
    "tezos-data-encoding"
    [ ("success", Success.tests);
      ("invalid_encoding", Invalid_encoding.tests);
      ("read_failure", Read_failure.tests);
      ("write_failure", Write_failure.tests);
      ("randomized", Randomized.tests);
      ("versioned", Versioned.tests) ]
src/lib_data_encoding/test/test.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_data_encoding/test/test_generated.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* NOTE: the current release of Crowbar, v0.1, is quite limited. Several
 * improvements have been made to the dev version which will make it possible to
 * simplify this file and increase coverage.
 * For now, this is a limited test-suite. *)

let char = Crowbar.map [Crowbar.uint8] Char.chr

let string = Crowbar.bytes

(* The v0.1 of Crowbar doesn't have fixed-size string generation. When we
 * update Crowbar, we can improve this generator. *)
let short_string =
  let open Crowbar in
  choose
    [ const "";
      map [char] (fun c -> String.make 1 c);
      map [char; char; char; char] (fun c1 c2 c3 c4 ->
          let s = Bytes.make 4 c1 in
          Bytes.set s 1 c2 ;
          Bytes.set s 2 c3 ;
          Bytes.set s 3 c4 ;
          Bytes.to_string s) ]

let short_string1 =
  let open Crowbar in
  choose
    [ map [char] (fun c -> String.make 1 c);
      map [char; char; char; char] (fun c1 c2 c3 c4 ->
          let s = Bytes.make 4 c1 in
          Bytes.set s 1 c2 ;
          Bytes.set s 2 c3 ;
          Bytes.set s 3 c4 ;
          Bytes.to_string s) ]

let mbytes = Crowbar.map [Crowbar.bytes] Bytes.of_string

let short_mbytes = Crowbar.map [short_string] Bytes.of_string

let short_mbytes1 = Crowbar.map [short_string1] Bytes.of_string

(* We need to hide the type parameter of `Encoding.t` to avoid the generator
 * combinator `choose` from complaining about different types. We use first
 * level modules (for now) to encode existentials.
 *
 * An alternative is used in https://gitlab.com/gasche/fuzz-data-encoding *)

module type TESTABLE = sig
  type t

  val v : t

  val ding : t Data_encoding.t

  val pp : t Crowbar.printer
end

type testable = (module TESTABLE)

let null : testable =
  ( module struct
    type t = unit

    let v = ()

    let ding = Data_encoding.null

    let pp ppf () = Crowbar.pp ppf "(null)"
  end )

let empty : testable =
  ( module struct
    type t = unit

    let v = ()

    let ding = Data_encoding.empty

    let pp ppf () = Crowbar.pp ppf "(empty)"
  end )

let unit : testable =
  ( module struct
    type t = unit

    let v = ()

    let ding = Data_encoding.unit

    let pp ppf () = Crowbar.pp ppf "(unit)"
  end )

let map_constant (s : string) : testable =
  ( module struct
    type t = unit

    let v = ()

    let ding = Data_encoding.constant s

    let pp ppf () = Crowbar.pp ppf "\"%s\"" s
  end )

let map_int8 (i : int) : testable =
  ( module struct
    type t = int

    let v = i

    let ding = Data_encoding.int8

    let pp = Crowbar.pp_int
  end )

let map_uint8 (i : int) : testable =
  ( module struct
    type t = int

    let v = i

    let ding = Data_encoding.uint8

    let pp = Crowbar.pp_int
  end )

let map_int16 (i : int) : testable =
  ( module struct
    type t = int

    let v = i

    let ding = Data_encoding.int16

    let pp = Crowbar.pp_int
  end )

let map_uint16 (i : int) : testable =
  ( module struct
    type t = int

    let v = i

    let ding = Data_encoding.uint16

    let pp = Crowbar.pp_int
  end )

let map_int32 (i : int32) : testable =
  ( module struct
    type t = int32

    let v = i

    let ding = Data_encoding.int32

    let pp = Crowbar.pp_int32
  end )

let map_int64 (i : int64) : testable =
  ( module struct
    type t = int64

    let v = i

    let ding = Data_encoding.int64

    let pp = Crowbar.pp_int64
  end )

let map_range_int a b c : testable =
  let (small, middle, big) =
    match List.sort compare [a; b; c] with
    | [small; middle; big] ->
        assert (small <= middle) ;
        assert (middle <= big) ;
        (small, middle, big)
    | _ ->
        assert false
  in
  ( module struct
    type t = int

    let v = middle

    let ding = Data_encoding.ranged_int small big

    let pp ppf i = Crowbar.pp ppf "(%d :[%d;%d])" i small big
  end )

let map_range_float a b c : testable =
  if compare a nan = 0 || compare b nan = 0 || compare c nan = 0 then
    (* copout *)
    null
  else
    let (small, middle, big) =
      match List.sort compare [a; b; c] with
      | [small; middle; big] ->
          assert (small <= middle) ;
          assert (middle <= big) ;
          (small, middle, big)
      | _ ->
          assert false
    in
    ( module struct
      type t = float

      let v = middle

      let ding = Data_encoding.ranged_float small big

      let pp ppf i = Crowbar.pp ppf "(%f :[%f;%f])" i small big
    end )

let map_bool b : testable =
  ( module struct
    type t = bool

    let v = b

    let ding = Data_encoding.bool

    let pp = Crowbar.pp_bool
  end )

let map_string s : testable =
  ( module struct
    type t = string

    let v = s

    let ding = Data_encoding.string

    let pp = Crowbar.pp_string
  end )

let map_bytes s : testable =
  ( module struct
    type t = Bytes.t

    let v = s

    let ding = Data_encoding.bytes

    let pp ppf m =
      if Bytes.length m > 40 then
        Crowbar.pp
          ppf
          "@[<hv 1>%a … (%d more bytes)@]"
          Hex.pp
          (Hex.of_bytes (Bytes.sub m 1 30))
          (Bytes.length m)
      else Hex.pp ppf (Hex.of_bytes m)
  end )

let map_float f : testable =
  ( module struct
    type t = float

    let v = f

    let ding = Data_encoding.float

    let pp = Crowbar.pp_float
  end )

let map_fixed_string s : testable =
  ( module struct
    type t = string

    let v = s

    let ding = Data_encoding.Fixed.string (String.length s)

    let pp ppf s = Crowbar.pp ppf "\"%s\"" s
  end )

let map_fixed_bytes s : testable =
  ( module struct
    type t = Bytes.t

    let v = s

    let ding = Data_encoding.Fixed.bytes (Bytes.length s)

    let pp fmt x = Hex.pp fmt (Hex.of_bytes x)
  end )

let map_variable_string s : testable =
  ( module struct
    type t = string

    let v = s

    let ding = Data_encoding.Variable.string

    let pp ppf s = Crowbar.pp ppf "\"%s\"" s
  end )

let map_variable_bytes s : testable =
  ( module struct
    type t = Bytes.t

    let v = s

    let ding = Data_encoding.Variable.bytes

    let pp fmt x = Hex.pp fmt (Hex.of_bytes x)
  end )

(* And now combinators *)

let dyn_if_not ding =
  match Data_encoding.classify ding with
  | `Fixed _ | `Dynamic ->
      ding
  | `Variable ->
      Data_encoding.dynamic_size ding

let map_some (t : testable) : testable =
  let module T = (val t) in
  ( module struct
    type t = T.t option

    let v = Some T.v

    let ding =
      try Data_encoding.option T.ding
      with Invalid_argument _ -> Crowbar.bad_test ()

    let pp ppf o =
      Crowbar.pp
        ppf
        "@[<hv 1>%a@]"
        (fun fmt v ->
          match v with
          | None ->
              Format.fprintf fmt "None"
          | Some v ->
              Format.fprintf fmt "Some(%a)" T.pp v)
        o
  end )

let map_none (t : testable) : testable =
  let module T = (val t) in
  ( module struct
    type t = T.t option

    let v = None

    let ding =
      try Data_encoding.option T.ding
      with Invalid_argument _ -> Crowbar.bad_test ()

    let pp ppf o =
      Crowbar.pp
        ppf
        "@[<hv 1>%a@]"
        (fun fmt v ->
          match v with
          | None ->
              Format.fprintf fmt "None"
          | Some v ->
              Format.fprintf fmt "Some(%a)" T.pp v)
        o
  end )

let map_ok (t_o : testable) (t_e : testable) : testable =
  let module T_O = (val t_o) in
  let module T_E = (val t_e) in
  ( module struct
    type t = (T_O.t, T_E.t) result

    let v = Ok T_O.v

    let ding = Data_encoding.result T_O.ding T_E.ding

    let pp ppf r =
      Crowbar.pp
        ppf
        "@[<hv 1>%a@]"
        (fun fmt r ->
          match r with
          | Ok o ->
              Format.fprintf fmt "Ok(%a)" T_O.pp o
          | Error e ->
              Format.fprintf fmt "Error(%a)" T_E.pp e)
        r
  end )

let map_error (t_o : testable) (t_e : testable) : testable =
  let module T_O = (val t_o) in
  let module T_E = (val t_e) in
  ( module struct
    type t = (T_O.t, T_E.t) result

    let v = Error T_E.v

    let ding = Data_encoding.result T_O.ding T_E.ding

    let pp ppf r =
      Crowbar.pp
        ppf
        "@[<hv 1>%a@]"
        (fun fmt r ->
          match r with
          | Ok o ->
              Format.fprintf fmt "Ok(%a)" T_O.pp o
          | Error e ->
              Format.fprintf fmt "Error(%a)" T_E.pp e)
        r
  end )

let map_variable_list (t : testable) (ts : testable list) : testable =
  let module T = (val t) in
  ( module struct
    type t = T.t list

    let ding = Data_encoding.Variable.list (dyn_if_not T.ding)

    let v =
      List.fold_left
        (fun acc (t : testable) ->
          let module T = (val t) in
          (* We can get rid of this Obj when we update Crowbar *)
          Obj.magic T.v :: acc)
        []
        ts

    let pp = Crowbar.pp_list T.pp
  end )

let map_variable_array (t : testable) (ts : testable array) : testable =
  let module T = (val t) in
  ( module struct
    type t = T.t array

    let ding = Data_encoding.Variable.array (dyn_if_not T.ding)

    let v =
      Array.of_list
        (Array.fold_left
           (fun acc (t : testable) ->
             let module T = (val t) in
             Obj.magic T.v :: acc)
           []
           ts)

    let pp ppf a =
      if Array.length a > 40 then
        Crowbar.pp
          ppf
          "@[<hv 1>[|%a … (%d more elements)|]@]"
          (Format.pp_print_list
             ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
             T.pp)
          (Array.to_list (Array.sub a 0 30))
          (Array.length a)
      else
        Crowbar.pp
          ppf
          "@[<hv 1>[|%a|]@]"
          (Format.pp_print_list
             ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
             T.pp)
          (Array.to_list a)
  end )

let map_dynamic_size (t : testable) : testable =
  let module T = (val t) in
  ( module struct
    include T

    let ding = Data_encoding.dynamic_size T.ding
  end )

let map_tup1 (t1 : testable) : testable =
  let module T1 = (val t1) in
  ( module struct
    include T1

    let ding = Data_encoding.tup1 T1.ding

    let pp ppf v1 = Crowbar.pp ppf "@[<hv 1>(%a)@]" T1.pp v1
  end )

let map_tup2 (t1 : testable) (t2 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  ( module struct
    type t = T1.t * T2.t

    let ding = Data_encoding.tup2 (dyn_if_not T1.ding) T2.ding

    let v = (T1.v, T2.v)

    let pp ppf (v1, v2) = Crowbar.pp ppf "@[<hv 1>(%a, %a)@]" T1.pp v1 T2.pp v2
  end )

let map_tup3 (t1 : testable) (t2 : testable) (t3 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  ( module struct
    type t = T1.t * T2.t * T3.t

    let ding =
      Data_encoding.tup3 (dyn_if_not T1.ding) (dyn_if_not T2.ding) T3.ding

    let v = (T1.v, T2.v, T3.v)

    let pp ppf (v1, v2, v3) =
      Crowbar.pp ppf "@[<hv 1>(%a, %a, %a)@]" T1.pp v1 T2.pp v2 T3.pp v3
  end )

let map_tup4 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable) :
    testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t

    let ding =
      Data_encoding.tup4
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        T4.ding

    let v = (T1.v, T2.v, T3.v, T4.v)

    let pp ppf (v1, v2, v3, v4) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
  end )

let map_tup5 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t

    let ding =
      Data_encoding.tup5
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        T5.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v)

    let pp ppf (v1, v2, v3, v4, v5) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
  end )

let map_tup6 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t

    let ding =
      Data_encoding.tup6
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        T6.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v)

    let pp ppf (v1, v2, v3, v4, v5, v6) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
  end )

let map_tup7 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) (t7 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  let module T7 = (val t7) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t

    let ding =
      Data_encoding.tup7
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        (dyn_if_not T6.ding)
        T7.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v)

    let pp ppf (v1, v2, v3, v4, v5, v6, v7) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
        T7.pp
        v7
  end )

let map_tup8 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable) : testable
    =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  let module T7 = (val t7) in
  let module T8 = (val t8) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t

    let ding =
      Data_encoding.tup8
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        (dyn_if_not T6.ding)
        (dyn_if_not T7.ding)
        T8.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v)

    let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
        T7.pp
        v7
        T8.pp
        v8
  end )

let map_tup9 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
    (t9 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  let module T7 = (val t7) in
  let module T8 = (val t8) in
  let module T9 = (val t9) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t * T9.t

    let ding =
      Data_encoding.tup9
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        (dyn_if_not T6.ding)
        (dyn_if_not T7.ding)
        (dyn_if_not T8.ding)
        T9.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v, T9.v)

    let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8, v9) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
        T7.pp
        v7
        T8.pp
        v8
        T9.pp
        v9
  end )

let map_tup10 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
    (t9 : testable) (t10 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  let module T7 = (val t7) in
  let module T8 = (val t8) in
  let module T9 = (val t9) in
  let module T10 = (val t10) in
  ( module struct
    type t =
      T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t * T9.t * T10.t

    let ding =
      Data_encoding.tup10
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        (dyn_if_not T6.ding)
        (dyn_if_not T7.ding)
        (dyn_if_not T8.ding)
        (dyn_if_not T9.ding)
        T10.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v, T9.v, T10.v)

    let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
        T7.pp
        v7
        T8.pp
        v8
        T9.pp
        v9
        T10.pp
        v10
  end )

let map_merge_tups (t1 : testable) (t2 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  ( module struct
    type t = T1.t * T2.t

    let ding =
      Data_encoding.merge_tups (dyn_if_not T1.ding) (dyn_if_not T2.ding)

    let v = (T1.v, T2.v)

    let pp ppf (v1, v2) = Crowbar.pp ppf "@[<hv 1>(%a, %a)@]" T1.pp v1 T2.pp v2
  end )

let testable_printer : testable Crowbar.printer =
 fun ppf (t : testable) ->
  let module T = (val t) in
  T.pp ppf T.v

(* helpers to construct values tester values *)

(* Generator for testable values *)

let tup_gen (tgen : testable Crowbar.gen) : testable Crowbar.gen =
  let open Crowbar in
  (* Stack overflow if there are more levels *)
  with_printer testable_printer
  @@ choose
       [ map [tgen] map_tup1;
         map [tgen; tgen] map_tup2;
         map [tgen; tgen; tgen] map_tup3;
         map [tgen; tgen; tgen; tgen] map_tup4;
         map [tgen; tgen; tgen; tgen; tgen] map_tup5;
         map [tgen; tgen; tgen; tgen; tgen; tgen] map_tup6 ]

let gen =
  let open Crowbar in
  let g : testable Crowbar.gen =
    fix (fun g ->
        choose
          [ const null;
            const empty;
            const unit;
            map [short_string] map_constant;
            map [int8] map_int8;
            map [uint8] map_uint8;
            (* TODO: use newer version of crowbar to get these generators
              map [int16] map_int16;
              map [uint16] map_uint16;
        *)
            map [int32] map_int32;
            map [int64] map_int64;
            (* NOTE: the int encoding require ranges to be 30-bit compatible *)
            map [int8; int8; int8] map_range_int;
            map [float; float; float] map_range_float;
            map [bool] map_bool;
            map [short_string] map_string;
            map [short_mbytes] map_bytes;
            map [float] map_float;
            map [short_string1] map_fixed_string;
            map [short_mbytes1] map_fixed_bytes;
            map [short_string] map_variable_string;
            map [short_mbytes] map_variable_bytes;
            map [g] map_some;
            map [g] map_none;
            map [g] map_dynamic_size;
            map [g] map_tup1;
            map [g; g] map_tup2;
            map [g; g; g] map_tup3;
            map [g; g; g; g] map_tup4;
            map [g; g; g; g; g] map_tup5;
            map [g; g; g; g; g; g] map_tup6;
            map [g; g] (fun t1 t2 ->
                map_merge_tups (map_tup1 t1) (map_tup1 t2));
            map [g; g; g] (fun t1 t2 t3 ->
                map_merge_tups (map_tup2 t1 t2) (map_tup1 t3));
            map [g; g; g] (fun t1 t2 t3 ->
                map_merge_tups (map_tup1 t1) (map_tup2 t2 t3))
            (* NOTE: we cannot use lists/arrays for now. They require the
           data-inside to be homogeneous (e.g., same rangedness of ranged
           numbers) which we cannot guarantee right now. This can be fixed once
           we update Crowbar and get access to the new `dynamic_bind` generator
           combinator.

           map [g; list g] map_variable_list;
           map [g; list g] (fun t ts -> map_variable_array t (Array.of_list ts));
        *)
           ])
  in
  with_printer testable_printer g

(* TODO: The following features are not yet tested
   val string_enum : (string * 'a) list -> 'a encoding
   val delayed : (unit -> 'a encoding) -> 'a encoding
   val json : json encoding
   val json_schema : json_schema encoding
   type 'a field
   val req :
   ?title:string -> ?description:string ->
   string -> 't encoding -> 't field
   val opt :
   ?title:string -> ?description:string ->
   string -> 't encoding -> 't option field
   val varopt :
   ?title:string -> ?description:string ->
   string -> 't encoding -> 't option field
   val dft :
   ?title:string -> ?description:string ->
   string -> 't encoding -> 't -> 't field
   val obj1 : 'f1 field -> 'f1 encoding
   val obj2 : 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding
   val obj3 : 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding
   val obj4 :
   val obj5 :
   val obj6 :
   val obj7 :
   val obj8 :
   val obj9 :
   val obj10 :
   val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding
   val array : 'a encoding -> 'a array encoding
   val list : 'a encoding -> 'a list encoding
   val assoc : 'a encoding -> (string * 'a) list encoding
   type 't case
   type case_tag = Tag of int | Json_only
   val case : case_tag -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
   val union : ?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding

*)

(* Basic functions for executing tests on a given input *)
let roundtrip_json pp ding v =
  let json =
    try Data_encoding.Json.construct ding v
    with Invalid_argument m ->
      Crowbar.fail (Format.asprintf "Cannot construct: %a (%s)" pp v m)
  in
  let vv =
    try Data_encoding.Json.destruct ding json
    with Data_encoding.Json.Cannot_destruct (_, _) ->
      Crowbar.fail "Cannot destruct"
  in
  Crowbar.check_eq ~pp v vv

let roundtrip_binary pp ding v =
  let bin =
    try Data_encoding.Binary.to_bytes_exn ding v
    with Data_encoding.Binary.Write_error we ->
      Format.kasprintf
        Crowbar.fail
        "Cannot construct: %a (%a)"
        pp
        v
        Data_encoding.Binary.pp_write_error
        we
  in
  let vv =
    try Data_encoding.Binary.of_bytes_exn ding bin
    with Data_encoding.Binary.Read_error re ->
      Format.kasprintf
        Crowbar.fail
        "Cannot destruct: %a (%a)"
        pp
        v
        Data_encoding.Binary.pp_read_error
        re
  in
  Crowbar.check_eq ~pp v vv

(* Setting up the actual tests *)
let test_testable_json (testable : testable) =
  let module T = (val testable) in
  roundtrip_json T.pp T.ding T.v

let test_testable_binary (testable : testable) =
  let module T = (val testable) in
  roundtrip_binary T.pp T.ding T.v

let () =
  Crowbar.add_test ~name:"binary roundtrips" [gen] test_testable_binary ;
  Crowbar.add_test ~name:"json roundtrips" [gen] test_testable_json ;
  ()
src/lib_data_encoding/test/test_generated.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition char {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []) Stdlib.Char.chr.

Definition string {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition short_string {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition short_string1 {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition mbytes {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []) Stdlib.Bytes.of_string.

Definition short_mbytes {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star (cons short_string [])
    Stdlib.Bytes.of_string.

Definition short_mbytes1 {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star (cons short_string1 [])
    Stdlib.Bytes.of_string.

Module TESTABLE.
  Record signature {t : Type} := {
    t := t;
    v : t;
    ding : Tezos_data_encoding.Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End TESTABLE.

Definition testable := {t : _ & TESTABLE.signature t}.

Definition null : testable :=
  existT _ _
    {|
      TESTABLE.v := tt;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.null
      |}.

Definition empty : testable :=
  existT _ _
    {|
      TESTABLE.v := tt;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.empty
      |}.

Definition unit : testable :=
  existT _ _
    {|
      TESTABLE.v := tt;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.unit
      |}.

Definition map_constant (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := tt;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.constant s
      |}.

Definition map_int8 (i : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.int8
      |}.

Definition map_uint8 (i : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.uint8
      |}.

Definition map_int16 (i : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.int16
      |}.

Definition map_uint16 (i : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.uint16
      |}.

Definition map_int32 (i : int32) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.int32
      |}.

Definition map_int64 (i : int64) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.int64
      |}.

Definition map_range_int (a : Z) (b : Z) (c : Z) : testable :=
  match
    match Stdlib.List.sort OCaml.Stdlib.compare (cons a (cons b (cons c [])))
      with
    | cons small (cons middle (cons big [])) =>
      OCaml.Stdlib.le small middle;
      OCaml.Stdlib.le middle big;
      (small, middle, big)
    | _ => false
    end with
  | (small, middle, big) =>
    existT _ _
      {|
        TESTABLE.v := middle;
        TESTABLE.ding := Tezos_data_encoding.Data_encoding.ranged_int small big
        |}
  end.

Definition map_range_float (a : float) (b : float) (c : float) : testable :=
  if
    orb (equiv_decb (OCaml.Stdlib.compare a Stdlib.nan) 0)
      (orb (equiv_decb (OCaml.Stdlib.compare b Stdlib.nan) 0)
        (equiv_decb (OCaml.Stdlib.compare c Stdlib.nan) 0)) then
    null
  else
    match
      match Stdlib.List.sort OCaml.Stdlib.compare (cons a (cons b (cons c [])))
        with
      | cons small (cons middle (cons big [])) =>
        OCaml.Stdlib.le small middle;
        OCaml.Stdlib.le middle big;
        (small, middle, big)
      | _ => false
      end with
    | (small, middle, big) =>
      existT _ _
        {|
          TESTABLE.v := middle;
          TESTABLE.ding :=
            Tezos_data_encoding.Data_encoding.ranged_float small big
          |}
    end.

Definition map_bool (b : bool) : testable :=
  existT _ _
    {|
      TESTABLE.v := b;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.bool
      |}.

Definition map_string (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.string
      |}.

Definition map_bytes (s : Stdlib.Bytes.t) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.bytes
      |}.

Definition map_float (f : float) : testable :=
  existT _ _
    {|
      TESTABLE.v := f;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.float
      |}.

Definition map_fixed_string (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.Fixed.string (OCaml.String.length s)
      |}.

Definition map_fixed_bytes (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.Fixed.bytes (String.length s)
      |}.

Definition map_variable_string (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.Variable.string
      |}.

Definition map_variable_bytes (s : Stdlib.Bytes.t) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.Variable.bytes
      |}.

Definition dyn_if_not {A : Type}
  (ding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding A :=
  match Tezos_data_encoding.Data_encoding.classify ding with
  | Fixed _ | Dynamic => ding
  | Variable => Tezos_data_encoding.Data_encoding.dynamic_size None ding
  end.

Definition map_some (t : testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      TESTABLE.v := Some T.(TESTABLE.v);
      TESTABLE.ding := try
      |}.

Definition map_none (t : testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      TESTABLE.ding := try
      |}.

Definition map_ok (t_o : testable) (t_e : testable) : testable :=
  let T_O := projT2 t_o in
  let T_E := projT2 t_e in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.result T_O.(TESTABLE.ding)
          T_E.(TESTABLE.ding)
      |}.

Definition map_error (t_o : testable) (t_e : testable) : testable :=
  let T_O := projT2 t_o in
  let T_E := projT2 t_e in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.result T_O.(TESTABLE.ding)
          T_E.(TESTABLE.ding)
      |}.

Definition map_variable_list (t : testable) (ts : list testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.Variable.list None
          (dyn_if_not T.(TESTABLE.ding))
      |}.

Definition map_variable_array (t : testable) (ts : array testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.Variable.array None
          (dyn_if_not T.(TESTABLE.ding));
      TESTABLE.v :=
        Stdlib.Array.of_list
          (Stdlib.Array.fold_left
            (fun acc =>
              fun t =>
                let T := projT2 t in
                cons (Stdlib.Obj.magic T.(TESTABLE.v)) acc) [] ts)
      |}.

Definition map_dynamic_size (t : testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.dynamic_size None T.(TESTABLE.ding)
      |}.

Definition map_tup1 (t1 : testable) : testable :=
  let T1 := projT2 t1 in
  existT _ _
    {|
      TESTABLE.ding := Tezos_data_encoding.Data_encoding.tup1 T1.(TESTABLE.ding)
      |}.

Definition map_tup2 (t1 : testable) (t2 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup2 (dyn_if_not T1.(TESTABLE.ding))
          T2.(TESTABLE.ding);
      TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v))
      |}.

Definition map_tup3 (t1 : testable) (t2 : testable) (t3 : testable)
  : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup3 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) T3.(TESTABLE.ding);
      TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v))
      |}.

Definition map_tup4
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup4 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          T4.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v))
      |}.

Definition map_tup5
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup5 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) T5.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v))
      |}.

Definition map_tup6
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup6 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          T6.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v))
      |}.

Definition map_tup7
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) (t7 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  let T7 := projT2 t7 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup7 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          (dyn_if_not T6.(TESTABLE.ding)) T7.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v))
      |}.

Definition map_tup8
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  let T7 := projT2 t7 in
  let T8 := projT2 t8 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup8 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          (dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
          T8.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v))
      |}.

Definition map_tup9
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
  (t9 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  let T7 := projT2 t7 in
  let T8 := projT2 t8 in
  let T9 := projT2 t9 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup9 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          (dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
          (dyn_if_not T8.(TESTABLE.ding)) T9.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v),
          T9.(TESTABLE.v))
      |}.

Definition map_tup10
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
  (t9 : testable) (t10 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  let T7 := projT2 t7 in
  let T8 := projT2 t8 in
  let T9 := projT2 t9 in
  let T10 := projT2 t10 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.tup10 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          (dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
          (dyn_if_not T8.(TESTABLE.ding)) (dyn_if_not T9.(TESTABLE.ding))
          T10.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v),
          T9.(TESTABLE.v), T10.(TESTABLE.v))
      |}.

Definition map_merge_tups (t1 : testable) (t2 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  existT _ _
    {|
      TESTABLE.ding :=
        Tezos_data_encoding.Data_encoding.merge_tups
          (dyn_if_not T1.(TESTABLE.ding)) (dyn_if_not T2.(TESTABLE.ding));
      TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v))
      |}.

Definition tup_gen {A B : Type} (function_parameter : A) : B :=
  match function_parameter with
  | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition gen {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition roundtrip_json {A B : Type}
  (pp : Stdlib.Format.formatter -> A -> unit)
  (ding : Tezos_data_encoding__Data_encoding.Encoding.t A) (v : A) : B :=
  let json := try in
  let vv := try in
  op_star_t_y_p_e_minus_e_r_r_o_r_star pp v vv.

Definition roundtrip_binary {A B : Type}
  (pp : Stdlib.Format.formatter -> A -> unit)
  (ding : Tezos_data_encoding__Data_encoding.Encoding.t A) (v : A) : B :=
  let bin := try in
  let vv := try in
  op_star_t_y_p_e_minus_e_r_r_o_r_star pp v vv.

Definition test_testable_json {A : Type} (testable : testable) : A :=
  let T := projT2 testable in
  roundtrip_json op_star_t_y_p_e_minus_e_r_r_o_r_star T.(TESTABLE.ding)
    T.(TESTABLE.v).

Definition test_testable_binary {A : Type} (testable : testable) : A :=
  let T := projT2 testable in
  roundtrip_binary op_star_t_y_p_e_minus_e_r_r_o_r_star T.(TESTABLE.ding)
    T.(TESTABLE.v).
src/lib_data_encoding/test/types.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

type record = {a : int; b : bool; c : Z.t option; d : float}

let default_record = {a = 32; b = true; c = Some Z.one; d = 12.34}

let record_obj_enc =
  conv
    (fun {a; b; c; d} -> ((a, b), (c, d)))
    (fun ((a, b), (c, d)) -> {a; b; c; d})
    (merge_objs
       (obj2 (req "a" int31) (dft "b" bool false))
       (obj2 (opt "c" z) (req "d" float)))

let record_tup_enc =
  conv
    (fun {a; b; c; d} -> ((a, b, c), d))
    (fun ((a, b, c), d) -> {a; b; c; d})
    (merge_tups (tup3 int31 bool (option z)) (tup1 float))

let record_to_string {a; b; c; d} =
  let c = match c with None -> "none" | Some c -> Z.to_string c in
  Format.asprintf "(%d, %B, %s, %f)" a b c d

type variable_record = {p : int; q : Bytes.t}

let default_variable_record = {p = 23; q = Bytes.of_string "wwwxxyyzzz"}

let variable_record_obj_enc =
  conv
    (fun {p; q} -> (p, q))
    (fun (p, q) -> {p; q})
    (obj2 (req "p" int31) (req "q" Variable.bytes))

let variable_record_tup_enc =
  conv
    (fun {p; q} -> (p, q))
    (fun (p, q) -> {p; q})
    (tup2 int31 Variable.bytes)

let variable_record_to_string {p; q} =
  Format.asprintf "(%d, %a)" p Hex.pp (Hex.of_bytes q)

type variable_left_record = {x : int; y : Bytes.t; z : int}

let default_variable_left_record =
  {x = 98; y = Bytes.of_string "765"; z = 4321}

let variable_left_record_obj_enc =
  conv
    (fun {x; y; z} -> (x, y, z))
    (fun (x, y, z) -> {x; y; z})
    (obj3 (req "x" int31) (req "y" Variable.bytes) (req "z" int31))

let variable_left_record_tup_enc =
  conv
    (fun {x; y; z} -> (x, y, z))
    (fun (x, y, z) -> {x; y; z})
    (tup3 int31 Variable.bytes int31)

let variable_left_record_to_string {x; y; z} =
  Format.asprintf "(%d, %a, %d)" x Hex.pp (Hex.of_bytes y) z

type union = A of int | B of string | C of int | D of string | E

let union_enc =
  union
    [ case
        (Tag 1)
        ~title:"A"
        int8
        (function A i -> Some i | _ -> None)
        (fun i -> A i);
      case
        (Tag 2)
        ~title:"B"
        string
        (function B s -> Some s | _ -> None)
        (fun s -> B s);
      case
        (Tag 3)
        ~title:"C"
        (obj1 (req "C" int8))
        (function C i -> Some i | _ -> None)
        (fun i -> C i);
      case
        (Tag 4)
        ~title:"D"
        (obj2 (req "kind" (constant "D")) (req "data" string))
        (function D s -> Some ((), s) | _ -> None)
        (fun ((), s) -> D s);
      case
        (Tag 5)
        ~title:"E"
        empty
        (function E -> Some () | _ -> None)
        (fun () -> E) ]

let mini_union_enc =
  union
    [ case
        (Tag 1)
        ~title:"A"
        int8
        (function A i -> Some i | _ -> None)
        (fun i -> A i) ]

let union_to_string = function
  | A i ->
      Printf.sprintf "A %d" i
  | B s ->
      Printf.sprintf "B %s" s
  | C i ->
      Printf.sprintf "C %d" i
  | D s ->
      Printf.sprintf "D %s" s
  | E ->
      "E"

let enum_enc =
  string_enum
    [("one", 1); ("two", 2); ("three", 3); ("four", 4); ("five", 5); ("six", 6)]

let mini_enum_enc = string_enum [("one", 1); ("two", 2)]

let mu_list_enc enc =
  mu "list"
  @@ fun mu_list_enc ->
  union
    [ case
        (Tag 0)
        ~title:"Nil"
        empty
        (function [] -> Some () | _ :: _ -> None)
        (fun () -> []);
      case
        (Tag 1)
        ~title:"Cons"
        (obj2 (req "value" enc) (req "next" mu_list_enc))
        (function x :: xs -> Some (x, xs) | [] -> None)
        (fun (x, xs) -> x :: xs) ]

let bounded_list ~total ~elements enc =
  check_size total (Variable.list (check_size elements enc))

module Alcotest = struct
  include Alcotest

  let float =
    testable Fmt.float (fun f1 f2 ->
        match (classify_float f1, classify_float f2) with
        | (FP_nan, FP_nan) ->
            true
        | _ ->
            f1 = f2)

  let bytes =
    testable
      (Fmt.of_to_string (fun s ->
           let (`Hex s) = Hex.of_bytes s in
           s))
      Bytes.equal

  let z = testable (Fmt.of_to_string Z.to_string) Z.equal

  let n = z

  let record = testable (Fmt.of_to_string record_to_string) ( = )

  let variable_record =
    testable (Fmt.of_to_string variable_record_to_string) ( = )

  let variable_left_record =
    testable (Fmt.of_to_string variable_left_record_to_string) ( = )

  let union = testable (Fmt.of_to_string union_to_string) ( = )
end
src/lib_data_encoding/test/types.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Data_encoding.

Record record := {
  a : Z;
  b : bool;
  c : option Z.t;
  d : float }.

Definition default_record : record :=
  {| a := 32; b := true; c := Some Z.one; d := 12 |}.

Definition record_obj_enc : Tezos_data_encoding.Data_encoding.encoding record :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| a := a; b := b; c := c; d := d |} => ((a, b), (c, d))
      end)
    (fun function_parameter =>
      match function_parameter with
      | ((a, b), (c, d)) => {| a := a; b := b; c := c; d := d |}
      end) None
    (Tezos_data_encoding.Data_encoding.merge_objs
      (Tezos_data_encoding.Data_encoding.obj2
        (Tezos_data_encoding.Data_encoding.req None None "a" % string
          Tezos_data_encoding.Data_encoding.int31)
        (Tezos_data_encoding.Data_encoding.dft None None "b" % string
          Tezos_data_encoding.Data_encoding.bool false))
      (Tezos_data_encoding.Data_encoding.obj2
        (Tezos_data_encoding.Data_encoding.opt None None "c" % string
          Tezos_data_encoding.Data_encoding.z)
        (Tezos_data_encoding.Data_encoding.req None None "d" % string
          Tezos_data_encoding.Data_encoding.float))).

Definition record_tup_enc : Tezos_data_encoding.Data_encoding.encoding record :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| a := a; b := b; c := c; d := d |} => ((a, b, c), d)
      end)
    (fun function_parameter =>
      match function_parameter with
      | ((a, b, c), d) => {| a := a; b := b; c := c; d := d |}
      end) None
    (Tezos_data_encoding.Data_encoding.merge_tups
      (Tezos_data_encoding.Data_encoding.tup3
        Tezos_data_encoding.Data_encoding.int31
        Tezos_data_encoding.Data_encoding.bool
        (Tezos_data_encoding.Data_encoding.option
          Tezos_data_encoding.Data_encoding.z))
      (Tezos_data_encoding.Data_encoding.tup1
        Tezos_data_encoding.Data_encoding.float)).

Definition record_to_string (function_parameter : record) : string :=
  match function_parameter with
  | {| a := a; b := b; c := c; d := d |} =>
    let c :=
      match c with
      | None => "none" % string
      | Some c => Z.to_string c
      end in
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal ", " % string
              (CamlinternalFormatBasics.Bool CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal ", " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal ", " % string
                      (CamlinternalFormatBasics.Float
                        CamlinternalFormatBasics.Float_f
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))))))))
        "(%d, %B, %s, %f)" % string) a b c d
  end.

Record variable_record := {
  p : Z;
  q : Stdlib.Bytes.t }.

Definition default_variable_record : variable_record :=
  {| p := 23; q := Stdlib.Bytes.of_string "wwwxxyyzzz" % string |}.

Definition variable_record_obj_enc
  : Tezos_data_encoding.Data_encoding.encoding variable_record :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| p := p; q := q |} => (p, q)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (p, q) => {| p := p; q := q |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj2
      (Tezos_data_encoding.Data_encoding.req None None "p" % string
        Tezos_data_encoding.Data_encoding.int31)
      (Tezos_data_encoding.Data_encoding.req None None "q" % string
        Tezos_data_encoding.Data_encoding.Variable.bytes)).

Definition variable_record_tup_enc
  : Tezos_data_encoding.Data_encoding.encoding variable_record :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| p := p; q := q |} => (p, q)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (p, q) => {| p := p; q := q |}
      end) None
    (Tezos_data_encoding.Data_encoding.tup2
      Tezos_data_encoding.Data_encoding.int31
      Tezos_data_encoding.Data_encoding.Variable.bytes).

Definition variable_record_to_string (function_parameter : variable_record)
  : string :=
  match function_parameter with
  | {| p := p; q := q |} =>
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal ", " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "(%d, %a)" % string) p Hex.pp (Hex.of_bytes None q)
  end.

Record variable_left_record := {
  x : Z;
  y : Stdlib.Bytes.t;
  z : Z }.

Definition default_variable_left_record : variable_left_record :=
  {| x := 98; y := Stdlib.Bytes.of_string "765" % string; z := 4321 |}.

Definition variable_left_record_obj_enc
  : Tezos_data_encoding.Data_encoding.encoding variable_left_record :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| x := x; y := y; z := z |} => (x, y, z)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (x, y, z) => {| x := x; y := y; z := z |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj3
      (Tezos_data_encoding.Data_encoding.req None None "x" % string
        Tezos_data_encoding.Data_encoding.int31)
      (Tezos_data_encoding.Data_encoding.req None None "y" % string
        Tezos_data_encoding.Data_encoding.Variable.bytes)
      (Tezos_data_encoding.Data_encoding.req None None "z" % string
        Tezos_data_encoding.Data_encoding.int31)).

Definition variable_left_record_tup_enc
  : Tezos_data_encoding.Data_encoding.encoding variable_left_record :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| x := x; y := y; z := z |} => (x, y, z)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (x, y, z) => {| x := x; y := y; z := z |}
      end) None
    (Tezos_data_encoding.Data_encoding.tup3
      Tezos_data_encoding.Data_encoding.int31
      Tezos_data_encoding.Data_encoding.Variable.bytes
      Tezos_data_encoding.Data_encoding.int31).

Definition variable_left_record_to_string
  (function_parameter : variable_left_record) : string :=
  match function_parameter with
  | {| x := x; y := y; z := z |} =>
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal ", " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal ", " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format)))))))
        "(%d, %a, %d)" % string) x Hex.pp (Hex.of_bytes None y) z
  end.

Inductive union : Type :=
| A : Z -> union
| B : string -> union
| C : Z -> union
| D : string -> union
| E : union.

Definition union_enc : Tezos_data_encoding.Data_encoding.encoding union :=
  Tezos_data_encoding.Data_encoding.union None
    (cons
      (Tezos_data_encoding.Data_encoding.case "A" % string None (Tag 1)
        Tezos_data_encoding.Data_encoding.int8
        (fun function_parameter =>
          match function_parameter with
          | A i => Some i
          | _ => None
          end) (fun i => A i))
      (cons
        (Tezos_data_encoding.Data_encoding.case "B" % string None (Tag 2)
          Tezos_data_encoding.Data_encoding.string
          (fun function_parameter =>
            match function_parameter with
            | B s => Some s
            | _ => None
            end) (fun s => B s))
        (cons
          (Tezos_data_encoding.Data_encoding.case "C" % string None (Tag 3)
            (Tezos_data_encoding.Data_encoding.obj1
              (Tezos_data_encoding.Data_encoding.req None None "C" % string
                Tezos_data_encoding.Data_encoding.int8))
            (fun function_parameter =>
              match function_parameter with
              | C i => Some i
              | _ => None
              end) (fun i => C i))
          (cons
            (Tezos_data_encoding.Data_encoding.case "D" % string None (Tag 4)
              (Tezos_data_encoding.Data_encoding.obj2
                (Tezos_data_encoding.Data_encoding.req None None "kind" % string
                  (Tezos_data_encoding.Data_encoding.constant "D" % string))
                (Tezos_data_encoding.Data_encoding.req None None "data" % string
                  Tezos_data_encoding.Data_encoding.string))
              (fun function_parameter =>
                match function_parameter with
                | D s => Some (tt, s)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (tt, s) => D s
                end))
            (cons
              (Tezos_data_encoding.Data_encoding.case "E" % string None (Tag 5)
                Tezos_data_encoding.Data_encoding.empty
                (fun function_parameter =>
                  match function_parameter with
                  | E => Some tt
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => E
                  end)) []))))).

Definition mini_union_enc : Tezos_data_encoding.Data_encoding.encoding union :=
  Tezos_data_encoding.Data_encoding.union None
    (cons
      (Tezos_data_encoding.Data_encoding.case "A" % string None (Tag 1)
        Tezos_data_encoding.Data_encoding.int8
        (fun function_parameter =>
          match function_parameter with
          | A i => Some i
          | _ => None
          end) (fun i => A i)) []).

Definition union_to_string (function_parameter : union) : string :=
  match function_parameter with
  | A i =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "A " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "A %d" % string) i
  | B s =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "B " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "B %s" % string) s
  | C i =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "C " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "C %d" % string) i
  | D s =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "D " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "D %s" % string) s
  | E => "E" % string
  end.

Definition enum_enc : Tezos_data_encoding.Data_encoding.encoding Z :=
  Tezos_data_encoding.Data_encoding.string_enum
    (cons ("one" % string, 1)
      (cons ("two" % string, 2)
        (cons ("three" % string, 3)
          (cons ("four" % string, 4)
            (cons ("five" % string, 5) (cons ("six" % string, 6) [])))))).

Definition mini_enum_enc : Tezos_data_encoding.Data_encoding.encoding Z :=
  Tezos_data_encoding.Data_encoding.string_enum
    (cons ("one" % string, 1) (cons ("two" % string, 2) [])).

Definition mu_list_enc {A : Type}
  (enc : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (list A) :=
  apply
    (let arg := Tezos_data_encoding.Data_encoding.mu "list" % string in
    fun eta => arg None None eta)
    (fun mu_list_enc =>
      Tezos_data_encoding.Data_encoding.union None
        (cons
          (Tezos_data_encoding.Data_encoding.case "Nil" % string None (Tag 0)
            Tezos_data_encoding.Data_encoding.empty
            (fun function_parameter =>
              match function_parameter with
              | [] => Some tt
              | cons _ _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => []
              end))
          (cons
            (Tezos_data_encoding.Data_encoding.case "Cons" % string None (Tag 1)
              (Tezos_data_encoding.Data_encoding.obj2
                (Tezos_data_encoding.Data_encoding.req None None
                  "value" % string enc)
                (Tezos_data_encoding.Data_encoding.req None None "next" % string
                  mu_list_enc))
              (fun function_parameter =>
                match function_parameter with
                | cons x xs => Some (x, xs)
                | [] => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (x, xs) => cons x xs
                end)) []))).

Definition bounded_list {A : Type}
  (total : Z) (elements : Z)
  (enc : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (list A) :=
  Tezos_data_encoding.Data_encoding.check_size total
    (Tezos_data_encoding.Data_encoding.Variable.list None
      (Tezos_data_encoding.Data_encoding.check_size elements enc)).

Module Alcotest.
  Definition float {A : Type} : A :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun f1 =>
        fun f2 =>
          match ((Stdlib.classify_float f1), (Stdlib.classify_float f2)) with
          | (FP_nan, FP_nan) => true
          | _ => equiv_decb f1 f2
          end).
  
  Definition bytes {A : Type} : A :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        (fun s =>
          match Hex.of_bytes None s with
          | Hex s => s
          end)) Stdlib.Bytes.equal.
  
  Definition z {A : Type} : A :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star Z.to_string) Z.equal.
  
  Definition n {A : Type} : A := z.
  
  Definition record {A : Type} : A :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star record_to_string) equiv_decb.
  
  Definition variable_record {A : Type} : A :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star variable_record_to_string)
      equiv_decb.
  
  Definition variable_left_record {A : Type} : A :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star variable_left_record_to_string)
      equiv_decb.
  
  Definition union {A : Type} : A :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star union_to_string) equiv_decb.
End Alcotest.
src/lib_data_encoding/test/versioned.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**
   Tests for the {!Data_encoding.With_version} module.
*)

(** This module is a simple example of use of {!With_version}. *)
module Documented_example = struct
  (** Here we show how to {i "versionize"} a given random encoding (which
      just happens to be very similar to {!Internal_event.Debug_event}). *)

  (** We are going to provide successive versions of a module
      implementing {!INTENDED_SIGNATURE} (which is similar to a
      simplified {!Internal_event.EVENT_DEFINITION}): *)
  module type INTENDED_SIGNATURE = sig
    type t

    val encoding : t Data_encoding.t

    val pp : Format.formatter -> t -> unit
  end

  (** The name, once used with {!With_version.encoding}, appears in
      the serialized values, it has to remain constant across versions: *)
  let name = "versioned-documented-example"

  (** The first version has a [(string * string) list] field. *)
  module V0 = struct
    type t = {message : string; attachment : (string * string) list}

    (** This is the "naked" (i.e. non-versioned) encoding of version-0: *)
    let encoding =
      let open Data_encoding in
      conv
        (fun {message; attachment} -> (message, attachment))
        (fun (message, attachment) -> {message; attachment})
        (obj2 (req "message" string) (req "attach" (list (tup2 string string))))
  end

  (** The versioned implementation of {!INTENDED_SIGNATURE}: *)
  module First_version : INTENDED_SIGNATURE with type t = V0.t = struct
    include V0

    (** The encoding with the version tagging: *)
    let encoding =
      Data_encoding.With_version.(encoding ~name (first_version V0.encoding))

    let pp ppf {message; attachment} =
      let open Format in
      fprintf ppf "%s:@ %s@ [" name message ;
      pp_open_box ppf 2 ;
      pp_print_list
        ~pp_sep:(fun fmt () -> fprintf fmt ";@ ")
        (fun fmt (k, v) -> fprintf fmt "%s: %S" k v)
        ppf
        attachment ;
      pp_close_box ppf () ;
      fprintf ppf "]" ;
      ()
  end

  (** In a later version we want the attachment to be any piece of
      Json and not just a key-value list: *)
  module V1 = struct
    (** Version 1 is very similar to {!Internal_event.Debug_event}: *)
    type t = {message : string; attachment : Data_encoding.Json.t}

    let make ?(attach = `Null) message () = {message; attachment = attach}

    (** Note the "upgrade" function which can make a {!V1.t} from a {!V0.t}: *)
    let of_v0 {V0.message; attachment} =
      {
        message;
        attachment = `O (List.map (fun (k, v) -> (k, `String v)) attachment);
      }

    (** Again we build first a version-free encoding: *)
    let encoding =
      let open Data_encoding in
      conv
        (fun {message; attachment} -> (message, attachment))
        (fun (message, attachment) -> {message; attachment})
        (obj2 (req "message" string) (req "attachment" json))
  end

  (** The second version exports {!V1.t} while being able to parse
      (and upgrade from) {!First_version.t} values. *)
  module Second_version : INTENDED_SIGNATURE with type t = V1.t = struct
    include V1

    (** Here is the interesting use of {!Data_encoding.With_version}: the
        encoding uses both {!V0.encoding} and {!V1.encoding} and
        provides {!V1.of_v0} as an upgrade function. *)
    let encoding =
      Data_encoding.With_version.(
        encoding
          ~name
          (first_version V0.encoding |> next_version V1.encoding V1.of_v0))

    let pp ppf {message; attachment} =
      let open Format in
      fprintf ppf "%s:@ %s@ %a" name message Data_encoding.Json.pp attachment
  end

  (** This test "serializes" successively using
      {!First_version.encoding} and {!Second_version.encoding}, and then
      shows that the former's output can be parsed with the later. *)
  let actual_test () =
    let v0_thing : First_version.t =
      {
        V0.message = "The v0 message";
        attachment = [("k1", "v1"); ("k2", "v2")];
      }
    in
    let json_v0 =
      Data_encoding.Json.construct First_version.encoding v0_thing
    in
    let expected_json_v0 =
      `O
        [ ( name ^ ".v0",
            (* -> here we see how the [~name] is used. *)
            `O
              [ ("message", `String v0_thing.V0.message);
                ( "attach",
                  `A
                    (List.map
                       (fun (k, v) -> `A [`String k; `String v])
                       v0_thing.V0.attachment) ) ] ) ]
    in
    if json_v0 <> expected_json_v0 then
      Alcotest.failf
        "Json-v0: %a@ Vs@ %a"
        Data_encoding.Json.pp
        json_v0
        Data_encoding.Json.pp
        expected_json_v0 ;
    (* Up to here we only used the {!First_version} module. Now the
       same process with {!Second_version}: *)
    let v1_thing : Second_version.t =
      {
        V1.message = "The v1 message";
        attachment = `O [("k1", `String "v1"); ("kn", `Float 42.)];
      }
    in
    let json_v1 =
      Data_encoding.Json.construct Second_version.encoding v1_thing
    in
    let expected_json_v1 =
      `O
        [ ( name ^ ".v1",
            `O
              [ ("message", `String v1_thing.V1.message);
                ("attachment", v1_thing.V1.attachment) ] ) ]
    in
    if json_v1 <> expected_json_v1 then
      Alcotest.failf
        "Json-v1: %a@ Vs@ %a"
        Data_encoding.Json.pp
        json_v1
        Data_encoding.Json.pp
        expected_json_v1 ;
    (* Now the {b interesting part}, we decode ("destruct") the JSON from
       {!First_version} with {!Second_version}: *)
    let v0_decoded_later : Second_version.t =
      Data_encoding.Json.destruct Second_version.encoding json_v0
    in
    (* And we check that going through JSON is equivalent to just
       calling the upgrade function directly on the {!First_version.t}
       value: *)
    let expected_v1 = V1.of_v0 v0_thing in
    if v0_decoded_later <> expected_v1 then
      Alcotest.failf
        "Parsing v0 with v1: %a@ Vs@ %a"
        Second_version.pp
        v0_decoded_later
        Second_version.pp
        expected_v1 ;
    ()
end

(** This test builds a few successive versions of encodings and tries
    out parsing/printing with successive encapsulated
    versioned-encodings.

    Check out ["_build/_tests/versioned.001.output"] to see how they look.
*)
let test_n_encapsulated_versions () =
  let open Data_encoding in
  let name = "test0" in
  let version_0 = obj2 (req "left" string) (req "right" string) in
  let versioned_0 = With_version.(encoding ~name @@ first_version version_0) in
  let value_0 = ("v0", "k0") in
  let json_0 = Json.construct versioned_0 value_0 in
  Helpers.no_exception (fun () ->
      let result = Json.destruct versioned_0 json_0 in
      if result <> value_0 then Alcotest.failf "value-0") ;
  let module Ex = struct
    type v0 = string * string

    type t =
      | Hide : 'a Data_encoding.t * 'a With_version.t * 'a * (v0 -> 'a) -> t
  end in
  let make_next (Ex.Hide (enc, versioned, example, from_v0)) index =
    let new_tag = Printf.sprintf "left-%d" index in
    let version_n = obj2 (req new_tag string) (req "right" enc) in
    let upgrade vn = ("some-random-extra-string", vn) in
    let versioned_n =
      With_version.(next_version version_n upgrade versioned)
    in
    let encoding = With_version.(encoding ~name versioned_n) in
    let example_n = ("val4" ^ new_tag, example) in
    let json_example_n = Json.construct encoding example_n in
    Helpers.no_exception (fun () ->
        let result = Json.destruct encoding json_example_n in
        if result <> example_n then Alcotest.failf "value-%d" index) ;
    let json_example_p =
      Json.construct With_version.(encoding ~name versioned) example
    in
    Helpers.no_exception (fun () ->
        let result = Json.destruct encoding json_example_p in
        if result <> upgrade example then
          Alcotest.failf "value-%d-previous-encoding" index) ;
    let next_upgrade x = upgrade (from_v0 x) in
    Helpers.no_exception (fun () ->
        let result = Json.destruct encoding json_0 in
        if result <> next_upgrade value_0 then
          Alcotest.failf "value-%d-from-v0-encoding" index) ;
    Format.eprintf "json_example_%d:@ %a\n%!" index Json.pp json_example_n ;
    Format.eprintf
      "json_example_%d-from-v0:@ %a\n%!"
      index
      Json.pp
      (Json.construct encoding (next_upgrade value_0)) ;
    Ex.Hide (version_n, versioned_n, example_n, next_upgrade)
  in
  let (Ex.Hide _) =
    ListLabels.fold_left
      (List.init 10 (( + ) 1))
      ~init:
        (Ex.Hide
           ( version_0,
             With_version.(first_version version_0),
             value_0,
             fun x -> x ))
      ~f:make_next
  in
  ()

let tests =
  [ ("example-test", `Quick, Documented_example.actual_test);
    ("test-encapsulated-versions", `Quick, test_n_encapsulated_versions) ]
src/lib_data_encoding/test/versioned.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Documented_example.
  Module INTENDED_SIGNATURE.
    Record signature {t : Type} := {
      t := t;
      encoding : Tezos_data_encoding.Data_encoding.t t;
      pp : Stdlib.Format.formatter -> t -> unit;
    }.
    Arguments signature : clear implicits.
  End INTENDED_SIGNATURE.
  
  Definition name : string := "versioned-documented-example" % string.
  
  Module V0.
    Record t := {
      message : string;
      attachment : list (string * string) }.
    
    Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
      Tezos_data_encoding.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {| message := message; attachment := attachment |} =>
            (message, attachment)
          end)
        (fun function_parameter =>
          match function_parameter with
          | (message, attachment) =>
            {| message := message; attachment := attachment |}
          end) None
        (Tezos_data_encoding.Data_encoding.obj2
          (Tezos_data_encoding.Data_encoding.req None None "message" % string
            Tezos_data_encoding.Data_encoding.string)
          (Tezos_data_encoding.Data_encoding.req None None "attach" % string
            (Tezos_data_encoding.Data_encoding.list None
              (Tezos_data_encoding.Data_encoding.tup2
                Tezos_data_encoding.Data_encoding.string
                Tezos_data_encoding.Data_encoding.string)))).
  End V0.
  
  Module V1.
    Record t := {
      message : string;
      attachment : Tezos_data_encoding.Data_encoding.Json.t }.
    
    Definition make (op_star_o_p_t_star : option variant)
      : string -> unit -> t :=
      let attach :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => variant
        end in
      fun message =>
        fun function_parameter =>
          match function_parameter with
          | tt => {| message := message; attachment := attach |}
          end.
    
    Definition of_v0 (function_parameter : V0.t) : t :=
      match function_parameter with
      | {| V0.message := message; V0.attachment := attachment |} =>
        {| message := message; attachment := variant |}
      end.
    
    Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
      Tezos_data_encoding.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {| message := message; attachment := attachment |} =>
            (message, attachment)
          end)
        (fun function_parameter =>
          match function_parameter with
          | (message, attachment) =>
            {| message := message; attachment := attachment |}
          end) None
        (Tezos_data_encoding.Data_encoding.obj2
          (Tezos_data_encoding.Data_encoding.req None None "message" % string
            Tezos_data_encoding.Data_encoding.string)
          (Tezos_data_encoding.Data_encoding.req None None "attachment" % string
            Tezos_data_encoding.Data_encoding.json)).
  End V1.
  
  Definition actual_test (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      let v0_thing :=
        {| V0.message := "The v0 message" % string;
          V0.attachment :=
            cons ("k1" % string, "v1" % string)
              (cons ("k2" % string, "v2" % string) []) |} in
      let json_v0 :=
        Tezos_data_encoding.Data_encoding.Json.construct
          First_version.(INTENDED_SIGNATURE.encoding) v0_thing in
      let expected_json_v0 := variant in
      if nequiv_decb json_v0 expected_json_v0 then
        op_star_t_y_p_e_minus_e_r_r_o_r_star "Json-v0: %a@ Vs@ %a" % string
          Tezos_data_encoding.Data_encoding.Json.pp json_v0
          Tezos_data_encoding.Data_encoding.Json.pp expected_json_v0
      else
        tt;
      let v1_thing :=
        {| V1.message := "The v1 message" % string; V1.attachment := variant |}
        in
      let json_v1 :=
        Tezos_data_encoding.Data_encoding.Json.construct
          Second_version.(INTENDED_SIGNATURE.encoding) v1_thing in
      let expected_json_v1 := variant in
      if nequiv_decb json_v1 expected_json_v1 then
        op_star_t_y_p_e_minus_e_r_r_o_r_star "Json-v1: %a@ Vs@ %a" % string
          Tezos_data_encoding.Data_encoding.Json.pp json_v1
          Tezos_data_encoding.Data_encoding.Json.pp expected_json_v1
      else
        tt;
      let v0_decoded_later :=
        Tezos_data_encoding.Data_encoding.Json.destruct
          Second_version.(INTENDED_SIGNATURE.encoding) json_v0 in
      let expected_v1 := V1.of_v0 v0_thing in
      if nequiv_decb v0_decoded_later expected_v1 then
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          "Parsing v0 with v1: %a@ Vs@ %a" % string
          Second_version.(INTENDED_SIGNATURE.pp) v0_decoded_later
          Second_version.(INTENDED_SIGNATURE.pp) expected_v1
      else
        tt;
      tt
    end.
End Documented_example.

Definition test_n_encapsulated_versions (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let name := "test0" % string in
    let version_0 :=
      Tezos_data_encoding.Data_encoding.obj2
        (Tezos_data_encoding.Data_encoding.req None None "left" % string
          Tezos_data_encoding.Data_encoding.string)
        (Tezos_data_encoding.Data_encoding.req None None "right" % string
          Tezos_data_encoding.Data_encoding.string) in
    let versioned_0 :=
      apply (Tezos_data_encoding.Data_encoding.With_version.encoding name)
        (Tezos_data_encoding.Data_encoding.With_version.first_version version_0)
      in
    let value_0 := ("v0" % string, "k0" % string) in
    let json_0 :=
      Tezos_data_encoding.Data_encoding.Json.construct versioned_0 value_0 in
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let result :=
            Tezos_data_encoding.Data_encoding.Json.destruct versioned_0 json_0
            in
          if nequiv_decb result value_0 then
            op_star_t_y_p_e_minus_e_r_r_o_r_star "value-0" % string
          else
            tt
        end);
    let Ex :=
      existT _ _
        {|
          
          |} in
    let make_next (function_parameter : Ex.t) : Z -> Ex.t :=
      match function_parameter with
      | Ex.Hide enc versioned example from_v0 =>
        fun index =>
          let new_tag :=
            Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "left-" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format)) "left-%d" % string)
              index in
          let version_n :=
            Tezos_data_encoding.Data_encoding.obj2
              (Tezos_data_encoding.Data_encoding.req None None new_tag
                Tezos_data_encoding.Data_encoding.string)
              (Tezos_data_encoding.Data_encoding.req None None "right" % string
                enc) in
          let upgrade {A : Type} (vn : A) : string * A :=
            ("some-random-extra-string" % string, vn) in
          let versioned_n :=
            Tezos_data_encoding.Data_encoding.With_version.next_version
              version_n upgrade versioned in
          let encoding :=
            Tezos_data_encoding.Data_encoding.With_version.encoding name
              versioned_n in
          let example_n := ((String.append "val4" % string new_tag), example) in
          let json_example_n :=
            Tezos_data_encoding.Data_encoding.Json.construct encoding example_n
            in
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let result :=
                  Tezos_data_encoding.Data_encoding.Json.destruct encoding
                    json_example_n in
                if nequiv_decb result example_n then
                  op_star_t_y_p_e_minus_e_r_r_o_r_star "value-%d" % string index
                else
                  tt
              end);
          let json_example_p :=
            Tezos_data_encoding.Data_encoding.Json.construct
              (Tezos_data_encoding.Data_encoding.With_version.encoding name
                versioned) example in
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let result :=
                  Tezos_data_encoding.Data_encoding.Json.destruct encoding
                    json_example_p in
                if nequiv_decb result (upgrade example) then
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "value-%d-previous-encoding" % string index
                else
                  tt
              end);
          let next_upgrade (x : Ex.v0) : string * op_dollar_H_i_d_e___'_a :=
            upgrade (from_v0 x) in
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let result :=
                  Tezos_data_encoding.Data_encoding.Json.destruct encoding
                    json_0 in
                if nequiv_decb result (next_upgrade value_0) then
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "value-%d-from-v0-encoding" % string index
                else
                  tt
              end);
          Stdlib.Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "json_example_" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal ":" % char
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Flush
                            CamlinternalFormatBasics.End_of_format)))))))
              "json_example_%d:@ %a
%!" % string) index
            Tezos_data_encoding.Data_encoding.Json.pp json_example_n;
          Stdlib.Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "json_example_" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal "-from-v0:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Flush
                            CamlinternalFormatBasics.End_of_format)))))))
              "json_example_%d-from-v0:@ %a
%!" % string) index
            Tezos_data_encoding.Data_encoding.Json.pp
            (Tezos_data_encoding.Data_encoding.Json.construct encoding
              (next_upgrade value_0));
          Ex.Hide version_n versioned_n example_n next_upgrade
      end in
    match
      Stdlib.ListLabels.fold_left make_next
        (Ex.Hide version_0
          (Tezos_data_encoding.Data_encoding.With_version.first_version
            version_0) value_0 (fun x => x)) (Stdlib.List.init 10 (Z.add 1))
      with
    | Ex.Hide _ _ _ _ => tt
    end
  end.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons ("example-test" % string, variant, Documented_example.actual_test)
    (cons
      ("test-encapsulated-versions" % string, variant,
        test_n_encapsulated_versions) []).
src/lib_data_encoding/test/write_failure.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Test expected errors while serializing data. *)

open Data_encoding
open Types

let check_raises expected f =
  match f () with
  | exception exn when expected exn ->
      ()
  | exception exn ->
      Alcotest.failf "Unexpected exception: %s." (Printexc.to_string exn)
  | _ ->
      Alcotest.failf "Expecting exception, got success."

let json ?(expected = fun _ -> true) encoding value () =
  check_raises expected (fun () ->
      ignore (Json.construct encoding value : Json.t))

let bson ?(expected = fun _ -> true) encoding value () =
  check_raises expected (fun () ->
      ignore (Bson.construct encoding value : Bson.t))

let binary ?(expected = fun _ -> true) encoding value () =
  check_raises expected (fun () ->
      ignore (Binary.to_bytes_exn encoding value : Bytes.t))

let all name encoding value =
  [ (name ^ ".json", `Quick, json encoding value);
    (name ^ ".bson", `Quick, bson encoding value);
    (name ^ ".bytes", `Quick, binary encoding value) ]

let all_ranged_int minimum maximum =
  let encoding = ranged_int minimum maximum in
  let name = Format.asprintf "ranged_int.%d" minimum in
  all (name ^ ".min") encoding (minimum - 1)
  @ all (name ^ ".max") encoding (maximum + 1)

let all_ranged_float minimum maximum =
  let encoding = ranged_float minimum maximum in
  let name = Format.asprintf "ranged_float.%f" minimum in
  all (name ^ ".min") encoding (minimum -. 1.)
  @ all (name ^ ".max") encoding (maximum +. 1.)

let test_bounded_string_list =
  let expected = function
    | Binary_error.Write_error Size_limit_exceeded ->
        true
    | _ ->
        false
  in
  let test name ~total ~elements v =
    ( "bounded_string_list." ^ name,
      `Quick,
      binary ~expected (bounded_list ~total ~elements string) v )
  in
  [ test "a" ~total:0 ~elements:0 [""];
    test "b1" ~total:3 ~elements:4 [""];
    test "b2" ~total:4 ~elements:3 [""];
    test "c1" ~total:19 ~elements:4 [""; ""; ""; ""; ""];
    test "c2" ~total:20 ~elements:3 [""; ""; ""; ""; ""];
    test "d1" ~total:20 ~elements:5 [""; ""; ""; ""; "a"];
    test "d2" ~total:21 ~elements:4 [""; ""; ""; ""; "a"];
    test "e" ~total:30 ~elements:10 ["ab"; "c"; "def"; "gh"; "ijk"] ]

let tests =
  all_ranged_int 100 400 @ all_ranged_int 19000 19254
  @ all_ranged_int ~-100 300
  @ all_ranged_int ~-300_000_000 300_000_000
  @ all_ranged_float ~-.100. 300.
  @ all "string.fixed" (Fixed.string 4) "turlututu"
  @ all "string.bounded" (Bounded.string 4) "turlututu"
  @ all "bytes.fixed" (Fixed.bytes 4) (Bytes.of_string "turlututu")
  @ all "bytes.bounded" (Bounded.bytes 4) (Bytes.of_string "turlututu")
  @ all "unknown_case.B" mini_union_enc (B "2")
  @ all "unknown_case.E" mini_union_enc E
  @ test_bounded_string_list
  @ all "n" n (Z.of_string "-12")
  @ []
src/lib_data_encoding/test/write_failure.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Data_encoding.

Definition check_raises {A : Type} (expected : exn -> bool) (f : unit -> A)
  : unit :=
  match f tt with
  | _ =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      "Expecting exception, got success." % string
  end.

Definition json {A : Type} (op_star_o_p_t_star : option (exn -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun encoding =>
    fun value =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          check_raises expected
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                OCaml.Stdlib.ignore
                  (Tezos_data_encoding.Data_encoding.Json.construct encoding
                    value)
              end)
        end.

Definition bson {A : Type} (op_star_o_p_t_star : option (exn -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun encoding =>
    fun value =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          check_raises expected
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                OCaml.Stdlib.ignore
                  (Tezos_data_encoding.Data_encoding.Bson.construct encoding
                    value)
              end)
        end.

Definition binary {A : Type} (op_star_o_p_t_star : option (exn -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => true
        end
    end in
  fun encoding =>
    fun value =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          check_raises expected
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                OCaml.Stdlib.ignore
                  (Tezos_data_encoding.Data_encoding.Binary.to_bytes_exn
                    encoding value)
              end)
        end.

Definition all {A : Type}
  (name : string) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (value : A) : list (string * variant * (unit -> unit)) :=
  cons
    ((String.append name ".json" % string), variant, (json None encoding value))
    (cons
      ((String.append name ".bson" % string), variant,
        (bson None encoding value))
      (cons
        ((String.append name ".bytes" % string), variant,
          (binary None encoding value)) [])).

Definition all_ranged_int (minimum : Z) (maximum : Z)
  : list (string * variant * (unit -> unit)) :=
  let encoding := Tezos_data_encoding.Data_encoding.ranged_int minimum maximum
    in
  let name :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_int." % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_int.%d" % string)
      minimum in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string) encoding (Z.sub minimum 1))
    (all (String.append name ".max" % string) encoding (Z.add maximum 1)).

Definition all_ranged_float (minimum : float) (maximum : float)
  : list (string * variant * (unit -> unit)) :=
  let encoding := Tezos_data_encoding.Data_encoding.ranged_float minimum maximum
    in
  let name :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_float." % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_float.%f" % string)
      minimum in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string) encoding
      (Stdlib.op_minus_point minimum 1))
    (all (String.append name ".max" % string) encoding
      (Stdlib.op_plus_point maximum 1)).

Definition test_bounded_string_list
  : list (string * variant * (unit -> unit)) :=
  let expected (function_parameter : exn) : bool :=
    match function_parameter with
    | Binary_error.Write_error Size_limit_exceeded => true
    | _ => false
    end in
  let test {A B C : Type} (name : string) (total : A) (elements : B) (v : C)
    : string * variant * (unit -> unit) :=
    ((String.append "bounded_string_list." % string name), variant,
      (binary (Some expected)
        (op_star_t_y_p_e_minus_e_r_r_o_r_star total elements
          Tezos_data_encoding.Data_encoding.string) v)) in
  cons (test "a" % string 0 0 (cons "" % string []))
    (cons (test "b1" % string 3 4 (cons "" % string []))
      (cons (test "b2" % string 4 3 (cons "" % string []))
        (cons
          (test "c1" % string 19 4
            (cons "" % string
              (cons "" % string
                (cons "" % string (cons "" % string (cons "" % string []))))))
          (cons
            (test "c2" % string 20 3
              (cons "" % string
                (cons "" % string
                  (cons "" % string (cons "" % string (cons "" % string []))))))
            (cons
              (test "d1" % string 20 5
                (cons "" % string
                  (cons "" % string
                    (cons "" % string (cons "" % string (cons "a" % string []))))))
              (cons
                (test "d2" % string 21 4
                  (cons "" % string
                    (cons "" % string
                      (cons "" % string
                        (cons "" % string (cons "a" % string []))))))
                (cons
                  (test "e" % string 30 10
                    (cons "ab" % string
                      (cons "c" % string
                        (cons "def" % string
                          (cons "gh" % string (cons "ijk" % string [])))))) []))))))).

Definition tests : list (string * variant * (unit -> unit)) :=
  OCaml.Stdlib.app (all_ranged_int 100 400)
    (OCaml.Stdlib.app (all_ranged_int 19000 19254)
      (OCaml.Stdlib.app (all_ranged_int (Z.opp 100) 300)
        (OCaml.Stdlib.app (all_ranged_int (Z.opp 300000000) 300000000)
          (OCaml.Stdlib.app
            (all_ranged_float (Stdlib.op_tilde_minus_point 100) 300)
            (OCaml.Stdlib.app
              (all "string.fixed" % string
                (Tezos_data_encoding.Data_encoding.Fixed.string 4)
                "turlututu" % string)
              (OCaml.Stdlib.app
                (all "string.bounded" % string
                  (Tezos_data_encoding.Data_encoding.Bounded.string 4)
                  "turlututu" % string)
                (OCaml.Stdlib.app
                  (all "bytes.fixed" % string
                    (Tezos_data_encoding.Data_encoding.Fixed.bytes 4)
                    (Stdlib.Bytes.of_string "turlututu" % string))
                  (OCaml.Stdlib.app
                    (all "bytes.bounded" % string
                      (Tezos_data_encoding.Data_encoding.Bounded.bytes 4)
                      (Stdlib.Bytes.of_string "turlututu" % string))
                    (OCaml.Stdlib.app
                      (all "unknown_case.B" % string
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (OCaml.Stdlib.app
                        (all "unknown_case.E" % string
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (OCaml.Stdlib.app test_bounded_string_list
                          (OCaml.Stdlib.app
                            (all "n" % string
                              Tezos_data_encoding.Data_encoding.n
                              (Z.of_string "-12" % string)) [])))))))))))).
src/lib_data_encoding/tzEndian.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Bytes_encodings

let set_int32 = set_int32_be

let get_int32 = get_int32_be

let set_int8 = set_int8

let get_int8 = get_int8

let set_int16 = set_int16_be

let get_int16 = get_int16_be

let set_int64 = set_int64_be

let get_int64 = get_int64_be

let get_uint8 = get_uint8

let get_uint16 = get_uint16_be

let get_double buff i = Int64.float_of_bits (get_int64_be buff i)

let set_double buff i v = set_int64_be buff i (Int64.bits_of_float v)
src/lib_data_encoding/tzEndian.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Bytes_encodings.

Definition set_int32 : string -> Z -> int32 -> unit :=
  Tezos_data_encoding.Bytes_encodings.set_int32_be.

Definition get_int32 : string -> Z -> int32 :=
  Tezos_data_encoding.Bytes_encodings.get_int32_be.

Definition set_int8 : string -> Z -> Z -> unit :=
  Tezos_data_encoding.Bytes_encodings.set_int8.

Definition get_int8 : string -> Z -> Z :=
  Tezos_data_encoding.Bytes_encodings.get_int8.

Definition set_int16 : string -> Z -> Z -> unit :=
  Tezos_data_encoding.Bytes_encodings.set_int16_be.

Definition get_int16 : string -> Z -> Z :=
  Tezos_data_encoding.Bytes_encodings.get_int16_be.

Definition set_int64 : string -> Z -> int64 -> unit :=
  Tezos_data_encoding.Bytes_encodings.set_int64_be.

Definition get_int64 : string -> Z -> int64 :=
  Tezos_data_encoding.Bytes_encodings.get_int64_be.

Definition get_uint8 : string -> Z -> Z :=
  Tezos_data_encoding.Bytes_encodings.get_uint8.

Definition get_uint16 : string -> Z -> Z :=
  Tezos_data_encoding.Bytes_encodings.get_uint16_be.

Definition get_double (buff : string) (i : Z) : float :=
  Stdlib.Int64.float_of_bits
    (Tezos_data_encoding.Bytes_encodings.get_int64_be buff i).

Definition set_double (buff : string) (i : Z) (v : float) : unit :=
  Tezos_data_encoding.Bytes_encodings.set_int64_be buff i
    (Stdlib.Int64.bits_of_float v).
src/lib_data_encoding/tzEndian.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val get_int32 : bytes -> int -> int32

val set_int32 : bytes -> int -> int32 -> unit

val set_int8 : bytes -> int -> int -> unit

val get_int8 : bytes -> int -> int

val set_int16 : bytes -> int -> int -> unit

val get_int16 : bytes -> int -> int

val set_int64 : bytes -> int -> int64 -> unit

val get_int64 : bytes -> int -> int64

val get_uint8 : bytes -> int -> int

val get_uint16 : bytes -> int -> int

val set_double : bytes -> int -> float -> unit

val get_double : bytes -> int -> float
src/lib_data_encoding/tzEndian.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_int32 : string -> Z -> int32.

Parameter set_int32 : string -> Z -> int32 -> unit.

Parameter set_int8 : string -> Z -> Z -> unit.

Parameter get_int8 : string -> Z -> Z.

Parameter set_int16 : string -> Z -> Z -> unit.

Parameter get_int16 : string -> Z -> Z.

Parameter set_int64 : string -> Z -> int64 -> unit.

Parameter get_int64 : string -> Z -> int64.

Parameter get_uint8 : string -> Z -> Z.

Parameter get_uint16 : string -> Z -> Z.

Parameter set_double : string -> Z -> float -> unit.

Parameter get_double : string -> Z -> float.
src/lib_data_encoding/with_version.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Encoding

let version_case enc choose wrap name nth =
  case
    ~title:(Printf.sprintf "%s version %d" name nth)
    Json_only
    (obj1 (req (Printf.sprintf "%s.v%d" name nth) enc))
    choose
    wrap

let make_encoding ~name l =
  union ~tag_size:`Uint8 (List.mapi (fun nth f -> f name nth) l)

type _ t =
  | Version_0 : 'v0 encoding -> 'v0 t
  | Version_S : {
      previous : 'vn t;
      encoding : 'vnp1 encoding;
      upgrade : 'vn -> 'vnp1;
    }
      -> 'vnp1 t

let first_version e = Version_0 e

let next_version encoding upgrade previous =
  Version_S {encoding; upgrade; previous}

let encoding : type a. name:string -> a t -> a encoding =
 fun ~name version ->
  match version with
  | Version_0 e ->
      make_encoding ~name [version_case e (fun x -> Some x) (fun x -> x)]
  | Version_S {previous; encoding; upgrade} ->
      let rec mk_nones :
          type (* This function generates encoding cases for all the
             outdated versions.
             These versions are never encoded to
             (hence [fun _ -> None]) but are safely decoded with
             the use of the upgrade functions. *)
          b.
          (b -> a) -> b t -> (string -> int -> a case) list =
       fun upgr -> function
        | Version_0 e ->
            [version_case e (fun _ -> None) (fun x -> upgr x)]
        | Version_S {previous; encoding; upgrade} ->
            let others = mk_nones (fun x -> upgr (upgrade x)) previous in
            version_case encoding (fun _ -> None) (fun x -> upgr x) :: others
      in
      let nones = mk_nones upgrade previous in
      let cases =
        version_case encoding (fun x -> Some x) (fun x -> x) :: nones
        |> List.rev
      in
      make_encoding ~name cases
src/lib_data_encoding/with_version.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_data_encoding.Encoding.

Definition version_case {A B : Type}
  (enc : Tezos_data_encoding.Encoding.encoding A) (choose : B -> option A)
  (wrap : A -> B) (name : string) (nth : Z)
  : Tezos_data_encoding.Encoding.case B :=
  Tezos_data_encoding.Encoding.case
    (Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal " version " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s version %d" % string)
      name nth) None Json_only
    (Tezos_data_encoding.Encoding.obj1
      (Tezos_data_encoding.Encoding.req None None
        (Stdlib.Printf.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal ".v" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))) "%s.v%d" % string)
          name nth) enc)) choose wrap.

Definition make_encoding {A B : Type}
  (name : A) (l : list (A -> Z -> Tezos_data_encoding.Encoding.case B))
  : Tezos_data_encoding.Encoding.encoding B :=
  Tezos_data_encoding.Encoding.union (Some variant)
    (Stdlib.List.mapi (fun nth => fun f => f name nth) l).

Inductive t : forall (_ : Type), Type :=
| Version_0 : forall {v0 : Type}, (Tezos_data_encoding.Encoding.encoding v0) ->
  t v0
| Version_S : forall {vn vnp1 : Type}, (t vn) ->
  (Tezos_data_encoding.Encoding.encoding vnp1) -> (vn -> vnp1) -> t vnp1.

Definition first_version {A : Type}
  (e : Tezos_data_encoding.Encoding.encoding A) : t A := Version_0 e.

Definition next_version {A B : Type}
  (encoding : Tezos_data_encoding.Encoding.encoding A) (upgrade : B -> A)
  (previous : t B) : t A :=
  Version_S {| previous := previous; encoding := encoding; upgrade := upgrade |}.

Definition encoding {a : Type} (name : string) (version : t a)
  : Tezos_data_encoding.Encoding.encoding a :=
  match version with
  | Version_0 e =>
    make_encoding name (cons (version_case e (fun x => Some x) (fun x => x)) [])
  |
    Version_S {|
      previous := previous; encoding := encoding; upgrade := upgrade |} =>
    let fix mk_nones {b : Type} (upgr : b -> a) (function_parameter : t b)
      : list (string -> Z -> Tezos_data_encoding.Encoding.case a) :=
      match function_parameter with
      | Version_0 e =>
        cons
          (version_case e
            (fun function_parameter =>
              match function_parameter with
              | _ => None
              end) (fun x => upgr x)) []
      |
        Version_S {|
          previous := previous; encoding := encoding; upgrade := upgrade |}
        =>
        let others := mk_nones (fun x => upgr (upgrade x)) previous in
        cons
          (version_case encoding
            (fun function_parameter =>
              match function_parameter with
              | _ => None
              end) (fun x => upgr x)) others
      end in
    let nones := mk_nones upgrade previous in
    let cases :=
      OCaml.Stdlib.reverse_apply
        (cons (version_case encoding (fun x => Some x) (fun x => x)) nones)
        List.rev in
    make_encoding name cases
  end.
src/lib_data_encoding/with_version.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This is for use *within* the data encoding library only. Instead, you should
    use the corresponding module intended for use: {!Data_encoding.Encoding}. *)

type _ t

val first_version : 'a Encoding.t -> 'a t

val next_version : 'a Encoding.t -> ('b -> 'a) -> 'b t -> 'a t

val encoding : name:string -> 'a t -> 'a Encoding.t
src/lib_data_encoding/with_version.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (_ : Type), Type.

Parameter first_version : forall {a : Type},
(Tezos_data_encoding.Encoding.t a) -> t a.

Parameter next_version : forall {a b : Type},
(Tezos_data_encoding.Encoding.t a) -> (b -> a) -> (t b) -> t a.

Parameter encoding : forall {a : Type},
string -> (t a) -> Tezos_data_encoding.Encoding.t a.
src/lib_error_monad/error_monad.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Error Monad *)

(*-- Error classification ----------------------------------------------------*)

type error_category = [`Branch | `Temporary | `Permanent]

(* hack: forward reference from [Data_encoding_ezjsonm] *)
let json_to_string = ref (fun _ -> "")

let json_pp id encoding ppf x =
  Format.pp_print_string ppf @@ !json_to_string
  @@
  let encoding =
    Data_encoding.(merge_objs (obj1 (req "id" string)) encoding)
  in
  Data_encoding.Json.construct encoding (id, x)

let set_error_encoding_cache_dirty = ref (fun () -> ())

module Make (Prefix : sig
  val id : string
end) =
struct
  type error = ..

  module type Wrapped_error_monad = sig
    type unwrapped = ..

    include Error_monad_sig.S with type error := unwrapped

    val unwrap : error -> unwrapped option

    val wrap : unwrapped -> error
  end

  type full_error_category =
    | Main of error_category
    | Wrapped of (module Wrapped_error_monad)

  (* the toplevel store for error kinds *)
  type error_kind =
    | Error_kind : {
        id : string;
        title : string;
        description : string;
        from_error : error -> 'err option;
        category : full_error_category;
        encoding_case : error Data_encoding.case;
        pp : Format.formatter -> 'err -> unit;
      }
        -> error_kind

  type error_info = {
    category : error_category;
    id : string;
    title : string;
    description : string;
    schema : Data_encoding.json_schema;
  }

  let error_kinds : error_kind list ref = ref []

  let get_registered_errors () : error_info list =
    List.flatten
      (List.map
         (function
           | Error_kind {id = ""; _} ->
               []
           | Error_kind
               { id;
                 title;
                 description;
                 category = Main category;
                 encoding_case;
                 _ } ->
               [ {
                   id;
                   title;
                   description;
                   category;
                   schema =
                     Data_encoding.Json.schema
                       (Data_encoding.union [encoding_case]);
                 } ]
           | Error_kind {category = Wrapped (module WEM); _} ->
               List.map
                 (fun {WEM.id; title; description; category; schema} ->
                   {id; title; description; category; schema})
                 (WEM.get_registered_errors ()))
         !error_kinds)

  let error_encoding_cache = ref None

  let () =
    let cont = !set_error_encoding_cache_dirty in
    set_error_encoding_cache_dirty :=
      fun () ->
        cont () ;
        error_encoding_cache := None

  let string_of_category = function
    | `Permanent ->
        "permanent"
    | `Temporary ->
        "temporary"
    | `Branch ->
        "branch"

  let pp_info ppf {category; id; title; description; schema} =
    Format.fprintf
      ppf
      "@[<v 2>category : %s\n\
       id : %s\n\
       title : %s\n\
       description : %s\n\
       schema : %a@]"
      (string_of_category category)
      id
      title
      description
      (Json_repr.pp (module Json_repr.Ezjsonm))
      (Json_schema.to_json schema)

  (* Catch all error when 'serializing' an error. *)
  type error += Unclassified of string

  let () =
    let id = "" in
    let category = Main `Temporary in
    let to_error msg = Unclassified msg in
    let from_error = function
      | Unclassified msg ->
          Some msg
      | error ->
          let msg = Obj.(extension_name @@ extension_constructor error) in
          Some ("Unclassified error: " ^ msg ^ ". Was the error registered?")
    in
    let title = "Generic error" in
    let description = "An unclassified error" in
    let encoding_case =
      let open Data_encoding in
      case
        Json_only
        ~title:"Generic error"
        ( def "generic_error" ~title ~description
        @@ conv (fun x -> ((), x)) (fun ((), x) -> x)
        @@ obj2 (req "kind" (constant "generic")) (req "error" string) )
        from_error
        to_error
    in
    let pp ppf s = Format.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s in
    error_kinds :=
      Error_kind
        {id; title; description; from_error; category; encoding_case; pp}
      :: !error_kinds

  (* Catch all error when 'deserializing' an error. *)
  type error += Unregistred_error of Data_encoding.json

  let () =
    let id = "" in
    let category = Main `Temporary in
    let to_error msg = Unregistred_error msg in
    let from_error = function
      | Unregistred_error json ->
          Some json
      | _ ->
          None
    in
    let encoding_case =
      let open Data_encoding in
      case Json_only ~title:"Unregistred error" json from_error to_error
    in
    let pp ppf json =
      Format.fprintf
        ppf
        "@[<v 2>Unregistred error:@ %a@]"
        Data_encoding.Json.pp
        json
    in
    error_kinds :=
      Error_kind
        {
          id;
          title = "";
          description = "";
          from_error;
          category;
          encoding_case;
          pp;
        }
      :: !error_kinds

  let raw_register_error_kind category ~id:name ~title ~description ?pp
      encoding from_error to_error =
    let name = Prefix.id ^ name in
    if List.exists (fun (Error_kind {id; _}) -> name = id) !error_kinds then
      invalid_arg
        (Printf.sprintf "register_error_kind: duplicate error name: %s" name) ;
    let encoding_case =
      let open Data_encoding in
      match category with
      | Wrapped (module WEM) ->
          let unwrap err =
            match WEM.unwrap err with
            | Some (WEM.Unclassified _) ->
                None
            | Some (WEM.Unregistred_error _) ->
                Format.eprintf "What %s@." name ;
                None
            | res ->
                res
          in
          let wrap err =
            match err with
            | WEM.Unclassified _ ->
                failwith "ignore wrapped error when serializing"
            | WEM.Unregistred_error _ ->
                failwith "ignore wrapped error when deserializing"
            | res ->
                WEM.wrap res
          in
          case Json_only ~title:name WEM.error_encoding unwrap wrap
      | Main category ->
          let with_id_and_kind_encoding =
            merge_objs
              (obj2
                 (req "kind" (constant (string_of_category category)))
                 (req "id" (constant name)))
              encoding
          in
          case
            Json_only
            ~title
            ~description
            (conv
               (fun x -> (((), ()), x))
               (fun (((), ()), x) -> x)
               with_id_and_kind_encoding)
            from_error
            to_error
    in
    !set_error_encoding_cache_dirty () ;
    error_kinds :=
      Error_kind
        {
          id = name;
          category;
          title;
          description;
          from_error;
          encoding_case;
          pp = Option.unopt ~default:(json_pp name encoding) pp;
        }
      :: !error_kinds

  let register_wrapped_error_kind (module WEM : Wrapped_error_monad) ~id ~title
      ~description =
    raw_register_error_kind
      (Wrapped (module WEM))
      ~id
      ~title
      ~description
      ~pp:WEM.pp
      WEM.error_encoding
      WEM.unwrap
      WEM.wrap

  let register_error_kind category ~id ~title ~description ?pp encoding
      from_error to_error =
    if not (Data_encoding.is_obj encoding) then
      invalid_arg
        (Printf.sprintf
           "Specified encoding for \"%s%s\" is not an object, but error \
            encodings must be objects."
           Prefix.id
           id) ;
    raw_register_error_kind
      (Main category)
      ~id
      ~title
      ~description
      ?pp
      encoding
      from_error
      to_error

  let error_encoding () =
    match !error_encoding_cache with
    | None ->
        let cases =
          List.map
            (fun (Error_kind {encoding_case; _}) -> encoding_case)
            !error_kinds
        in
        let json_encoding = Data_encoding.union cases in
        let encoding =
          Data_encoding.dynamic_size
          @@ Data_encoding.splitted
               ~json:json_encoding
               ~binary:
                 (Data_encoding.conv
                    (Data_encoding.Json.construct json_encoding)
                    (Data_encoding.Json.destruct json_encoding)
                    Data_encoding.json)
        in
        error_encoding_cache := Some encoding ;
        encoding
    | Some encoding ->
        encoding

  let error_encoding = Data_encoding.delayed error_encoding

  let json_of_error error = Data_encoding.Json.construct error_encoding error

  let error_of_json json = Data_encoding.Json.destruct error_encoding json

  let classify_error error =
    let rec find e = function
      | [] ->
          `Temporary
      (* assert false (\* See "Generic error" *\) *)
      | Error_kind {from_error; category; _} :: rest -> (
        match from_error e with
        | Some _ -> (
          match category with
          | Main error_category ->
              error_category
          | Wrapped (module WEM) -> (
            match WEM.unwrap e with
            | Some e ->
                WEM.classify_errors [e]
            | None ->
                find e rest ) )
        | None ->
            find e rest )
    in
    find error !error_kinds

  let classify_errors errors =
    List.fold_left
      (fun r e ->
        match (r, classify_error e) with
        | (`Permanent, _) | (_, `Permanent) ->
            `Permanent
        | (`Branch, _) | (_, `Branch) ->
            `Branch
        | (`Temporary, `Temporary) ->
            `Temporary)
      `Temporary
      errors

  let pp ppf error =
    let rec find = function
      | [] ->
          assert false (* See "Generic error" *)
      | Error_kind {from_error; pp; _} :: errors -> (
        match from_error error with None -> find errors | Some x -> pp ppf x )
    in
    find !error_kinds

  (*-- Monad definition --------------------------------------------------------*)

  let ( >>= ) = Lwt.( >>= )

  type 'a tzresult = ('a, error list) result

  let result_encoding t_encoding =
    let open Data_encoding in
    let errors_encoding = obj1 (req "error" (list error_encoding)) in
    let t_encoding = obj1 (req "result" t_encoding) in
    union
      ~tag_size:`Uint8
      [ case
          (Tag 0)
          t_encoding
          ~title:"Ok"
          (function Ok x -> Some x | _ -> None)
          (function res -> Ok res);
        case
          (Tag 1)
          errors_encoding
          ~title:"Error"
          (function Error x -> Some x | _ -> None)
          (fun errs -> Error errs) ]

  let return v = Lwt.return_ok v

  let return_unit = Lwt.return (Ok ())

  let return_none = Lwt.return (Ok None)

  let return_some x = Lwt.return_ok (Some x)

  let return_nil = Lwt.return (Ok [])

  let return_true = Lwt.return (Ok true)

  let return_false = Lwt.return (Ok false)

  let error s = Error [s]

  let ok v = Ok v

  let fail s = Lwt.return_error [s]

  let ( >>? ) v f = match v with Error _ as err -> err | Ok v -> f v

  let ( >>=? ) v f =
    v >>= function Error _ as err -> Lwt.return err | Ok v -> f v

  let ( >>|? ) v f = v >>=? fun v -> Lwt.return_ok (f v)

  let ( >|= ) = Lwt.( >|= )

  let ( >|? ) v f = v >>? fun v -> Ok (f v)

  let rec map_s f l =
    match l with
    | [] ->
        return_nil
    | h :: t ->
        f h >>=? fun rh -> map_s f t >>=? fun rt -> return (rh :: rt)

  let mapi_s f l =
    let rec mapi_s f i l =
      match l with
      | [] ->
          return_nil
      | h :: t ->
          f i h
          >>=? fun rh -> mapi_s f (i + 1) t >>=? fun rt -> return (rh :: rt)
    in
    mapi_s f 0 l

  let rec rev_map_append_s acc f = function
    | [] ->
        return acc
    | hd :: tl ->
        f hd >>=? fun v -> rev_map_append_s (v :: acc) f tl

  let rev_map_s f l = rev_map_append_s [] f l

  let rec map_p f l =
    match l with
    | [] ->
        return_nil
    | x :: l -> (
        let tx = f x and tl = map_p f l in
        tx
        >>= fun x ->
        tl
        >>= fun l ->
        match (x, l) with
        | (Ok x, Ok l) ->
            Lwt.return_ok (x :: l)
        | (Error exn1, Error exn2) ->
            Lwt.return_error (exn1 @ exn2)
        | (Ok _, Error exn) | (Error exn, Ok _) ->
            Lwt.return_error exn )

  let mapi_p f l =
    let rec mapi_p f i l =
      match l with
      | [] ->
          return_nil
      | x :: l -> (
          let tx = f i x and tl = mapi_p f (i + 1) l in
          tx
          >>= fun x ->
          tl
          >>= fun l ->
          match (x, l) with
          | (Ok x, Ok l) ->
              Lwt.return_ok (x :: l)
          | (Error exn1, Error exn2) ->
              Lwt.return_error (exn1 @ exn2)
          | (Ok _, Error exn) | (Error exn, Ok _) ->
              Lwt.return_error exn )
    in
    mapi_p f 0 l

  let rec map2_s f l1 l2 =
    match (l1, l2) with
    | ([], []) ->
        return_nil
    | (_ :: _, []) | ([], _ :: _) ->
        invalid_arg "Error_monad.map2_s"
    | (h1 :: t1, h2 :: t2) ->
        f h1 h2 >>=? fun rh -> map2_s f t1 t2 >>=? fun rt -> return (rh :: rt)

  let mapi2_s f l1 l2 =
    let rec mapi2_s i f l1 l2 =
      match (l1, l2) with
      | ([], []) ->
          return_nil
      | (_ :: _, []) | ([], _ :: _) ->
          invalid_arg "Error_monad.mapi2_s"
      | (h1 :: t1, h2 :: t2) ->
          f i h1 h2
          >>=? fun rh ->
          mapi2_s (i + 1) f t1 t2 >>=? fun rt -> return (rh :: rt)
    in
    mapi2_s 0 f l1 l2

  let rec map2 f l1 l2 =
    match (l1, l2) with
    | ([], []) ->
        Ok []
    | (_ :: _, []) | ([], _ :: _) ->
        invalid_arg "Error_monad.map2"
    | (h1 :: t1, h2 :: t2) ->
        f h1 h2 >>? fun rh -> map2 f t1 t2 >>? fun rt -> Ok (rh :: rt)

  let rec filter_map_s f l =
    match l with
    | [] ->
        return_nil
    | h :: t -> (
        f h
        >>=? function
        | None ->
            filter_map_s f t
        | Some rh ->
            filter_map_s f t >>=? fun rt -> return (rh :: rt) )

  let rec filter_map_p f l =
    match l with
    | [] ->
        return_nil
    | h :: t -> (
        let th = f h and tt = filter_map_p f t in
        th
        >>=? function
        | None -> tt | Some rh -> tt >>=? fun rt -> return (rh :: rt) )

  let rec filter_s f l =
    match l with
    | [] ->
        return_nil
    | h :: t -> (
        f h
        >>=? function
        | false ->
            filter_s f t
        | true ->
            filter_s f t >>=? fun t -> return (h :: t) )

  let rec filter_p f l =
    match l with
    | [] ->
        return_nil
    | h :: t -> (
        let jh = f h and t = filter_p f t in
        jh >>=? function false -> t | true -> t >>=? fun t -> return (h :: t) )

  let rec iter_s f l =
    match l with [] -> return_unit | h :: t -> f h >>=? fun () -> iter_s f t

  let rec iter_p f l =
    match l with
    | [] ->
        return_unit
    | x :: l -> (
        let tx = f x and tl = iter_p f l in
        tx
        >>= fun tx_res ->
        tl
        >>= fun tl_res ->
        match (tx_res, tl_res) with
        | (Ok (), Ok ()) ->
            Lwt.return_ok ()
        | (Error exn1, Error exn2) ->
            Lwt.return_error (exn1 @ exn2)
        | (Ok (), Error exn) | (Error exn, Ok ()) ->
            Lwt.return_error exn )

  let iteri_p f l =
    let rec iteri_p i f l =
      match l with
      | [] ->
          return_unit
      | x :: l -> (
          let tx = f i x and tl = iteri_p (i + 1) f l in
          tx
          >>= fun tx_res ->
          tl
          >>= fun tl_res ->
          match (tx_res, tl_res) with
          | (Ok (), Ok ()) ->
              Lwt.return (Ok ())
          | (Error exn1, Error exn2) ->
              Lwt.return (Error (exn1 @ exn2))
          | (Ok (), Error exn) | (Error exn, Ok ()) ->
              Lwt.return (Error exn) )
    in
    iteri_p 0 f l

  let rec iter2_p f l1 l2 =
    match (l1, l2) with
    | ([], []) ->
        return_unit
    | ([], _) | (_, []) ->
        invalid_arg "Error_monad.iter2_p"
    | (x1 :: l1, x2 :: l2) -> (
        let tx = f x1 x2 and tl = iter2_p f l1 l2 in
        tx
        >>= fun tx_res ->
        tl
        >>= fun tl_res ->
        match (tx_res, tl_res) with
        | (Ok (), Ok ()) ->
            Lwt.return_ok ()
        | (Error exn1, Error exn2) ->
            Lwt.return_error (exn1 @ exn2)
        | (Ok (), Error exn) | (Error exn, Ok ()) ->
            Lwt.return_error exn )

  let iteri2_p f l1 l2 =
    let rec iteri2_p i f l1 l2 =
      match (l1, l2) with
      | ([], []) ->
          return_unit
      | ([], _) | (_, []) ->
          invalid_arg "Error_monad.iteri2_p"
      | (x1 :: l1, x2 :: l2) -> (
          let tx = f i x1 x2 and tl = iteri2_p (i + 1) f l1 l2 in
          tx
          >>= fun tx_res ->
          tl
          >>= fun tl_res ->
          match (tx_res, tl_res) with
          | (Ok (), Ok ()) ->
              Lwt.return_ok ()
          | (Error exn1, Error exn2) ->
              Lwt.return_error (exn1 @ exn2)
          | (Ok (), Error exn) | (Error exn, Ok ()) ->
              Lwt.return_error exn )
    in
    iteri2_p 0 f l1 l2

  let rec fold_left_s f init l =
    match l with
    | [] ->
        return init
    | h :: t ->
        f init h >>=? fun acc -> fold_left_s f acc t

  let rec fold_right_s f l init =
    match l with
    | [] ->
        return init
    | h :: t ->
        fold_right_s f t init >>=? fun acc -> f h acc

  let rec join = function
    | [] ->
        return_unit
    | t :: ts -> (
        t
        >>= function
        | Error _ as err ->
            join ts >>=? fun () -> Lwt.return err
        | Ok () ->
            join ts )

  let record_trace err result =
    match result with Ok _ as res -> res | Error errs -> Error (err :: errs)

  let trace err f =
    f
    >>= function
    | Error errs -> Lwt.return_error (err :: errs) | ok -> Lwt.return ok

  let record_trace_eval mk_err result =
    match result with
    | Ok _ as res ->
        res
    | Error errs ->
        mk_err () >>? fun err -> Error (err :: errs)

  let trace_eval mk_err f =
    f
    >>= function
    | Error errs ->
        mk_err () >>=? fun err -> Lwt.return_error (err :: errs)
    | ok ->
        Lwt.return ok

  let fail_unless cond exn = if cond then return_unit else fail exn

  let fail_when cond exn = if cond then fail exn else return_unit

  let unless cond f = if cond then return_unit else f ()

  let _when cond f = if cond then f () else return_unit

  let pp_print_error ppf errors =
    match errors with
    | [] ->
        Format.fprintf ppf "Unknown error@."
    | [error] ->
        Format.fprintf ppf "@[<v 2>Error:@ %a@]@." pp error
    | errors ->
        Format.fprintf
          ppf
          "@[<v 2>Error, dumping error stack:@,%a@]@."
          (Format.pp_print_list pp)
          (List.rev errors)

  type error += Assert_error of string * string

  let () =
    let id = "" in
    let category = Main `Permanent in
    let to_error (loc, msg) = Assert_error (loc, msg) in
    let from_error = function
      | Assert_error (loc, msg) ->
          Some (loc, msg)
      | _ ->
          None
    in
    let title = "Assertion error" in
    let description = "An fatal assertion" in
    let encoding_case =
      let open Data_encoding in
      case
        Json_only
        ~title
        ~description
        (conv
           (fun (x, y) -> ((), x, y))
           (fun ((), x, y) -> (x, y))
           (obj3
              (req "kind" (constant "assertion"))
              (req "location" string)
              (req "error" string)))
        from_error
        to_error
    in
    let pp ppf (loc, msg) =
      Format.fprintf
        ppf
        "Assert failure (%s)%s"
        loc
        (if msg = "" then "." else ": " ^ msg)
    in
    error_kinds :=
      Error_kind
        {id; title; description; from_error; category; encoding_case; pp}
      :: !error_kinds

  let _assert b loc fmt =
    if b then Format.ikfprintf (fun _ -> return_unit) Format.str_formatter fmt
    else Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt

  type 'a tzlazy_state =
    | Remembered of 'a
    | Not_yet_known of (unit -> 'a tzresult Lwt.t)

  type 'a tzlazy = {mutable tzcontents : 'a tzlazy_state}

  let tzlazy c = {tzcontents = Not_yet_known c}

  let tzforce v =
    match v.tzcontents with
    | Remembered v ->
        return v
    | Not_yet_known c ->
        c ()
        >>=? fun w ->
        v.tzcontents <- Remembered w ;
        return w
end

include Make (struct
  let id = ""
end)

type error += Exn of exn

let generic_error fmt = Format.kasprintf (fun s -> error (Exn (Failure s))) fmt

let failwith fmt = Format.kasprintf (fun s -> fail (Exn (Failure s))) fmt

let error s = Error [s]

let error_exn s = Error [Exn s]

let trace_exn exn f = trace (Exn exn) f

let generic_trace fmt =
  Format.kasprintf (fun str -> trace_exn (Failure str)) fmt

let record_trace_exn exn f = record_trace (Exn exn) f

let failure fmt = Format.kasprintf (fun str -> Exn (Failure str)) fmt

let pp_exn ppf exn = pp ppf (Exn exn)

let () =
  register_error_kind
    `Temporary
    ~id:"failure"
    ~title:"Generic error"
    ~description:"Unclassified error"
    ~pp:(fun ppf s -> Format.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s)
    Data_encoding.(obj1 (req "msg" string))
    (function
      | Exn (Failure msg) ->
          Some msg
      | Exn exn ->
          Some (Printexc.to_string exn)
      | _ ->
          None)
    (fun msg -> Exn (Failure msg))

type error += Canceled

let () =
  register_error_kind
    `Temporary
    ~id:"canceled"
    ~title:"Canceled"
    ~description:"A promise was unexpectedly canceled"
    ~pp:(fun f () ->
      Format.pp_print_string f "The promise was unexpectedly canceled")
    Data_encoding.unit
    (function Canceled -> Some () | _ -> None)
    (fun () -> Canceled)

let protect ?on_error ?canceler t =
  let cancellation =
    match canceler with
    | None ->
        Lwt_utils.never_ending ()
    | Some canceler ->
        Lwt_canceler.cancellation canceler >>= fun () -> fail Canceled
  in
  let res = Lwt.pick [cancellation; Lwt.catch t (fun exn -> fail (Exn exn))] in
  res
  >>= function
  | Ok _ ->
      res
  | Error err -> (
      let canceled =
        Option.unopt_map canceler ~default:false ~f:Lwt_canceler.canceled
      in
      let err = if canceled then [Canceled] else err in
      match on_error with
      | None ->
          Lwt.return_error err
      | Some on_error ->
          Lwt.catch (fun () -> on_error err) (fun exn -> fail (Exn exn)) )

type error += Timeout

let () =
  register_error_kind
    `Temporary
    ~id:"utils.Timeout"
    ~title:"Timeout"
    ~description:"Timeout"
    ~pp:(fun f () -> Format.pp_print_string f "The request has timed out")
    Data_encoding.unit
    (function Timeout -> Some () | _ -> None)
    (fun () -> Timeout)

let with_timeout ?(canceler = Lwt_canceler.create ()) timeout f =
  let target = f canceler in
  Lwt.choose [timeout; (target >|= fun _ -> ())]
  >>= fun () ->
  if Lwt.state target <> Lwt.Sleep then (Lwt.cancel timeout ; target)
  else Lwt_canceler.cancel canceler >>= fun () -> fail Timeout

let errs_tag = Tag.def ~doc:"Errors" "errs" pp_print_error
src/lib_error_monad/error_monad.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition error_category := variant.

Definition json_to_string
  : Stdlib.ref (Tezos_data_encoding.Data_encoding.Json.json -> string) :=
  Stdlib.ref
    (fun function_parameter =>
      match function_parameter with
      | _ => "" % string
      end).

Definition json_pp {A : Type}
  (id : string) (encoding : Tezos_data_encoding.Data_encoding.encoding A)
  (ppf : Stdlib.Format.formatter) (x : A) : unit :=
  apply (Stdlib.Format.pp_print_string ppf)
    (apply (Stdlib.op_exclamation json_to_string)
      (let encoding :=
        Tezos_data_encoding.Data_encoding.merge_objs
          (Tezos_data_encoding.Data_encoding.obj1
            (Tezos_data_encoding.Data_encoding.req None None "id" % string
              Tezos_data_encoding.Data_encoding.string)) encoding in
      Tezos_data_encoding.Data_encoding.Json.construct encoding (id, x))).

Definition set_error_encoding_cache_dirty : Stdlib.ref (unit -> unit) :=
  Stdlib.ref
    (fun function_parameter =>
      match function_parameter with
      | tt => tt
      end).

Definition generic_error {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (sum B (list error)))
  : A := Stdlib.Format.kasprintf (fun s => error (Exn (OCaml.Failure s))) fmt.

Definition failwith {A B : Type}
  (fmt :
    Stdlib.format4 A Stdlib.Format.formatter unit
      (Lwt.t (Result.result B (list error)))) : A :=
  Stdlib.Format.kasprintf (fun s => fail (Exn (OCaml.Failure s))) fmt.

Definition error {A B : Type} (s : A) : sum B (list A) := inr (cons s []).

Definition error_exn {A : Type} (s : exn) : sum A (list error) :=
  inr (cons (Exn s) []).

Definition trace_exn {A : Type} (exn : exn) (f : Lwt.t (sum A (list error)))
  : Lwt.t (Result.result A (list error)) := trace (Exn exn) f.

Definition generic_trace {A B : Type}
  (fmt :
    Stdlib.format4 A Stdlib.Format.formatter unit
      ((Lwt.t (sum B (list error))) -> Lwt.t (Result.result B (list error))))
  : A := Stdlib.Format.kasprintf (fun str => trace_exn (OCaml.Failure str)) fmt.

Definition record_trace_exn {A : Type} (exn : exn) (f : sum A (list error))
  : sum A (list error) := record_trace (Exn exn) f.

Definition failure {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit error) : A :=
  Stdlib.Format.kasprintf (fun str => Exn (OCaml.Failure str)) fmt.

Definition pp_exn (ppf : Stdlib.Format.formatter) (exn : exn) : unit :=
  pp ppf (Exn exn).

Definition protect {A : Type}
  (on_error : option ((list error) -> Lwt.t (Result.result A (list error))))
  (canceler : option Tezos_stdlib.Lwt_canceler.t)
  (t : unit -> Lwt.t (Result.result A (list error)))
  : Lwt.t (Result.result A (list error)) :=
  let cancellation :=
    match canceler with
    | None => Tezos_stdlib.Lwt_utils.never_ending tt
    | Some canceler =>
      op_gt_gt_eq (Tezos_stdlib.Lwt_canceler.cancellation canceler)
        (fun function_parameter =>
          match function_parameter with
          | tt => fail Canceled
          end)
    end in
  let res :=
    Lwt.pick
      (cons cancellation (cons (Lwt.catch t (fun exn => fail (Exn exn))) [])) in
  op_gt_gt_eq res
    (fun function_parameter =>
      match function_parameter with
      | inl _ => res
      | inr err =>
        let canceled :=
          Tezos_stdlib.Option.unopt_map Tezos_stdlib.Lwt_canceler.canceled false
            canceler in
        let err :=
          if canceled then
            cons Canceled []
          else
            err in
        match on_error with
        | None => Lwt.return_error err
        | Some on_error =>
          Lwt.catch
            (fun function_parameter =>
              match function_parameter with
              | tt => on_error err
              end) (fun exn => fail (Exn exn))
        end
      end).

Definition with_timeout {A : Type}
  (op_star_o_p_t_star : option Tezos_stdlib.Lwt_canceler.t)
  : (Lwt.t unit) ->
    (Tezos_stdlib.Lwt_canceler.t -> Lwt.t (Result.result A (list error))) ->
      Lwt.t (Result.result A (list error)) :=
  let canceler :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_stdlib.Lwt_canceler.create tt
    end in
  fun timeout =>
    fun f =>
      let target := f canceler in
      op_gt_gt_eq
        (Lwt.choose
          (cons timeout
            (cons
              (op_gt_pipe_eq target
                (fun function_parameter =>
                  match function_parameter with
                  | _ => tt
                  end)) [])))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            if nequiv_decb (Lwt.state target) Lwt.Sleep then
              Lwt.cancel timeout;
              target
            else
              op_gt_gt_eq (Tezos_stdlib.Lwt_canceler.cancel canceler)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => fail Timeout
                  end)
          end).

Definition errs_tag : Tezos_stdlib.Tag.def (list error) :=
  Tezos_stdlib.Tag.def (Some "Errors" % string) "errs" % string pp_print_error.
src/lib_error_monad/error_monad.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Error Monad *)

(** Categories of error *)
type error_category =
  [ `Branch  (** Errors that may not happen in another context *)
  | `Temporary  (** Errors that may not happen in a later context *)
  | `Permanent  (** Errors that will happen no matter the context *) ]

include Error_monad_sig.S

module type Wrapped_error_monad = sig
  type unwrapped = ..

  include Error_monad_sig.S with type error := unwrapped

  val unwrap : error -> unwrapped option

  val wrap : unwrapped -> error
end

val register_wrapped_error_kind :
  (module Wrapped_error_monad) ->
  id:string ->
  title:string ->
  description:string ->
  unit

(** Erroneous result (shortcut for generic errors) *)
val generic_error : ('a, Format.formatter, unit, 'b tzresult) format4 -> 'a

(** Erroneous return (shortcut for generic errors) *)
val failwith : ('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 -> 'a

val error_exn : exn -> 'a tzresult

val record_trace_exn : exn -> 'a tzresult -> 'a tzresult

val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t

val generic_trace :
  ( 'a,
    Format.formatter,
    unit,
    ('b, error list) result Lwt.t -> ('b, error list) result Lwt.t )
  format4 ->
  'a

val pp_exn : Format.formatter -> exn -> unit

val failure : ('a, Format.formatter, unit, error) format4 -> 'a

(** Wrapped OCaml/Lwt exception *)
type error += Exn of exn

type error += Canceled

(** [protect] is a wrapper around [Lwt.catch] where the error handler operates
    over `error list` instead of `exn`. Besides, [protect ~on_error ~canceler ~f]
    may *cancel* [f] via a [Lwt_canceler.t].

    More precisely, [protect ~on_error ~canceler f] runs [f ()]. An Lwt failure
    triggered by [f ()] is wrapped into an [Exn]. If a [canceler] is given and
    [Lwt_canceler.cancellation canceler] is determined before [f ()],
    a [Canceled] error is returned.

    Errors are caught by [~on_error] (if given), otherwise the previous value
    is returned. An Lwt failure triggered by [~on_error] is wrapped into an
    [Exn] *)
val protect :
  ?on_error:(error list -> 'a tzresult Lwt.t) ->
  ?canceler:Lwt_canceler.t ->
  (unit -> 'a tzresult Lwt.t) ->
  'a tzresult Lwt.t

type error += Timeout

val with_timeout :
  ?canceler:Lwt_canceler.t ->
  unit Lwt.t ->
  (Lwt_canceler.t -> 'a tzresult Lwt.t) ->
  'a tzresult Lwt.t

module Make (Prefix : sig
  val id : string
end) : Error_monad_sig.S

(**/**)

val json_to_string : (Data_encoding.json -> string) ref

val errs_tag : error list Tag.def
src/lib_error_monad/error_monad.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition error_category := variant.

include

module_type

Parameter register_wrapped_error_kind :
{'(unwrapped, error_info, tzlazy) : _ &
  Wrapped_error_monad.signature unwrapped error_info tzlazy} ->
  string -> string -> string -> unit.

Parameter generic_error : forall {a b : Type},
(Stdlib.format4 a Stdlib.Format.formatter unit (tzresult b)) -> a.

Parameter failwith : forall {a b : Type},
(Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t (tzresult b))) -> a.

Parameter error_exn : forall {a : Type}, exn -> tzresult a.

Parameter record_trace_exn : forall {a : Type},
exn -> (tzresult a) -> tzresult a.

Parameter trace_exn : forall {b : Type},
exn -> (Lwt.t (tzresult b)) -> Lwt.t (tzresult b).

Parameter generic_trace : forall {a b : Type},
(Stdlib.format4 a Stdlib.Format.formatter unit
  ((Lwt.t (sum b (list error))) -> Lwt.t (sum b (list error)))) -> a.

Parameter pp_exn : Stdlib.Format.formatter -> exn -> unit.

Parameter failure : forall {a : Type},
(Stdlib.format4 a Stdlib.Format.formatter unit error) -> a.

extensible_type

extensible_type

Parameter protect : forall {a : Type},
(option ((list error) -> Lwt.t (tzresult a))) ->
  (option Tezos_stdlib.Lwt_canceler.t) ->
    (unit -> Lwt.t (tzresult a)) -> Lwt.t (tzresult a).

extensible_type

Parameter with_timeout : forall {a : Type},
(option Tezos_stdlib.Lwt_canceler.t) ->
  (Lwt.t unit) ->
    (Tezos_stdlib.Lwt_canceler.t -> Lwt.t (tzresult a)) -> Lwt.t (tzresult a).

unhandled_module

Parameter json_to_string :
Stdlib.ref (Tezos_data_encoding.Data_encoding.json -> string).

Parameter errs_tag : Tezos_stdlib.Tag.def (list error).
src/lib_error_monad/error_monad_sig.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Categories of error *)
type error_category =
  [ `Branch  (** Errors that may not happen in another context *)
  | `Temporary  (** Errors that may not happen in a later context *)
  | `Permanent  (** Errors that will happen no matter the context *) ]

module type S = sig
  type error = ..

  (** Catch all error when 'serializing' an error. *)
  type error +=
    private
    | Unclassified of string
          (** Catch all error when 'deserializing' an error. *)

  type error += private Unregistred_error of Data_encoding.json

  val pp : Format.formatter -> error -> unit

  val pp_print_error : Format.formatter -> error list -> unit

  (** An error serializer *)
  val error_encoding : error Data_encoding.t

  val json_of_error : error -> Data_encoding.json

  val error_of_json : Data_encoding.json -> error

  (** {2 Error documentation} *)

  (** Error information *)
  type error_info = {
    category : error_category;
    id : string;
    title : string;
    description : string;
    schema : Data_encoding.json_schema;
  }

  val pp_info : Format.formatter -> error_info -> unit

  (** Retrieves information of registered errors *)
  val get_registered_errors : unit -> error_info list

  (** {2 Error classification} *)

  (** The error data type is extensible. Each module can register specialized
      error serializers
      [id] unique name of this error. Ex.: overflow_time_counter
      [title] more readable name. Ex.: Overflow of time counter
      [description] human readable description. Ex.: The time counter overflowed while computing delta increase
      [pp] formatter used to pretty print additional arguments. Ex.: The time counter overflowed while computing delta increase. Previous value %d. Delta: %d
      [encoder] [decoder] data encoding for this error. If the error has no value, specify Data_encoding.empty
  *)
  val register_error_kind :
    error_category ->
    id:string ->
    title:string ->
    description:string ->
    ?pp:(Format.formatter -> 'err -> unit) ->
    'err Data_encoding.t ->
    (error -> 'err option) ->
    ('err -> error) ->
    unit

  (** Classify an error using the registered kinds *)
  val classify_errors : error list -> error_category

  (** {2 Monad definition} *)

  (** The error monad wrapper type, the error case holds a stack of
      error, initialized by the first call to {!fail} and completed by
      each call to {!trace} as the stack is rewinded. The most general
      error is thus at the top of the error stack, going down to the
      specific error that actually caused the failure. *)
  type 'a tzresult = ('a, error list) result

  (** A serializer for result of a given type *)
  val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.t

  (** Sucessful result *)
  val ok : 'a -> 'a tzresult

  (** Sucessful return *)
  val return : 'a -> 'a tzresult Lwt.t

  (** Sucessful return of [()] *)
  val return_unit : unit tzresult Lwt.t

  (** Sucessful return of [None] *)
  val return_none : 'a option tzresult Lwt.t

  (** [return_some x] is a sucessful return of [Some x] *)
  val return_some : 'a -> 'a option tzresult Lwt.t

  (** Sucessful return of [[]] *)
  val return_nil : 'a list tzresult Lwt.t

  (** Sucessful return of [true] *)
  val return_true : bool tzresult Lwt.t

  (** Sucessful return of [false] *)
  val return_false : bool tzresult Lwt.t

  (** Erroneous result *)
  val error : error -> 'a tzresult

  (** Erroneous return *)
  val fail : error -> 'a tzresult Lwt.t

  (** Non-Lwt bind operator *)
  val ( >>? ) : 'a tzresult -> ('a -> 'b tzresult) -> 'b tzresult

  (** Bind operator *)
  val ( >>=? ) :
    'a tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t

  (** Lwt's bind reexported *)
  val ( >>= ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t

  val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t

  (** To operator *)
  val ( >>|? ) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t

  (** Non-Lwt to operator *)
  val ( >|? ) : 'a tzresult -> ('a -> 'b) -> 'b tzresult

  (** Enrich an error report (or do nothing on a successful result) manually *)
  val record_trace : error -> 'a tzresult -> 'a tzresult

  (** Automatically enrich error reporting on stack rewind *)
  val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t

  (** Same as record_trace, for unevaluated error *)
  val record_trace_eval :
    (unit -> error tzresult) -> 'a tzresult -> 'a tzresult

  (** Same as trace, for unevaluated Lwt error *)
  val trace_eval :
    (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t

  (** Erroneous return on failed assertion *)
  val fail_unless : bool -> error -> unit tzresult Lwt.t

  val fail_when : bool -> error -> unit tzresult Lwt.t

  val unless : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t

  val _when : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t

  (* Usage: [_assert cond __LOC__ "<fmt>" ...] *)
  val _assert :
    bool ->
    string ->
    ('a, Format.formatter, unit, unit tzresult Lwt.t) format4 ->
    'a

  (** {2 In-monad list iterators} *)

  (** A {!List.iter} in the monad *)
  val iter_s : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t

  val iter_p : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t

  val iteri_p :
    (int -> 'a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t

  val iter2_p :
    ('a -> 'b -> unit tzresult Lwt.t) ->
    'a list ->
    'b list ->
    unit tzresult Lwt.t

  val iteri2_p :
    (int -> 'a -> 'b -> unit tzresult Lwt.t) ->
    'a list ->
    'b list ->
    unit tzresult Lwt.t

  (** A {!List.map} in the monad *)
  val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val rev_map_s :
    ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val map_p : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val mapi_s :
    (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val mapi_p :
    (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  (** A {!List.map2} in the monad *)
  val map2 :
    ('a -> 'b -> 'c tzresult) -> 'a list -> 'b list -> 'c list tzresult

  val map2_s :
    ('a -> 'b -> 'c tzresult Lwt.t) ->
    'a list ->
    'b list ->
    'c list tzresult Lwt.t

  val mapi2_s :
    (int -> 'a -> 'b -> 'c tzresult Lwt.t) ->
    'a list ->
    'b list ->
    'c list tzresult Lwt.t

  (** A {!List.filter_map} in the monad *)
  val filter_map_s :
    ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val filter_map_p :
    ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  (** A {!List.filter} in the monad *)
  val filter_s :
    ('a -> bool tzresult Lwt.t) -> 'a list -> 'a list tzresult Lwt.t

  val filter_p :
    ('a -> bool tzresult Lwt.t) -> 'a list -> 'a list tzresult Lwt.t

  (** A {!List.fold_left} in the monad *)
  val fold_left_s :
    ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b list -> 'a tzresult Lwt.t

  (** A {!List.fold_right} in the monad *)
  val fold_right_s :
    ('a -> 'b -> 'b tzresult Lwt.t) -> 'a list -> 'b -> 'b tzresult Lwt.t

  (** A {!Lwt.join} in the monad *)
  val join : unit tzresult Lwt.t list -> unit tzresult Lwt.t

  (** Lazy values with retry-until success semantics *)
  type 'a tzlazy

  (** Create a {!tzlazy} value. *)
  val tzlazy : (unit -> 'a tzresult Lwt.t) -> 'a tzlazy

  (** [tzforce tzl] is either
      (a) the remembered value carried by [tzl] if available
      (b) the result of the callback/closure used to create [tzl] if successful,
      in which case the value is remembered, or
      (c) an error if the callback/closure used to create [tzl] is unsuccessful.
  *)
  val tzforce : 'a tzlazy -> 'a tzresult Lwt.t
end
src/lib_error_monad/error_monad_sig.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition error_category := variant.

Module S.
  Record signature {error error_info tzlazy : Type} := {
    error := error;
    extensible_type;
    extensible_type;
    pp : Stdlib.Format.formatter -> error -> unit;
    pp_print_error : Stdlib.Format.formatter -> (list error) -> unit;
    error_encoding : Tezos_data_encoding.Data_encoding.t error;
    json_of_error : error -> Tezos_data_encoding.Data_encoding.json;
    error_of_json : Tezos_data_encoding.Data_encoding.json -> error;
    error_info := error_info;
    pp_info : Stdlib.Format.formatter -> error_info -> unit;
    get_registered_errors : unit -> list error_info;
    register_error_kind : forall {err : Type}, error_category ->
      string ->
        string ->
          string ->
            (option (Stdlib.Format.formatter -> err -> unit)) ->
              (Tezos_data_encoding.Data_encoding.t err) ->
                (error -> option err) -> (err -> error) -> unit;
    classify_errors : (list error) -> error_category;
    tzresult (a : Type) := sum a (list error);
    result_encoding : forall {a : Type}, (Tezos_data_encoding.Data_encoding.t a)
      -> Tezos_data_encoding.Data_encoding.t (tzresult a);
    ok : forall {a : Type}, a -> tzresult a;
    _return : forall {a : Type}, a -> Lwt.t (tzresult a);
    return_unit : Lwt.t (tzresult unit);
    return_none : forall {a : Type}, Lwt.t (tzresult (option a));
    return_some : forall {a : Type}, a -> Lwt.t (tzresult (option a));
    return_nil : forall {a : Type}, Lwt.t (tzresult (list a));
    return_true : Lwt.t (tzresult bool);
    return_false : Lwt.t (tzresult bool);
    error : forall {a : Type}, error -> tzresult a;
    fail : forall {a : Type}, error -> Lwt.t (tzresult a);
    op_gt_gt_question : forall {a b : Type}, (tzresult a) ->
      (a -> tzresult b) -> tzresult b;
    op_gt_gt_eq_question : forall {a b : Type}, (Lwt.t (tzresult a)) ->
      (a -> Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
    op_gt_gt_eq : forall {a b : Type}, (Lwt.t a) -> (a -> Lwt.t b) -> Lwt.t b;
    op_gt_pipe_eq : forall {a b : Type}, (Lwt.t a) -> (a -> b) -> Lwt.t b;
    op_gt_gt_pipe_question : forall {a b : Type}, (Lwt.t (tzresult a)) ->
      (a -> b) -> Lwt.t (tzresult b);
    op_gt_pipe_question : forall {a b : Type}, (tzresult a) ->
      (a -> b) -> tzresult b;
    record_trace : forall {a : Type}, error -> (tzresult a) -> tzresult a;
    trace : forall {b : Type}, error ->
      (Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
    record_trace_eval : forall {a : Type}, (unit -> tzresult error) ->
      (tzresult a) -> tzresult a;
    trace_eval : forall {b : Type}, (unit -> Lwt.t (tzresult error)) ->
      (Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
    fail_unless : bool -> error -> Lwt.t (tzresult unit);
    fail_when : bool -> error -> Lwt.t (tzresult unit);
    unless : bool -> (unit -> Lwt.t (tzresult unit)) -> Lwt.t (tzresult unit);
    _when : bool -> (unit -> Lwt.t (tzresult unit)) -> Lwt.t (tzresult unit);
    _assert : forall {a : Type}, bool ->
      string ->
        (Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t (tzresult unit)))
          -> a;
    iter_s : forall {a : Type}, (a -> Lwt.t (tzresult unit)) ->
      (list a) -> Lwt.t (tzresult unit);
    iter_p : forall {a : Type}, (a -> Lwt.t (tzresult unit)) ->
      (list a) -> Lwt.t (tzresult unit);
    iteri_p : forall {a : Type}, (Z -> a -> Lwt.t (tzresult unit)) ->
      (list a) -> Lwt.t (tzresult unit);
    iter2_p : forall {a b : Type}, (a -> b -> Lwt.t (tzresult unit)) ->
      (list a) -> (list b) -> Lwt.t (tzresult unit);
    iteri2_p : forall {a b : Type}, (Z -> a -> b -> Lwt.t (tzresult unit)) ->
      (list a) -> (list b) -> Lwt.t (tzresult unit);
    map_s : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    rev_map_s : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    map_p : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    mapi_s : forall {a b : Type}, (Z -> a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    mapi_p : forall {a b : Type}, (Z -> a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    map2 : forall {a b c : Type}, (a -> b -> tzresult c) ->
      (list a) -> (list b) -> tzresult (list c);
    map2_s : forall {a b c : Type}, (a -> b -> Lwt.t (tzresult c)) ->
      (list a) -> (list b) -> Lwt.t (tzresult (list c));
    mapi2_s : forall {a b c : Type}, (Z -> a -> b -> Lwt.t (tzresult c)) ->
      (list a) -> (list b) -> Lwt.t (tzresult (list c));
    filter_map_s : forall {a b : Type}, (a -> Lwt.t (tzresult (option b))) ->
      (list a) -> Lwt.t (tzresult (list b));
    filter_map_p : forall {a b : Type}, (a -> Lwt.t (tzresult (option b))) ->
      (list a) -> Lwt.t (tzresult (list b));
    filter_s : forall {a : Type}, (a -> Lwt.t (tzresult bool)) ->
      (list a) -> Lwt.t (tzresult (list a));
    filter_p : forall {a : Type}, (a -> Lwt.t (tzresult bool)) ->
      (list a) -> Lwt.t (tzresult (list a));
    fold_left_s : forall {a b : Type}, (a -> b -> Lwt.t (tzresult a)) ->
      a -> (list b) -> Lwt.t (tzresult a);
    fold_right_s : forall {a b : Type}, (a -> b -> Lwt.t (tzresult b)) ->
      (list a) -> b -> Lwt.t (tzresult b);
    join : (list (Lwt.t (tzresult unit))) -> Lwt.t (tzresult unit);
    polymorphic_abstract_type;
    tzlazy : forall {a : Type}, (unit -> Lwt.t (tzresult a)) -> tzlazy a;
    tzforce : forall {a : Type}, (tzlazy a) -> Lwt.t (tzresult a);
  }.
  Arguments signature : clear implicits.
End S.
src/lib_error_monad/error_table.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module type S = sig
  type key

  type 'a t

  val create : int -> 'a t

  val clear : 'a t -> unit

  val reset : 'a t -> unit

  val find_or_make :
    'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t

  val remove : 'a t -> key -> unit

  val find_opt : 'a t -> key -> 'a tzresult Lwt.t option

  val mem : 'a t -> key -> bool

  val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t

  val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t

  val fold : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t

  val fold_promises :
    (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val length : 'a t -> int
end

module Make (T : Hashtbl.S) : S with type key = T.key = struct
  type key = T.key

  type 'a t = {table : 'a tzresult Lwt.t T.t; cleaners : unit Lwt.t T.t}

  let create n = {table = T.create n; cleaners = T.create n}

  let clear t =
    T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ;
    T.iter (fun _ a -> Lwt.cancel a) t.table ;
    T.clear t.cleaners ;
    T.clear t.table

  let reset t =
    T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ;
    T.iter (fun _ a -> Lwt.cancel a) t.table ;
    T.reset t.cleaners ;
    T.reset t.table

  let find_or_make t k i =
    match T.find_opt t.table k with
    | Some a ->
        a
    | None ->
        let p = i () in
        T.add t.table k p ;
        T.add
          t.cleaners
          k
          ( p
          >>= function
          | Ok _ ->
              T.remove t.cleaners k ; Lwt.return_unit
          | Error _ ->
              T.remove t.table k ; T.remove t.cleaners k ; Lwt.return_unit ) ;
        p

  let remove t k =
    (match T.find_opt t.cleaners k with None -> () | Some a -> Lwt.cancel a) ;
    T.remove t.cleaners k ;
    (match T.find_opt t.table k with None -> () | Some a -> Lwt.cancel a) ;
    T.remove t.table k

  let find_opt t k = T.find_opt t.table k

  let mem t k = T.mem t.table k

  let iter_s f t =
    T.fold (fun k a acc -> (k, a) :: acc) t.table []
    |> Lwt_list.iter_s (fun (k, a) ->
           a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a)

  let iter_p f t =
    T.fold (fun k a acc -> (k, a) :: acc) t.table []
    |> Lwt_list.iter_p (fun (k, a) ->
           a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a)

  let fold f t acc =
    T.fold (fun k a acc -> (k, a) :: acc) t.table []
    |> Lwt_list.fold_left_s
         (fun acc (k, a) ->
           a >>= function Error _ -> Lwt.return acc | Ok a -> f k a acc)
         acc

  let fold_promises f t acc = T.fold f t.table acc

  let fold_resolved f t acc =
    T.fold
      (fun k a acc ->
        match Lwt.state a with
        | Lwt.Sleep | Lwt.Fail _ | Lwt.Return (Error _) ->
            acc
        | Lwt.Return (Ok a) ->
            f k a acc)
      t.table
      acc

  let fold_keys f t acc = T.fold (fun k _ acc -> f k acc) t.table acc

  let length t = T.length t.table
end
src/lib_error_monad/error_table.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Module S.
  Record signature {key t : Type} := {
    key := key;
    polymorphic_abstract_type;
    create : forall {a : Type}, Z -> t a;
    clear : forall {a : Type}, (t a) -> unit;
    reset : forall {a : Type}, (t a) -> unit;
    find_or_make : forall {a : Type}, (t a) ->
      key ->
        (unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult a)) ->
          Lwt.t (Tezos_error_monad.Error_monad.tzresult a);
    remove : forall {a : Type}, (t a) -> key -> unit;
    find_opt : forall {a : Type}, (t a) ->
      key -> option (Lwt.t (Tezos_error_monad.Error_monad.tzresult a));
    mem : forall {a : Type}, (t a) -> key -> bool;
    iter_s : forall {a : Type}, (key -> a -> Lwt.t unit) -> (t a) -> Lwt.t unit;
    iter_p : forall {a : Type}, (key -> a -> Lwt.t unit) -> (t a) -> Lwt.t unit;
    fold : forall {a b : Type}, (key -> a -> b -> Lwt.t b) ->
      (t a) -> b -> Lwt.t b;
    fold_promises : forall {a b : Type}, (key ->
      (Lwt.t (Tezos_error_monad.Error_monad.tzresult a)) -> b -> b) ->
      (t a) -> b -> b;
    fold_resolved : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
    fold_keys : forall {a b : Type}, (key -> b -> b) -> (t a) -> b -> b;
    length : forall {a : Type}, (t a) -> Z;
  }.
  Arguments signature : clear implicits.
End S.
src/lib_error_monad/error_table.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module type S = sig
  (** This is mostly [Hashtbl.S] with the following differences:

      Looking up an element and creating an element to insert in the table are
      the same operations. In other words:
      - The function [find_or_make t k gen] behaves in two separate ways
      depending if an element is already bound to key [k] in table [t].
      - If an element is bound, then it is returned.
      - Otherwise, an element is generated using the [gen] function and recorded
      in the table.

      The table does not record elements per se. Instead it records promises of
      results of elements. This means that [find_or_make t k gen] is a value
      within the lwt-error monad.

      The table automatically cleans itself of errors. Specifically, when one of
      the promises resolves as an error, all the caller of [find_or_make] for
      the matching key are woken up with [Error] and the value is removed from
      the table. The next call to [find_or_make] with the same key causes the
      provided [gen] function to be called. *)

  type key

  type 'a t

  val create : int -> 'a t

  val clear : 'a t -> unit

  val reset : 'a t -> unit

  (** [find_or_make t k gen] is [p] if [k] is already bound to [k] in [t]. In
      this case, no side-effect is performed.

      [find_or_make t k gen] is [r] if [k] is not bound in [t] where [r] is [gen
      ()]. In this case, [r] becomes bound to [k] in [t]. In addition, a
      listener is added to [r] so that if [r] resolves to [Error _], the binding
      is removed. *)
  val find_or_make :
    'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t

  val remove : 'a t -> key -> unit

  (** [find_opt t k] is [None] if there are no bindings for [k] in [t], and
      [Some p] if [p] is bound to [k] in [t]. *)
  val find_opt : 'a t -> key -> 'a tzresult Lwt.t option

  val mem : 'a t -> key -> bool

  val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t

  (** [iter_{s,p} f t] iterates [f] over the promises of [t]. It blocks on
      unresolved promises and only applies the function on the ones that resolve
      successfully. *)
  val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t

  (** [fold f t init] folds [f] over the successfully resolving promises
      of [t]. I.e., it goes through the promises in the table and waits for each
      of the promise to resolve in order to fold over it. *)
  val fold : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t

  (** [fold_promises f t init] folds [f] over the promises of [t]. *)
  val fold_promises :
    (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b

  (** [fold_resolved f t init] folds [f] over the successfully resolved promises
      of [t]. *)
  val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  (** [fold_keys f t init] folds [f] over the keys bound in [t]. *)
  val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val length : 'a t -> int
end

(** Intended use: [Make(Hashtbl.Make(M))]. *)
module Make (T : Hashtbl.S) : S with type key = T.key
src/lib_error_monad/error_table.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

unhandled_module
src/lib_error_monad/test/assert.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf failwith "@[%s@ expected: %s@ got: %s@]" msg expected given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg
src/lib_error_monad/test/assert.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Stdlib.Format.kasprintf OCaml.Stdlib.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Stdlib.Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  match function_parameter with
  | _ => "" % string
  end.

Definition equal {A : Type} (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun op_star_o_p_t_star =>
    let prn :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.
src/lib_error_monad/test/test_error_tables.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

module IntErrorTable = Error_table.Make (Hashtbl.Make (struct
  type t = int

  let equal x y = x = y

  let hash x = x
end))

let test_add_remove _ _ =
  let t = IntErrorTable.create 2 in
  IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
  >>= function
  | Error _ ->
      Assert.fail "Ok 0" "Error _" "find_or_make"
  | Ok n -> (
      if not (n = 0) then
        Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make"
      else
        match IntErrorTable.find_opt t 0 with
        | None ->
            Assert.fail "Some (Ok 0)" "None" "find_opt"
        | Some p -> (
            p
            >>= function
            | Error _ ->
                Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt"
            | Ok n ->
                if not (n = 0) then
                  Assert.fail
                    "Some (Ok 0)"
                    (Format.asprintf "Some (Ok %d)" n)
                    "find_opt"
                else (
                  IntErrorTable.remove t 0 ;
                  match IntErrorTable.find_opt t 0 with
                  | Some _ ->
                      Assert.fail "None" "Some _" "remove;find_opt"
                  | None ->
                      Lwt.return_unit ) ) )

let test_add_add _ _ =
  let t = IntErrorTable.create 2 in
  IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
  >>= fun _ ->
  IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 1)
  >>= fun _ ->
  match IntErrorTable.find_opt t 0 with
  | None ->
      Assert.fail "Some (Ok 0)" "None" "find_opt"
  | Some p -> (
      p
      >>= function
      | Error _ ->
          Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt"
      | Ok n ->
          if not (n = 0) then
            Assert.fail
              "Some (Ok 0)"
              (Format.asprintf "Some (Ok %d)" n)
              "find_opt"
          else Lwt.return_unit )

let test_length _ _ =
  let t = IntErrorTable.create 2 in
  IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
  >>= fun _ ->
  IntErrorTable.find_or_make t 1 (fun () -> Error_monad.return 1)
  >>= fun _ ->
  IntErrorTable.find_or_make t 2 (fun () -> Error_monad.return 2)
  >>= fun _ ->
  IntErrorTable.find_or_make t 3 (fun () -> Error_monad.return 3)
  >>= fun _ ->
  let l = IntErrorTable.length t in
  if not (l = 4) then Assert.fail "4" (Format.asprintf "%d" l) "length"
  else Lwt.return_unit

let test_self_clean _ _ =
  let t = IntErrorTable.create 2 in
  IntErrorTable.find_or_make t 0 (fun () -> Lwt.return (Ok 0))
  >>= fun _ ->
  IntErrorTable.find_or_make t 1 (fun () -> Lwt.return (Error []))
  >>= fun _ ->
  IntErrorTable.find_or_make t 2 (fun () -> Lwt.return (Error []))
  >>= fun _ ->
  IntErrorTable.find_or_make t 3 (fun () -> Lwt.return (Ok 3))
  >>= fun _ ->
  IntErrorTable.find_or_make t 4 (fun () -> Lwt.return (Ok 4))
  >>= fun _ ->
  IntErrorTable.find_or_make t 5 (fun () -> Lwt.return (Error []))
  >>= fun _ ->
  let l = IntErrorTable.length t in
  if not (l = 3) then Assert.fail "3" (Format.asprintf "%d" l) "length"
  else Lwt.return_unit

let test_order _ _ =
  let t = IntErrorTable.create 2 in
  let (wter, wker) = Lwt.task () in
  let world = ref [] in
  (* PROMISE A *)
  let p_a =
    IntErrorTable.find_or_make t 0 (fun () ->
        wter
        >>= fun r ->
        world := "a_inner" :: !world ;
        Lwt.return r)
    >>= fun r_a ->
    world := "a_outer" :: !world ;
    Lwt.return r_a
  in
  Lwt_main.yield ()
  >>= fun () ->
  (* PROMISE B *)
  let p_b =
    IntErrorTable.find_or_make t 0 (fun () ->
        world := "b_inner" :: !world ;
        Lwt.return (Ok 1024))
    >>= fun r_b ->
    world := "b_outer" :: !world ;
    Lwt.return r_b
  in
  Lwt_main.yield ()
  >>= fun () ->
  (* Wake up A *)
  Lwt.wakeup wker (Ok 0) ;
  (* Check that both A and B get expected results *)
  p_a
  >>= (function
        | Error _ ->
            Assert.fail "Ok 0" "Error _" "find_or_make(a)"
        | Ok n ->
            if not (n = 0) then
              Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make(a)"
            else Lwt.return_unit)
  >>= fun () ->
  p_b
  >>= (function
        | Error _ ->
            Assert.fail "Ok 0" "Error _" "find_or_make(b)"
        | Ok n ->
            if not (n = 0) then
              Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make(b)"
            else Lwt.return_unit)
  >>= fun () ->
  (* Check that the `world` record is as expected *)
  match !world with
  | ["b_outer"; "a_outer"; "a_inner"] | ["a_outer"; "b_outer"; "a_inner"] ->
      Lwt.return ()
  | world ->
      Assert.fail
        "[outers;a_inner]"
        Format.(asprintf "[%a]" (pp_print_list pp_print_string) world)
        "world"

let tests =
  [ Alcotest_lwt.test_case "add_remove" `Quick test_add_remove;
    Alcotest_lwt.test_case "add_add" `Quick test_add_add;
    Alcotest_lwt.test_case "length" `Quick test_length;
    Alcotest_lwt.test_case "self_clean" `Quick test_length;
    Alcotest_lwt.test_case "order" `Quick test_order ]

let () = Alcotest.run "error_tables" [("error_tables", tests)]
src/lib_error_monad/test/test_error_tables.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Definition test_add_remove {A B : Type} (function_parameter : A)
  : B -> Lwt.t unit :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        let t := IntErrorTable.create 2 in
        Lwt.Infix.op_gt_gt_eq
          (IntErrorTable.find_or_make t 0
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_error_monad.Error_monad._return 0
              end))
          (fun function_parameter =>
            match function_parameter with
            | inr _ =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star "Ok 0" % string
                "Error _" % string "find_or_make" % string
            | inl n =>
              if negb (equiv_decb n 0) then
                op_star_t_y_p_e_minus_e_r_r_o_r_star "Ok 0" % string
                  (Stdlib.Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "Ok " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          CamlinternalFormatBasics.End_of_format))
                      "Ok %d" % string) n) "find_or_make" % string
              else
                match IntErrorTable.find_opt t 0 with
                | None =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star "Some (Ok 0)" % string
                    "None" % string "find_opt" % string
                | Some p =>
                  Lwt.Infix.op_gt_gt_eq p
                    (fun function_parameter =>
                      match function_parameter with
                      | inr _ =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          "Some (Ok 0)" % string "Some (Error _)" % string
                          "find_opt" % string
                      | inl n =>
                        if negb (equiv_decb n 0) then
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            "Some (Ok 0)" % string
                            (Stdlib.Format.asprintf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Some (Ok " % string
                                  (CamlinternalFormatBasics.Int
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.Char_literal
                                      ")" % char
                                      CamlinternalFormatBasics.End_of_format)))
                                "Some (Ok %d)" % string) n) "find_opt" % string
                        else
                          IntErrorTable.remove t 0;
                          match IntErrorTable.find_opt t 0 with
                          | Some _ =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star "None" % string
                              "Some _" % string "remove;find_opt" % string
                          | None => Lwt.return_unit
                          end
                      end)
                end
            end)
      end
  end.

Definition test_add_add {A B : Type} (function_parameter : A)
  : B -> Lwt.t unit :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        let t := IntErrorTable.create 2 in
        Lwt.Infix.op_gt_gt_eq
          (IntErrorTable.find_or_make t 0
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_error_monad.Error_monad._return 0
              end))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              Lwt.Infix.op_gt_gt_eq
                (IntErrorTable.find_or_make t 0
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_error_monad.Error_monad._return 1
                    end))
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    match IntErrorTable.find_opt t 0 with
                    | None =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "Some (Ok 0)" % string "None" % string
                        "find_opt" % string
                    | Some p =>
                      Lwt.Infix.op_gt_gt_eq p
                        (fun function_parameter =>
                          match function_parameter with
                          | inr _ =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              "Some (Ok 0)" % string "Some (Error _)" % string
                              "find_opt" % string
                          | inl n =>
                            if negb (equiv_decb n 0) then
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                "Some (Ok 0)" % string
                                (Stdlib.Format.asprintf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Some (Ok " % string
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.Char_literal
                                          ")" % char
                                          CamlinternalFormatBasics.End_of_format)))
                                    "Some (Ok %d)" % string) n)
                                "find_opt" % string
                            else
                              Lwt.return_unit
                          end)
                    end
                  end)
            end)
      end
  end.

Definition test_length {A B : Type} (function_parameter : A)
  : B -> Lwt.t unit :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        let t := IntErrorTable.create 2 in
        Lwt.Infix.op_gt_gt_eq
          (IntErrorTable.find_or_make t 0
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_error_monad.Error_monad._return 0
              end))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              Lwt.Infix.op_gt_gt_eq
                (IntErrorTable.find_or_make t 1
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_error_monad.Error_monad._return 1
                    end))
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Lwt.Infix.op_gt_gt_eq
                      (IntErrorTable.find_or_make t 2
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_error_monad.Error_monad._return 2
                          end))
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          Lwt.Infix.op_gt_gt_eq
                            (IntErrorTable.find_or_make t 3
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_error_monad.Error_monad._return 3
                                end))
                            (fun function_parameter =>
                              match function_parameter with
                              | _ =>
                                let l := IntErrorTable.length t in
                                if negb (equiv_decb l 4) then
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    "4" % string
                                    (Stdlib.Format.asprintf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.Int
                                          CamlinternalFormatBasics.Int_d
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.No_precision
                                          CamlinternalFormatBasics.End_of_format)
                                        "%d" % string) l) "length" % string
                                else
                                  Lwt.return_unit
                              end)
                        end)
                  end)
            end)
      end
  end.

Definition test_self_clean {A B : Type} (function_parameter : A)
  : B -> Lwt.t unit :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        let t := IntErrorTable.create 2 in
        Lwt.Infix.op_gt_gt_eq
          (IntErrorTable.find_or_make t 0
            (fun function_parameter =>
              match function_parameter with
              | tt => Lwt._return (inl 0)
              end))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              Lwt.Infix.op_gt_gt_eq
                (IntErrorTable.find_or_make t 1
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Lwt._return (inr [])
                    end))
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Lwt.Infix.op_gt_gt_eq
                      (IntErrorTable.find_or_make t 2
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Lwt._return (inr [])
                          end))
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          Lwt.Infix.op_gt_gt_eq
                            (IntErrorTable.find_or_make t 3
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Lwt._return (inl 3)
                                end))
                            (fun function_parameter =>
                              match function_parameter with
                              | _ =>
                                Lwt.Infix.op_gt_gt_eq
                                  (IntErrorTable.find_or_make t 4
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt => Lwt._return (inl 4)
                                      end))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ =>
                                      Lwt.Infix.op_gt_gt_eq
                                        (IntErrorTable.find_or_make t 5
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt => Lwt._return (inr [])
                                            end))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | _ =>
                                            let l := IntErrorTable.length t in
                                            if negb (equiv_decb l 3) then
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                "3" % string
                                                (Stdlib.Format.asprintf
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.Int
                                                      CamlinternalFormatBasics.Int_d
                                                      CamlinternalFormatBasics.No_padding
                                                      CamlinternalFormatBasics.No_precision
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "%d" % string) l)
                                                "length" % string
                                            else
                                              Lwt.return_unit
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end
  end.

Definition test_order {A B : Type} (function_parameter : A) : B -> Lwt.t unit :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        let t := IntErrorTable.create 2 in
        match Lwt.task tt with
        | (wter, wker) =>
          let world := Stdlib.ref [] in
          let p_a :=
            Lwt.Infix.op_gt_gt_eq
              (IntErrorTable.find_or_make t 0
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Lwt.Infix.op_gt_gt_eq wter
                      (fun r =>
                        Stdlib.op_colon_eq world
                          (cons "a_inner" % string (Stdlib.op_exclamation world));
                        Lwt._return r)
                  end))
              (fun r_a =>
                Stdlib.op_colon_eq world
                  (cons "a_outer" % string (Stdlib.op_exclamation world));
                Lwt._return r_a) in
          Lwt.Infix.op_gt_gt_eq (op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let p_b :=
                  Lwt.Infix.op_gt_gt_eq
                    (IntErrorTable.find_or_make t 0
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Stdlib.op_colon_eq world
                            (cons "b_inner" % string
                              (Stdlib.op_exclamation world));
                          Lwt._return (inl 1024)
                        end))
                    (fun r_b =>
                      Stdlib.op_colon_eq world
                        (cons "b_outer" % string (Stdlib.op_exclamation world));
                      Lwt._return r_b) in
                Lwt.Infix.op_gt_gt_eq (op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Lwt.wakeup wker (inl 0);
                      Lwt.Infix.op_gt_gt_eq
                        (Lwt.Infix.op_gt_gt_eq p_a
                          (fun function_parameter =>
                            match function_parameter with
                            | inr _ =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                "Ok 0" % string "Error _" % string
                                "find_or_make(a)" % string
                            | inl n =>
                              if negb (equiv_decb n 0) then
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  "Ok 0" % string
                                  (Stdlib.Format.asprintf
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Ok " % string
                                        (CamlinternalFormatBasics.Int
                                          CamlinternalFormatBasics.Int_d
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.No_precision
                                          CamlinternalFormatBasics.End_of_format))
                                      "Ok %d" % string) n)
                                  "find_or_make(a)" % string
                              else
                                Lwt.return_unit
                            end))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Lwt.Infix.op_gt_gt_eq
                              (Lwt.Infix.op_gt_gt_eq p_b
                                (fun function_parameter =>
                                  match function_parameter with
                                  | inr _ =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      "Ok 0" % string "Error _" % string
                                      "find_or_make(b)" % string
                                  | inl n =>
                                    if negb (equiv_decb n 0) then
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        "Ok 0" % string
                                        (Stdlib.Format.asprintf
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Ok " % string
                                              (CamlinternalFormatBasics.Int
                                                CamlinternalFormatBasics.Int_d
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.No_precision
                                                CamlinternalFormatBasics.End_of_format))
                                            "Ok %d" % string) n)
                                        "find_or_make(b)" % string
                                    else
                                      Lwt.return_unit
                                  end))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  match Stdlib.op_exclamation world with
                                  |
                                    cons "b_outer" % string
                                      (cons "a_outer" % string
                                        (cons "a_inner" % string [])) |
                                      cons "a_outer" % string
                                        (cons "b_outer" % string
                                          (cons "a_inner" % string [])) =>
                                    Lwt._return tt
                                  | world =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      "[outers;a_inner]" % string
                                      (Stdlib.Format.asprintf
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Char_literal
                                            "[" % char
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                "]" % char
                                                CamlinternalFormatBasics.End_of_format)))
                                          "[%a]" % string)
                                        (Stdlib.Format.pp_print_list None
                                          Stdlib.Format.pp_print_string) world)
                                      "world" % string
                                  end
                                end)
                          end)
                    end)
              end)
        end
      end
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "add_remove" % string variant
      test_add_remove)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star "add_add" % string variant
        test_add_add)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star "length" % string variant
          test_length)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star "self_clean" % string variant
            test_length)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star "order" % string variant
              test_order) [])))).
src/lib_event_logging/internal_event.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**
   This module defines a "structured event logging framework."

   Internal-Event streams are like traditional logs but they have a proper
   {!Data_encoding} format in order to be processed by software.

   The module defines "Sinks" {!SINK} as the receptacle for structured
   events: pluggable modules which can absorb (i.e. display, store,
   forward) the events emitted within the code-base.
*)

open Tezos_error_monad
open Error_monad

(** {3 Events Definitions and Registration } *)

type level =
  | Debug
  | Info
  | Notice
  | Warning
  | Error
  | Fatal
      (** The relative importance of a particular event (compatible with
    traditional logging systems, cf. {!Lwt_log_core.level}). *)

(** Module to manipulate values of type {!level}.  *)
module Level : sig
  (** Alias of {!level}. *)
  type t = level

  (** The default level is {!Info}, it is used in {!Event_defaults}. *)
  val default : t

  (** Cast the level to a value of {!Lwt_log_core.level}. *)
  val to_lwt_log : t -> Lwt_log_core.level

  val to_string : t -> string

  val of_string : string -> t option

  val encoding : t Data_encoding.t

  val compare : t -> t -> int
end

(** Sections are a simple way of classifying events at the time of
    their emission. *)
module Section : sig
  type t = private string list

  val empty : t

  (** Build a {!Section.t} by replacing special characters with ['_']. *)
  val make_sanitized : string list -> t

  (** Make the equivalent {!Lwt_log} section.  *)
  val to_lwt_log : t -> Lwt_log_core.section

  val encoding : t Data_encoding.t

  val to_string_list : t -> string list
end

(** Parameters defining an inspectable type of events. *)
module type EVENT_DEFINITION = sig
  type t

  (** Defines the identifier for the event. Names should be unique and
      are restricted to alphanumeric characters or [".@-_+=,~"].*)
  val name : string

  (** A display-friendly test which describes what the event means. *)
  val doc : string

  val pp : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t

  (** Return the preferred {!level} for a given event instance. *)
  val level : t -> level
end

(** Default values for fields in {!EVENT_DEFINITION}. *)
module Event_defaults : sig
  (** Use this module as needed with [include Event_defaults]. *)

  val level : 'a -> level
end

(** Events created with {!Make} provide the {!EVENT} API. *)
module type EVENT = sig
  include EVENT_DEFINITION

  (** Output an event of type {!t}, if no sinks are listening the
      function won't be applied. *)
  val emit : ?section:Section.t -> (unit -> t) -> unit tzresult Lwt.t
end

(** Build an event from an event-definition. *)
module Make (E : EVENT_DEFINITION) : EVENT with type t = E.t

(** [event_definition] wraps {!EVENT_DEFINITION} as a first class module. *)
type 'a event_definition = (module EVENT_DEFINITION with type t = 'a)

(** Helper functions to manipulate all kinds of events in a generic way. *)
module Generic : sig
  type definition = Definition : (string * 'a event_definition) -> definition

  type event = Event : (string * 'a event_definition * 'a) -> event

  type with_name = < doc : string ; name : string >

  (** Get the JSON schema (together with [name] and [doc]) of a given
      event definition. *)
  val json_schema : definition -> < schema : Json_schema.schema ; with_name >

  (** Get the JSON representation and a pretty-printer for a given
        event {i instance}. *)
  val explode_event :
    event ->
    < pp : Format.formatter -> unit -> unit
    ; json : Data_encoding.json
    ; with_name >
end

(** Access to all the event definitions registered with {!Make}. *)
module All_definitions : sig
  (** Get the list of all the known definitions. *)
  val get : unit -> Generic.definition list

  (** Find the definition matching on the given name. *)
  val find : (string -> bool) -> Generic.definition option
end

(** {3 Sink Definitions and Registration } *)

(** An implementation of {!SINK} is responsible for handling/storing
    events, for instance, a sink could be output to a file, to a
    database, or a simple "memory-less" forwarding mechanism.  *)
module type SINK = sig
  (** A sink can store any required state, e.g. a database handle, in
      a value of the [t] type see {!configure}. *)
  type t

  (** Registered sinks are a distinguished by their URI scheme. *)
  val uri_scheme : string

  (** When a registered sink is activated the {!configure} function is
      called to initialize it. The parameters should be encoded or
      obtained from the URI (the scheme of the URI is already
      {!uri_scheme}). *)
  val configure : Uri.t -> t tzresult Lwt.t

  (** A sink's main function is to {!handle} incoming events from the
      code base. *)
  val handle :
    t ->
    'a event_definition ->
    ?section:Section.t ->
    (unit -> 'a) ->
    unit tzresult Lwt.t

  (** A function to be called on graceful termination of processes
      (e.g. to flush file-descriptors, etc.). *)
  val close : t -> unit tzresult Lwt.t
end

(** [sink_definition] wraps {!SINK_DEFINITION} as a first class module. *)
type 'a sink_definition = (module SINK with type t = 'a)

(** Use {!All_sinks.register} to add a new {i inactive} sink, then
    {!All_sinks.activate} to make it handle events. *)
module All_sinks : sig
  (** Register a new sink (e.g.
      [let () = Internal_event.All_sinks.register (module Sink_implementation)])
      for it to be available (but inactive) in the framework. *)
  val register : 'a sink_definition -> unit

  (** Make a registered sink active: the function finds it by URI
      scheme and calls {!configure}. *)
  val activate : Uri.t -> unit tzresult Lwt.t

  (** Call [close] on all the sinks. *)
  val close : unit -> unit tzresult Lwt.t

  (** Display the state of registered/active sinks. *)
  val pp_state : Format.formatter -> unit -> unit
end

(** {3 Common Event Definitions } *)

(** {!Error_event.t} is a generic event to emit values of type
    {!Error_monad.error list}. *)
module Error_event : sig
  (** Errors mainly store {!Error_monad.error list} values. One can
      attach a message and a severity (the default is [`Recoverable]
      which corresponds to the {!Error} {!level}, while [`Fatal]
      corresponds to {!Fatal}). *)
  type t = {
    message : string option;
    severity : [`Fatal | `Recoverable];
    trace : Error_monad.error list;
  }

  val make :
    ?message:string ->
    ?severity:[`Fatal | `Recoverable] ->
    Error_monad.error list ->
    unit ->
    t

  include EVENT with type t := t

  (** [log_error_and_recover f] calls [f ()] and emits an {!Error_event.t}
        event if it results in an error. It then continues in the [_ Lwt.t]
        monad (e.g. there is no call to [Lwt.fail]). *)
  val log_error_and_recover :
    ?section:Section.t ->
    ?message:string ->
    ?severity:[`Fatal | `Recoverable] ->
    (unit -> (unit, error list) result Lwt.t) ->
    unit Lwt.t
end

(** The debug-event is meant for emitting (temporarily)
    semi-structured data in the event stream. *)
module Debug_event : sig
  type t = {message : string; attachment : Data_encoding.Json.t}

  val make : ?attach:Data_encoding.Json.t -> string -> unit -> t

  include EVENT with type t := t
end

(** The worker event is meant for use with {!Lwt_utils.worker}. *)
module Lwt_worker_event : sig
  type t = {name : string; event : [`Ended | `Failed of string | `Started]}

  include EVENT with type t := t

  (** [on_event msg status] emits an event of type [t] and matches
        the signature required by {!Lwt_utils.worker}.  *)
  val on_event :
    string -> [`Ended | `Failed of string | `Started] -> unit Lwt.t
end

(** {3 Compatibility With Legacy Logging } *)

(** The module {!Legacy_logging} replaces the previous
    [Logging.Make_*] functors by injecting the non-structured logs
    into the event-logging framework.
    {b Please do not use for new modules.} *)
module Legacy_logging : sig
  module type LOG = sig
    val debug : ('a, Format.formatter, unit, unit) format4 -> 'a

    val log_info : ('a, Format.formatter, unit, unit) format4 -> 'a

    val log_notice : ('a, Format.formatter, unit, unit) format4 -> 'a

    val warn : ('a, Format.formatter, unit, unit) format4 -> 'a

    val log_error : ('a, Format.formatter, unit, unit) format4 -> 'a

    val fatal_error : ('a, Format.formatter, unit, unit) format4 -> 'a

    val lwt_debug : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a

    val lwt_log_info : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a

    val lwt_log_notice : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a

    val lwt_warn : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a

    val lwt_log_error : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a

    val lwt_fatal_error :
      ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
  end

  open Tezos_stdlib

  type ('a, 'b) msgf =
    (('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) ->
    ?tags:Tag.set ->
    'b

  type ('a, 'b) log = ('a, 'b) msgf -> 'b

  module type SEMLOG = sig
    module Tag = Tag

    val debug : ('a, unit) log

    val log_info : ('a, unit) log

    val log_notice : ('a, unit) log

    val warn : ('a, unit) log

    val log_error : ('a, unit) log

    val fatal_error : ('a, unit) log

    val lwt_debug : ('a, unit Lwt.t) log

    val lwt_log_info : ('a, unit Lwt.t) log

    val lwt_log_notice : ('a, unit Lwt.t) log

    val lwt_warn : ('a, unit Lwt.t) log

    val lwt_log_error : ('a, unit Lwt.t) log

    val lwt_fatal_error : ('a, unit Lwt.t) log

    val event : string Tag.def

    val exn : exn Tag.def
  end

  module Make : functor
    (_ : sig
       val name : string
     end)
    -> sig
    module Event : EVENT

    include LOG
  end

  module Make_semantic : functor
    (_ : sig
       val name : string
     end)
    -> sig
    module Event : EVENT

    include SEMLOG
  end

  val sections : string list ref
end

(** {3 Common Event-Sink Definitions } *)

(** The lwt-sink outputs pretty-printed renderings of events to the
    lwt-log logging framework (see the {!Lwt_log_core} module).

    It is activated {i by default} in {!Internal_event_unix.Configuration.default}
    (in any case it can be activated with [TEZOS_EVENTS_CONFIG="lwt-log://"]. To
    configure further how the sink outputs to a file or the user's
    terminal, one needs to use the [TEZOS_LOG] variable (see also the module
    {!Lwt_log_sink_unix}).
*)
module Lwt_log_sink : sig
  val uri_scheme : string
end
src/lib_event_logging/internal_event.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive level : Type :=
| Debug : level
| Info : level
| Notice : level
| Warning : level
| Error : level
| Fatal : level.

Module Level.
  Definition t := level.
  
  Parameter default : t.
  
  Parameter to_lwt_log : t -> Lwt_log_core.level.
  
  Parameter to_string : t -> string.
  
  Parameter of_string : string -> option t.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter compare : t -> t -> Z.
End Level.

Module Section.
  Definition t := list string.
  
  Parameter empty : t.
  
  Parameter make_sanitized : (list string) -> t.
  
  Parameter to_lwt_log : t -> Lwt_log_core.section.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter to_string_list : t -> list string.
End Section.

module_type

Module Event_defaults.
  Parameter level : forall {a : Type}, a -> level.
End Event_defaults.

module_type

unhandled_module

Definition event_definition (a : Type) :=
  {_ : unit & EVENT_DEFINITION.signature a}.

Module Generic.
  Inductive definition : Type :=
  | Definition : forall {a : Type}, (string * (event_definition a)) ->
    definition.
  
  Inductive event : Type :=
  | Event : forall {a : Type}, (string * (event_definition a) * a) -> event.
  
  Definition with_name := (string * (string * nil)).
  
  Parameter json_schema : forall {nil : Type}, definition ->
    (Json_schema.schema * (string * (string * nil))).
  
  Parameter explode_event : forall {nil : Type}, event ->
    ((Stdlib.Format.formatter -> unit -> unit) *
      (string * (Tezos_data_encoding.Data_encoding.json * (string * nil)))).
End Generic.

Module All_definitions.
  Parameter get : unit -> list Generic.definition.
  
  Parameter find : (string -> bool) -> option Generic.definition.
End All_definitions.

module_type

Definition sink_definition (a : Type) := {_ : unit & SINK.signature a}.

Module All_sinks.
  Parameter register : forall {a : Type}, (sink_definition a) -> unit.
  
  Parameter activate : Uri.t ->
    Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).
  
  Parameter close : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).
  
  Parameter pp_state : Stdlib.Format.formatter -> unit -> unit.
End All_sinks.

Module Error_event.
  Record t := {
    message : option string;
    severity : variant;
    trace : list Tezos_error_monad.Error_monad.error }.
  
  Parameter make : forall {variant : Type}, (option string) ->
    (option variant) -> (list Tezos_error_monad.Error_monad.error) -> unit -> t.
  
  include
  
  Parameter log_error_and_recover : forall {variant : Type}, (option Section.t)
    ->
    (option string) ->
      (option variant) ->
        (unit -> Lwt.t (sum unit (list Tezos_error_monad.Error_monad.error))) ->
          Lwt.t unit.
End Error_event.

Module Debug_event.
  Record t := {
    message : string;
    attachment : Tezos_data_encoding.Data_encoding.Json.t }.
  
  Parameter make : (option Tezos_data_encoding.Data_encoding.Json.t) ->
    string -> unit -> t.
  
  include
End Debug_event.

Module Lwt_worker_event.
  Record t := {
    name : string;
    event : variant }.
  
  include
  
  Parameter on_event : forall {variant : Type}, string -> variant -> Lwt.t unit.
End Lwt_worker_event.

Module Legacy_logging.
  module_type
  
  Definition msgf (a b : Type) :=
    ((Stdlib.format4 a Stdlib.Format.formatter unit b) ->
      (option Tezos_stdlib.Tag.set) -> a) -> (option Tezos_stdlib.Tag.set) -> b.
  
  Definition log (a b : Type) := (msgf a b) -> b.
  
  module_type
  
  unhandled_module
  
  unhandled_module
  
  Parameter sections : Stdlib.ref (list string).
End Legacy_logging.

Module Lwt_log_sink.
  Parameter uri_scheme : string.
End Lwt_log_sink.
src/lib_micheline/micheline.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type annot = string list

type ('l, 'p) node =
  | Int of 'l * Z.t
  | String of 'l * string
  | Bytes of 'l * Bytes.t
  | Prim of 'l * 'p * ('l, 'p) node list * annot
  | Seq of 'l * ('l, 'p) node list

type canonical_location = int

type 'p canonical = Canonical of (canonical_location, 'p) node

let canonical_location_encoding =
  let open Data_encoding in
  def
    "micheline.location"
    ~title:"Canonical location in a Micheline expression"
    ~description:
      "The location of a node in a Micheline expression tree in prefix order, \
       with zero being the root and adding one for every basic node, sequence \
       and primitive application."
  @@ int31

let location = function
  | Int (loc, _) ->
      loc
  | String (loc, _) ->
      loc
  | Bytes (loc, _) ->
      loc
  | Seq (loc, _) ->
      loc
  | Prim (loc, _, _, _) ->
      loc

let annotations = function
  | Int (_, _) ->
      []
  | String (_, _) ->
      []
  | Bytes (_, _) ->
      []
  | Seq (_, _) ->
      []
  | Prim (_, _, _, annots) ->
      annots

let root (Canonical expr) = expr

let strip_locations root =
  let id =
    let id = ref (-1) in
    fun () -> incr id ; !id
  in
  let rec strip_locations l =
    let id = id () in
    match l with
    | Int (_, v) ->
        Int (id, v)
    | String (_, v) ->
        String (id, v)
    | Bytes (_, v) ->
        Bytes (id, v)
    | Seq (_, seq) ->
        Seq (id, List.map strip_locations seq)
    | Prim (_, name, seq, annots) ->
        Prim (id, name, List.map strip_locations seq, annots)
  in
  Canonical (strip_locations root)

let extract_locations root =
  let id =
    let id = ref (-1) in
    fun () -> incr id ; !id
  in
  let loc_table = ref [] in
  let rec strip_locations l =
    let id = id () in
    match l with
    | Int (loc, v) ->
        loc_table := (id, loc) :: !loc_table ;
        Int (id, v)
    | String (loc, v) ->
        loc_table := (id, loc) :: !loc_table ;
        String (id, v)
    | Bytes (loc, v) ->
        loc_table := (id, loc) :: !loc_table ;
        Bytes (id, v)
    | Seq (loc, seq) ->
        loc_table := (id, loc) :: !loc_table ;
        Seq (id, List.map strip_locations seq)
    | Prim (loc, name, seq, annots) ->
        loc_table := (id, loc) :: !loc_table ;
        Prim (id, name, List.map strip_locations seq, annots)
  in
  let stripped = strip_locations root in
  (Canonical stripped, List.rev !loc_table)

let inject_locations lookup (Canonical root) =
  let rec inject_locations l =
    match l with
    | Int (loc, v) ->
        Int (lookup loc, v)
    | String (loc, v) ->
        String (lookup loc, v)
    | Bytes (loc, v) ->
        Bytes (lookup loc, v)
    | Seq (loc, seq) ->
        Seq (lookup loc, List.map inject_locations seq)
    | Prim (loc, name, seq, annots) ->
        Prim (lookup loc, name, List.map inject_locations seq, annots)
  in
  inject_locations root

let map f (Canonical expr) =
  let rec map_node f = function
    | (Int _ | String _ | Bytes _) as node ->
        node
    | Seq (loc, seq) ->
        Seq (loc, List.map (map_node f) seq)
    | Prim (loc, name, seq, annots) ->
        Prim (loc, f name, List.map (map_node f) seq, annots)
  in
  Canonical (map_node f expr)

let rec map_node fl fp = function
  | Int (loc, v) ->
      Int (fl loc, v)
  | String (loc, v) ->
      String (fl loc, v)
  | Bytes (loc, v) ->
      Bytes (fl loc, v)
  | Seq (loc, seq) ->
      Seq (fl loc, List.map (map_node fl fp) seq)
  | Prim (loc, name, seq, annots) ->
      Prim (fl loc, fp name, List.map (map_node fl fp) seq, annots)

type semantics = V0 | V1

let internal_canonical_encoding ~semantics ~variant prim_encoding =
  let open Data_encoding in
  let int_encoding = obj1 (req "int" z) in
  let string_encoding = obj1 (req "string" string) in
  let bytes_encoding = obj1 (req "bytes" bytes) in
  let int_encoding tag =
    case
      tag
      int_encoding
      ~title:"Int"
      (function Int (_, v) -> Some v | _ -> None)
      (fun v -> Int (0, v))
  in
  let string_encoding tag =
    case
      tag
      string_encoding
      ~title:"String"
      (function String (_, v) -> Some v | _ -> None)
      (fun v -> String (0, v))
  in
  let bytes_encoding tag =
    case
      tag
      bytes_encoding
      ~title:"Bytes"
      (function Bytes (_, v) -> Some v | _ -> None)
      (fun v -> Bytes (0, v))
  in
  let seq_encoding tag expr_encoding =
    case
      tag
      (list expr_encoding)
      ~title:"Sequence"
      (function Seq (_, v) -> Some v | _ -> None)
      (fun args -> Seq (0, args))
  in
  let annots_encoding =
    let split s =
      if s = "" && semantics <> V0 then []
      else
        let annots = String.split_on_char ' ' s in
        List.iter
          (fun a ->
            if String.length a > 255 then failwith "Oversized annotation")
          annots ;
        if String.concat " " annots <> s then
          failwith
            "Invalid annotation string, must be a sequence of valid \
             annotations with spaces" ;
        annots
    in
    splitted
      ~json:(list (Bounded.string 255))
      ~binary:(conv (String.concat " ") split string)
  in
  let application_encoding tag expr_encoding =
    case
      tag
      ~title:"Generic prim (any number of args with or without annot)"
      (obj3
         (req "prim" prim_encoding)
         (dft "args" (list expr_encoding) [])
         (dft "annots" annots_encoding []))
      (function
        | Prim (_, prim, args, annots) -> Some (prim, args, annots) | _ -> None)
      (fun (prim, args, annots) -> Prim (0, prim, args, annots))
  in
  let node_encoding =
    mu
      ("micheline." ^ variant ^ ".expression")
      (fun expr_encoding ->
        splitted
          ~json:
            (union
               ~tag_size:`Uint8
               [ int_encoding Json_only;
                 string_encoding Json_only;
                 bytes_encoding Json_only;
                 seq_encoding Json_only expr_encoding;
                 application_encoding Json_only expr_encoding ])
          ~binary:
            (union
               ~tag_size:`Uint8
               [ int_encoding (Tag 0);
                 string_encoding (Tag 1);
                 seq_encoding (Tag 2) expr_encoding;
                 (* No args, no annot *)
                 case
                   (Tag 3)
                   ~title:"Prim (no args, annot)"
                   (obj1 (req "prim" prim_encoding))
                   (function Prim (_, v, [], []) -> Some v | _ -> None)
                   (fun v -> Prim (0, v, [], []));
                 (* No args, with annots *)
                 case
                   (Tag 4)
                   ~title:"Prim (no args + annot)"
                   (obj2
                      (req "prim" prim_encoding)
                      (req "annots" annots_encoding))
                   (function
                     | Prim (_, v, [], annots) -> Some (v, annots) | _ -> None)
                   (function (prim, annots) -> Prim (0, prim, [], annots));
                 (* Single arg, no annot *)
                 case
                   (Tag 5)
                   ~title:"Prim (1 arg, no annot)"
                   (obj2 (req "prim" prim_encoding) (req "arg" expr_encoding))
                   (function
                     | Prim (_, v, [arg], []) -> Some (v, arg) | _ -> None)
                   (function (prim, arg) -> Prim (0, prim, [arg], []));
                 (* Single arg, with annot *)
                 case
                   (Tag 6)
                   ~title:"Prim (1 arg + annot)"
                   (obj3
                      (req "prim" prim_encoding)
                      (req "arg" expr_encoding)
                      (req "annots" annots_encoding))
                   (function
                     | Prim (_, prim, [arg], annots) ->
                         Some (prim, arg, annots)
                     | _ ->
                         None)
                   (fun (prim, arg, annots) -> Prim (0, prim, [arg], annots));
                 (* Two args, no annot *)
                 case
                   (Tag 7)
                   ~title:"Prim (2 args, no annot)"
                   (obj3
                      (req "prim" prim_encoding)
                      (req "arg1" expr_encoding)
                      (req "arg2" expr_encoding))
                   (function
                     | Prim (_, prim, [arg1; arg2], []) ->
                         Some (prim, arg1, arg2)
                     | _ ->
                         None)
                   (fun (prim, arg1, arg2) -> Prim (0, prim, [arg1; arg2], []));
                 (* Two args, with annots *)
                 case
                   (Tag 8)
                   ~title:"Prim (2 args + annot)"
                   (obj4
                      (req "prim" prim_encoding)
                      (req "arg1" expr_encoding)
                      (req "arg2" expr_encoding)
                      (req "annots" annots_encoding))
                   (function
                     | Prim (_, prim, [arg1; arg2], annots) ->
                         Some (prim, arg1, arg2, annots)
                     | _ ->
                         None)
                   (fun (prim, arg1, arg2, annots) ->
                     Prim (0, prim, [arg1; arg2], annots));
                 (* General case *)
                 application_encoding (Tag 9) expr_encoding;
                 bytes_encoding (Tag 10) ]))
  in
  conv
    (function Canonical node -> node)
    (fun node -> strip_locations node)
    node_encoding

let canonical_encoding ~variant prim_encoding =
  internal_canonical_encoding ~semantics:V1 ~variant prim_encoding

let canonical_encoding_v1 ~variant prim_encoding =
  internal_canonical_encoding ~semantics:V1 ~variant prim_encoding

let canonical_encoding_v0 ~variant prim_encoding =
  internal_canonical_encoding ~semantics:V0 ~variant prim_encoding

let table_encoding ~variant location_encoding prim_encoding =
  let open Data_encoding in
  conv
    (fun node ->
      let (canon, assoc) = extract_locations node in
      let (_, table) = List.split assoc in
      (canon, table))
    (fun (canon, table) ->
      let table = Array.of_list table in
      inject_locations (fun i -> table.(i)) canon)
    (obj2
       (req "expression" (canonical_encoding ~variant prim_encoding))
       (req "locations" (list location_encoding)))

let erased_encoding ~variant default_location prim_encoding =
  let open Data_encoding in
  conv
    (fun node -> strip_locations node)
    (fun canon -> inject_locations (fun _ -> default_location) canon)
    (canonical_encoding ~variant prim_encoding)
src/lib_micheline/micheline.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition annot := list string.

Inductive node (l p : Type) : Type :=
| Int : l -> Z.t -> node l p
| String : l -> string -> node l p
| Bytes : l -> Stdlib.Bytes.t -> node l p
| Prim : l -> p -> (list (node l p)) -> annot -> node l p
| Seq : l -> (list (node l p)) -> node l p.

Arguments Int {_ _}.
Arguments String {_ _}.
Arguments Bytes {_ _}.
Arguments Prim {_ _}.
Arguments Seq {_ _}.

Definition canonical_location := Z.

Inductive canonical (p : Type) : Type :=
| Canonical : (node canonical_location p) -> canonical p.

Arguments Canonical {_}.

Definition canonical_location_encoding
  : Tezos_data_encoding.Data_encoding.encoding Z :=
  apply
    (Tezos_data_encoding.Data_encoding.def "micheline.location" % string
      (Some "Canonical location in a Micheline expression" % string)
      (Some
        "The location of a node in a Micheline expression tree in prefix order, with zero being the root and adding one for every basic node, sequence and primitive application."
          % string)) Tezos_data_encoding.Data_encoding.int31.

Definition location {A B : Type} (function_parameter : node A B) : A :=
  match function_parameter with
  | Int loc _ => loc
  | String loc _ => loc
  | Bytes loc _ => loc
  | Seq loc _ => loc
  | Prim loc _ _ _ => loc
  end.

Definition annotations {A B : Type} (function_parameter : node A B) : annot :=
  match function_parameter with
  | Int _ _ => []
  | String _ _ => []
  | Bytes _ _ => []
  | Seq _ _ => []
  | Prim _ _ _ annots => annots
  end.

Definition root {A : Type} (function_parameter : canonical A)
  : node canonical_location A :=
  match function_parameter with
  | Canonical expr => expr
  end.

Definition strip_locations {A B : Type} (root : node A B) : canonical B :=
  let id :=
    let id := Stdlib.ref (-1) in
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Stdlib.incr id;
        Stdlib.op_exclamation id
      end in
  let fix strip_locations {C D : Type} (l : node C D) : node Z D :=
    let id := id tt in
    match l with
    | Int _ v => Int id v
    | String _ v => String id v
    | Bytes _ v => Bytes id v
    | Seq _ seq => Seq id (List.map strip_locations seq)
    | Prim _ name seq annots =>
      Prim id name (List.map strip_locations seq) annots
    end in
  Canonical (strip_locations root).

Definition extract_locations {A B : Type} (root : node A B)
  : (canonical B) * (list (Z * A)) :=
  let id :=
    let id := Stdlib.ref (-1) in
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Stdlib.incr id;
        Stdlib.op_exclamation id
      end in
  let loc_table := Stdlib.ref [] in
  let fix strip_locations {C : Type} (l : node A C) : node Z C :=
    let id := id tt in
    match l with
    | Int loc v =>
      Stdlib.op_colon_eq loc_table
        (cons (id, loc) (Stdlib.op_exclamation loc_table));
      Int id v
    | String loc v =>
      Stdlib.op_colon_eq loc_table
        (cons (id, loc) (Stdlib.op_exclamation loc_table));
      String id v
    | Bytes loc v =>
      Stdlib.op_colon_eq loc_table
        (cons (id, loc) (Stdlib.op_exclamation loc_table));
      Bytes id v
    | Seq loc seq =>
      Stdlib.op_colon_eq loc_table
        (cons (id, loc) (Stdlib.op_exclamation loc_table));
      Seq id (List.map strip_locations seq)
    | Prim loc name seq annots =>
      Stdlib.op_colon_eq loc_table
        (cons (id, loc) (Stdlib.op_exclamation loc_table));
      Prim id name (List.map strip_locations seq) annots
    end in
  let stripped := strip_locations root in
  ((Canonical stripped), (List.rev (Stdlib.op_exclamation loc_table))).

Definition inject_locations {A B : Type}
  (lookup : canonical_location -> A) (function_parameter : canonical B)
  : node A B :=
  match function_parameter with
  | Canonical root =>
    let fix inject_locations {C : Type} (l : node canonical_location C)
      : node A C :=
      match l with
      | Int loc v => Int (lookup loc) v
      | String loc v => String (lookup loc) v
      | Bytes loc v => Bytes (lookup loc) v
      | Seq loc seq => Seq (lookup loc) (List.map inject_locations seq)
      | Prim loc name seq annots =>
        Prim (lookup loc) name (List.map inject_locations seq) annots
      end in
    inject_locations root
  end.

Definition map {A B : Type} (f : A -> B) (function_parameter : canonical A)
  : canonical B :=
  match function_parameter with
  | Canonical expr =>
    let fix map_node {C D E : Type} (f : C -> D) (function_parameter : node E C)
      : node E D :=
      match function_parameter with
      | (Int _ _ | String _ _ | Bytes _ _) as node => node
      | Seq loc seq => Seq loc (List.map (map_node f) seq)
      | Prim loc name seq annots =>
        Prim loc (f name) (List.map (map_node f) seq) annots
      end in
    Canonical (map_node f expr)
  end.

Fixpoint map_node {A B C D : Type}
  (fl : A -> B) (fp : C -> D) (function_parameter : node A C) : node B D :=
  match function_parameter with
  | Int loc v => Int (fl loc) v
  | String loc v => String (fl loc) v
  | Bytes loc v => Bytes (fl loc) v
  | Seq loc seq => Seq (fl loc) (List.map (map_node fl fp) seq)
  | Prim loc name seq annots =>
    Prim (fl loc) (fp name) (List.map (map_node fl fp) seq) annots
  end.

Inductive semantics : Type :=
| V0 : semantics
| V1 : semantics.

Definition internal_canonical_encoding {A : Type}
  (semantics : semantics) (variant : string)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
  let int_encoding :=
    Tezos_data_encoding.Data_encoding.obj1
      (Tezos_data_encoding.Data_encoding.req None None "int" % string
        Tezos_data_encoding.Data_encoding.z) in
  let string_encoding :=
    Tezos_data_encoding.Data_encoding.obj1
      (Tezos_data_encoding.Data_encoding.req None None "string" % string
        Tezos_data_encoding.Data_encoding.string) in
  let bytes_encoding :=
    Tezos_data_encoding.Data_encoding.obj1
      (Tezos_data_encoding.Data_encoding.req None None "bytes" % string
        Tezos_data_encoding.Data_encoding.bytes) in
  let int_encoding {B : Type} (tag : Tezos_data_encoding.Data_encoding.case_tag)
    : Tezos_data_encoding.Data_encoding.case (node Z B) :=
    Tezos_data_encoding.Data_encoding.case "Int" % string None tag int_encoding
      (fun function_parameter =>
        match function_parameter with
        | Int _ v => Some v
        | _ => None
        end) (fun v => Int 0 v) in
  let string_encoding {B : Type}
    (tag : Tezos_data_encoding.Data_encoding.case_tag)
    : Tezos_data_encoding.Data_encoding.case (node Z B) :=
    Tezos_data_encoding.Data_encoding.case "String" % string None tag
      string_encoding
      (fun function_parameter =>
        match function_parameter with
        | String _ v => Some v
        | _ => None
        end) (fun v => String 0 v) in
  let bytes_encoding {B : Type}
    (tag : Tezos_data_encoding.Data_encoding.case_tag)
    : Tezos_data_encoding.Data_encoding.case (node Z B) :=
    Tezos_data_encoding.Data_encoding.case "Bytes" % string None tag
      bytes_encoding
      (fun function_parameter =>
        match function_parameter with
        | Bytes _ v => Some v
        | _ => None
        end) (fun v => Bytes 0 v) in
  let seq_encoding {B : Type}
    (tag : Tezos_data_encoding.Data_encoding.case_tag) (expr_encoding :
    Tezos_data_encoding.Data_encoding.encoding (node Z B))
    : Tezos_data_encoding.Data_encoding.case (node Z B) :=
    Tezos_data_encoding.Data_encoding.case "Sequence" % string None tag
      (Tezos_data_encoding.Data_encoding.list None expr_encoding)
      (fun function_parameter =>
        match function_parameter with
        | Seq _ v => Some v
        | _ => None
        end) (fun args => Seq 0 args) in
  let annots_encoding :=
    let split (s : string) : list string :=
      if andb (equiv_decb s "" % string) (nequiv_decb semantics V0) then
        []
      else
        let annots := Stdlib.String.split_on_char " " % char s in
        Stdlib.List.iter
          (fun a =>
            if OCaml.Stdlib.gt (OCaml.String.length a) 255 then
              OCaml.Stdlib.failwith "Oversized annotation" % string
            else
              tt) annots;
        if nequiv_decb (Stdlib.String.concat " " % string annots) s then
          OCaml.Stdlib.failwith
            "Invalid annotation string, must be a sequence of valid annotations with spaces"
              % string
        else
          tt;
        annots in
    Tezos_data_encoding.Data_encoding.splitted
      (Tezos_data_encoding.Data_encoding.list None
        (Tezos_data_encoding.Data_encoding.Bounded.string 255))
      (Tezos_data_encoding.Data_encoding.conv
        (Stdlib.String.concat " " % string) split None
        Tezos_data_encoding.Data_encoding.string) in
  let application_encoding
    (tag : Tezos_data_encoding.Data_encoding.case_tag) (expr_encoding :
    Tezos_data_encoding.Data_encoding.encoding (node Z A))
    : Tezos_data_encoding.Data_encoding.case (node Z A) :=
    Tezos_data_encoding.Data_encoding.case
      "Generic prim (any number of args with or without annot)" % string None
      tag
      (Tezos_data_encoding.Data_encoding.obj3
        (Tezos_data_encoding.Data_encoding.req None None "prim" % string
          prim_encoding)
        (Tezos_data_encoding.Data_encoding.dft None None "args" % string
          (Tezos_data_encoding.Data_encoding.list None expr_encoding) [])
        (Tezos_data_encoding.Data_encoding.dft None None "annots" % string
          annots_encoding []))
      (fun function_parameter =>
        match function_parameter with
        | Prim _ prim args annots => Some (prim, args, annots)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | (prim, args, annots) => Prim 0 prim args annots
        end) in
  let node_encoding :=
    Tezos_data_encoding.Data_encoding.mu
      (String.append "micheline." % string
        (String.append variant ".expression" % string)) None None
      (fun expr_encoding =>
        Tezos_data_encoding.Data_encoding.splitted
          (Tezos_data_encoding.Data_encoding.union (Some variant)
            (cons (int_encoding Json_only)
              (cons (string_encoding Json_only)
                (cons (bytes_encoding Json_only)
                  (cons (seq_encoding Json_only expr_encoding)
                    (cons (application_encoding Json_only expr_encoding) []))))))
          (Tezos_data_encoding.Data_encoding.union (Some variant)
            (cons (int_encoding (Tag 0))
              (cons (string_encoding (Tag 1))
                (cons (seq_encoding (Tag 2) expr_encoding)
                  (cons
                    (Tezos_data_encoding.Data_encoding.case
                      "Prim (no args, annot)" % string None (Tag 3)
                      (Tezos_data_encoding.Data_encoding.obj1
                        (Tezos_data_encoding.Data_encoding.req None None
                          "prim" % string prim_encoding))
                      (fun function_parameter =>
                        match function_parameter with
                        | Prim _ v [] [] => Some v
                        | _ => None
                        end) (fun v => Prim 0 v [] []))
                    (cons
                      (Tezos_data_encoding.Data_encoding.case
                        "Prim (no args + annot)" % string None (Tag 4)
                        (Tezos_data_encoding.Data_encoding.obj2
                          (Tezos_data_encoding.Data_encoding.req None None
                            "prim" % string prim_encoding)
                          (Tezos_data_encoding.Data_encoding.req None None
                            "annots" % string annots_encoding))
                        (fun function_parameter =>
                          match function_parameter with
                          | Prim _ v [] annots => Some (v, annots)
                          | _ => None
                          end)
                        (fun function_parameter =>
                          match function_parameter with
                          | (prim, annots) => Prim 0 prim [] annots
                          end))
                      (cons
                        (Tezos_data_encoding.Data_encoding.case
                          "Prim (1 arg, no annot)" % string None (Tag 5)
                          (Tezos_data_encoding.Data_encoding.obj2
                            (Tezos_data_encoding.Data_encoding.req None None
                              "prim" % string prim_encoding)
                            (Tezos_data_encoding.Data_encoding.req None None
                              "arg" % string expr_encoding))
                          (fun function_parameter =>
                            match function_parameter with
                            | Prim _ v (cons arg []) [] => Some (v, arg)
                            | _ => None
                            end)
                          (fun function_parameter =>
                            match function_parameter with
                            | (prim, arg) => Prim 0 prim (cons arg []) []
                            end))
                        (cons
                          (Tezos_data_encoding.Data_encoding.case
                            "Prim (1 arg + annot)" % string None (Tag 6)
                            (Tezos_data_encoding.Data_encoding.obj3
                              (Tezos_data_encoding.Data_encoding.req None None
                                "prim" % string prim_encoding)
                              (Tezos_data_encoding.Data_encoding.req None None
                                "arg" % string expr_encoding)
                              (Tezos_data_encoding.Data_encoding.req None None
                                "annots" % string annots_encoding))
                            (fun function_parameter =>
                              match function_parameter with
                              | Prim _ prim (cons arg []) annots =>
                                Some (prim, arg, annots)
                              | _ => None
                              end)
                            (fun function_parameter =>
                              match function_parameter with
                              | (prim, arg, annots) =>
                                Prim 0 prim (cons arg []) annots
                              end))
                          (cons
                            (Tezos_data_encoding.Data_encoding.case
                              "Prim (2 args, no annot)" % string None (Tag 7)
                              (Tezos_data_encoding.Data_encoding.obj3
                                (Tezos_data_encoding.Data_encoding.req None None
                                  "prim" % string prim_encoding)
                                (Tezos_data_encoding.Data_encoding.req None None
                                  "arg1" % string expr_encoding)
                                (Tezos_data_encoding.Data_encoding.req None None
                                  "arg2" % string expr_encoding))
                              (fun function_parameter =>
                                match function_parameter with
                                | Prim _ prim (cons arg1 (cons arg2 [])) [] =>
                                  Some (prim, arg1, arg2)
                                | _ => None
                                end)
                              (fun function_parameter =>
                                match function_parameter with
                                | (prim, arg1, arg2) =>
                                  Prim 0 prim (cons arg1 (cons arg2 [])) []
                                end))
                            (cons
                              (Tezos_data_encoding.Data_encoding.case
                                "Prim (2 args + annot)" % string None (Tag 8)
                                (Tezos_data_encoding.Data_encoding.obj4
                                  (Tezos_data_encoding.Data_encoding.req None
                                    None "prim" % string prim_encoding)
                                  (Tezos_data_encoding.Data_encoding.req None
                                    None "arg1" % string expr_encoding)
                                  (Tezos_data_encoding.Data_encoding.req None
                                    None "arg2" % string expr_encoding)
                                  (Tezos_data_encoding.Data_encoding.req None
                                    None "annots" % string annots_encoding))
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    Prim _ prim (cons arg1 (cons arg2 []))
                                      annots => Some (prim, arg1, arg2, annots)
                                  | _ => None
                                  end)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (prim, arg1, arg2, annots) =>
                                    Prim 0 prim (cons arg1 (cons arg2 []))
                                      annots
                                  end))
                              (cons (application_encoding (Tag 9) expr_encoding)
                                (cons (bytes_encoding (Tag 10)) [])))))))))))))
    in
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | Canonical node => node
      end) (fun node => strip_locations node) None node_encoding.

Definition canonical_encoding {A : Type}
  (variant : string)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
  internal_canonical_encoding V1 variant prim_encoding.

Definition canonical_encoding_v1 {A : Type}
  (variant : string)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
  internal_canonical_encoding V1 variant prim_encoding.

Definition canonical_encoding_v0 {A : Type}
  (variant : string)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
  internal_canonical_encoding V0 variant prim_encoding.

Definition table_encoding {A B : Type}
  (variant : string)
  (location_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding B)
  : Tezos_data_encoding.Data_encoding.encoding (node A B) :=
  Tezos_data_encoding.Data_encoding.conv
    (fun node =>
      match extract_locations node with
      | (canon, assoc) =>
        match Stdlib.List.split assoc with
        | (_, table) => (canon, table)
        end
      end)
    (fun function_parameter =>
      match function_parameter with
      | (canon, table) =>
        let table := Stdlib.Array.of_list table in
        inject_locations (fun i => Stdlib.Array.get table i) canon
      end) None
    (Tezos_data_encoding.Data_encoding.obj2
      (Tezos_data_encoding.Data_encoding.req None None "expression" % string
        (canonical_encoding variant prim_encoding))
      (Tezos_data_encoding.Data_encoding.req None None "locations" % string
        (Tezos_data_encoding.Data_encoding.list None location_encoding))).

Definition erased_encoding {A B : Type}
  (variant : string) (default_location : A)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding B)
  : Tezos_data_encoding.Data_encoding.encoding (node A B) :=
  Tezos_data_encoding.Data_encoding.conv (fun node => strip_locations node)
    (fun canon =>
      inject_locations
        (fun function_parameter =>
          match function_parameter with
          | _ => default_location
          end) canon) None (canonical_encoding variant prim_encoding).
src/lib_micheline/micheline.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type annot = string list

(** The abstract syntax tree of Micheline expressions. The first
    parameter is used to contain locations, but can also embed custom
    data. The second parameter is the type of primitive names. *)
type ('l, 'p) node =
  | Int of 'l * Z.t
  | String of 'l * string
  | Bytes of 'l * Bytes.t
  | Prim of 'l * 'p * ('l, 'p) node list * annot
  | Seq of 'l * ('l, 'p) node list

(** Encoding for expressions, as their {!canonical} encoding.
    Locations are stored in a side table.
    See {!canonical_encoding} for the [variant] parameter. *)
val table_encoding :
  variant:string ->
  'l Data_encoding.encoding ->
  'p Data_encoding.encoding ->
  ('l, 'p) node Data_encoding.encoding

(** Encoding for expressions, as their {!canonical} encoding.
    Locations are erased when serialized, and restored to a provided
    default value when deserialized.
    See {!canonical_encoding} for the [variant] parameter. *)
val erased_encoding :
  variant:string ->
  'l ->
  'p Data_encoding.encoding ->
  ('l, 'p) node Data_encoding.encoding

(** Extract the location of the node. *)
val location : ('l, 'p) node -> 'l

(** Extract the annotations of the node. *)
val annotations : ('l, 'p) node -> string list

(** Expression form using canonical integer numbering as
    locations. The root has number zero, and each node adds one in the
    order of infix traversal. To be used when locations are not
    important, or when one wants to attach properties to nodes in an
    expression without rewriting it (using an indirection table with
    canonical locations as keys). *)
type 'p canonical

(** Canonical integer locations that appear inside {!canonical} expressions. *)
type canonical_location = int

(** Encoding for canonical integer locations. *)
val canonical_location_encoding : canonical_location Data_encoding.encoding

(** Encoding for expressions in canonical form. The first parameter
    is a name used to produce named definitions in the schemas. Make
    sure to use different names if two expression variants with
    different primitive encodings are used in the same schema. *)
val canonical_encoding :
  variant:string ->
  'l Data_encoding.encoding ->
  'l canonical Data_encoding.encoding

(** Old version of {!canonical_encoding} for retrocompatibility.
    Do not use in new code. *)
val canonical_encoding_v0 :
  variant:string ->
  'l Data_encoding.encoding ->
  'l canonical Data_encoding.encoding

(** Alias for {!canonical_encoding}. *)
val canonical_encoding_v1 :
  variant:string ->
  'l Data_encoding.encoding ->
  'l canonical Data_encoding.encoding

(** Compute the canonical form of an expression.
    Drops the concrete locations completely. *)
val strip_locations : (_, 'p) node -> 'p canonical

(** Give the root node of an expression in canonical form. *)
val root : 'p canonical -> (canonical_location, 'p) node

(** Compute the canonical form of an expression.
    Saves the concrete locations in an association list. *)
val extract_locations :
  ('l, 'p) node -> 'p canonical * (canonical_location * 'l) list

(** Transforms an expression in canonical form into a polymorphic one.
    Takes a mapping function to inject the concrete locations. *)
val inject_locations :
  (canonical_location -> 'l) -> 'p canonical -> ('l, 'p) node

(** Copies the tree, updating its primitives. *)
val map : ('a -> 'b) -> 'a canonical -> 'b canonical

(** Copies the tree, updating its primitives and locations. *)
val map_node :
  ('la -> 'lb) -> ('pa -> 'pb) -> ('la, 'pa) node -> ('lb, 'pb) node
src/lib_micheline/micheline.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition annot := list string.

Inductive node (l p : Type) : Type :=
| Int : l -> Z.t -> node l p
| String : l -> string -> node l p
| Bytes : l -> Stdlib.Bytes.t -> node l p
| Prim : l -> p -> (list (node l p)) -> annot -> node l p
| Seq : l -> (list (node l p)) -> node l p.

Arguments Int {_ _}.
Arguments String {_ _}.
Arguments Bytes {_ _}.
Arguments Prim {_ _}.
Arguments Seq {_ _}.

Parameter table_encoding : forall {l p : Type},
string ->
  (Tezos_data_encoding.Data_encoding.encoding l) ->
    (Tezos_data_encoding.Data_encoding.encoding p) ->
      Tezos_data_encoding.Data_encoding.encoding (node l p).

Parameter erased_encoding : forall {l p : Type},
string ->
  l ->
    (Tezos_data_encoding.Data_encoding.encoding p) ->
      Tezos_data_encoding.Data_encoding.encoding (node l p).

Parameter location : forall {l p : Type}, (node l p) -> l.

Parameter annotations : forall {l p : Type}, (node l p) -> list string.

Parameter canonical : forall (p : Type), Type.

Definition canonical_location := Z.

Parameter canonical_location_encoding :
Tezos_data_encoding.Data_encoding.encoding canonical_location.

Parameter canonical_encoding : forall {l : Type},
string ->
  (Tezos_data_encoding.Data_encoding.encoding l) ->
    Tezos_data_encoding.Data_encoding.encoding (canonical l).

Parameter canonical_encoding_v0 : forall {l : Type},
string ->
  (Tezos_data_encoding.Data_encoding.encoding l) ->
    Tezos_data_encoding.Data_encoding.encoding (canonical l).

Parameter canonical_encoding_v1 : forall {l : Type},
string ->
  (Tezos_data_encoding.Data_encoding.encoding l) ->
    Tezos_data_encoding.Data_encoding.encoding (canonical l).

Parameter strip_locations : forall {_ p : Type}, (node _ p) -> canonical p.

Parameter root : forall {p : Type}, (canonical p) -> node canonical_location p.

Parameter extract_locations : forall {l p : Type},
(node l p) -> (canonical p) * (list (canonical_location * l)).

Parameter inject_locations : forall {l p : Type},
(canonical_location -> l) -> (canonical p) -> node l p.

Parameter map : forall {a b : Type}, (a -> b) -> (canonical a) -> canonical b.

Parameter map_node : forall {la lb pa pb : Type},
(la -> lb) -> (pa -> pb) -> (node la pa) -> node lb pb.
src/lib_micheline/micheline_parser.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad
open Micheline

type 'a parsing_result = 'a * error list

type point = {point : int; byte : int; line : int; column : int}

let point_zero = {point = 0; byte = 0; line = 0; column = 0}

let point_encoding =
  let open Data_encoding in
  conv
    (fun {line; column; point; byte} -> (line, column, point, byte))
    (fun (line, column, point, byte) -> {line; column; point; byte})
    (obj4
       (req "line" uint16)
       (req "column" uint16)
       (req "point" uint16)
       (req "byte" uint16))

type location = {start : point; stop : point}

let location_zero = {start = point_zero; stop = point_zero}

let location_encoding =
  let open Data_encoding in
  conv
    (fun {start; stop} -> (start, stop))
    (fun (start, stop) -> {start; stop})
    (obj2 (req "start" point_encoding) (req "stop" point_encoding))

type token_value =
  | String of string
  | Bytes of string
  | Int of string
  | Ident of string
  | Annot of string
  | Comment of string
  | Eol_comment of string
  | Semi
  | Open_paren
  | Close_paren
  | Open_brace
  | Close_brace

let token_value_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"String"
        (obj1 (req "string" string))
        (function String s -> Some s | _ -> None)
        (fun s -> String s);
      case
        (Tag 1)
        ~title:"Int"
        (obj1 (req "int" string))
        (function Int s -> Some s | _ -> None)
        (fun s -> Int s);
      case
        (Tag 2)
        ~title:"Annot"
        (obj1 (req "annot" string))
        (function Annot s -> Some s | _ -> None)
        (fun s -> Annot s);
      case
        (Tag 3)
        ~title:"Comment"
        (obj2 (req "comment" string) (dft "end_of_line" bool false))
        (function
          | Comment s ->
              Some (s, false)
          | Eol_comment s ->
              Some (s, true)
          | _ ->
              None)
        (function (s, false) -> Comment s | (s, true) -> Eol_comment s);
      case
        (Tag 4)
        ~title:"Punctuation"
        (obj1
           (req
              "punctuation"
              (string_enum
                 [ ("(", Open_paren);
                   (")", Close_paren);
                   ("{", Open_brace);
                   ("}", Close_brace);
                   (";", Semi) ])))
        (fun t -> Some t)
        (fun t -> t);
      case
        (Tag 5)
        ~title:"Bytes"
        (obj1 (req "bytes" string))
        (function Bytes s -> Some s | _ -> None)
        (fun s -> Bytes s) ]

type token = {token : token_value; loc : location}

let max_annot_length = 255

type error += Invalid_utf8_sequence of point * string

type error += Unexpected_character of point * string

type error += Undefined_escape_sequence of point * string

type error += Missing_break_after_number of point

type error += Unterminated_string of location

type error += Unterminated_integer of location

type error += Odd_lengthed_bytes of location

type error += Unterminated_comment of location

type error += Annotation_length of location

let tokenize source =
  let decoder = Uutf.decoder ~encoding:`UTF_8 (`String source) in
  let here () =
    {
      point = Uutf.decoder_count decoder;
      byte = Uutf.decoder_byte_count decoder;
      line = Uutf.decoder_line decoder;
      column = Uutf.decoder_col decoder;
    }
  in
  let tok start stop token = {loc = {start; stop}; token} in
  let stack = ref [] in
  let errors = ref [] in
  let rec next () =
    match !stack with
    | charloc :: charlocs ->
        stack := charlocs ;
        charloc
    | [] -> (
        let loc = here () in
        match Uutf.decode decoder with
        | `Await ->
            assert false
        | `Malformed s ->
            errors := Invalid_utf8_sequence (loc, s) :: !errors ;
            next ()
        | (`Uchar _ | `End) as other ->
            (other, loc) )
  in
  let back charloc = stack := charloc :: !stack in
  let uchar_to_char c =
    if Uchar.is_char c then Some (Uchar.to_char c) else None
  in
  let allowed_ident_char c =
    match uchar_to_char c with
    | Some ('a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9') ->
        true
    | Some _ | None ->
        false
  in
  let allowed_annot_char c =
    match uchar_to_char c with
    | Some ('a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9') ->
        true
    | Some _ | None ->
        false
  in
  let rec skip acc =
    match next () with
    | (`End, _) ->
        List.rev acc
    | (`Uchar c, start) -> (
      match uchar_to_char c with
      | Some ('a' .. 'z' | 'A' .. 'Z') ->
          ident acc start (fun s _ -> Ident s)
      | Some ('@' | ':' | '$' | '&' | '%' | '!' | '?') ->
          annot acc start (fun str stop ->
              if String.length str > max_annot_length then
                errors := Annotation_length {start; stop} :: !errors ;
              Annot str)
      | Some '-' -> (
        match next () with
        | (`End, stop) ->
            errors := Unterminated_integer {start; stop} :: !errors ;
            List.rev acc
        | (`Uchar c, stop) as first -> (
          match uchar_to_char c with
          | Some '0' ->
              base acc start
          | Some '1' .. '9' ->
              integer acc start
          | Some _ | None ->
              errors := Unterminated_integer {start; stop} :: !errors ;
              back first ;
              skip acc ) )
      | Some '0' ->
          base acc start
      | Some '1' .. '9' ->
          integer acc start
      | Some (' ' | '\n') ->
          skip acc
      | Some ';' ->
          skip (tok start (here ()) Semi :: acc)
      | Some '{' ->
          skip (tok start (here ()) Open_brace :: acc)
      | Some '}' ->
          skip (tok start (here ()) Close_brace :: acc)
      | Some '(' ->
          skip (tok start (here ()) Open_paren :: acc)
      | Some ')' ->
          skip (tok start (here ()) Close_paren :: acc)
      | Some '"' ->
          string acc [] start
      | Some '#' ->
          eol_comment acc start
      | Some '/' -> (
        match next () with
        | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '*') ->
            comment acc start 0
        | ((`Uchar _ | `End), _) as charloc ->
            errors := Unexpected_character (start, "/") :: !errors ;
            back charloc ;
            skip acc )
      | Some _ | None ->
          let byte = Uutf.decoder_byte_count decoder in
          let s = String.sub source start.byte (byte - start.byte) in
          errors := Unexpected_character (start, s) :: !errors ;
          skip acc )
  and base acc start =
    match next () with
    | (`Uchar c, stop) as charloc -> (
      match uchar_to_char c with
      | Some '0' .. '9' ->
          integer acc start
      | Some 'x' ->
          bytes acc start
      | Some ('a' .. 'w' | 'y' | 'z' | 'A' .. 'Z') ->
          errors := Missing_break_after_number stop :: !errors ;
          back charloc ;
          skip (tok start stop (Int "0") :: acc)
      | Some _ | None ->
          back charloc ;
          skip (tok start stop (Int "0") :: acc) )
    | (_, stop) as other ->
        back other ;
        skip (tok start stop (Int "0") :: acc)
  and integer acc start =
    let tok stop =
      let value = String.sub source start.byte (stop.byte - start.byte) in
      tok start stop (Int value)
    in
    match next () with
    | (`Uchar c, stop) as charloc -> (
        let missing_break () =
          errors := Missing_break_after_number stop :: !errors ;
          back charloc ;
          skip (tok stop :: acc)
        in
        match Uchar.to_char c with
        | '0' .. '9' ->
            integer acc start
        | 'a' .. 'z' | 'A' .. 'Z' ->
            missing_break ()
        | _ ->
            back charloc ;
            skip (tok stop :: acc) )
    | (`End, stop) as other ->
        back other ;
        skip (tok stop :: acc)
  and bytes acc start =
    let tok stop =
      let value = String.sub source start.byte (stop.byte - start.byte) in
      tok start stop (Bytes value)
    in
    match next () with
    | (`Uchar c, stop) as charloc -> (
        let missing_break () =
          errors := Missing_break_after_number stop :: !errors ;
          back charloc ;
          skip (tok stop :: acc)
        in
        match Uchar.to_char c with
        | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' ->
            bytes acc start
        | 'g' .. 'z' | 'G' .. 'Z' ->
            missing_break ()
        | _ ->
            back charloc ;
            skip (tok stop :: acc) )
    | (`End, stop) as other ->
        back other ;
        skip (tok stop :: acc)
  and string acc sacc start =
    let tok () =
      tok start (here ()) (String (String.concat "" (List.rev sacc)))
    in
    match next () with
    | (`End, stop) ->
        errors := Unterminated_string {start; stop} :: !errors ;
        skip (tok () :: acc)
    | (`Uchar c, stop) -> (
      match uchar_to_char c with
      | Some '"' ->
          skip (tok () :: acc)
      | Some ('\n' | '\r') ->
          errors := Unterminated_string {start; stop} :: !errors ;
          skip (tok () :: acc)
      | Some '\\' -> (
        match next () with
        | (`End, stop) ->
            errors := Unterminated_string {start; stop} :: !errors ;
            skip (tok () :: acc)
        | (`Uchar c, loc) -> (
          match uchar_to_char c with
          | Some '"' ->
              string acc ("\"" :: sacc) start
          | Some 'r' ->
              string acc ("\r" :: sacc) start
          | Some 'n' ->
              string acc ("\n" :: sacc) start
          | Some 't' ->
              string acc ("\t" :: sacc) start
          | Some 'b' ->
              string acc ("\b" :: sacc) start
          | Some '\\' ->
              string acc ("\\" :: sacc) start
          | Some _ | None ->
              let byte = Uutf.decoder_byte_count decoder in
              let s = String.sub source loc.byte (byte - loc.byte) in
              errors := Undefined_escape_sequence (loc, s) :: !errors ;
              string acc sacc start ) )
      | Some _ | None ->
          let byte = Uutf.decoder_byte_count decoder in
          let s = String.sub source stop.byte (byte - stop.byte) in
          string acc (s :: sacc) start )
  and generic_ident allow_char acc start (ret : string -> point -> token_value)
      =
    let tok stop =
      let name = String.sub source start.byte (stop.byte - start.byte) in
      tok start stop (ret name stop)
    in
    match next () with
    | (`Uchar c, stop) as charloc ->
        if allow_char c then generic_ident allow_char acc start ret
        else (
          back charloc ;
          skip (tok stop :: acc) )
    | (_, stop) as other ->
        back other ;
        skip (tok stop :: acc)
  and ident acc start ret = generic_ident allowed_ident_char acc start ret
  and annot acc start ret = generic_ident allowed_annot_char acc start ret
  and comment acc start lvl =
    match next () with
    | (`End, stop) ->
        errors := Unterminated_comment {start; stop} :: !errors ;
        let text = String.sub source start.byte (stop.byte - start.byte) in
        skip (tok start stop (Comment text) :: acc)
    | (`Uchar c, _) -> (
      match uchar_to_char c with
      | Some '*' -> (
        match next () with
        | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '/') ->
            if lvl = 0 then
              let stop = here () in
              let text =
                String.sub source start.byte (stop.byte - start.byte)
              in
              skip (tok start stop (Comment text) :: acc)
            else comment acc start (lvl - 1)
        | other ->
            back other ; comment acc start lvl )
      | Some '/' -> (
        match next () with
        | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '*') ->
            comment acc start (lvl + 1)
        | other ->
            back other ; comment acc start lvl )
      | Some _ | None ->
          comment acc start lvl )
  and eol_comment acc start =
    let tok stop =
      let text = String.sub source start.byte (stop.byte - start.byte) in
      tok start stop (Eol_comment text)
    in
    match next () with
    | (`Uchar c, stop) -> (
      match uchar_to_char c with
      | Some '\n' ->
          skip (tok stop :: acc)
      | Some _ | None ->
          eol_comment acc start )
    | (_, stop) as other ->
        back other ;
        skip (tok stop :: acc)
  in
  let tokens = skip [] in
  (tokens, List.rev !errors)

type node = (location, string) Micheline.node

let node_encoding =
  Micheline.table_encoding
    ~variant:"generic"
    location_encoding
    Data_encoding.string

(* Beginning of a sequence of consecutive primitives *)
let min_point : node list -> point = function
  | [] ->
      point_zero
  | Int ({start; _}, _) :: _
  | String ({start; _}, _) :: _
  | Bytes ({start; _}, _) :: _
  | Prim ({start; _}, _, _, _) :: _
  | Seq ({start; _}, _) :: _ ->
      start

(* End of a sequence of consecutive primitives *)
let rec max_point : node list -> point = function
  | [] ->
      point_zero
  | _ :: (_ :: _ as rest) ->
      max_point rest
  | [Int ({stop; _}, _)]
  | [String ({stop; _}, _)]
  | [Bytes ({stop; _}, _)]
  | [Prim ({stop; _}, _, _, _)]
  | [Seq ({stop; _}, _)] ->
      stop

(* An item in the parser's state stack.
   Not every value of type [mode list] is a valid parsing context.
   It must respect the following additional invariants.
   - a state stack always ends in [Toplevel _],
   - [Toplevel _] does not appear anywhere else,
   - [Unwrapped _] cannot appear directly on top of [Wrapped _],
   - [Wrapped _] cannot appear directly on top of [Sequence _],
   - [Wrapped _] cannot appear directly on top of [Sequence _]. *)
type mode =
  | Toplevel of node list
  | Expression of node option
  | Sequence of token * node list
  | Unwrapped of location * string * node list * string list
  | Wrapped of token * string * node list * string list

(* Enter a new parsing state. *)
let push_mode mode stack = mode :: stack

(* Leave a parsing state. *)
let pop_mode = function [] -> assert false | _ :: rest -> rest

(* Usually after a [pop_mode], jump back into the previous parsing
   state, injecting the current reduction (insert the just parsed item
   of a sequence or argument of a primitive application). *)
let fill_mode result = function
  | [] ->
      assert false
  | Expression _ :: _ :: _ ->
      assert false
  | [Expression (Some _)] ->
      assert false
  | Toplevel _ :: _ :: _ ->
      assert false
  | [Expression None] ->
      [Expression (Some result)]
  | [Toplevel exprs] ->
      [Toplevel (result :: exprs)]
  | Sequence (token, exprs) :: rest ->
      Sequence (token, result :: exprs) :: rest
  | Wrapped (token, name, exprs, annot) :: rest ->
      Wrapped (token, name, result :: exprs, annot) :: rest
  | Unwrapped (start, name, exprs, annot) :: rest ->
      Unwrapped (start, name, result :: exprs, annot) :: rest

type error += Unclosed of token

type error += Unexpected of token

type error += Extra of token

type error += Misaligned of node

type error += Empty

let rec annots = function
  | {token = Annot annot; _} :: rest ->
      let (annots, rest) = annots rest in
      (annot :: annots, rest)
  | rest ->
      ([], rest)

let rec parse ?(check = true) errors tokens stack =
  (* Two steps:
     - 1. parse without checking indentation [parse]
     - 2. check indentation [check] (inlined in 1) *)
  match (stack, tokens) with
  (* Start by preventing all absurd cases, so now the pattern
     matching exhaustivity can tell us that we treater all
     possible tokens for all possible valid states. *)
  | ([], _)
  | ([Wrapped _], _)
  | ([Unwrapped _], _)
  | (Unwrapped _ :: Unwrapped _ :: _, _)
  | (Unwrapped _ :: Wrapped _ :: _, _)
  | (Toplevel _ :: _ :: _, _)
  | (Expression _ :: _ :: _, _) ->
      assert false
  (* Return *)
  | (Expression (Some result) :: _, []) ->
      ([result], List.rev errors)
  | (Expression (Some _) :: _, token :: rem) ->
      let errors = Unexpected token :: errors in
      parse ~check errors rem (* skip *) stack
  | (Expression None :: _, []) ->
      let errors = Empty :: errors in
      let ghost = {start = point_zero; stop = point_zero} in
      ([Seq (ghost, [])], List.rev errors)
  | ([Toplevel [(Seq (_, exprs) as expr)]], []) ->
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      (exprs, List.rev errors)
  | ([Toplevel exprs], []) ->
      let exprs = List.rev exprs in
      let loc = {start = min_point exprs; stop = max_point exprs} in
      let expr = Seq (loc, exprs) in
      let errors =
        if check then do_check ~toplevel:true errors expr else errors
      in
      (exprs, List.rev errors)
  (* Ignore comments *)
  | (_, {token = Eol_comment _ | Comment _; _} :: rest) ->
      parse ~check errors rest stack
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      ({token = Int _ | String _ | Bytes _; _} as token)
      :: {token = Eol_comment _ | Comment _; _} :: rest )
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token)
      :: {token = Eol_comment _ | Comment _; _} :: rest ) ->
      parse ~check errors (token :: rest) stack
  (* Erroneous states *)
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token)
      :: {token = Open_paren | Open_brace; _} :: rem )
  | ( Unwrapped _ :: Expression _ :: _,
      ({token = Semi | Close_brace | Close_paren; _} as token) :: rem )
  | ( Expression None :: _,
      ({token = Semi | Close_brace | Close_paren | Open_paren; _} as token)
      :: rem ) ->
      let errors = Unexpected token :: errors in
      parse ~check errors rem (* skip *) stack
  | ( (Sequence _ | Toplevel _) :: _,
      ({token = Semi; _} as valid) :: ({token = Semi; _} as token) :: rem ) ->
      let errors = Extra token :: errors in
      parse ~check errors ((* skip *) valid :: rem) stack
  | ( (Wrapped _ | Unwrapped _) :: _,
      {token = Open_paren; _}
      :: ( {token = Int _ | String _ | Bytes _ | Annot _ | Close_paren; _} as
         token )
         :: rem )
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      {token = Int _ | String _ | Bytes _; _}
      :: ( { token =
               ( Ident _
               | Int _
               | String _
               | Bytes _
               | Annot _
               | Close_paren
               | Open_paren
               | Open_brace );
             _ } as token )
         :: rem )
  | ( Unwrapped (_, _, _, _) :: Toplevel _ :: _,
      ({token = Close_brace; _} as token) :: rem )
  | (Unwrapped (_, _, _, _) :: _, ({token = Close_paren; _} as token) :: rem)
  | ([Toplevel _], ({token = Close_paren; _} as token) :: rem)
  | ([Toplevel _], ({token = Open_paren; _} as token) :: rem)
  | ([Toplevel _], ({token = Close_brace; _} as token) :: rem)
  | (Sequence _ :: _, ({token = Open_paren; _} as token) :: rem)
  | (Sequence _ :: _, ({token = Close_paren; _} as token) :: rem)
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token)
      :: (({token = Close_brace | Semi; _} :: _ | []) as rem) )
  | (_, ({token = Annot _; _} as token) :: rem) ->
      let errors = Unexpected token :: errors in
      parse ~check errors rem (* skip *) stack
  | (Wrapped (token, _, _, _) :: _, ([] | {token = Close_brace | Semi; _} :: _))
    ->
      let errors = Unclosed token :: errors in
      let fake = {token with token = Close_paren} in
      let tokens = (* insert *) fake :: tokens in
      parse ~check errors tokens stack
  | ((Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), [])
    ->
      let errors = Unclosed token :: errors in
      let fake = {token with token = Close_brace} in
      let tokens = (* insert *) fake :: tokens in
      parse ~check errors tokens stack
  (* Valid states *)
  | ( (Toplevel _ | Sequence (_, _)) :: _,
      {token = Ident name; loc} :: ({token = Annot _; _} :: _ as rest) ) ->
      let (annots, rest) = annots rest in
      let mode = Unwrapped (loc, name, [], annots) in
      parse ~check errors rest (push_mode mode stack)
  | ( (Expression None | Toplevel _ | Sequence (_, _)) :: _,
      {token = Ident name; loc} :: rest ) ->
      let mode = Unwrapped (loc, name, [], []) in
      parse ~check errors rest (push_mode mode stack)
  | ((Unwrapped _ | Wrapped _) :: _, {token = Int value; loc} :: rest)
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      {token = Int value; loc}
      :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
      let expr : node = Int (loc, Z.of_string value) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr stack)
  | ((Unwrapped _ | Wrapped _) :: _, {token = String contents; loc} :: rest)
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      {token = String contents; loc}
      :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
      let expr : node = String (loc, contents) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr stack)
  | ((Unwrapped _ | Wrapped _) :: _, {token = Bytes contents; loc} :: rest)
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      {token = Bytes contents; loc}
      :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
      let (errors, contents) =
        if String.length contents mod 2 <> 0 then
          (Odd_lengthed_bytes loc :: errors, contents ^ "0")
        else (errors, contents)
      in
      let bytes =
        Hex.to_bytes
          (`Hex (String.sub contents 2 (String.length contents - 2)))
      in
      let expr : node = Bytes (loc, bytes) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr stack)
  | ( Sequence ({loc = {start; _}; _}, exprs) :: _,
      {token = Close_brace; loc = {stop; _}} :: rest ) ->
      let exprs = List.rev exprs in
      let expr = Micheline.Seq ({start; stop}, exprs) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr (pop_mode stack))
  | ((Sequence _ | Toplevel _) :: _, {token = Semi; _} :: rest) ->
      parse ~check errors rest stack
  | ( Unwrapped ({start; stop}, name, exprs, annot) :: Expression _ :: _,
      ([] as rest) )
  | ( Unwrapped ({start; stop}, name, exprs, annot) :: Toplevel _ :: _,
      (({token = Semi; _} :: _ | []) as rest) )
  | ( Unwrapped ({start; stop}, name, exprs, annot) :: Sequence _ :: _,
      ({token = Close_brace | Semi; _} :: _ as rest) )
  | ( Wrapped ({loc = {start; stop}; _}, name, exprs, annot) :: _,
      {token = Close_paren; _} :: rest ) ->
      let exprs = List.rev exprs in
      let stop = if exprs = [] then stop else max_point exprs in
      let expr = Micheline.Prim ({start; stop}, name, exprs, annot) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr (pop_mode stack))
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token)
      :: {token = Ident name; _} :: ({token = Annot _; _} :: _ as rest) ) ->
      let (annots, rest) = annots rest in
      let mode = Wrapped (token, name, [], annots) in
      parse ~check errors rest (push_mode mode stack)
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest )
    ->
      let mode = Wrapped (token, name, [], []) in
      parse ~check errors rest (push_mode mode stack)
  | ((Wrapped _ | Unwrapped _) :: _, {token = Ident name; loc} :: rest) ->
      let expr = Micheline.Prim (loc, name, [], []) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr stack)
  | ( (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _,
      ({token = Open_brace; _} as token) :: rest ) ->
      let mode = Sequence (token, []) in
      parse ~check errors rest (push_mode mode stack)

(* indentation checker *)
and do_check ?(toplevel = false) errors = function
  | Seq ({start; stop}, []) as expr ->
      if start.column >= stop.column then Misaligned expr :: errors else errors
  | ( Prim ({start; stop}, _, first :: rest, _)
    | Seq ({start; stop}, first :: rest) ) as expr ->
      let {column = first_column; line = first_line; _} = min_point [first] in
      if start.column >= stop.column then Misaligned expr :: errors
      else if (not toplevel) && start.column >= first_column then
        Misaligned expr :: errors
      else
        (* In a sequence or in the arguments of a primitive, we
           require all items to be aligned, but we relax the rule to
           allow consecutive items to be writtem on the same line. *)
        let rec in_line_or_aligned prev_start_line errors = function
          | [] ->
              errors
          | expr :: rest ->
              let {column; line = start_line; _} = min_point [expr] in
              let {line = stop_line; _} = max_point [expr] in
              let errors =
                if stop_line <> prev_start_line && column <> first_column then
                  Misaligned expr :: errors
                else errors
              in
              in_line_or_aligned start_line errors rest
        in
        in_line_or_aligned first_line errors rest
  | Prim (_, _, [], _) | String _ | Int _ | Bytes _ ->
      errors

let parse_expression ?check tokens =
  let result =
    match tokens with
    | ({token = Open_paren; _} as token)
      :: {token = Ident name; _} :: {token = Annot annot; _} :: rest ->
        let (annots, rest) = annots rest in
        let mode = Wrapped (token, name, [], annot :: annots) in
        parse ?check [] rest [mode; Expression None]
    | ({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest ->
        let mode = Wrapped (token, name, [], []) in
        parse ?check [] rest [mode; Expression None]
    | _ ->
        parse ?check [] tokens [Expression None]
  in
  match result with
  | ([single], errors) ->
      (single, errors)
  | _ ->
      assert false

let parse_toplevel ?check tokens = parse ?check [] tokens [Toplevel []]

let print_point ppf {line; column; _} =
  Format.fprintf ppf "At line %d character %d" line column

let print_token_kind ppf = function
  | Open_paren | Close_paren ->
      Format.fprintf ppf "parenthesis"
  | Open_brace | Close_brace ->
      Format.fprintf ppf "curly brace"
  | String _ ->
      Format.fprintf ppf "string constant"
  | Bytes _ ->
      Format.fprintf ppf "bytes constant"
  | Int _ ->
      Format.fprintf ppf "integer constant"
  | Ident _ ->
      Format.fprintf ppf "identifier"
  | Annot _ ->
      Format.fprintf ppf "annotation"
  | Comment _ | Eol_comment _ ->
      Format.fprintf ppf "comment"
  | Semi ->
      Format.fprintf ppf "semi colon"

let print_location ppf loc =
  if loc.start.line = loc.stop.line then
    if loc.start.column = loc.stop.column then
      Format.fprintf
        ppf
        "At line %d character %d"
        loc.start.line
        loc.start.column
    else
      Format.fprintf
        ppf
        "At line %d characters %d to %d"
        loc.start.line
        loc.start.column
        loc.stop.column
  else
    Format.fprintf
      ppf
      "From line %d character %d to line %d character %d"
      loc.start.line
      loc.start.column
      loc.stop.line
      loc.stop.column

let no_parsing_error (ast, errors) =
  match errors with [] -> ok ast | errors -> Error errors

let () =
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.invalid_utf8_sequence"
    ~title:"Micheline parser error: invalid UTF-8 sequence"
    ~description:
      "While parsing a piece of Micheline source, a sequence of bytes that is \
       not valid UTF-8 was encountered."
    ~pp:(fun ppf (point, str) ->
      Format.fprintf ppf "%a, invalid UTF-8 sequence %S" print_point point str)
    Data_encoding.(obj2 (req "point" point_encoding) (req "sequence" string))
    (function
      | Invalid_utf8_sequence (point, str) -> Some (point, str) | _ -> None)
    (fun (point, str) -> Invalid_utf8_sequence (point, str)) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unexpected_character"
    ~title:"Micheline parser error: unexpected character"
    ~description:
      "While parsing a piece of Micheline source, an unexpected character was \
       encountered."
    ~pp:(fun ppf (point, str) ->
      Format.fprintf ppf "%a, unexpected character %s" print_point point str)
    Data_encoding.(obj2 (req "point" point_encoding) (req "character" string))
    (function
      | Unexpected_character (point, str) -> Some (point, str) | _ -> None)
    (fun (point, str) -> Unexpected_character (point, str)) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.undefined_escape_sequence"
    ~title:"Micheline parser error: undefined escape sequence"
    ~description:
      "While parsing a piece of Micheline source, an unexpected escape \
       sequence was encountered in a string."
    ~pp:(fun ppf (point, str) ->
      Format.fprintf
        ppf
        "%a, undefined escape sequence \"%s\""
        print_point
        point
        str)
    Data_encoding.(obj2 (req "point" point_encoding) (req "sequence" string))
    (function
      | Undefined_escape_sequence (point, str) -> Some (point, str) | _ -> None)
    (fun (point, str) -> Undefined_escape_sequence (point, str)) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.missing_break_after_number"
    ~title:"Micheline parser error: missing break after number"
    ~description:
      "While parsing a piece of Micheline source, a number was not visually \
       separated from its follower token, leading to misreadability."
    ~pp:(fun ppf point ->
      Format.fprintf ppf "%a, missing break after number" print_point point)
    Data_encoding.(obj1 (req "point" point_encoding))
    (function Missing_break_after_number point -> Some point | _ -> None)
    (fun point -> Missing_break_after_number point) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unterminated_string"
    ~title:"Micheline parser error: unterminated string"
    ~description:
      "While parsing a piece of Micheline source, a string was not terminated."
    ~pp:(fun ppf loc ->
      Format.fprintf ppf "%a, unterminated string" print_location loc)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Unterminated_string loc -> Some loc | _ -> None)
    (fun loc -> Unterminated_string loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unterminated_integer"
    ~title:"Micheline parser error: unterminated integer"
    ~description:
      "While parsing a piece of Micheline source, an integer was not \
       terminated."
    ~pp:(fun ppf loc ->
      Format.fprintf ppf "%a, unterminated integer" print_location loc)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Unterminated_integer loc -> Some loc | _ -> None)
    (fun loc -> Unterminated_integer loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.odd_lengthed_bytes"
    ~title:"Micheline parser error: odd lengthed bytes"
    ~description:
      "While parsing a piece of Micheline source, the length of a byte \
       sequence (0x...) was not a multiple of two, leaving a trailing half \
       byte."
    ~pp:(fun ppf loc ->
      Format.fprintf ppf "%a, odd_lengthed bytes" print_location loc)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Odd_lengthed_bytes loc -> Some loc | _ -> None)
    (fun loc -> Odd_lengthed_bytes loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unterminated_comment"
    ~title:"Micheline parser error: unterminated comment"
    ~description:
      "While parsing a piece of Micheline source, a commentX was not \
       terminated."
    ~pp:(fun ppf loc ->
      Format.fprintf ppf "%a, unterminated comment" print_location loc)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Unterminated_comment loc -> Some loc | _ -> None)
    (fun loc -> Unterminated_comment loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.annotation_exceeds_max_length"
    ~title:"Micheline parser error: annotation exceeds max length"
    ~description:
      (Format.sprintf
         "While parsing a piece of Micheline source, an annotation exceeded \
          the maximum length (%d)."
         max_annot_length)
    ~pp:(fun ppf loc ->
      Format.fprintf
        ppf
        "%a, annotation exceeded maximum length (%d chars)"
        print_location
        loc
        max_annot_length)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Annotation_length loc -> Some loc | _ -> None)
    (fun loc -> Annotation_length loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unclosed_token"
    ~title:"Micheline parser error: unclosed token"
    ~description:
      "While parsing a piece of Micheline source, a parenthesis or a brace \
       was unclosed."
    ~pp:(fun ppf (loc, token) ->
      Format.fprintf
        ppf
        "%a, unclosed %a"
        print_location
        loc
        print_token_kind
        token)
    Data_encoding.(
      obj2
        (req "location" location_encoding)
        (req "token" token_value_encoding))
    (function Unclosed {loc; token} -> Some (loc, token) | _ -> None)
    (fun (loc, token) -> Unclosed {loc; token}) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unexpected_token"
    ~title:"Micheline parser error: unexpected token"
    ~description:
      "While parsing a piece of Micheline source, an unexpected token was \
       encountered."
    ~pp:(fun ppf (loc, token) ->
      Format.fprintf
        ppf
        "%a, unexpected %a"
        print_location
        loc
        print_token_kind
        token)
    Data_encoding.(
      obj2
        (req "location" location_encoding)
        (req "token" token_value_encoding))
    (function Unexpected {loc; token} -> Some (loc, token) | _ -> None)
    (fun (loc, token) -> Unexpected {loc; token}) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.extra_token"
    ~title:"Micheline parser error: extra token"
    ~description:
      "While parsing a piece of Micheline source, an extra semi colon or \
       parenthesis was encountered."
    ~pp:(fun ppf (loc, token) ->
      Format.fprintf
        ppf
        "%a, extra %a"
        print_location
        loc
        print_token_kind
        token)
    Data_encoding.(
      obj2
        (req "location" location_encoding)
        (req "token" token_value_encoding))
    (function Extra {loc; token} -> Some (loc, token) | _ -> None)
    (fun (loc, token) -> Extra {loc; token}) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.misaligned_node"
    ~title:"Micheline parser error: misaligned node"
    ~description:
      "While parsing a piece of Micheline source, an expression was not \
       aligned with its siblings of the same mother application or sequence."
    ~pp:(fun ppf node ->
      Format.fprintf
        ppf
        "%a, misaligned expression"
        print_location
        (location node))
    Data_encoding.(obj1 (req "expression" node_encoding))
    (function Misaligned node -> Some node | _ -> None)
    (fun node -> Misaligned node) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.empty_expression"
    ~title:"Micheline parser error: empty_expression"
    ~description:
      "Tried to interpret an empty piece or Micheline source as a single \
       expression."
    ~pp:(fun ppf () -> Format.fprintf ppf "empty expression")
    Data_encoding.empty
    (function Empty -> Some () | _ -> None)
    (fun () -> Empty)
src/lib_micheline/micheline_parser.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Import Tezos_micheline.Micheline.

Definition parsing_result (a : Type) :=
  a * (list Tezos_error_monad.Error_monad.error).

Record point := {
  point : Z;
  byte : Z;
  line : Z;
  column : Z }.

Definition point_zero : point :=
  {| point := 0; byte := 0; line := 0; column := 0 |}.

Definition point_encoding : Tezos_data_encoding.Data_encoding.encoding point :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| point := point; byte := byte; line := line; column := column |} =>
        (line, column, point, byte)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (line, column, point, byte) =>
        {| point := point; byte := byte; line := line; column := column |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj4
      (Tezos_data_encoding.Data_encoding.req None None "line" % string
        Tezos_data_encoding.Data_encoding.uint16)
      (Tezos_data_encoding.Data_encoding.req None None "column" % string
        Tezos_data_encoding.Data_encoding.uint16)
      (Tezos_data_encoding.Data_encoding.req None None "point" % string
        Tezos_data_encoding.Data_encoding.uint16)
      (Tezos_data_encoding.Data_encoding.req None None "byte" % string
        Tezos_data_encoding.Data_encoding.uint16)).

Record location := {
  start : point;
  stop : point }.

Definition location_zero : location :=
  {| start := point_zero; stop := point_zero |}.

Definition location_encoding
  : Tezos_data_encoding.Data_encoding.encoding location :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| start := start; stop := stop |} => (start, stop)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (start, stop) => {| start := start; stop := stop |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj2
      (Tezos_data_encoding.Data_encoding.req None None "start" % string
        point_encoding)
      (Tezos_data_encoding.Data_encoding.req None None "stop" % string
        point_encoding)).

Inductive token_value : Type :=
| String : string -> token_value
| Bytes : string -> token_value
| Int : string -> token_value
| Ident : string -> token_value
| Annot : string -> token_value
| Comment : string -> token_value
| Eol_comment : string -> token_value
| Semi : token_value
| Open_paren : token_value
| Close_paren : token_value
| Open_brace : token_value
| Close_brace : token_value.

Definition token_value_encoding
  : Tezos_data_encoding.Data_encoding.encoding token_value :=
  Tezos_data_encoding.Data_encoding.union None
    (cons
      (Tezos_data_encoding.Data_encoding.case "String" % string None (Tag 0)
        (Tezos_data_encoding.Data_encoding.obj1
          (Tezos_data_encoding.Data_encoding.req None None "string" % string
            Tezos_data_encoding.Data_encoding.string))
        (fun function_parameter =>
          match function_parameter with
          | String s => Some s
          | _ => None
          end) (fun s => String s))
      (cons
        (Tezos_data_encoding.Data_encoding.case "Int" % string None (Tag 1)
          (Tezos_data_encoding.Data_encoding.obj1
            (Tezos_data_encoding.Data_encoding.req None None "int" % string
              Tezos_data_encoding.Data_encoding.string))
          (fun function_parameter =>
            match function_parameter with
            | Int s => Some s
            | _ => None
            end) (fun s => Int s))
        (cons
          (Tezos_data_encoding.Data_encoding.case "Annot" % string None (Tag 2)
            (Tezos_data_encoding.Data_encoding.obj1
              (Tezos_data_encoding.Data_encoding.req None None "annot" % string
                Tezos_data_encoding.Data_encoding.string))
            (fun function_parameter =>
              match function_parameter with
              | Annot s => Some s
              | _ => None
              end) (fun s => Annot s))
          (cons
            (Tezos_data_encoding.Data_encoding.case "Comment" % string None
              (Tag 3)
              (Tezos_data_encoding.Data_encoding.obj2
                (Tezos_data_encoding.Data_encoding.req None None
                  "comment" % string Tezos_data_encoding.Data_encoding.string)
                (Tezos_data_encoding.Data_encoding.dft None None
                  "end_of_line" % string Tezos_data_encoding.Data_encoding.bool
                  false))
              (fun function_parameter =>
                match function_parameter with
                | Comment s => Some (s, false)
                | Eol_comment s => Some (s, true)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (s, false) => Comment s
                | (s, true) => Eol_comment s
                end))
            (cons
              (Tezos_data_encoding.Data_encoding.case "Punctuation" % string
                None (Tag 4)
                (Tezos_data_encoding.Data_encoding.obj1
                  (Tezos_data_encoding.Data_encoding.req None None
                    "punctuation" % string
                    (Tezos_data_encoding.Data_encoding.string_enum
                      (cons ("(" % string, Open_paren)
                        (cons (")" % string, Close_paren)
                          (cons ("{" % string, Open_brace)
                            (cons ("}" % string, Close_brace)
                              (cons (";" % string, Semi) []))))))))
                (fun t => Some t) (fun t => t))
              (cons
                (Tezos_data_encoding.Data_encoding.case "Bytes" % string None
                  (Tag 5)
                  (Tezos_data_encoding.Data_encoding.obj1
                    (Tezos_data_encoding.Data_encoding.req None None
                      "bytes" % string Tezos_data_encoding.Data_encoding.string))
                  (fun function_parameter =>
                    match function_parameter with
                    | Bytes s => Some s
                    | _ => None
                    end) (fun s => Bytes s)) [])))))).

Record token := {
  token : token_value;
  loc : location }.

Definition max_annot_length : Z := 255.

Definition tokenize (source : string)
  : (list token) * (list Tezos_error_monad.Error_monad.error) :=
  let decoder := Uutf.decoder None (Some variant) variant in
  let here (function_parameter : unit) : point :=
    match function_parameter with
    | tt =>
      {| point := Uutf.decoder_count decoder;
        byte := Uutf.decoder_byte_count decoder;
        line := Uutf.decoder_line decoder; column := Uutf.decoder_col decoder |}
    end in
  let tok (start : point) (stop : point) (token : token_value) : token :=
    {| token := token; loc := {| start := start; stop := stop |} |} in
  let stack := Stdlib.ref [] in
  let errors := Stdlib.ref [] in
  let fix next (function_parameter : unit) : variant * point :=
    match function_parameter with
    | tt =>
      match Stdlib.op_exclamation stack with
      | cons charloc charlocs =>
        Stdlib.op_colon_eq stack charlocs;
        charloc
      | [] =>
        let loc := here tt in
        match Uutf.decode decoder with
        | Await => false
        | Malformed s =>
          Stdlib.op_colon_eq errors
            (cons (Invalid_utf8_sequence loc s) (Stdlib.op_exclamation errors));
          next tt
        | (Uchar _ | End) as other => (other, loc)
        end
      end
    end in
  let back (charloc : variant * point) : unit :=
    Stdlib.op_colon_eq stack (cons charloc (Stdlib.op_exclamation stack)) in
  let uchar_to_char (c : Stdlib.Uchar.t) : option ascii :=
    if Stdlib.Uchar.is_char c then
      Some (Stdlib.Uchar.to_char c)
    else
      None in
  let allowed_ident_char (c : Stdlib.Uchar.t) : bool :=
    match uchar_to_char c with
    |
      Some
        ("a" % char |
          "b" % char |
            "c" % char |
              "d" % char |
                "e" % char |
                  "f" % char |
                    "g" % char |
                      "h" % char |
                        "i" % char |
                          "j" % char |
                            "k" % char |
                              "l" % char |
                                "m" % char |
                                  "n" % char |
                                    "o" % char |
                                      "p" % char |
                                        "q" % char |
                                          "r" % char |
                                            "s" % char |
                                              "t" % char |
                                                "u" % char |
                                                  "v" % char |
                                                    "w" % char |
                                                      "x" % char |
                                                        "y" % char | "z" % char
          |
          "A" % char |
            "B" % char |
              "C" % char |
                "D" % char |
                  "E" % char |
                    "F" % char |
                      "G" % char |
                        "H" % char |
                          "I" % char |
                            "J" % char |
                              "K" % char |
                                "L" % char |
                                  "M" % char |
                                    "N" % char |
                                      "O" % char |
                                        "P" % char |
                                          "Q" % char |
                                            "R" % char |
                                              "S" % char |
                                                "T" % char |
                                                  "U" % char |
                                                    "V" % char |
                                                      "W" % char |
                                                        "X" % char |
                                                          "Y" % char |
                                                            "Z" % char |
          "_" % char |
          "0" % char |
            "1" % char |
              "2" % char |
                "3" % char |
                  "4" % char |
                    "5" % char |
                      "6" % char | "7" % char | "8" % char | "9" % char) => true
    | Some _ | None => false
    end in
  let allowed_annot_char (c : Stdlib.Uchar.t) : bool :=
    match uchar_to_char c with
    |
      Some
        ("a" % char |
          "b" % char |
            "c" % char |
              "d" % char |
                "e" % char |
                  "f" % char |
                    "g" % char |
                      "h" % char |
                        "i" % char |
                          "j" % char |
                            "k" % char |
                              "l" % char |
                                "m" % char |
                                  "n" % char |
                                    "o" % char |
                                      "p" % char |
                                        "q" % char |
                                          "r" % char |
                                            "s" % char |
                                              "t" % char |
                                                "u" % char |
                                                  "v" % char |
                                                    "w" % char |
                                                      "x" % char |
                                                        "y" % char | "z" % char
          |
          "A" % char |
            "B" % char |
              "C" % char |
                "D" % char |
                  "E" % char |
                    "F" % char |
                      "G" % char |
                        "H" % char |
                          "I" % char |
                            "J" % char |
                              "K" % char |
                                "L" % char |
                                  "M" % char |
                                    "N" % char |
                                      "O" % char |
                                        "P" % char |
                                          "Q" % char |
                                            "R" % char |
                                              "S" % char |
                                                "T" % char |
                                                  "U" % char |
                                                    "V" % char |
                                                      "W" % char |
                                                        "X" % char |
                                                          "Y" % char |
                                                            "Z" % char |
          "_" % char | "." % char | "%" % char | "@" % char |
          "0" % char |
            "1" % char |
              "2" % char |
                "3" % char |
                  "4" % char |
                    "5" % char |
                      "6" % char | "7" % char | "8" % char | "9" % char) => true
    | Some _ | None => false
    end in
  let fix skip (acc : list token) : list token :=
    match next tt with
    | (End, _) => List.rev acc
    | (Uchar c, start) =>
      match uchar_to_char c with
      |
        Some
          ("a" % char |
            "b" % char |
              "c" % char |
                "d" % char |
                  "e" % char |
                    "f" % char |
                      "g" % char |
                        "h" % char |
                          "i" % char |
                            "j" % char |
                              "k" % char |
                                "l" % char |
                                  "m" % char |
                                    "n" % char |
                                      "o" % char |
                                        "p" % char |
                                          "q" % char |
                                            "r" % char |
                                              "s" % char |
                                                "t" % char |
                                                  "u" % char |
                                                    "v" % char |
                                                      "w" % char |
                                                        "x" % char |
                                                          "y" % char |
                                                            "z" % char |
            "A" % char |
              "B" % char |
                "C" % char |
                  "D" % char |
                    "E" % char |
                      "F" % char |
                        "G" % char |
                          "H" % char |
                            "I" % char |
                              "J" % char |
                                "K" % char |
                                  "L" % char |
                                    "M" % char |
                                      "N" % char |
                                        "O" % char |
                                          "P" % char |
                                            "Q" % char |
                                              "R" % char |
                                                "S" % char |
                                                  "T" % char |
                                                    "U" % char |
                                                      "V" % char |
                                                        "W" % char |
                                                          "X" % char |
                                                            "Y" % char |
                                                              "Z" % char) =>
        ident acc start
          (fun s =>
            fun function_parameter =>
              match function_parameter with
              | _ => Ident s
              end)
      |
        Some
          ("@" % char | ":" % char | "$" % char | "&" % char | "%" % char |
            "!" % char | "?" % char) =>
        annot acc start
          (fun str =>
            fun stop =>
              if OCaml.Stdlib.gt (OCaml.String.length str) max_annot_length then
                Stdlib.op_colon_eq errors
                  (cons (Annotation_length {| start := start; stop := stop |})
                    (Stdlib.op_exclamation errors))
              else
                tt;
              Annot str)
      | Some "-" % char =>
        match next tt with
        | (End, stop) =>
          Stdlib.op_colon_eq errors
            (cons (Unterminated_integer {| start := start; stop := stop |})
              (Stdlib.op_exclamation errors));
          List.rev acc
        | (Uchar c, stop) as first =>
          match uchar_to_char c with
          | Some "0" % char => base acc start
          |
            Some
              ("1" % char |
                "2" % char |
                  "3" % char |
                    "4" % char |
                      "5" % char |
                        "6" % char | "7" % char | "8" % char | "9" % char) =>
            integer acc start
          | Some _ | None =>
            Stdlib.op_colon_eq errors
              (cons (Unterminated_integer {| start := start; stop := stop |})
                (Stdlib.op_exclamation errors));
            back first;
            skip acc
          end
        end
      | Some "0" % char => base acc start
      |
        Some
          ("1" % char |
            "2" % char |
              "3" % char |
                "4" % char |
                  "5" % char | "6" % char | "7" % char | "8" % char | "9" % char)
        => integer acc start
      | Some (" " % char | "010" % char) => skip acc
      | Some ";" % char => skip (cons (tok start (here tt) Semi) acc)
      | Some "{" % char => skip (cons (tok start (here tt) Open_brace) acc)
      | Some "}" % char => skip (cons (tok start (here tt) Close_brace) acc)
      | Some "(" % char => skip (cons (tok start (here tt) Open_paren) acc)
      | Some ")" % char => skip (cons (tok start (here tt) Close_paren) acc)
      | Some """" % char => string acc [] start
      | Some "#" % char => eol_comment acc start
      | Some "/" % char =>
        match next tt with
        | (Uchar _ | End, _) as charloc =>
          Stdlib.op_colon_eq errors
            (cons (Unexpected_character start "/" % string)
              (Stdlib.op_exclamation errors));
          back charloc;
          skip acc
        end
      | Some _ | None =>
        let byte := Uutf.decoder_byte_count decoder in
        let s := Stdlib.String.sub source (byte start) (Z.sub byte (byte start))
          in
        Stdlib.op_colon_eq errors
          (cons (Unexpected_character start s) (Stdlib.op_exclamation errors));
        skip acc
      end
    end
  with base (acc : list token) (start : point) : list token :=
    match next tt with
    | (Uchar c, stop) as charloc =>
      match uchar_to_char c with
      |
        Some
          ("0" % char |
            "1" % char |
              "2" % char |
                "3" % char |
                  "4" % char |
                    "5" % char |
                      "6" % char | "7" % char | "8" % char | "9" % char) =>
        integer acc start
      | Some "x" % char => string acc start
      |
        Some
          ("a" % char |
            "b" % char |
              "c" % char |
                "d" % char |
                  "e" % char |
                    "f" % char |
                      "g" % char |
                        "h" % char |
                          "i" % char |
                            "j" % char |
                              "k" % char |
                                "l" % char |
                                  "m" % char |
                                    "n" % char |
                                      "o" % char |
                                        "p" % char |
                                          "q" % char |
                                            "r" % char |
                                              "s" % char |
                                                "t" % char |
                                                  "u" % char |
                                                    "v" % char | "w" % char |
            "y" % char | "z" % char |
            "A" % char |
              "B" % char |
                "C" % char |
                  "D" % char |
                    "E" % char |
                      "F" % char |
                        "G" % char |
                          "H" % char |
                            "I" % char |
                              "J" % char |
                                "K" % char |
                                  "L" % char |
                                    "M" % char |
                                      "N" % char |
                                        "O" % char |
                                          "P" % char |
                                            "Q" % char |
                                              "R" % char |
                                                "S" % char |
                                                  "T" % char |
                                                    "U" % char |
                                                      "V" % char |
                                                        "W" % char |
                                                          "X" % char |
                                                            "Y" % char |
                                                              "Z" % char) =>
        Stdlib.op_colon_eq errors
          (cons (Missing_break_after_number stop) (Stdlib.op_exclamation errors));
        back charloc;
        skip (cons (tok start stop (Int "0" % string)) acc)
      | Some _ | None =>
        back charloc;
        skip (cons (tok start stop (Int "0" % string)) acc)
      end
    | (_, stop) as other =>
      back other;
      skip (cons (tok start stop (Int "0" % string)) acc)
    end
  with integer (acc : list token) (start : point) : list token :=
    let tok (stop : point) : token :=
      let value :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      tok start stop (Int value) in
    match next tt with
    | (Uchar c, stop) as charloc =>
      let missing_break (function_parameter : unit) : list token :=
        match function_parameter with
        | tt =>
          Stdlib.op_colon_eq errors
            (cons (Missing_break_after_number stop)
              (Stdlib.op_exclamation errors));
          back charloc;
          skip (cons (tok stop) acc)
        end in
      match Stdlib.Uchar.to_char c with
      |
        "0" % char |
          "1" % char |
            "2" % char |
              "3" % char |
                "4" % char |
                  "5" % char | "6" % char | "7" % char | "8" % char | "9" % char
        => integer acc start
      |
        "a" % char |
          "b" % char |
            "c" % char |
              "d" % char |
                "e" % char |
                  "f" % char |
                    "g" % char |
                      "h" % char |
                        "i" % char |
                          "j" % char |
                            "k" % char |
                              "l" % char |
                                "m" % char |
                                  "n" % char |
                                    "o" % char |
                                      "p" % char |
                                        "q" % char |
                                          "r" % char |
                                            "s" % char |
                                              "t" % char |
                                                "u" % char |
                                                  "v" % char |
                                                    "w" % char |
                                                      "x" % char |
                                                        "y" % char | "z" % char
          |
          "A" % char |
            "B" % char |
              "C" % char |
                "D" % char |
                  "E" % char |
                    "F" % char |
                      "G" % char |
                        "H" % char |
                          "I" % char |
                            "J" % char |
                              "K" % char |
                                "L" % char |
                                  "M" % char |
                                    "N" % char |
                                      "O" % char |
                                        "P" % char |
                                          "Q" % char |
                                            "R" % char |
                                              "S" % char |
                                                "T" % char |
                                                  "U" % char |
                                                    "V" % char |
                                                      "W" % char |
                                                        "X" % char |
                                                          "Y" % char |
                                                            "Z" % char =>
        missing_break tt
      | _ =>
        back charloc;
        skip (cons (tok stop) acc)
      end
    | (End, stop) as other =>
      back other;
      skip (cons (tok stop) acc)
    end
  with bytes (acc : list token) (start : point) : list token :=
    let tok (stop : point) : token :=
      let value :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      tok start stop (Bytes value) in
    match next tt with
    | (Uchar c, stop) as charloc =>
      let missing_break (function_parameter : unit) : list token :=
        match function_parameter with
        | tt =>
          Stdlib.op_colon_eq errors
            (cons (Missing_break_after_number stop)
              (Stdlib.op_exclamation errors));
          back charloc;
          skip (cons (tok stop) acc)
        end in
      match Stdlib.Uchar.to_char c with
      |
        "0" % char |
          "1" % char |
            "2" % char |
              "3" % char |
                "4" % char |
                  "5" % char | "6" % char | "7" % char | "8" % char | "9" % char
          |
          "a" % char |
            "b" % char | "c" % char | "d" % char | "e" % char | "f" % char |
          "A" % char |
            "B" % char | "C" % char | "D" % char | "E" % char | "F" % char =>
        string acc start
      |
        "g" % char |
          "h" % char |
            "i" % char |
              "j" % char |
                "k" % char |
                  "l" % char |
                    "m" % char |
                      "n" % char |
                        "o" % char |
                          "p" % char |
                            "q" % char |
                              "r" % char |
                                "s" % char |
                                  "t" % char |
                                    "u" % char |
                                      "v" % char |
                                        "w" % char |
                                          "x" % char | "y" % char | "z" % char |
          "G" % char |
            "H" % char |
              "I" % char |
                "J" % char |
                  "K" % char |
                    "L" % char |
                      "M" % char |
                        "N" % char |
                          "O" % char |
                            "P" % char |
                              "Q" % char |
                                "R" % char |
                                  "S" % char |
                                    "T" % char |
                                      "U" % char |
                                        "V" % char |
                                          "W" % char |
                                            "X" % char | "Y" % char | "Z" % char
        => missing_break tt
      | _ =>
        back charloc;
        skip (cons (tok stop) acc)
      end
    | (End, stop) as other =>
      back other;
      skip (cons (tok stop) acc)
    end
  with string (acc : list token) (sacc : list string) (start : point)
    : list token :=
    let tok (function_parameter : unit) : token :=
      match function_parameter with
      | tt =>
        tok start (here tt)
          (String (Stdlib.String.concat "" % string (List.rev sacc)))
      end in
    match next tt with
    | (End, stop) =>
      Stdlib.op_colon_eq errors
        (cons (Unterminated_string {| start := start; stop := stop |})
          (Stdlib.op_exclamation errors));
      skip (cons (tok tt) acc)
    | (Uchar c, stop) =>
      match uchar_to_char c with
      | Some """" % char => skip (cons (tok tt) acc)
      | Some ("010" % char | "013" % char) =>
        Stdlib.op_colon_eq errors
          (cons (Unterminated_string {| start := start; stop := stop |})
            (Stdlib.op_exclamation errors));
        skip (cons (tok tt) acc)
      | Some "\" % char =>
        match next tt with
        | (End, stop) =>
          Stdlib.op_colon_eq errors
            (cons (Unterminated_string {| start := start; stop := stop |})
              (Stdlib.op_exclamation errors));
          skip (cons (tok tt) acc)
        | (Uchar c, loc) =>
          match uchar_to_char c with
          | Some """" % char => string acc (cons """" % string sacc) start
          | Some "r" % char => string acc (cons "
" % string sacc) start
          | Some "n" % char => string acc (cons "
" % string sacc) start
          | Some "t" % char => string acc (cons "	" % string sacc) start
          | Some "b" % char => string acc (cons "" % string sacc) start
          | Some "\" % char => string acc (cons "\" % string sacc) start
          | Some _ | None =>
            let byte := Uutf.decoder_byte_count decoder in
            let s := Stdlib.String.sub source (byte loc) (Z.sub byte (byte loc))
              in
            Stdlib.op_colon_eq errors
              (cons (Undefined_escape_sequence loc s)
                (Stdlib.op_exclamation errors));
            string acc sacc start
          end
        end
      | Some _ | None =>
        let byte := Uutf.decoder_byte_count decoder in
        let s := Stdlib.String.sub source (byte stop) (Z.sub byte (byte stop))
          in
        string acc (cons s sacc) start
      end
    end
  with generic_ident
    (allow_char : Stdlib.Uchar.t -> bool) (acc : list token) (start : point)
    (ret : string -> point -> token_value) : list token :=
    let tok (stop : point) : token :=
      let name :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      tok start stop (ret name stop) in
    match next tt with
    | (Uchar c, stop) as charloc =>
      if allow_char c then
        generic_ident allow_char acc start ret
      else
        back charloc;
        skip (cons (tok stop) acc)
    | (_, stop) as other =>
      back other;
      skip (cons (tok stop) acc)
    end
  with ident
    (acc : list token) (start : point) (ret : string -> point -> token_value)
    : list token :=
    generic_ident allowed_ident_char acc start ret
  with annot
    (acc : list token) (start : point) (ret : string -> point -> token_value)
    : list token :=
    generic_ident allowed_annot_char acc start ret
  with comment (acc : list token) (start : point) (lvl : Z) : list token :=
    match next tt with
    | (End, stop) =>
      Stdlib.op_colon_eq errors
        (cons (Unterminated_comment {| start := start; stop := stop |})
          (Stdlib.op_exclamation errors));
      let text :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      skip (cons (tok start stop (Comment text)) acc)
    | (Uchar c, _) =>
      match uchar_to_char c with
      | Some "*" % char =>
        match next tt with
        | other =>
          back other;
          comment acc start lvl
        end
      | Some "/" % char =>
        match next tt with
        | other =>
          back other;
          comment acc start lvl
        end
      | Some _ | None => comment acc start lvl
      end
    end
  with eol_comment (acc : list token) (start : point) : list token :=
    let tok (stop : point) : token :=
      let text :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      tok start stop (Eol_comment text) in
    match next tt with
    | (Uchar c, stop) =>
      match uchar_to_char c with
      | Some "010" % char => skip (cons (tok stop) acc)
      | Some _ | None => eol_comment acc start
      end
    | (_, stop) as other =>
      back other;
      skip (cons (tok stop) acc)
    end in
  let tokens := skip [] in
  (tokens, (List.rev (Stdlib.op_exclamation errors))).

Definition node := Tezos_micheline.Micheline.node location string.

Definition node_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_micheline.Micheline.node location string) :=
  Tezos_micheline.Micheline.table_encoding "generic" % string location_encoding
    Tezos_data_encoding.Data_encoding.string.

Definition min_point (function_parameter : list node) : point :=
  match function_parameter with
  | [] => point_zero
  |
    cons (Int {| start := start |} _) _ | cons (String {| start := start |} _) _
      | cons (Bytes {| start := start |} _) _ |
      cons (Prim {| start := start |} _ _ _) _ |
      cons (Seq {| start := start |} _) _ => start
  end.

Fixpoint max_point (function_parameter : list node) : point :=
  match function_parameter with
  | [] => point_zero
  | cons _ ((cons _ _) as rest) => max_point rest
  |
    cons (Int {| stop := stop |} _) [] | cons (String {| stop := stop |} _) [] |
      cons (Bytes {| stop := stop |} _) [] |
      cons (Prim {| stop := stop |} _ _ _) [] |
      cons (Seq {| stop := stop |} _) [] => stop
  end.

Inductive mode : Type :=
| Toplevel : (list node) -> mode
| Expression : (option node) -> mode
| Sequence : token -> (list node) -> mode
| Unwrapped : location -> string -> (list node) -> (list string) -> mode
| Wrapped : token -> string -> (list node) -> (list string) -> mode.

Definition push_mode {A : Type} (mode : A) (stack : list A) : list A :=
  cons mode stack.

Definition pop_mode {A : Type} (function_parameter : list A) : list A :=
  match function_parameter with
  | [] => false
  | cons _ rest => rest
  end.

Definition fill_mode (result : node) (function_parameter : list mode)
  : list mode :=
  match function_parameter with
  | [] => false
  | cons (Expression _) (cons _ _) => false
  | cons (Expression (Some _)) [] => false
  | cons (Toplevel _) (cons _ _) => false
  | cons (Expression None) [] => cons (Expression (Some result)) []
  | cons (Toplevel exprs) [] => cons (Toplevel (cons result exprs)) []
  | cons (Sequence token exprs) rest =>
    cons (Sequence token (cons result exprs)) rest
  | cons (Wrapped token name exprs annot) rest =>
    cons (Wrapped token name (cons result exprs) annot) rest
  | cons (Unwrapped start name exprs annot) rest =>
    cons (Unwrapped start name (cons result exprs) annot) rest
  end.

Fixpoint annots (function_parameter : list token)
  : (list string) * (list token) :=
  match function_parameter with
  | cons {| token := Annot annot |} rest =>
    match annots rest with
    | (annots, rest) => ((cons annot annots), rest)
    end
  | rest => ([], rest)
  end.

Fixpoint parse (op_star_o_p_t_star : option bool)
  : (list Tezos_error_monad.Error_monad.error) ->
    (list token) ->
      (list mode) -> (list node) * (list Tezos_error_monad.Error_monad.error) :=
  let check :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun errors =>
    fun tokens =>
      fun stack =>
        match (stack, tokens) with
        |
          ([], _) | (cons (Wrapped _ _ _ _) [], _) |
            (cons (Unwrapped _ _ _ _) [], _) |
            (cons (Unwrapped _ _ _ _) (cons (Unwrapped _ _ _ _) _), _) |
            (cons (Unwrapped _ _ _ _) (cons (Wrapped _ _ _ _) _), _) |
            (cons (Toplevel _) (cons _ _), _) |
            (cons (Expression _) (cons _ _), _) => false
        | (cons (Expression (Some result)) _, []) =>
          ((cons result []), (List.rev errors))
        | (cons (Expression (Some _)) _, cons token rem) =>
          let errors := cons (Unexpected token) errors in
          parse (Some check) errors rem stack
        | (cons (Expression None) _, []) =>
          let errors := cons Empty errors in
          let ghost := {| start := point_zero; stop := point_zero |} in
          ((cons (Seq ghost []) []), (List.rev errors))
        | (cons (Toplevel (cons ((Seq _ exprs) as expr) [])) [], []) =>
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          (exprs, (List.rev errors))
        | (cons (Toplevel exprs) [], []) =>
          let exprs := List.rev exprs in
          let loc := {| start := min_point exprs; stop := max_point exprs |} in
          let expr := Seq loc exprs in
          let errors :=
            if check then
              do_check (Some true) errors expr
            else
              errors in
          (exprs, (List.rev errors))
        | (_, cons {| token := Eol_comment _ | Comment _ |} rest) =>
          parse (Some check) errors rest stack
        |
          (cons (Expression None | Sequence _ _ | Toplevel _) _,
            cons ({| token := Int _ | String _ | Bytes _ |} as token)
              (cons {| token := Eol_comment _ | Comment _ |} rest)) |
            (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
              cons ({| token := Open_paren |} as token)
                (cons {| token := Eol_comment _ | Comment _ |} rest)) =>
          parse (Some check) errors (cons token rest) stack
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons ({| token := Open_paren |} as token)
              (cons {| token := Open_paren | Open_brace |} rem)) |
            (cons (Unwrapped _ _ _ _) (cons (Expression _) _),
              cons ({| token := Semi | Close_brace | Close_paren |} as token)
                rem) |
            (cons (Expression None) _,
              cons
                ({| token := Semi | Close_brace | Close_paren | Open_paren |} as
                  token) rem) =>
          let errors := cons (Unexpected token) errors in
          parse (Some check) errors rem stack
        |
          (cons (Sequence _ _ | Toplevel _) _,
            cons ({| token := Semi |} as valid)
              (cons ({| token := Semi |} as token) rem)) =>
          let errors := cons (Extra token) errors in
          parse (Some check) errors (cons valid rem) stack
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons {| token := Open_paren |}
              (cons
                ({|
                  token := Int _ | String _ | Bytes _ | Annot _ | Close_paren
                    |} as token) rem)) |
            (cons (Expression None | Sequence _ _ | Toplevel _) _,
              cons {| token := Int _ | String _ | Bytes _ |}
                (cons
                  ({|
                    token :=
                      Ident _ | Int _ | String _ | Bytes _ | Annot _ |
                        Close_paren | Open_paren | Open_brace
                      |} as token) rem)) |
            (cons (Unwrapped _ _ _ _) (cons (Toplevel _) _),
              cons ({| token := Close_brace |} as token) rem) |
            (cons (Unwrapped _ _ _ _) _,
              cons ({| token := Close_paren |} as token) rem) |
            (cons (Toplevel _) [],
              cons ({| token := Close_paren |} as token) rem) |
            (cons (Toplevel _) [], cons ({| token := Open_paren |} as token) rem)
            |
            (cons (Toplevel _) [],
              cons ({| token := Close_brace |} as token) rem) |
            (cons (Sequence _ _) _,
              cons ({| token := Open_paren |} as token) rem) |
            (cons (Sequence _ _) _,
              cons ({| token := Close_paren |} as token) rem) |
            (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
              cons ({| token := Open_paren |} as token)
                ((cons {| token := Close_brace | Semi |} _ | []) as rem)) |
            (_, cons ({| token := Annot _ |} as token) rem) =>
          let errors := cons (Unexpected token) errors in
          parse (Some check) errors rem stack
        |
          (cons (Wrapped token _ _ _) _,
            [] | cons {| token := Close_brace | Semi |} _) =>
          let errors := cons (Unclosed token) errors in
          let fake := record in
          let tokens := cons fake tokens in
          parse (Some check) errors tokens stack
        |
          (cons (Sequence token _) _ |
            cons (Unwrapped _ _ _ _) (cons (Sequence token _) _), []) =>
          let errors := cons (Unclosed token) errors in
          let fake := record in
          let tokens := cons fake tokens in
          parse (Some check) errors tokens stack
        |
          (cons (Toplevel _ | Sequence _ _) _,
            cons {| token := Ident name; loc := loc |}
              ((cons {| token := Annot _ |} _) as rest)) =>
          match annots rest with
          | (annots, rest) =>
            let mode := Unwrapped loc name [] annots in
            parse (Some check) errors rest (push_mode mode stack)
          end
        |
          (cons (Expression None | Toplevel _ | Sequence _ _) _,
            cons {| token := Ident name; loc := loc |} rest) =>
          let mode := Unwrapped loc name [] [] in
          parse (Some check) errors rest (push_mode mode stack)
        |
          (cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
            cons {| token := Int value; loc := loc |} rest) |
            (cons (Expression None | Sequence _ _ | Toplevel _) _,
              cons {| token := Int value; loc := loc |}
                (([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
          let expr := Int loc (Z.of_string value) in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr stack)
        |
          (cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
            cons {| token := String contents; loc := loc |} rest) |
            (cons (Expression None | Sequence _ _ | Toplevel _) _,
              cons {| token := String contents; loc := loc |}
                (([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
          let expr := String loc contents in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr stack)
        |
          (cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
            cons {| token := Bytes contents; loc := loc |} rest) |
            (cons (Expression None | Sequence _ _ | Toplevel _) _,
              cons {| token := Bytes contents; loc := loc |}
                (([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
          match
            if nequiv_decb (Z.modulo (OCaml.String.length contents) 2) 0 then
              ((cons (Odd_lengthed_bytes loc) errors),
                (String.append contents "0" % string))
            else
              (errors, contents) with
          | (errors, contents) =>
            let bytes := Hex.to_bytes variant in
            let expr := Bytes loc string in
            let errors :=
              if check then
                do_check (Some false) errors expr
              else
                errors in
            parse (Some check) errors rest (fill_mode expr stack)
          end
        |
          (cons (Sequence {| loc := {| start := start |} |} exprs) _,
            cons {| token := Close_brace; loc := {| stop := stop |} |} rest) =>
          let exprs := List.rev exprs in
          let expr := Micheline.Seq {| start := start; stop := stop |} exprs in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr (pop_mode stack))
        | (cons (Sequence _ _ | Toplevel _) _, cons {| token := Semi |} rest) =>
          parse (Some check) errors rest stack
        |
          (cons (Unwrapped {| start := start; stop := stop |} name exprs annot)
            (cons (Expression _) _), [] as rest) |
            (cons
              (Unwrapped {| start := start; stop := stop |} name exprs annot)
              (cons (Toplevel _) _), (cons {| token := Semi |} _ | []) as rest)
            |
            (cons
              (Unwrapped {| start := start; stop := stop |} name exprs annot)
              (cons (Sequence _ _) _),
              (cons {| token := Close_brace | Semi |} _) as rest) |
            (cons
              (Wrapped {| loc := {| start := start; stop := stop |} |} name
                exprs annot) _, cons {| token := Close_paren |} rest) =>
          let exprs := List.rev exprs in
          let stop :=
            if equiv_decb exprs [] then
              stop
            else
              max_point exprs in
          let expr :=
            Micheline.Prim {| start := start; stop := stop |} name exprs annot
            in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr (pop_mode stack))
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons ({| token := Open_paren |} as token)
              (cons {| token := Ident name |}
                ((cons {| token := Annot _ |} _) as rest))) =>
          match annots rest with
          | (annots, rest) =>
            let mode := Wrapped token name [] annots in
            parse (Some check) errors rest (push_mode mode stack)
          end
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons ({| token := Open_paren |} as token)
              (cons {| token := Ident name |} rest)) =>
          let mode := Wrapped token name [] [] in
          parse (Some check) errors rest (push_mode mode stack)
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons {| token := Ident name; loc := loc |} rest) =>
          let expr := Micheline.Prim loc name [] [] in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr stack)
        |
          (cons
            (Wrapped _ _ _ _ | Unwrapped _ _ _ _ | Toplevel _ | Sequence _ _ |
              Expression None) _, cons ({| token := Open_brace |} as token) rest)
          =>
          let mode := Sequence token [] in
          parse (Some check) errors rest (push_mode mode stack)
        end

with do_check (op_star_o_p_t_star : option bool)
  : (list Tezos_error_monad.Error_monad.error) ->
    (Tezos_micheline.Micheline.node location string) ->
      list Tezos_error_monad.Error_monad.error :=
  let toplevel :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun errors =>
    fun function_parameter =>
      match function_parameter with
      | (Seq {| start := start; stop := stop |} []) as expr =>
        if OCaml.Stdlib.ge (column start) (column stop) then
          cons (Misaligned expr) errors
        else
          errors
      |
        (Prim {| start := start; stop := stop |} _ (cons first rest) _ |
          Seq {| start := start; stop := stop |} (cons first rest)) as expr =>
        match min_point (cons first []) with
        | {| line := first_line; column := first_column |} =>
          if OCaml.Stdlib.ge (column start) (column stop) then
            cons (Misaligned expr) errors
          else
            if
              andb (negb toplevel) (OCaml.Stdlib.ge (column start) first_column)
              then
              cons (Misaligned expr) errors
            else
              let fix in_line_or_aligned
                (prev_start_line : Z) (errors :
                list Tezos_error_monad.Error_monad.error) (function_parameter :
                list node) : list Tezos_error_monad.Error_monad.error :=
                match function_parameter with
                | [] => errors
                | cons expr rest =>
                  match min_point (cons expr []) with
                  | {| line := start_line; column := column |} =>
                    match max_point (cons expr []) with
                    | {| line := stop_line |} =>
                      let errors :=
                        if
                          andb (nequiv_decb stop_line prev_start_line)
                            (nequiv_decb column first_column) then
                          cons (Misaligned expr) errors
                        else
                          errors in
                      in_line_or_aligned start_line errors rest
                    end
                  end
                end in
              in_line_or_aligned first_line errors rest
        end
      | Prim _ _ [] _ | String _ _ | Int _ _ | Bytes _ _ => errors
      end.

Definition parse_expression (check : option bool) (tokens : list token)
  : node * (list Tezos_error_monad.Error_monad.error) :=
  let result :=
    match tokens with
    |
      cons ({| token := Open_paren |} as token)
        (cons {| token := Ident name |} (cons {| token := Annot annot |} rest))
      =>
      match annots rest with
      | (annots, rest) =>
        let mode := Wrapped token name [] (cons annot annots) in
        parse check [] rest (cons mode (cons (Expression None) []))
      end
    |
      cons ({| token := Open_paren |} as token)
        (cons {| token := Ident name |} rest) =>
      let mode := Wrapped token name [] [] in
      parse check [] rest (cons mode (cons (Expression None) []))
    | _ => parse check [] tokens (cons (Expression None) [])
    end in
  match result with
  | (cons single [], errors) => (single, errors)
  | _ => false
  end.

Definition parse_toplevel (check : option bool) (tokens : list token)
  : (list node) * (list Tezos_error_monad.Error_monad.error) :=
  parse check [] tokens (cons (Toplevel []) []).

Definition print_point
  (ppf : Stdlib.Format.formatter) (function_parameter : point) : unit :=
  match function_parameter with
  | {| line := line; column := column |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "At line " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " character " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                CamlinternalFormatBasics.End_of_format))))
        "At line %d character %d" % string) line column
  end.

Definition print_token_kind
  (ppf : Stdlib.Format.formatter) (function_parameter : token_value) : unit :=
  match function_parameter with
  | Open_paren | Close_paren =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "parenthesis" % string
          CamlinternalFormatBasics.End_of_format) "parenthesis" % string)
  | Open_brace | Close_brace =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "curly brace" % string
          CamlinternalFormatBasics.End_of_format) "curly brace" % string)
  | String _ =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "string constant" % string
          CamlinternalFormatBasics.End_of_format) "string constant" % string)
  | Bytes _ =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "bytes constant" % string
          CamlinternalFormatBasics.End_of_format) "bytes constant" % string)
  | Int _ =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "integer constant" % string
          CamlinternalFormatBasics.End_of_format) "integer constant" % string)
  | Ident _ =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "identifier" % string
          CamlinternalFormatBasics.End_of_format) "identifier" % string)
  | Annot _ =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "annotation" % string
          CamlinternalFormatBasics.End_of_format) "annotation" % string)
  | Comment _ | Eol_comment _ =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "comment" % string
          CamlinternalFormatBasics.End_of_format) "comment" % string)
  | Semi =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "semi colon" % string
          CamlinternalFormatBasics.End_of_format) "semi colon" % string)
  end.

Definition print_location (ppf : Stdlib.Format.formatter) (loc : location)
  : unit :=
  if equiv_decb (line (start loc)) (line (stop loc)) then
    if equiv_decb (column (start loc)) (column (stop loc)) then
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "At line " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " character " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))))
          "At line %d character %d" % string) (line (start loc))
        (column (start loc))
    else
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "At line " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " characters " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal " to " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format))))))
          "At line %d characters %d to %d" % string) (line (start loc))
        (column (start loc)) (column (stop loc))
  else
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "From line " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " character " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " to line " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal
                      " character " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        CamlinternalFormatBasics.End_of_format))))))))
        "From line %d character %d to line %d character %d" % string)
      (line (start loc)) (column (start loc)) (line (stop loc))
      (column (stop loc)).

Definition no_parsing_error {A : Type}
  (function_parameter : A * (list Tezos_error_monad.Error_monad.error))
  : Tezos_error_monad.Error_monad.tzresult A :=
  match function_parameter with
  | (ast, errors) =>
    match errors with
    | [] => Tezos_error_monad.Error_monad.ok ast
    | errors => inr errors
    end
  end.
src/lib_micheline/micheline_parser.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

type 'a parsing_result = 'a * error list

val no_parsing_error : 'a parsing_result -> 'a tzresult

type point = {point : int; byte : int; line : int; column : int}

val point_zero : point

type location = {start : point; stop : point}

val location_zero : location

val point_encoding : point Data_encoding.encoding

val location_encoding : location Data_encoding.encoding

type token_value =
  | String of string
  | Bytes of string
  | Int of string
  | Ident of string
  | Annot of string
  | Comment of string
  | Eol_comment of string
  | Semi
  | Open_paren
  | Close_paren
  | Open_brace
  | Close_brace

type token = {token : token_value; loc : location}

val tokenize : string -> token list parsing_result

type node = (location, string) Micheline.node

(** Beginning of a sequence of consecutive primitives *)
val min_point : node list -> point

(** End of a sequence of consecutive primitives *)
val max_point : node list -> point

val max_annot_length : int

val node_encoding : node Data_encoding.encoding

type error += Invalid_utf8_sequence of point * string

type error += Unexpected_character of point * string

type error += Undefined_escape_sequence of point * string

type error += Missing_break_after_number of point

type error += Unterminated_string of location

type error += Unterminated_integer of location

type error += Odd_lengthed_bytes of location

type error += Unterminated_comment of location

type error += Unclosed of token

type error += Unexpected of token

type error += Extra of token

type error += Misaligned of node

type error += Empty

type error += Annotation_length of location

val parse_toplevel : ?check:bool -> token list -> node list parsing_result

val parse_expression : ?check:bool -> token list -> node parsing_result

val print_location : Format.formatter -> location -> unit

val print_point : Format.formatter -> point -> unit
src/lib_micheline/micheline_parser.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition parsing_result (a : Type) :=
  a * (list Tezos_error_monad.Error_monad.error).

Parameter no_parsing_error : forall {a : Type},
(parsing_result a) -> Tezos_error_monad.Error_monad.tzresult a.

Record point := {
  point : Z;
  byte : Z;
  line : Z;
  column : Z }.

Parameter point_zero : point.

Record location := {
  start : point;
  stop : point }.

Parameter location_zero : location.

Parameter point_encoding : Tezos_data_encoding.Data_encoding.encoding point.

Parameter location_encoding :
Tezos_data_encoding.Data_encoding.encoding location.

Inductive token_value : Type :=
| String : string -> token_value
| Bytes : string -> token_value
| Int : string -> token_value
| Ident : string -> token_value
| Annot : string -> token_value
| Comment : string -> token_value
| Eol_comment : string -> token_value
| Semi : token_value
| Open_paren : token_value
| Close_paren : token_value
| Open_brace : token_value
| Close_brace : token_value.

Record token := {
  token : token_value;
  loc : location }.

Parameter tokenize : string -> parsing_result (list token).

Definition node := Tezos_micheline.Micheline.node location string.

Parameter min_point : (list node) -> point.

Parameter max_point : (list node) -> point.

Parameter max_annot_length : Z.

Parameter node_encoding : Tezos_data_encoding.Data_encoding.encoding node.

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

Parameter parse_toplevel :
(option bool) -> (list token) -> parsing_result (list node).

Parameter parse_expression :
(option bool) -> (list token) -> parsing_result node.

Parameter print_location : Stdlib.Format.formatter -> location -> unit.

Parameter print_point : Stdlib.Format.formatter -> point -> unit.
src/lib_micheline/micheline_printer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Micheline

type location = {comment : string option}

type node = (location, string) Micheline.node

let printable ?(comment = fun _ -> None) map_prim expr =
  let map_loc loc = {comment = comment loc} in
  map_node map_loc map_prim (root expr)

let print_comment ppf text =
  Format.fprintf ppf "/* @[<h>%a@] */" Format.pp_print_text text

let print_string ppf text =
  Format.fprintf ppf "\"" ;
  String.iter
    (function
      | '"' ->
          Format.fprintf ppf "\\\""
      | '\n' ->
          Format.fprintf ppf "\\n"
      | '\r' ->
          Format.fprintf ppf "\\r"
      | '\b' ->
          Format.fprintf ppf "\\b"
      | '\t' ->
          Format.fprintf ppf "\\t"
      | '\\' ->
          Format.fprintf ppf "\\\\"
      | c ->
          Format.fprintf ppf "%c" c)
    text ;
  Format.fprintf ppf "\""

let print_annotations =
  Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string

let preformat root =
  let preformat_loc = function
    | {comment = None} ->
        (false, 0)
    | {comment = Some text} ->
        (String.contains text '\n', String.length text + 1)
  in
  let preformat_annots = function
    | [] ->
        0
    | annots ->
        String.length (String.concat " " annots) + 2
  in
  let rec preformat_expr = function
    | Int (loc, value) ->
        let (cml, csz) = preformat_loc loc in
        Int ((cml, String.length (Z.to_string value) + csz, loc), value)
    | String (loc, value) ->
        let (cml, csz) = preformat_loc loc in
        String ((cml, String.length value + csz, loc), value)
    | Bytes (loc, value) ->
        let (cml, csz) = preformat_loc loc in
        Bytes ((cml, (Bytes.length value * 2) + 2 + csz, loc), value)
    | Prim (loc, name, items, annots) ->
        let (cml, csz) = preformat_loc loc in
        let asz = preformat_annots annots in
        let items = List.map preformat_expr items in
        let (ml, sz) =
          List.fold_left
            (fun (tml, tsz) e ->
              let (ml, sz, _) = location e in
              (tml || ml, tsz + 1 + sz))
            (cml, String.length name + csz + asz)
            items
        in
        Prim ((ml, sz, loc), name, items, annots)
    | Seq (loc, items) ->
        let (cml, csz) = preformat_loc loc in
        let items = List.map preformat_expr items in
        let (ml, sz) =
          List.fold_left
            (fun (tml, tsz) e ->
              let (ml, sz, _) = location e in
              (tml || ml, tsz + 3 + sz))
            (cml, 4 + csz)
            items
        in
        Seq ((ml, sz, loc), items)
  in
  preformat_expr root

let rec print_expr_unwrapped ppf = function
  | Prim ((ml, s, {comment}), name, args, annot) ->
      let name =
        match annot with
        | [] ->
            name
        | annots ->
            Format.asprintf "%s @[<h>%a@]" name print_annotations annots
      in
      if (not ml) && s < 80 then (
        if args = [] then Format.fprintf ppf "%s" name
        else
          Format.fprintf
            ppf
            "@[<h>%s %a@]"
            name
            (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
            args ;
        match comment with
        | None ->
            ()
        | Some text ->
            Format.fprintf ppf "@ /* %s */" text )
      else (
        if args = [] then Format.fprintf ppf "%s" name
        else if String.length name <= 4 then
          Format.fprintf
            ppf
            "%s @[<v 0>%a@]"
            name
            (Format.pp_print_list print_expr)
            args
        else
          Format.fprintf
            ppf
            "@[<v 2>%s@,%a@]"
            name
            (Format.pp_print_list print_expr)
            args ;
        match comment with
        | None ->
            ()
        | Some comment ->
            Format.fprintf ppf "@ %a" print_comment comment )
  | Int ((_, _, {comment}), value) -> (
    match comment with
    | None ->
        Format.fprintf ppf "%s" (Z.to_string value)
    | Some comment ->
        Format.fprintf ppf "%s@ %a" (Z.to_string value) print_comment comment )
  | String ((_, _, {comment}), value) -> (
    match comment with
    | None ->
        print_string ppf value
    | Some comment ->
        Format.fprintf ppf "%a@ %a" print_string value print_comment comment )
  | Bytes ((_, _, {comment}), value) -> (
    match comment with
    | None ->
        Format.fprintf ppf "0x%a" Hex.pp (Hex.of_bytes value)
    | Some comment ->
        Format.fprintf
          ppf
          "0x%a@ %a"
          Hex.pp
          (Hex.of_bytes value)
          print_comment
          comment )
  | Seq ((_, _, {comment = None}), []) ->
      Format.fprintf ppf "{}"
  | Seq ((ml, s, {comment}), items) ->
      if (not ml) && s < 80 then Format.fprintf ppf "{ @[<h 0>"
      else Format.fprintf ppf "{ @[<v 0>" ;
      ( match (comment, items) with
      | (None, _) ->
          ()
      | (Some comment, []) ->
          Format.fprintf ppf "%a" print_comment comment
      | (Some comment, _) ->
          Format.fprintf ppf "%a@ " print_comment comment ) ;
      Format.pp_print_list
        ~pp_sep:(fun ppf () -> Format.fprintf ppf " ;@ ")
        print_expr_unwrapped
        ppf
        items ;
      Format.fprintf ppf "@] }"

and print_expr ppf = function
  | (Prim (_, _, _ :: _, _) | Prim (_, _, [], _ :: _)) as expr ->
      Format.fprintf ppf "(%a)" print_expr_unwrapped expr
  | expr ->
      print_expr_unwrapped ppf expr

let with_unbounded_formatter ppf f x =
  let buf = Buffer.create 10000 in
  let sppf = Format.formatter_of_buffer buf in
  Format.pp_set_margin sppf 199999 ;
  Format.pp_set_max_indent sppf 99999 ;
  Format.pp_set_max_boxes sppf 99999 ;
  f sppf x ;
  Format.fprintf sppf "%!" ;
  let lines = String.split_on_char '\n' (Buffer.contents buf) in
  Format.pp_print_list
    ~pp_sep:Format.pp_force_newline
    Format.pp_print_string
    ppf
    lines

let print_expr_unwrapped ppf expr =
  with_unbounded_formatter ppf print_expr_unwrapped (preformat expr)

let print_expr ppf expr =
  with_unbounded_formatter ppf print_expr (preformat expr)
src/lib_micheline/micheline_printer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_micheline.Micheline.

Record location := {
  comment : option string }.

Definition node := Tezos_micheline.Micheline.node location string.

Definition printable {A B : Type}
  (op_star_o_p_t_star :
    option (Tezos_micheline.Micheline.canonical_location -> option string))
  : (A -> B) ->
    (Tezos_micheline.Micheline.canonical A) ->
      Tezos_micheline.Micheline.node location B :=
  let comment :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => None
        end
    end in
  fun map_prim =>
    fun expr =>
      let map_loc (loc : Tezos_micheline.Micheline.canonical_location)
        : location :=
        {| comment := comment loc |} in
      Tezos_micheline.Micheline.map_node map_loc map_prim
        (Tezos_micheline.Micheline.root expr).

Definition print_comment (ppf : Stdlib.Format.formatter) (text : string)
  : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "/* " % string
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<h>" % string
                CamlinternalFormatBasics.End_of_format) "<h>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              (CamlinternalFormatBasics.String_literal " */" % string
                CamlinternalFormatBasics.End_of_format)))))
      "/* @[<h>%a@] */" % string) Stdlib.Format.pp_print_text text.

Definition print_string (ppf : Stdlib.Format.formatter) (text : string)
  : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal """" % char
        CamlinternalFormatBasics.End_of_format) """" % string);
  Stdlib.String.iter
    (fun function_parameter =>
      match function_parameter with
      | """" % char =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "\""" % string
              CamlinternalFormatBasics.End_of_format) "\""" % string)
      | "010" % char =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "\n" % string
              CamlinternalFormatBasics.End_of_format) "\n" % string)
      | "013" % char =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "\r" % string
              CamlinternalFormatBasics.End_of_format) "\r" % string)
      | "008" % char =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "\b" % string
              CamlinternalFormatBasics.End_of_format) "\b" % string)
      | "009" % char =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "\t" % string
              CamlinternalFormatBasics.End_of_format) "\t" % string)
      | "\" % char =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "\\" % string
              CamlinternalFormatBasics.End_of_format) "\\" % string)
      | c =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char
              CamlinternalFormatBasics.End_of_format) "%c" % string) c
      end) text;
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal """" % char
        CamlinternalFormatBasics.End_of_format) """" % string).

Definition print_annotations
  : Stdlib.Format.formatter -> (list string) -> unit :=
  Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space)
    Stdlib.Format.pp_print_string.

Definition preformat (root : Tezos_micheline.Micheline.node location string)
  : Tezos_micheline.Micheline.node (bool * Z * location) string :=
  let preformat_loc (function_parameter : location) : bool * Z :=
    match function_parameter with
    | {| comment := None |} => (false, 0)
    | {| comment := Some text |} =>
      ((Stdlib.String.contains text "010" % char),
        (Z.add (OCaml.String.length text) 1))
    end in
  let preformat_annots (function_parameter : list string) : Z :=
    match function_parameter with
    | [] => 0
    | annots =>
      Z.add (OCaml.String.length (Stdlib.String.concat " " % string annots)) 2
    end in
  let fix preformat_expr
    (function_parameter : Tezos_micheline.Micheline.node location string)
    : Tezos_micheline.Micheline.node (bool * Z * location) string :=
    match function_parameter with
    | Int loc value =>
      match preformat_loc loc with
      | (cml, csz) =>
        Int (cml, (Z.add (OCaml.String.length (Z.to_string value)) csz), loc)
          value
      end
    | String loc value =>
      match preformat_loc loc with
      | (cml, csz) =>
        String (cml, (Z.add (OCaml.String.length value) csz), loc) value
      end
    | Bytes loc value =>
      match preformat_loc loc with
      | (cml, csz) =>
        Bytes (cml, (Z.add (Z.add (Z.mul (String.length value) 2) 2) csz), loc)
          value
      end
    | Prim loc name items annots =>
      match preformat_loc loc with
      | (cml, csz) =>
        let asz := preformat_annots annots in
        let items := List.map preformat_expr items in
        match
          Stdlib.List.fold_left
            (fun function_parameter =>
              match function_parameter with
              | (tml, tsz) =>
                fun e =>
                  match Tezos_micheline.Micheline.location e with
                  | (ml, sz, _) => ((orb tml ml), (Z.add (Z.add tsz 1) sz))
                  end
              end) (cml, (Z.add (Z.add (OCaml.String.length name) csz) asz))
            items with
        | (ml, sz) => Prim (ml, sz, loc) name items annots
        end
      end
    | Seq loc items =>
      match preformat_loc loc with
      | (cml, csz) =>
        let items := List.map preformat_expr items in
        match
          Stdlib.List.fold_left
            (fun function_parameter =>
              match function_parameter with
              | (tml, tsz) =>
                fun e =>
                  match Tezos_micheline.Micheline.location e with
                  | (ml, sz, _) => ((orb tml ml), (Z.add (Z.add tsz 3) sz))
                  end
              end) (cml, (Z.add 4 csz)) items with
        | (ml, sz) => Seq (ml, sz, loc) items
        end
      end
    end in
  preformat_expr root.

Fixpoint print_expr_unwrapped
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_micheline.Micheline.node (bool * Z * location) string) : unit :=
  match function_parameter with
  | Prim (ml, s, {| comment := comment |}) name args annot =>
    let name :=
      match annot with
      | [] => name
      | annots =>
        Stdlib.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal " " % char
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<h>" % string
                        CamlinternalFormatBasics.End_of_format) "<h>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "%s @[<h>%a@]" % string) name print_annotations annots
      end in
    if andb (negb ml) (OCaml.Stdlib.lt s 80) then
      if equiv_decb args [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format) "%s" % string) name
      else
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<h>" % string
                    CamlinternalFormatBasics.End_of_format) "<h>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<h>%s %a@]" % string) name
          (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space)
            print_expr) args;
      match comment with
      | None => tt
      | Some text =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String_literal "/* " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " */" % string
                    CamlinternalFormatBasics.End_of_format))))
            "@ /* %s */" % string) text
      end
    else
      if equiv_decb args [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format) "%s" % string) name
      else
        if OCaml.Stdlib.le (OCaml.String.length name) 4 then
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 0>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 0>" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))
              "%s @[<v 0>%a@]" % string) name
            (Stdlib.Format.pp_print_list None print_expr) args
        else
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))
              "@[<v 2>%s@,%a@]" % string) name
            (Stdlib.Format.pp_print_list None print_expr) args;
      match comment with
      | None => tt
      | Some comment =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "@ %a" % string)
          print_comment comment
      end
  | Int (_, _, {| comment := comment |}) value =>
    match comment with
    | None =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string)
        (Z.to_string value)
    | Some comment =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))) "%s@ %a" % string)
        (Z.to_string value) print_comment comment
    end
  | String (_, _, {| comment := comment |}) value =>
    match comment with
    | None => print_string ppf value
    | Some comment =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))) "%a@ %a" % string)
        print_string value print_comment comment
    end
  | Bytes (_, _, {| comment := comment |}) value =>
    match comment with
    | None =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "0x" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "0x%a" % string) Hex.pp
        (Hex.of_bytes None value)
    | Some comment =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "0x" % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))) "0x%a@ %a" % string)
        Hex.pp (Hex.of_bytes None value) print_comment comment
    end
  | Seq (_, _, {| comment := None |}) [] =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "{}" % string
          CamlinternalFormatBasics.End_of_format) "{}" % string)
  | Seq (ml, s, {| comment := comment |}) items =>
    if andb (negb ml) (OCaml.Stdlib.lt s 80) then
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "{ " % string
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<h 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<h 0>" % string))
              CamlinternalFormatBasics.End_of_format)) "{ @[<h 0>" % string)
    else
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "{ " % string
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              CamlinternalFormatBasics.End_of_format)) "{ @[<v 0>" % string);
    match (comment, items) with
    | (None, _) => tt
    | (Some comment, []) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) print_comment comment
    | (Some comment, _) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              CamlinternalFormatBasics.End_of_format)) "%a@ " % string)
        print_comment comment
    end;
    Stdlib.Format.pp_print_list
      (Some
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal " ;" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      CamlinternalFormatBasics.End_of_format)) " ;@ " % string)
            end)) print_expr_unwrapped ppf items;
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          (CamlinternalFormatBasics.String_literal " }" % string
            CamlinternalFormatBasics.End_of_format)) "@] }" % string)
  end

with print_expr
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_micheline.Micheline.node (bool * Z * location) string) : unit :=
  match function_parameter with
  | (Prim _ _ (cons _ _) _ | Prim _ _ [] (cons _ _)) as expr =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format))) "(%a)" % string)
      print_expr_unwrapped expr
  | expr => print_expr_unwrapped ppf expr
  end.

Definition with_unbounded_formatter {A : Type}
  (ppf : Stdlib.Format.formatter) (f : Stdlib.Format.formatter -> A -> unit)
  (x : A) : unit :=
  let buf := Stdlib.Buffer.create 10000 in
  let sppf := Stdlib.Format.formatter_of_buffer buf in
  Stdlib.Format.pp_set_margin sppf 199999;
  Stdlib.Format.pp_set_max_indent sppf 99999;
  Stdlib.Format.pp_set_max_boxes sppf 99999;
  f sppf x;
  Stdlib.Format.fprintf sppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format)
      "%!" % string);
  let lines :=
    Stdlib.String.split_on_char "010" % char (Stdlib.Buffer.contents buf) in
  Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_force_newline)
    Stdlib.Format.pp_print_string ppf lines.

Definition print_expr_unwrapped
  (ppf : Stdlib.Format.formatter)
  (expr : Tezos_micheline.Micheline.node location string) : unit :=
  with_unbounded_formatter ppf print_expr_unwrapped (preformat expr).

Definition print_expr
  (ppf : Stdlib.Format.formatter)
  (expr : Tezos_micheline.Micheline.node location string) : unit :=
  with_unbounded_formatter ppf print_expr (preformat expr).
src/lib_micheline/micheline_printer.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Micheline

val print_string : Format.formatter -> string -> unit

type location = {comment : string option}

type node = (location, string) Micheline.node

val print_expr : Format.formatter -> (location, string) Micheline.node -> unit

val print_expr_unwrapped :
  Format.formatter -> (location, string) Micheline.node -> unit

val printable :
  ?comment:(int -> string option) ->
  ('p -> string) ->
  'p canonical ->
  (location, string) Micheline.node
src/lib_micheline/micheline_printer.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter print_string : Stdlib.Format.formatter -> string -> unit.

Record location := {
  comment : option string }.

Definition node := Tezos_micheline.Micheline.node location string.

Parameter print_expr :
Stdlib.Format.formatter ->
  (Tezos_micheline.Micheline.node location string) -> unit.

Parameter print_expr_unwrapped :
Stdlib.Format.formatter ->
  (Tezos_micheline.Micheline.node location string) -> unit.

Parameter printable : forall {p : Type},
(option (Z -> option string)) ->
  (p -> string) ->
    (Tezos_micheline.Micheline.canonical p) ->
      Tezos_micheline.Micheline.node location string.
src/lib_micheline/test/assert.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Mini compatibility layer to avoid circular dependency *)
module Compat = struct
  let failwith fmt = Format.kasprintf (fun s -> Lwt.return_error s) fmt

  let return_unit = Lwt.return_ok ()

  let ( >>= ) = Lwt.bind

  let ( >>=? ) v f =
    v >>= function Error _ as err -> Lwt.return err | Ok v -> f v

  let rec iter2_p f l1 l2 =
    match (l1, l2) with
    | ([], []) ->
        return_unit
    | ([], _) | (_, []) ->
        invalid_arg "Error_monad.iter2_p"
    | (x1 :: l1, x2 :: l2) -> (
        let tx = f x1 x2 and tl = iter2_p f l1 l2 in
        tx
        >>= fun tx_res ->
        tl
        >>= fun tl_res ->
        match (tx_res, tl_res) with
        | (Ok (), Ok ()) ->
            Lwt.return_ok ()
        | (Error exn1, Error exn2) ->
            failwith "%s -- %s" exn1 exn2
        | (Ok (), Error exn) | (Error exn, Ok ()) ->
            Lwt.return_error exn )
end

open Compat

let fail loc printer given expected msg =
  failwith
    "@[<v 2> On %s : %s@ @[Given:\t%a@]@ @[Expected:\t%a@]@]"
    loc
    msg
    printer
    given
    printer
    expected

let default_printer fmt _ = Format.fprintf fmt ""

let equal ~loc ?(eq = ( = )) ?(printer = default_printer) ?(msg = "") given
    expected =
  if not (eq given expected) then fail loc printer given expected msg
  else return_unit

let not_equal ~loc ?(eq = ( = )) ?(printer = default_printer) ?(msg = "") given
    expected =
  if eq given expected then fail loc printer given expected msg
  else return_unit

let pp_tokens fmt tokens =
  let token_value_printer fmt token_value =
    Format.fprintf
      fmt
      "@[%s@]"
      (let open Micheline_parser in
      match token_value with
      | String s ->
          Format.sprintf "String %S" s
      | Bytes s ->
          Format.sprintf "Bytes %S" s
      | Int s ->
          Format.sprintf "Int %S" s
      | Ident s ->
          Format.sprintf "Ident %S" s
      | Annot s ->
          Format.sprintf "Annot %S" s
      | Comment s ->
          Format.sprintf "Comment %S" s
      | Eol_comment s ->
          Format.sprintf "Eol_comment %S" s
      | Semi ->
          Format.sprintf "Semi"
      | Open_paren ->
          Format.sprintf "Open_paren"
      | Close_paren ->
          Format.sprintf "Close_paren"
      | Open_brace ->
          Format.sprintf "Open_brace"
      | Close_brace ->
          Format.sprintf "Close_brace")
  in
  Format.fprintf fmt "%a" (Format.pp_print_list token_value_printer) tokens

let equal_tokens ~loc given expected =
  equal
    ~loc
    ~eq:( = )
    ~printer:pp_tokens
    ~msg:"Tokens are not equal"
    given
    expected

let not_equal_tokens ~loc given expected =
  not_equal
    ~loc
    ~eq:( = )
    ~printer:pp_tokens
    ~msg:"Tokens are equal"
    given
    expected
src/lib_micheline/test/assert.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Compat.
  Definition failwith {A B : Type}
    (fmt :
      Stdlib.format4 A Stdlib.Format.formatter unit
        (Lwt.t (Result.result B string))) : A :=
    Stdlib.Format.kasprintf (fun s => Lwt.return_error s) fmt.
  
  Definition return_unit {A : Type} : Lwt.t (Result.result unit A) :=
    Lwt.return_ok tt.
  
  Definition op_gt_gt_eq {A B : Type}
    : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B := Lwt.bind.
  
  Definition op_gt_gt_eq_question {A B C : Type}
    (v : Lwt.t (sum A B)) (f : A -> Lwt.t (sum C B)) : Lwt.t (sum C B) :=
    op_gt_gt_eq v
      (fun function_parameter =>
        match function_parameter with
        | (inr _) as err => Lwt._return err
        | inl v => f v
        end).
  
  Fixpoint iter2_p {A B : Type}
    (f : A -> B -> Lwt.t (sum unit string)) (l1 : list A) (l2 : list B)
    : Lwt.t (Result.result unit string) :=
    match (l1, l2) with
    | ([], []) => return_unit
    | ([], _) | (_, []) =>
      OCaml.Stdlib.invalid_arg "Error_monad.iter2_p" % string
    | (cons x1 l1, cons x2 l2) =>
      let tx : Lwt.t (sum unit string) :=
        f x1 x2
      with tl : Lwt.t (Result.result unit string) :=
        iter2_p f l1 l2 in
      op_gt_gt_eq tx
        (fun tx_res =>
          op_gt_gt_eq tl
            (fun tl_res =>
              match (tx_res, tl_res) with
              | (inl tt, inl tt) => Lwt.return_ok tt
              | (inr exn1, inr exn2) =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal " -- " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.End_of_format)))
                    "%s -- %s" % string) exn1 exn2
              | (inl tt, inr exn) | (inr exn, inl tt) => Lwt.return_error exn
              end))
    end.
End Compat.

Import Compat.

Definition fail {A B : Type}
  (loc : string) (printer : Stdlib.Format.formatter -> A -> unit) (given : A)
  (expected : A) (msg : string) : Lwt.t (Result.result B string) :=
  Compat.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 2>" % string
              CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
        (CamlinternalFormatBasics.String_literal " On " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal " : " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal "Given:	" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  CamlinternalFormatBasics.End_of_format
                                  "" % string))
                              (CamlinternalFormatBasics.String_literal
                                "Expected:	" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format))))))))))))))))
      "@[<v 2> On %s : %s@ @[Given:	%a@]@ @[Expected:	%a@]@]" % string) loc msg
    printer given printer expected.

Definition default_printer {A : Type}
  (fmt : Stdlib.Format.formatter) (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    Stdlib.Format.fprintf fmt
      (CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
        "" % string)
  end.

Definition equal {A : Type}
  (loc : string) (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (Stdlib.Format.formatter -> A -> unit)) ->
    (option string) -> A -> A -> Lwt.t (Result.result unit string) :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun op_star_o_p_t_star =>
    let printer :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun given =>
        fun expected =>
          if negb (eq given expected) then
            fail loc printer given expected msg
          else
            Compat.return_unit.

Definition not_equal {A : Type}
  (loc : string) (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (Stdlib.Format.formatter -> A -> unit)) ->
    (option string) -> A -> A -> Lwt.t (Result.result unit string) :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun op_star_o_p_t_star =>
    let printer :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun given =>
        fun expected =>
          if eq given expected then
            fail loc printer given expected msg
          else
            Compat.return_unit.

Definition pp_tokens
  (fmt : Stdlib.Format.formatter)
  (tokens : list Tezos_micheline.Micheline_parser.token_value) : unit :=
  let token_value_printer
    (fmt : Stdlib.Format.formatter) (token_value :
    Tezos_micheline.Micheline_parser.token_value) : unit :=
    Stdlib.Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format))) "@[%s@]" % string)
      match token_value with
      | String s =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "String " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "String %S" % string) s
      | Bytes s =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Bytes " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Bytes %S" % string) s
      | Int s =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Int " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Int %S" % string) s
      | Ident s =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Ident " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Ident %S" % string) s
      | Annot s =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Annot " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Annot %S" % string) s
      | Comment s =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Comment " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Comment %S" % string)
          s
      | Eol_comment s =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Eol_comment " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Eol_comment %S" % string) s
      | Semi =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Semi" % string
              CamlinternalFormatBasics.End_of_format) "Semi" % string)
      | Open_paren =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Open_paren" % string
              CamlinternalFormatBasics.End_of_format) "Open_paren" % string)
      | Close_paren =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Close_paren" % string
              CamlinternalFormatBasics.End_of_format) "Close_paren" % string)
      | Open_brace =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Open_brace" % string
              CamlinternalFormatBasics.End_of_format) "Open_brace" % string)
      | Close_brace =>
        Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Close_brace" % string
              CamlinternalFormatBasics.End_of_format) "Close_brace" % string)
      end in
  Stdlib.Format.fprintf fmt
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
      "%a" % string) (Stdlib.Format.pp_print_list None token_value_printer)
    tokens.

Definition equal_tokens
  (loc : string) (given : list Tezos_micheline.Micheline_parser.token_value)
  (expected : list Tezos_micheline.Micheline_parser.token_value)
  : Lwt.t (Result.result unit string) :=
  equal loc (Some equiv_decb) (Some pp_tokens)
    (Some "Tokens are not equal" % string) given expected.

Definition not_equal_tokens
  (loc : string) (given : list Tezos_micheline.Micheline_parser.token_value)
  (expected : list Tezos_micheline.Micheline_parser.token_value)
  : Lwt.t (Result.result unit string) :=
  not_equal loc (Some equiv_decb) (Some pp_tokens)
    (Some "Tokens are equal" % string) given expected.
src/lib_micheline/test/test_parser.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(****************************************************************************)
(* Token value   *)
(****************************************************************************)

open Assert.Compat

let assert_tokenize ~loc given expected =
  match Micheline_parser.tokenize given with
  | (tokens, []) ->
      let tokens_got = List.map (fun x -> x.Micheline_parser.token) tokens in
      Assert.equal_tokens ~loc tokens_got expected
  | (_, _) ->
      failwith "%s - Cannot tokenize %s" loc given

let assert_tokenize_error ~loc given expected =
  match Micheline_parser.tokenize given with
  | (tokens, []) ->
      let tokens_got = List.map (fun x -> x.Micheline_parser.token) tokens in
      Assert.not_equal_tokens ~loc tokens_got expected
  | (_, _) ->
      return_unit

let test_tokenize_basic () =
  (* String *)
  assert_tokenize ~loc:__LOC__ "\"abc\"" [String "abc"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "\"abc\t\"" [String "abc\t"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "\"abc\b\"" [String "abc\b"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "\"abc\\n\"" [String "abc\n"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "\"abc\\r\"" [String "abc\r"]
  >>=? fun () ->
  (*fail*)
  assert_tokenize_error ~loc:__LOC__ "\"abc\n\"" [String "abc\n"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc\\\"" [String "abc\\"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc\"" [String "abc\n"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc\r\"" [String "abc\r"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "abc\r" [String "abc\r"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc\"\r" [String "abc\r"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc" [String "abc"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "abc\"" [String "abc"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"\"\"" [String ""]
  >>=? fun () ->
  (* Bytes *)
  assert_tokenize ~loc:__LOC__ "0xabc" [Bytes "0xabc"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "0x" [Bytes "0x"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "0x1" [Bytes "0x1"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "xabc" [Bytes "xabc"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1xabc" [Bytes "1xabc"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1c" [Bytes "1c"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0c" [Bytes "0c"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0xx" [Bytes "0xx"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0b" [Bytes "0b"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0xg" [Bytes "0xg"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0X" [Bytes "0X"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1x" [Bytes "1x"]
  >>=? fun () ->
  (* Int *)
  assert_tokenize ~loc:__LOC__ "10" [Int "10"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "0" [Int "0"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "00" [Int "00"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "001" [Int "001"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "-0" [Int "0"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "-1" [Int "-1"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "1" [Int "1"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "-10" [Int "-10"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ ".1000" [Int ".1000"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "10_00" [Int "10_00"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1,000" [Int "1,000"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1000.000" [Int "1000.000"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "-0" [Int "-0"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "--0" [Int "0"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "+0" [Int "0"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "a" [Int "a"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0a" [Int "0a"]
  >>=? fun () ->
  (* Ident *)
  assert_tokenize ~loc:__LOC__ "string" [Ident "string"]
  >>=? fun () ->
  (* Annotation *)
  assert_tokenize ~loc:__LOC__ "@my_pair" [Annot "@my_pair"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "@@my_pair" [Annot "@@my_pair"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "$t" [Annot "$t"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "&t" [Annot "&t"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":t" [Annot ":t"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":_" [Annot ":_"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":0" [Annot ":0"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%" [Annot ":%"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%%" [Annot ":%%"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%@" [Annot ":%@"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%@_" [Annot ":%@_"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%@_0" [Annot ":%@_0"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%from" [Annot "%from"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%@from" [Annot "%@from"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%from_a" [Annot "%from_a"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%from.a" [Annot "%from.a"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%From.a" [Annot "%From.a"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%0From.a" [Annot "%0From.a"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "?t" [Annot "?t"]
  >>=? fun () ->
  (*fail*)
  assert_tokenize_error ~loc:__LOC__ "??t" [Annot "??t"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "&&t" [Annot "&&t"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "$$t" [Annot "$$t"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "_from" [Annot "_from"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ ".from" [Annot ".from"]
  >>=? fun () ->
  (*NOTE: the cases below fail because ':' is used in the middle of the
    annotation. *)
  assert_tokenize_error ~loc:__LOC__ "%:from" [Annot "%:from"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "%:@from" [Annot "%:@from"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "::t" [Annot "::t"]
  >>=? fun () ->
  (* Comment *)
  assert_tokenize ~loc:__LOC__ "/*\"/**/\"*/" [Comment "/*\"/**/\"*/"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "/* /* /* */ */ */" [Comment "/* /* /* */ */ */"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "/*parse 1" [Comment "/*parse 1"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "parse 1*/" [Comment "parse 1*/"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "/* */*/" [Comment "/* */*/"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "/*/* */" [Comment "/*/* */"]
  >>=? fun () ->
  (* EOL *)
  assert_tokenize ~loc:__LOC__ "#Access" [Eol_comment "#Access"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "##Access" [Eol_comment "##Access"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "?Access" [Eol_comment "?Access"]
  >>=? fun () ->
  (* SKIP *)
  assert_tokenize ~loc:__LOC__ ";" [Semi]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "{" [Open_brace]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "}" [Close_brace]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "(" [Open_paren]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ")" [Close_paren]
  >>=? fun () ->
  (*fail*)
  assert_tokenize_error ~loc:__LOC__ "{" [Semi]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ ";" [Open_brace]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "}" [Open_brace]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "(" [Close_paren]
  >>=? fun () -> assert_tokenize_error ~loc:__LOC__ ")" [Open_paren]

(*********************)
(* One line contracts *)

let test_one_line_contract () =
  assert_tokenize
    ~loc:__LOC__
    "(option int)"
    [Open_paren; Ident "option"; Ident "int"; Close_paren]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "DIP {ADD}"
    [Ident "DIP"; Open_brace; Ident "ADD"; Close_brace]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "parameter int;"
    [Ident "parameter"; Ident "int"; Semi]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "PUSH string \"abc\";"
    [Ident "PUSH"; Ident "string"; String "abc"; Semi]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "DROP; SWAP" [Ident "DROP"; Semi; Ident "SWAP"]
  >>=? fun () ->
  (* NOTE: the cases below do not fail because we only do tokenization. *)
  assert_tokenize ~loc:__LOC__ "DIP {ADD" [Ident "DIP"; Open_brace; Ident "ADD"]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "(option int"
    [Open_paren; Ident "option"; Ident "int"]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "parameter int}"
    [Ident "parameter"; Ident "int"; Close_brace]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "}{}{}{"
    [Close_brace; Open_brace; Close_brace; Open_brace; Close_brace; Open_brace]

(*********************************)
(* Conditional contracts *)

let test_condition_contract () =
  assert_tokenize
    ~loc:__LOC__
    "parameter (or string (option int));storage unit;return string;code \
     {CAR;IF_LEFT{}{IF_NONE {FAIL}{PUSH int 0; CMPGT; IF {FAIL}{PUSH string \
     \"\"}}};UNIT; SWAP; PAIR}"
    [ Ident "parameter";
      Open_paren;
      Ident "or";
      Ident "string";
      Open_paren;
      Ident "option";
      Ident "int";
      Close_paren;
      Close_paren;
      Semi;
      Ident "storage";
      Ident "unit";
      Semi;
      Ident "return";
      Ident "string";
      Semi;
      Ident "code";
      Open_brace;
      Ident "CAR";
      Semi;
      Ident "IF_LEFT";
      Open_brace;
      Close_brace;
      Open_brace;
      Ident "IF_NONE";
      Open_brace;
      Ident "FAIL";
      Close_brace;
      Open_brace;
      Ident "PUSH";
      Ident "int";
      Int "0";
      Semi;
      Ident "CMPGT";
      Semi;
      Ident "IF";
      Open_brace;
      Ident "FAIL";
      Close_brace;
      Open_brace;
      Ident "PUSH";
      Ident "string";
      String "";
      Close_brace;
      Close_brace;
      Close_brace;
      Semi;
      Ident "UNIT";
      Semi;
      Ident "SWAP";
      Semi;
      Ident "PAIR";
      Close_brace ]
  >>=? fun () ->
  (* NOTE: the cases below do not fail because we only do tokenization. *)
  assert_tokenize
    ~loc:__LOC__
    "parameter (or string (option int);"
    [ Ident "parameter";
      Open_paren;
      Ident "or";
      Ident "string";
      Open_paren;
      Ident "option";
      Ident "int";
      Close_paren;
      Semi ]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "parameter (or)"
    [Ident "parameter"; Open_paren; Ident "or"; Close_paren]
  >>=? fun () ->
  assert_tokenize_error
    ~loc:__LOC__
    "parameter (or"
    [Ident "parameter"; Open_paren; Ident "or"; Close_paren]

(****************************************************************************)
(* Top-level parsing tests *)
(****************************************************************************)

let assert_toplevel_parsing ~loc source expected =
  match Micheline_parser.tokenize source with
  | (_, _ :: _) ->
      failwith "%s - Cannot tokenize %s" loc source
  | (tokens, []) -> (
    match Micheline_parser.parse_toplevel tokens with
    | (_, _ :: _) ->
        failwith "%s - Cannot parse_toplevel %s" loc source
    | (ast, []) ->
        let ast = List.map Micheline.strip_locations ast in
        let expected = List.map Micheline.strip_locations expected in
        Assert.equal ~loc (List.length ast) (List.length expected)
        >>=? fun () ->
        iter2_p (Assert.equal ~loc) ast expected >>=? fun () -> return_unit )

let assert_toplevel_parsing_error ~loc source expected =
  match Micheline_parser.tokenize source with
  | (_, _ :: _) ->
      return_unit
  | (tokens, []) -> (
    match Micheline_parser.parse_toplevel tokens with
    | (_, _ :: _) ->
        return_unit
    | (ast, []) ->
        let ast = List.map Micheline.strip_locations ast in
        let expected = List.map Micheline.strip_locations expected in
        Assert.equal ~loc (List.length ast) (List.length expected)
        >>=? fun () -> iter2_p (Assert.not_equal ~loc) ast expected )

let test_basic_parsing () =
  assert_toplevel_parsing
    ~loc:__LOC__
    "parameter unit;"
    [Prim ((), "parameter", [Prim ((), "unit", [], [])], [])]
  >>=? fun () ->
  (* Sequence *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "code {}"
    [Prim ((), "code", [Seq ((), [])], [])]
  >>=? fun () ->
  (* Int *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "PUSH int 100"
    [Prim ((), "PUSH", [Prim ((), "int", [], []); Int ((), Z.of_int 100)], [])]
  >>=? fun () ->
  (*NOTE: this case doesn't fail because we don't type check *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "PUSH string 100"
    [ Prim
        ((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
    ]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "PUSH int 100_000"
    [ Prim
        ( (),
          "PUSH",
          [Prim ((), "string", [], []); Int ((), Z.of_int 100_000)],
          [] ) ]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "PUSH int 100"
    [Prim ((), "PUSH", [Prim ((), "int", [], []); Int ((), Z.of_int 1000)], [])]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "PUSH int 100"
    [ Prim
        ((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
    ]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "PUSH int \"100\""
    [ Prim
        ((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
    ]
  >>=? fun () ->
  (* String *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "Pair False \"abc\""
    [Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "Pair False \"ab\""
    [Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "Pair False abc\""
    [Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
  >>=? fun () ->
  (* annotations *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "NIL @annot string; #comment\n"
    [Prim ((), "NIL", [Prim ((), "string", [], [])], ["@annot"])]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "NIL @annot string; #comment\n"
    [Prim ((), "NIL", [Prim ((), "string", [], [])], [])]
  >>=? fun () ->
  assert_toplevel_parsing
    ~loc:__LOC__
    "IF_NONE {FAIL} {}"
    [ Prim
        ( (),
          "IF_NONE",
          [Seq ((), [Prim ((), "FAIL", [], [])]); Seq ((), [])],
          [] ) ]
  >>=? fun () ->
  assert_toplevel_parsing
    ~loc:__LOC__
    "PUSH (map int bool) (Map (Item 100 False))"
    [ Prim
        ( (),
          "PUSH",
          [ Prim
              ( (),
                "map",
                [Prim ((), "int", [], []); Prim ((), "bool", [], [])],
                [] );
            Prim
              ( (),
                "Map",
                [ Prim
                    ( (),
                      "Item",
                      [Int ((), Z.of_int 100); Prim ((), "False", [], [])],
                      [] ) ],
                [] ) ],
          [] ) ]
  >>=? fun () ->
  assert_toplevel_parsing
    ~loc:__LOC__
    "LAMDA @name int int {}"
    [ Prim
        ( (),
          "LAMDA",
          [Prim ((), "int", [], []); Prim ((), "int", [], []); Seq ((), [])],
          ["@name"] ) ]
  >>=? fun () ->
  assert_toplevel_parsing
    ~loc:__LOC__
    "code {DUP @test; DROP}"
    [ Prim
        ( (),
          "code",
          [ Seq
              ((), [Prim ((), "DUP", [], ["@test"]); Prim ((), "DROP", [], [])])
          ],
          [] ) ]

let test_condition_contract_parsing () =
  assert_toplevel_parsing
    ~loc:__LOC__
    "parameter unit;return unit;storage tez; #How much you have to send me \n\
     code {CDR; DUP;AMOUNT; CMPLT;IF {FAIL}}"
    [ Prim ((), "parameter", [Prim ((), "unit", [], [])], []);
      Prim ((), "return", [Prim ((), "unit", [], [])], []);
      Prim ((), "storage", [Prim ((), "tez", [], [])], []);
      Prim
        ( (),
          "code",
          [ Seq
              ( (),
                [ Prim ((), "CDR", [], []);
                  Prim ((), "DUP", [], []);
                  Prim ((), "AMOUNT", [], []);
                  Prim ((), "CMPLT", [], []);
                  Prim ((), "IF", [Seq ((), [Prim ((), "FAIL", [], [])])], [])
                ] ) ],
          [] ) ]

let test_list_append_parsing () =
  assert_toplevel_parsing
    ~loc:__LOC__
    "parameter (pair (list int)(list int));return (list int);storage \
     unit;code { CAR; DUP; DIP{CDR}; CAR;NIL int; SWAP;LAMDA (pair int (list \
     int))(list int){DUP; CAR; DIP {CDR}; CONS};REDUCE;LAMDA (pair int (list \
     int))(list int){DUP; CAR; DIP{CDR}; CONS};UNIT; SWAP; PAIR}"
    [ Prim
        ( (),
          "parameter",
          [ Prim
              ( (),
                "pair",
                [ Prim ((), "list", [Prim ((), "int", [], [])], []);
                  Prim ((), "list", [Prim ((), "int", [], [])], []) ],
                [] ) ],
          [] );
      Prim
        ((), "return", [Prim ((), "list", [Prim ((), "int", [], [])], [])], []);
      Prim ((), "storage", [Prim ((), "unit", [], [])], []);
      Prim
        ( (),
          "code",
          [ Seq
              ( (),
                [ Prim ((), "CAR", [], []);
                  Prim ((), "DUP", [], []);
                  Prim ((), "DIP", [Seq ((), [Prim ((), "CDR", [], [])])], []);
                  Prim ((), "CAR", [], []);
                  Prim ((), "NIL", [Prim ((), "int", [], [])], []);
                  Prim ((), "SWAP", [], []);
                  Prim
                    ( (),
                      "LAMDA",
                      [ Prim
                          ( (),
                            "pair",
                            [ Prim ((), "int", [], []);
                              Prim ((), "list", [Prim ((), "int", [], [])], [])
                            ],
                            [] );
                        Prim ((), "list", [Prim ((), "int", [], [])], []);
                        Seq
                          ( (),
                            [ Prim ((), "DUP", [], []);
                              Prim ((), "CAR", [], []);
                              Prim
                                ( (),
                                  "DIP",
                                  [Seq ((), [Prim ((), "CDR", [], [])])],
                                  [] );
                              Prim ((), "CONS", [], []) ] ) ],
                      [] );
                  Prim ((), "REDUCE", [], []);
                  Prim
                    ( (),
                      "LAMDA",
                      [ Prim
                          ( (),
                            "pair",
                            [ Prim ((), "int", [], []);
                              Prim ((), "list", [Prim ((), "int", [], [])], [])
                            ],
                            [] );
                        Prim ((), "list", [Prim ((), "int", [], [])], []);
                        Seq
                          ( (),
                            [ Prim ((), "DUP", [], []);
                              Prim ((), "CAR", [], []);
                              Prim
                                ( (),
                                  "DIP",
                                  [Seq ((), [Prim ((), "CDR", [], [])])],
                                  [] );
                              Prim ((), "CONS", [], []) ] ) ],
                      [] );
                  Prim ((), "UNIT", [], []);
                  Prim ((), "SWAP", [], []);
                  Prim ((), "PAIR", [], []) ] ) ],
          [] ) ]

(****************************************************************************)
(* Expression parsing tests *)
(****************************************************************************)

let assert_expression_parsing ~loc source expected =
  match Micheline_parser.tokenize source with
  | (_, _ :: _) ->
      failwith "%s - Cannot tokenize %s" loc source
  | (tokens, []) -> (
    match Micheline_parser.parse_expression tokens with
    | (_, _ :: _) ->
        failwith "%s - Cannot parse_expression %s" loc source
    | (ast, []) ->
        let ast = Micheline.strip_locations ast in
        let expected = Micheline.strip_locations expected in
        Assert.equal ~loc ast expected )

let test_parses_expression () =
  (* String *)
  assert_expression_parsing
    ~loc:__LOC__
    "Pair False \"abc\""
    (Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], []))
  >>=? fun () ->
  (* Int *)
  assert_expression_parsing
    ~loc:__LOC__
    "Item 100"
    (Prim ((), "Item", [Int ((), Z.of_int 100)], []))
  >>=? fun () ->
  (* Sequence *)
  assert_expression_parsing ~loc:__LOC__ "{}" (Seq ((), []))

(****************************************************************************)

let tests =
  [ ("tokenize", fun _ -> test_tokenize_basic ());
    ("test one line contract", fun _ -> test_one_line_contract ());
    ("test_condition_contract", fun _ -> test_condition_contract ());
    ("test_basic_parsing", fun _ -> test_basic_parsing ());
    ( "test_condition_contract_parsing",
      fun _ -> test_condition_contract_parsing () );
    ("test_list_append_parsing", fun _ -> test_list_append_parsing ());
    ("test_parses_expression", fun _ -> test_parses_expression ()) ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      f ()
      >>= function Ok () -> Lwt.return_unit | Error err -> Lwt.fail_with err)

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-lib-micheline"
    [("micheline", List.map wrap tests)]
src/lib_micheline/test/test_parser.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition assert_tokenize {A B C : Type}
  (loc : A) (given : string) (expected : B) : C :=
  match Tezos_micheline.Micheline_parser.tokenize given with
  | (tokens, []) =>
    let tokens_got := List.map (fun x => Micheline_parser.token x) tokens in
    op_star_t_y_p_e_minus_e_r_r_o_r_star loc tokens_got expected
  | (_, _) => OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc given
  end.

Definition assert_tokenize_error {A B C : Type}
  (loc : A) (given : string) (expected : B) : C :=
  match Tezos_micheline.Micheline_parser.tokenize given with
  | (tokens, []) =>
    let tokens_got := List.map (fun x => Micheline_parser.token x) tokens in
    op_star_t_y_p_e_minus_e_r_r_o_r_star loc tokens_got expected
  | (_, _) => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_tokenize_basic {A : Type} (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (assert_tokenize Stdlib.__LOC__ """abc""" % string
        (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (assert_tokenize Stdlib.__LOC__ """abc	""" % string
              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (assert_tokenize Stdlib.__LOC__ """abc""" % string
                    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (assert_tokenize Stdlib.__LOC__ """abc\n""" % string
                          (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (assert_tokenize Stdlib.__LOC__
                                """abc\r""" % string
                                (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (assert_tokenize_error Stdlib.__LOC__
                                      """abc
""" % string
                                      (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        []))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (assert_tokenize_error Stdlib.__LOC__
                                            """abc\""" % string
                                            (cons
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              []))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (assert_tokenize_error
                                                  Stdlib.__LOC__
                                                  """abc""" % string
                                                  (cons
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    []))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (assert_tokenize_error
                                                        Stdlib.__LOC__
                                                        """abc
""" % string
                                                        (cons
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          []))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (assert_tokenize_error
                                                              Stdlib.__LOC__
                                                              "abc
" % string
                                                              (cons
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                []))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  (assert_tokenize_error
                                                                    Stdlib.__LOC__
                                                                    """abc""
" %
                                                                      string
                                                                    (cons
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      []))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | tt =>
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        (assert_tokenize_error
                                                                          Stdlib.__LOC__
                                                                          """abc"
                                                                            %
                                                                            string
                                                                          (cons
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            []))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | tt
                                                                            =>
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              (assert_tokenize_error
                                                                                Stdlib.__LOC__
                                                                                "abc"""
                                                                                  %
                                                                                  string
                                                                                (cons
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  []))
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  tt
                                                                                  =>
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    (assert_tokenize_error
                                                                                      Stdlib.__LOC__
                                                                                      """"""""
                                                                                        %
                                                                                        string
                                                                                      (cons
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        []))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        tt
                                                                                        =>
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          (assert_tokenize
                                                                                            Stdlib.__LOC__
                                                                                            "0xabc"
                                                                                              %
                                                                                              string
                                                                                            (cons
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              []))
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            match
                                                                                              function_parameter
                                                                                              with
                                                                                            |
                                                                                              tt
                                                                                              =>
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                (assert_tokenize
                                                                                                  Stdlib.__LOC__
                                                                                                  "0x"
                                                                                                    %
                                                                                                    string
                                                                                                  (cons
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    []))
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  match
                                                                                                    function_parameter
                                                                                                    with
                                                                                                  |
                                                                                                    tt
                                                                                                    =>
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      (assert_tokenize
                                                                                                        Stdlib.__LOC__
                                                                                                        "0x1"
                                                                                                          %
                                                                                                          string
                                                                                                        (cons
                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          []))
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        match
                                                                                                          function_parameter
                                                                                                          with
                                                                                                        |
                                                                                                          tt
                                                                                                          =>
                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            (assert_tokenize_error
                                                                                                              Stdlib.__LOC__
                                                                                                              "xabc"
                                                                                                                %
                                                                                                                string
                                                                                                              (cons
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                []))
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              match
                                                                                                                function_parameter
                                                                                                                with
                                                                                                              |
                                                                                                                tt
                                                                                                                =>
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                  (assert_tokenize_error
                                                                                                                    Stdlib.__LOC__
                                                                                                                    "1xabc"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    (cons
                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                      []))
                                                                                                                  (fun
                                                                                                                    function_parameter
                                                                                                                    =>
                                                                                                                    match
                                                                                                                      function_parameter
                                                                                                                      with
                                                                                                                    |
                                                                                                                      tt
                                                                                                                      =>
                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                        (assert_tokenize_error
                                                                                                                          Stdlib.__LOC__
                                                                                                                          "1c"
                                                                                                                            %
                                                                                                                            string
                                                                                                                          (cons
                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                            []))
                                                                                                                        (fun
                                                                                                                          function_parameter
                                                                                                                          =>
                                                                                                                          match
                                                                                                                            function_parameter
                                                                                                                            with
                                                                                                                          |
                                                                                                                            tt
                                                                                                                            =>
                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              (assert_tokenize_error
                                                                                                                                Stdlib.__LOC__
                                                                                                                                "0c"
                                                                                                                                  %
                                                                                                                                  string
                                                                                                                                (cons
                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  []))
                                                                                                                              (fun
                                                                                                                                function_parameter
                                                                                                                                =>
                                                                                                                                match
                                                                                                                                  function_parameter
                                                                                                                                  with
                                                                                                                                |
                                                                                                                                  tt
                                                                                                                                  =>
                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    (assert_tokenize_error
                                                                                                                                      Stdlib.__LOC__
                                                                                                                                      "0xx"
                                                                                                                                        %
                                                                                                                                        string
                                                                                                                                      (cons
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                        []))
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      match
                                                                                                                                        function_parameter
                                                                                                                                        with
                                                                                                                                      |
                                                                                                                                        tt
                                                                                                                                        =>
                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          (assert_tokenize_error
                                                                                                                                            Stdlib.__LOC__
                                                                                                                                            "0b"
                                                                                                                                              %
                                                                                                                                              string
                                                                                                                                            (cons
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              []))
                                                                                                                                          (fun
                                                                                                                                            function_parameter
                                                                                                                                            =>
                                                                                                                                            match
                                                                                                                                              function_parameter
                                                                                                                                              with
                                                                                                                                            |
                                                                                                                                              tt
                                                                                                                                              =>
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                (assert_tokenize_error
                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                  "0xg"
                                                                                                                                                    %
                                                                                                                                                    string
                                                                                                                                                  (cons
                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                    []))
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  match
                                                                                                                                                    function_parameter
                                                                                                                                                    with
                                                                                                                                                  |
                                                                                                                                                    tt
                                                                                                                                                    =>
                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      (assert_tokenize_error
                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                        "0X"
                                                                                                                                                          %
                                                                                                                                                          string
                                                                                                                                                        (cons
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                          []))
                                                                                                                                                      (fun
                                                                                                                                                        function_parameter
                                                                                                                                                        =>
                                                                                                                                                        match
                                                                                                                                                          function_parameter
                                                                                                                                                          with
                                                                                                                                                        |
                                                                                                                                                          tt
                                                                                                                                                          =>
                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                              "1x"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              (cons
                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                []))
                                                                                                                                                            (fun
                                                                                                                                                              function_parameter
                                                                                                                                                              =>
                                                                                                                                                              match
                                                                                                                                                                function_parameter
                                                                                                                                                                with
                                                                                                                                                              |
                                                                                                                                                                tt
                                                                                                                                                                =>
                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  (assert_tokenize
                                                                                                                                                                    Stdlib.__LOC__
                                                                                                                                                                    "10"
                                                                                                                                                                      %
                                                                                                                                                                      string
                                                                                                                                                                    (cons
                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                      []))
                                                                                                                                                                  (fun
                                                                                                                                                                    function_parameter
                                                                                                                                                                    =>
                                                                                                                                                                    match
                                                                                                                                                                      function_parameter
                                                                                                                                                                      with
                                                                                                                                                                    |
                                                                                                                                                                      tt
                                                                                                                                                                      =>
                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                          "0"
                                                                                                                                                                            %
                                                                                                                                                                            string
                                                                                                                                                                          (cons
                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                            []))
                                                                                                                                                                        (fun
                                                                                                                                                                          function_parameter
                                                                                                                                                                          =>
                                                                                                                                                                          match
                                                                                                                                                                            function_parameter
                                                                                                                                                                            with
                                                                                                                                                                          |
                                                                                                                                                                            tt
                                                                                                                                                                            =>
                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                              (assert_tokenize
                                                                                                                                                                                Stdlib.__LOC__
                                                                                                                                                                                "00"
                                                                                                                                                                                  %
                                                                                                                                                                                  string
                                                                                                                                                                                (cons
                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                  []))
                                                                                                                                                                              (fun
                                                                                                                                                                                function_parameter
                                                                                                                                                                                =>
                                                                                                                                                                                match
                                                                                                                                                                                  function_parameter
                                                                                                                                                                                  with
                                                                                                                                                                                |
                                                                                                                                                                                  tt
                                                                                                                                                                                  =>
                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                      "001"
                                                                                                                                                                                        %
                                                                                                                                                                                        string
                                                                                                                                                                                      (cons
                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                        []))
                                                                                                                                                                                    (fun
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      =>
                                                                                                                                                                                      match
                                                                                                                                                                                        function_parameter
                                                                                                                                                                                        with
                                                                                                                                                                                      |
                                                                                                                                                                                        tt
                                                                                                                                                                                        =>
                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                          (assert_tokenize
                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                            "-0"
                                                                                                                                                                                              %
                                                                                                                                                                                              string
                                                                                                                                                                                            (cons
                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                              []))
                                                                                                                                                                                          (fun
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            =>
                                                                                                                                                                                            match
                                                                                                                                                                                              function_parameter
                                                                                                                                                                                              with
                                                                                                                                                                                            |
                                                                                                                                                                                              tt
                                                                                                                                                                                              =>
                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                  "-1"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string
                                                                                                                                                                                                  (cons
                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                    []))
                                                                                                                                                                                                (fun
                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                  =>
                                                                                                                                                                                                  match
                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                    with
                                                                                                                                                                                                  |
                                                                                                                                                                                                    tt
                                                                                                                                                                                                    =>
                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                      (assert_tokenize
                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                        "1"
                                                                                                                                                                                                          %
                                                                                                                                                                                                          string
                                                                                                                                                                                                        (cons
                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                          []))
                                                                                                                                                                                                      (fun
                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                        =>
                                                                                                                                                                                                        match
                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                          with
                                                                                                                                                                                                        |
                                                                                                                                                                                                          tt
                                                                                                                                                                                                          =>
                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                              "-10"
                                                                                                                                                                                                                %
                                                                                                                                                                                                                string
                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                []))
                                                                                                                                                                                                            (fun
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              match
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                with
                                                                                                                                                                                                              |
                                                                                                                                                                                                                tt
                                                                                                                                                                                                                =>
                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                  (assert_tokenize_error
                                                                                                                                                                                                                    Stdlib.__LOC__
                                                                                                                                                                                                                    ".1000"
                                                                                                                                                                                                                      %
                                                                                                                                                                                                                      string
                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                      []))
                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                    match
                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                      with
                                                                                                                                                                                                                    |
                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                          "10_00"
                                                                                                                                                                                                                            %
                                                                                                                                                                                                                            string
                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          match
                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                            with
                                                                                                                                                                                                                          |
                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                              (assert_tokenize_error
                                                                                                                                                                                                                                Stdlib.__LOC__
                                                                                                                                                                                                                                "1,000"
                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                  []))
                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                      "1000.000"
                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                          (assert_tokenize_error
                                                                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                                                                            "-0"
                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                              []))
                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                              tt
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                  "--0"
                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                      (assert_tokenize_error
                                                                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                                                                        "+0"
                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                          []))
                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                              "a"
                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                  (assert_tokenize_error
                                                                                                                                                                                                                                                                    Stdlib.__LOC__
                                                                                                                                                                                                                                                                    "0a"
                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                      []))
                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                          "string"
                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                              (assert_tokenize
                                                                                                                                                                                                                                                                                Stdlib.__LOC__
                                                                                                                                                                                                                                                                                "@my_pair"
                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                  []))
                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                      "@@my_pair"
                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                          (assert_tokenize
                                                                                                                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                                                                                                                            "$t"
                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                              []))
                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                              tt
                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                  "&t"
                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                      (assert_tokenize
                                                                                                                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                        ":t"
                                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                          []))
                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                              ":_"
                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                  (assert_tokenize
                                                                                                                                                                                                                                                                                                                    Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                    ":0"
                                                                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                      []))
                                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                          ":%"
                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                              (assert_tokenize
                                                                                                                                                                                                                                                                                                                                Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                ":%%"
                                                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                  []))
                                                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                      ":%@"
                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                          (assert_tokenize
                                                                                                                                                                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                            ":%@_"
                                                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                              []))
                                                                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                                                              tt
                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                  ":%@_0"
                                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                      (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                        "%from"
                                                                                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                          []))
                                                                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                              "%@from"
                                                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                  (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                    Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                    "%from_a"
                                                                                                                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                      []))
                                                                                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                          "%from.a"
                                                                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                              (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                "%From.a"
                                                                                                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                  []))
                                                                                                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                      "%0From.a"
                                                                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                          (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                            "?t"
                                                                                                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                              []))
                                                                                                                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                                                                                                              tt
                                                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                  "??t"
                                                                                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                      (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                        "&&t"
                                                                                                                                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                          []))
                                                                                                                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                              "$$t"
                                                                                                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                  (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                    Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                    "_from"
                                                                                                                                                                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                      []))
                                                                                                                                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                          ".from"
                                                                                                                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                              (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                "%:from"
                                                                                                                                                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                  []))
                                                                                                                                                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                      "%:@from"
                                                                                                                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                          (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                            "::t"
                                                                                                                                                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                              []))
                                                                                                                                                                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                                                                                                                                                              tt
                                                                                                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                  "/*""/**/""*/"
                                                                                                                                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                      (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                        "/* /* /* */ */ */"
                                                                                                                                                                                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                          []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                              "/*parse 1"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                  (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                    Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                    "parse 1*/"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          "/* */*/"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                              (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                "/*/* */"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      "#Access"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            "##Access"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  "?Access"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        ";"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              "{"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    "}"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          "("
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ")"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      "{"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            ";"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  "}"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        "("
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          []))
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            ")"
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              [])
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                            end)
                                                                                                                                                                                                                                      end)
                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                          end)
                                                                                                                                                                                                                    end)
                                                                                                                                                                                                              end)
                                                                                                                                                                                                        end)
                                                                                                                                                                                                  end)
                                                                                                                                                                                            end)
                                                                                                                                                                                      end)
                                                                                                                                                                                end)
                                                                                                                                                                          end)
                                                                                                                                                                    end)
                                                                                                                                                              end)
                                                                                                                                                        end)
                                                                                                                                                  end)
                                                                                                                                            end)
                                                                                                                                      end)
                                                                                                                                end)
                                                                                                                          end)
                                                                                                                    end)
                                                                                                              end)
                                                                                                        end)
                                                                                                  end)
                                                                                            end)
                                                                                      end)
                                                                                end)
                                                                          end)
                                                                    end)
                                                              end)
                                                        end)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition test_one_line_contract {A : Type} (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (assert_tokenize Stdlib.__LOC__ "(option int)" % string
        (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
          (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
            (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star [])))))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (assert_tokenize Stdlib.__LOC__ "DIP {ADD}" % string
              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star [])))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (assert_tokenize Stdlib.__LOC__ "parameter int;" % string
                    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (assert_tokenize Stdlib.__LOC__
                          "PUSH string ""abc"";" % string
                          (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (cons op_star_t_y_p_e_minus_e_r_r_o_r_star [])))))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (assert_tokenize Stdlib.__LOC__
                                "DROP; SWAP" % string
                                (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      []))))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (assert_tokenize Stdlib.__LOC__
                                      "DIP {ADD" % string
                                      (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (cons
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (cons
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            []))))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (assert_tokenize Stdlib.__LOC__
                                            "(option int" % string
                                            (cons
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (cons
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (cons
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  []))))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (assert_tokenize Stdlib.__LOC__
                                                  "parameter int}" % string
                                                  (cons
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    (cons
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (cons
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        []))))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    assert_tokenize
                                                      Stdlib.__LOC__
                                                      "}{}{}{" % string
                                                      (cons
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (cons
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (cons
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (cons
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (cons
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (cons
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  []))))))
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition test_condition_contract {A : Type} (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (assert_tokenize Stdlib.__LOC__
        "parameter (or string (option int));storage unit;return string;code {CAR;IF_LEFT{}{IF_NONE {FAIL}{PUSH int 0; CMPGT; IF {FAIL}{PUSH string """"}}};UNIT; SWAP; PAIR}"
          % string
        (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
          (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
            (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (cons
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (cons
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (cons
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (cons
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (cons
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (cons
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    (cons
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (cons
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (cons
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (cons
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (cons
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (cons
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (cons
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  (cons
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    (cons
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (cons
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        (cons
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          (cons
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            (cons
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              (cons
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                (cons
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  (cons
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    (cons
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      (cons
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        (cons
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          (cons
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            (cons
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (cons
                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                (cons
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  (cons
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (cons
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      (cons
                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        (cons
                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                          (cons
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            (cons
                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              (cons
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                (cons
                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                  []))))))))))))))))))))))))))))))))))))))))))))))))))))))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (assert_tokenize Stdlib.__LOC__
              "parameter (or string (option int);" % string
              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []))))))))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (assert_tokenize Stdlib.__LOC__ "parameter (or)" % string
                    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (cons op_star_t_y_p_e_minus_e_r_r_o_r_star [])))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      assert_tokenize_error Stdlib.__LOC__
                        "parameter (or" % string
                        (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []))))
                    end)
              end)
        end)
  end.

Definition assert_toplevel_parsing {A B C D : Type}
  (loc : A) (source : string)
  (expected : list (Tezos_micheline.Micheline.node B C)) : D :=
  match Tezos_micheline.Micheline_parser.tokenize source with
  | (_, cons _ _) =>
    OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc source
  | (tokens, []) =>
    match Tezos_micheline.Micheline_parser.parse_toplevel None tokens with
    | (_, cons _ _) =>
      OCaml.Stdlib.failwith "%s - Cannot parse_toplevel %s" % string loc source
    | (ast, []) =>
      let ast := List.map Tezos_micheline.Micheline.strip_locations ast in
      let expected :=
        List.map Tezos_micheline.Micheline.strip_locations expected in
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star loc (OCaml.List.length ast)
          (OCaml.List.length expected))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star loc) ast expected)
              (fun function_parameter =>
                match function_parameter with
                | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
                end)
          end)
    end
  end.

Definition assert_toplevel_parsing_error {A B C D : Type}
  (loc : A) (source : string)
  (expected : list (Tezos_micheline.Micheline.node B C)) : D :=
  match Tezos_micheline.Micheline_parser.tokenize source with
  | (_, cons _ _) => op_star_t_y_p_e_minus_e_r_r_o_r_star
  | (tokens, []) =>
    match Tezos_micheline.Micheline_parser.parse_toplevel None tokens with
    | (_, cons _ _) => op_star_t_y_p_e_minus_e_r_r_o_r_star
    | (ast, []) =>
      let ast := List.map Tezos_micheline.Micheline.strip_locations ast in
      let expected :=
        List.map Tezos_micheline.Micheline.strip_locations expected in
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star loc (OCaml.List.length ast)
          (OCaml.List.length expected))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (op_star_t_y_p_e_minus_e_r_r_o_r_star loc) ast expected
          end)
    end
  end.

Definition test_basic_parsing {A : Type} (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (assert_toplevel_parsing Stdlib.__LOC__ "parameter unit;" % string
        (cons
          (Prim tt "parameter" % string
            (cons (Prim tt "unit" % string [] []) []) []) []))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (assert_toplevel_parsing Stdlib.__LOC__ "code {}" % string
              (cons (Prim tt "code" % string (cons (Seq tt []) []) []) []))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (assert_toplevel_parsing Stdlib.__LOC__
                    "PUSH int 100" % string
                    (cons
                      (Prim tt "PUSH" % string
                        (cons (Prim tt "int" % string [] [])
                          (cons (Int tt (Z.of_int 100)) [])) []) []))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (assert_toplevel_parsing Stdlib.__LOC__
                          "PUSH string 100" % string
                          (cons
                            (Prim tt "PUSH" % string
                              (cons (Prim tt "string" % string [] [])
                                (cons (Int tt (Z.of_int 100)) [])) []) []))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (assert_toplevel_parsing_error Stdlib.__LOC__
                                "PUSH int 100_000" % string
                                (cons
                                  (Prim tt "PUSH" % string
                                    (cons (Prim tt "string" % string [] [])
                                      (cons (Int tt (Z.of_int 100000)) [])) [])
                                  []))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (assert_toplevel_parsing_error
                                      Stdlib.__LOC__ "PUSH int 100" % string
                                      (cons
                                        (Prim tt "PUSH" % string
                                          (cons (Prim tt "int" % string [] [])
                                            (cons (Int tt (Z.of_int 1000)) []))
                                          []) []))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (assert_toplevel_parsing_error
                                            Stdlib.__LOC__
                                            "PUSH int 100" % string
                                            (cons
                                              (Prim tt "PUSH" % string
                                                (cons
                                                  (Prim tt "string" % string []
                                                    [])
                                                  (cons (Int tt (Z.of_int 100))
                                                    [])) []) []))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (assert_toplevel_parsing_error
                                                  Stdlib.__LOC__
                                                  "PUSH int ""100""" % string
                                                  (cons
                                                    (Prim tt "PUSH" % string
                                                      (cons
                                                        (Prim tt
                                                          "string" % string []
                                                          [])
                                                        (cons
                                                          (Int tt (Z.of_int 100))
                                                          [])) []) []))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (assert_toplevel_parsing
                                                        Stdlib.__LOC__
                                                        "Pair False ""abc""" %
                                                          string
                                                        (cons
                                                          (Prim tt
                                                            "Pair" % string
                                                            (cons
                                                              (Prim tt
                                                                "False" % string
                                                                [] [])
                                                              (cons
                                                                (String tt
                                                                  "abc" % string)
                                                                [])) []) []))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (assert_toplevel_parsing_error
                                                              Stdlib.__LOC__
                                                              "Pair False ""ab"""
                                                                % string
                                                              (cons
                                                                (Prim tt
                                                                  "Pair" %
                                                                    string
                                                                  (cons
                                                                    (Prim tt
                                                                      "False" %
                                                                        string
                                                                      [] [])
                                                                    (cons
                                                                      (String tt
                                                                        "abc" %
                                                                          string)
                                                                      [])) [])
                                                                []))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  (assert_toplevel_parsing_error
                                                                    Stdlib.__LOC__
                                                                    "Pair False abc"""
                                                                      % string
                                                                    (cons
                                                                      (Prim tt
                                                                        "Pair" %
                                                                          string
                                                                        (cons
                                                                          (Prim
                                                                            tt
                                                                            "False"
                                                                              %
                                                                              string
                                                                            []
                                                                            [])
                                                                          (cons
                                                                            (String
                                                                              tt
                                                                              "abc"
                                                                                %
                                                                                string)
                                                                            []))
                                                                        []) []))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | tt =>
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        (assert_toplevel_parsing
                                                                          Stdlib.__LOC__
                                                                          "NIL @annot string; #comment
"
                                                                            %
                                                                            string
                                                                          (cons
                                                                            (Prim
                                                                              tt
                                                                              "NIL"
                                                                                %
                                                                                string
                                                                              (cons
                                                                                (Prim
                                                                                  tt
                                                                                  "string"
                                                                                    %
                                                                                    string
                                                                                  []
                                                                                  [])
                                                                                [])
                                                                              (cons
                                                                                "@annot"
                                                                                  %
                                                                                  string
                                                                                []))
                                                                            []))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | tt
                                                                            =>
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              (assert_toplevel_parsing_error
                                                                                Stdlib.__LOC__
                                                                                "NIL @annot string; #comment
"
                                                                                  %
                                                                                  string
                                                                                (cons
                                                                                  (Prim
                                                                                    tt
                                                                                    "NIL"
                                                                                      %
                                                                                      string
                                                                                    (cons
                                                                                      (Prim
                                                                                        tt
                                                                                        "string"
                                                                                          %
                                                                                          string
                                                                                        []
                                                                                        [])
                                                                                      [])
                                                                                    [])
                                                                                  []))
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  tt
                                                                                  =>
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    (assert_toplevel_parsing
                                                                                      Stdlib.__LOC__
                                                                                      "IF_NONE {FAIL} {}"
                                                                                        %
                                                                                        string
                                                                                      (cons
                                                                                        (Prim
                                                                                          tt
                                                                                          "IF_NONE"
                                                                                            %
                                                                                            string
                                                                                          (cons
                                                                                            (Seq
                                                                                              tt
                                                                                              (cons
                                                                                                (Prim
                                                                                                  tt
                                                                                                  "FAIL"
                                                                                                    %
                                                                                                    string
                                                                                                  []
                                                                                                  [])
                                                                                                []))
                                                                                            (cons
                                                                                              (Seq
                                                                                                tt
                                                                                                [])
                                                                                              []))
                                                                                          [])
                                                                                        []))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        tt
                                                                                        =>
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          (assert_toplevel_parsing
                                                                                            Stdlib.__LOC__
                                                                                            "PUSH (map int bool) (Map (Item 100 False))"
                                                                                              %
                                                                                              string
                                                                                            (cons
                                                                                              (Prim
                                                                                                tt
                                                                                                "PUSH"
                                                                                                  %
                                                                                                  string
                                                                                                (cons
                                                                                                  (Prim
                                                                                                    tt
                                                                                                    "map"
                                                                                                      %
                                                                                                      string
                                                                                                    (cons
                                                                                                      (Prim
                                                                                                        tt
                                                                                                        "int"
                                                                                                          %
                                                                                                          string
                                                                                                        []
                                                                                                        [])
                                                                                                      (cons
                                                                                                        (Prim
                                                                                                          tt
                                                                                                          "bool"
                                                                                                            %
                                                                                                            string
                                                                                                          []
                                                                                                          [])
                                                                                                        []))
                                                                                                    [])
                                                                                                  (cons
                                                                                                    (Prim
                                                                                                      tt
                                                                                                      "Map"
                                                                                                        %
                                                                                                        string
                                                                                                      (cons
                                                                                                        (Prim
                                                                                                          tt
                                                                                                          "Item"
                                                                                                            %
                                                                                                            string
                                                                                                          (cons
                                                                                                            (Int
                                                                                                              tt
                                                                                                              (Z.of_int
                                                                                                                100))
                                                                                                            (cons
                                                                                                              (Prim
                                                                                                                tt
                                                                                                                "False"
                                                                                                                  %
                                                                                                                  string
                                                                                                                []
                                                                                                                [])
                                                                                                              []))
                                                                                                          [])
                                                                                                        [])
                                                                                                      [])
                                                                                                    []))
                                                                                                [])
                                                                                              []))
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            match
                                                                                              function_parameter
                                                                                              with
                                                                                            |
                                                                                              tt
                                                                                              =>
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                (assert_toplevel_parsing
                                                                                                  Stdlib.__LOC__
                                                                                                  "LAMDA @name int int {}"
                                                                                                    %
                                                                                                    string
                                                                                                  (cons
                                                                                                    (Prim
                                                                                                      tt
                                                                                                      "LAMDA"
                                                                                                        %
                                                                                                        string
                                                                                                      (cons
                                                                                                        (Prim
                                                                                                          tt
                                                                                                          "int"
                                                                                                            %
                                                                                                            string
                                                                                                          []
                                                                                                          [])
                                                                                                        (cons
                                                                                                          (Prim
                                                                                                            tt
                                                                                                            "int"
                                                                                                              %
                                                                                                              string
                                                                                                            []
                                                                                                            [])
                                                                                                          (cons
                                                                                                            (Seq
                                                                                                              tt
                                                                                                              [])
                                                                                                            [])))
                                                                                                      (cons
                                                                                                        "@name"
                                                                                                          %
                                                                                                          string
                                                                                                        []))
                                                                                                    []))
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  match
                                                                                                    function_parameter
                                                                                                    with
                                                                                                  |
                                                                                                    tt
                                                                                                    =>
                                                                                                    assert_toplevel_parsing
                                                                                                      Stdlib.__LOC__
                                                                                                      "code {DUP @test; DROP}"
                                                                                                        %
                                                                                                        string
                                                                                                      (cons
                                                                                                        (Prim
                                                                                                          tt
                                                                                                          "code"
                                                                                                            %
                                                                                                            string
                                                                                                          (cons
                                                                                                            (Seq
                                                                                                              tt
                                                                                                              (cons
                                                                                                                (Prim
                                                                                                                  tt
                                                                                                                  "DUP"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  []
                                                                                                                  (cons
                                                                                                                    "@test"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    []))
                                                                                                                (cons
                                                                                                                  (Prim
                                                                                                                    tt
                                                                                                                    "DROP"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    []
                                                                                                                    [])
                                                                                                                  [])))
                                                                                                            [])
                                                                                                          [])
                                                                                                        [])
                                                                                                  end)
                                                                                            end)
                                                                                      end)
                                                                                end)
                                                                          end)
                                                                    end)
                                                              end)
                                                        end)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition test_condition_contract_parsing {A : Type}
  (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    assert_toplevel_parsing Stdlib.__LOC__
      "parameter unit;return unit;storage tez; #How much you have to send me 
code {CDR; DUP;AMOUNT; CMPLT;IF {FAIL}}"
        % string
      (cons
        (Prim tt "parameter" % string (cons (Prim tt "unit" % string [] []) [])
          [])
        (cons
          (Prim tt "return" % string (cons (Prim tt "unit" % string [] []) [])
            [])
          (cons
            (Prim tt "storage" % string (cons (Prim tt "tez" % string [] []) [])
              [])
            (cons
              (Prim tt "code" % string
                (cons
                  (Seq tt
                    (cons (Prim tt "CDR" % string [] [])
                      (cons (Prim tt "DUP" % string [] [])
                        (cons (Prim tt "AMOUNT" % string [] [])
                          (cons (Prim tt "CMPLT" % string [] [])
                            (cons
                              (Prim tt "IF" % string
                                (cons
                                  (Seq tt
                                    (cons (Prim tt "FAIL" % string [] []) []))
                                  []) []) [])))))) []) []) []))))
  end.

Definition test_list_append_parsing {A : Type} (function_parameter : unit)
  : A :=
  match function_parameter with
  | tt =>
    assert_toplevel_parsing Stdlib.__LOC__
      "parameter (pair (list int)(list int));return (list int);storage unit;code { CAR; DUP; DIP{CDR}; CAR;NIL int; SWAP;LAMDA (pair int (list int))(list int){DUP; CAR; DIP {CDR}; CONS};REDUCE;LAMDA (pair int (list int))(list int){DUP; CAR; DIP{CDR}; CONS};UNIT; SWAP; PAIR}"
        % string
      (cons
        (Prim tt "parameter" % string
          (cons
            (Prim tt "pair" % string
              (cons
                (Prim tt "list" % string
                  (cons (Prim tt "int" % string [] []) []) [])
                (cons
                  (Prim tt "list" % string
                    (cons (Prim tt "int" % string [] []) []) []) [])) []) []) [])
        (cons
          (Prim tt "return" % string
            (cons
              (Prim tt "list" % string (cons (Prim tt "int" % string [] []) [])
                []) []) [])
          (cons
            (Prim tt "storage" % string
              (cons (Prim tt "unit" % string [] []) []) [])
            (cons
              (Prim tt "code" % string
                (cons
                  (Seq tt
                    (cons (Prim tt "CAR" % string [] [])
                      (cons (Prim tt "DUP" % string [] [])
                        (cons
                          (Prim tt "DIP" % string
                            (cons
                              (Seq tt (cons (Prim tt "CDR" % string [] []) []))
                              []) [])
                          (cons (Prim tt "CAR" % string [] [])
                            (cons
                              (Prim tt "NIL" % string
                                (cons (Prim tt "int" % string [] []) []) [])
                              (cons (Prim tt "SWAP" % string [] [])
                                (cons
                                  (Prim tt "LAMDA" % string
                                    (cons
                                      (Prim tt "pair" % string
                                        (cons (Prim tt "int" % string [] [])
                                          (cons
                                            (Prim tt "list" % string
                                              (cons
                                                (Prim tt "int" % string [] [])
                                                []) []) [])) [])
                                      (cons
                                        (Prim tt "list" % string
                                          (cons (Prim tt "int" % string [] [])
                                            []) [])
                                        (cons
                                          (Seq tt
                                            (cons (Prim tt "DUP" % string [] [])
                                              (cons
                                                (Prim tt "CAR" % string [] [])
                                                (cons
                                                  (Prim tt "DIP" % string
                                                    (cons
                                                      (Seq tt
                                                        (cons
                                                          (Prim tt
                                                            "CDR" % string [] [])
                                                          [])) []) [])
                                                  (cons
                                                    (Prim tt "CONS" % string []
                                                      []) []))))) []))) [])
                                  (cons (Prim tt "REDUCE" % string [] [])
                                    (cons
                                      (Prim tt "LAMDA" % string
                                        (cons
                                          (Prim tt "pair" % string
                                            (cons (Prim tt "int" % string [] [])
                                              (cons
                                                (Prim tt "list" % string
                                                  (cons
                                                    (Prim tt "int" % string []
                                                      []) []) []) [])) [])
                                          (cons
                                            (Prim tt "list" % string
                                              (cons
                                                (Prim tt "int" % string [] [])
                                                []) [])
                                            (cons
                                              (Seq tt
                                                (cons
                                                  (Prim tt "DUP" % string [] [])
                                                  (cons
                                                    (Prim tt "CAR" % string []
                                                      [])
                                                    (cons
                                                      (Prim tt "DIP" % string
                                                        (cons
                                                          (Seq tt
                                                            (cons
                                                              (Prim tt
                                                                "CDR" % string
                                                                [] []) [])) [])
                                                        [])
                                                      (cons
                                                        (Prim tt "CONS" % string
                                                          [] []) []))))) [])))
                                        [])
                                      (cons (Prim tt "UNIT" % string [] [])
                                        (cons (Prim tt "SWAP" % string [] [])
                                          (cons (Prim tt "PAIR" % string [] [])
                                            []))))))))))))) []) []) []))))
  end.

Definition assert_expression_parsing {A B C D : Type}
  (loc : A) (source : string) (expected : Tezos_micheline.Micheline.node B C)
  : D :=
  match Tezos_micheline.Micheline_parser.tokenize source with
  | (_, cons _ _) =>
    OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc source
  | (tokens, []) =>
    match Tezos_micheline.Micheline_parser.parse_expression None tokens with
    | (_, cons _ _) =>
      OCaml.Stdlib.failwith "%s - Cannot parse_expression %s" % string loc
        source
    | (ast, []) =>
      let ast := Tezos_micheline.Micheline.strip_locations ast in
      let expected := Tezos_micheline.Micheline.strip_locations expected in
      op_star_t_y_p_e_minus_e_r_r_o_r_star loc ast expected
    end
  end.

Definition test_parses_expression {A : Type} (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (assert_expression_parsing Stdlib.__LOC__ "Pair False ""abc""" % string
        (Prim tt "Pair" % string
          (cons (Prim tt "False" % string [] [])
            (cons (String tt "abc" % string) [])) []))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (assert_expression_parsing Stdlib.__LOC__ "Item 100" % string
              (Prim tt "Item" % string (cons (Int tt (Z.of_int 100)) []) []))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                assert_expression_parsing Stdlib.__LOC__ "{}" % string
                  (Seq tt [])
              end)
        end)
  end.

Definition tests {A B : Type} : list (string * (A -> B)) :=
  cons
    ("tokenize" % string,
      (fun function_parameter =>
        match function_parameter with
        | _ => test_tokenize_basic tt
        end))
    (cons
      ("test one line contract" % string,
        (fun function_parameter =>
          match function_parameter with
          | _ => test_one_line_contract tt
          end))
      (cons
        ("test_condition_contract" % string,
          (fun function_parameter =>
            match function_parameter with
            | _ => test_condition_contract tt
            end))
        (cons
          ("test_basic_parsing" % string,
            (fun function_parameter =>
              match function_parameter with
              | _ => test_basic_parsing tt
              end))
          (cons
            ("test_condition_contract_parsing" % string,
              (fun function_parameter =>
                match function_parameter with
                | _ => test_condition_contract_parsing tt
                end))
            (cons
              ("test_list_append_parsing" % string,
                (fun function_parameter =>
                  match function_parameter with
                  | _ => test_list_append_parsing tt
                  end))
              (cons
                ("test_parses_expression" % string,
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => test_parses_expression tt
                    end)) [])))))).

Definition wrap {A B C : Type} (function_parameter : A * (unit -> B)) : C :=
  match function_parameter with
  | (n, f) =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star (f tt)
                (fun function_parameter =>
                  match function_parameter with
                  | inl tt => Lwt.return_unit
                  | inr err => Lwt.fail_with err
                  end)
            end
        end)
  end.
src/lib_p2p/p2p.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p"
end)

type 'peer_meta peer_meta_config = 'peer_meta P2p_pool.peer_meta_config = {
  peer_meta_encoding : 'peer_meta Data_encoding.t;
  peer_meta_initial : unit -> 'peer_meta;
  score : 'peer_meta -> float;
}

type 'conn_meta conn_meta_config = 'conn_meta P2p_socket.metadata_config = {
  conn_meta_encoding : 'conn_meta Data_encoding.t;
  conn_meta_value : P2p_peer.Id.t -> 'conn_meta;
  private_node : 'conn_meta -> bool;
}

type 'msg app_message_encoding = 'msg P2p_message.encoding =
  | Encoding : {
      tag : int;
      title : string;
      encoding : 'a Data_encoding.t;
      wrap : 'a -> 'msg;
      unwrap : 'msg -> 'a option;
      max_length : int option;
    }
      -> 'msg app_message_encoding

type 'msg message_config = 'msg P2p_pool.message_config = {
  encoding : 'msg app_message_encoding list;
  chain_name : Distributed_db_version.name;
  distributed_db_versions : Distributed_db_version.t list;
}

type config = {
  listening_port : P2p_addr.port option;
  listening_addr : P2p_addr.t option;
  discovery_port : P2p_addr.port option;
  discovery_addr : Ipaddr.V4.t option;
  trusted_points : P2p_point.Id.t list;
  peers_file : string;
  private_mode : bool;
  identity : P2p_identity.t;
  proof_of_work_target : Crypto_box.target;
  disable_mempool : bool;
  trust_discovered_peers : bool;
  disable_testchain : bool;
  greylisting_config : P2p_point_state.Info.greylisting_config;
}

type limits = {
  connection_timeout : Time.System.Span.t;
  authentication_timeout : Time.System.Span.t;
  greylist_timeout : Time.System.Span.t;
  maintenance_idle_time : Time.System.Span.t;
  min_connections : int;
  expected_connections : int;
  max_connections : int;
  backlog : int;
  max_incoming_connections : int;
  max_download_speed : int option;
  max_upload_speed : int option;
  read_buffer_size : int;
  read_queue_size : int option;
  write_queue_size : int option;
  incoming_app_message_queue_size : int option;
  incoming_message_queue_size : int option;
  outgoing_message_queue_size : int option;
  known_peer_ids_history_size : int;
  known_points_history_size : int;
  max_known_peer_ids : (int * int) option;
  max_known_points : (int * int) option;
  swap_linger : Time.System.Span.t;
  binary_chunks_size : int option;
}

let create_scheduler limits =
  let max_upload_speed = Option.map limits.max_upload_speed ~f:(( * ) 1024) in
  let max_download_speed =
    Option.map limits.max_upload_speed ~f:(( * ) 1024)
  in
  P2p_io_scheduler.create
    ~read_buffer_size:limits.read_buffer_size
    ?max_upload_speed
    ?max_download_speed
    ?read_queue_size:limits.read_queue_size
    ?write_queue_size:limits.write_queue_size
    ()

let create_connection_pool config limits meta_cfg conn_meta_cfg msg_cfg
    io_sched =
  let pool_cfg =
    {
      P2p_pool.identity = config.identity;
      proof_of_work_target = config.proof_of_work_target;
      listening_port = config.listening_port;
      trusted_points = config.trusted_points;
      peers_file = config.peers_file;
      private_mode = config.private_mode;
      greylisting_config = config.greylisting_config;
      min_connections = limits.min_connections;
      max_connections = limits.max_connections;
      max_incoming_connections = limits.max_incoming_connections;
      connection_timeout = limits.connection_timeout;
      authentication_timeout = limits.authentication_timeout;
      incoming_app_message_queue_size = limits.incoming_app_message_queue_size;
      incoming_message_queue_size = limits.incoming_message_queue_size;
      outgoing_message_queue_size = limits.outgoing_message_queue_size;
      known_peer_ids_history_size = limits.known_peer_ids_history_size;
      known_points_history_size = limits.known_points_history_size;
      max_known_points = limits.max_known_points;
      max_known_peer_ids = limits.max_known_peer_ids;
      swap_linger = limits.swap_linger;
      binary_chunks_size = limits.binary_chunks_size;
    }
  in
  let pool =
    P2p_pool.create pool_cfg meta_cfg conn_meta_cfg msg_cfg io_sched
  in
  pool

let may_create_discovery_worker _limits config pool =
  match
    (config.listening_port, config.discovery_port, config.discovery_addr)
  with
  | (Some listening_port, Some discovery_port, Some discovery_addr) ->
      Some
        (P2p_discovery.create
           pool
           config.identity.peer_id
           ~listening_port
           ~discovery_port
           ~discovery_addr
           ~trust_discovered_peers:config.trust_discovered_peers)
  | (_, _, _) ->
      None

let create_maintenance_worker limits pool config =
  let maintenance_config =
    {
      P2p_maintenance.maintenance_idle_time = limits.maintenance_idle_time;
      greylist_timeout = limits.greylist_timeout;
      private_mode = config.private_mode;
      min_connections = limits.min_connections;
      max_connections = limits.max_connections;
      expected_connections = limits.max_connections;
    }
  in
  let discovery = may_create_discovery_worker limits config pool in
  P2p_maintenance.create ?discovery maintenance_config pool

let may_create_welcome_worker config limits pool =
  match config.listening_port with
  | None ->
      Lwt.return_none
  | Some port ->
      P2p_welcome.create
        ~backlog:limits.backlog
        pool
        ?addr:config.listening_addr
        port
      >>= fun w -> Lwt.return_some w

type ('msg, 'peer_meta, 'conn_meta) connection =
  ('msg, 'peer_meta, 'conn_meta) P2p_pool.connection

module Real = struct
  type ('msg, 'peer_meta, 'conn_meta) net = {
    config : config;
    limits : limits;
    io_sched : P2p_io_scheduler.t;
    pool : ('msg, 'peer_meta, 'conn_meta) P2p_pool.t;
    maintenance : ('msg, 'peer_meta, 'conn_meta) P2p_maintenance.t;
    welcome : P2p_welcome.t option;
  }

  let create ~config ~limits meta_cfg conn_meta_cfg msg_cfg =
    let io_sched = create_scheduler limits in
    create_connection_pool
      config
      limits
      meta_cfg
      conn_meta_cfg
      msg_cfg
      io_sched
    >>= fun pool ->
    let maintenance = create_maintenance_worker limits pool config in
    may_create_welcome_worker config limits pool
    >>= fun welcome ->
    return {config; limits; io_sched; pool; maintenance; welcome}

  let peer_id {config; _} = config.identity.peer_id

  let maintain {maintenance; _} () = P2p_maintenance.maintain maintenance

  let activate t () =
    log_info "activate" ;
    (match t.welcome with None -> () | Some w -> P2p_welcome.activate w) ;
    P2p_maintenance.activate t.maintenance ;
    ()

  let roll _net () = Lwt.return_unit (* TODO implement *)

  (* returns when all workers have shutted down in the opposite
     creation order. *)
  let shutdown net () =
    lwt_log_notice "Shutting down the p2p's welcome worker..."
    >>= fun () ->
    Lwt_utils.may ~f:P2p_welcome.shutdown net.welcome
    >>= fun () ->
    lwt_log_notice "Shutting down the p2p's network maintenance worker..."
    >>= fun () ->
    P2p_maintenance.shutdown net.maintenance
    >>= fun () ->
    lwt_log_notice "Shutting down the p2p connection pool..."
    >>= fun () ->
    P2p_pool.destroy net.pool
    >>= fun () ->
    lwt_log_notice "Shutting down the p2p scheduler..."
    >>= fun () -> P2p_io_scheduler.shutdown ~timeout:3.0 net.io_sched

  let connections {pool; _} () =
    P2p_pool.Connection.fold pool ~init:[] ~f:(fun _peer_id c acc -> c :: acc)

  let find_connection {pool; _} peer_id =
    P2p_pool.Connection.find_by_peer_id pool peer_id

  let disconnect ?wait conn = P2p_pool.disconnect ?wait conn

  let connection_info _net conn = P2p_pool.Connection.info conn

  let connection_local_metadata _net conn =
    P2p_pool.Connection.local_metadata conn

  let connection_remote_metadata _net conn =
    P2p_pool.Connection.remote_metadata conn

  let connection_stat _net conn = P2p_pool.Connection.stat conn

  let global_stat {pool; _} () = P2p_pool.pool_stat pool

  let set_peer_metadata {pool; _} conn meta =
    P2p_pool.Peers.set_peer_metadata pool conn meta

  let get_peer_metadata {pool; _} conn =
    P2p_pool.Peers.get_peer_metadata pool conn

  let recv _net conn =
    P2p_pool.read conn
    >>=? fun msg ->
    lwt_debug
      "message read from %a"
      P2p_peer.Id.pp
      (P2p_pool.Connection.info conn).peer_id
    >>= fun () -> return msg

  let rec recv_any net () =
    let pipes =
      P2p_pool.Connection.fold net.pool ~init:[] ~f:(fun _peer_id conn acc ->
          ( P2p_pool.is_readable conn
          >>= function
          | Ok () ->
              Lwt.return_some conn
          | Error _ ->
              Lwt_utils.never_ending () )
          :: acc)
    in
    Lwt.pick
      ( ( P2p_pool.Pool_event.wait_new_connection net.pool
        >>= fun () -> Lwt.return_none )
      :: pipes )
    >>= function
    | None ->
        recv_any net ()
    | Some conn -> (
        P2p_pool.read conn
        >>= function
        | Ok msg ->
            lwt_debug
              "message read from %a"
              P2p_peer.Id.pp
              (P2p_pool.Connection.info conn).peer_id
            >>= fun () -> Lwt.return (conn, msg)
        | Error _ ->
            lwt_debug
              "error reading message from %a"
              P2p_peer.Id.pp
              (P2p_pool.Connection.info conn).peer_id
            >>= fun () -> Lwt_unix.yield () >>= fun () -> recv_any net () )

  let send _net conn m =
    P2p_pool.write conn m
    >>= function
    | Ok () ->
        lwt_debug
          "message sent to %a"
          P2p_peer.Id.pp
          (P2p_pool.Connection.info conn).peer_id
        >>= fun () -> return_unit
    | Error err ->
        lwt_debug
          "error sending message from %a: %a"
          P2p_peer.Id.pp
          (P2p_pool.Connection.info conn).peer_id
          pp_print_error
          err
        >>= fun () -> Lwt.return_error err

  let try_send _net conn v =
    match P2p_pool.write_now conn v with
    | Ok v ->
        debug
          "message trysent to %a"
          P2p_peer.Id.pp
          (P2p_pool.Connection.info conn).peer_id ;
        v
    | Error err ->
        debug
          "error trysending message to %a@ %a"
          P2p_peer.Id.pp
          (P2p_pool.Connection.info conn).peer_id
          pp_print_error
          err ;
        false

  let broadcast {pool; _} msg =
    P2p_pool.write_all pool msg ;
    debug "message broadcasted"

  let fold_connections {pool; _} ~init ~f =
    P2p_pool.Connection.fold pool ~init ~f

  let iter_connections {pool; _} f =
    P2p_pool.Connection.fold pool ~init:() ~f:(fun gid conn () -> f gid conn)

  let on_new_connection {pool; _} f = P2p_pool.on_new_connection pool f
end

module Fake = struct
  let id = P2p_identity.generate (Crypto_box.make_target 0.)

  let empty_stat =
    {
      P2p_stat.total_sent = 0L;
      total_recv = 0L;
      current_inflow = 0;
      current_outflow = 0;
    }

  let connection_info announced_version faked_metadata =
    {
      P2p_connection.Info.incoming = false;
      peer_id = id.peer_id;
      id_point = (Ipaddr.V6.unspecified, None);
      remote_socket_port = 0;
      announced_version;
      local_metadata = faked_metadata;
      remote_metadata = faked_metadata;
      private_node = false;
    }
end

type ('msg, 'peer_meta, 'conn_meta) t = {
  announced_version : Network_version.t;
  peer_id : P2p_peer.Id.t;
  maintain : unit -> unit Lwt.t;
  roll : unit -> unit Lwt.t;
  shutdown : unit -> unit Lwt.t;
  connections : unit -> ('msg, 'peer_meta, 'conn_meta) connection list;
  find_connection :
    P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection option;
  disconnect :
    ?wait:bool -> ('msg, 'peer_meta, 'conn_meta) connection -> unit Lwt.t;
  connection_info :
    ('msg, 'peer_meta, 'conn_meta) connection ->
    'conn_meta P2p_connection.Info.t;
  connection_local_metadata :
    ('msg, 'peer_meta, 'conn_meta) connection -> 'conn_meta;
  connection_remote_metadata :
    ('msg, 'peer_meta, 'conn_meta) connection -> 'conn_meta;
  connection_stat : ('msg, 'peer_meta, 'conn_meta) connection -> P2p_stat.t;
  global_stat : unit -> P2p_stat.t;
  get_peer_metadata : P2p_peer.Id.t -> 'peer_meta;
  set_peer_metadata : P2p_peer.Id.t -> 'peer_meta -> unit;
  recv : ('msg, 'peer_meta, 'conn_meta) connection -> 'msg tzresult Lwt.t;
  recv_any : unit -> (('msg, 'peer_meta, 'conn_meta) connection * 'msg) Lwt.t;
  send :
    ('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> unit tzresult Lwt.t;
  try_send : ('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> bool;
  broadcast : 'msg -> unit;
  pool : ('msg, 'peer_meta, 'conn_meta) P2p_pool.t option;
  fold_connections :
    'a. init:'a ->
    f:(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> 'a -> 'a) ->
    'a;
  iter_connections :
    (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
    unit;
  on_new_connection :
    (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
    unit;
  activate : unit -> unit;
}

type ('msg, 'peer_meta, 'conn_meta) net = ('msg, 'peer_meta, 'conn_meta) t

let announced_version net = net.announced_version

let pool net = net.pool

let check_limits =
  let fail_1 v orig =
    if not (Ptime.Span.compare v Ptime.Span.zero <= 0) then return_unit
    else
      Error_monad.failwith
        "value of option %S cannot be negative or null@."
        orig
  in
  let fail_2 v orig =
    if not (v < 0) then return_unit
    else Error_monad.failwith "value of option %S cannot be negative@." orig
  in
  fun c ->
    fail_1 c.authentication_timeout "authentication-timeout"
    >>=? fun () ->
    fail_2 c.min_connections "min-connections"
    >>=? fun () ->
    fail_2 c.expected_connections "expected-connections"
    >>=? fun () ->
    fail_2 c.max_connections "max-connections"
    >>=? fun () ->
    fail_2 c.max_incoming_connections "max-incoming-connections"
    >>=? fun () ->
    fail_2 c.read_buffer_size "read-buffer-size"
    >>=? fun () ->
    fail_2 c.known_peer_ids_history_size "known-peer-ids-history-size"
    >>=? fun () ->
    fail_2 c.known_points_history_size "known-points-history-size"
    >>=? fun () ->
    fail_1 c.swap_linger "swap-linger"
    >>=? fun () ->
    ( match c.binary_chunks_size with
    | None ->
        return_unit
    | Some size ->
        P2p_socket.check_binary_chunks_size size )
    >>=? fun () -> return_unit

let create ~config ~limits peer_cfg conn_cfg msg_cfg =
  check_limits limits
  >>=? fun () ->
  Real.create ~config ~limits peer_cfg conn_cfg msg_cfg
  >>=? fun net ->
  return
    {
      announced_version =
        Network_version.announced
          ~chain_name:msg_cfg.chain_name
          ~distributed_db_versions:msg_cfg.distributed_db_versions
          ~p2p_versions:P2p_version.supported;
      peer_id = Real.peer_id net;
      maintain = Real.maintain net;
      roll = Real.roll net;
      shutdown = Real.shutdown net;
      connections = Real.connections net;
      find_connection = Real.find_connection net;
      disconnect = Real.disconnect;
      connection_info = Real.connection_info net;
      connection_local_metadata = Real.connection_local_metadata net;
      connection_remote_metadata = Real.connection_remote_metadata net;
      connection_stat = Real.connection_stat net;
      global_stat = Real.global_stat net;
      get_peer_metadata = Real.get_peer_metadata net;
      set_peer_metadata = Real.set_peer_metadata net;
      recv = Real.recv net;
      recv_any = Real.recv_any net;
      send = Real.send net;
      try_send = Real.try_send net;
      broadcast = Real.broadcast net;
      pool = Some net.pool;
      fold_connections = (fun ~init ~f -> Real.fold_connections net ~init ~f);
      iter_connections = Real.iter_connections net;
      on_new_connection = Real.on_new_connection net;
      activate = Real.activate net;
    }

let activate t =
  log_info "activate P2P layer !" ;
  t.activate ()

let faked_network (msg_cfg : 'msg message_config) peer_cfg faked_metadata =
  let announced_version =
    Network_version.announced
      ~chain_name:msg_cfg.chain_name
      ~distributed_db_versions:msg_cfg.distributed_db_versions
      ~p2p_versions:P2p_version.supported
  in
  {
    announced_version;
    peer_id = Fake.id.peer_id;
    maintain = Lwt.return;
    roll = Lwt.return;
    shutdown = Lwt.return;
    connections = (fun () -> []);
    find_connection = (fun _ -> None);
    disconnect = (fun ?wait:_ _ -> Lwt.return_unit);
    connection_info =
      (fun _ -> Fake.connection_info announced_version faked_metadata);
    connection_local_metadata = (fun _ -> faked_metadata);
    connection_remote_metadata = (fun _ -> faked_metadata);
    connection_stat = (fun _ -> Fake.empty_stat);
    global_stat = (fun () -> Fake.empty_stat);
    get_peer_metadata = (fun _ -> peer_cfg.peer_meta_initial ());
    set_peer_metadata = (fun _ _ -> ());
    recv = (fun _ -> Lwt_utils.never_ending ());
    recv_any = (fun () -> Lwt_utils.never_ending ());
    send = (fun _ _ -> fail P2p_errors.Connection_closed);
    try_send = (fun _ _ -> false);
    fold_connections = (fun ~init ~f:_ -> init);
    iter_connections = (fun _f -> ());
    on_new_connection = (fun _f -> ());
    broadcast = ignore;
    pool = None;
    activate = (fun _ -> ());
  }

let peer_id net = net.peer_id

let maintain net = net.maintain ()

let roll net = net.roll ()

let shutdown net = net.shutdown ()

let connections net = net.connections ()

let disconnect net = net.disconnect

let find_connection net = net.find_connection

let connection_info net = net.connection_info

let connection_local_metadata net = net.connection_local_metadata

let connection_remote_metadata net = net.connection_remote_metadata

let connection_stat net = net.connection_stat

let global_stat net = net.global_stat ()

let get_peer_metadata net = net.get_peer_metadata

let set_peer_metadata net = net.set_peer_metadata

let recv net = net.recv

let recv_any net = net.recv_any ()

let send net = net.send

let try_send net = net.try_send

let broadcast net = net.broadcast

let fold_connections net = net.fold_connections

let iter_connections net = net.iter_connections

let on_new_connection net = net.on_new_connection

let greylist_addr net addr =
  Option.iter net.pool ~f:(fun pool -> P2p_pool.greylist_addr pool addr)

let greylist_peer net peer_id =
  Option.iter net.pool ~f:(fun pool -> P2p_pool.greylist_peer pool peer_id)
src/lib_p2p/p2p.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record peer_meta_config {peer_meta : Type} := {
  peer_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t peer_meta;
  peer_meta_initial : unit -> peer_meta;
  score : peer_meta -> float }.
Arguments peer_meta_config : clear implicits.

Record conn_meta_config {conn_meta : Type} := {
  conn_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t conn_meta;
  conn_meta_value : Tezos_base__TzPervasives.P2p_peer.Id.t -> conn_meta;
  private_node : conn_meta -> bool }.
Arguments conn_meta_config : clear implicits.

Inductive app_message_encoding (msg : Type) : Type :=
| Encoding : forall {a : Type}, Z -> string ->
  (Tezos_base__TzPervasives.Data_encoding.t a) -> (a -> msg) ->
  (msg -> option a) -> (option Z) -> app_message_encoding msg.

Arguments Encoding {_}.

Record message_config {msg : Type} := {
  encoding : list (app_message_encoding msg);
  chain_name : Tezos_base__TzPervasives.Distributed_db_version.name;
  distributed_db_versions :
    list Tezos_base__TzPervasives.Distributed_db_version.t }.
Arguments message_config : clear implicits.

Record config := {
  listening_port : option Tezos_base__TzPervasives.P2p_addr.port;
  listening_addr : option Tezos_base__TzPervasives.P2p_addr.t;
  discovery_port : option Tezos_base__TzPervasives.P2p_addr.port;
  discovery_addr : option Ipaddr.V4.t;
  trusted_points : list Tezos_base__TzPervasives.P2p_point.Id.t;
  peers_file : string;
  private_mode : bool;
  identity : Tezos_base__TzPervasives.P2p_identity.t;
  proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target;
  disable_mempool : bool;
  trust_discovered_peers : bool;
  disable_testchain : bool;
  greylisting_config : Tezos_p2p.P2p_point_state.Info.greylisting_config }.

Record limits := {
  connection_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  authentication_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  greylist_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  maintenance_idle_time : Tezos_base__TzPervasives.Time.System.Span.t;
  min_connections : Z;
  expected_connections : Z;
  max_connections : Z;
  backlog : Z;
  max_incoming_connections : Z;
  max_download_speed : option Z;
  max_upload_speed : option Z;
  read_buffer_size : Z;
  read_queue_size : option Z;
  write_queue_size : option Z;
  incoming_app_message_queue_size : option Z;
  incoming_message_queue_size : option Z;
  outgoing_message_queue_size : option Z;
  known_peer_ids_history_size : Z;
  known_points_history_size : Z;
  max_known_peer_ids : option (Z * Z);
  max_known_points : option (Z * Z);
  swap_linger : Tezos_base__TzPervasives.Time.System.Span.t;
  binary_chunks_size : option Z }.

Definition create_scheduler (limits : limits) : Tezos_p2p.P2p_io_scheduler.t :=
  let max_upload_speed :=
    Tezos_stdlib.Option.map (Z.mul 1024) (max_upload_speed limits) in
  let max_download_speed :=
    Tezos_stdlib.Option.map (Z.mul 1024) (max_upload_speed limits) in
  Tezos_p2p.P2p_io_scheduler.create max_upload_speed max_download_speed
    (read_queue_size limits) (write_queue_size limits) (read_buffer_size limits)
    tt.

Definition create_connection_pool {A B C : Type}
  (config : config) (limits : limits)
  (meta_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
  (conn_meta_cfg : Tezos_p2p.P2p_socket.metadata_config B)
  (msg_cfg : Tezos_p2p.P2p_pool.message_config C)
  (io_sched : Tezos_p2p.P2p_io_scheduler.t)
  : Lwt.t (Tezos_p2p.P2p_pool.pool C A B) :=
  let pool_cfg :=
    {| P2p_pool.identity := identity config;
      P2p_pool.proof_of_work_target := proof_of_work_target config;
      P2p_pool.trusted_points := trusted_points config;
      P2p_pool.peers_file := peers_file config;
      P2p_pool.private_mode := private_mode config;
      P2p_pool.greylisting_config := greylisting_config config;
      P2p_pool.listening_port := listening_port config;
      P2p_pool.min_connections := min_connections limits;
      P2p_pool.max_connections := max_connections limits;
      P2p_pool.max_incoming_connections := max_incoming_connections limits;
      P2p_pool.connection_timeout := connection_timeout limits;
      P2p_pool.authentication_timeout := authentication_timeout limits;
      P2p_pool.incoming_app_message_queue_size :=
        incoming_app_message_queue_size limits;
      P2p_pool.incoming_message_queue_size := incoming_message_queue_size limits;
      P2p_pool.outgoing_message_queue_size := outgoing_message_queue_size limits;
      P2p_pool.known_peer_ids_history_size := known_peer_ids_history_size limits;
      P2p_pool.known_points_history_size := known_points_history_size limits;
      P2p_pool.max_known_points := max_known_points limits;
      P2p_pool.max_known_peer_ids := max_known_peer_ids limits;
      P2p_pool.swap_linger := swap_linger limits;
      P2p_pool.binary_chunks_size := binary_chunks_size limits |} in
  let pool :=
    Tezos_p2p.P2p_pool.create None pool_cfg meta_cfg conn_meta_cfg msg_cfg
      io_sched in
  pool.

Definition may_create_discovery_worker {A B C D : Type}
  (_limits : A) (config : config) (pool : Tezos_p2p.P2p_pool.t B C D)
  : option Tezos_p2p.P2p_discovery.t :=
  match
    ((listening_port config), (discovery_port config), (discovery_addr config))
    with
  | (Some listening_port, Some discovery_port, Some discovery_addr) =>
    Some
      (Tezos_p2p.P2p_discovery.create listening_port discovery_port
        discovery_addr (trust_discovered_peers config) pool
        (peer_id (identity config)))
  | (_, _, _) => None
  end.

Definition create_maintenance_worker {A B C : Type}
  (limits : limits) (pool : Tezos_p2p.P2p_pool.t A B C) (config : config)
  : Tezos_p2p.P2p_maintenance.t A B C :=
  let maintenance_config :=
    {| P2p_maintenance.maintenance_idle_time := maintenance_idle_time limits;
      P2p_maintenance.greylist_timeout := greylist_timeout limits;
      P2p_maintenance.private_mode := private_mode config;
      P2p_maintenance.min_connections := min_connections limits;
      P2p_maintenance.max_connections := max_connections limits;
      P2p_maintenance.expected_connections := max_connections limits |} in
  let discovery := may_create_discovery_worker limits config pool in
  Tezos_p2p.P2p_maintenance.create discovery maintenance_config pool.

Definition may_create_welcome_worker {A B C : Type}
  (config : config) (limits : limits) (pool : Tezos_p2p.P2p_pool.t A B C)
  : Lwt.t (option Tezos_p2p.P2p_welcome.t) :=
  match listening_port config with
  | None => Lwt.return_none
  | Some port =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_p2p.P2p_welcome.create (listening_addr config) (backlog limits)
        pool port) (fun w => Lwt.return_some w)
  end.

Definition connection (msg peer_meta conn_meta : Type) :=
  Tezos_p2p.P2p_pool.connection msg peer_meta conn_meta.

Module Real.
  Record net {msg peer_meta conn_meta : Type} := {
    config : config;
    limits : limits;
    io_sched : Tezos_p2p.P2p_io_scheduler.t;
    pool : Tezos_p2p.P2p_pool.t msg peer_meta conn_meta;
    maintenance : Tezos_p2p.P2p_maintenance.t msg peer_meta conn_meta;
    welcome : option Tezos_p2p.P2p_welcome.t }.
  Arguments net : clear implicits.
  
  Definition create {A B C : Type}
    (config : config) (limits : limits)
    (meta_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
    (conn_meta_cfg : Tezos_p2p.P2p_socket.metadata_config B)
    (msg_cfg : Tezos_p2p.P2p_pool.message_config C)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (net C A B)) :=
    let io_sched := create_scheduler limits in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (create_connection_pool config limits meta_cfg conn_meta_cfg msg_cfg
        io_sched)
      (fun pool =>
        let maintenance := create_maintenance_worker limits pool config in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (may_create_welcome_worker config limits pool)
          (fun welcome =>
            Tezos_base__TzPervasives._return
              {| config := config; limits := limits; io_sched := io_sched;
                pool := pool; maintenance := maintenance; welcome := welcome |})).
  
  Definition peer_id {A B C : Type} (function_parameter : net A B C)
    : Tezos_base.P2p_peer.Id.t :=
    match function_parameter with
    | {| config := config |} => peer_id (identity config)
    end.
  
  Definition maintain {A B C : Type} (function_parameter : net A B C)
    : unit -> Lwt.t unit :=
    match function_parameter with
    | {| maintenance := maintenance |} =>
      fun function_parameter =>
        match function_parameter with
        | tt => Tezos_p2p.P2p_maintenance.maintain maintenance
        end
    end.
  
  Definition activate {A B C : Type} (t : net A B C) (function_parameter : unit)
    : unit :=
    match function_parameter with
    | tt =>
      log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "activate" % string
            CamlinternalFormatBasics.End_of_format) "activate" % string);
      match welcome t with
      | None => tt
      | Some w => Tezos_p2p.P2p_welcome.activate w
      end;
      Tezos_p2p.P2p_maintenance.activate (maintenance t);
      tt
    end.
  
  Definition roll {A : Type} (_net : A) (function_parameter : unit)
    : Lwt.t unit :=
    match function_parameter with
    | tt => Lwt.return_unit
    end.
  
  Definition shutdown {A B C : Type}
    (net : net A B C) (function_parameter : unit) : Lwt.t unit :=
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (lwt_log_notice
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Shutting down the p2p's welcome worker..." % string
              CamlinternalFormatBasics.End_of_format)
            "Shutting down the p2p's welcome worker..." % string))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_stdlib.Lwt_utils.may Tezos_p2p.P2p_welcome.shutdown
                (welcome net))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_log_notice
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Shutting down the p2p's network maintenance worker..."
                            % string CamlinternalFormatBasics.End_of_format)
                        "Shutting down the p2p's network maintenance worker..."
                          % string))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_p2p.P2p_maintenance.shutdown (maintenance net))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (lwt_log_notice
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Shutting down the p2p connection pool..."
                                        % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "Shutting down the p2p connection pool..." %
                                      string))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Tezos_p2p.P2p_pool.destroy (pool net))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (lwt_log_notice
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Shutting down the p2p scheduler..."
                                                    % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "Shutting down the p2p scheduler..."
                                                  % string))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_p2p.P2p_io_scheduler.shutdown
                                                  (Some 3) (io_sched net)
                                              end)
                                        end)
                                  end)
                            end)
                      end)
                end)
          end)
    end.
  
  Definition connections {A B C : Type} (function_parameter : net A B C)
    : unit -> list (Tezos_p2p__P2p_pool.connection A B C) :=
    match function_parameter with
    | {| pool := pool |} =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_p2p.P2p_pool.Connection.fold pool []
            (fun _peer_id => fun c => fun acc => cons c acc)
        end
    end.
  
  Definition find_connection {A B C : Type} (function_parameter : net A B C)
    : Tezos_base__TzPervasives.P2p_peer.Id.t ->
      option (Tezos_p2p__P2p_pool.connection A B C) :=
    match function_parameter with
    | {| pool := pool |} =>
      fun peer_id => Tezos_p2p.P2p_pool.Connection.find_by_peer_id pool peer_id
    end.
  
  Definition disconnect {A B C : Type}
    (wait : option bool) (conn : Tezos_p2p.P2p_pool.connection A B C)
    : Lwt.t unit := Tezos_p2p.P2p_pool.disconnect wait conn.
  
  Definition connection_info {A B C D : Type}
    (_net : A) (conn : Tezos_p2p__P2p_pool.connection B C D)
    : Tezos_base__TzPervasives.P2p_connection.Info.t D :=
    Tezos_p2p.P2p_pool.Connection.info conn.
  
  Definition connection_local_metadata {A B C D : Type}
    (_net : A) (conn : Tezos_p2p__P2p_pool.connection B C D) : D :=
    Tezos_p2p.P2p_pool.Connection.local_metadata conn.
  
  Definition connection_remote_metadata {A B C D : Type}
    (_net : A) (conn : Tezos_p2p__P2p_pool.connection B C D) : D :=
    Tezos_p2p.P2p_pool.Connection.remote_metadata conn.
  
  Definition connection_stat {A B C D : Type}
    (_net : A) (conn : Tezos_p2p__P2p_pool.connection B C D)
    : Tezos_base__TzPervasives.P2p_stat.t :=
    Tezos_p2p.P2p_pool.Connection.stat conn.
  
  Definition global_stat {A B C : Type} (function_parameter : net A B C)
    : unit -> Tezos_base__TzPervasives.P2p_stat.t :=
    match function_parameter with
    | {| pool := pool |} =>
      fun function_parameter =>
        match function_parameter with
        | tt => Tezos_p2p.P2p_pool.pool_stat pool
        end
    end.
  
  Definition set_peer_metadata {A B C : Type} (function_parameter : net A B C)
    : Tezos_base__TzPervasives.P2p_peer.Id.t -> B -> unit :=
    match function_parameter with
    | {| pool := pool |} =>
      fun conn =>
        fun meta => Tezos_p2p.P2p_pool.Peers.set_peer_metadata pool conn meta
    end.
  
  Definition get_peer_metadata {A B C : Type} (function_parameter : net A B C)
    : Tezos_base__TzPervasives.P2p_peer.Id.t -> B :=
    match function_parameter with
    | {| pool := pool |} =>
      fun conn => Tezos_p2p.P2p_pool.Peers.get_peer_metadata pool conn
    end.
  
  Definition recv {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_pool.connection B C D)
    : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (Tezos_p2p.P2p_pool.read conn)
      (fun msg =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "message read from " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "message read from %a" % string)
            Tezos_base__TzPervasives.P2p_peer.Id.pp
            (peer_id (Tezos_p2p.P2p_pool.Connection.info conn)))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives._return msg
            end)).
  
  Fixpoint recv_any {A B C : Type} (net : net A B C) (function_parameter : unit)
    : Lwt.t ((Tezos_p2p.P2p_pool.connection A B C) * A) :=
    match function_parameter with
    | tt =>
      let pipes :=
        Tezos_p2p.P2p_pool.Connection.fold (pool net) []
          (fun _peer_id =>
            fun conn =>
              fun acc =>
                cons
                  (Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_p2p.P2p_pool.is_readable conn)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl tt => Lwt.return_some conn
                      | inr _ => Tezos_stdlib.Lwt_utils.never_ending tt
                      end)) acc) in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt.pick
          (cons
            (Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_p2p.P2p_pool.Pool_event.wait_new_connection (pool net))
              (fun function_parameter =>
                match function_parameter with
                | tt => Lwt.return_none
                end)) pipes))
        (fun function_parameter =>
          match function_parameter with
          | None => recv_any net tt
          | Some conn =>
            Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_p2p.P2p_pool.read conn)
              (fun function_parameter =>
                match function_parameter with
                | inl msg =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_debug
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "message read from " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        "message read from %a" % string)
                      Tezos_base__TzPervasives.P2p_peer.Id.pp
                      (peer_id (Tezos_p2p.P2p_pool.Connection.info conn)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Lwt._return (conn, msg)
                      end)
                | inr _ =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_debug
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "error reading message from " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        "error reading message from %a" % string)
                      Tezos_base__TzPervasives.P2p_peer.Id.pp
                      (peer_id (Tezos_p2p.P2p_pool.Connection.info conn)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => recv_any net tt
                            end)
                      end)
                end)
          end)
    end.
  
  Definition send {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_pool.connection B C D) (m : B)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_p2p.P2p_pool.write conn m)
      (fun function_parameter =>
        match function_parameter with
        | inl tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "message sent to " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "message sent to %a" % string)
              Tezos_base__TzPervasives.P2p_peer.Id.pp
              (peer_id (Tezos_p2p.P2p_pool.Connection.info conn)))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        | inr err =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "error sending message from " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ": " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "error sending message from %a: %a" % string)
              Tezos_base__TzPervasives.P2p_peer.Id.pp
              (peer_id (Tezos_p2p.P2p_pool.Connection.info conn))
              Tezos_base__TzPervasives.pp_print_error err)
            (fun function_parameter =>
              match function_parameter with
              | tt => Lwt.return_error err
              end)
        end).
  
  Definition try_send {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_pool.connection B C D) (v : B) : bool :=
    match Tezos_p2p.P2p_pool.write_now conn v with
    | inl v =>
      debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "message trysent to " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "message trysent to %a" % string)
        Tezos_base__TzPervasives.P2p_peer.Id.pp
        (peer_id (Tezos_p2p.P2p_pool.Connection.info conn));
      v
    | inr err =>
      debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "error trysending message to " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))))
          "error trysending message to %a@ %a" % string)
        Tezos_base__TzPervasives.P2p_peer.Id.pp
        (peer_id (Tezos_p2p.P2p_pool.Connection.info conn))
        Tezos_base__TzPervasives.pp_print_error err;
      false
    end.
  
  Definition broadcast {A B C : Type} (function_parameter : net A B C)
    : A -> unit :=
    match function_parameter with
    | {| pool := pool |} =>
      fun msg =>
        Tezos_p2p.P2p_pool.write_all pool msg;
        debug
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "message broadcasted" % string
              CamlinternalFormatBasics.End_of_format)
            "message broadcasted" % string)
    end.
  
  Definition fold_connections {A B C D : Type} (function_parameter : net A B C)
    : D ->
      (Tezos_base__TzPervasives.P2p_peer.Id.t ->
        (Tezos_p2p__P2p_pool.connection A B C) -> D -> D) -> D :=
    match function_parameter with
    | {| pool := pool |} =>
      fun init => fun f => Tezos_p2p.P2p_pool.Connection.fold pool init f
    end.
  
  Definition iter_connections {A B C : Type} (function_parameter : net A B C)
    : (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (Tezos_p2p__P2p_pool.connection A B C) -> unit) -> unit :=
    match function_parameter with
    | {| pool := pool |} =>
      fun f =>
        Tezos_p2p.P2p_pool.Connection.fold pool tt
          (fun gid =>
            fun conn =>
              fun function_parameter =>
                match function_parameter with
                | tt => f gid conn
                end)
    end.
  
  Definition on_new_connection {A B C : Type} (function_parameter : net A B C)
    : (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (Tezos_p2p.P2p_pool.connection A B C) -> unit) -> unit :=
    match function_parameter with
    | {| pool := pool |} => fun f => Tezos_p2p.P2p_pool.on_new_connection pool f
    end.
End Real.

Module Fake.
  Definition id : Tezos_base__TzPervasives.P2p_identity.t :=
    Tezos_base__TzPervasives.P2p_identity.generate
      (Tezos_base__TzPervasives.Crypto_box.make_target 0).
  
  Definition empty_stat : Tezos_base__TzPervasives.P2p_stat.t :=
    {| P2p_stat.total_sent := 0; P2p_stat.total_recv := 0;
      P2p_stat.current_inflow := 0; P2p_stat.current_outflow := 0 |}.
  
  Definition connection_info {A : Type}
    (announced_version : Tezos_base.Network_version.t) (faked_metadata : A)
    : Tezos_base__TzPervasives.P2p_connection.Info.t A :=
    {| P2p_connection.Info.incoming := false;
      P2p_connection.Info.peer_id := peer_id id;
      P2p_connection.Info.id_point := (Ipaddr.V6.unspecified, None);
      P2p_connection.Info.remote_socket_port := 0;
      P2p_connection.Info.announced_version := announced_version;
      P2p_connection.Info.private_node := false;
      P2p_connection.Info.local_metadata := faked_metadata;
      P2p_connection.Info.remote_metadata := faked_metadata |}.
End Fake.

Record t {msg peer_meta conn_meta : Type} := {
  announced_version : Tezos_base__TzPervasives.Network_version.t;
  peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
  maintain : unit -> Lwt.t unit;
  roll : unit -> Lwt.t unit;
  shutdown : unit -> Lwt.t unit;
  connections : unit -> list (connection msg peer_meta conn_meta);
  find_connection :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      option (connection msg peer_meta conn_meta);
  disconnect :
    (option bool) -> (connection msg peer_meta conn_meta) -> Lwt.t unit;
  connection_info :
    (connection msg peer_meta conn_meta) ->
      Tezos_base__TzPervasives.P2p_connection.Info.t conn_meta;
  connection_local_metadata : (connection msg peer_meta conn_meta) -> conn_meta;
  connection_remote_metadata : (connection msg peer_meta conn_meta) -> conn_meta;
  connection_stat :
    (connection msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_stat.t;
  global_stat : unit -> Tezos_base__TzPervasives.P2p_stat.t;
  get_peer_metadata : Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta;
  set_peer_metadata :
    Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta -> unit;
  recv :
    (connection msg peer_meta conn_meta) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult msg);
  recv_any : unit -> Lwt.t ((connection msg peer_meta conn_meta) * msg);
  send :
    (connection msg peer_meta conn_meta) ->
      msg -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
  try_send : (connection msg peer_meta conn_meta) -> msg -> bool;
  broadcast : msg -> unit;
  pool : option (Tezos_p2p.P2p_pool.t msg peer_meta conn_meta);
  fold_connections :
    (a ->
      (Tezos_base__TzPervasives.P2p_peer.Id.t ->
        (connection msg peer_meta conn_meta) -> a -> a) -> a) * (a);
  iter_connections :
    (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (connection msg peer_meta conn_meta) -> unit) -> unit;
  on_new_connection :
    (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (connection msg peer_meta conn_meta) -> unit) -> unit;
  activate : unit -> unit }.
Arguments t : clear implicits.

Definition net (msg peer_meta conn_meta : Type) := t msg peer_meta conn_meta.

Definition announced_version {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.Network_version.t := announced_version net.

Definition pool {A B C : Type} (net : t A B C)
  : option (Tezos_p2p.P2p_pool.t A B C) := pool net.

Definition check_limits
  : limits -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let fail_1 (v : Ptime.span) (orig : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    if negb (OCaml.Stdlib.le (Ptime.Span.compare v Ptime.Span.zero) 0) then
      Tezos_base__TzPervasives.return_unit
    else
      Tezos_base__TzPervasives.Error_monad.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "value of option " % string
            (CamlinternalFormatBasics.Caml_string
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " cannot be negative or null" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Flush_newline
                  CamlinternalFormatBasics.End_of_format))))
          "value of option %S cannot be negative or null@." % string) orig in
  let fail_2 (v : Z) (orig : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    if negb (OCaml.Stdlib.lt v 0) then
      Tezos_base__TzPervasives.return_unit
    else
      Tezos_base__TzPervasives.Error_monad.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "value of option " % string
            (CamlinternalFormatBasics.Caml_string
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " cannot be negative" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Flush_newline
                  CamlinternalFormatBasics.End_of_format))))
          "value of option %S cannot be negative@." % string) orig in
  fun c =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (fail_1 (authentication_timeout c) "authentication-timeout" % string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (fail_2 (min_connections c) "min-connections" % string)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (fail_2 (expected_connections c)
                    "expected-connections" % string)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (fail_2 (max_connections c) "max-connections" % string)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (fail_2 (max_incoming_connections c)
                                "max-incoming-connections" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (fail_2 (read_buffer_size c)
                                      "read-buffer-size" % string)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (fail_2
                                            (known_peer_ids_history_size c)
                                            "known-peer-ids-history-size" %
                                              string)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (fail_2
                                                  (known_points_history_size c)
                                                  "known-points-history-size" %
                                                    string)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                      (fail_1 (swap_linger c)
                                                        "swap-linger" % string)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                            match
                                                              binary_chunks_size
                                                                c with
                                                            | None =>
                                                              Tezos_base__TzPervasives.return_unit
                                                            | Some size =>
                                                              Tezos_p2p.P2p_socket.check_binary_chunks_size
                                                                size
                                                            end
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_base__TzPervasives.return_unit
                                                              end)
                                                        end)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end)
        end).

Definition create {A B C : Type}
  (config : config) (limits : limits)
  (peer_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
  (conn_cfg : Tezos_p2p.P2p_socket.metadata_config B)
  (msg_cfg : Tezos_p2p.P2p_pool.message_config C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (t C A B)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (check_limits limits)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Real.create config limits peer_cfg conn_cfg msg_cfg)
          (fun net =>
            Tezos_base__TzPervasives._return
              {|
                announced_version :=
                  Tezos_base__TzPervasives.Network_version.announced
                    (chain_name msg_cfg) (distributed_db_versions msg_cfg)
                    Tezos_base__TzPervasives.P2p_version.supported;
                peer_id := Real.peer_id net; maintain := Real.maintain net;
                roll := Real.roll net; shutdown := Real.shutdown net;
                connections := Real.connections net;
                find_connection := Real.find_connection net;
                disconnect := Real.disconnect;
                connection_info := Real.connection_info net;
                connection_local_metadata := Real.connection_local_metadata net;
                connection_remote_metadata :=
                  Real.connection_remote_metadata net;
                connection_stat := Real.connection_stat net;
                global_stat := Real.global_stat net;
                get_peer_metadata := Real.get_peer_metadata net;
                set_peer_metadata := Real.set_peer_metadata net;
                recv := Real.recv net; recv_any := Real.recv_any net;
                send := Real.send net; try_send := Real.try_send net;
                broadcast := Real.broadcast net; pool := Some (pool net);
                fold_connections :=
                  fun init => fun f => Real.fold_connections net init f;
                iter_connections := Real.iter_connections net;
                on_new_connection := Real.on_new_connection net;
                activate := Real.activate net |})
      end).

Definition activate {A B C : Type} (t : t A B C) : unit :=
  log_info
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "activate P2P layer !" % string
        CamlinternalFormatBasics.End_of_format) "activate P2P layer !" % string);
  (activate t) tt.

Definition faked_network {B C D msg : Type}
  (msg_cfg : message_config msg) (peer_cfg : peer_meta_config B)
  (faked_metadata : C) : t D B C :=
  let announced_version :=
    Tezos_base__TzPervasives.Network_version.announced (chain_name msg_cfg)
      (distributed_db_versions msg_cfg)
      Tezos_base__TzPervasives.P2p_version.supported in
  {| announced_version := announced_version; peer_id := peer_id Fake.id;
    maintain := Lwt._return; roll := Lwt._return; shutdown := Lwt._return;
    connections :=
      fun function_parameter =>
        match function_parameter with
        | tt => []
        end;
    find_connection :=
      fun function_parameter =>
        match function_parameter with
        | _ => None
        end;
    disconnect :=
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => Lwt.return_unit
            end
        end;
    connection_info :=
      fun function_parameter =>
        match function_parameter with
        | _ => Fake.connection_info announced_version faked_metadata
        end;
    connection_local_metadata :=
      fun function_parameter =>
        match function_parameter with
        | _ => faked_metadata
        end;
    connection_remote_metadata :=
      fun function_parameter =>
        match function_parameter with
        | _ => faked_metadata
        end;
    connection_stat :=
      fun function_parameter =>
        match function_parameter with
        | _ => Fake.empty_stat
        end;
    global_stat :=
      fun function_parameter =>
        match function_parameter with
        | tt => Fake.empty_stat
        end;
    get_peer_metadata :=
      fun function_parameter =>
        match function_parameter with
        | _ => (peer_meta_initial peer_cfg) tt
        end;
    set_peer_metadata :=
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => tt
            end
        end;
    recv :=
      fun function_parameter =>
        match function_parameter with
        | _ => Tezos_stdlib.Lwt_utils.never_ending tt
        end;
    recv_any :=
      fun function_parameter =>
        match function_parameter with
        | tt => Tezos_stdlib.Lwt_utils.never_ending tt
        end;
    send :=
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => Tezos_base__TzPervasives.fail P2p_errors.Connection_closed
            end
        end;
    try_send :=
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => false
            end
        end; broadcast := OCaml.Stdlib.ignore; pool := None;
    fold_connections :=
      fun init =>
        fun function_parameter =>
          match function_parameter with
          | _ => init
          end; iter_connections := fun _f => tt;
    on_new_connection := fun _f => tt;
    activate :=
      fun function_parameter =>
        match function_parameter with
        | _ => tt
        end |}.

Definition peer_id {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t := peer_id net.

Definition maintain {A B C : Type} (net : t A B C) : Lwt.t unit :=
  (maintain net) tt.

Definition roll {A B C : Type} (net : t A B C) : Lwt.t unit := (roll net) tt.

Definition shutdown {A B C : Type} (net : t A B C) : Lwt.t unit :=
  (shutdown net) tt.

Definition connections {A B C : Type} (net : t A B C)
  : list (connection A B C) := (connections net) tt.

Definition disconnect {A B C : Type} (net : t A B C)
  : (option bool) -> (connection A B C) -> Lwt.t unit := disconnect net.

Definition find_connection {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> option (connection A B C) :=
  find_connection net.

Definition connection_info {A B C : Type} (net : t A B C)
  : (connection A B C) -> Tezos_base__TzPervasives.P2p_connection.Info.t C :=
  connection_info net.

Definition connection_local_metadata {A B C : Type} (net : t A B C)
  : (connection A B C) -> C := connection_local_metadata net.

Definition connection_remote_metadata {A B C : Type} (net : t A B C)
  : (connection A B C) -> C := connection_remote_metadata net.

Definition connection_stat {A B C : Type} (net : t A B C)
  : (connection A B C) -> Tezos_base__TzPervasives.P2p_stat.t :=
  connection_stat net.

Definition global_stat {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_stat.t := (global_stat net) tt.

Definition get_peer_metadata {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> B := get_peer_metadata net.

Definition set_peer_metadata {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> B -> unit := set_peer_metadata net.

Definition recv {A B C : Type} (net : t A B C)
  : (connection A B C) -> Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  recv net.

Definition recv_any {A B C : Type} (net : t A B C)
  : Lwt.t ((connection A B C) * A) := (recv_any net) tt.

Definition send {A B C : Type} (net : t A B C)
  : (connection A B C) -> A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  send net.

Definition try_send {A B C : Type} (net : t A B C)
  : (connection A B C) -> A -> bool := try_send net.

Definition broadcast {A B C : Type} (net : t A B C) : A -> unit := broadcast net.

Definition fold_connections {A B C D : Type} (net : t A B C)
  : D ->
    (Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> D -> D) ->
      D := fold_connections net.

Definition iter_connections {A B C : Type} (net : t A B C)
  : (Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> unit) ->
    unit := iter_connections net.

Definition on_new_connection {A B C : Type} (net : t A B C)
  : (Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> unit) ->
    unit := on_new_connection net.

Definition greylist_addr {A B C : Type}
  (net : t A B C) (addr : Tezos_base__TzPervasives.P2p_addr.t) : unit :=
  Tezos_stdlib.Option.iter
    (fun pool => Tezos_p2p.P2p_pool.greylist_addr pool addr) (pool net).

Definition greylist_peer {A B C : Type}
  (net : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
  Tezos_stdlib.Option.iter
    (fun pool => Tezos_p2p.P2p_pool.greylist_peer pool peer_id) (pool net).
src/lib_p2p/p2p.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos P2p layer - Dynamic overlay network of authenticated peers.

    The P2P layer implements several mechanisms, notably:
    - It maintains pools of known points (P2P servers), peers (authenticated
      P2P servers), connections,
    - it implements an "administrative" protocol for maintaining the network
      topology,
    - it regulates bandwidth usage between connections,
    - it implements an authentication / session agreement protocol,
    - it can ban or greylist peers or IP addresses who don't behave well,
    - it offers the ability to the upper-layer to send, broadcast, or
      receive messages.

    The protocol sends/receives messages to maintain the network topology,
    and also "generic" application messages that can be sent and received
    by the upper-layer. See [P2p_message].

    The protocol may operate in *private* mode, in which only user-provided
    points (a.k.a. *trusted* ) are used. In particular, points
    advertisements and swap requests messages are ignored.

    The module [P2p_pool] maintains pools of points, peers and
    connections.

    Several workers are used:
    - [P2p_maintenance] tries to regulate the number of connections
    - [P2p_welcome] waits for incoming connections
    - [P2p_discovery] looks for points on the local network via UDP messages
    - A protocol worker implements the messaging protocol

    Points can be trusted. This is relevant in private mode
    (see above), but generally peers shouldn't advertise trusted points.

    Addresses and peers can be *banned* (a.k.a. blacklisted). In
    which case, connections to and from them should be ignored.

    Addresses or peers can be *greylisted*. As for banning, greylisting
    can be enforced via the API, but also dynamically when the peer isn't
    able to authenticate. Eventually greylisted peers are whitelisted again. *)

(** Most types of the P2p layer are parameterized by three types ['peer_meta],
    ['conn_meta], [`msg]. The concrete types, and function operating on them,
    are defined by the calling layer. *)

(** Metadata for a peer. Typically contains information used to compute the
    score of a peer. This is used to classify peers when choosing "good"
    neighbors. *)
type 'peer_meta peer_meta_config = {
  peer_meta_encoding : 'peer_meta Data_encoding.t;
      (** Encoding of the peer meta data. *)
  peer_meta_initial : unit -> 'peer_meta;
      (** Initial value for this peer meta-data *)
  score : 'peer_meta -> float;  (** Score of a peer. *)
}

(* Metadata for a connection. *)
type 'conn_meta conn_meta_config = {
  conn_meta_encoding : 'conn_meta Data_encoding.t;
  conn_meta_value : P2p_peer.Id.t -> 'conn_meta;
  private_node : 'conn_meta -> bool;
}

(* Configuration for the application protocol. ['msg] represents
   the type of the application level protocol *)
type 'msg message_config = {
  encoding : 'msg P2p_message.encoding list;  (** Encoding of the messages. *)
  chain_name : Distributed_db_version.name;
      (** Identifier for this P2p protocol when establishing session. *)
  distributed_db_versions : Distributed_db_version.t list;
      (** List of versions supported by this P2p protocol. *)
}

(** Network configuration *)
type config = {
  listening_port : P2p_addr.port option;
      (** Tells if incoming connections accepted, specifying the TCP port
      on which the peer can be reached (default: [9732])*)
  listening_addr : P2p_addr.t option;
      (** When incoming connections are accepted, precise on which
      IP address the node listen (default: [[::]]). *)
  discovery_port : P2p_addr.port option;
      (** Tells if local peer discovery is enabled, specifying the TCP port
      on which the peer can be reached (default: [10732]) *)
  discovery_addr : Ipaddr.V4.t option;
      (** When local peer discovery is enabled, precise on which
      IP address messages are broadcast (default: [255.255.255.255]). *)
  trusted_points : P2p_point.Id.t list;
      (** List of hard-coded known peers to bootstrap the network from. *)
  peers_file : string;
      (** The path to the JSON file where the metadata associated to
      peer_ids are loaded / stored. *)
  private_mode : bool;
      (** If [true], only open outgoing/accept incoming connections
      to/from peers whose addresses are in [trusted_peers], and inform
      these peers that the identity of this node should be revealed to
      the rest of the network. *)
  identity : P2p_identity.t;  (** Cryptographic identity of the peer. *)
  proof_of_work_target : Crypto_box.target;
      (** Expected level of proof of work of peers' identity. *)
  disable_mempool : bool;
      (** If [true], all non-empty mempools will be ignored. *)
  (* TODO this option is unused in lib_p2p. Should be moved outside the lib. *)
  trust_discovered_peers : bool;
      (** If [true], peers discovered on the local network will be trusted. *)
  disable_testchain : bool;
      (** If [true], testchain related messages will be ignored. *)
  (* TODO this option is unused in lib_p2p. Should be moved outside the lib. *)
  greylisting_config : P2p_point_state.Info.greylisting_config;
      (** The greylisting configuration. *)
}

(** Network capacities *)
type limits = {
  connection_timeout : Time.System.Span.t;
      (** Maximum time allowed to the establishment of a connection. *)
  authentication_timeout : Time.System.Span.t;
      (** Delay granted to a peer to perform authentication, in seconds. *)
  greylist_timeout : Time.System.Span.t;
      (** GC delay for the grelists tables, in seconds. *)
  maintenance_idle_time : Time.System.Span.t;
      (** How long to wait at most, in seconds, before running a maintenance loop. *)
  min_connections : int;
      (** Strict minimum number of connections (triggers an urgent maintenance) *)
  expected_connections : int;
      (** Targeted number of connections to reach when bootstrapping / maintaining *)
  max_connections : int;
      (** Maximum number of connections (exceeding peers are disconnected) *)
  backlog : int;  (** Argument of [Lwt_unix.accept].*)
  max_incoming_connections : int;
      (** Maximum not-yet-authenticated incoming connections. *)
  max_download_speed : int option;
      (** Hard-limit in the number of bytes received per second. *)
  max_upload_speed : int option;
      (** Hard-limit in the number of bytes sent per second. *)
  read_buffer_size : int;
      (** Size in bytes of the buffer passed to [Lwt_unix.read]. *)
  read_queue_size : int option;
  write_queue_size : int option;
  incoming_app_message_queue_size : int option;
  incoming_message_queue_size : int option;
  outgoing_message_queue_size : int option;
      (** Various bounds for internal queues. *)
  known_peer_ids_history_size : int;
  known_points_history_size : int;
      (** Size of circular log buffers, in number of events recorded. *)
  max_known_peer_ids : (int * int) option;
  max_known_points : (int * int) option;
      (** Optional limitation of internal hashtables (max, target) *)
  swap_linger : Time.System.Span.t;
      (** Peer swapping does not occur more than once during a timespan of
      [swap_linger] seconds. *)
  binary_chunks_size : int option;
      (** Size (in bytes) of binary blocks that are sent to other
      peers. Default value is 64 kB. Max value is 64kB. *)
}

(** Type of a P2P layer instance, parametrized by:
    ['msg]: type of messages exchanged between peers
    ['peer_meta]: type of the metadata associated with peers (score, etc.)
    ['conn_meta]: type of the metadata associated with connection (ack_cfg)
*)
type ('msg, 'peer_meta, 'conn_meta) t

type ('msg, 'peer_meta, 'conn_meta) net = ('msg, 'peer_meta, 'conn_meta) t

val announced_version : ('msg, 'peer_meta, 'conn_meta) net -> Network_version.t

val pool :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) P2p_pool.t option

(** A faked p2p layer, which do not initiate any connection
    nor open any listening socket *)
val faked_network :
  'msg message_config ->
  'peer_meta peer_meta_config ->
  'conn_meta ->
  ('msg, 'peer_meta, 'conn_meta) net

(** Main network initialization function *)
val create :
  config:config ->
  limits:limits ->
  'peer_meta peer_meta_config ->
  'conn_meta conn_meta_config ->
  'msg message_config ->
  ('msg, 'peer_meta, 'conn_meta) net tzresult Lwt.t

val activate : ('msg, 'peer_meta, 'conn_meta) net -> unit

(** Return one's peer_id *)
val peer_id : ('msg, 'peer_meta, 'conn_meta) net -> P2p_peer.Id.t

(** A maintenance operation : try and reach the ideal number of peers *)
val maintain : ('msg, 'peer_meta, 'conn_meta) net -> unit Lwt.t

(** Voluntarily drop some peers and replace them by new buddies *)
val roll : ('msg, 'peer_meta, 'conn_meta) net -> unit Lwt.t

(** Close all connections properly *)
val shutdown : ('msg, 'peer_meta, 'conn_meta) net -> unit Lwt.t

(** A connection to a peer *)
type ('msg, 'peer_meta, 'conn_meta) connection

(** Access the domain of active peers *)
val connections :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) connection list

(** Return the active peer with identity [peer_id] *)
val find_connection :
  ('msg, 'peer_meta, 'conn_meta) net ->
  P2p_peer.Id.t ->
  ('msg, 'peer_meta, 'conn_meta) connection option

(** Access the info of an active peer, if available *)
val connection_info :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) connection ->
  'conn_meta P2p_connection.Info.t

val connection_local_metadata :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) connection ->
  'conn_meta

val connection_remote_metadata :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) connection ->
  'conn_meta

val connection_stat :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) connection ->
  P2p_stat.t

(** Cleanly closes a connection. *)
val disconnect :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ?wait:bool ->
  ('msg, 'peer_meta, 'conn_meta) connection ->
  unit Lwt.t

val global_stat : ('msg, 'peer_meta, 'conn_meta) net -> P2p_stat.t

(** Accessors for meta information about a global identifier *)
val get_peer_metadata :
  ('msg, 'peer_meta, 'conn_meta) net -> P2p_peer.Id.t -> 'peer_meta

val set_peer_metadata :
  ('msg, 'peer_meta, 'conn_meta) net -> P2p_peer.Id.t -> 'peer_meta -> unit

(** Wait for a message from a given connection. *)
val recv :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) connection ->
  'msg tzresult Lwt.t

(** Wait for a message from any active connections. *)
val recv_any :
  ('msg, 'peer_meta, 'conn_meta) net ->
  (('msg, 'peer_meta, 'conn_meta) connection * 'msg) Lwt.t

(** [send net peer msg] is a thread that returns when [msg] has been
    successfully enqueued in the send queue. *)
val send :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) connection ->
  'msg ->
  unit tzresult Lwt.t

(** [try_send net peer msg] is [true] if [msg] has been added to the
    send queue for [peer], [false] otherwise *)
val try_send :
  ('msg, 'peer_meta, 'conn_meta) net ->
  ('msg, 'peer_meta, 'conn_meta) connection ->
  'msg ->
  bool

(** Send a message to all peers *)
val broadcast : ('msg, 'peer_meta, 'conn_meta) net -> 'msg -> unit

val fold_connections :
  ('msg, 'peer_meta, 'conn_meta) net ->
  init:'a ->
  f:(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> 'a -> 'a) ->
  'a

val iter_connections :
  ('msg, 'peer_meta, 'conn_meta) net ->
  (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
  unit

val on_new_connection :
  ('msg, 'peer_meta, 'conn_meta) net ->
  (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
  unit

val greylist_addr : ('msg, 'peer_meta, 'conn_meta) net -> P2p_addr.t -> unit

val greylist_peer : ('msg, 'peer_meta, 'conn_meta) net -> P2p_peer.Id.t -> unit
src/lib_p2p/p2p.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record peer_meta_config {peer_meta : Type} := {
  peer_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t peer_meta;
  peer_meta_initial : unit -> peer_meta;
  score : peer_meta -> float }.
Arguments peer_meta_config : clear implicits.

Record conn_meta_config {conn_meta : Type} := {
  conn_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t conn_meta;
  conn_meta_value : Tezos_base__TzPervasives.P2p_peer.Id.t -> conn_meta;
  private_node : conn_meta -> bool }.
Arguments conn_meta_config : clear implicits.

Record message_config {msg : Type} := {
  encoding : list (Tezos_p2p.P2p_message.encoding msg);
  chain_name : Tezos_base__TzPervasives.Distributed_db_version.name;
  distributed_db_versions :
    list Tezos_base__TzPervasives.Distributed_db_version.t }.
Arguments message_config : clear implicits.

Record config := {
  listening_port : option Tezos_base__TzPervasives.P2p_addr.port;
  listening_addr : option Tezos_base__TzPervasives.P2p_addr.t;
  discovery_port : option Tezos_base__TzPervasives.P2p_addr.port;
  discovery_addr : option Ipaddr.V4.t;
  trusted_points : list Tezos_base__TzPervasives.P2p_point.Id.t;
  peers_file : string;
  private_mode : bool;
  identity : Tezos_base__TzPervasives.P2p_identity.t;
  proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target;
  disable_mempool : bool;
  trust_discovered_peers : bool;
  disable_testchain : bool;
  greylisting_config : Tezos_p2p.P2p_point_state.Info.greylisting_config }.

Record limits := {
  connection_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  authentication_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  greylist_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  maintenance_idle_time : Tezos_base__TzPervasives.Time.System.Span.t;
  min_connections : Z;
  expected_connections : Z;
  max_connections : Z;
  backlog : Z;
  max_incoming_connections : Z;
  max_download_speed : option Z;
  max_upload_speed : option Z;
  read_buffer_size : Z;
  read_queue_size : option Z;
  write_queue_size : option Z;
  incoming_app_message_queue_size : option Z;
  incoming_message_queue_size : option Z;
  outgoing_message_queue_size : option Z;
  known_peer_ids_history_size : Z;
  known_points_history_size : Z;
  max_known_peer_ids : option (Z * Z);
  max_known_points : option (Z * Z);
  swap_linger : Tezos_base__TzPervasives.Time.System.Span.t;
  binary_chunks_size : option Z }.

Parameter t : forall (msg peer_meta conn_meta : Type), Type.

Definition net (msg peer_meta conn_meta : Type) := t msg peer_meta conn_meta.

Parameter announced_version : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> Tezos_base__TzPervasives.Network_version.t.

Parameter pool : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  option (Tezos_p2p.P2p_pool.t msg peer_meta conn_meta).

Parameter faked_network : forall {conn_meta msg peer_meta : Type},
(message_config msg) ->
  (peer_meta_config peer_meta) -> conn_meta -> net msg peer_meta conn_meta.

Parameter create : forall {conn_meta msg peer_meta : Type},
config ->
  limits ->
    (peer_meta_config peer_meta) ->
      (conn_meta_config conn_meta) ->
        (message_config msg) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult (net msg peer_meta conn_meta)).

Parameter activate : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> unit.

Parameter peer_id : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t.

Parameter maintain : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> Lwt.t unit.

Parameter roll : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> Lwt.t unit.

Parameter shutdown : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> Lwt.t unit.

Parameter connection : forall (msg peer_meta conn_meta : Type), Type.

Parameter connections : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> list (connection msg peer_meta conn_meta).

Parameter find_connection : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  Tezos_base__TzPervasives.P2p_peer.Id.t ->
    option (connection msg peer_meta conn_meta).

Parameter connection_info : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (connection msg peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_connection.Info.t conn_meta.

Parameter connection_local_metadata : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (connection msg peer_meta conn_meta) -> conn_meta.

Parameter connection_remote_metadata : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (connection msg peer_meta conn_meta) -> conn_meta.

Parameter connection_stat : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (connection msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_stat.t.

Parameter disconnect : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (option bool) -> (connection msg peer_meta conn_meta) -> Lwt.t unit.

Parameter global_stat : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_stat.t.

Parameter get_peer_metadata : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta.

Parameter set_peer_metadata : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta -> unit.

Parameter recv : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (connection msg peer_meta conn_meta) ->
    Lwt.t (Tezos_base__TzPervasives.tzresult msg).

Parameter recv_any : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  Lwt.t ((connection msg peer_meta conn_meta) * msg).

Parameter send : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (connection msg peer_meta conn_meta) ->
    msg -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter try_send : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (connection msg peer_meta conn_meta) -> msg -> bool.

Parameter broadcast : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> msg -> unit.

Parameter fold_connections : forall {a conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  a ->
    (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (connection msg peer_meta conn_meta) -> a -> a) -> a.

Parameter iter_connections : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (Tezos_base__TzPervasives.P2p_peer.Id.t ->
    (connection msg peer_meta conn_meta) -> unit) -> unit.

Parameter on_new_connection : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) ->
  (Tezos_base__TzPervasives.P2p_peer.Id.t ->
    (connection msg peer_meta conn_meta) -> unit) -> unit.

Parameter greylist_addr : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_addr.t -> unit.

Parameter greylist_peer : forall {conn_meta msg peer_meta : Type},
(net msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
src/lib_p2p/p2p_acl.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module PeerRing = Ring.MakeTable (struct
  include P2p_peer.Id
end)

module PatriciaTree (V : HashPtree.Value) = struct
  module Size = struct
    let size = 128
  end

  module Bits = HashPtree.Bits (Size)
  module M = HashPtree.Make_BE_sized (V) (Size)

  type t = M.t

  let empty = M.empty

  (* take into consideration the fact that the int64
   * returned by Ipaddr.V6.to_int64 is signed *)
  let z_of_bytes i =
    let i = Z.of_int64 i in
    Z.(if i < zero then i + (of_int 2 ** 64) else i)

  let z_of_ipv6 ip =
    let (hi_x, lo_x) = Ipaddr.V6.to_int64 ip in
    let hi = z_of_bytes hi_x in
    let lo = z_of_bytes lo_x in
    Z.((hi lsl 64) + lo)

  let key_of_ipv6 ip = Bits.of_z (z_of_ipv6 ip)

  let z_mask_of_ipv6_prefix p =
    let ip = Ipaddr.V6.Prefix.network p in
    let len = Ipaddr.V6.Prefix.bits p in
    (z_of_ipv6 ip, Z.( lsl ) Z.one (128 - len))

  let key_mask_of_ipv6_prefix p =
    let (z, m) = z_mask_of_ipv6_prefix p in
    (Bits.of_z z, Bits.of_z m)

  let z_to_ipv6 z =
    (* assumes z is a 128 bit value *)
    let hi_z = Z.(z asr 64) in
    let hi =
      if Z.(hi_z >= of_int 2 ** 63) then
        (* If overflows int64, then returns the bit equivalent
           representation (which is negative) *)
        Int64.add 0x8000000000000000L Z.(to_int64 (hi_z - (of_int 2 ** 63)))
      else Z.(to_int64 hi_z)
    in
    let lo = Z.(to_int64 (z mod pow ~$2 64)) in
    Ipaddr.V6.of_int64 (hi, lo)

  let remove key t = M.remove (key_of_ipv6 key) t

  let remove_prefix prefix t =
    let (key, mask) = key_mask_of_ipv6_prefix prefix in
    M.remove_prefix key mask t

  let add_prefix prefix value t =
    let (key, mask) = key_mask_of_ipv6_prefix prefix in
    M.add (fun _ v -> v) ~key ~value ~mask t

  let add key value t =
    let key = key_of_ipv6 key in
    M.add (fun _ v -> v) ~key ~value t

  let mem key t = M.mem (key_of_ipv6 key) t

  let key_mask_to_prefix key mask =
    let len =
      if Bits.(equal mask zero) then 0
      else 128 - Z.trailing_zeros (Bits.to_z mask)
    in
    Ipaddr.V6.Prefix.make len (z_to_ipv6 (Bits.to_z key))

  let fold f t acc =
    let f key mask value acc =
      let prefix = key_mask_to_prefix key mask in
      f prefix value acc
    in
    M.fold f t acc

  let pp ppf t =
    let lst = fold (fun p _ l -> p :: l) t [] in
    Format.fprintf
      ppf
      "@[<2>[%a]@]"
      Format.(
        pp_print_list
          ~pp_sep:(fun ppf () -> fprintf ppf ";@ ")
          Ipaddr.V6.Prefix.pp)
      lst
end

(* patricia trees using IpV6 addresses as keys *)
module IpSet = struct
  include PatriciaTree (Time.System)

  let remove_old t ~older_than =
    let module MI = struct
      type result = Time.System.t

      let default = Ptime.max

      let map _t _key value = value

      let reduce _t left right = Time.System.(min left right)
    end in
    let module MR = M.Map_Reduce (MI) in
    MR.filter (fun addtime -> Time.System.(older_than <= addtime)) t
end

module IpTable = Hashtbl.Make (struct
  type t = Ipaddr.V6.t

  let hash = Hashtbl.hash

  let equal x y = Ipaddr.V6.compare x y = 0
end)

type t = {
  mutable greylist_ips : IpSet.t;
  greylist_peers : PeerRing.t;
  banned_ips : unit IpTable.t;
  banned_peers : unit P2p_peer.Table.t;
}

let create size =
  {
    greylist_ips = IpSet.empty;
    greylist_peers = PeerRing.create size;
    banned_ips = IpTable.create 53;
    banned_peers = P2p_peer.Table.create 53;
  }

(* check if an ip is banned. priority is for static blacklist, then
   in the greylist *)
let banned_addr acl addr =
  IpTable.mem acl.banned_ips addr || IpSet.mem addr acl.greylist_ips

let unban_addr acl addr =
  IpTable.remove acl.banned_ips addr ;
  acl.greylist_ips <- IpSet.remove addr acl.greylist_ips

(* Check is the peer_id is in the banned ring. It might be possible that
   a peer ID that is not banned, but its ip address is. *)
let banned_peer acl peer_id =
  P2p_peer.Table.mem acl.banned_peers peer_id
  || PeerRing.mem acl.greylist_peers peer_id

let unban_peer acl peer_id =
  P2p_peer.Table.remove acl.banned_peers peer_id ;
  PeerRing.remove acl.greylist_peers peer_id

let clear acl =
  acl.greylist_ips <- IpSet.empty ;
  P2p_peer.Table.clear acl.banned_peers ;
  IpTable.clear acl.banned_ips ;
  PeerRing.clear acl.greylist_peers

module IPGreylist = struct
  let add acl addr time =
    acl.greylist_ips <- IpSet.add addr time acl.greylist_ips

  let mem acl addr = IpSet.mem addr acl.greylist_ips

  (* The GC operation works only on the address set. Peers are removed
     from the ring in a round-robin fashion. If a address is removed
     by the GC from the acl.greylist set, it could potentially
     persist in the acl.peers set until more peers are banned. *)
  let remove_old acl ~older_than =
    acl.greylist_ips <- IpSet.remove_old acl.greylist_ips ~older_than

  let encoding = Data_encoding.(list P2p_addr.encoding)
end

module IPBlacklist = struct
  let add acl addr = IpTable.add acl.banned_ips addr ()

  let mem acl addr = IpTable.mem acl.banned_ips addr
end

module PeerBlacklist = struct
  let add acl addr = P2p_peer.Table.add acl.banned_peers addr ()

  let mem acl addr = P2p_peer.Table.mem acl.banned_peers addr
end

module PeerGreylist = struct
  let add acl peer_id = PeerRing.add acl.greylist_peers peer_id

  let mem acl peer_id = PeerRing.mem acl.greylist_peers peer_id
end
src/lib_p2p/p2p_acl.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module IpSet.
  Definition remove_old
    (t : M.t) (older_than : Tezos_base__TzPervasives.Time.System.t) : M.t :=
    let MI :=
      existT _ unit
        {|
          M.Map_Reduce.default := Ptime.max
          |} in
    let MR := unsupported_functor_application in
    MR.filter
      (fun addtime =>
        Tezos_base__TzPervasives.Time.System.op_lt_eq older_than addtime) t.
End IpSet.

Record t := {
  greylist_ips : IpSet.t;
  greylist_peers : PeerRing.t;
  banned_ips : IpTable.t unit;
  banned_peers : Tezos_base__TzPervasives.P2p_peer.Table.t unit }.

Definition create (size : Z) : t :=
  {| greylist_ips := IpSet.empty; greylist_peers := PeerRing.create size;
    banned_ips := IpTable.create 53;
    banned_peers := Tezos_base__TzPervasives.P2p_peer.Table.create 53 |}.

Definition banned_addr (acl : t) (addr : IpTable.key) : bool :=
  orb (IpTable.mem (banned_ips acl) addr) (IpSet.mem addr (greylist_ips acl)).

Definition unban_addr (acl : t) (addr : IpTable.key) : unit :=
  IpTable.remove (banned_ips acl) addr;
  set_field.

Definition banned_peer
  (acl : t) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key) : bool :=
  orb (Tezos_base__TzPervasives.P2p_peer.Table.mem (banned_peers acl) peer_id)
    (PeerRing.mem (greylist_peers acl) peer_id).

Definition unban_peer
  (acl : t) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key) : unit :=
  Tezos_base__TzPervasives.P2p_peer.Table.remove (banned_peers acl) peer_id;
  PeerRing.remove (greylist_peers acl) peer_id.

Definition clear (acl : t) : unit :=
  set_field;
  Tezos_base__TzPervasives.P2p_peer.Table.clear (banned_peers acl);
  IpTable.clear (banned_ips acl);
  PeerRing.clear (greylist_peers acl).

Module IPGreylist.
  Definition add (acl : t) (addr : Ipaddr.V6.t) (time : IpSet.M.value) : unit :=
    set_field.
  
  Definition mem (acl : t) (addr : Ipaddr.V6.t) : bool :=
    IpSet.mem addr (greylist_ips acl).
  
  Definition remove_old
    (acl : t) (older_than : Tezos_base__TzPervasives.Time.System.t) : unit :=
    set_field.
  
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (list Tezos_base__TzPervasives.P2p_addr.t) :=
    Tezos_base__TzPervasives.Data_encoding.list None
      Tezos_base__TzPervasives.P2p_addr.encoding.
End IPGreylist.

Module IPBlacklist.
  Definition add (acl : t) (addr : IpTable.key) : unit :=
    IpTable.add (banned_ips acl) addr tt.
  
  Definition mem (acl : t) (addr : IpTable.key) : bool :=
    IpTable.mem (banned_ips acl) addr.
End IPBlacklist.

Module PeerBlacklist.
  Definition add (acl : t) (addr : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit :=
    Tezos_base__TzPervasives.P2p_peer.Table.add (banned_peers acl) addr tt.
  
  Definition mem (acl : t) (addr : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : bool :=
    Tezos_base__TzPervasives.P2p_peer.Table.mem (banned_peers acl) addr.
End PeerBlacklist.

Module PeerGreylist.
  Definition add (acl : t) (peer_id : PeerRing.v) : unit :=
    PeerRing.add (greylist_peers acl) peer_id.
  
  Definition mem (acl : t) (peer_id : PeerRing.v) : bool :=
    PeerRing.mem (greylist_peers acl) peer_id.
End PeerGreylist.
src/lib_p2p/p2p_acl.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**
   This module implements four Access Control Lists:
   - IP greylist is a set of banned IP addresses automatically added by
     the P2P layer.
   - [peer_id] greylist is a set of banned peers ids automatically added by
     the P2P layer.
   - IP blacklist is a set of IP addresses manually added by the node admin.
   - peers blacklist is a set of peers ids manually added by the node admin.

   IP greylists use a time based GC to periodically remove entries from
   the table, while [peer_id] greylists are built using a ring structure,
   where peers are removed from the table when removed from the fixed size
   ring. Other tables are user defined and static.

*)

type t

(** [create size] is a set of four ACLs (see above) with the peer_id
    greylist being a ring buffer of size [size]. *)
val create : int -> t

(** [banned_addr t addr] is [true] if [addr] is blacklisted or
    greylisted. *)
val banned_addr : t -> P2p_addr.t -> bool

val unban_addr : t -> P2p_addr.t -> unit

(** [banned_peer t peer_id] is [true] if peer with id [peer_id] is
    blacklisted or greylisted. *)
val banned_peer : t -> P2p_peer.Id.t -> bool

val unban_peer : t -> P2p_peer.Id.t -> unit

(** [clear t] clears all four ACLs. *)
val clear : t -> unit

module IPGreylist : sig
  (** [add t addr] adds [addr] to the address greylist. *)
  val add : t -> P2p_addr.t -> Time.System.t -> unit

  (** [remove_old t ~older_than] removes all banned peers older than the
      given time. *)
  val remove_old : t -> older_than:Time.System.t -> unit

  val mem : t -> P2p_addr.t -> bool

  val encoding : P2p_addr.t list Data_encoding.t
end

module IPBlacklist : sig
  val add : t -> P2p_addr.t -> unit

  val mem : t -> P2p_addr.t -> bool
end

module PeerBlacklist : sig
  val add : t -> P2p_peer.Id.t -> unit

  val mem : t -> P2p_peer.Id.t -> bool
end

module PeerGreylist : sig
  val add : t -> P2p_peer.Id.t -> unit

  val mem : t -> P2p_peer.Id.t -> bool
end

(** / *)

module PeerRing : Ring.TABLE with type v = P2p_peer.Id.t

module IpSet : sig
  type t

  val empty : t

  val add : Ipaddr.V6.t -> Time.System.t -> t -> t

  val add_prefix : Ipaddr.V6.Prefix.t -> Time.System.t -> t -> t

  val remove : Ipaddr.V6.t -> t -> t

  val remove_prefix : Ipaddr.V6.Prefix.t -> t -> t

  val mem : Ipaddr.V6.t -> t -> bool

  val fold : (Ipaddr.V6.Prefix.t -> Time.System.t -> 'a -> 'a) -> t -> 'a -> 'a

  val pp : Format.formatter -> t -> unit

  val remove_old : t -> older_than:Time.System.t -> t
end

module IpTable : Hashtbl.S with type key = Ipaddr.V6.t
src/lib_p2p/p2p_acl.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create : Z -> t.

Parameter banned_addr : t -> Tezos_base__TzPervasives.P2p_addr.t -> bool.

Parameter unban_addr : t -> Tezos_base__TzPervasives.P2p_addr.t -> unit.

Parameter banned_peer : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> bool.

Parameter unban_peer : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.

Parameter clear : t -> unit.

Module IPGreylist.
  Parameter add : t ->
    Tezos_base__TzPervasives.P2p_addr.t ->
      Tezos_base__TzPervasives.Time.System.t -> unit.
  
  Parameter remove_old : t -> Tezos_base__TzPervasives.Time.System.t -> unit.
  
  Parameter mem : t -> Tezos_base__TzPervasives.P2p_addr.t -> bool.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t
    (list Tezos_base__TzPervasives.P2p_addr.t).
End IPGreylist.

Module IPBlacklist.
  Parameter add : t -> Tezos_base__TzPervasives.P2p_addr.t -> unit.
  
  Parameter mem : t -> Tezos_base__TzPervasives.P2p_addr.t -> bool.
End IPBlacklist.

Module PeerBlacklist.
  Parameter add : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter mem : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> bool.
End PeerBlacklist.

Module PeerGreylist.
  Parameter add : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter mem : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> bool.
End PeerGreylist.

unhandled_module

Module IpSet.
  Parameter t : Type.
  
  Parameter empty : t.
  
  Parameter add : Ipaddr.V6.t ->
    Tezos_base__TzPervasives.Time.System.t -> t -> t.
  
  Parameter add_prefix : Ipaddr.V6.Prefix.t ->
    Tezos_base__TzPervasives.Time.System.t -> t -> t.
  
  Parameter remove : Ipaddr.V6.t -> t -> t.
  
  Parameter remove_prefix : Ipaddr.V6.Prefix.t -> t -> t.
  
  Parameter mem : Ipaddr.V6.t -> t -> bool.
  
  Parameter fold : forall {a : Type}, (Ipaddr.V6.Prefix.t ->
    Tezos_base__TzPervasives.Time.System.t -> a -> a) -> t -> a -> a.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
  
  Parameter remove_old : t -> Tezos_base__TzPervasives.Time.System.t -> t.
End IpSet.

unhandled_module
src/lib_p2p/p2p_answerer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.answerer"
end)

type 'msg callback = {
  bootstrap : unit -> P2p_point.Id.t list Lwt.t;
  advertise : P2p_point.Id.t list -> unit Lwt.t;
  message : int -> 'msg -> unit Lwt.t;
  swap_request : P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t;
  swap_ack : P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t;
}

type ('msg, 'meta) t = {
  canceler : Lwt_canceler.t;
  conn : ('msg P2p_message.t, 'meta) P2p_socket.t;
  callback : 'msg callback;
  mutable worker : unit Lwt.t;
}

let rec worker_loop st =
  Lwt_unix.yield ()
  >>= fun () ->
  protect ~canceler:st.canceler (fun () -> P2p_socket.read st.conn)
  >>= function
  | Ok (_, Bootstrap) -> (
      (* st.callback.bootstrap will return an empty list if the node
         is in private mode *)
      st.callback.bootstrap ()
      >>= function
      | [] ->
          worker_loop st
      | points -> (
        match P2p_socket.write_now st.conn (Advertise points) with
        | Ok _sent ->
            (* if not sent then ?? TODO count dropped message ?? *)
            worker_loop st
        | Error _ ->
            Lwt_canceler.cancel st.canceler ) )
  | Ok (_, Advertise points) ->
      (* st.callback.advertise will ignore the points if the node is
         in private mode *)
      st.callback.advertise points >>= fun () -> worker_loop st
  | Ok (_, Swap_request (point, peer)) ->
      st.callback.swap_request point peer >>= fun () -> worker_loop st
  | Ok (_, Swap_ack (point, peer)) ->
      st.callback.swap_ack point peer >>= fun () -> worker_loop st
  | Ok (size, Message msg) ->
      st.callback.message size msg >>= fun () -> worker_loop st
  | Ok (_, Disconnect) | Error (P2p_errors.Connection_closed :: _) ->
      Lwt_canceler.cancel st.canceler
  | Error (P2p_errors.Decoding_error :: _) ->
      (* TODO: Penalize peer... *)
      Lwt_canceler.cancel st.canceler
  | Error (Canceled :: _) ->
      Lwt.return_unit
  | Error err ->
      lwt_log_error
        "@[Answerer unexpected error:@ %a@]"
        Error_monad.pp_print_error
        err
      >>= fun () -> Lwt_canceler.cancel st.canceler

let run conn canceler callback =
  let st = {canceler; conn; callback; worker = Lwt.return_unit} in
  st.worker <-
    Lwt_utils.worker
      "answerer"
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> worker_loop st)
      ~cancel:(fun () -> Lwt_canceler.cancel canceler) ;
  st

let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
src/lib_p2p/p2p_answerer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record callback {msg : Type} := {
  bootstrap : unit -> Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t);
  advertise : (list Tezos_base__TzPervasives.P2p_point.Id.t) -> Lwt.t unit;
  message : Z -> msg -> Lwt.t unit;
  swap_request :
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit;
  swap_ack :
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit }.
Arguments callback : clear implicits.

Record t {msg meta : Type} := {
  canceler : Tezos_stdlib.Lwt_canceler.t;
  conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t msg) meta;
  callback : callback msg;
  worker : Lwt.t unit }.
Arguments t : clear implicits.

Fixpoint worker_loop {A B : Type} (st : t A B) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_base__TzPervasives.protect None (Some (canceler st))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_p2p.P2p_socket.read (conn st)
              end))
          (fun function_parameter =>
            match function_parameter with
            | inl (_, Bootstrap) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                ((bootstrap (callback st)) tt)
                (fun function_parameter =>
                  match function_parameter with
                  | [] => worker_loop st
                  | points =>
                    match
                      Tezos_p2p.P2p_socket.write_now (conn st)
                        (Advertise points) with
                    | inl _sent => worker_loop st
                    | inr _ => Tezos_stdlib.Lwt_canceler.cancel (canceler st)
                    end
                  end)
            | inl (_, Advertise points) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                ((advertise (callback st)) points)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => worker_loop st
                  end)
            | inl (_, Swap_request point peer) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                ((swap_request (callback st)) point peer)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => worker_loop st
                  end)
            | inl (_, Swap_ack point peer) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                ((swap_ack (callback st)) point peer)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => worker_loop st
                  end)
            | inl (size, Message msg) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                ((message (callback st)) size msg)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => worker_loop st
                  end)
            | inl (_, Disconnect) | inr (cons P2p_errors.Connection_closed _) =>
              Tezos_stdlib.Lwt_canceler.cancel (canceler st)
            | inr (cons P2p_errors.Decoding_error _) =>
              Tezos_stdlib.Lwt_canceler.cancel (canceler st)
            | inr (cons Canceled _) => Lwt.return_unit
            | inr err =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (lwt_log_error
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Answerer unexpected error:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))
                    "@[Answerer unexpected error:@ %a@]" % string)
                  Tezos_base__TzPervasives.Error_monad.pp_print_error err)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_stdlib.Lwt_canceler.cancel (canceler st)
                  end)
            end)
      end).

Definition run {A B : Type}
  (conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t A) B)
  (canceler : Tezos_stdlib.Lwt_canceler.t) (callback : callback A) : t A B :=
  let st :=
    {| canceler := canceler; conn := conn; callback := callback;
      worker := Lwt.return_unit |} in
  set_field;
  st.

Definition shutdown {A B : Type} (st : t A B) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_stdlib.Lwt_canceler.cancel (canceler st))
    (fun function_parameter =>
      match function_parameter with
      | tt => worker st
      end).
src/lib_p2p/p2p_answerer.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This module defines an answering worker that replies to [P2p_message.t]
    using callbacks. *)

type 'msg callback = {
  bootstrap : unit -> P2p_point.Id.t list Lwt.t;
  advertise : P2p_point.Id.t list -> unit Lwt.t;
  message : int -> 'msg -> unit Lwt.t;
  swap_request : P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t;
  swap_ack : P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t;
}

type ('msg, 'meta) t

val shutdown : ('msg, 'meta) t -> unit Lwt.t

val run :
  ('msg P2p_message.t, 'meta) P2p_socket.t ->
  Lwt_canceler.t ->
  'msg callback ->
  ('msg, 'meta) t
src/lib_p2p/p2p_answerer.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record callback {msg : Type} := {
  bootstrap : unit -> Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t);
  advertise : (list Tezos_base__TzPervasives.P2p_point.Id.t) -> Lwt.t unit;
  message : Z -> msg -> Lwt.t unit;
  swap_request :
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit;
  swap_ack :
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit }.
Arguments callback : clear implicits.

Parameter t : forall (msg meta : Type), Type.

Parameter shutdown : forall {meta msg : Type}, (t msg meta) -> Lwt.t unit.

Parameter run : forall {meta msg : Type},
(Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t msg) meta) ->
  Tezos_stdlib.Lwt_canceler.t -> (callback msg) -> t msg meta.
src/lib_p2p/p2p_discovery.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.discovery"
end)

type pool = Pool : ('msg, 'meta, 'meta_conn) P2p_pool.t -> pool

module Message = struct
  let encoding =
    Data_encoding.(tup3 (Fixed.string 10) P2p_peer.Id.encoding int16)

  let length = Data_encoding.Binary.fixed_length_exn encoding

  let key = "DISCOMAGIC"

  let make peer_id port =
    Data_encoding.Binary.to_bytes_exn encoding (key, peer_id, port)
end

module Answer = struct
  type t = {
    my_peer_id : P2p_peer.Id.t;
    pool : pool;
    discovery_port : int;
    canceler : Lwt_canceler.t;
    trust_discovered_peers : bool;
    mutable worker : unit Lwt.t;
  }

  let create_socket st =
    Lwt.catch
      (fun () ->
        let socket = Lwt_unix.socket PF_INET SOCK_DGRAM 0 in
        Lwt_canceler.on_cancel st.canceler (fun () ->
            Lwt_utils_unix.safe_close socket) ;
        Lwt_unix.setsockopt socket SO_BROADCAST true ;
        Lwt_unix.setsockopt socket SO_REUSEADDR true ;
        let addr =
          Lwt_unix.ADDR_INET (Unix.inet_addr_any, st.discovery_port)
        in
        Lwt_unix.bind socket addr >>= fun () -> Lwt.return socket)
      (fun exn ->
        lwt_debug "Error creating a socket" >>= fun () -> Lwt.fail exn)

  let loop st =
    protect ~canceler:st.canceler (fun () ->
        create_socket st >>= fun socket -> return socket)
    >>=? fun socket ->
    (* Infinite loop, should never exit. *)
    let rec aux () =
      let buf = Bytes.create Message.length in
      protect ~canceler:st.canceler (fun () ->
          Lwt_unix.recvfrom socket buf 0 Message.length []
          >>= fun content ->
          lwt_debug "Received discovery message..."
          >>= fun () -> return content)
      >>=? function
      | (len, Lwt_unix.ADDR_INET (remote_addr, _))
        when Compare.Int.equal len Message.length -> (
        match Data_encoding.Binary.of_bytes Message.encoding buf with
        | Some (key, remote_peer_id, remote_port)
          when Compare.String.equal key Message.key
               && not (P2p_peer.Id.equal remote_peer_id st.my_peer_id) -> (
            let s_addr = Unix.string_of_inet_addr remote_addr in
            match P2p_addr.of_string_opt s_addr with
            | None ->
                lwt_debug "Failed to parse %S\n@." s_addr >>= fun () -> aux ()
            | Some addr ->
                let (Pool pool) = st.pool in
                lwt_log_info
                  "Registering new point %a:%d"
                  P2p_addr.pp
                  addr
                  remote_port
                >>= fun () ->
                P2p_pool.register_new_point
                  ~trusted:st.trust_discovered_peers
                  pool
                  st.my_peer_id
                  (addr, remote_port) ;
                aux () )
        | _ ->
            aux () )
      | _ ->
          aux ()
    in
    aux ()

  let worker_loop st =
    loop st
    >>= function
    | Error (Canceled :: _) ->
        Lwt.return_unit
    | Error err ->
        lwt_log_error
          "@[<v 2>Unexpected error in answer worker@ %a@]"
          pp_print_error
          err
        >>= fun () -> Lwt_canceler.cancel st.canceler
    | Ok () ->
        lwt_log_error "@[<v 2>Unexpected exit in answer worker@]"
        >>= fun () -> Lwt_canceler.cancel st.canceler

  let create my_peer_id pool ~trust_discovered_peers ~discovery_port =
    {
      canceler = Lwt_canceler.create ();
      my_peer_id;
      discovery_port;
      trust_discovered_peers;
      pool = Pool pool;
      worker = Lwt.return_unit;
    }

  let activate st =
    st.worker <-
      Lwt_utils.worker
        "discovery_answer"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop st)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler)
end

(* ************************************************************ *)
(* Sender  *)

module Sender = struct
  type t = {
    canceler : Lwt_canceler.t;
    my_peer_id : P2p_peer.Id.t;
    listening_port : int;
    discovery_port : int;
    discovery_addr : Ipaddr.V4.t;
    pool : pool;
    restart_discovery : unit Lwt_condition.t;
    mutable worker : unit Lwt.t;
  }

  module Config = struct
    type t = {delay : float; loop : int}

    let initial = {delay = 0.1; loop = 0}

    let increase_delay config = {config with delay = 2.0 *. config.delay}

    let max_loop = 10
  end

  let broadcast_message st =
    let msg = Message.make st.my_peer_id st.listening_port in
    Lwt.catch
      (fun () ->
        let socket = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in
        Lwt_canceler.on_cancel st.canceler (fun () ->
            Lwt_utils_unix.safe_close socket) ;
        Lwt_unix.setsockopt socket Lwt_unix.SO_BROADCAST true ;
        let broadcast_ipv4 = Ipaddr_unix.V4.to_inet_addr st.discovery_addr in
        let addr = Lwt_unix.ADDR_INET (broadcast_ipv4, st.discovery_port) in
        Lwt_unix.connect socket addr
        >>= fun () ->
        lwt_debug "Broadcasting discovery message..."
        >>= fun () ->
        Lwt_unix.sendto socket msg 0 Message.length [] addr
        >>= fun _len -> Lwt_utils_unix.safe_close socket)
      (fun _exn -> lwt_debug "Error broadcasting a discovery request")

  let rec worker_loop sender_config st =
    protect ~canceler:st.canceler (fun () ->
        broadcast_message st >>= fun () -> return_unit)
    >>=? (fun () ->
           protect ~canceler:st.canceler (fun () ->
               Lwt.pick
                 [ ( Lwt_condition.wait st.restart_discovery
                   >>= fun () -> return Config.initial );
                   ( Lwt_unix.sleep sender_config.Config.delay
                   >>= fun () ->
                   return
                     {sender_config with Config.loop = succ sender_config.loop}
                   ) ]))
    >>= function
    | Ok config when config.Config.loop = Config.max_loop ->
        let new_sender_config = {config with Config.loop = pred config.loop} in
        worker_loop new_sender_config st
    | Ok config ->
        let new_sender_config = Config.increase_delay config in
        worker_loop new_sender_config st
    | Error (Canceled :: _) ->
        Lwt.return_unit
    | Error err ->
        lwt_log_error
          "@[<v 2>Unexpected error in sender worker@ %a@]"
          pp_print_error
          err
        >>= fun () -> Lwt_canceler.cancel st.canceler

  let create my_peer_id pool ~listening_port ~discovery_port ~discovery_addr =
    {
      canceler = Lwt_canceler.create ();
      my_peer_id;
      listening_port;
      discovery_port;
      discovery_addr;
      restart_discovery = Lwt_condition.create ();
      pool = Pool pool;
      worker = Lwt.return_unit;
    }

  let activate st =
    st.worker <-
      Lwt_utils.worker
        "discovery_sender"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop Config.initial st)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler)
end

(* ********************************************************************** *)

type t = {answer : Answer.t; sender : Sender.t}

let create ~listening_port ~discovery_port ~discovery_addr
    ~trust_discovered_peers pool my_peer_id =
  let answer =
    Answer.create my_peer_id pool ~discovery_port ~trust_discovered_peers
  in
  let sender =
    Sender.create
      my_peer_id
      pool
      ~listening_port
      ~discovery_port
      ~discovery_addr
  in
  {answer; sender}

let activate {answer; sender} = Answer.activate answer ; Sender.activate sender

let wakeup t = Lwt_condition.signal t.sender.restart_discovery ()

let shutdown t =
  Lwt.join
    [ Lwt_canceler.cancel t.answer.canceler;
      Lwt_canceler.cancel t.sender.canceler ]
src/lib_p2p/p2p_discovery.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive pool : Type :=
| Pool : forall {meta meta_conn msg : Type},
  (Tezos_p2p.P2p_pool.t msg meta meta_conn) -> pool.

Module Message.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (string * Tezos_base__TzPervasives.P2p_peer.Id.t * Z) :=
    Tezos_base__TzPervasives.Data_encoding.tup3
      (Tezos_base__TzPervasives.Data_encoding.Fixed.string 10)
      Tezos_base__TzPervasives.P2p_peer.Id.encoding
      Tezos_base__TzPervasives.Data_encoding.int16.
  
  Definition length : Z :=
    Tezos_base__TzPervasives.Data_encoding.Binary.fixed_length_exn encoding.
  
  Definition key : string := "DISCOMAGIC" % string.
  
  Definition make (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) (port : Z)
    : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn encoding
      (key, peer_id, port).
End Message.

Module Answer.
  Record t := {
    my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
    pool : pool;
    discovery_port : Z;
    canceler : Tezos_stdlib.Lwt_canceler.t;
    trust_discovered_peers : bool;
    worker : Lwt.t unit }.
  
  Definition create_socket (st : t) : Lwt.t Lwt_unix.file_descr :=
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let socket := Lwt_unix.socket PF_INET SOCK_DGRAM 0 in
          Tezos_stdlib.Lwt_canceler.on_cancel (canceler st)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_stdlib_unix.Lwt_utils_unix.safe_close socket
              end);
          Lwt_unix.setsockopt socket SO_BROADCAST true;
          Lwt_unix.setsockopt socket SO_REUSEADDR true;
          let addr := Lwt_unix.ADDR_INET Unix.inet_addr_any (discovery_port st)
            in
          Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.bind socket addr)
            (fun function_parameter =>
              match function_parameter with
              | tt => Lwt._return socket
              end)
        end)
      (fun exn =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Error creating a socket" % string
                CamlinternalFormatBasics.End_of_format)
              "Error creating a socket" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt.fail exn
            end)).
  
  Definition loop {A : Type} (st : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.protect None (Some (canceler st))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq (create_socket st)
              (fun socket => Tezos_base__TzPervasives._return socket)
          end))
      (fun socket =>
        let fix aux {B : Type} (function_parameter : unit)
          : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
          match function_parameter with
          | tt =>
            let buf := Stdlib.Bytes.create Message.length in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.protect None (Some (canceler st))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Lwt_unix.recvfrom socket buf 0 Message.length [])
                      (fun content =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (lwt_debug
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Received discovery message..." % string
                                CamlinternalFormatBasics.End_of_format)
                              "Received discovery message..." % string))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives._return content
                            end))
                  end))
              (fun function_parameter =>
                match function_parameter with
                | (len, Lwt_unix.ADDR_INET remote_addr _) =>
                  match
                    Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
                      Message.encoding buf with
                  | _ => aux tt
                  end
                | _ => aux tt
                end)
          end in
        aux tt).
  
  Definition worker_loop (st : t) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq (loop st)
      (fun function_parameter =>
        match function_parameter with
        | inr (cons Canceled _) => Lwt.return_unit
        | inr err =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Unexpected error in answer worker" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))
                "@[<v 2>Unexpected error in answer worker@ %a@]" % string)
              Tezos_base__TzPervasives.pp_print_error err)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_stdlib.Lwt_canceler.cancel (canceler st)
              end)
        | inl tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Unexpected exit in answer worker" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))
                "@[<v 2>Unexpected exit in answer worker@]" % string))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_stdlib.Lwt_canceler.cancel (canceler st)
              end)
        end).
  
  Definition create {A B C : Type}
    (my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    (pool : Tezos_p2p.P2p_pool.t A B C) (trust_discovered_peers : bool)
    (discovery_port : Z) : t :=
    {| my_peer_id := my_peer_id; pool := Pool pool;
      discovery_port := discovery_port;
      canceler := Tezos_stdlib.Lwt_canceler.create tt;
      trust_discovered_peers := trust_discovered_peers;
      worker := Lwt.return_unit |}.
  
  Definition activate (st : t) : unit := set_field.
End Answer.

Module Sender.
  Record t := {
    canceler : Tezos_stdlib.Lwt_canceler.t;
    my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
    listening_port : Z;
    discovery_port : Z;
    discovery_addr : Ipaddr.V4.t;
    pool : pool;
    restart_discovery : Lwt_condition.t unit;
    worker : Lwt.t unit }.
  
  Module Config.
    Record t := {
      delay : float;
      loop : Z }.
    
    Definition initial : t := {| delay := 0; loop := 0 |}.
    
    Definition increase_delay (config : t) : t := record.
    
    Definition max_loop : Z := 10.
  End Config.
  
  Definition broadcast_message (st : t) : Lwt.t unit :=
    let msg := Message.make (my_peer_id st) (listening_port st) in
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let socket := Lwt_unix.socket PF_INET SOCK_DGRAM 0 in
          Tezos_stdlib.Lwt_canceler.on_cancel (canceler st)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_stdlib_unix.Lwt_utils_unix.safe_close socket
              end);
          Lwt_unix.setsockopt socket Lwt_unix.SO_BROADCAST true;
          let broadcast_ipv4 := Ipaddr_unix.V4.to_inet_addr (discovery_addr st)
            in
          let addr := Lwt_unix.ADDR_INET broadcast_ipv4 (discovery_port st) in
          Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.connect socket addr)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_debug
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Broadcasting discovery message..." % string
                        CamlinternalFormatBasics.End_of_format)
                      "Broadcasting discovery message..." % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Lwt_unix.sendto socket msg 0 Message.length [] addr)
                        (fun _len =>
                          Tezos_stdlib_unix.Lwt_utils_unix.safe_close socket)
                    end)
              end)
        end)
      (fun _exn =>
        lwt_debug
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Error broadcasting a discovery request" % string
              CamlinternalFormatBasics.End_of_format)
            "Error broadcasting a discovery request" % string)).
  
  Fixpoint worker_loop (sender_config : Config.t) (st : t) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_base__TzPervasives.protect None (Some (canceler st))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq (broadcast_message st)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            end))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.protect None (Some (canceler st))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Lwt.pick
                    (cons
                      (Tezos_base__TzPervasives.op_gt_gt_eq
                        (Lwt_condition.wait None (restart_discovery st))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives._return Config.initial
                          end))
                      (cons
                        (Tezos_base__TzPervasives.op_gt_gt_eq
                          (Lwt_unix.sleep (Config.delay sender_config))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives._return record
                            end)) []))
                end)
          end))
      (fun function_parameter =>
        match function_parameter with
        | inl config =>
          let new_sender_config := record in
          worker_loop new_sender_config st
        | inl config =>
          let new_sender_config := Config.increase_delay config in
          worker_loop new_sender_config st
        | inr (cons Canceled _) => Lwt.return_unit
        | inr err =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Unexpected error in sender worker" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))
                "@[<v 2>Unexpected error in sender worker@ %a@]" % string)
              Tezos_base__TzPervasives.pp_print_error err)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_stdlib.Lwt_canceler.cancel (canceler st)
              end)
        end).
  
  Definition create {A B C : Type}
    (my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    (pool : Tezos_p2p.P2p_pool.t A B C) (listening_port : Z)
    (discovery_port : Z) (discovery_addr : Ipaddr.V4.t) : t :=
    {| canceler := Tezos_stdlib.Lwt_canceler.create tt;
      my_peer_id := my_peer_id; listening_port := listening_port;
      discovery_port := discovery_port; discovery_addr := discovery_addr;
      pool := Pool pool; restart_discovery := Lwt_condition.create tt;
      worker := Lwt.return_unit |}.
  
  Definition activate (st : t) : unit := set_field.
End Sender.

Record t := {
  answer : Answer.t;
  sender : Sender.t }.

Definition create {A B C : Type}
  (listening_port : Z) (discovery_port : Z) (discovery_addr : Ipaddr.V4.t)
  (trust_discovered_peers : bool) (pool : Tezos_p2p.P2p_pool.t A B C)
  (my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) : t :=
  let answer :=
    Answer.create my_peer_id pool trust_discovered_peers discovery_port in
  let sender :=
    Sender.create my_peer_id pool listening_port discovery_port discovery_addr
    in
  {| answer := answer; sender := sender |}.

Definition activate (function_parameter : t) : unit :=
  match function_parameter with
  | {| answer := answer; sender := sender |} =>
    Answer.activate answer;
    Sender.activate sender
  end.

Definition wakeup (t : t) : unit :=
  Lwt_condition.signal (restart_discovery (sender t)) tt.

Definition shutdown (t : t) : Lwt.t unit :=
  Lwt.join
    (cons (Tezos_stdlib.Lwt_canceler.cancel (canceler (answer t)))
      (cons (Tezos_stdlib.Lwt_canceler.cancel (canceler (sender t))) [])).
src/lib_p2p/p2p_discovery.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Local peer discovery.

    This module manages the discovery of local peers through UDP broadcasting.
    It is composed of two workers:
    - The sender worker whose role is to broadcast discovery messages.
    - The answer worker whose role is to listen discovery messages and register new
      peers in the current pool.
    Discovery messages are composed of an arbitrary key, the listening port and
    the peer id of the current peer.
*)

(** Type of a discovery worker. *)
type t

(** [create ~listening_port ~discovery_port ~discovery_addr pool peer_id]
    returns a discovery worker registering local peers to the [pool]
    and broadcasting discovery messages with the [peer_id] and
    the [listening_port] through the address [discovery_addr:discovery_port]. *)
val create :
  listening_port:int ->
  discovery_port:int ->
  discovery_addr:Ipaddr.V4.t ->
  trust_discovered_peers:bool ->
  ('a, 'b, 'c) P2p_pool.t ->
  P2p_peer.Table.key ->
  t

val activate : t -> unit

(** [wakeup t] sends a signal to the sender machine of [t], asking it
    to immediately proceed to broadcasting. *)
val wakeup : t -> unit

(** [shutdown t] returns when [t] has completed shutdown. *)
val shutdown : t -> unit Lwt.t
src/lib_p2p/p2p_discovery.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create : forall {a b c : Type},
Z ->
  Z ->
    Ipaddr.V4.t ->
      bool ->
        (Tezos_p2p.P2p_pool.t a b c) ->
          Tezos_base__TzPervasives.P2p_peer.Table.key -> t.

Parameter activate : t -> unit.

Parameter wakeup : t -> unit.

Parameter shutdown : t -> Lwt.t unit.
src/lib_p2p/p2p_errors.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(************************ p2p io scheduler ********************************)

type error += Connection_closed

let () =
  (* Connection closed *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_io_scheduler.connection_closed"
    ~title:"Connection closed"
    ~description:"IO error: connection with a peer is closed."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "IO error: connection with a peer is closed.")
    Data_encoding.empty
    (function Connection_closed -> Some () | _ -> None)
    (fun () -> Connection_closed)

(***************************** p2p socket *********************************)

type error += Decipher_error

type error += Invalid_message_size

type error += Encoding_error

type error += Rejected_socket_connection

type error += Rejected_no_common_protocol of {announced : Network_version.t}

type error += Decoding_error

type error += Myself of P2p_connection.Id.t

type error += Not_enough_proof_of_work of P2p_peer.Id.t

type error += Invalid_auth

type error += Invalid_chunks_size of {value : int; min : int; max : int}

let () =
  (* Decipher error *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.decipher_error"
    ~title:"Decipher error"
    ~description:"An error occurred while deciphering."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "An error occurred while deciphering.")
    Data_encoding.empty
    (function Decipher_error -> Some () | _ -> None)
    (fun () -> Decipher_error) ;
  (* Invalid message size *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.invalid_message_size"
    ~title:"Invalid message size"
    ~description:"The size of the message to be written is invalid."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "The size of the message to be written is invalid.")
    Data_encoding.empty
    (function Invalid_message_size -> Some () | _ -> None)
    (fun () -> Invalid_message_size) ;
  (* Encoding error *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.encoding_error"
    ~title:"Encoding error"
    ~description:"An error occurred while encoding."
    ~pp:(fun ppf () -> Format.fprintf ppf "An error occurred while encoding.")
    Data_encoding.empty
    (function Encoding_error -> Some () | _ -> None)
    (fun () -> Encoding_error) ;
  (* Rejected socket connection *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.rejected_socket_connection"
    ~title:"Rejected socket connection"
    ~description:"Rejected peer connection: rejected socket connection."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Rejected peer connection: rejected socket connection.")
    Data_encoding.empty
    (function Rejected_socket_connection -> Some () | _ -> None)
    (fun () -> Rejected_socket_connection) ;
  (* Rejected socket connection, no common network protocol *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.rejected_no_common_protocol"
    ~title:"Rejected socket connection - no common network protocol"
    ~description:
      "Rejected peer connection: rejected socket connection as we have no \
       common network protocol with the peer."
    ~pp:(fun ppf _lst ->
      Format.fprintf
        ppf
        "Rejected peer connection: no common network protocol.")
    Data_encoding.(obj1 (req "announced_version" Network_version.encoding))
    (function
      | Rejected_no_common_protocol {announced} -> Some announced | _ -> None)
    (fun announced -> Rejected_no_common_protocol {announced}) ;
  (* Decoding error *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.decoding_error"
    ~title:"Decoding error"
    ~description:"An error occurred while decoding."
    ~pp:(fun ppf () -> Format.fprintf ppf "An error occurred while decoding.")
    Data_encoding.empty
    (function Decoding_error -> Some () | _ -> None)
    (fun () -> Decoding_error) ;
  (* Myself *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.myself"
    ~title:"Myself"
    ~description:"Remote peer is actually yourself."
    ~pp:(fun ppf id ->
      Format.fprintf
        ppf
        "Remote peer %a cannot be authenticated: peer is actually yourself."
        P2p_connection.Id.pp
        id)
    Data_encoding.(obj1 (req "connection id" P2p_connection.Id.encoding))
    (function Myself id -> Some id | _ -> None)
    (fun id -> Myself id) ;
  (* Not enough proof of work *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.not_enough_proof_of_work"
    ~title:"Not enough proof of work"
    ~description:
      "Remote peer cannot be authenticated: not enough proof of work."
    ~pp:(fun ppf id ->
      Format.fprintf
        ppf
        "Remote peer %a cannot be authenticated: not enough proof of work."
        P2p_peer.Id.pp
        id)
    Data_encoding.(obj1 (req "peer id" P2p_peer.Id.encoding))
    (function Not_enough_proof_of_work id -> Some id | _ -> None)
    (fun id -> Not_enough_proof_of_work id) ;
  (* Invalid authentication *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.invalid_auth"
    ~title:"Invalid authentication"
    ~description:"Rejected peer connection: invalid authentication."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Rejected peer connection: invalid authentication.")
    Data_encoding.empty
    (function Invalid_auth -> Some () | _ -> None)
    (fun () -> Invalid_auth) ;
  (* Invalid chunks size *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.invalid_chunks_size"
    ~title:"Invalid chunks size"
    ~description:"Size of chunks is not valid."
    ~pp:(fun ppf (value, min, max) ->
      Format.fprintf
        ppf
        "Size of chunks is invalid: should be between %d and %d but is %d"
        min
        max
        value)
    Data_encoding.(
      obj3 (req "value" int31) (req "min" int31) (req "max" int31))
    (function
      | Invalid_chunks_size {value; min; max} ->
          Some (value, min, max)
      | _ ->
          None)
    (fun (value, min, max) -> Invalid_chunks_size {value; min; max})

(***************************** p2p pool ***********************************)

type error += Pending_connection

type error += Connected

type error += Connection_refused

type error += Rejected of P2p_peer.Id.t

type error += Too_many_connections

type error += Private_mode

type error += Point_banned of P2p_point.Id.t

type error += Peer_banned of P2p_peer.Id.t

let () =
  (* Pending connection *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.pending_connection"
    ~title:"Pending connection"
    ~description:
      "Fail to connect with a peer: a connection is already pending."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Fail to connect with a peer: a connection is already pending.")
    Data_encoding.empty
    (function Pending_connection -> Some () | _ -> None)
    (fun () -> Pending_connection) ;
  (* Connected *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.connected"
    ~title:"Connected"
    ~description:
      "Fail to connect with a peer: a connection is already established."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Fail to connect with a peer: a connection is already established.")
    Data_encoding.empty
    (function Connected -> Some () | _ -> None)
    (fun () -> Connected) ;
  (* Connected refused *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.connection_refused"
    ~title:"Connection refused"
    ~description:"Connection was refused."
    ~pp:(fun ppf () -> Format.fprintf ppf "Connection was refused.")
    Data_encoding.empty
    (function Connection_refused -> Some () | _ -> None)
    (fun () -> Connection_refused) ;
  (* Rejected *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.rejected"
    ~title:"Rejected peer"
    ~description:"Connection to peer was rejected."
    ~pp:(fun ppf id ->
      Format.fprintf
        ppf
        "Connection to peer %a was rejected."
        P2p_peer.Id.pp
        id)
    Data_encoding.(obj1 (req "peer id" P2p_peer.Id.encoding))
    (function Rejected id -> Some id | _ -> None)
    (fun id -> Rejected id) ;
  (* Too many connections *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.too_many_connections"
    ~title:"Too many connections"
    ~description:"Too many connections."
    ~pp:(fun ppf () -> Format.fprintf ppf "Too many connections.")
    Data_encoding.empty
    (function Too_many_connections -> Some () | _ -> None)
    (fun () -> Too_many_connections) ;
  (* Private mode *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.private_mode"
    ~title:"Private mode"
    ~description:"Node is in private mode."
    ~pp:(fun ppf () -> Format.fprintf ppf "Node is in private mode.")
    Data_encoding.empty
    (function Private_mode -> Some () | _ -> None)
    (fun () -> Private_mode) ;
  (* Point Banned *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.point_banned"
    ~title:"Point Banned"
    ~description:"The address you tried to connect is banned."
    ~pp:(fun ppf (addr, _port) ->
      Format.fprintf
        ppf
        "The address you tried to connect (%a) is banned."
        P2p_addr.pp
        addr)
    Data_encoding.(obj1 (req "point" P2p_point.Id.encoding))
    (function Point_banned point -> Some point | _ -> None)
    (fun point -> Point_banned point) ;
  (* Peer Banned *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.peer_banned"
    ~title:"Peer Banned"
    ~description:"The peer identity you tried to connect is banned."
    ~pp:(fun ppf peer_id ->
      Format.fprintf
        ppf
        "The peer identity you tried to connect (%a) is banned."
        P2p_peer.Id.pp
        peer_id)
    Data_encoding.(obj1 (req "peer" P2p_peer.Id.encoding))
    (function Peer_banned peer_id -> Some peer_id | _ -> None)
    (fun peer_id -> Peer_banned peer_id)
src/lib_p2p/p2p_errors.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_p2p/p2p_errors.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* P2P IO scheduler *)

type error += Connection_closed

(* P2P socket *)

type error += Decipher_error

type error += Invalid_message_size

type error += Encoding_error

type error += Rejected_socket_connection

type error += Rejected_no_common_protocol of {announced : Network_version.t}

type error += Decoding_error

type error += Myself of P2p_connection.Id.t

type error += Not_enough_proof_of_work of P2p_peer.Id.t

type error += Invalid_auth

type error += Invalid_chunks_size of {value : int; min : int; max : int}

(* P2P pool *)

type error += Pending_connection

type error += Connected

type error += Connection_refused

type error += Rejected of P2p_peer.Id.t

type error += Too_many_connections

type error += Private_mode

type error += Point_banned of P2p_point.Id.t

type error += Peer_banned of P2p_peer.Id.t
src/lib_p2p/p2p_errors.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type
src/lib_p2p/p2p_fd.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* logging facility to monitor sockets *)

let is_not_windows = Sys.os_type <> "Win32"

let () =
  (* Otherwise some writes trigger a SIGPIPE instead of raising an
     Lwt_unit exception. In the node, this is already done by
     Cohttp, so this is only useful when using the P2P layer as a
     stand alone library.  *)
  if is_not_windows then Sys.(set_signal sigpipe Signal_ignore)

(* Logging facility for the P2P layer *)
module Log = Internal_event.Legacy_logging.Make (struct
  let name = "p2p.fd"
end)

type t = {
  fd : Lwt_unix.file_descr;
  id : int;
  mutable nread : int;
  mutable nwrit : int;
}

(* we use a prefix ' cnx:' that allows easy grepping in the log to lookup
   everything related to a particular connection. *)
let log t fmt = Format.kasprintf (fun s -> Log.debug "cnx:%d:%s" t.id s) fmt

let create =
  let counter = ref 0 in
  function
  | fd ->
      incr counter ;
      let t = {fd; id = !counter; nread = 0; nwrit = 0} in
      log t "create: fd %d" t.id ; t

let string_of_sockaddr addr =
  match addr with
  | Lwt_unix.ADDR_INET (ip, port) ->
      Printf.sprintf "%s:%d" (Unix.string_of_inet_addr ip) port
  | Lwt_unix.ADDR_UNIX file ->
      Printf.sprintf "@%s" file

let id t = t.id

let socket proto kind arg = create (Lwt_unix.socket proto kind arg)

let close t =
  log t "close: stats %d/%d" t.nread t.nwrit ;
  Lwt_utils_unix.safe_close t.fd

let read t buf pos len =
  log t "try-read: %d" len ;
  Lwt_unix.read t.fd buf pos len
  >>= fun nread ->
  t.nread <- t.nread + nread ;
  log t "read: %d (%d)" nread t.nread ;
  Lwt.return nread

let write t buf =
  let len = Bytes.length buf in
  log t "try-write: %d" len ;
  Lwt_utils_unix.write_mbytes t.fd buf
  >>= fun () ->
  t.nwrit <- t.nwrit + len ;
  log t "written: %d (%d)" len t.nwrit ;
  Lwt.return_unit

let connect t saddr =
  log t "connect: %s" (string_of_sockaddr saddr) ;
  Lwt_unix.connect t.fd saddr

let accept sock =
  Lwt_unix.accept sock
  >>= fun (fd, saddr) ->
  let t = create fd in
  log t "accept: %s" (string_of_sockaddr saddr) ;
  Lwt.return (t, saddr)

module Table = Hashtbl.Make (struct
  type nonrec t = t

  let equal {id = x; _} {id = y; _} = x = y

  let hash {id; _} = Hashtbl.hash id
end)
src/lib_p2p/p2p_fd.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition is_not_windows : bool :=
  nequiv_decb Stdlib.Sys.os_type "Win32" % string.

Record t := {
  fd : Lwt_unix.file_descr;
  id : Z;
  nread : Z;
  nwrit : Z }.

Definition log {A : Type}
  (t : t) (fmt : Stdlib.format4 A Stdlib.Format.formatter unit unit) : A :=
  Stdlib.Format.kasprintf
    (fun s =>
      Log.debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "cnx:" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "cnx:%d:%s" % string) (id t) s) fmt.

Definition create : Lwt_unix.file_descr -> t :=
  let counter := Stdlib.ref 0 in
  fun fd =>
    Stdlib.incr counter;
    let t :=
      {| fd := fd; id := Stdlib.op_exclamation counter; nread := 0; nwrit := 0
        |} in
    log t
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "create: fd " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "create: fd %d" % string)
      (id t);
    t.

Definition string_of_sockaddr (addr : Lwt_unix.sockaddr) : string :=
  match addr with
  | Lwt_unix.ADDR_INET ip port =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal ":" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s:%d" % string)
      (Unix.string_of_inet_addr ip) port
  | Lwt_unix.ADDR_UNIX file =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "@" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "@%s" % string) file
  end.

Definition id (t : t) : Z := id t.

Definition socket
  (proto : Lwt_unix.socket_domain) (kind : Lwt_unix.socket_type) (arg : Z)
  : t := create (Lwt_unix.socket proto kind arg).

Definition close (t : t) : Lwt.t unit :=
  log t
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "close: stats " % string
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.Char_literal "/" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))))
      "close: stats %d/%d" % string) (nread t) (nwrit t);
  Tezos_stdlib_unix.Lwt_utils_unix.safe_close (fd t).

Definition read (t : t) (buf : string) (pos : Z) (len : Z) : Lwt.t Z :=
  log t
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "try-read: " % string
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          CamlinternalFormatBasics.End_of_format)) "try-read: %d" % string) len;
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.read (fd t) buf pos len)
    (fun nread =>
      set_field;
      log t
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "read: " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " (" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))))
          "read: %d (%d)" % string) nread (nread t);
      Lwt._return nread).

Definition write (t : t) (buf : Stdlib.Bytes.t) : Lwt.t unit :=
  let len := String.length buf in
  log t
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "try-write: " % string
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          CamlinternalFormatBasics.End_of_format)) "try-write: %d" % string) len;
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_stdlib_unix.Lwt_utils_unix.write_mbytes None None (fd t) buf)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        set_field;
        log t
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "written: " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " (" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format)))))
            "written: %d (%d)" % string) len (nwrit t);
        Lwt.return_unit
      end).

Definition connect (t : t) (saddr : Lwt_unix.sockaddr) : Lwt.t unit :=
  log t
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "connect: " % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format)) "connect: %s" % string)
    (string_of_sockaddr saddr);
  Lwt_unix.connect (fd t) saddr.

Definition accept (sock : Lwt_unix.file_descr)
  : Lwt.t (t * Lwt_unix.sockaddr) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.accept sock)
    (fun function_parameter =>
      match function_parameter with
      | (fd, saddr) =>
        let t := create fd in
        log t
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "accept: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "accept: %s" % string)
          (string_of_sockaddr saddr);
        Lwt._return (t, saddr)
      end).
src/lib_p2p/p2p_fd.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This module defines a type [t] which wraps a file descriptor. Most
    functions simply call the underlying file descriptor function and generate
    logs with prefix "p2p.fd". *)

type t

(** [id t] returns a unique, positive, identifier for t. Identifiers
    are generated sequentially at creation time. *)
val id : t -> int

val read : t -> Bytes.t -> int -> int -> int Lwt.t

val close : t -> unit Lwt.t

val write : t -> Bytes.t -> unit Lwt.t

val socket : Lwt_unix.socket_domain -> Lwt_unix.socket_type -> int -> t

val connect : t -> Lwt_unix.sockaddr -> unit Lwt.t

val accept : Lwt_unix.file_descr -> (t * Lwt_unix.sockaddr) Lwt.t

module Table : Hashtbl.S with type key = t
src/lib_p2p/p2p_fd.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter id : t -> Z.

Parameter read : t -> Stdlib.Bytes.t -> Z -> Z -> Lwt.t Z.

Parameter close : t -> Lwt.t unit.

Parameter write : t -> Stdlib.Bytes.t -> Lwt.t unit.

Parameter socket : Lwt_unix.socket_domain -> Lwt_unix.socket_type -> Z -> t.

Parameter connect : t -> Lwt_unix.sockaddr -> Lwt.t unit.

Parameter accept : Lwt_unix.file_descr -> Lwt.t (t * Lwt_unix.sockaddr).

unhandled_module
src/lib_p2p/p2p_io_scheduler.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* TODO decide whether we need to preallocate buffers or not. *)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.io-scheduler"
end)

let alpha = 0.2

module type IO = sig
  val name : string

  type in_param

  val pop : in_param -> Bytes.t tzresult Lwt.t

  type out_param

  val push : out_param -> Bytes.t -> unit tzresult Lwt.t

  val close : out_param -> error list -> unit Lwt.t
end

module Scheduler (IO : IO) = struct
  [@@@ocaml.warning "-30"]

  type t = {
    canceler : Lwt_canceler.t;
    mutable worker : unit Lwt.t;
    counter : Moving_average.t;
    max_speed : int option;
    mutable quota : int;
    quota_updated : unit Lwt_condition.t;
    readys : unit Lwt_condition.t;
    readys_high : (connection * Bytes.t tzresult) Queue.t;
    readys_low : (connection * Bytes.t tzresult) Queue.t;
  }

  and connection = {
    id : int;
    mutable closed : bool;
    canceler : Lwt_canceler.t;
    in_param : IO.in_param;
    out_param : IO.out_param;
    mutable current_pop : Bytes.t tzresult Lwt.t;
    mutable current_push : unit tzresult Lwt.t;
    counter : Moving_average.t;
    mutable quota : int;
    mutable last_quota : int;
  }

  let cancel (conn : connection) err =
    Lwt_utils.unless conn.closed (fun () ->
        lwt_debug "Connection closed (%d, %s) " conn.id IO.name
        >>= fun () ->
        conn.closed <- true ;
        Lwt.catch
          (fun () -> IO.close conn.out_param err)
          (fun _ -> Lwt.return_unit)
        >>= fun () -> Lwt_canceler.cancel conn.canceler)

  let waiter st conn =
    assert (Lwt.state conn.current_pop <> Sleep) ;
    conn.current_pop <- IO.pop conn.in_param ;
    Lwt.async (fun () ->
        conn.current_pop
        >>= fun res ->
        conn.current_push
        >>= fun _ ->
        let was_empty =
          Queue.is_empty st.readys_high && Queue.is_empty st.readys_low
        in
        if conn.quota > 0 then Queue.push (conn, res) st.readys_high
        else Queue.push (conn, res) st.readys_low ;
        if was_empty then Lwt_condition.broadcast st.readys () ;
        Lwt.return_unit)

  let wait_data st =
    let is_empty =
      Queue.is_empty st.readys_high && Queue.is_empty st.readys_low
    in
    if is_empty then Lwt_condition.wait st.readys else Lwt.return_unit

  let check_quota st =
    if st.max_speed <> None && st.quota < 0 then
      lwt_debug "scheduler.wait_quota(%s)" IO.name
      >>= fun () -> Lwt_condition.wait st.quota_updated
    else Lwt_unix.yield ()

  let rec worker_loop st =
    check_quota st
    >>= fun () ->
    lwt_debug "scheduler.wait(%s)" IO.name
    >>= fun () ->
    Lwt.pick [Lwt_canceler.cancellation st.canceler; wait_data st]
    >>= fun () ->
    if Lwt_canceler.canceled st.canceler then Lwt.return_unit
    else
      let (prio, (conn, msg)) =
        if not (Queue.is_empty st.readys_high) then
          (true, Queue.pop st.readys_high)
        else (false, Queue.pop st.readys_low)
      in
      match msg with
      | Error (Canceled :: _) ->
          worker_loop st
      | Error (P2p_errors.Connection_closed :: _ as err)
      | Error (Exn Lwt_pipe.Closed :: _ as err)
      | Error (Exn (Unix.Unix_error ((EBADF | ETIMEDOUT), _, _)) :: _ as err)
        ->
          lwt_debug "Connection closed (pop: %d, %s)" conn.id IO.name
          >>= fun () -> cancel conn err >>= fun () -> worker_loop st
      | Error err ->
          lwt_log_error
            "@[Unexpected error in connection (pop: %d, %s):@ %a@]"
            conn.id
            IO.name
            pp_print_error
            err
          >>= fun () -> cancel conn err >>= fun () -> worker_loop st
      | Ok msg ->
          conn.current_push <-
            ( IO.push conn.out_param msg
            >>= function
            | Ok () | Error (Canceled :: _) ->
                return_unit
            | Error (P2p_errors.Connection_closed :: _ as err)
            | Error (Exn (Unix.Unix_error (EBADF, _, _)) :: _ as err)
            | Error (Exn Lwt_pipe.Closed :: _ as err) ->
                lwt_debug "Connection closed (push: %d, %s)" conn.id IO.name
                >>= fun () -> cancel conn err >>= fun () -> return_unit
            | Error err ->
                lwt_log_error
                  "@[Unexpected error in connection (push: %d, %s):@ %a@]"
                  conn.id
                  IO.name
                  pp_print_error
                  err
                >>= fun () ->
                cancel conn err >>= fun () -> Lwt.return_error err ) ;
          let len = Bytes.length msg in
          lwt_debug "Handle: %d (%d, %s)" len conn.id IO.name
          >>= fun () ->
          Moving_average.add st.counter len ;
          st.quota <- st.quota - len ;
          Moving_average.add conn.counter len ;
          if prio then conn.quota <- conn.quota - len ;
          waiter st conn ;
          worker_loop st

  let create max_speed =
    let st =
      {
        canceler = Lwt_canceler.create ();
        worker = Lwt.return_unit;
        counter = Moving_average.create ~init:0 ~alpha;
        max_speed;
        quota = Option.unopt ~default:0 max_speed;
        quota_updated = Lwt_condition.create ();
        readys = Lwt_condition.create ();
        readys_high = Queue.create ();
        readys_low = Queue.create ();
      }
    in
    st.worker <-
      Lwt_utils.worker
        IO.name
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop st)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
    st

  let create_connection st in_param out_param canceler id =
    debug "scheduler(%s).create_connection (%d)" IO.name id ;
    let conn =
      {
        id;
        closed = false;
        canceler;
        in_param;
        out_param;
        current_pop = Lwt.fail Not_found (* dummy *);
        current_push = return_unit;
        counter = Moving_average.create ~init:0 ~alpha;
        quota = 0;
        last_quota = 0;
      }
    in
    waiter st conn ; conn

  let update_quota st =
    debug "scheduler(%s).update_quota" IO.name ;
    Option.iter st.max_speed ~f:(fun quota ->
        st.quota <- min st.quota 0 + quota ;
        Lwt_condition.broadcast st.quota_updated ()) ;
    if not (Queue.is_empty st.readys_low) then (
      let tmp = Queue.create () in
      Queue.iter
        (fun (((conn : connection), _) as msg) ->
          if conn.quota > 0 then Queue.push msg st.readys_high
          else Queue.push msg tmp)
        st.readys_low ;
      Queue.clear st.readys_low ;
      Queue.transfer tmp st.readys_low )

  let shutdown st =
    lwt_debug "--> scheduler(%s).shutdown" IO.name
    >>= fun () ->
    Lwt_canceler.cancel st.canceler
    >>= fun () ->
    st.worker >>= fun () -> lwt_debug "<-- scheduler(%s).shutdown" IO.name
end

module ReadScheduler = Scheduler (struct
  let name = "io_scheduler(read)"

  type in_param = P2p_fd.t * int

  let pop (fd, maxlen) =
    Lwt.catch
      (fun () ->
        let buf = Bytes.create maxlen in
        P2p_fd.read fd buf 0 maxlen
        >>= fun len ->
        if len = 0 then fail P2p_errors.Connection_closed
        else return (Bytes.sub buf 0 len))
      (function
        | Unix.Unix_error (Unix.ECONNRESET, _, _) ->
            fail P2p_errors.Connection_closed
        | exn ->
            Lwt.return (error_exn exn))

  type out_param = Bytes.t tzresult Lwt_pipe.t

  let push p msg =
    Lwt.catch
      (fun () -> Lwt_pipe.push p (Ok msg) >>= fun () -> return_unit)
      (fun exn -> fail (Exn exn))

  let close p err =
    Lwt.catch
      (fun () -> Lwt_pipe.push p (Error err))
      (fun _ -> Lwt.return_unit)
end)

module WriteScheduler = Scheduler (struct
  let name = "io_scheduler(write)"

  type in_param = Bytes.t Lwt_pipe.t

  let pop p =
    Lwt.catch
      (fun () -> Lwt_pipe.pop p >>= return)
      (fun _ -> fail (Exn Lwt_pipe.Closed))

  type out_param = P2p_fd.t

  let push fd buf =
    Lwt.catch
      (fun () -> P2p_fd.write fd buf >>= return)
      (function
        | Unix.Unix_error (Unix.ECONNRESET, _, _)
        | Unix.Unix_error (Unix.EPIPE, _, _)
        | Lwt.Canceled
        | End_of_file ->
            fail P2p_errors.Connection_closed
        | exn ->
            Lwt.return (error_exn exn))

  let close _p _err = Lwt.return_unit
end)

type connection = {
  sched : t;
  fd : P2p_fd.t;
  canceler : Lwt_canceler.t;
  read_conn : ReadScheduler.connection;
  read_queue : Bytes.t tzresult Lwt_pipe.t;
  write_conn : WriteScheduler.connection;
  write_queue : Bytes.t Lwt_pipe.t;
  mutable partial_read : Bytes.t option;
}

and t = {
  mutable closed : bool;
  connected : connection P2p_fd.Table.t;
  read_scheduler : ReadScheduler.t;
  write_scheduler : WriteScheduler.t;
  max_upload_speed : int option;
  (* bytes per second. *)
  max_download_speed : int option;
  read_buffer_size : int;
  read_queue_size : int option;
  write_queue_size : int option;
}

let reset_quota st =
  debug "--> reset quota" ;
  let {Moving_average.average = current_inflow; _} =
    Moving_average.stat st.read_scheduler.counter
  and {Moving_average.average = current_outflow; _} =
    Moving_average.stat st.write_scheduler.counter
  in
  let nb_conn = P2p_fd.Table.length st.connected in
  ( if nb_conn > 0 then
    let fair_read_quota = current_inflow / nb_conn
    and fair_write_quota = current_outflow / nb_conn in
    P2p_fd.Table.iter
      (fun _id conn ->
        conn.read_conn.last_quota <- fair_read_quota ;
        conn.read_conn.quota <- min conn.read_conn.quota 0 + fair_read_quota ;
        conn.write_conn.last_quota <- fair_write_quota ;
        conn.write_conn.quota <- min conn.write_conn.quota 0 + fair_write_quota)
      st.connected ) ;
  ReadScheduler.update_quota st.read_scheduler ;
  WriteScheduler.update_quota st.write_scheduler

let create ?max_upload_speed ?max_download_speed ?read_queue_size
    ?write_queue_size ~read_buffer_size () =
  log_info "--> create" ;
  let st =
    {
      closed = false;
      connected = P2p_fd.Table.create 53;
      read_scheduler = ReadScheduler.create max_download_speed;
      write_scheduler = WriteScheduler.create max_upload_speed;
      max_upload_speed;
      max_download_speed;
      read_buffer_size;
      read_queue_size;
      write_queue_size;
    }
  in
  Moving_average.on_update (fun () -> reset_quota st) ;
  st

exception Closed

let read_size = function
  | Ok buf ->
      (Sys.word_size / 8 * 8) + Bytes.length buf + Lwt_pipe.push_overhead
  | Error _ ->
      0

(* we push Error only when we close the socket,
                    we don't fear memory leaks in that case... *)

let write_size mbytes =
  (Sys.word_size / 8 * 6) + Bytes.length mbytes + Lwt_pipe.push_overhead

let register st fd =
  if st.closed then (
    Lwt.async (fun () -> P2p_fd.close fd) ;
    raise Closed )
  else
    let id = P2p_fd.id fd in
    let canceler = Lwt_canceler.create () in
    let read_size =
      Option.map st.read_queue_size ~f:(fun v -> (v, read_size))
    in
    let write_size =
      Option.map st.write_queue_size ~f:(fun v -> (v, write_size))
    in
    let read_queue = Lwt_pipe.create ?size:read_size () in
    let write_queue = Lwt_pipe.create ?size:write_size () in
    let read_conn =
      ReadScheduler.create_connection
        st.read_scheduler
        (fd, st.read_buffer_size)
        read_queue
        canceler
        id
    and write_conn =
      WriteScheduler.create_connection
        st.write_scheduler
        write_queue
        fd
        canceler
        id
    in
    Lwt_canceler.on_cancel canceler (fun () ->
        P2p_fd.Table.remove st.connected fd ;
        Moving_average.destroy read_conn.counter ;
        Moving_average.destroy write_conn.counter ;
        Lwt_pipe.close write_queue ;
        Lwt_pipe.close read_queue ;
        P2p_fd.close fd) ;
    let conn =
      {
        sched = st;
        fd;
        canceler;
        read_queue;
        read_conn;
        write_queue;
        write_conn;
        partial_read = None;
      }
    in
    P2p_fd.Table.add st.connected conn.fd conn ;
    log_info "--> register (%d)" id ;
    conn

let write ?canceler {write_queue; _} msg =
  trace P2p_errors.Connection_closed
  @@ protect ?canceler (fun () ->
         Lwt_pipe.push write_queue msg >>= fun () -> return_unit)

let write_now {write_queue; _} msg = Lwt_pipe.push_now write_queue msg

let read_from conn ?pos ?len buf msg =
  let maxlen = Bytes.length buf in
  let pos = Option.unopt ~default:0 pos in
  assert (0 <= pos && pos < maxlen) ;
  let len = Option.unopt ~default:(maxlen - pos) len in
  assert (len <= maxlen - pos) ;
  match msg with
  | Ok msg ->
      let msg_len = Bytes.length msg in
      let read_len = min len msg_len in
      Bytes.blit msg 0 buf pos read_len ;
      if read_len < msg_len then
        conn.partial_read <- Some (Bytes.sub msg read_len (msg_len - read_len)) ;
      Ok read_len
  | Error _ ->
      error P2p_errors.Connection_closed

let read_now conn ?pos ?len buf =
  match conn.partial_read with
  | Some msg ->
      conn.partial_read <- None ;
      Some (read_from conn ?pos ?len buf (Ok msg))
  | None -> (
    try
      Option.map
        ~f:(read_from conn ?pos ?len buf)
        (Lwt_pipe.pop_now conn.read_queue)
    with Lwt_pipe.Closed -> Some (error P2p_errors.Connection_closed) )

let read ?canceler conn ?pos ?len buf =
  match conn.partial_read with
  | Some msg ->
      conn.partial_read <- None ;
      Lwt.return (read_from conn ?pos ?len buf (Ok msg))
  | None ->
      Lwt.catch
        (fun () ->
          protect ?canceler (fun () -> Lwt_pipe.pop conn.read_queue)
          >|= fun msg -> read_from conn ?pos ?len buf msg)
        (fun _ -> fail P2p_errors.Connection_closed)

let read_full ?canceler conn ?pos ?len buf =
  let maxlen = Bytes.length buf in
  let pos = Option.unopt ~default:0 pos in
  let len = Option.unopt ~default:(maxlen - pos) len in
  assert (0 <= pos && pos < maxlen) ;
  assert (len <= maxlen - pos) ;
  let rec loop pos len =
    if len = 0 then return_unit
    else
      read ?canceler conn ~pos ~len buf
      >>=? fun read_len -> loop (pos + read_len) (len - read_len)
  in
  loop pos len

let convert ~ws ~rs =
  {
    P2p_stat.total_sent = ws.Moving_average.total;
    total_recv = rs.Moving_average.total;
    current_outflow = ws.average;
    current_inflow = rs.average;
  }

let global_stat {read_scheduler; write_scheduler; _} =
  let rs = Moving_average.stat read_scheduler.counter
  and ws = Moving_average.stat write_scheduler.counter in
  convert ~rs ~ws

let stat {read_conn; write_conn; _} =
  let rs = Moving_average.stat read_conn.counter
  and ws = Moving_average.stat write_conn.counter in
  convert ~rs ~ws

let close ?timeout conn =
  let id = P2p_fd.id conn.fd in
  lwt_log_info "--> close (%d)" id
  >>= fun () ->
  P2p_fd.Table.remove conn.sched.connected conn.fd ;
  Lwt_pipe.close conn.write_queue ;
  ( match timeout with
  | None ->
      return (Lwt_canceler.cancellation conn.canceler)
  | Some timeout ->
      with_timeout
        ~canceler:conn.canceler
        (Lwt_unix.sleep timeout)
        (fun canceler -> return (Lwt_canceler.cancellation canceler)) )
  >>=? fun _ ->
  conn.write_conn.current_push
  >>= fun res -> lwt_log_info "<-- close (%d)" id >>= fun () -> Lwt.return res

let iter_connection {connected; _} f =
  P2p_fd.Table.iter (fun _ conn -> f conn) connected

let shutdown ?timeout st =
  lwt_log_info "--> shutdown"
  >>= fun () ->
  st.closed <- true ;
  ReadScheduler.shutdown st.read_scheduler
  >>= fun () ->
  P2p_fd.Table.fold
    (fun _peer_id conn acc -> close ?timeout conn >>= fun _ -> acc)
    st.connected
    Lwt.return_unit
  >>= fun () ->
  WriteScheduler.shutdown st.write_scheduler
  >>= fun () -> lwt_log_info "<-- shutdown"

let id conn = P2p_fd.id conn.fd
src/lib_p2p/p2p_io_scheduler.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition alpha : float := 0.

Module IO.
  Record signature {in_param out_param : Type} := {
    name : string;
    in_param := in_param;
    pop : in_param -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t);
    out_param := out_param;
    push : out_param ->
      Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    close : out_param -> (list Tezos_base__TzPervasives.error) -> Lwt.t unit;
  }.
  Arguments signature : clear implicits.
End IO.

.

Definition reset_quota (st : t) : unit :=
  debug
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "--> reset quota" % string
        CamlinternalFormatBasics.End_of_format) "--> reset quota" % string);
  in
  let nb_conn := Tezos_p2p.P2p_fd.Table.length (connected st) in
  if OCaml.Stdlib.gt nb_conn 0 then
    let fair_read_quota : Z :=
      Z.div current_inflow nb_conn
    with fair_write_quota : Z :=
      Z.div current_outflow nb_conn in
    Tezos_p2p.P2p_fd.Table.iter
      (fun _id =>
        fun conn =>
          set_field;
          set_field;
          set_field;
          set_field) (connected st)
  else
    tt;
  ReadScheduler.update_quota (read_scheduler st);
  WriteScheduler.update_quota (write_scheduler st).

Definition create
  (max_upload_speed : option Z) (max_download_speed : option Z)
  (read_queue_size : option Z) (write_queue_size : option Z)
  (read_buffer_size : Z) (function_parameter : unit) : t :=
  match function_parameter with
  | tt =>
    log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--> create" % string
          CamlinternalFormatBasics.End_of_format) "--> create" % string);
    let st :=
      {| closed := false; connected := Tezos_p2p.P2p_fd.Table.create 53;
        read_scheduler := ReadScheduler.create max_download_speed;
        write_scheduler := WriteScheduler.create max_upload_speed;
        max_upload_speed := max_upload_speed;
        max_download_speed := max_download_speed;
        read_buffer_size := read_buffer_size;
        read_queue_size := read_queue_size; write_queue_size := write_queue_size
        |} in
    Tezos_stdlib_unix.Moving_average.on_update
      (fun function_parameter =>
        match function_parameter with
        | tt => reset_quota st
        end);
    st
  end.

Definition read_size {A : Type} (function_parameter : sum string A) : Z :=
  match function_parameter with
  | inl buf =>
    Z.add (Z.add (Z.mul (Z.div Stdlib.Sys.word_size 8) 8) (String.length buf))
      Tezos_stdlib.Lwt_pipe.push_overhead
  | inr _ => 0
  end.

Definition write_size (mbytes : string) : Z :=
  Z.add (Z.add (Z.mul (Z.div Stdlib.Sys.word_size 8) 6) (String.length mbytes))
    Tezos_stdlib.Lwt_pipe.push_overhead.

Definition register (st : t) (fd : Tezos_p2p.P2p_fd.t) : connection :=
  if closed st then
    Lwt.async
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_p2p.P2p_fd.close fd
        end);
    Stdlib.raise Closed
  else
    let id := Tezos_p2p.P2p_fd.id fd in
    let canceler := Tezos_stdlib.Lwt_canceler.create tt in
    let read_size :=
      Tezos_stdlib.Option.map (fun v => (v, read_size)) (read_queue_size st) in
    let write_size :=
      Tezos_stdlib.Option.map (fun v => (v, write_size)) (write_queue_size st)
      in
    let read_queue := Tezos_stdlib.Lwt_pipe.create read_size tt in
    let write_queue := Tezos_stdlib.Lwt_pipe.create write_size tt in
    let read_conn : ReadScheduler.connection :=
      ReadScheduler.create_connection (read_scheduler st)
        (fd, (read_buffer_size st)) read_queue canceler id
    with write_conn : WriteScheduler.connection :=
      WriteScheduler.create_connection (write_scheduler st) write_queue fd
        canceler id in
    Tezos_stdlib.Lwt_canceler.on_cancel canceler
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_p2p.P2p_fd.Table.remove (connected st) fd;
          Tezos_stdlib_unix.Moving_average.destroy (counter read_conn);
          Tezos_stdlib_unix.Moving_average.destroy (counter write_conn);
          Tezos_stdlib.Lwt_pipe.close write_queue;
          Tezos_stdlib.Lwt_pipe.close read_queue;
          Tezos_p2p.P2p_fd.close fd
        end);
    let conn :=
      {| sched := st; fd := fd; canceler := canceler; read_conn := read_conn;
        read_queue := read_queue; write_conn := write_conn;
        write_queue := write_queue; partial_read := None |} in
    Tezos_p2p.P2p_fd.Table.add (connected st) (fd conn) conn;
    log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--> register (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "--> register (%d)" % string) id;
    conn.

Definition write
  (canceler : option Tezos_stdlib.Lwt_canceler.t)
  (function_parameter : connection)
  : Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| write_queue := write_queue |} =>
    fun msg =>
      apply (Tezos_base__TzPervasives.trace P2p_errors.Connection_closed)
        (Tezos_base__TzPervasives.protect None canceler
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_stdlib.Lwt_pipe.push write_queue msg)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            end))
  end.

Definition write_now (function_parameter : connection)
  : Stdlib.Bytes.t -> bool :=
  match function_parameter with
  | {| write_queue := write_queue |} =>
    fun msg => Tezos_stdlib.Lwt_pipe.push_now write_queue msg
  end.

Definition read_from {A : Type}
  (conn : connection) (pos : option Z) (len : option Z) (buf : string)
  (msg : sum string A) : sum Z (list Tezos_base__TzPervasives.error) :=
  let maxlen := String.length buf in
  let pos := Tezos_stdlib.Option.unopt 0 pos in
  andb (OCaml.Stdlib.le 0 pos) (OCaml.Stdlib.lt pos maxlen);
  let len := Tezos_stdlib.Option.unopt (Z.sub maxlen pos) len in
  OCaml.Stdlib.le len (Z.sub maxlen pos);
  match msg with
  | inl msg =>
    let msg_len := String.length msg in
    let read_len := OCaml.Stdlib.min len msg_len in
    Stdlib.Bytes.blit msg 0 buf pos read_len;
    if OCaml.Stdlib.lt read_len msg_len then
      set_field
    else
      tt;
    inl read_len
  | inr _ => Tezos_base__TzPervasives.error P2p_errors.Connection_closed
  end.

Definition read_now
  (conn : connection) (pos : option Z) (len : option Z) (buf : string)
  : option (sum Z (list Tezos_base__TzPervasives.error)) :=
  match partial_read conn with
  | Some msg =>
    set_field;
    Some (read_from conn pos len buf (inl msg))
  | None => try
  end.

Definition read
  (canceler : option Tezos_stdlib.Lwt_canceler.t) (conn : connection)
  (pos : option Z) (len : option Z) (buf : string)
  : Lwt.t (sum Z (list Tezos_base__TzPervasives.error)) :=
  match partial_read conn with
  | Some msg =>
    set_field;
    Lwt._return (read_from conn pos len buf (inl msg))
  | None =>
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_pipe_eq
            (Tezos_base__TzPervasives.protect None canceler
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_stdlib.Lwt_pipe.pop (read_queue conn)
                end)) (fun msg => read_from conn pos len buf msg)
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ => Tezos_base__TzPervasives.fail P2p_errors.Connection_closed
        end)
  end.

Definition read_full
  (canceler : option Tezos_stdlib.Lwt_canceler.t) (conn : connection)
  (pos : option Z) (len : option Z) (buf : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let maxlen := String.length buf in
  let pos := Tezos_stdlib.Option.unopt 0 pos in
  let len := Tezos_stdlib.Option.unopt (Z.sub maxlen pos) len in
  andb (OCaml.Stdlib.le 0 pos) (OCaml.Stdlib.lt pos maxlen);
  OCaml.Stdlib.le len (Z.sub maxlen pos);
  let fix loop (pos : Z) (len : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    if equiv_decb len 0 then
      Tezos_base__TzPervasives.return_unit
    else
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (read canceler conn (Some pos) (Some len) buf)
        (fun read_len => loop (Z.add pos read_len) (Z.sub len read_len)) in
  loop pos len.

Definition convert
  (ws : Tezos_stdlib_unix.Moving_average.stat)
  (rs : Tezos_stdlib_unix.Moving_average.stat)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  {| P2p_stat.total_sent := Moving_average.total ws;
    P2p_stat.total_recv := Moving_average.total rs;
    P2p_stat.current_inflow := average rs;
    P2p_stat.current_outflow := average ws |}.

Definition global_stat (function_parameter : t)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  match function_parameter with
  | {| read_scheduler := read_scheduler; write_scheduler := write_scheduler |}
    =>
    let rs : Tezos_stdlib_unix.Moving_average.stat :=
      Tezos_stdlib_unix.Moving_average.stat (counter read_scheduler)
    with ws : Tezos_stdlib_unix.Moving_average.stat :=
      Tezos_stdlib_unix.Moving_average.stat (counter write_scheduler) in
    convert ws rs
  end.

Definition stat (function_parameter : connection)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  match function_parameter with
  | {| read_conn := read_conn; write_conn := write_conn |} =>
    let rs : Tezos_stdlib_unix.Moving_average.stat :=
      Tezos_stdlib_unix.Moving_average.stat (counter read_conn)
    with ws : Tezos_stdlib_unix.Moving_average.stat :=
      Tezos_stdlib_unix.Moving_average.stat (counter write_conn) in
    convert ws rs
  end.

Definition close (timeout : option float) (conn : connection)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let id := Tezos_p2p.P2p_fd.id (fd conn) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--> close (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "--> close (%d)" % string) id)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_p2p.P2p_fd.Table.remove (connected (sched conn)) (fd conn);
        Tezos_stdlib.Lwt_pipe.close (write_queue conn);
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          match timeout with
          | None =>
            Tezos_base__TzPervasives._return
              (Tezos_stdlib.Lwt_canceler.cancellation (canceler conn))
          | Some timeout =>
            Tezos_base__TzPervasives.with_timeout (Some (canceler conn))
              (Lwt_unix.sleep timeout)
              (fun canceler =>
                Tezos_base__TzPervasives._return
                  (Tezos_stdlib.Lwt_canceler.cancellation canceler))
          end
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (current_push (write_conn conn))
                (fun res =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_log_info
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<-- close (" % string
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format)))
                        "<-- close (%d)" % string) id)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Lwt._return res
                      end))
            end)
      end).

Definition iter_connection (function_parameter : t)
  : (connection -> unit) -> unit :=
  match function_parameter with
  | {| connected := connected |} =>
    fun f =>
      Tezos_p2p.P2p_fd.Table.iter
        (fun function_parameter =>
          match function_parameter with
          | _ => fun conn => f conn
          end) connected
  end.

Definition shutdown (timeout : option float) (st : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--> shutdown" % string
          CamlinternalFormatBasics.End_of_format) "--> shutdown" % string))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        set_field;
        Tezos_base__TzPervasives.op_gt_gt_eq
          (ReadScheduler.shutdown (read_scheduler st))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_p2p.P2p_fd.Table.fold
                  (fun _peer_id =>
                    fun conn =>
                      fun acc =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (close timeout conn)
                          (fun function_parameter =>
                            match function_parameter with
                            | _ => acc
                            end)) (connected st) Lwt.return_unit)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (WriteScheduler.shutdown (write_scheduler st))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          lwt_log_info
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<-- shutdown" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<-- shutdown" % string)
                        end)
                  end)
            end)
      end).

Definition id (conn : connection) : Z := Tezos_p2p.P2p_fd.id (fd conn).
src/lib_p2p/p2p_io_scheduler.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Scheduling of I/O operations over file descriptors.

    This module defines the scheduler type [t], and connection type
    [connection]. A [connection] is a wrapper over a [P2p_fd.t]. R/W
    functions over [connection]s behave like regular R/W over file
    descriptors, but the scheduler ensures of fair allocation of bandwidth
    between them.

    To each connection is associated a read (resp. write) queue where data is
    copied to (resp. read from), at a rate of [max_download_speed /
    num_connections] (resp. [max_upload_speed / num_connections]). *)

(** Type of a connection. *)
type connection

(** Type of an IO scheduler. *)
type t

(** [create ~max_upload_speed ~max_download_speed ~read_queue_size
    ~write_queue_size ()] is an IO scheduler with specified (global)
    max upload (resp. download) speed, and specified read
    (resp. write) queue sizes (in bytes) for connections. *)
val create :
  ?max_upload_speed:int ->
  ?max_download_speed:int ->
  ?read_queue_size:int ->
  ?write_queue_size:int ->
  read_buffer_size:int ->
  unit ->
  t

(** [register sched fd] is a [connection] managed by [sched]. *)
val register : t -> P2p_fd.t -> connection

(** [write conn msg] returns [Ok ()] when [msg] has been added to
    [conn]'s write queue, or fail with an error. *)
val write :
  ?canceler:Lwt_canceler.t -> connection -> Bytes.t -> unit tzresult Lwt.t

(** [write_now conn msg] is [true] iff [msg] has been (immediately)
    added to [conn]'s write queue, [false] if it has been dropped. *)
val write_now : connection -> Bytes.t -> bool

(** [read_now conn ~pos ~len buf] blits at most [len] bytes from
    [conn]'s read queue and returns the number of bytes written in
    [buf] starting at [pos]. *)
val read_now :
  connection -> ?pos:int -> ?len:int -> Bytes.t -> int tzresult option

(** Like [read_now], but waits till [conn] read queue has at least one
    element instead of failing. *)
val read :
  ?canceler:Lwt_canceler.t ->
  connection ->
  ?pos:int ->
  ?len:int ->
  Bytes.t ->
  int tzresult Lwt.t

(** Like [read], but blits exactly [len] bytes in [buf]. *)
val read_full :
  ?canceler:Lwt_canceler.t ->
  connection ->
  ?pos:int ->
  ?len:int ->
  Bytes.t ->
  unit tzresult Lwt.t

(** [stat conn] is a snapshot of current bandwidth usage for
    [conn]. *)
val stat : connection -> P2p_stat.t

(** [global_stat sched] is a snapshot of [sched]'s bandwidth usage
    (sum of [stat conn] for each [conn] in [sched]). *)
val global_stat : t -> P2p_stat.t

(** [iter_connection sched f] applies [f] on each connection managed
    by [sched]. *)
val iter_connection : t -> (connection -> unit) -> unit

(** [close conn] cancels [conn] and returns after any pending data has
    been sent. *)
val close : ?timeout:float -> connection -> unit tzresult Lwt.t

(** [shutdown sched] returns after all connections managed by [sched]
    have been closed and [sched]'s inner worker has successfully
    canceled. *)
val shutdown : ?timeout:float -> t -> unit Lwt.t

(** [id connection] returns the identifier of the underlying [P2p_fd.t]
    file descriptor. This uniquely identifies a connection. *)
val id : connection -> int
src/lib_p2p/p2p_io_scheduler.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter connection : Type.

Parameter t : Type.

Parameter create :
(option Z) -> (option Z) -> (option Z) -> (option Z) -> Z -> unit -> t.

Parameter register : t -> Tezos_p2p.P2p_fd.t -> connection.

Parameter write :
(option Tezos_stdlib.Lwt_canceler.t) ->
  connection -> Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter write_now : connection -> Stdlib.Bytes.t -> bool.

Parameter read_now :
connection ->
  (option Z) ->
    (option Z) -> Stdlib.Bytes.t -> option (Tezos_base__TzPervasives.tzresult Z).

Parameter read :
(option Tezos_stdlib.Lwt_canceler.t) ->
  connection ->
    (option Z) ->
      (option Z) ->
        Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Z).

Parameter read_full :
(option Tezos_stdlib.Lwt_canceler.t) ->
  connection ->
    (option Z) ->
      (option Z) ->
        Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter stat : connection -> Tezos_base__TzPervasives.P2p_stat.t.

Parameter global_stat : t -> Tezos_base__TzPervasives.P2p_stat.t.

Parameter iter_connection : t -> (connection -> unit) -> unit.

Parameter close :
(option float) -> connection -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter shutdown : (option float) -> t -> Lwt.t unit.

Parameter id : connection -> Z.
src/lib_p2p/p2p_maintenance.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.maintenance"
end)

let time_between_looking_for_peers = 5.0 (* TODO put this in config *)

type bounds = {
  min_threshold : int;
  min_target : int;
  max_target : int;
  max_threshold : int;
}

type config = {
  maintenance_idle_time : Time.System.Span.t;
  greylist_timeout : Time.System.Span.t;
  private_mode : bool;
  min_connections : int;
  max_connections : int;
  expected_connections : int;
}

type ('msg, 'meta, 'meta_conn) t = {
  canceler : Lwt_canceler.t;
  config : config;
  bounds : bounds;
  pool : ('msg, 'meta, 'meta_conn) P2p_pool.t;
  discovery : P2p_discovery.t option;
  just_maintained : unit Lwt_condition.t;
  please_maintain : unit Lwt_condition.t;
  mutable maintain_worker : unit Lwt.t;
}

let classify pool private_mode start_time seen_points point pi =
  let now = Systime_os.now () in
  if
    P2p_point.Set.mem point seen_points
    || P2p_pool.Points.banned pool point
    || (private_mode && not (P2p_point_state.Info.trusted pi))
  then `Ignore
  else
    match P2p_point_state.get pi with
    | Disconnected -> (
      match P2p_point_state.Info.last_miss pi with
      | Some last
        when Time.System.(start_time < last)
             || P2p_point_state.Info.greylisted ~now pi ->
          `Seen
      | last ->
          `Candidate last )
    | _ ->
        `Seen

(** [establish t contactable] tries to establish as many connection as possible
    with points in [contactable]. It returns the number of established
    connections *)
let establish t contactable =
  let try_to_connect acc point =
    protect ~canceler:t.canceler (fun () -> P2p_pool.connect t.pool point)
    >>= function Ok _ -> acc >|= succ | Error _ -> acc
  in
  List.fold_left try_to_connect (Lwt.return 0) contactable

(* [connectable t start_time expected seen_points] selects at most
   [expected] connections candidates from the known points, not in [seen]
   points. *)
let connectable t start_time expected seen_points =
  let module Bounded_point_info = List.Bounded (struct
    type t = Time.System.t option * P2p_point.Id.t

    let compare (t1, _) (t2, _) =
      match (t1, t2) with
      | (None, None) ->
          0
      | (None, Some _) ->
          1
      | (Some _, None) ->
          -1
      | (Some t1, Some t2) ->
          Time.System.compare t2 t1
  end) in
  let acc = Bounded_point_info.create expected in
  let f point pi seen_points =
    match
      classify t.pool t.config.private_mode start_time seen_points point pi
    with
    | `Ignore ->
        seen_points (* Ignored points can be retried again *)
    | `Candidate last ->
        Bounded_point_info.insert (last, point) acc ;
        P2p_point.Set.add point seen_points
    | `Seen ->
        P2p_point.Set.add point seen_points
  in
  let seen_points = P2p_pool.Points.fold_known t.pool ~init:seen_points ~f in
  (List.map snd (Bounded_point_info.get acc), seen_points)

(* [try_to_contact_loop t start_time ~seen_points] is the main loop
    for contacting points. [start_time] is set when calling the function
    and remains constant in the loop. [seen_points] simply accumulates the
    points already seen, to avoid trying to contact them again.

    It repeats two operations until the number of connections is reached:
      - get [max_to_contact] points
      - connect to many of them as possible

   TODO why not the simpler implementation. Sort all candidates points,
        and try to connect to [n] of them. *)
let rec try_to_contact_loop t start_time ~seen_points min_to_contact
    max_to_contact =
  if min_to_contact <= 0 then Lwt.return_true
  else
    let (candidates, seen_points) =
      connectable t start_time max_to_contact seen_points
    in
    if candidates = [] then Lwt_unix.yield () >>= fun () -> Lwt.return_false
    else
      establish t candidates
      >>= fun established ->
      try_to_contact_loop
        t
        start_time
        ~seen_points
        (min_to_contact - established)
        (max_to_contact - established)

(** [try_to_contact t min_to_contact max_to_contact] tries to create
    between [min_to_contact] and [max_to_contact] new connections.

    It goes through all know points, and ignores points which are
    - greylisted,
    - banned,
    - for which a connection failed after the time this function is called
    - Non-trusted points if option --private-mode is set.

    It tries to favor points for which the last failed missed connection is old.

    Note that this function works as a sequence of lwt tasks that tries
    to incrementally reach the number of connections. The set of
    known points maybe be concurrently updated. *)
let try_to_contact t min_to_contact max_to_contact =
  let start_time = Systime_os.now () in
  let seen_points = P2p_point.Set.empty in
  try_to_contact_loop t start_time min_to_contact max_to_contact ~seen_points

(** not enough contacts, ask the pals of our pals,
    discover the local network and then wait *)
let ask_for_more_contacts t =
  P2p_pool.broadcast_bootstrap_msg t.pool ;
  Option.iter ~f:P2p_discovery.wakeup t.discovery ;
  protect ~canceler:t.canceler (fun () ->
      Lwt.pick
        [ P2p_pool.Pool_event.wait_new_peer t.pool;
          P2p_pool.Pool_event.wait_new_point t.pool;
          (* TODO exponential back-off, or wait for the existence
         of a non grey-listed peer? *)
          Lwt_unix.sleep time_between_looking_for_peers ]
      >>= fun () -> return_unit)

(** Selects [n] random connections. Ignore connections to
    nodes who are both private and trusted. *)
let random_connections pool n =
  let open P2p_pool.Connection in
  let f _ conn acc =
    if private_node conn && trusted_node conn then acc else conn :: acc
  in
  let candidates = fold pool ~init:[] ~f |> TzList.shuffle in
  TzList.rev_sub candidates n

(** GC peers from the greylist that has been greylisted for more than
    [t.config.greylist_timeout] *)
let trigger_greylist_gc t =
  let now = Systime_os.now () in
  let minus_greylist_timeout = Ptime.Span.neg t.config.greylist_timeout in
  let time = Ptime.add_span now minus_greylist_timeout in
  let older_than =
    Option.unopt_exn (Failure "P2p_maintenance.maintain: time overflow") time
  in
  P2p_pool.gc_greylist t.pool ~older_than

(** Maintenance step.
    1. trigger greylist gc
    2. tries *forever* to achieve a number of connections
       between `min_threshold` and `max_threshold`. *)
let rec do_maintain t =
  trigger_greylist_gc t ;
  let n_connected = P2p_pool.active_connections t.pool in
  if n_connected < t.bounds.min_threshold then
    too_few_connections t n_connected
  else if t.bounds.max_threshold < n_connected then
    too_many_connections t n_connected
  else (
    (* end of maintenance when enough users have been reached *)
    Lwt_condition.broadcast t.just_maintained () ;
    lwt_debug "Maintenance step ended" >>= fun () -> return_unit )

and too_few_connections t n_connected =
  (* try and contact new peers *)
  lwt_log_notice "Too few connections (%d)" n_connected
  >>= fun () ->
  let min_to_contact = t.bounds.min_target - n_connected in
  let max_to_contact = t.bounds.max_target - n_connected in
  try_to_contact t min_to_contact max_to_contact
  >>= fun success ->
  (if success then return_unit else ask_for_more_contacts t)
  >>=? fun () -> do_maintain t

and too_many_connections t n_connected =
  (* kill random connections *)
  let n = n_connected - t.bounds.max_target in
  lwt_log_notice "Too many connections, will kill %d" n
  >>= fun () ->
  let connections = random_connections t.pool n in
  Lwt_list.iter_p P2p_pool.disconnect connections >>= fun () -> do_maintain t

let rec worker_loop t =
  (let n_connected = P2p_pool.active_connections t.pool in
   if
     n_connected < t.bounds.min_threshold
     || t.bounds.max_threshold < n_connected
   then do_maintain t
   else
     ( P2p_pool.send_swap_request t.pool ;
       return_unit )
     >>=? fun () ->
     protect ~canceler:t.canceler (fun () ->
         Lwt.pick
           [ (* default: every two minutes *)
             Systime_os.sleep t.config.maintenance_idle_time;
             Lwt_condition.wait t.please_maintain;
             (* when asked *)
             P2p_pool.Pool_event.wait_too_few_connections t.pool;
             (* limits *)
             P2p_pool.Pool_event.wait_too_many_connections t.pool ]
         >>= fun () -> return_unit))
  >>= function
  | Ok () ->
      worker_loop t
  | Error (Canceled :: _) ->
      Lwt.return_unit
  | Error _ ->
      Lwt.return_unit

let bounds ~min ~expected ~max =
  assert (min <= expected) ;
  assert (expected <= max) ;
  let step_min = (expected - min) / 3 and step_max = (max - expected) / 3 in
  {
    min_threshold = min + step_min;
    min_target = min + (2 * step_min);
    max_target = max - (2 * step_max);
    max_threshold = max - step_max;
  }

let create ?discovery config pool =
  let bounds =
    bounds
      ~min:config.min_connections
      ~expected:config.expected_connections
      ~max:config.max_connections
  in
  {
    canceler = Lwt_canceler.create ();
    config;
    bounds;
    discovery;
    pool;
    just_maintained = Lwt_condition.create ();
    please_maintain = Lwt_condition.create ();
    maintain_worker = Lwt.return_unit;
  }

let activate t =
  t.maintain_worker <-
    Lwt_utils.worker
      "maintenance"
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> worker_loop t)
      ~cancel:(fun () -> Lwt_canceler.cancel t.canceler) ;
  Option.iter t.discovery ~f:P2p_discovery.activate

let maintain t =
  let wait = Lwt_condition.wait t.just_maintained in
  Lwt_condition.broadcast t.please_maintain () ;
  wait

let shutdown {canceler; discovery; maintain_worker; just_maintained; _} =
  Lwt_canceler.cancel canceler
  >>= fun () ->
  Lwt_utils.may ~f:P2p_discovery.shutdown discovery
  >>= fun () ->
  maintain_worker
  >>= fun () ->
  Lwt_condition.broadcast just_maintained () ;
  Lwt.return_unit
src/lib_p2p/p2p_maintenance.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition time_between_looking_for_peers : float := 5.

Record bounds := {
  min_threshold : Z;
  min_target : Z;
  max_target : Z;
  max_threshold : Z }.

Record config := {
  maintenance_idle_time : Tezos_base__TzPervasives.Time.System.Span.t;
  greylist_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  private_mode : bool;
  min_connections : Z;
  max_connections : Z;
  expected_connections : Z }.

Record t {msg meta meta_conn : Type} := {
  canceler : Tezos_stdlib.Lwt_canceler.t;
  config : config;
  bounds : bounds;
  pool : Tezos_p2p.P2p_pool.t msg meta meta_conn;
  discovery : option Tezos_p2p.P2p_discovery.t;
  just_maintained : Lwt_condition.t unit;
  please_maintain : Lwt_condition.t unit;
  maintain_worker : Lwt.t unit }.
Arguments t : clear implicits.

Definition classify {A B C D : Type}
  (pool : Tezos_p2p__P2p_pool.pool A B C) (private_mode : bool)
  (start_time : Tezos_base__TzPervasives.Time.System.t)
  (seen_points : Tezos_base__TzPervasives.P2p_point.Set.t)
  (point : Tezos_base__TzPervasives.P2p_point.Set.elt)
  (pi : Tezos_p2p.P2p_point_state.Info.point_info D) : variant :=
  let now := Tezos_stdlib_unix.Systime_os.now tt in
  if
    orb (Tezos_base__TzPervasives.P2p_point.Set.mem point seen_points)
      (orb (Tezos_p2p.P2p_pool.Points.banned pool point)
        (andb private_mode (negb (Tezos_p2p.P2p_point_state.Info.trusted pi))))
    then
    variant
  else
    match Tezos_p2p.P2p_point_state.get pi with
    | Disconnected =>
      match Tezos_p2p.P2p_point_state.Info.last_miss pi with
      | last => variant
      end
    | _ => variant
    end.

Definition establish {A B C : Type}
  (t : t A B C) (contactable : list Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t Z :=
  let try_to_connect
    (acc : Lwt.t Z) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t Z :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.protect None (Some (canceler t))
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_p2p.P2p_pool.connect None (pool t) point
          end))
      (fun function_parameter =>
        match function_parameter with
        | inl _ => Tezos_base__TzPervasives.op_gt_pipe_eq acc Z.succ
        | inr _ => acc
        end) in
  Tezos_base__TzPervasives.List.fold_left try_to_connect (Lwt._return 0)
    contactable.

Definition connectable {A B C : Type}
  (t : t A B C) (start_time : Tezos_base__TzPervasives.Time.System.t)
  (expected : Z) (seen_points : Tezos_base__TzPervasives.P2p_point.Set.t)
  : (list Tezos_base__TzPervasives.P2p_point.Id.t) *
    Tezos_base__TzPervasives.P2p_point.Set.t :=
  let Bounded_point_info := unsupported_functor_application in
  let acc := Bounded_point_info.create expected in
  let f {D : Type}
    (point : Tezos_base__TzPervasives.P2p_point.Set.elt) (pi :
    Tezos_p2p.P2p_point_state.Info.point_info D) (seen_points :
    Tezos_base__TzPervasives.P2p_point.Set.t)
    : Tezos_base__TzPervasives.P2p_point.Set.t :=
    match
      classify (pool t) (private_mode (config t)) start_time seen_points point
        pi with
    | Ignore => seen_points
    | Candidate last =>
      Bounded_point_info.insert (last, point) acc;
      Tezos_base__TzPervasives.P2p_point.Set.add point seen_points
    | Seen => Tezos_base__TzPervasives.P2p_point.Set.add point seen_points
    end in
  let seen_points := Tezos_p2p.P2p_pool.Points.fold_known (pool t) seen_points f
    in
  ((Tezos_base__TzPervasives.List.map snd (Bounded_point_info.get acc)),
    seen_points).

Fixpoint try_to_contact_loop {A B C : Type}
  (t : t A B C) (start_time : Tezos_base__TzPervasives.Time.System.t)
  (seen_points : Tezos_base__TzPervasives.P2p_point.Set.t) (min_to_contact : Z)
  (max_to_contact : Z) : Lwt.t bool :=
  if OCaml.Stdlib.le min_to_contact 0 then
    Lwt.return_true
  else
    match connectable t start_time max_to_contact seen_points with
    | (candidates, seen_points) =>
      if equiv_decb candidates [] then
        Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt.return_false
            end)
      else
        Tezos_base__TzPervasives.op_gt_gt_eq (establish t candidates)
          (fun established =>
            try_to_contact_loop t start_time seen_points
              (Z.sub min_to_contact established)
              (Z.sub max_to_contact established))
    end.

Definition try_to_contact {A B C : Type}
  (t : t A B C) (min_to_contact : Z) (max_to_contact : Z) : Lwt.t bool :=
  let start_time := Tezos_stdlib_unix.Systime_os.now tt in
  let seen_points := Tezos_base__TzPervasives.P2p_point.Set.empty in
  try_to_contact_loop t start_time seen_points min_to_contact max_to_contact.

Definition ask_for_more_contacts {A B C : Type} (t : t A B C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_p2p.P2p_pool.broadcast_bootstrap_msg (pool t);
  Tezos_stdlib.Option.iter Tezos_p2p.P2p_discovery.wakeup (discovery t);
  Tezos_base__TzPervasives.protect None (Some (canceler t))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Lwt.pick
            (cons (Tezos_p2p.P2p_pool.Pool_event.wait_new_peer (pool t))
              (cons (Tezos_p2p.P2p_pool.Pool_event.wait_new_point (pool t))
                (cons (Lwt_unix.sleep time_between_looking_for_peers) []))))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition random_connections {A B C : Type}
  (pool : Tezos_p2p__P2p_pool.pool A B C) (n : Z)
  : list (Tezos_p2p__P2p_pool.connection A B C) :=
  let f {D E F G : Type} (function_parameter : D)
    : (Tezos_p2p__P2p_pool.connection E F G) ->
      (list (Tezos_p2p__P2p_pool.connection E F G)) ->
        list (Tezos_p2p__P2p_pool.connection E F G) :=
    match function_parameter with
    | _ =>
      fun conn =>
        fun acc =>
          if
            andb (Tezos_p2p.P2p_pool.Connection.private_node conn)
              (Tezos_p2p.P2p_pool.Connection.trusted_node conn) then
            acc
          else
            cons conn acc
    end in
  let candidates :=
    OCaml.Stdlib.reverse_apply (Tezos_p2p.P2p_pool.Connection.fold pool [] f)
      Tezos_stdlib.TzList.shuffle in
  Tezos_stdlib.TzList.rev_sub candidates n.

Definition trigger_greylist_gc {A B C : Type} (t : t A B C) : unit :=
  let now := Tezos_stdlib_unix.Systime_os.now tt in
  let minus_greylist_timeout := Ptime.Span.neg (greylist_timeout (config t)) in
  let time := Ptime.add_span now minus_greylist_timeout in
  let older_than :=
    Tezos_stdlib.Option.unopt_exn
      (OCaml.Failure "P2p_maintenance.maintain: time overflow" % string) time in
  Tezos_p2p.P2p_pool.gc_greylist older_than (pool t).

Fixpoint do_maintain {A B C : Type} (t : t A B C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  trigger_greylist_gc t;
  let n_connected := Tezos_p2p.P2p_pool.active_connections (pool t) in
  if OCaml.Stdlib.lt n_connected (min_threshold (bounds t)) then
    too_few_connections t n_connected
  else
    if OCaml.Stdlib.lt (max_threshold (bounds t)) n_connected then
      too_many_connections t n_connected
    else
      Lwt_condition.broadcast (just_maintained t) tt;
      Tezos_base__TzPervasives.op_gt_gt_eq
        (lwt_debug
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Maintenance step ended" % string
              CamlinternalFormatBasics.End_of_format)
            "Maintenance step ended" % string))
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_base__TzPervasives.return_unit
          end)

with too_few_connections {A B C : Type} (t : t A B C) (n_connected : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_log_notice
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Too few connections (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Too few connections (%d)" % string) n_connected)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let min_to_contact := Z.sub (min_target (bounds t)) n_connected in
        let max_to_contact := Z.sub (max_target (bounds t)) n_connected in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (try_to_contact t min_to_contact max_to_contact)
          (fun success =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (if success then
                Tezos_base__TzPervasives.return_unit
              else
                ask_for_more_contacts t)
              (fun function_parameter =>
                match function_parameter with
                | tt => do_maintain t
                end))
      end)

with too_many_connections {A B C : Type} (t : t A B C) (n_connected : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let n := Z.sub n_connected (max_target (bounds t)) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_log_notice
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Too many connections, will kill " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format))
        "Too many connections, will kill %d" % string) n)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let connections := random_connections (pool t) n in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Lwt_list.iter_p
            (let arg := Tezos_p2p.P2p_pool.disconnect in
            fun eta => arg None eta) connections)
          (fun function_parameter =>
            match function_parameter with
            | tt => do_maintain t
            end)
      end).

Fixpoint worker_loop {A B C : Type} (t : t A B C) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (let n_connected := Tezos_p2p.P2p_pool.active_connections (pool t) in
    if
      orb (OCaml.Stdlib.lt n_connected (min_threshold (bounds t)))
        (OCaml.Stdlib.lt (max_threshold (bounds t)) n_connected) then
      do_maintain t
    else
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_p2p.P2p_pool.send_swap_request (pool t);
        Tezos_base__TzPervasives.return_unit)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.protect None (Some (canceler t))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Lwt.pick
                      (cons
                        (Tezos_stdlib_unix.Systime_os.sleep
                          (maintenance_idle_time (config t)))
                        (cons (Lwt_condition.wait None (please_maintain t))
                          (cons
                            (Tezos_p2p.P2p_pool.Pool_event.wait_too_few_connections
                              (pool t))
                            (cons
                              (Tezos_p2p.P2p_pool.Pool_event.wait_too_many_connections
                                (pool t)) [])))))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end)
          end))
    (fun function_parameter =>
      match function_parameter with
      | inl tt => worker_loop t
      | inr (cons Canceled _) => Lwt.return_unit
      | inr _ => Lwt.return_unit
      end).

Definition bounds (min : Z) (expected : Z) (max : Z) : bounds :=
  OCaml.Stdlib.le min expected;
  OCaml.Stdlib.le expected max;
  let step_min : Z :=
    Z.div (Z.sub expected min) 3
  with step_max : Z :=
    Z.div (Z.sub max expected) 3 in
  {| min_threshold := Z.add min step_min;
    min_target := Z.add min (Z.mul 2 step_min);
    max_target := Z.sub max (Z.mul 2 step_max);
    max_threshold := Z.sub max step_max |}.

Definition create {A B C : Type}
  (discovery : option Tezos_p2p.P2p_discovery.t) (config : config)
  (pool : Tezos_p2p.P2p_pool.t A B C) : t A B C :=
  let bounds :=
    bounds (min_connections config) (expected_connections config)
      (max_connections config) in
  {| canceler := Tezos_stdlib.Lwt_canceler.create tt; config := config;
    bounds := bounds; pool := pool; discovery := discovery;
    just_maintained := Lwt_condition.create tt;
    please_maintain := Lwt_condition.create tt;
    maintain_worker := Lwt.return_unit |}.

Definition activate {A B C : Type} (t : t A B C) : unit :=
  set_field;
  Tezos_stdlib.Option.iter Tezos_p2p.P2p_discovery.activate (discovery t).

Definition maintain {A B C : Type} (t : t A B C) : Lwt.t unit :=
  let wait := Lwt_condition.wait None (just_maintained t) in
  Lwt_condition.broadcast (please_maintain t) tt;
  wait.

Definition shutdown {A B C : Type} (function_parameter : t A B C)
  : Lwt.t unit :=
  match function_parameter with
  | {|
    canceler := canceler;
      discovery := discovery;
      just_maintained := just_maintained;
      maintain_worker := maintain_worker
      |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_stdlib.Lwt_canceler.cancel canceler)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_stdlib.Lwt_utils.may Tezos_p2p.P2p_discovery.shutdown
              discovery)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq maintain_worker
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Lwt_condition.broadcast just_maintained tt;
                      Lwt.return_unit
                    end)
              end)
        end)
  end.
src/lib_p2p/p2p_maintenance.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** P2P maintenance worker.

    This worker enforces the connection bounds defined on the command-line
    or/and the configuration file.

    The maintenance process is launched:
    . If not launched within [maintenance_idle_time] seconds
    . When any of the following future  is resolved
        [P2p_pool.Pool_event.wait_too_few_connections]
        [P2p_pool.Pool_event.wait_too_many_connections]
        [P2p_pool.Pool_event.wait_too_few_trusted_connections]
    . When [maintain] is called

    If the number of connections is above the limit, the maintainer
    kill existing connections.

    If below the limit, it tries to connect to points available from [P2p_pool].
    If not enough connections can be obtained, it requires new points from
    [P2p_pool] using [P2p_pool.broadcast msg], and wakes up the
    [P2p_discovery] worker. It then waits for new peers or points by waiting
    on futures
      [P2p_pool.Pool_event.wait_new_peer]
      [P2p_pool.Pool_event.wait_new_point pool]
    This is reiterated indefinitely every [require_new_points_time] seconds. *)

type config = {
  maintenance_idle_time : Time.System.Span.t;
      (** How long to wait at most, in seconds, before running a maintenance loop. *)
  greylist_timeout : Time.System.Span.t;
      (** GC delay for the greylists tables, in seconds. *)
  private_mode : bool;
      (** If [true], only open outgoing/accept incoming connections
      to/from peers whose addresses are in [trusted_peers], and inform
      these peers that the identity of this node should be revealed to
      the rest of the network. *)
  min_connections : int;  (** Strict minimum number of connections *)
  max_connections : int;  (** Maximum number of connections *)
  expected_connections : int;  (** Targeted number of connections to reach *)
}

(** Type of a maintenance worker. *)
type ('msg, 'meta, 'meta_conn) t

(** [starts ?discovery config pool] returns a maintenance worker, with
    the [discovery] worker if present, for [pool]. *)
val create :
  ?discovery:P2p_discovery.t ->
  config ->
  ('msg, 'meta, 'meta_conn) P2p_pool.t ->
  ('msg, 'meta, 'meta_conn) t

(** [activate t] starts the worker that will maintain connections *)
val activate : ('msg, 'meta, 'meta_conn) t -> unit

(** [maintain t] gives a hint to maintenance worker [t] that
    maintenance is needed and returns whenever [t] has done a
    maintenance cycle. *)
val maintain : ('msg, 'meta, 'meta_conn) t -> unit Lwt.t

(** [shutdown t] is a thread that returns whenever [t] has
    successfully shut down. *)
val shutdown : ('msg, 'meta, 'meta_conn) t -> unit Lwt.t
src/lib_p2p/p2p_maintenance.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record config := {
  maintenance_idle_time : Tezos_base__TzPervasives.Time.System.Span.t;
  greylist_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  private_mode : bool;
  min_connections : Z;
  max_connections : Z;
  expected_connections : Z }.

Parameter t : forall (msg meta meta_conn : Type), Type.

Parameter create : forall {meta meta_conn msg : Type},
(option Tezos_p2p.P2p_discovery.t) ->
  config -> (Tezos_p2p.P2p_pool.t msg meta meta_conn) -> t msg meta meta_conn.

Parameter activate : forall {meta meta_conn msg : Type},
(t msg meta meta_conn) -> unit.

Parameter maintain : forall {meta meta_conn msg : Type},
(t msg meta meta_conn) -> Lwt.t unit.

Parameter shutdown : forall {meta meta_conn msg : Type},
(t msg meta meta_conn) -> Lwt.t unit.
src/lib_p2p/p2p_message.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'msg encoding =
  | Encoding : {
      tag : int;
      title : string;
      encoding : 'a Data_encoding.t;
      wrap : 'a -> 'msg;
      unwrap : 'msg -> 'a option;
      max_length : int option;
    }
      -> 'msg encoding

type 'msg t =
  | Bootstrap
  | Advertise of P2p_point.Id.t list
  | Swap_request of P2p_point.Id.t * P2p_peer.Id.t
  | Swap_ack of P2p_point.Id.t * P2p_peer.Id.t
  | Message of 'msg
  | Disconnect

let encoding msg_encoding =
  let open Data_encoding in
  dynamic_size
  @@ union
       ~tag_size:`Uint16
       ( [ case
             (Tag 0x01)
             ~title:"Disconnect"
             (obj1 (req "kind" (constant "Disconnect")))
             (function Disconnect -> Some () | _ -> None)
             (fun () -> Disconnect);
           case
             (Tag 0x02)
             ~title:"Bootstrap"
             (obj1 (req "kind" (constant "Bootstrap")))
             (function Bootstrap -> Some () | _ -> None)
             (fun () -> Bootstrap);
           case
             (Tag 0x03)
             ~title:"Advertise"
             (obj2
                (req "id" (Variable.list P2p_point.Id.encoding))
                (req "kind" (constant "Advertise")))
             (function Advertise points -> Some (points, ()) | _ -> None)
             (fun (points, ()) -> Advertise points);
           case
             (Tag 0x04)
             ~title:"Swap_request"
             (obj3
                (req "point" P2p_point.Id.encoding)
                (req "peer_id" P2p_peer.Id.encoding)
                (req "kind" (constant "Swap_request")))
             (function
               | Swap_request (point, peer_id) ->
                   Some (point, peer_id, ())
               | _ ->
                   None)
             (fun (point, peer_id, ()) -> Swap_request (point, peer_id));
           case
             (Tag 0x05)
             ~title:"Swap_ack"
             (obj3
                (req "point" P2p_point.Id.encoding)
                (req "peer_id" P2p_peer.Id.encoding)
                (req "kind" (constant "Swap_ack")))
             (function
               | Swap_ack (point, peer_id) ->
                   Some (point, peer_id, ())
               | _ ->
                   None)
             (fun (point, peer_id, ()) -> Swap_ack (point, peer_id)) ]
       @ ListLabels.map msg_encoding ~f:(function
             | Encoding
                 {tag; title; encoding; wrap; unwrap; max_length = _ (* ?? *)}
             ->
             Data_encoding.case
               (Tag tag)
               ~title
               encoding
               (function Message msg -> unwrap msg | _ -> None)
               (fun msg -> Message (wrap msg))) )
src/lib_p2p/p2p_message.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive encoding (msg : Type) : Type :=
| Encoding : forall {a : Type}, Z -> string ->
  (Tezos_base__TzPervasives.Data_encoding.t a) -> (a -> msg) ->
  (msg -> option a) -> (option Z) -> encoding msg.

Arguments Encoding {_}.

Inductive t (msg : Type) : Type :=
| Bootstrap : t msg
| Advertise : (list Tezos_base__TzPervasives.P2p_point.Id.t) -> t msg
| Swap_request : Tezos_base__TzPervasives.P2p_point.Id.t ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> t msg
| Swap_ack : Tezos_base__TzPervasives.P2p_point.Id.t ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> t msg
| Message : msg -> t msg
| Disconnect : t msg.

Arguments Bootstrap {_}.
Arguments Advertise {_}.
Arguments Swap_request {_}.
Arguments Swap_ack {_}.
Arguments Message {_}.
Arguments Disconnect {_}.

Definition encoding {A : Type} (msg_encoding : list (encoding A))
  : Tezos_base__TzPervasives.Data_encoding.encoding (t A) :=
  apply
    (let arg := Tezos_base__TzPervasives.Data_encoding.dynamic_size in
    fun eta => arg None eta)
    (Tezos_base__TzPervasives.Data_encoding.union (Some variant)
      (OCaml.Stdlib.app
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Disconnect" % string
            None (Tag 1)
            (Tezos_base__TzPervasives.Data_encoding.obj1
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "kind" % string
                (Tezos_base__TzPervasives.Data_encoding.constant
                  "Disconnect" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Disconnect => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => Disconnect
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case "Bootstrap" % string
              None (Tag 2)
              (Tezos_base__TzPervasives.Data_encoding.obj1
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "kind" % string
                  (Tezos_base__TzPervasives.Data_encoding.constant
                    "Bootstrap" % string)))
              (fun function_parameter =>
                match function_parameter with
                | Bootstrap => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | tt => Bootstrap
                end))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case "Advertise" % string
                None (Tag 3)
                (Tezos_base__TzPervasives.Data_encoding.obj2
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "id" % string
                    (Tezos_base__TzPervasives.Data_encoding.Variable.list None
                      Tezos_base__TzPervasives.P2p_point.Id.encoding))
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "kind" % string
                    (Tezos_base__TzPervasives.Data_encoding.constant
                      "Advertise" % string)))
                (fun function_parameter =>
                  match function_parameter with
                  | Advertise points => Some (points, tt)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (points, tt) => Advertise points
                  end))
              (cons
                (Tezos_base__TzPervasives.Data_encoding.case
                  "Swap_request" % string None (Tag 4)
                  (Tezos_base__TzPervasives.Data_encoding.obj3
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "point" % string
                      Tezos_base__TzPervasives.P2p_point.Id.encoding)
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "peer_id" % string
                      Tezos_base__TzPervasives.P2p_peer.Id.encoding)
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "kind" % string
                      (Tezos_base__TzPervasives.Data_encoding.constant
                        "Swap_request" % string)))
                  (fun function_parameter =>
                    match function_parameter with
                    | Swap_request point peer_id => Some (point, peer_id, tt)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | (point, peer_id, tt) => Swap_request point peer_id
                    end))
                (cons
                  (Tezos_base__TzPervasives.Data_encoding.case
                    "Swap_ack" % string None (Tag 5)
                    (Tezos_base__TzPervasives.Data_encoding.obj3
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "point" % string
                        Tezos_base__TzPervasives.P2p_point.Id.encoding)
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "peer_id" % string
                        Tezos_base__TzPervasives.P2p_peer.Id.encoding)
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "kind" % string
                        (Tezos_base__TzPervasives.Data_encoding.constant
                          "Swap_ack" % string)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Swap_ack point peer_id => Some (point, peer_id, tt)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | (point, peer_id, tt) => Swap_ack point peer_id
                      end)) [])))))
        (Stdlib.ListLabels.map
          (fun function_parameter =>
            match function_parameter with
            |
              Encoding {|
                tag := tag;
                  title := title;
                  encoding := encoding;
                  wrap := wrap;
                  unwrap := unwrap;
                  max_length := _
                  |} =>
              Tezos_base__TzPervasives.Data_encoding.case title None (Tag tag)
                encoding
                (fun function_parameter =>
                  match function_parameter with
                  | Message msg => unwrap msg
                  | _ => None
                  end) (fun msg => Message (wrap msg))
            end) msg_encoding))).
src/lib_p2p/p2p_message.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This module defines the messages of the P2p layers.

    P2p messages are parameterized by a generic upper-layer message type
    ['msg]. The P2p layer serializes these ['msg] using a ['msg encoding']
    provided by the client of this lib.

    The P2p protocol is simple and can be deduced mostly from the message type.
    To make the network topology more dynamic, it implements a simple peer
    swapping mechanism which works as follows.

    Peer A sends a message : [Swap_request (point, peer)] to B.
    If B is already connected to the peer, the message is ignored.
    Otherwise B picks a peer [peer'] at point [point'] and connect to [peer]. If
    successful, it sends a response [Swap_ack (point', peer')] to A. Upon
    reception of [Swap_ack]. B tries to connected to [peer']. If successful,
    it disconnect from [peer]. *)

(* TODO: It would be interesting to measure the effect of the swap request
         mechanism on an actual network. Is it the added complexity
         worth it, wouldn't it  be enough to rely on [Advertise]? *)

type 'msg encoding =
  | Encoding : {
      tag : int;
      title : string;
      encoding : 'a Data_encoding.t;
      wrap : 'a -> 'msg;
      unwrap : 'msg -> 'a option;
      max_length : int option;
    }
      -> 'msg encoding

type 'msg t =
  | Bootstrap  (** Welcome message sent by a peer upon connection *)
  | Advertise of P2p_point.Id.t list
      (** Response to a [Bootstrap] message, contains list of known points *)
  | Swap_request of P2p_point.Id.t * P2p_peer.Id.t
      (** Propose new peer/point and ask a peer/point to swap with *)
  | Swap_ack of P2p_point.Id.t * P2p_peer.Id.t
      (** Response to a swap request and propose peer/point to swap with. *)
  | Message of 'msg  (** Generic upper-layer message *)
  | Disconnect  (** Ending of connection *)

val encoding : 'a encoding list -> 'a t Data_encoding.t
src/lib_p2p/p2p_message.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive encoding (msg : Type) : Type :=
| Encoding : forall {a : Type}, Z -> string ->
  (Tezos_base__TzPervasives.Data_encoding.t a) -> (a -> msg) ->
  (msg -> option a) -> (option Z) -> encoding msg.

Arguments Encoding {_}.

Inductive t (msg : Type) : Type :=
| Bootstrap : t msg
| Advertise : (list Tezos_base__TzPervasives.P2p_point.Id.t) -> t msg
| Swap_request : Tezos_base__TzPervasives.P2p_point.Id.t ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> t msg
| Swap_ack : Tezos_base__TzPervasives.P2p_point.Id.t ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> t msg
| Message : msg -> t msg
| Disconnect : t msg.

Arguments Bootstrap {_}.
Arguments Advertise {_}.
Arguments Swap_request {_}.
Arguments Swap_ack {_}.
Arguments Message {_}.
Arguments Disconnect {_}.

Parameter encoding : forall {a : Type},
(list (encoding a)) -> Tezos_base__TzPervasives.Data_encoding.t (t a).
src/lib_p2p/p2p_peer_state.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open P2p_peer

type ('conn, 'conn_meta) t =
  | Accepted of {current_point : P2p_connection.Id.t; cancel : Lwt_canceler.t}
  | Running of {
      data : 'conn;
      conn_metadata : 'conn_meta;
      current_point : P2p_connection.Id.t;
    }
  | Disconnected

type ('conn, 'conn_meta) state = ('conn, 'conn_meta) t

let pp ppf = function
  | Accepted {current_point; _} ->
      Format.fprintf ppf "accepted %a" P2p_connection.Id.pp current_point
  | Running {current_point; _} ->
      Format.fprintf ppf "running %a" P2p_connection.Id.pp current_point
  | Disconnected ->
      Format.fprintf ppf "disconnected"

module Info = struct
  type ('conn, 'peer_meta, 'conn_meta) t = {
    peer_id : Id.t;
    created : Time.System.t;
    mutable state : ('conn, 'conn_meta) state;
    mutable peer_metadata : 'peer_meta;
    mutable trusted : bool;
    mutable last_failed_connection :
      (P2p_connection.Id.t * Time.System.t) option;
    mutable last_rejected_connection :
      (P2p_connection.Id.t * Time.System.t) option;
    mutable last_established_connection :
      (P2p_connection.Id.t * Time.System.t) option;
    mutable last_disconnection : (P2p_connection.Id.t * Time.System.t) option;
    events : Pool_event.t Ring.t;
    watchers : Pool_event.t Lwt_watcher.input;
  }

  type ('conn, 'peer_meta, 'conn_meta) peer_info =
    ('conn, 'peer_meta, 'conn_meta) t

  let compare gi1 gi2 = Id.compare gi1.peer_id gi2.peer_id

  let log_size = 100

  let create ?(created = Systime_os.now ()) ?(trusted = false) ~peer_metadata
      peer_id =
    {
      peer_id;
      created;
      state = Disconnected;
      peer_metadata;
      trusted;
      last_failed_connection = None;
      last_rejected_connection = None;
      last_established_connection = None;
      last_disconnection = None;
      events = Ring.create log_size;
      watchers = Lwt_watcher.create_input ();
    }

  let encoding peer_metadata_encoding =
    let open Data_encoding in
    conv
      (fun { peer_id;
             trusted;
             peer_metadata;
             events;
             created;
             last_failed_connection;
             last_rejected_connection;
             last_established_connection;
             last_disconnection;
             _ } ->
        ( peer_id,
          created,
          trusted,
          peer_metadata,
          Ring.elements events,
          last_failed_connection,
          last_rejected_connection,
          last_established_connection,
          last_disconnection ))
      (fun ( peer_id,
             created,
             trusted,
             peer_metadata,
             event_list,
             last_failed_connection,
             last_rejected_connection,
             last_established_connection,
             last_disconnection ) ->
        let info = create ~trusted ~peer_metadata peer_id in
        let events = Ring.create log_size in
        Ring.add_list info.events event_list ;
        {
          state = Disconnected;
          trusted;
          peer_id;
          peer_metadata;
          created;
          last_failed_connection;
          last_rejected_connection;
          last_established_connection;
          last_disconnection;
          events;
          watchers = Lwt_watcher.create_input ();
        })
      (obj9
         (req "peer_id" Id.encoding)
         (req "created" Time.System.encoding)
         (dft "trusted" bool false)
         (req "peer_metadata" peer_metadata_encoding)
         (dft "events" (list Pool_event.encoding) [])
         (opt
            "last_failed_connection"
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
         (opt
            "last_rejected_connection"
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
         (opt
            "last_established_connection"
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
         (opt
            "last_disconnection"
            (tup2 P2p_connection.Id.encoding Time.System.encoding)))

  let peer_id {peer_id; _} = peer_id

  let created {created; _} = created

  let peer_metadata {peer_metadata; _} = peer_metadata

  let set_peer_metadata gi peer_metadata = gi.peer_metadata <- peer_metadata

  let trusted {trusted; _} = trusted

  let set_trusted gi = gi.trusted <- true

  let unset_trusted gi = gi.trusted <- false

  let last_established_connection s = s.last_established_connection

  let last_disconnection s = s.last_disconnection

  let last_failed_connection s = s.last_failed_connection

  let last_rejected_connection s = s.last_rejected_connection

  let last_seen s =
    Time.System.recent
      s.last_established_connection
      (Time.System.recent s.last_rejected_connection s.last_disconnection)

  let last_miss s =
    Time.System.recent
      s.last_failed_connection
      (Time.System.recent s.last_rejected_connection s.last_disconnection)

  let log {events; watchers; _} ?(timestamp = Systime_os.now ()) point kind =
    let event = {Pool_event.kind; timestamp; point} in
    Ring.add events event ;
    Lwt_watcher.notify watchers event

  let log_incoming_rejection ?timestamp peer_info point =
    log peer_info ?timestamp point Rejecting_request

  module File = struct
    let load path peer_metadata_encoding =
      let enc = Data_encoding.list (encoding peer_metadata_encoding) in
      if path <> "/dev/null" && Sys.file_exists path then
        Lwt_utils_unix.Json.read_file path
        >>=? fun json -> return (Data_encoding.Json.destruct enc json)
      else return_nil

    let save path peer_metadata_encoding peers =
      let open Data_encoding in
      Lwt_utils_unix.Json.write_file path
      @@ Json.construct (list (encoding peer_metadata_encoding)) peers
  end

  let watch {watchers; _} = Lwt_watcher.create_stream watchers

  let fold {events; _} ~init ~f = Ring.fold events ~init ~f
end

let get {Info.state; _} = state

let is_disconnected {Info.state; _} =
  match state with Disconnected -> true | Accepted _ | Running _ -> false

let set_accepted ?(timestamp = Systime_os.now ()) peer_info current_point
    cancel =
  assert (
    match peer_info.Info.state with
    | Accepted _ | Running _ ->
        false
    | Disconnected ->
        true ) ;
  peer_info.state <- Accepted {current_point; cancel} ;
  Info.log peer_info ~timestamp current_point Accepting_request

let set_running ?(timestamp = Systime_os.now ()) peer_info point data
    conn_metadata =
  assert (
    match peer_info.Info.state with
    | Disconnected ->
        true (* request to unknown peer_id. *)
    | Running _ ->
        false
    | Accepted {current_point; _} ->
        P2p_connection.Id.equal point current_point ) ;
  peer_info.state <- Running {data; conn_metadata; current_point = point} ;
  peer_info.last_established_connection <- Some (point, timestamp) ;
  Info.log peer_info ~timestamp point Connection_established

let set_disconnected ?(timestamp = Systime_os.now ()) ?(requested = false)
    peer_info =
  let (current_point, (event : Pool_event.kind)) =
    match peer_info.Info.state with
    | Accepted {current_point; _} ->
        peer_info.last_rejected_connection <- Some (current_point, timestamp) ;
        (current_point, Request_rejected)
    | Running {current_point; _} ->
        peer_info.last_disconnection <- Some (current_point, timestamp) ;
        ( current_point,
          if requested then Disconnection else External_disconnection )
    | Disconnected ->
        assert false
  in
  peer_info.state <- Disconnected ;
  Info.log peer_info ~timestamp current_point event
src/lib_p2p/p2p_peer_state.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.P2p_peer.

Inductive t (conn conn_meta : Type) : Type :=
| Accepted : Tezos_base__TzPervasives.P2p_connection.Id.t ->
  Tezos_stdlib.Lwt_canceler.t -> t conn conn_meta
| Running : conn -> conn_meta -> Tezos_base__TzPervasives.P2p_connection.Id.t ->
  t conn conn_meta
| Disconnected : t conn conn_meta.

Arguments Accepted {_ _}.
Arguments Running {_ _}.
Arguments Disconnected {_ _}.

Definition state (conn conn_meta : Type) := t conn conn_meta.

Definition pp {A B : Type}
  (ppf : Stdlib.Format.formatter) (function_parameter : t A B) : unit :=
  match function_parameter with
  | Accepted {| current_point := current_point |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "accepted " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "accepted %a" % string) Tezos_base__TzPervasives.P2p_connection.Id.pp
      current_point
  | Running {| current_point := current_point |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "running " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "running %a" % string) Tezos_base__TzPervasives.P2p_connection.Id.pp
      current_point
  | Disconnected =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "disconnected" % string
          CamlinternalFormatBasics.End_of_format) "disconnected" % string)
  end.

Module Info.
  Record t {conn peer_meta conn_meta : Type} := {
    peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
    created : Tezos_base__TzPervasives.Time.System.t;
    state : state conn conn_meta;
    peer_metadata : peer_meta;
    trusted : bool;
    last_failed_connection :
      option
        (Tezos_base__TzPervasives.P2p_connection.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    last_rejected_connection :
      option
        (Tezos_base__TzPervasives.P2p_connection.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    last_established_connection :
      option
        (Tezos_base__TzPervasives.P2p_connection.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    last_disconnection :
      option
        (Tezos_base__TzPervasives.P2p_connection.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    events : Tezos_stdlib.Ring.t Tezos_base__TzPervasives.P2p_peer.Pool_event.t;
    watchers :
      Tezos_stdlib.Lwt_watcher.input
        Tezos_base__TzPervasives.P2p_peer.Pool_event.t }.
  Arguments t : clear implicits.
  
  Definition peer_info (conn peer_meta conn_meta : Type) :=
    t conn peer_meta conn_meta.
  
  Definition compare {A B C D E F : Type} (gi1 : t A B C) (gi2 : t D E F) : Z :=
    Tezos_base__TzPervasives.P2p_peer.Id.compare (peer_id gi1) (peer_id gi2).
  
  Definition log_size : Z := 100.
  
  Definition create {A B C : Type}
    (op_star_o_p_t_star : option Tezos_base__TzPervasives.Time.System.t)
    : (option bool) -> A -> Tezos_base__TzPervasives.P2p_peer.Id.t -> t B A C :=
    let created :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => Tezos_stdlib_unix.Systime_os.now tt
      end in
    fun op_star_o_p_t_star =>
      let trusted :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => false
        end in
      fun peer_metadata =>
        fun peer_id =>
          {| peer_id := peer_id; created := created; state := Disconnected;
            peer_metadata := peer_metadata; trusted := trusted;
            last_failed_connection := None; last_rejected_connection := None;
            last_established_connection := None; last_disconnection := None;
            events := Tezos_stdlib.Ring.create log_size;
            watchers := Tezos_stdlib.Lwt_watcher.create_input tt |}.
  
  Definition encoding {A B C : Type}
    (peer_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.encoding A)
    : Tezos_base__TzPervasives.Data_encoding.encoding (t B A C) :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          peer_id := peer_id;
            created := created;
            peer_metadata := peer_metadata;
            trusted := trusted;
            last_failed_connection := last_failed_connection;
            last_rejected_connection := last_rejected_connection;
            last_established_connection := last_established_connection;
            last_disconnection := last_disconnection;
            events := events
            |} =>
          (peer_id, created, trusted, peer_metadata,
            (Tezos_stdlib.Ring.elements events), last_failed_connection,
            last_rejected_connection, last_established_connection,
            last_disconnection)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (peer_id, created, trusted, peer_metadata, event_list,
            last_failed_connection, last_rejected_connection,
            last_established_connection, last_disconnection) =>
          let info := create None (Some trusted) peer_metadata peer_id in
          let events := Tezos_stdlib.Ring.create log_size in
          Tezos_stdlib.Ring.add_list (events info) event_list;
          {| peer_id := peer_id; created := created; state := Disconnected;
            peer_metadata := peer_metadata; trusted := trusted;
            last_failed_connection := last_failed_connection;
            last_rejected_connection := last_rejected_connection;
            last_established_connection := last_established_connection;
            last_disconnection := last_disconnection; events := events;
            watchers := Tezos_stdlib.Lwt_watcher.create_input tt |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj9
        (Tezos_base__TzPervasives.Data_encoding.req None None "peer_id" % string
          Tezos_base__TzPervasives.P2p_peer.Id.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "created" % string
          Tezos_base__TzPervasives.Time.System.encoding)
        (Tezos_base__TzPervasives.Data_encoding.dft None None "trusted" % string
          Tezos_base__TzPervasives.Data_encoding.bool false)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "peer_metadata" % string peer_metadata_encoding)
        (Tezos_base__TzPervasives.Data_encoding.dft None None "events" % string
          (Tezos_base__TzPervasives.Data_encoding.list None
            Tezos_base__TzPervasives.P2p_peer.Pool_event.encoding) [])
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "last_failed_connection" % string
          (Tezos_base__TzPervasives.Data_encoding.tup2
            Tezos_base__TzPervasives.P2p_connection.Id.encoding
            Tezos_base__TzPervasives.Time.System.encoding))
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "last_rejected_connection" % string
          (Tezos_base__TzPervasives.Data_encoding.tup2
            Tezos_base__TzPervasives.P2p_connection.Id.encoding
            Tezos_base__TzPervasives.Time.System.encoding))
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "last_established_connection" % string
          (Tezos_base__TzPervasives.Data_encoding.tup2
            Tezos_base__TzPervasives.P2p_connection.Id.encoding
            Tezos_base__TzPervasives.Time.System.encoding))
        (Tezos_base__TzPervasives.Data_encoding.opt None None
          "last_disconnection" % string
          (Tezos_base__TzPervasives.Data_encoding.tup2
            Tezos_base__TzPervasives.P2p_connection.Id.encoding
            Tezos_base__TzPervasives.Time.System.encoding))).
  
  Definition peer_id {A B C : Type} (function_parameter : t A B C)
    : Tezos_base__TzPervasives.P2p_peer.Id.t :=
    match function_parameter with
    | {| peer_id := peer_id |} => peer_id
    end.
  
  Definition created {A B C : Type} (function_parameter : t A B C)
    : Tezos_base__TzPervasives.Time.System.t :=
    match function_parameter with
    | {| created := created |} => created
    end.
  
  Definition peer_metadata {A B C : Type} (function_parameter : t A B C) : B :=
    match function_parameter with
    | {| peer_metadata := peer_metadata |} => peer_metadata
    end.
  
  Definition set_peer_metadata {A B C : Type} (gi : t A B C) (peer_metadata : B)
    : unit := set_field.
  
  Definition trusted {A B C : Type} (function_parameter : t A B C) : bool :=
    match function_parameter with
    | {| trusted := trusted |} => trusted
    end.
  
  Definition set_trusted {A B C : Type} (gi : t A B C) : unit := set_field.
  
  Definition unset_trusted {A B C : Type} (gi : t A B C) : unit := set_field.
  
  Definition last_established_connection {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_established_connection s.
  
  Definition last_disconnection {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_disconnection s.
  
  Definition last_failed_connection {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_failed_connection s.
  
  Definition last_rejected_connection {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_rejected_connection s.
  
  Definition last_seen {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) :=
    Tezos_base__TzPervasives.Time.System.recent (last_established_connection s)
      (Tezos_base__TzPervasives.Time.System.recent (last_rejected_connection s)
        (last_disconnection s)).
  
  Definition last_miss {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) :=
    Tezos_base__TzPervasives.Time.System.recent (last_failed_connection s)
      (Tezos_base__TzPervasives.Time.System.recent (last_rejected_connection s)
        (last_disconnection s)).
  
  Definition log {A B C : Type} (function_parameter : t A B C)
    : (option Tezos_base.Time.System.t) ->
      Tezos_base.P2p_connection.Id.t ->
        Tezos_base__TzPervasives.P2p_peer.Pool_event.kind -> unit :=
    match function_parameter with
    | {| events := events; watchers := watchers |} =>
      fun op_star_o_p_t_star =>
        let timestamp :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => Tezos_stdlib_unix.Systime_os.now tt
          end in
        fun point =>
          fun kind =>
            let event :=
              {| Pool_event.kind := kind; Pool_event.timestamp := timestamp;
                Pool_event.point := point |} in
            Tezos_stdlib.Ring.add events event;
            Tezos_stdlib.Lwt_watcher.notify watchers event
    end.
  
  Definition log_incoming_rejection {A B C : Type}
    (timestamp : option Tezos_base.Time.System.t) (peer_info : t A B C)
    (point : Tezos_base.P2p_connection.Id.t) : unit :=
    log peer_info timestamp point Rejecting_request.
  
  Module File.
    Definition load {A B C : Type}
      (path : string)
      (peer_metadata_encoding :
        Tezos_base__TzPervasives.Data_encoding.encoding A)
      : Lwt.t (Tezos_base__TzPervasives.tzresult (list (t B A C))) :=
      let enc :=
        Tezos_base__TzPervasives.Data_encoding.list None
          (encoding peer_metadata_encoding) in
      if
        andb (nequiv_decb path "/dev/null" % string)
          (Stdlib.Sys.file_exists path) then
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file path)
          (fun json =>
            Tezos_base__TzPervasives._return
              (Tezos_base__TzPervasives.Data_encoding.Json.destruct enc json))
      else
        Tezos_base__TzPervasives.return_nil.
    
    Definition save {A B C : Type}
      (path : string)
      (peer_metadata_encoding :
        Tezos_base__TzPervasives.Data_encoding.encoding A)
      (peers : list (t B A C))
      : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
      apply (Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file path)
        (Tezos_base__TzPervasives.Data_encoding.Json.construct
          (Tezos_base__TzPervasives.Data_encoding.list None
            (encoding peer_metadata_encoding)) peers).
  End File.
  
  Definition watch {A B C : Type} (function_parameter : t A B C)
    : (Lwt_stream.t Tezos_base__TzPervasives.P2p_peer.Pool_event.t) *
      Tezos_stdlib.Lwt_watcher.stopper :=
    match function_parameter with
    | {| watchers := watchers |} =>
      Tezos_stdlib.Lwt_watcher.create_stream watchers
    end.
  
  Definition fold {A B C D : Type} (function_parameter : t A B C)
    : D -> (D -> Tezos_base__TzPervasives.P2p_peer.Pool_event.t -> D) -> D :=
    match function_parameter with
    | {| events := events |} =>
      fun init => fun f => Tezos_stdlib.Ring.fold events init f
    end.
End Info.

Definition get {A B C : Type} (function_parameter : Info.t A B C) : state A C :=
  match function_parameter with
  | {| Info.state := state |} => state
  end.

Definition is_disconnected {A B C : Type} (function_parameter : Info.t A B C)
  : bool :=
  match function_parameter with
  | {| Info.state := state |} =>
    match state with
    | Disconnected => true
    | Accepted _ | Running _ => false
    end
  end.

Definition set_accepted {A B C : Type}
  (op_star_o_p_t_star : option Tezos_base.Time.System.t)
  : (Info.t A B C) ->
    Tezos_base__TzPervasives.P2p_connection.Id.t ->
      Tezos_stdlib.Lwt_canceler.t -> unit :=
  let timestamp :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_stdlib_unix.Systime_os.now tt
    end in
  fun peer_info =>
    fun current_point =>
      fun cancel =>
        match Info.state peer_info with
        | Accepted _ | Running _ => false
        | Disconnected => true
        end;
        set_field;
        Info.log peer_info (Some timestamp) current_point Accepting_request.

Definition set_running {A B C : Type}
  (op_star_o_p_t_star : option Tezos_base__TzPervasives.Time.System.t)
  : (Info.t A B C) ->
    Tezos_base__TzPervasives.P2p_connection.Id.t -> A -> C -> unit :=
  let timestamp :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_stdlib_unix.Systime_os.now tt
    end in
  fun peer_info =>
    fun point =>
      fun data =>
        fun conn_metadata =>
          match Info.state peer_info with
          | Disconnected => true
          | Running _ => false
          | Accepted {| current_point := current_point |} =>
            Tezos_base__TzPervasives.P2p_connection.Id.equal point current_point
          end;
          set_field;
          set_field;
          Info.log peer_info (Some timestamp) point Connection_established.

Definition set_disconnected {A B C : Type}
  (op_star_o_p_t_star : option Tezos_base.Time.System.t)
  : (option bool) -> (Info.t A B C) -> unit :=
  let timestamp :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_stdlib_unix.Systime_os.now tt
    end in
  fun op_star_o_p_t_star =>
    let requested :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun peer_info =>
      match
        match Info.state peer_info with
        | Accepted {| current_point := current_point |} =>
          set_field;
          (current_point, Request_rejected)
        | Running {| current_point := current_point |} =>
          set_field;
          (current_point,
            (if requested then
              Disconnection
            else
              External_disconnection))
        | Disconnected => false
        end with
      | (current_point, _ as event) =>
        set_field;
        Info.log peer_info (Some timestamp) current_point event
      end.
src/lib_p2p/p2p_peer_state.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open P2p_peer

type ('conn, 'conn_meta) t =
  | Accepted of {current_point : P2p_connection.Id.t; cancel : Lwt_canceler.t}
      (** We accepted a incoming connection, we greeted back and
      we are waiting for an acknowledgment. *)
  | Running of {
      data : 'conn;
      conn_metadata : 'conn_meta;
      current_point : P2p_connection.Id.t;
    }  (** Successfully authenticated connection, normal business. *)
  | Disconnected  (** No connection established currently. *)

type ('conn, 'conn_meta) state = ('conn, 'conn_meta) t

val pp : Format.formatter -> ('conn, 'conn_meta) t -> unit

module Info : sig
  type ('conn, 'peer_meta, 'conn_meta) t

  type ('conn, 'peer_meta, 'conn_meta) peer_info =
    ('conn, 'peer_meta, 'conn_meta) t

  val compare :
    ('conn, 'peer_meta, 'conn_meta) t ->
    ('conn, 'peer_meta, 'conn_meta) t ->
    int

  (** [create ~trusted ~meta peer_id] is a freshly minted peer_id info for
      [peer_id]. *)
  val create :
    ?created:Time.System.t ->
    ?trusted:bool ->
    peer_metadata:'peer_meta ->
    Id.t ->
    ('conn, 'peer_meta, 'conn_meta) peer_info

  val peer_id : ('conn, 'peer_meta, 'conn_meta) peer_info -> Id.t

  val created : ('conn, 'peer_meta, 'conn_meta) peer_info -> Time.System.t

  val peer_metadata : ('conn, 'peer_meta, 'conn_meta) peer_info -> 'peer_meta

  val set_peer_metadata :
    ('conn, 'peer_meta, 'conn_meta) peer_info -> 'peer_meta -> unit

  val trusted : ('conn, 'peer_meta, 'conn_meta) peer_info -> bool

  val set_trusted : ('conn, 'peer_meta, 'conn_meta) peer_info -> unit

  val unset_trusted : ('conn, 'peer_meta, 'conn_meta) peer_info -> unit

  val last_failed_connection :
    ('conn, 'peer_meta, 'conn_meta) peer_info ->
    (P2p_connection.Id.t * Time.System.t) option

  val last_rejected_connection :
    ('conn, 'peer_meta, 'conn_meta) peer_info ->
    (P2p_connection.Id.t * Time.System.t) option

  val last_established_connection :
    ('conn, 'peer_meta, 'conn_meta) peer_info ->
    (P2p_connection.Id.t * Time.System.t) option

  val last_disconnection :
    ('conn, 'peer_meta, 'conn_meta) peer_info ->
    (P2p_connection.Id.t * Time.System.t) option

  (** [last_seen gi] is the most recent of:

      * last established connection
      * last rejected connection
      * last disconnection
  *)
  val last_seen :
    ('conn, 'peer_meta, 'conn_meta) peer_info ->
    (P2p_connection.Id.t * Time.System.t) option

  (** [last_miss gi] is the most recent of:

      * last failed connection
      * last rejected connection
      * last disconnection
  *)
  val last_miss :
    ('conn, 'peer_meta, 'conn_meta) peer_info ->
    (P2p_connection.Id.t * Time.System.t) option

  val log_incoming_rejection :
    ?timestamp:Time.System.t ->
    ('conn, 'peer_meta, 'conn_meta) peer_info ->
    P2p_connection.Id.t ->
    unit

  module File : sig
    val load :
      string ->
      'peer_meta Data_encoding.t ->
      ('conn, 'peer_meta, 'conn_meta) peer_info list tzresult Lwt.t

    val save :
      string ->
      'peer_meta Data_encoding.t ->
      ('conn, 'peer_meta, 'conn_meta) peer_info list ->
      unit tzresult Lwt.t
  end

  val fold :
    ('conn, 'peer_meta, 'conn_meta) t ->
    init:'a ->
    f:('a -> Pool_event.t -> 'a) ->
    'a

  val watch :
    ('conn, 'peer_meta, 'conn_meta) t ->
    Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
end

val get : ('conn, 'peer_meta, 'conn_meta) Info.t -> ('conn, 'conn_meta) state

val is_disconnected : ('conn, 'peer_meta, 'conn_meta) Info.t -> bool

val set_accepted :
  ?timestamp:Time.System.t ->
  ('conn, 'peer_meta, 'conn_meta) Info.t ->
  P2p_connection.Id.t ->
  Lwt_canceler.t ->
  unit

val set_running :
  ?timestamp:Time.System.t ->
  ('conn, 'peer_meta, 'conn_meta) Info.t ->
  P2p_connection.Id.t ->
  'conn ->
  'conn_meta ->
  unit

val set_disconnected :
  ?timestamp:Time.System.t ->
  ?requested:bool ->
  ('conn, 'peer_meta, 'conn_meta) Info.t ->
  unit
src/lib_p2p/p2p_peer_state.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t (conn conn_meta : Type) : Type :=
| Accepted : Tezos_base__TzPervasives.P2p_connection.Id.t ->
  Tezos_stdlib.Lwt_canceler.t -> t conn conn_meta
| Running : conn -> conn_meta -> Tezos_base__TzPervasives.P2p_connection.Id.t ->
  t conn conn_meta
| Disconnected : t conn conn_meta.

Arguments Accepted {_ _}.
Arguments Running {_ _}.
Arguments Disconnected {_ _}.

Definition state (conn conn_meta : Type) := t conn conn_meta.

Parameter pp : forall {conn conn_meta : Type},
Stdlib.Format.formatter -> (t conn conn_meta) -> unit.

Module Info.
  Parameter t : forall (conn peer_meta conn_meta : Type), Type.
  
  Definition peer_info (conn peer_meta conn_meta : Type) :=
    t conn peer_meta conn_meta.
  
  Parameter compare : forall {conn conn_meta peer_meta : Type}, (t conn
    peer_meta conn_meta) -> (t conn peer_meta conn_meta) -> Z.
  
  Parameter create : forall {conn conn_meta peer_meta : Type}, (option
    Tezos_base__TzPervasives.Time.System.t) ->
    (option bool) ->
      peer_meta ->
        Tezos_base__TzPervasives.P2p_peer.Id.t ->
          peer_info conn peer_meta conn_meta.
  
  Parameter peer_id : forall {conn conn_meta peer_meta : Type}, (peer_info conn
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t.
  
  Parameter created : forall {conn conn_meta peer_meta : Type}, (peer_info conn
    peer_meta conn_meta) -> Tezos_base__TzPervasives.Time.System.t.
  
  Parameter peer_metadata : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) -> peer_meta.
  
  Parameter set_peer_metadata : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) -> peer_meta -> unit.
  
  Parameter trusted : forall {conn conn_meta peer_meta : Type}, (peer_info conn
    peer_meta conn_meta) -> bool.
  
  Parameter set_trusted : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) -> unit.
  
  Parameter unset_trusted : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) -> unit.
  
  Parameter last_failed_connection : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) ->
    option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_rejected_connection : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) ->
    option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_established_connection : forall {conn conn_meta peer_meta :
  Type}, (peer_info conn peer_meta conn_meta) ->
    option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_disconnection : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) ->
    option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_seen : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) ->
    option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_miss : forall {conn conn_meta peer_meta : Type}, (peer_info
    conn peer_meta conn_meta) ->
    option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter log_incoming_rejection : forall {conn conn_meta peer_meta : Type}, (option
    Tezos_base__TzPervasives.Time.System.t) ->
    (peer_info conn peer_meta conn_meta) ->
      Tezos_base__TzPervasives.P2p_connection.Id.t -> unit.
  
  Module File.
    Parameter load : forall {conn conn_meta peer_meta : Type}, string ->
      (Tezos_base__TzPervasives.Data_encoding.t peer_meta) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list (peer_info conn peer_meta conn_meta))).
    
    Parameter save : forall {conn conn_meta peer_meta : Type}, string ->
      (Tezos_base__TzPervasives.Data_encoding.t peer_meta) ->
        (list (peer_info conn peer_meta conn_meta)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  End File.
  
  Parameter fold : forall {a conn conn_meta peer_meta : Type}, (t conn peer_meta
    conn_meta) ->
    a -> (a -> Tezos_base__TzPervasives.P2p_peer.Pool_event.t -> a) -> a.
  
  Parameter watch : forall {conn conn_meta peer_meta : Type}, (t conn peer_meta
    conn_meta) ->
    (Lwt_stream.t Tezos_base__TzPervasives.P2p_peer.Pool_event.t) *
      Tezos_stdlib.Lwt_watcher.stopper.
End Info.

Parameter get : forall {conn conn_meta peer_meta : Type},
(Info.t conn peer_meta conn_meta) -> state conn conn_meta.

Parameter is_disconnected : forall {conn conn_meta peer_meta : Type},
(Info.t conn peer_meta conn_meta) -> bool.

Parameter set_accepted : forall {conn conn_meta peer_meta : Type},
(option Tezos_base__TzPervasives.Time.System.t) ->
  (Info.t conn peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_connection.Id.t ->
      Tezos_stdlib.Lwt_canceler.t -> unit.

Parameter set_running : forall {conn conn_meta peer_meta : Type},
(option Tezos_base__TzPervasives.Time.System.t) ->
  (Info.t conn peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_connection.Id.t -> conn -> conn_meta -> unit.

Parameter set_disconnected : forall {conn conn_meta peer_meta : Type},
(option Tezos_base__TzPervasives.Time.System.t) ->
  (option bool) -> (Info.t conn peer_meta conn_meta) -> unit.
src/lib_p2p/p2p_point_state.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open P2p_point

type 'data t =
  | Requested of {cancel : Lwt_canceler.t}
  | Accepted of {current_peer_id : P2p_peer.Id.t; cancel : Lwt_canceler.t}
  | Running of {data : 'data; current_peer_id : P2p_peer.Id.t}
  | Disconnected

type 'data state = 'data t

let pp ppf = function
  | Requested _ ->
      Format.fprintf ppf "requested"
  | Accepted {current_peer_id; _} ->
      Format.fprintf ppf "accepted %a" P2p_peer.Id.pp current_peer_id
  | Running {current_peer_id; _} ->
      Format.fprintf ppf "running %a" P2p_peer.Id.pp current_peer_id
  | Disconnected ->
      Format.fprintf ppf "disconnected"

module Info = struct
  type greylisting_config = {
    factor : float;
    initial_delay : Time.System.Span.t;
    disconnection_delay : Time.System.Span.t;
    increase_cap : Time.System.Span.t;
  }

  type 'data t = {
    point : Id.t;
    mutable trusted : bool;
    mutable state : 'data state;
    mutable last_failed_connection : Time.System.t option;
    mutable last_rejected_connection : (P2p_peer.Id.t * Time.System.t) option;
    mutable last_established_connection :
      (P2p_peer.Id.t * Time.System.t) option;
    mutable known_public : bool;
    mutable last_disconnection : (P2p_peer.Id.t * Time.System.t) option;
    mutable greylisting_delay : Time.System.Span.t;
    mutable greylisting_end : Time.System.t;
    events : Pool_event.t Ring.t;
    watchers : Pool_event.t Lwt_watcher.input;
  }

  type 'data point_info = 'data t

  let compare pi1 pi2 = Id.compare pi1.point pi2.point

  let log_size = 100

  let default_greylisting_config =
    {
      factor = 1.2;
      initial_delay = Ptime.Span.of_int_s 1;
      disconnection_delay = Ptime.Span.of_int_s 60;
      increase_cap = Ptime.Span.of_int_s 172800 (* 2 days *);
    }

  let greylisting_config_encoding =
    let open Data_encoding in
    conv
      (fun {factor; initial_delay; disconnection_delay; increase_cap} ->
        (factor, initial_delay, disconnection_delay, increase_cap))
      (fun (factor, initial_delay, disconnection_delay, increase_cap) ->
        {factor; initial_delay; disconnection_delay; increase_cap})
      (obj4
         (dft
            "factor"
            ~description:
              "The factor by which the greylisting delay is increased when an \
               already greylisted peer is greylisted again. This value should \
               be set to 1 for a linear back-off and to >1 for an exponential \
               back-off."
            float
            default_greylisting_config.factor)
         (dft
            "initial-delay"
            ~description:
              "The span of time a peer is greylisted for when it is first \
               greylisted."
            Time.System.Span.encoding
            default_greylisting_config.initial_delay)
         (dft
            "disconnection-delay"
            ~description:
              "The span of time a peer is greylisted for when it is \
               greylisted as the result of an abrupt disconnection."
            Time.System.Span.encoding
            default_greylisting_config.disconnection_delay)
         (dft
            "increase-cap"
            ~description:
              "The maximum amount by which the greylisting is extended. This \
               limits the rate of the exponential back-off, which eventually \
               becomes linear when it reaches this limit. This limit is set \
               to avoid reaching the End-of-Time when repeatedly greylisting \
               a peer."
            Time.System.Span.encoding
            default_greylisting_config.increase_cap))

  let create ?(trusted = false) addr port =
    {
      point = (addr, port);
      trusted;
      state = Disconnected;
      last_failed_connection = None;
      last_rejected_connection = None;
      last_established_connection = None;
      last_disconnection = None;
      known_public = false;
      events = Ring.create log_size;
      greylisting_delay = Ptime.Span.of_int_s 1;
      greylisting_end = Time.System.epoch;
      watchers = Lwt_watcher.create_input ();
    }

  let point s = s.point

  let trusted s = s.trusted

  let set_trusted gi = gi.trusted <- true

  let unset_trusted gi = gi.trusted <- false

  let last_established_connection s = s.last_established_connection

  let last_disconnection s = s.last_disconnection

  let last_failed_connection s = s.last_failed_connection

  let last_rejected_connection s = s.last_rejected_connection

  let known_public s = s.known_public

  let greylisted ?(now = Systime_os.now ()) s =
    Time.System.compare now s.greylisting_end <= 0

  let greylisted_until s = s.greylisting_end

  let last_seen s =
    Time.System.recent
      s.last_rejected_connection
      (Time.System.recent s.last_established_connection s.last_disconnection)

  let last_miss s =
    match
      ( s.last_failed_connection,
        Option.map ~f:(fun (_, time) -> time)
        @@ Time.System.recent s.last_rejected_connection s.last_disconnection
      )
    with
    | (None, None) ->
        None
    | (None, (Some _ as a)) | ((Some _ as a), None) ->
        a
    | ((Some t1 as a1), (Some t2 as a2)) ->
        if Time.System.compare t1 t2 < 0 then a2 else a1

  let log {events; watchers; _} ?timestamp kind =
    let time = Option.unopt ~default:(Systime_os.now ()) timestamp in
    let event = Time.System.stamp ~time kind in
    Ring.add events event ;
    Lwt_watcher.notify watchers event

  let log_incoming_rejection ?timestamp point_info peer_id =
    log point_info ?timestamp (Rejecting_request peer_id)

  let fold {events; _} ~init ~f = Ring.fold events ~init ~f

  let watch {watchers; _} = Lwt_watcher.create_stream watchers
end

let get {Info.state; _} = state

let is_disconnected {Info.state; _} =
  match state with
  | Disconnected ->
      true
  | Requested _ | Accepted _ | Running _ ->
      false

let set_requested ?timestamp point_info cancel =
  assert (
    match point_info.Info.state with
    | Requested _ ->
        true
    | Accepted _ | Running _ ->
        false
    | Disconnected ->
        true ) ;
  point_info.state <- Requested {cancel} ;
  Info.log point_info ?timestamp Outgoing_request

let set_accepted ?(timestamp = Systime_os.now ()) point_info current_peer_id
    cancel =
  (* log_notice "SET_ACCEPTED %a@." P2p_point.pp point_info.point ; *)
  assert (
    match point_info.Info.state with
    | Accepted _ | Running _ ->
        false
    | Requested _ | Disconnected ->
        true ) ;
  point_info.state <- Accepted {current_peer_id; cancel} ;
  Info.log point_info ~timestamp (Accepting_request current_peer_id)

let set_private point_info known_private =
  point_info.Info.known_public <- not known_private

let set_running ?(timestamp = Systime_os.now ()) point_info peer_id data =
  assert (
    match point_info.Info.state with
    | Disconnected ->
        true (* request to unknown peer_id. *)
    | Running _ ->
        false
    | Accepted {current_peer_id; _} ->
        P2p_peer.Id.equal peer_id current_peer_id
    | Requested _ ->
        true ) ;
  point_info.state <- Running {data; current_peer_id = peer_id} ;
  point_info.last_established_connection <- Some (peer_id, timestamp) ;
  Info.log point_info ~timestamp (Connection_established peer_id)

let maxed_time_add t s =
  match Ptime.add_span t s with Some t -> t | None -> Ptime.max

let set_greylisted greylisting_config timestamp point_info =
  point_info.Info.greylisting_end <-
    maxed_time_add timestamp point_info.Info.greylisting_delay ;
  point_info.greylisting_delay <-
    (let new_delay =
       Time.System.Span.multiply_exn
         greylisting_config.Info.factor
         point_info.greylisting_delay
     in
     if Ptime.Span.compare greylisting_config.Info.increase_cap new_delay > 0
     then new_delay
     else greylisting_config.Info.increase_cap)

let set_disconnected ?(timestamp = Systime_os.now ()) ?(requested = false)
    greylisting_config point_info =
  let event : Pool_event.kind =
    match point_info.Info.state with
    | Requested _ ->
        set_greylisted greylisting_config timestamp point_info ;
        point_info.last_failed_connection <- Some timestamp ;
        Request_rejected None
    | Accepted {current_peer_id; _} ->
        set_greylisted greylisting_config timestamp point_info ;
        point_info.last_rejected_connection <- Some (current_peer_id, timestamp) ;
        Request_rejected (Some current_peer_id)
    | Running {current_peer_id; _} ->
        point_info.greylisting_delay <- greylisting_config.Info.initial_delay ;
        point_info.greylisting_end <-
          maxed_time_add timestamp greylisting_config.Info.disconnection_delay ;
        point_info.last_disconnection <- Some (current_peer_id, timestamp) ;
        if requested then Disconnection current_peer_id
        else External_disconnection current_peer_id
    | Disconnected ->
        assert false
  in
  point_info.state <- Disconnected ;
  Info.log point_info ~timestamp event
src/lib_p2p/p2p_point_state.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.P2p_point.

Inductive t (data : Type) : Type :=
| Requested : Tezos_stdlib.Lwt_canceler.t -> t data
| Accepted : Tezos_base__TzPervasives.P2p_peer.Id.t ->
  Tezos_stdlib.Lwt_canceler.t -> t data
| Running : data -> Tezos_base__TzPervasives.P2p_peer.Id.t -> t data
| Disconnected : t data.

Arguments Requested {_}.
Arguments Accepted {_}.
Arguments Running {_}.
Arguments Disconnected {_}.

Definition state (data : Type) := t data.

Definition pp {A : Type}
  (ppf : Stdlib.Format.formatter) (function_parameter : t A) : unit :=
  match function_parameter with
  | Requested _ =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "requested" % string
          CamlinternalFormatBasics.End_of_format) "requested" % string)
  | Accepted {| current_peer_id := current_peer_id |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "accepted " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "accepted %a" % string) Tezos_base__TzPervasives.P2p_peer.Id.pp
      current_peer_id
  | Running {| current_peer_id := current_peer_id |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "running " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "running %a" % string) Tezos_base__TzPervasives.P2p_peer.Id.pp
      current_peer_id
  | Disconnected =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "disconnected" % string
          CamlinternalFormatBasics.End_of_format) "disconnected" % string)
  end.

Module Info.
  Record greylisting_config := {
    factor : float;
    initial_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    disconnection_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    increase_cap : Tezos_base__TzPervasives.Time.System.Span.t }.
  
  Record t {data : Type} := {
    point : Tezos_base__TzPervasives.P2p_point.Id.t;
    trusted : bool;
    state : state data;
    last_failed_connection : option Tezos_base__TzPervasives.Time.System.t;
    last_rejected_connection :
      option
        (Tezos_base__TzPervasives.P2p_peer.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    last_established_connection :
      option
        (Tezos_base__TzPervasives.P2p_peer.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    known_public : bool;
    last_disconnection :
      option
        (Tezos_base__TzPervasives.P2p_peer.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    greylisting_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    greylisting_end : Tezos_base__TzPervasives.Time.System.t;
    events : Tezos_stdlib.Ring.t Tezos_base__TzPervasives.P2p_point.Pool_event.t;
    watchers :
      Tezos_stdlib.Lwt_watcher.input
        Tezos_base__TzPervasives.P2p_point.Pool_event.t }.
  Arguments t : clear implicits.
  
  Definition point_info (data : Type) := t data.
  
  Definition compare {A B : Type} (pi1 : t A) (pi2 : t B) : Z :=
    Tezos_base__TzPervasives.P2p_point.Id.compare (point pi1) (point pi2).
  
  Definition log_size : Z := 100.
  
  Definition default_greylisting_config : greylisting_config :=
    {| factor := 1; initial_delay := Ptime.Span.of_int_s 1;
      disconnection_delay := Ptime.Span.of_int_s 60;
      increase_cap := Ptime.Span.of_int_s 172800 |}.
  
  Definition greylisting_config_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding greylisting_config :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          factor := factor;
            initial_delay := initial_delay;
            disconnection_delay := disconnection_delay;
            increase_cap := increase_cap
            |} => (factor, initial_delay, disconnection_delay, increase_cap)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (factor, initial_delay, disconnection_delay, increase_cap) =>
          {| factor := factor; initial_delay := initial_delay;
            disconnection_delay := disconnection_delay;
            increase_cap := increase_cap |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj4
        (Tezos_base__TzPervasives.Data_encoding.dft None
          (Some
            "The factor by which the greylisting delay is increased when an already greylisted peer is greylisted again. This value should be set to 1 for a linear back-off and to >1 for an exponential back-off."
              % string) "factor" % string
          Tezos_base__TzPervasives.Data_encoding.float
          (factor default_greylisting_config))
        (Tezos_base__TzPervasives.Data_encoding.dft None
          (Some
            "The span of time a peer is greylisted for when it is first greylisted."
              % string) "initial-delay" % string
          Tezos_base__TzPervasives.Time.System.Span.encoding
          (initial_delay default_greylisting_config))
        (Tezos_base__TzPervasives.Data_encoding.dft None
          (Some
            "The span of time a peer is greylisted for when it is greylisted as the result of an abrupt disconnection."
              % string) "disconnection-delay" % string
          Tezos_base__TzPervasives.Time.System.Span.encoding
          (disconnection_delay default_greylisting_config))
        (Tezos_base__TzPervasives.Data_encoding.dft None
          (Some
            "The maximum amount by which the greylisting is extended. This limits the rate of the exponential back-off, which eventually becomes linear when it reaches this limit. This limit is set to avoid reaching the End-of-Time when repeatedly greylisting a peer."
              % string) "increase-cap" % string
          Tezos_base__TzPervasives.Time.System.Span.encoding
          (increase_cap default_greylisting_config))).
  
  Definition create {A : Type} (op_star_o_p_t_star : option bool)
    : Tezos_base.P2p_addr.t -> Tezos_base.P2p_addr.port -> t A :=
    let trusted :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun addr =>
      fun port =>
        {| point := (addr, port); trusted := trusted; state := Disconnected;
          last_failed_connection := None; last_rejected_connection := None;
          last_established_connection := None; known_public := false;
          last_disconnection := None;
          greylisting_delay := Ptime.Span.of_int_s 1;
          greylisting_end := Tezos_base__TzPervasives.Time.System.epoch;
          events := Tezos_stdlib.Ring.create log_size;
          watchers := Tezos_stdlib.Lwt_watcher.create_input tt |}.
  
  Definition point {A : Type} (s : t A)
    : Tezos_base__TzPervasives.P2p_point.Id.t := point s.
  
  Definition trusted {A : Type} (s : t A) : bool := trusted s.
  
  Definition set_trusted {A : Type} (gi : t A) : unit := set_field.
  
  Definition unset_trusted {A : Type} (gi : t A) : unit := set_field.
  
  Definition last_established_connection {A : Type} (s : t A)
    : option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_established_connection s.
  
  Definition last_disconnection {A : Type} (s : t A)
    : option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_disconnection s.
  
  Definition last_failed_connection {A : Type} (s : t A)
    : option Tezos_base__TzPervasives.Time.System.t := last_failed_connection s.
  
  Definition last_rejected_connection {A : Type} (s : t A)
    : option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_rejected_connection s.
  
  Definition known_public {A : Type} (s : t A) : bool := known_public s.
  
  Definition greylisted {A : Type}
    (op_star_o_p_t_star : option Tezos_base__TzPervasives.Time.System.t)
    : (t A) -> bool :=
    let now :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => Tezos_stdlib_unix.Systime_os.now tt
      end in
    fun s =>
      OCaml.Stdlib.le
        (Tezos_base__TzPervasives.Time.System.compare now (greylisting_end s)) 0.
  
  Definition greylisted_until {A : Type} (s : t A)
    : Tezos_base__TzPervasives.Time.System.t := greylisting_end s.
  
  Definition last_seen {A : Type} (s : t A)
    : option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t) :=
    Tezos_base__TzPervasives.Time.System.recent (last_rejected_connection s)
      (Tezos_base__TzPervasives.Time.System.recent
        (last_established_connection s) (last_disconnection s)).
  
  Definition last_miss {A : Type} (s : t A)
    : option Tezos_base__TzPervasives.Time.System.t :=
    match
      ((last_failed_connection s),
        (apply
          (Tezos_stdlib.Option.map
            (fun function_parameter =>
              match function_parameter with
              | (_, time) => time
              end))
          (Tezos_base__TzPervasives.Time.System.recent
            (last_rejected_connection s) (last_disconnection s)))) with
    | (None, None) => None
    | (None, (Some _) as a) | ((Some _) as a, None) => a
    | ((Some t1) as a1, (Some t2) as a2) =>
      if OCaml.Stdlib.lt (Tezos_base__TzPervasives.Time.System.compare t1 t2) 0
        then
        a2
      else
        a1
    end.
  
  Definition log {A : Type} (function_parameter : t A)
    : (option Tezos_base__TzPervasives.Time.System.t) ->
      Tezos_base__TzPervasives.P2p_point.Pool_event.kind -> unit :=
    match function_parameter with
    | {| events := events; watchers := watchers |} =>
      fun timestamp =>
        fun kind =>
          let time :=
            Tezos_stdlib.Option.unopt (Tezos_stdlib_unix.Systime_os.now tt)
              timestamp in
          let event := Tezos_base__TzPervasives.Time.System.stamp time kind in
          Tezos_stdlib.Ring.add events event;
          Tezos_stdlib.Lwt_watcher.notify watchers event
    end.
  
  Definition log_incoming_rejection {A : Type}
    (timestamp : option Tezos_base__TzPervasives.Time.System.t)
    (point_info : t A) (peer_id : Tezos_base.P2p_peer_id.t) : unit :=
    log point_info timestamp (Rejecting_request peer_id).
  
  Definition fold {A B : Type} (function_parameter : t A)
    : B -> (B -> Tezos_base__TzPervasives.P2p_point.Pool_event.t -> B) -> B :=
    match function_parameter with
    | {| events := events |} =>
      fun init => fun f => Tezos_stdlib.Ring.fold events init f
    end.
  
  Definition watch {A : Type} (function_parameter : t A)
    : (Lwt_stream.t Tezos_base__TzPervasives.P2p_point.Pool_event.t) *
      Tezos_stdlib.Lwt_watcher.stopper :=
    match function_parameter with
    | {| watchers := watchers |} =>
      Tezos_stdlib.Lwt_watcher.create_stream watchers
    end.
End Info.

Definition get {A : Type} (function_parameter : Info.t A) : state A :=
  match function_parameter with
  | {| Info.state := state |} => state
  end.

Definition is_disconnected {A : Type} (function_parameter : Info.t A) : bool :=
  match function_parameter with
  | {| Info.state := state |} =>
    match state with
    | Disconnected => true
    | Requested _ | Accepted _ | Running _ => false
    end
  end.

Definition set_requested {A : Type}
  (timestamp : option Tezos_base__TzPervasives.Time.System.t)
  (point_info : Info.t A) (cancel : Tezos_stdlib.Lwt_canceler.t) : unit :=
  match Info.state point_info with
  | Requested _ => true
  | Accepted _ | Running _ => false
  | Disconnected => true
  end;
  set_field;
  Info.log point_info timestamp Outgoing_request.

Definition set_accepted {A : Type}
  (op_star_o_p_t_star : option Tezos_base__TzPervasives.Time.System.t)
  : (Info.t A) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_stdlib.Lwt_canceler.t -> unit :=
  let timestamp :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_stdlib_unix.Systime_os.now tt
    end in
  fun point_info =>
    fun current_peer_id =>
      fun cancel =>
        match Info.state point_info with
        | Accepted _ | Running _ => false
        | Requested _ | Disconnected => true
        end;
        set_field;
        Info.log point_info (Some timestamp) (Accepting_request current_peer_id).

Definition set_private {A : Type} (point_info : Info.t A) (known_private : bool)
  : unit := set_field.

Definition set_running {A : Type}
  (op_star_o_p_t_star : option Tezos_base__TzPervasives.Time.System.t)
  : (Info.t A) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> A -> unit :=
  let timestamp :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_stdlib_unix.Systime_os.now tt
    end in
  fun point_info =>
    fun peer_id =>
      fun data =>
        match Info.state point_info with
        | Disconnected => true
        | Running _ => false
        | Accepted {| current_peer_id := current_peer_id |} =>
          Tezos_base__TzPervasives.P2p_peer.Id.equal peer_id current_peer_id
        | Requested _ => true
        end;
        set_field;
        set_field;
        Info.log point_info (Some timestamp) (Connection_established peer_id).

Definition maxed_time_add (t : Ptime.t) (s : Ptime.span) : Ptime.t :=
  match Ptime.add_span t s with
  | Some t => t
  | None => Ptime.max
  end.

Definition set_greylisted {A : Type}
  (greylisting_config : Info.greylisting_config) (timestamp : Ptime.t)
  (point_info : Info.t A) : unit :=
  set_field;
  set_field.

Definition set_disconnected {A : Type}
  (op_star_o_p_t_star : option Tezos_base__TzPervasives.Time.System.t)
  : (option bool) -> Info.greylisting_config -> (Info.t A) -> unit :=
  let timestamp :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_stdlib_unix.Systime_os.now tt
    end in
  fun op_star_o_p_t_star =>
    let requested :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun greylisting_config =>
      fun point_info =>
        let event :=
          match Info.state point_info with
          | Requested _ =>
            set_greylisted greylisting_config timestamp point_info;
            set_field;
            Request_rejected None
          | Accepted {| current_peer_id := current_peer_id |} =>
            set_greylisted greylisting_config timestamp point_info;
            set_field;
            Request_rejected (Some current_peer_id)
          | Running {| current_peer_id := current_peer_id |} =>
            set_field;
            set_field;
            set_field;
            if requested then
              Disconnection current_peer_id
            else
              External_disconnection current_peer_id
          | Disconnected => false
          end in
        set_field;
        Info.log point_info (Some timestamp) event.
src/lib_p2p/p2p_point_state.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open P2p_point

type 'conn t =
  | Requested of {cancel : Lwt_canceler.t}  (** We initiated a connection. *)
  | Accepted of {current_peer_id : P2p_peer.Id.t; cancel : Lwt_canceler.t}
      (** We accepted a incoming connection. *)
  | Running of {data : 'conn; current_peer_id : P2p_peer.Id.t}
      (** Successfully authenticated connection, normal business. *)
  | Disconnected  (** No connection established currently. *)

type 'conn state = 'conn t

val pp : Format.formatter -> 'conn t -> unit

module Info : sig
  type 'conn t

  (** Type of info associated to a point. *)
  type 'conn point_info = 'conn t

  val compare : 'conn point_info -> 'conn point_info -> int

  type greylisting_config = {
    factor : float;
    initial_delay : Time.System.Span.t;
    disconnection_delay : Time.System.Span.t;
    increase_cap : Time.System.Span.t;
  }

  val default_greylisting_config : greylisting_config

  val greylisting_config_encoding : greylisting_config Data_encoding.encoding

  (** [create ~trusted addr port] is a freshly minted point_info. If
      [trusted] is true, this point is considered trusted and will
      be treated as such. *)
  val create : ?trusted:bool -> P2p_addr.t -> P2p_addr.port -> 'conn point_info

  (** [trusted pi] is [true] iff [pi] has is trusted,
      i.e. "whitelisted". *)
  val trusted : 'conn point_info -> bool

  (** Points can announce themselves as  either public or private.
      Private points will not be advertised to other nodes. *)
  val known_public : 'conn point_info -> bool

  val set_trusted : 'conn point_info -> unit

  val unset_trusted : 'conn point_info -> unit

  val last_failed_connection : 'conn point_info -> Time.System.t option

  val last_rejected_connection :
    'conn point_info -> (P2p_peer.Id.t * Time.System.t) option

  val last_established_connection :
    'conn point_info -> (P2p_peer.Id.t * Time.System.t) option

  val last_disconnection :
    'conn point_info -> (P2p_peer.Id.t * Time.System.t) option

  (** [last_seen pi] is the most recent of:

      * last established connection
      * last rejected connection
      * last disconnection
  *)
  val last_seen : 'conn point_info -> (P2p_peer.Id.t * Time.System.t) option

  (** [last_miss pi] is the most recent of:

      * last failed connection
      * last rejected connection
      * last disconnection
  *)
  val last_miss : 'conn point_info -> Time.System.t option

  val greylisted : ?now:Time.System.t -> 'conn point_info -> bool

  val greylisted_until : 'conn point_info -> Time.System.t

  val point : 'conn point_info -> Id.t

  val log_incoming_rejection :
    ?timestamp:Time.System.t -> 'conn point_info -> P2p_peer.Id.t -> unit

  val fold : 'conn t -> init:'a -> f:('a -> Pool_event.t -> 'a) -> 'a

  val watch : 'conn t -> Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
end

val get : 'conn Info.t -> 'conn t

val is_disconnected : 'conn Info.t -> bool

val set_requested :
  ?timestamp:Time.System.t -> 'conn Info.t -> Lwt_canceler.t -> unit

val set_accepted :
  ?timestamp:Time.System.t ->
  'conn Info.t ->
  P2p_peer.Id.t ->
  Lwt_canceler.t ->
  unit

val set_running :
  ?timestamp:Time.System.t -> 'conn Info.t -> P2p_peer.Id.t -> 'conn -> unit

val set_private : 'conn Info.t -> bool -> unit

val set_disconnected :
  ?timestamp:Time.System.t ->
  ?requested:bool ->
  Info.greylisting_config ->
  'conn Info.t ->
  unit
src/lib_p2p/p2p_point_state.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t (conn : Type) : Type :=
| Requested : Tezos_stdlib.Lwt_canceler.t -> t conn
| Accepted : Tezos_base__TzPervasives.P2p_peer.Id.t ->
  Tezos_stdlib.Lwt_canceler.t -> t conn
| Running : conn -> Tezos_base__TzPervasives.P2p_peer.Id.t -> t conn
| Disconnected : t conn.

Arguments Requested {_}.
Arguments Accepted {_}.
Arguments Running {_}.
Arguments Disconnected {_}.

Definition state (conn : Type) := t conn.

Parameter pp : forall {conn : Type},
Stdlib.Format.formatter -> (t conn) -> unit.

Module Info.
  Parameter t : forall (conn : Type), Type.
  
  Definition point_info (conn : Type) := t conn.
  
  Parameter compare : forall {conn : Type}, (point_info conn) ->
    (point_info conn) -> Z.
  
  Record greylisting_config := {
    factor : float;
    initial_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    disconnection_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    increase_cap : Tezos_base__TzPervasives.Time.System.Span.t }.
  
  Parameter default_greylisting_config : greylisting_config.
  
  Parameter greylisting_config_encoding : Tezos_base__TzPervasives.Data_encoding.encoding
    greylisting_config.
  
  Parameter create : forall {conn : Type}, (option bool) ->
    Tezos_base__TzPervasives.P2p_addr.t ->
      Tezos_base__TzPervasives.P2p_addr.port -> point_info conn.
  
  Parameter trusted : forall {conn : Type}, (point_info conn) -> bool.
  
  Parameter known_public : forall {conn : Type}, (point_info conn) -> bool.
  
  Parameter set_trusted : forall {conn : Type}, (point_info conn) -> unit.
  
  Parameter unset_trusted : forall {conn : Type}, (point_info conn) -> unit.
  
  Parameter last_failed_connection : forall {conn : Type}, (point_info conn) ->
    option Tezos_base__TzPervasives.Time.System.t.
  
  Parameter last_rejected_connection : forall {conn : Type}, (point_info conn)
    ->
    option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_established_connection : forall {conn : Type}, (point_info conn)
    ->
    option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_disconnection : forall {conn : Type}, (point_info conn) ->
    option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_seen : forall {conn : Type}, (point_info conn) ->
    option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t).
  
  Parameter last_miss : forall {conn : Type}, (point_info conn) ->
    option Tezos_base__TzPervasives.Time.System.t.
  
  Parameter greylisted : forall {conn : Type}, (option
    Tezos_base__TzPervasives.Time.System.t) -> (point_info conn) -> bool.
  
  Parameter greylisted_until : forall {conn : Type}, (point_info conn) ->
    Tezos_base__TzPervasives.Time.System.t.
  
  Parameter point : forall {conn : Type}, (point_info conn) ->
    Tezos_base__TzPervasives.P2p_point.Id.t.
  
  Parameter log_incoming_rejection : forall {conn : Type}, (option
    Tezos_base__TzPervasives.Time.System.t) ->
    (point_info conn) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter fold : forall {a conn : Type}, (t conn) ->
    a -> (a -> Tezos_base__TzPervasives.P2p_point.Pool_event.t -> a) -> a.
  
  Parameter watch : forall {conn : Type}, (t conn) ->
    (Lwt_stream.t Tezos_base__TzPervasives.P2p_point.Pool_event.t) *
      Tezos_stdlib.Lwt_watcher.stopper.
End Info.

Parameter get : forall {conn : Type}, (Info.t conn) -> t conn.

Parameter is_disconnected : forall {conn : Type}, (Info.t conn) -> bool.

Parameter set_requested : forall {conn : Type},
(option Tezos_base__TzPervasives.Time.System.t) ->
  (Info.t conn) -> Tezos_stdlib.Lwt_canceler.t -> unit.

Parameter set_accepted : forall {conn : Type},
(option Tezos_base__TzPervasives.Time.System.t) ->
  (Info.t conn) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_stdlib.Lwt_canceler.t -> unit.

Parameter set_running : forall {conn : Type},
(option Tezos_base__TzPervasives.Time.System.t) ->
  (Info.t conn) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> conn -> unit.

Parameter set_private : forall {conn : Type}, (Info.t conn) -> bool -> unit.

Parameter set_disconnected : forall {conn : Type},
(option Tezos_base__TzPervasives.Time.System.t) ->
  (option bool) -> Info.greylisting_config -> (Info.t conn) -> unit.
src/lib_p2p/p2p_pool.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* TODO Test cancellation of a (pending) connection *)

(* TODO do not recompute list_known_points at each requests... but
        only once in a while, e.g. every minutes or when a point
        or the associated peer_id is blacklisted. *)

(* TODO allow to track "requested peer_ids" when we reconnect to a point. *)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.connection-pool"
end)

type config = {
  identity : P2p_identity.t;
  proof_of_work_target : Crypto_box.target;
  trusted_points : P2p_point.Id.t list;
  peers_file : string;
  private_mode : bool;
  greylisting_config : P2p_point_state.Info.greylisting_config;
  listening_port : P2p_addr.port option;
  min_connections : int;
  max_connections : int;
  max_incoming_connections : int;
  connection_timeout : Time.System.Span.t;
  authentication_timeout : Time.System.Span.t;
  incoming_app_message_queue_size : int option;
  incoming_message_queue_size : int option;
  outgoing_message_queue_size : int option;
  known_peer_ids_history_size : int;
  known_points_history_size : int;
  max_known_points : (int * int) option;
  (* max, gc target *)
  max_known_peer_ids : (int * int) option;
  (* max, gc target *)
  swap_linger : Time.System.Span.t;
  binary_chunks_size : int option;
}

type 'peer_meta peer_meta_config = {
  peer_meta_encoding : 'peer_meta Data_encoding.t;
  peer_meta_initial : unit -> 'peer_meta;
  score : 'peer_meta -> float;
}

type 'msg message_config = {
  encoding : 'msg P2p_message.encoding list;
  chain_name : Distributed_db_version.name;
  distributed_db_versions : Distributed_db_version.t list;
}

type ('msg, 'peer_meta, 'conn_meta) t = {
  config : config;
  announced_version : Network_version.t;
  custom_p2p_versions : P2p_version.t list;
  greylisting_config : P2p_point_state.Info.greylisting_config;
  peer_meta_config : 'peer_meta peer_meta_config;
  conn_meta_config : 'conn_meta P2p_socket.metadata_config;
  message_config : 'msg message_config;
  my_id_points : unit P2p_point.Table.t;
  known_peer_ids :
    ( ('msg, 'peer_meta, 'conn_meta) connection,
      'peer_meta,
      'conn_meta )
    P2p_peer_state.Info.t
    P2p_peer.Table.t;
  connected_peer_ids :
    ( ('msg, 'peer_meta, 'conn_meta) connection,
      'peer_meta,
      'conn_meta )
    P2p_peer_state.Info.t
    P2p_peer.Table.t;
  known_points :
    ('msg, 'peer_meta, 'conn_meta) connection P2p_point_state.Info.t
    P2p_point.Table.t;
  connected_points :
    ('msg, 'peer_meta, 'conn_meta) connection P2p_point_state.Info.t
    P2p_point.Table.t;
  incoming : Lwt_canceler.t P2p_point.Table.t;
  io_sched : P2p_io_scheduler.t;
  encoding : 'msg P2p_message.t Data_encoding.t;
  events : events;
  watcher : P2p_connection.Pool_event.t Lwt_watcher.input;
  acl : P2p_acl.t;
  mutable new_connection_hook :
    (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) list;
  mutable latest_accepted_swap : Time.System.t;
  mutable latest_succesfull_swap : Time.System.t;
}

and events = {
  too_few_connections : unit Lwt_condition.t;
  too_many_connections : unit Lwt_condition.t;
  new_peer : unit Lwt_condition.t;
  new_point : unit Lwt_condition.t;
  new_connection : unit Lwt_condition.t;
}

and ('msg, 'peer_meta, 'conn_meta) connection = {
  canceler : Lwt_canceler.t;
  messages : (int * 'msg) Lwt_pipe.t;
  conn : ('msg P2p_message.t, 'conn_meta) P2p_socket.t;
  peer_info :
    ( ('msg, 'peer_meta, 'conn_meta) connection,
      'peer_meta,
      'conn_meta )
    P2p_peer_state.Info.t;
  point_info :
    ('msg, 'peer_meta, 'conn_meta) connection P2p_point_state.Info.t option;
  negotiated_version : Network_version.t;
  answerer : ('msg, 'conn_meta) P2p_answerer.t Lazy.t;
  mutable last_sent_swap_request : (Time.System.t * P2p_peer.Id.t) option;
  mutable wait_close : bool;
}

type ('msg, 'peer_meta, 'conn_meta) pool = ('msg, 'peer_meta, 'conn_meta) t

module Pool_event = struct
  let wait_too_few_connections pool =
    Lwt_condition.wait pool.events.too_few_connections

  let wait_too_many_connections pool =
    Lwt_condition.wait pool.events.too_many_connections

  let wait_new_peer pool = Lwt_condition.wait pool.events.new_peer

  let wait_new_point pool = Lwt_condition.wait pool.events.new_point

  let wait_new_connection pool = Lwt_condition.wait pool.events.new_connection
end

let watch {watcher; _} = Lwt_watcher.create_stream watcher

let log {watcher; _} event = Lwt_watcher.notify watcher event

let private_node_warn fmt =
  Format.kasprintf (fun s -> lwt_warn "[private node] %s" s) fmt

module Gc_point_set = List.Bounded (struct
  type t = Time.System.t * P2p_point.Id.t

  let compare (x, _) (y, _) = -Time.System.compare x y
end)

let gc_points ({config = {max_known_points; _}; known_points; _} as pool) =
  match max_known_points with
  | None ->
      ()
  | Some (_, target) ->
      let current_size = P2p_point.Table.length known_points in
      if current_size > target then (
        let to_remove_target = current_size - target in
        let now = Systime_os.now () in
        (* TODO: maybe time of discovery? *)
        let table = Gc_point_set.create to_remove_target in
        P2p_point.Table.iter
          (fun p point_info ->
            if P2p_point_state.is_disconnected point_info then
              let time =
                match P2p_point_state.Info.last_miss point_info with
                | None ->
                    now
                | Some t ->
                    t
              in
              Gc_point_set.insert (time, p) table)
          known_points ;
        let to_remove = Gc_point_set.get table in
        ListLabels.iter to_remove ~f:(fun (_, p) ->
            P2p_point.Table.remove known_points p) ;
        log pool Gc_points )

let register_point ?trusted pool _source_peer_id ((addr, port) as point) =
  match P2p_point.Table.find_opt pool.known_points point with
  | None ->
      let point_info = P2p_point_state.Info.create ?trusted addr port in
      Option.iter pool.config.max_known_points ~f:(fun (max, _) ->
          if P2p_point.Table.length pool.known_points >= max then
            gc_points pool) ;
      P2p_point.Table.add pool.known_points point point_info ;
      Lwt_condition.broadcast pool.events.new_point () ;
      log pool (New_point point) ;
      point_info
  | Some point_info ->
      ( match trusted with
      | Some true ->
          P2p_point_state.Info.set_trusted point_info
      | Some false ->
          P2p_point_state.Info.unset_trusted point_info
      | None ->
          () ) ;
      point_info

let may_register_my_id_point pool = function
  | [P2p_errors.Myself (addr, Some port)] ->
      P2p_point.Table.add pool.my_id_points (addr, port) () ;
      P2p_point.Table.remove pool.known_points (addr, port)
  | _ ->
      ()

(* Bounded table used to garbage collect peer_id infos when needed. The
   strategy used is to remove the info of the peer_id with the lowest
   score first. In case of equality, the info of the most recent added
   peer_id is removed. The rationale behind this choice is that in the
   case of a flood attack, the newly added infos will probably belong
   to peer_ids with the same (low) score and removing the most recent ones
   ensure that older (and probably legit) peer_id infos are kept. *)
module Gc_peer_set = List.Bounded (struct
  type t = float * Time.System.t * P2p_peer.Id.t

  let compare (s, t, _) (s', t', _) =
    let score_cmp = Pervasives.compare s s' in
    if score_cmp = 0 then Time.System.compare t t' else -score_cmp
end)

let gc_peer_ids
    ( { peer_meta_config = {score; _};
        config = {max_known_peer_ids; _};
        known_peer_ids;
        _ } as pool ) =
  match max_known_peer_ids with
  | None ->
      ()
  | Some (_, target) ->
      let current_size = P2p_peer.Table.length known_peer_ids in
      if current_size > target then (
        let to_remove_target = current_size - target in
        let table = Gc_peer_set.create to_remove_target in
        P2p_peer.Table.iter
          (fun peer_id peer_info ->
            let created = P2p_peer_state.Info.created peer_info in
            let score = score @@ P2p_peer_state.Info.peer_metadata peer_info in
            if P2p_peer_state.is_disconnected peer_info then
              Gc_peer_set.insert (score, created, peer_id) table)
          known_peer_ids ;
        let to_remove = Gc_peer_set.get table in
        ListLabels.iter to_remove ~f:(fun (_, _, peer_id) ->
            P2p_peer.Table.remove known_peer_ids peer_id) ;
        log pool Gc_peer_ids )

let register_peer pool peer_id =
  match P2p_peer.Table.find_opt pool.known_peer_ids peer_id with
  | None ->
      Lwt_condition.broadcast pool.events.new_peer () ;
      let peer =
        P2p_peer_state.Info.create
          peer_id
          ~peer_metadata:(pool.peer_meta_config.peer_meta_initial ())
      in
      Option.iter pool.config.max_known_peer_ids ~f:(fun (max, _) ->
          if P2p_peer.Table.length pool.known_peer_ids >= max then
            gc_peer_ids pool) ;
      P2p_peer.Table.add pool.known_peer_ids peer_id peer ;
      log pool (New_peer peer_id) ;
      peer
  | Some peer ->
      peer

(***************************************************************************)

let read {messages; conn; _} =
  Lwt.catch
    (fun () ->
      Lwt_pipe.pop messages
      >>= fun (s, msg) ->
      lwt_debug
        "%d bytes message popped from queue %a\027[0m"
        s
        P2p_peer.Id.pp
        (P2p_socket.info conn).peer_id
      >>= fun () -> return msg)
    (fun _ (* Closed *) -> fail P2p_errors.Connection_closed)

let is_readable {messages; _} =
  Lwt.catch
    (fun () -> Lwt_pipe.values_available messages >>= fun () -> return_unit)
    (fun _ (* Closed *) -> fail P2p_errors.Connection_closed)

let write {conn; _} msg = P2p_socket.write conn (Message msg)

let write_sync {conn; _} msg = P2p_socket.write_sync conn (Message msg)

let raw_write_sync {conn; _} buf = P2p_socket.raw_write_sync conn buf

let write_now {conn; _} msg = P2p_socket.write_now conn (Message msg)

let write_all pool msg =
  P2p_peer.Table.iter
    (fun _peer_id peer_info ->
      match P2p_peer_state.get peer_info with
      | Running {data = conn; _} ->
          ignore (write_now conn msg : bool tzresult)
      | _ ->
          ())
    pool.connected_peer_ids

let broadcast_bootstrap_msg pool =
  if not pool.config.private_mode then
    P2p_peer.Table.iter
      (fun _peer_id peer_info ->
        match P2p_peer_state.get peer_info with
        | Running {data = {conn; _}; _} ->
            (* should not ask private nodes for the list of their
                known peers*)
            if not (P2p_socket.private_node conn) then
              ignore (P2p_socket.write_now conn Bootstrap : bool tzresult)
        | _ ->
            ())
      pool.connected_peer_ids

(***************************************************************************)

(* this function duplicates bit of code from the modules below to avoid
   creating mutually recursive modules *)
let connection_of_peer_id pool peer_id =
  Option.apply
    (P2p_peer.Table.find_opt pool.known_peer_ids peer_id)
    ~f:(fun p ->
      match P2p_peer_state.get p with
      | Running {data; _} ->
          Some data
      | _ ->
          None)

(* Every running connection matching the point's ip address is returned. *)
let connections_of_addr pool addr =
  P2p_point.Table.fold
    (fun (addr', _) p acc ->
      if Ipaddr.V6.compare addr addr' = 0 then
        match P2p_point_state.get p with
        | P2p_point_state.Running {data; _} ->
            data :: acc
        | _ ->
            acc
      else acc)
    pool.connected_points
    []

let get_addr pool peer_id =
  Option.map (connection_of_peer_id pool peer_id) ~f:(fun ci ->
      (P2p_socket.info ci.conn).id_point)

module Points = struct
  type ('msg, 'peer_meta, 'conn_meta) info =
    ('msg, 'peer_meta, 'conn_meta) connection P2p_point_state.Info.t

  let info {known_points; _} point =
    P2p_point.Table.find_opt known_points point

  let get_trusted pool point =
    Option.unopt_map
      ~default:false
      ~f:P2p_point_state.Info.trusted
      (P2p_point.Table.find_opt pool.known_points point)

  let set_trusted pool point =
    ignore
    @@ register_point ~trusted:true pool pool.config.identity.peer_id point

  let unset_trusted pool point =
    Option.iter
      ~f:P2p_point_state.Info.unset_trusted
      (P2p_point.Table.find_opt pool.known_points point)

  let fold_known pool ~init ~f = P2p_point.Table.fold f pool.known_points init

  let fold_connected pool ~init ~f =
    P2p_point.Table.fold f pool.connected_points init

  let banned pool (addr, _port) = P2p_acl.banned_addr pool.acl addr

  let ban pool (addr, _port) =
    P2p_acl.IPBlacklist.add pool.acl addr ;
    (* Kick [addr]:* if it is in `Running` state. *)
    List.iter
      (fun conn ->
        conn.wait_close <- false ;
        Lwt.async (fun () -> P2p_answerer.shutdown (Lazy.force conn.answerer)))
      (connections_of_addr pool addr)

  let unban pool (addr, _port) = P2p_acl.unban_addr pool.acl addr

  let trust pool point = unban pool point ; set_trusted pool point

  let untrust pool point = unset_trusted pool point
end

module Peers = struct
  type ('msg, 'peer_meta, 'conn_meta) info =
    ( ('msg, 'peer_meta, 'conn_meta) connection,
      'peer_meta,
      'conn_meta )
    P2p_peer_state.Info.t

  let info {known_peer_ids; _} peer_id =
    try Some (P2p_peer.Table.find known_peer_ids peer_id)
    with Not_found -> None

  let get_peer_metadata pool peer_id =
    try
      P2p_peer_state.Info.peer_metadata
        (P2p_peer.Table.find pool.known_peer_ids peer_id)
    with Not_found -> pool.peer_meta_config.peer_meta_initial ()

  let get_score pool peer_id =
    pool.peer_meta_config.score (get_peer_metadata pool peer_id)

  let set_peer_metadata pool peer_id data =
    P2p_peer_state.Info.set_peer_metadata (register_peer pool peer_id) data

  let get_trusted pool peer_id =
    try
      P2p_peer_state.Info.trusted
        (P2p_peer.Table.find pool.known_peer_ids peer_id)
    with Not_found -> false

  let set_trusted pool peer_id =
    try P2p_peer_state.Info.set_trusted (register_peer pool peer_id)
    with Not_found -> ()

  let unset_trusted pool peer_id =
    try
      P2p_peer_state.Info.unset_trusted
        (P2p_peer.Table.find pool.known_peer_ids peer_id)
    with Not_found -> ()

  let fold_known pool ~init ~f = P2p_peer.Table.fold f pool.known_peer_ids init

  let fold_connected pool ~init ~f =
    P2p_peer.Table.fold f pool.connected_peer_ids init

  let ban pool peer =
    P2p_acl.PeerBlacklist.add pool.acl peer ;
    (* Kick [peer] if it is in `Running` state. *)
    Option.iter (connection_of_peer_id pool peer) ~f:(fun conn ->
        conn.wait_close <- false ;
        Lwt.async (fun () -> P2p_answerer.shutdown (Lazy.force conn.answerer)))

  let unban pool peer = P2p_acl.unban_peer pool.acl peer

  let trust pool peer = unban pool peer ; set_trusted pool peer

  let untrust pool peer = unset_trusted pool peer

  let banned pool peer = P2p_acl.banned_peer pool.acl peer
end

module Connection = struct
  let trusted_node conn =
    P2p_peer_state.Info.trusted conn.peer_info
    || Option.unopt_map
         ~default:false
         ~f:P2p_point_state.Info.trusted
         conn.point_info

  let private_node conn = P2p_socket.private_node conn.conn

  let fold pool ~init ~f =
    Peers.fold_connected pool ~init ~f:(fun peer_id peer_info acc ->
        match P2p_peer_state.get peer_info with
        | Running {data; _} ->
            f peer_id data acc
        | _ ->
            acc)

  let list pool =
    fold pool ~init:[] ~f:(fun peer_id c acc -> (peer_id, c) :: acc)

  let random ?different_than ~no_private pool =
    let candidates =
      fold pool ~init:[] ~f:(fun _peer conn acc ->
          if no_private && private_node conn then acc
          else
            match different_than with
            | Some excluded_conn
              when P2p_socket.equal conn.conn excluded_conn.conn ->
                acc
            | Some _ | None ->
                conn :: acc)
    in
    match candidates with
    | [] ->
        None
    | _ :: _ ->
        Some (List.nth candidates (Random.int @@ List.length candidates))

  let random_lowid ?different_than ~no_private pool =
    let candidates =
      fold pool ~init:[] ~f:(fun _peer conn acc ->
          if no_private && private_node conn then acc
          else
            match different_than with
            | Some excluded_conn
              when P2p_socket.equal conn.conn excluded_conn.conn ->
                acc
            | Some _ | None -> (
                let ci = P2p_socket.info conn.conn in
                match ci.id_point with
                | (_, None) ->
                    acc
                | (addr, Some port) ->
                    ((addr, port), ci.peer_id, conn) :: acc ))
    in
    match candidates with
    | [] ->
        None
    | _ :: _ ->
        Some (List.nth candidates (Random.int @@ List.length candidates))

  let stat {conn; _} = P2p_socket.stat conn

  let info {conn; _} = P2p_socket.info conn

  let local_metadata {conn; _} = P2p_socket.local_metadata conn

  let remote_metadata {conn; _} = P2p_socket.remote_metadata conn

  let find_by_peer_id pool peer_id =
    Option.apply (Peers.info pool peer_id) ~f:(fun p ->
        match P2p_peer_state.get p with
        | Running {data; _} ->
            Some data
        | _ ->
            None)

  let find_by_point pool point =
    Option.apply (Points.info pool point) ~f:(fun p ->
        match P2p_point_state.get p with
        | Running {data; _} ->
            Some data
        | _ ->
            None)
end

let greylist_addr pool addr =
  P2p_acl.IPGreylist.add pool.acl addr (Systime_os.now ())

let greylist_peer pool peer =
  Option.iter (get_addr pool peer) ~f:(fun (addr, _port) ->
      greylist_addr pool addr ;
      P2p_acl.PeerGreylist.add pool.acl peer)

let acl_clear pool = P2p_acl.clear pool.acl

let gc_greylist ~older_than pool =
  P2p_acl.IPGreylist.remove_old ~older_than pool.acl

let pool_stat {io_sched; _} = P2p_io_scheduler.global_stat io_sched

let config {config; _} = config

let score {peer_meta_config = {score; _}; _} meta = score meta

(***************************************************************************)

let fail_unless_disconnected_point point_info =
  match P2p_point_state.get point_info with
  | Disconnected ->
      return_unit
  | Requested _ | Accepted _ ->
      fail P2p_errors.Pending_connection
  | Running _ ->
      fail P2p_errors.Connected

(* [sample best other points] return a list of elements selected in [points].
   The [best] first elements are taken, then [other] elements are chosen
   randomly in the rest of the list.
   Note that it might select fewer elements than [other] if it the same index
   close to the end of the list is picked multiple times. *)
let sample best other points =
  let l = List.length points in
  if l <= best + other then points
  else
    let best_indexes = List.init best (fun i -> i) in
    let other_indexes =
      List.sort compare
      @@ List.init other (fun _ -> best + Random.int (l - best))
    in
    let indexes = best_indexes @ other_indexes in
    (* Note: we are doing a [fold_left_i] by hand, passing [i] manually *)
    (fun (_, _, result) -> result)
    @@ List.fold_left
         (fun (i, indexes, acc) point ->
           match indexes with
           | [] ->
               (0, [], acc) (* TODO: early return *)
           | index :: indexes when i >= index ->
               (* We compare `i >= index` (rather than `i = index`) to avoid a
                corner case whereby two identical `index`es are present in the
                list. In that case, using `>=` makes it so that if `i` overtakes
                `index` we still pick elements. *)
               (succ i, indexes, point :: acc)
           | _ ->
               (succ i, indexes, acc))
         (0, indexes, [])
         points

let compare_known_point_info p1 p2 =
  (* The most-recently disconnected peers are greater. *)
  (* Then come long-standing connected peers. *)
  let disconnected1 = P2p_point_state.is_disconnected p1
  and disconnected2 = P2p_point_state.is_disconnected p2 in
  let compare_last_seen p1 p2 =
    match
      (P2p_point_state.Info.last_seen p1, P2p_point_state.Info.last_seen p2)
    with
    | (None, None) ->
        (Random.int 2 * 2) - 1 (* HACK... *)
    | (Some _, None) ->
        1
    | (None, Some _) ->
        -1
    | (Some (_, time1), Some (_, time2)) -> (
      match compare time1 time2 with
      | 0 ->
          (Random.int 2 * 2) - 1 (* HACK... *)
      | x ->
          x )
  in
  match (disconnected1, disconnected2) with
  | (false, false) ->
      compare_last_seen p1 p2
  | (false, true) ->
      -1
  | (true, false) ->
      1
  | (true, true) ->
      compare_last_seen p2 p1

let rec connect ?timeout pool point =
  fail_when (Points.banned pool point) (P2p_errors.Point_banned point)
  >>=? fun () ->
  let timeout = Option.unopt ~default:pool.config.connection_timeout timeout in
  fail_unless
    (active_connections pool <= pool.config.max_connections)
    P2p_errors.Too_many_connections
  >>=? fun () ->
  let canceler = Lwt_canceler.create () in
  with_timeout ~canceler (Systime_os.sleep timeout) (fun canceler ->
      let point_info =
        register_point pool pool.config.identity.peer_id point
      in
      let ((addr, port) as point) = P2p_point_state.Info.point point_info in
      fail_unless
        ( (not pool.config.private_mode)
        || P2p_point_state.Info.trusted point_info )
        P2p_errors.Private_mode
      >>=? fun () ->
      fail_unless_disconnected_point point_info
      >>=? fun () ->
      P2p_point_state.set_requested point_info canceler ;
      let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
      let uaddr =
        Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port)
      in
      lwt_debug "connect: %a" P2p_point.Id.pp point
      >>= fun () ->
      protect
        ~canceler
        (fun () ->
          log pool (Outgoing_connection point) ;
          P2p_fd.connect fd uaddr >>= fun () -> return_unit)
        ~on_error:(fun err ->
          lwt_debug "connect: %a -> disconnect" P2p_point.Id.pp point
          >>= fun () ->
          P2p_point_state.set_disconnected pool.greylisting_config point_info ;
          P2p_fd.close fd
          >>= fun () ->
          match err with
          | [Exn (Unix.Unix_error (Unix.ECONNREFUSED, _, _))] ->
              fail P2p_errors.Connection_refused
          | err ->
              Lwt.return_error err)
      >>=? fun () ->
      lwt_debug "connect: %a -> authenticate" P2p_point.Id.pp point
      >>= fun () -> authenticate pool ~point_info canceler fd point)

and authenticate pool ?point_info canceler fd point =
  let fd = P2p_io_scheduler.register pool.io_sched fd in
  raw_authenticate pool ?point_info canceler fd point
  >>= function
  | Ok connection ->
      return connection
  | Error _ as err ->
      P2p_io_scheduler.close fd >>=? fun () -> Lwt.return err

and raw_authenticate pool ?point_info canceler fd point =
  let incoming = point_info = None in
  lwt_debug
    "authenticate: %a%s"
    P2p_point.Id.pp
    point
    (if incoming then " incoming" else "")
  >>= fun () ->
  protect
    ~canceler
    (fun () ->
      P2p_socket.authenticate
        ~canceler
        ~proof_of_work_target:pool.config.proof_of_work_target
        ~incoming
        fd
        point
        ?listening_port:pool.config.listening_port
        pool.config.identity
        pool.announced_version
        pool.conn_meta_config)
    ~on_error:(fun err ->
      ( match err with
      | [Canceled] ->
          (* Currently only on time out *)
          lwt_debug
            "authenticate: %a%s -> canceled"
            P2p_point.Id.pp
            point
            (if incoming then " incoming" else "")
      | err ->
          (* Authentication incorrect! Temp ban the offending points/peers *)
          List.iter
            (function
              | P2p_errors.Not_enough_proof_of_work _
              | P2p_errors.Invalid_auth
              | P2p_errors.Decipher_error
              | P2p_errors.Invalid_message_size
              | P2p_errors.Encoding_error
              | P2p_errors.Decoding_error
              | P2p_errors.Invalid_chunks_size _ ->
                  greylist_addr pool (fst point)
              | _ ->
                  ())
            err ;
          lwt_debug
            "@[authenticate: %a%s -> failed@ %a@]"
            P2p_point.Id.pp
            point
            (if incoming then " incoming" else "")
            pp_print_error
            err )
      >>= fun () ->
      may_register_my_id_point pool err ;
      log pool (Authentication_failed point) ;
      if incoming then P2p_point.Table.remove pool.incoming point
      else
        Option.iter
          ~f:(P2p_point_state.set_disconnected pool.greylisting_config)
          point_info ;
      Lwt.return_error err)
  >>=? fun (info, auth_fd) ->
  (* Authentication correct! *)
  lwt_debug
    "authenticate: %a -> auth %a"
    P2p_point.Id.pp
    point
    P2p_peer.Id.pp
    info.peer_id
  >>= fun () ->
  fail_when
    (Peers.banned pool info.peer_id)
    (P2p_errors.Peer_banned info.peer_id)
  >>=? fun () ->
  let remote_point_info =
    match info.id_point with
    | (addr, Some port)
      when not (P2p_point.Table.mem pool.my_id_points (addr, port)) ->
        Some (register_point pool info.peer_id (addr, port))
    | _ ->
        None
  in
  let connection_point_info =
    match (point_info, remote_point_info) with
    | (None, None) ->
        None
    | ((Some _ as point_info), _) | (_, (Some _ as point_info)) ->
        point_info
  in
  let peer_info = register_peer pool info.peer_id in
  let acceptable_version =
    Network_version.select
      ~chain_name:pool.message_config.chain_name
      ~distributed_db_versions:pool.message_config.distributed_db_versions
      ~p2p_versions:pool.custom_p2p_versions
      info.announced_version
  in
  let acceptable_point =
    Option.unopt_map
      connection_point_info
      ~default:(not pool.config.private_mode)
      ~f:(fun connection_point_info ->
        match P2p_point_state.get connection_point_info with
        | Requested _ ->
            not incoming
        | Disconnected ->
            let unexpected =
              pool.config.private_mode
              && not (P2p_point_state.Info.trusted connection_point_info)
            in
            if unexpected then
              warn
                "[private node] incoming connection from untrused peer \
                 rejected!" ;
            not unexpected
        | Accepted _ | Running _ ->
            false)
  in
  let acceptable_peer_id =
    match P2p_peer_state.get peer_info with
    | Accepted _ ->
        (* TODO: in some circumstances cancel and accept... *)
        false
    | Running _ ->
        false
    | Disconnected ->
        true
  in
  (* To Verify : the thread must ? not be interrupted between
     point removal from incoming and point registration into
     active connection to prevent flooding attack.
     incoming_connections + active_connection must reflect/dominate
     the actual number of ongoing connections.
     On the other hand, if we wait too long for Ack, we will reject
     incoming connections, thus giving an entry point for dos attack
     by giving late Nack.
  *)
  if incoming then P2p_point.Table.remove pool.incoming point ;
  Option.iter connection_point_info ~f:(fun point_info ->
      (* set the point to private or not, depending on the [info] gethered
           during authentication *)
      P2p_point_state.set_private point_info info.private_node) ;
  match acceptable_version with
  | Some version when acceptable_peer_id && acceptable_point ->
      log pool (Accepting_request (point, info.id_point, info.peer_id)) ;
      Option.iter connection_point_info ~f:(fun point_info ->
          P2p_point_state.set_accepted point_info info.peer_id canceler) ;
      P2p_peer_state.set_accepted peer_info info.id_point canceler ;
      lwt_debug
        "authenticate: %a -> accept %a"
        P2p_point.Id.pp
        point
        P2p_peer.Id.pp
        info.peer_id
      >>= fun () ->
      protect
        ~canceler
        (fun () ->
          P2p_socket.accept
            ?incoming_message_queue_size:
              pool.config.incoming_message_queue_size
            ?outgoing_message_queue_size:
              pool.config.outgoing_message_queue_size
            ?binary_chunks_size:pool.config.binary_chunks_size
            ~canceler
            auth_fd
            pool.encoding
          >>=? fun conn ->
          lwt_debug
            "authenticate: %a -> Connected %a"
            P2p_point.Id.pp
            point
            P2p_peer.Id.pp
            info.peer_id
          >>= fun () -> return conn)
        ~on_error:(fun err ->
          if incoming then
            log
              pool
              (Request_rejected (point, Some (info.id_point, info.peer_id))) ;
          lwt_debug
            "authenticate: %a -> rejected %a"
            P2p_point.Id.pp
            point
            P2p_peer.Id.pp
            info.peer_id
          >>= fun () ->
          Option.iter
            connection_point_info
            ~f:(P2p_point_state.set_disconnected pool.greylisting_config) ;
          P2p_peer_state.set_disconnected peer_info ;
          Lwt.return_error err)
      >>=? fun conn ->
      let id_point =
        match
          (info.id_point, Option.map ~f:P2p_point_state.Info.point point_info)
        with
        | ((addr, _), Some (_, port)) ->
            (addr, Some port)
        | (id_point, None) ->
            id_point
      in
      return
        (create_connection
           pool
           conn
           id_point
           connection_point_info
           peer_info
           version)
  | _ -> (
      log pool (Rejecting_request (point, info.id_point, info.peer_id)) ;
      lwt_debug
        "authenticate: %a -> kick %a point: %B peer_id: %B"
        P2p_point.Id.pp
        point
        P2p_peer.Id.pp
        info.peer_id
        acceptable_point
        acceptable_peer_id
      >>= fun () ->
      P2p_socket.kick auth_fd
      >>= fun () ->
      if not incoming then
        Option.iter
          ~f:(P2p_point_state.set_disconnected pool.greylisting_config)
          point_info
        (* FIXME P2p_peer_state.set_disconnected ~requested:true peer_info ; *) ;
      match acceptable_version with
      | None ->
          lwt_debug
            "No common protocol@.(chains: local %a - remote \
             %a)@.(db_versions: local [%a] - remote %a)@.(p2p_versions: local \
             [%a] - remote %a)"
            Distributed_db_version.pp_name
            pool.message_config.chain_name
            Distributed_db_version.pp_name
            info.announced_version.chain_name
            (Format.pp_print_list Distributed_db_version.pp)
            pool.message_config.distributed_db_versions
            Distributed_db_version.pp
            info.announced_version.distributed_db_version
            (Format.pp_print_list P2p_version.pp)
            pool.custom_p2p_versions
            P2p_version.pp
            info.announced_version.p2p_version
          >>= fun () ->
          fail
            (P2p_errors.Rejected_no_common_protocol
               {announced = info.announced_version})
      | Some _ ->
          fail (P2p_errors.Rejected info.peer_id) )

and create_connection pool p2p_conn id_point point_info peer_info
    negotiated_version =
  let peer_id = P2p_peer_state.Info.peer_id peer_info in
  let canceler = Lwt_canceler.create () in
  let size =
    Option.map pool.config.incoming_app_message_queue_size ~f:(fun qs ->
        ( qs,
          fun (size, _) ->
            (Sys.word_size / 8 * 11) + size + Lwt_pipe.push_overhead ))
  in
  let messages = Lwt_pipe.create ?size () in
  let rec callback_default =
    {
      P2p_answerer.message =
        (fun size msg -> Lwt_pipe.push messages (size, msg));
      advertise =
        (fun points ->
          register_new_points pool conn points ;
          Lwt.return_unit);
      bootstrap = (fun () -> list_known_points ~ignore_private:true pool conn);
      swap_request =
        (fun point peer_id -> swap_request pool conn point peer_id);
      swap_ack = (fun point peer_id -> swap_ack pool conn point peer_id);
    }
  (* when the node is in private mode: deactivate advertising,
     peers_swap and sending list of peers in callback *)
  and callback_private =
    {
      P2p_answerer.message =
        (fun size msg -> Lwt_pipe.push messages (size, msg));
      advertise =
        (fun _points ->
          private_node_warn
            "Received new peers addresses from %a"
            P2p_peer.Id.pp
            peer_id);
      bootstrap =
        (fun () ->
          private_node_warn
            "Receive requests for peers addresses from %a"
            P2p_peer.Id.pp
            peer_id
          >>= fun () -> Lwt.return_nil);
      swap_request =
        (fun _point _peer_id ->
          private_node_warn
            "Received swap requests from %a"
            P2p_peer.Id.pp
            peer_id);
      swap_ack =
        (fun _point _peer_id ->
          private_node_warn "Received swap ack from %a" P2p_peer.Id.pp peer_id);
    }
  and answerer =
    lazy
      ( P2p_answerer.run p2p_conn canceler
      @@
      if pool.config.private_mode then callback_private else callback_default
      )
  and conn =
    {
      conn = p2p_conn;
      point_info;
      peer_info;
      messages;
      canceler;
      answerer;
      wait_close = false;
      last_sent_swap_request = None;
      negotiated_version;
    }
  in
  ignore (Lazy.force answerer) ;
  let conn_meta = P2p_socket.remote_metadata p2p_conn in
  Option.iter point_info ~f:(fun point_info ->
      let point = P2p_point_state.Info.point point_info in
      P2p_point_state.set_running point_info peer_id conn ;
      P2p_point.Table.add pool.connected_points point point_info) ;
  log pool (Connection_established (id_point, peer_id)) ;
  P2p_peer_state.set_running peer_info id_point conn conn_meta ;
  P2p_peer.Table.add pool.connected_peer_ids peer_id peer_info ;
  Lwt_condition.broadcast pool.events.new_connection () ;
  Lwt_canceler.on_cancel canceler (fun () ->
      lwt_debug
        "Disconnect: %a (%a)"
        P2p_peer.Id.pp
        peer_id
        P2p_connection.Id.pp
        id_point
      >>= fun () ->
      Option.iter
        ~f:(P2p_point_state.set_disconnected pool.greylisting_config)
        point_info ;
      log pool (Disconnection peer_id) ;
      P2p_peer_state.set_disconnected peer_info ;
      Option.iter point_info ~f:(fun point_info ->
          P2p_point.Table.remove
            pool.connected_points
            (P2p_point_state.Info.point point_info)) ;
      P2p_peer.Table.remove pool.connected_peer_ids peer_id ;
      if pool.config.max_connections <= active_connections pool then (
        Lwt_condition.broadcast pool.events.too_many_connections () ;
        log pool Too_many_connections ) ;
      Lwt_pipe.close messages ;
      P2p_socket.close ~wait:conn.wait_close conn.conn) ;
  List.iter (fun f -> f peer_id conn) pool.new_connection_hook ;
  if active_connections pool < pool.config.min_connections then (
    Lwt_condition.broadcast pool.events.too_few_connections () ;
    log pool Too_few_connections ) ;
  conn

and disconnect ?(wait = false) conn =
  conn.wait_close <- wait ;
  P2p_answerer.shutdown (Lazy.force conn.answerer)

and register_new_points ?trusted pool conn =
  let source_peer_id = P2p_peer_state.Info.peer_id conn.peer_info in
  fun points ->
    List.iter (register_new_point ?trusted pool source_peer_id) points

and register_new_point ?trusted pool source_peer_id point =
  if not (P2p_point.Table.mem pool.my_id_points point) then
    ignore (register_point ?trusted pool source_peer_id point)

and list_known_points ?(ignore_private = false) pool conn =
  if Connection.private_node conn then
    private_node_warn
      "Private peer (%a) asked other peers addresses"
      P2p_peer.Id.pp
      (P2p_peer_state.Info.peer_id conn.peer_info)
    >>= fun () -> Lwt.return_nil
  else
    P2p_point.Table.fold
      (fun point_id point_info acc ->
        if
          (ignore_private && not (P2p_point_state.Info.known_public point_info))
          || Points.banned pool point_id
        then acc
        else point_info :: acc)
      pool.known_points
      []
    |> List.sort compare_known_point_info
    |> sample 30 20
    |> List.map P2p_point_state.Info.point
    |> Lwt.return

and active_connections pool = P2p_peer.Table.length pool.connected_peer_ids

and swap_request pool conn new_point _new_peer_id =
  let source_peer_id = P2p_peer_state.Info.peer_id conn.peer_info in
  log pool (Swap_request_received {source = source_peer_id}) ;
  lwt_log_info "Swap request received from %a" P2p_peer.Id.pp source_peer_id
  >>= fun () ->
  (* Ignore if already connected to peer or already swapped less
     than <swap_linger> seconds ago. *)
  let span_since_last_swap =
    Ptime.diff
      (Systime_os.now ())
      (Time.System.max pool.latest_succesfull_swap pool.latest_accepted_swap)
  in
  let new_point_info = register_point pool source_peer_id new_point in
  if
    Ptime.Span.compare span_since_last_swap pool.config.swap_linger < 0
    || not (P2p_point_state.is_disconnected new_point_info)
  then (
    log pool (Swap_request_ignored {source = source_peer_id}) ;
    lwt_log_info "Ignoring swap request from %a" P2p_peer.Id.pp source_peer_id
    )
  else
    match Connection.random_lowid pool ~no_private:true with
    | None ->
        lwt_log_info "No swap candidate for %a" P2p_peer.Id.pp source_peer_id
    | Some (proposed_point, proposed_peer_id, _proposed_conn) -> (
      match
        P2p_socket.write_now
          conn.conn
          (Swap_ack (proposed_point, proposed_peer_id))
      with
      | Ok true ->
          log pool (Swap_ack_sent {source = source_peer_id}) ;
          swap pool conn proposed_peer_id new_point
      | Ok false ->
          log pool (Swap_request_received {source = source_peer_id}) ;
          Lwt.return_unit
      | Error _ ->
          log pool (Swap_request_received {source = source_peer_id}) ;
          Lwt.return_unit )

and swap_ack pool conn new_point _new_peer_id =
  let source_peer_id = P2p_peer_state.Info.peer_id conn.peer_info in
  log pool (Swap_ack_received {source = source_peer_id}) ;
  lwt_log_info "Swap ack received from %a" P2p_peer.Id.pp source_peer_id
  >>= fun () ->
  match conn.last_sent_swap_request with
  | None ->
      Lwt.return_unit (* ignore *)
  | Some (_time, proposed_peer_id) -> (
    match Connection.find_by_peer_id pool proposed_peer_id with
    | None ->
        swap pool conn proposed_peer_id new_point
    | Some _ ->
        Lwt.return_unit )

and swap pool conn current_peer_id new_point =
  let source_peer_id = P2p_peer_state.Info.peer_id conn.peer_info in
  pool.latest_accepted_swap <- Systime_os.now () ;
  connect pool new_point
  >>= function
  | Ok _new_conn -> (
      pool.latest_succesfull_swap <- Systime_os.now () ;
      log pool (Swap_success {source = source_peer_id}) ;
      lwt_log_info "Swap to %a succeeded" P2p_point.Id.pp new_point
      >>= fun () ->
      match Connection.find_by_peer_id pool current_peer_id with
      | None ->
          Lwt.return_unit
      | Some conn ->
          disconnect conn )
  | Error err -> (
      pool.latest_accepted_swap <- pool.latest_succesfull_swap ;
      log pool (Swap_failure {source = source_peer_id}) ;
      match err with
      | [Timeout] ->
          lwt_debug
            "Swap to %a was interrupted: %a"
            P2p_point.Id.pp
            new_point
            pp_print_error
            err
      | _ ->
          lwt_log_error
            "Swap to %a failed: %a"
            P2p_point.Id.pp
            new_point
            pp_print_error
            err )

let accept pool fd point =
  log pool (Incoming_connection point) ;
  let max_active_conns =
    if Random.bool () then
      (* randomly allow one additional incoming connection *)
      pool.config.max_connections + 1
    else pool.config.max_connections
  in
  if
    pool.config.max_incoming_connections
    <= P2p_point.Table.length pool.incoming
    || max_active_conns <= active_connections pool
    (* silently ignore banned points *)
    || P2p_acl.banned_addr pool.acl (fst point)
  then Lwt.async (fun () -> P2p_fd.close fd)
  else
    let canceler = Lwt_canceler.create () in
    P2p_point.Table.add pool.incoming point canceler ;
    Lwt.async (fun () ->
        with_timeout
          ~canceler
          (Systime_os.sleep pool.config.authentication_timeout)
          (fun canceler -> authenticate pool canceler fd point))

let send_swap_request pool =
  match Connection.random ~no_private:true pool with
  | Some recipient when not pool.config.private_mode -> (
      let recipient_peer_id = (Connection.info recipient).peer_id in
      match
        Connection.random_lowid ~different_than:recipient ~no_private:true pool
      with
      | None ->
          ()
      | Some (proposed_point, proposed_peer_id, _proposed_conn) ->
          log pool (Swap_request_sent {source = recipient_peer_id}) ;
          recipient.last_sent_swap_request <-
            Some (Systime_os.now (), proposed_peer_id) ;
          ignore
            (P2p_socket.write_now
               recipient.conn
               (Swap_request (proposed_point, proposed_peer_id))) )
  | Some _ | None ->
      ()

(***************************************************************************)

let create ?(p2p_versions = P2p_version.supported) config peer_meta_config
    conn_meta_config message_config io_sched =
  let events =
    {
      too_few_connections = Lwt_condition.create ();
      too_many_connections = Lwt_condition.create ();
      new_peer = Lwt_condition.create ();
      new_point = Lwt_condition.create ();
      new_connection = Lwt_condition.create ();
    }
  in
  let pool =
    {
      config;
      peer_meta_config;
      conn_meta_config;
      message_config;
      greylisting_config = config.greylisting_config;
      announced_version =
        Network_version.announced
          ~chain_name:message_config.chain_name
          ~distributed_db_versions:message_config.distributed_db_versions
          ~p2p_versions;
      custom_p2p_versions = p2p_versions;
      my_id_points = P2p_point.Table.create 7;
      known_peer_ids = P2p_peer.Table.create 53;
      connected_peer_ids = P2p_peer.Table.create 53;
      known_points = P2p_point.Table.create 53;
      connected_points = P2p_point.Table.create 53;
      incoming = P2p_point.Table.create 53;
      io_sched;
      encoding = P2p_message.encoding message_config.encoding;
      events;
      watcher = Lwt_watcher.create_input ();
      acl = P2p_acl.create 1023;
      new_connection_hook = [];
      latest_accepted_swap = Ptime.epoch;
      latest_succesfull_swap = Ptime.epoch;
    }
  in
  List.iter (Points.set_trusted pool) config.trusted_points ;
  P2p_peer_state.Info.File.load
    config.peers_file
    peer_meta_config.peer_meta_encoding
  >>= function
  | Ok peer_ids ->
      List.iter
        (fun peer_info ->
          let peer_id = P2p_peer_state.Info.peer_id peer_info in
          P2p_peer.Table.add pool.known_peer_ids peer_id peer_info ;
          match P2p_peer_state.Info.last_seen peer_info with
          | None | Some ((_, None (* no reachable port stored*)), _) ->
              ()
          | Some ((addr, Some port), _) ->
              register_point pool peer_id (addr, port) |> ignore)
        peer_ids ;
      Lwt.return pool
  | Error err ->
      log_error "@[Failed to parse peers file:@ %a@]" pp_print_error err ;
      Lwt.return pool

let destroy ({config; peer_meta_config; _} as pool) =
  lwt_log_info "Saving metadata in %s" config.peers_file
  >>= fun () ->
  P2p_peer_state.Info.File.save
    config.peers_file
    peer_meta_config.peer_meta_encoding
    (P2p_peer.Table.fold (fun _ a b -> a :: b) pool.known_peer_ids [])
  >>= (function
        | Error err ->
            log_error "@[Failed to save peers file:@ %a@]" pp_print_error err ;
            Lwt.return_unit
        | Ok () ->
            Lwt.return_unit)
  >>= fun () ->
  P2p_point.Table.fold
    (fun _point point_info acc ->
      match P2p_point_state.get point_info with
      | Requested {cancel} | Accepted {cancel; _} ->
          Lwt_canceler.cancel cancel >>= fun () -> acc
      | Running {data = conn; _} ->
          disconnect conn >>= fun () -> acc
      | Disconnected ->
          acc)
    pool.known_points
  @@ P2p_peer.Table.fold
       (fun _peer_id peer_info acc ->
         match P2p_peer_state.get peer_info with
         | Accepted {cancel; _} ->
             Lwt_canceler.cancel cancel >>= fun () -> acc
         | Running {data = conn; _} ->
             disconnect conn >>= fun () -> acc
         | Disconnected ->
             acc)
       pool.known_peer_ids
  @@ P2p_point.Table.fold
       (fun _point canceler acc ->
         Lwt_canceler.cancel canceler >>= fun () -> acc)
       pool.incoming
       Lwt.return_unit

let on_new_connection pool f =
  pool.new_connection_hook <- f :: pool.new_connection_hook
src/lib_p2p/p2p_pool.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record config := {
  identity : Tezos_base__TzPervasives.P2p_identity.t;
  proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target;
  trusted_points : list Tezos_base__TzPervasives.P2p_point.Id.t;
  peers_file : string;
  private_mode : bool;
  greylisting_config : Tezos_p2p.P2p_point_state.Info.greylisting_config;
  listening_port : option Tezos_base__TzPervasives.P2p_addr.port;
  min_connections : Z;
  max_connections : Z;
  max_incoming_connections : Z;
  connection_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  authentication_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  incoming_app_message_queue_size : option Z;
  incoming_message_queue_size : option Z;
  outgoing_message_queue_size : option Z;
  known_peer_ids_history_size : Z;
  known_points_history_size : Z;
  max_known_points : option (Z * Z);
  max_known_peer_ids : option (Z * Z);
  swap_linger : Tezos_base__TzPervasives.Time.System.Span.t;
  binary_chunks_size : option Z }.

Record peer_meta_config {peer_meta : Type} := {
  peer_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t peer_meta;
  peer_meta_initial : unit -> peer_meta;
  score : peer_meta -> float }.
Arguments peer_meta_config : clear implicits.

Record message_config {msg : Type} := {
  encoding : list (Tezos_p2p.P2p_message.encoding msg);
  chain_name : Tezos_base__TzPervasives.Distributed_db_version.name;
  distributed_db_versions :
    list Tezos_base__TzPervasives.Distributed_db_version.t }.
Arguments message_config : clear implicits.

.

Definition pool (msg peer_meta conn_meta : Type) := t msg peer_meta conn_meta.

Module Pool_event.
  Definition wait_too_few_connections {A B C : Type} (pool : t A B C)
    : Lwt.t unit := Lwt_condition.wait None (too_few_connections (events pool)).
  
  Definition wait_too_many_connections {A B C : Type} (pool : t A B C)
    : Lwt.t unit := Lwt_condition.wait None (too_many_connections (events pool)).
  
  Definition wait_new_peer {A B C : Type} (pool : t A B C) : Lwt.t unit :=
    Lwt_condition.wait None (new_peer (events pool)).
  
  Definition wait_new_point {A B C : Type} (pool : t A B C) : Lwt.t unit :=
    Lwt_condition.wait None (new_point (events pool)).
  
  Definition wait_new_connection {A B C : Type} (pool : t A B C) : Lwt.t unit :=
    Lwt_condition.wait None (new_connection (events pool)).
End Pool_event.

Definition watch {A B C : Type} (function_parameter : t A B C)
  : (Lwt_stream.t Tezos_base__TzPervasives.P2p_connection.Pool_event.t) *
    Tezos_stdlib.Lwt_watcher.stopper :=
  match function_parameter with
  | {| watcher := watcher |} => Tezos_stdlib.Lwt_watcher.create_stream watcher
  end.

Definition log {A B C : Type} (function_parameter : t A B C)
  : Tezos_base__TzPervasives.P2p_connection.Pool_event.t -> unit :=
  match function_parameter with
  | {| watcher := watcher |} =>
    fun event => Tezos_stdlib.Lwt_watcher.notify watcher event
  end.

Definition private_node_warn {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  Stdlib.Format.kasprintf
    (fun s =>
      lwt_warn
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "[private node] " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format))
          "[private node] %s" % string) s) fmt.

Definition gc_points {A B C : Type} (function_parameter : t A B C) : unit :=
  match function_parameter with
  |
    {|
      config := {| max_known_points := max_known_points |};
        known_points := known_points
        |} as pool =>
    match max_known_points with
    | None => tt
    | Some (_, target) =>
      let current_size :=
        Tezos_base__TzPervasives.P2p_point.Table.length known_points in
      if OCaml.Stdlib.gt current_size target then
        let to_remove_target := Z.sub current_size target in
        let now := Tezos_stdlib_unix.Systime_os.now tt in
        let table := Gc_point_set.create to_remove_target in
        Tezos_base__TzPervasives.P2p_point.Table.iter
          (fun p =>
            fun point_info =>
              if Tezos_p2p.P2p_point_state.is_disconnected point_info then
                let time :=
                  match Tezos_p2p.P2p_point_state.Info.last_miss point_info with
                  | None => now
                  | Some t => t
                  end in
                Gc_point_set.insert (time, p) table
              else
                tt) known_points;
        let to_remove := Gc_point_set.get table in
        Stdlib.ListLabels.iter
          (fun function_parameter =>
            match function_parameter with
            | (_, p) =>
              Tezos_base__TzPervasives.P2p_point.Table.remove known_points p
            end) to_remove;
        log pool Gc_points
      else
        tt
    end
  end.

Definition register_point {A B C D : Type}
  (trusted : option bool) (pool : t A B C) (_source_peer_id : D)
  (function_parameter : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
  : Tezos_p2p.P2p_point_state.Info.point_info (connection A B C) :=
  match function_parameter with
  | (addr, port) as point =>
    match
      Tezos_base__TzPervasives.P2p_point.Table.find_opt (known_points pool)
        point with
    | None =>
      let point_info := Tezos_p2p.P2p_point_state.Info.create trusted addr port
        in
      Tezos_stdlib.Option.iter
        (fun function_parameter =>
          match function_parameter with
          | (max, _) =>
            if
              OCaml.Stdlib.ge
                (Tezos_base__TzPervasives.P2p_point.Table.length
                  (known_points pool)) max then
              gc_points pool
            else
              tt
          end) (max_known_points (config pool));
      Tezos_base__TzPervasives.P2p_point.Table.add (known_points pool) point
        point_info;
      Lwt_condition.broadcast (new_point (events pool)) tt;
      log pool (New_point point);
      point_info
    | Some point_info =>
      match trusted with
      | Some true => Tezos_p2p.P2p_point_state.Info.set_trusted point_info
      | Some false => Tezos_p2p.P2p_point_state.Info.unset_trusted point_info
      | None => tt
      end;
      point_info
    end
  end.

Definition may_register_my_id_point {A B C : Type}
  (pool : t A B C) (function_parameter : list Tezos_base__TzPervasives.error)
  : unit :=
  match function_parameter with
  | cons (P2p_errors.Myself (addr, Some port)) [] =>
    Tezos_base__TzPervasives.P2p_point.Table.add (my_id_points pool)
      (addr, port) tt;
    Tezos_base__TzPervasives.P2p_point.Table.remove (known_points pool)
      (addr, port)
  | _ => tt
  end.

Definition gc_peer_ids {A B C : Type} (function_parameter : t A B C) : unit :=
  match function_parameter with
  |
    {|
      config := {| max_known_peer_ids := max_known_peer_ids |};
        peer_meta_config := {| score := score |};
        known_peer_ids := known_peer_ids
        |} as pool =>
    match max_known_peer_ids with
    | None => tt
    | Some (_, target) =>
      let current_size :=
        Tezos_base__TzPervasives.P2p_peer.Table.length known_peer_ids in
      if OCaml.Stdlib.gt current_size target then
        let to_remove_target := Z.sub current_size target in
        let table := Gc_peer_set.create to_remove_target in
        Tezos_base__TzPervasives.P2p_peer.Table.iter
          (fun peer_id =>
            fun peer_info =>
              let created := Tezos_p2p.P2p_peer_state.Info.created peer_info in
              let score :=
                apply score
                  (Tezos_p2p.P2p_peer_state.Info.peer_metadata peer_info) in
              if Tezos_p2p.P2p_peer_state.is_disconnected peer_info then
                Gc_peer_set.insert (score, created, peer_id) table
              else
                tt) known_peer_ids;
        let to_remove := Gc_peer_set.get table in
        Stdlib.ListLabels.iter
          (fun function_parameter =>
            match function_parameter with
            | (_, _, peer_id) =>
              Tezos_base__TzPervasives.P2p_peer.Table.remove known_peer_ids
                peer_id
            end) to_remove;
        log pool Gc_peer_ids
      else
        tt
    end
  end.

Definition register_peer {A B C : Type}
  (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
  : Tezos_p2p.P2p_peer_state.Info.peer_info (connection A B C) B C :=
  match
    Tezos_base__TzPervasives.P2p_peer.Table.find_opt (known_peer_ids pool)
      peer_id with
  | None =>
    Lwt_condition.broadcast (new_peer (events pool)) tt;
    let peer :=
      Tezos_p2p.P2p_peer_state.Info.create None None
        ((peer_meta_initial (peer_meta_config pool)) tt) peer_id in
    Tezos_stdlib.Option.iter
      (fun function_parameter =>
        match function_parameter with
        | (max, _) =>
          if
            OCaml.Stdlib.ge
              (Tezos_base__TzPervasives.P2p_peer.Table.length
                (known_peer_ids pool)) max then
            gc_peer_ids pool
          else
            tt
        end) (max_known_peer_ids (config pool));
    Tezos_base__TzPervasives.P2p_peer.Table.add (known_peer_ids pool) peer_id
      peer;
    log pool (New_peer peer_id);
    peer
  | Some peer => peer
  end.

Definition read {A B C : Type} (function_parameter : connection A B C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  match function_parameter with
  | {| messages := messages; conn := conn |} =>
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_stdlib.Lwt_pipe.pop messages)
            (fun function_parameter =>
              match function_parameter with
              | (s, msg) =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_debug
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " bytes message popped from queue " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              "" % string
                              CamlinternalFormatBasics.End_of_format))))
                      "%d bytes message popped from queue %a" % string) s
                    Tezos_base__TzPervasives.P2p_peer.Id.pp
                    (peer_id (Tezos_p2p.P2p_socket.info conn)))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives._return msg
                    end)
              end)
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ => Tezos_base__TzPervasives.fail P2p_errors.Connection_closed
        end)
  end.

Definition is_readable {A B C : Type} (function_parameter : connection A B C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| messages := messages |} =>
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_stdlib.Lwt_pipe.values_available messages)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ => Tezos_base__TzPervasives.fail P2p_errors.Connection_closed
        end)
  end.

Definition write {A B C : Type} (function_parameter : connection A B C)
  : A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| conn := conn |} =>
    fun msg => Tezos_p2p.P2p_socket.write conn (Message msg)
  end.

Definition write_sync {A B C : Type} (function_parameter : connection A B C)
  : A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| conn := conn |} =>
    fun msg => Tezos_p2p.P2p_socket.write_sync conn (Message msg)
  end.

Definition raw_write_sync {A B C : Type} (function_parameter : connection A B C)
  : Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| conn := conn |} =>
    fun buf => Tezos_p2p.P2p_socket.raw_write_sync conn buf
  end.

Definition write_now {A B C : Type} (function_parameter : connection A B C)
  : A -> Tezos_base__TzPervasives.tzresult bool :=
  match function_parameter with
  | {| conn := conn |} =>
    fun msg => Tezos_p2p.P2p_socket.write_now conn (Message msg)
  end.

Definition write_all {A B C : Type} (pool : t A B C) (msg : A) : unit :=
  Tezos_base__TzPervasives.P2p_peer.Table.iter
    (fun _peer_id =>
      fun peer_info =>
        match Tezos_p2p.P2p_peer_state.get peer_info with
        | Running {| data := conn |} => OCaml.Stdlib.ignore (write_now conn msg)
        | _ => tt
        end) (connected_peer_ids pool).

Definition broadcast_bootstrap_msg {A B C : Type} (pool : t A B C) : unit :=
  if negb (private_mode (config pool)) then
    Tezos_base__TzPervasives.P2p_peer.Table.iter
      (fun _peer_id =>
        fun peer_info =>
          match Tezos_p2p.P2p_peer_state.get peer_info with
          | Running {| data := {| conn := conn |} |} =>
            if negb (Tezos_p2p.P2p_socket.private_node conn) then
              OCaml.Stdlib.ignore
                (Tezos_p2p.P2p_socket.write_now conn Bootstrap)
            else
              tt
          | _ => tt
          end) (connected_peer_ids pool)
  else
    tt.

Definition connection_of_peer_id {A B C : Type}
  (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
  : option (connection A B C) :=
  Tezos_stdlib.Option.apply
    (fun p =>
      match Tezos_p2p.P2p_peer_state.get p with
      | Running {| data := data |} => Some data
      | _ => None
      end)
    (Tezos_base__TzPervasives.P2p_peer.Table.find_opt (known_peer_ids pool)
      peer_id).

Definition connections_of_addr {A B C : Type}
  (pool : t A B C) (addr : Ipaddr.V6.t) : list (connection A B C) :=
  Tezos_base__TzPervasives.P2p_point.Table.fold
    (fun function_parameter =>
      match function_parameter with
      | (addr', _) =>
        fun p =>
          fun acc =>
            if equiv_decb (Ipaddr.V6.compare addr addr') 0 then
              match Tezos_p2p.P2p_point_state.get p with
              | P2p_point_state.Running {| data := data |} => cons data acc
              | _ => acc
              end
            else
              acc
      end) (connected_points pool) [].

Definition get_addr {A B C : Type}
  (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
  : option Tezos_base__P2p_connection.Id.t :=
  Tezos_stdlib.Option.map
    (fun ci => id_point (Tezos_p2p.P2p_socket.info (conn ci)))
    (connection_of_peer_id pool peer_id).

Module Points.
  Definition info (msg peer_meta conn_meta : Type) :=
    Tezos_p2p.P2p_point_state.Info.t (connection msg peer_meta conn_meta).
  
  Definition info {A B C : Type} (function_parameter : t A B C)
    : Tezos_base__TzPervasives.P2p_point.Table.key ->
      option (Tezos_p2p.P2p_point_state.Info.t (connection A B C)) :=
    match function_parameter with
    | {| known_points := known_points |} =>
      fun point =>
        Tezos_base__TzPervasives.P2p_point.Table.find_opt known_points point
    end.
  
  Definition get_trusted {A B C : Type}
    (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    : bool :=
    Tezos_stdlib.Option.unopt_map Tezos_p2p.P2p_point_state.Info.trusted false
      (Tezos_base__TzPervasives.P2p_point.Table.find_opt (known_points pool)
        point).
  
  Definition set_trusted {A B C : Type}
    (pool : t A B C) (point : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
    : unit :=
    apply OCaml.Stdlib.ignore
      (register_point (Some true) pool (peer_id (identity (config pool))) point).
  
  Definition unset_trusted {A B C : Type}
    (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    : unit :=
    Tezos_stdlib.Option.iter Tezos_p2p.P2p_point_state.Info.unset_trusted
      (Tezos_base__TzPervasives.P2p_point.Table.find_opt (known_points pool)
        point).
  
  Definition fold_known {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_point.Table.key ->
        (Tezos_p2p.P2p_point_state.Info.t (connection A B C)) -> D -> D) : D :=
    Tezos_base__TzPervasives.P2p_point.Table.fold f (known_points pool) init.
  
  Definition fold_connected {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_point.Table.key ->
        (Tezos_p2p.P2p_point_state.Info.t (connection A B C)) -> D -> D) : D :=
    Tezos_base__TzPervasives.P2p_point.Table.fold f (connected_points pool) init.
  
  Definition banned {A B C D : Type}
    (pool : t A B C)
    (function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : bool :=
    match function_parameter with
    | (addr, _port) => Tezos_p2p.P2p_acl.banned_addr (acl pool) addr
    end.
  
  Definition ban {A B C D : Type}
    (pool : t A B C)
    (function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : unit :=
    match function_parameter with
    | (addr, _port) =>
      Tezos_p2p.P2p_acl.IPBlacklist.add (acl pool) addr;
      Tezos_base__TzPervasives.List.iter
        (fun conn =>
          set_field;
          Lwt.async
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_p2p.P2p_answerer.shutdown
                  (Stdlib.Lazy.force (answerer conn))
              end)) (connections_of_addr pool addr)
    end.
  
  Definition unban {A B C D : Type}
    (pool : t A B C)
    (function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : unit :=
    match function_parameter with
    | (addr, _port) => Tezos_p2p.P2p_acl.unban_addr (acl pool) addr
    end.
  
  Definition trust {A B C : Type}
    (pool : t A B C) (point : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
    : unit :=
    unban pool point;
    set_trusted pool point.
  
  Definition untrust {A B C : Type}
    (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    : unit := unset_trusted pool point.
End Points.

Module Peers.
  Definition info (msg peer_meta conn_meta : Type) :=
    Tezos_p2p.P2p_peer_state.Info.t (connection msg peer_meta conn_meta)
      peer_meta conn_meta.
  
  Definition info {A B C : Type} (function_parameter : t A B C)
    : Tezos_base__TzPervasives.P2p_peer.Table.key ->
      option (Tezos_p2p.P2p_peer_state.Info.t (connection A B C) B C) :=
    match function_parameter with
    | {| known_peer_ids := known_peer_ids |} => fun peer_id => try
    end.
  
  Definition get_peer_metadata {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : B := try.
  
  Definition get_score {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : float := (score (peer_meta_config pool)) (get_peer_metadata pool peer_id).
  
  Definition set_peer_metadata {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    (data : B) : unit :=
    Tezos_p2p.P2p_peer_state.Info.set_peer_metadata (register_peer pool peer_id)
      data.
  
  Definition get_trusted {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : bool := try.
  
  Definition set_trusted {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit := try.
  
  Definition unset_trusted {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit := try.
  
  Definition fold_known {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_peer.Table.key ->
        (Tezos_p2p.P2p_peer_state.Info.t (connection A B C) B C) -> D -> D)
    : D :=
    Tezos_base__TzPervasives.P2p_peer.Table.fold f (known_peer_ids pool) init.
  
  Definition fold_connected {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_peer.Table.key ->
        (Tezos_p2p.P2p_peer_state.Info.t (connection A B C) B C) -> D -> D)
    : D :=
    Tezos_base__TzPervasives.P2p_peer.Table.fold f (connected_peer_ids pool)
      init.
  
  Definition ban {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
    Tezos_p2p.P2p_acl.PeerBlacklist.add (acl pool) peer;
    Tezos_stdlib.Option.iter
      (fun conn =>
        set_field;
        Lwt.async
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_p2p.P2p_answerer.shutdown
                (Stdlib.Lazy.force (answerer conn))
            end)) (connection_of_peer_id pool peer).
  
  Definition unban {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
    Tezos_p2p.P2p_acl.unban_peer (acl pool) peer.
  
  Definition trust {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
    unban pool peer;
    set_trusted pool peer.
  
  Definition untrust {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit := unset_trusted pool peer.
  
  Definition banned {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : bool :=
    Tezos_p2p.P2p_acl.banned_peer (acl pool) peer.
End Peers.

Module Connection.
  Definition trusted_node {A B C : Type} (conn : connection A B C) : bool :=
    orb (Tezos_p2p.P2p_peer_state.Info.trusted (peer_info conn))
      (Tezos_stdlib.Option.unopt_map Tezos_p2p.P2p_point_state.Info.trusted
        false (point_info conn)).
  
  Definition private_node {A B C : Type} (conn : connection A B C) : bool :=
    Tezos_p2p.P2p_socket.private_node (conn conn).
  
  Definition fold {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_peer.Table.key ->
        (connection A B C) -> D -> D) : D :=
    Peers.fold_connected pool init
      (fun peer_id =>
        fun peer_info =>
          fun acc =>
            match Tezos_p2p.P2p_peer_state.get peer_info with
            | Running {| data := data |} => f peer_id data acc
            | _ => acc
            end).
  
  Definition list {A B C : Type} (pool : t A B C)
    : list (Tezos_base__TzPervasives.P2p_peer.Table.key * (connection A B C)) :=
    fold pool [] (fun peer_id => fun c => fun acc => cons (peer_id, c) acc).
  
  Definition random {A B C D E : Type}
    (different_than : option (connection A B C)) (no_private : bool)
    (pool : t D E C) : option (connection D E C) :=
    let candidates :=
      fold pool []
        (fun _peer =>
          fun conn =>
            fun acc =>
              if andb no_private (private_node conn) then
                acc
              else
                match different_than with
                | Some _ | None => cons conn acc
                end) in
    match candidates with
    | [] => None
    | cons _ _ =>
      Some
        (Tezos_base__TzPervasives.List.nth candidates
          (apply Stdlib.Random.int
            (Tezos_base__TzPervasives.List.length candidates)))
    end.
  
  Definition random_lowid {A B C D E : Type}
    (different_than : option (connection A B C)) (no_private : bool)
    (pool : t D E C)
    : option
      ((Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port) *
        Tezos_base.P2p_peer_id.t * (connection D E C)) :=
    let candidates :=
      fold pool []
        (fun _peer =>
          fun conn =>
            fun acc =>
              if andb no_private (private_node conn) then
                acc
              else
                match different_than with
                | Some _ | None =>
                  let ci := Tezos_p2p.P2p_socket.info (conn conn) in
                  match id_point ci with
                  | (_, None) => acc
                  | (addr, Some port) =>
                    cons ((addr, port), (peer_id ci), conn) acc
                  end
                end) in
    match candidates with
    | [] => None
    | cons _ _ =>
      Some
        (Tezos_base__TzPervasives.List.nth candidates
          (apply Stdlib.Random.int
            (Tezos_base__TzPervasives.List.length candidates)))
    end.
  
  Definition stat {A B C : Type} (function_parameter : connection A B C)
    : Tezos_base__TzPervasives.P2p_stat.t :=
    match function_parameter with
    | {| conn := conn |} => Tezos_p2p.P2p_socket.stat conn
    end.
  
  Definition info {A B C : Type} (function_parameter : connection A B C)
    : Tezos_base__TzPervasives.P2p_connection.Info.t C :=
    match function_parameter with
    | {| conn := conn |} => Tezos_p2p.P2p_socket.info conn
    end.
  
  Definition local_metadata {A B C : Type}
    (function_parameter : connection A B C) : C :=
    match function_parameter with
    | {| conn := conn |} => Tezos_p2p.P2p_socket.local_metadata conn
    end.
  
  Definition remote_metadata {A B C : Type}
    (function_parameter : connection A B C) : C :=
    match function_parameter with
    | {| conn := conn |} => Tezos_p2p.P2p_socket.remote_metadata conn
    end.
  
  Definition find_by_peer_id {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : option (connection A B C) :=
    Tezos_stdlib.Option.apply
      (fun p =>
        match Tezos_p2p.P2p_peer_state.get p with
        | Running {| data := data |} => Some data
        | _ => None
        end) (Peers.info pool peer_id).
  
  Definition find_by_point {A B C : Type}
    (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    : option (connection A B C) :=
    Tezos_stdlib.Option.apply
      (fun p =>
        match Tezos_p2p.P2p_point_state.get p with
        | Running {| data := data |} => Some data
        | _ => None
        end) (Points.info pool point).
End Connection.

Definition greylist_addr {A B C : Type}
  (pool : t A B C) (addr : Tezos_base__TzPervasives.P2p_addr.t) : unit :=
  Tezos_p2p.P2p_acl.IPGreylist.add (acl pool) addr
    (Tezos_stdlib_unix.Systime_os.now tt).

Definition greylist_peer {A B C : Type}
  (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
  Tezos_stdlib.Option.iter
    (fun function_parameter =>
      match function_parameter with
      | (addr, _port) =>
        greylist_addr pool addr;
        Tezos_p2p.P2p_acl.PeerGreylist.add (acl pool) peer
      end) (get_addr pool peer).

Definition acl_clear {A B C : Type} (pool : t A B C) : unit :=
  Tezos_p2p.P2p_acl.clear (acl pool).

Definition gc_greylist {A B C : Type}
  (older_than : Tezos_base__TzPervasives.Time.System.t) (pool : t A B C)
  : unit := Tezos_p2p.P2p_acl.IPGreylist.remove_old (acl pool) older_than.

Definition pool_stat {A B C : Type} (function_parameter : t A B C)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  match function_parameter with
  | {| io_sched := io_sched |} =>
    Tezos_p2p.P2p_io_scheduler.global_stat io_sched
  end.

Definition config {A B C : Type} (function_parameter : t A B C) : config :=
  match function_parameter with
  | {| config := config |} => config
  end.

Definition score {A B C : Type} (function_parameter : t A B C) : B -> float :=
  match function_parameter with
  | {| peer_meta_config := {| score := score |} |} => fun meta => score meta
  end.

Definition fail_unless_disconnected_point {A : Type}
  (point_info : Tezos_p2p.P2p_point_state.Info.t A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match Tezos_p2p.P2p_point_state.get point_info with
  | Disconnected => Tezos_base__TzPervasives.return_unit
  | Requested _ | Accepted _ =>
    Tezos_base__TzPervasives.fail P2p_errors.Pending_connection
  | Running _ => Tezos_base__TzPervasives.fail P2p_errors.Connected
  end.

Definition sample {A : Type} (best : Z) (other : Z) (points : list A)
  : list A :=
  let l := Tezos_base__TzPervasives.List.length points in
  if OCaml.Stdlib.le l (Z.add best other) then
    points
  else
    let best_indexes := Tezos_base__TzPervasives.List.init best (fun i => i) in
    let other_indexes :=
      apply (Tezos_base__TzPervasives.List.sort OCaml.Stdlib.compare)
        (Tezos_base__TzPervasives.List.init other
          (fun function_parameter =>
            match function_parameter with
            | _ => Z.add best (Stdlib.Random.int (Z.sub l best))
            end)) in
    let indexes := OCaml.Stdlib.app best_indexes other_indexes in
    apply
      (fun function_parameter =>
        match function_parameter with
        | (_, _, result) => result
        end)
      (Tezos_base__TzPervasives.List.fold_left
        (fun function_parameter =>
          match function_parameter with
          | (i, indexes, acc) =>
            fun point =>
              match indexes with
              | [] => (0, [], acc)
              | _ => ((Z.succ i), indexes, acc)
              end
          end) (0, indexes, []) points).

Definition compare_known_point_info {A B : Type}
  (p1 : Tezos_p2p.P2p_point_state.Info.t A)
  (p2 : Tezos_p2p.P2p_point_state.Info.t B) : Z :=
  let disconnected1 : bool :=
    Tezos_p2p.P2p_point_state.is_disconnected p1
  with disconnected2 : bool :=
    Tezos_p2p.P2p_point_state.is_disconnected p2 in
  let compare_last_seen {C D : Type}
    (p1 : Tezos_p2p.P2p_point_state.Info.point_info C) (p2 :
    Tezos_p2p.P2p_point_state.Info.point_info D) : Z :=
    match
      ((Tezos_p2p.P2p_point_state.Info.last_seen p1),
        (Tezos_p2p.P2p_point_state.Info.last_seen p2)) with
    | (None, None) => Z.sub (Z.mul (Stdlib.Random.int 2) 2) 1
    | (Some _, None) => 1
    | (None, Some _) => (-1)
    | (Some (_, time1), Some (_, time2)) =>
      match OCaml.Stdlib.compare time1 time2 with
      | 0 => Z.sub (Z.mul (Stdlib.Random.int 2) 2) 1
      | x => x
      end
    end in
  match (disconnected1, disconnected2) with
  | (false, false) => compare_last_seen p1 p2
  | (false, true) => (-1)
  | (true, false) => 1
  | (true, true) => compare_last_seen p2 p1
  end.

Fixpoint connect {A B C : Type}
  (timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
  (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (connection A B C)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.fail_when (Points.banned pool point)
      (P2p_errors.Point_banned point))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let timeout :=
          Tezos_stdlib.Option.unopt (connection_timeout (config pool)) timeout
          in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_base__TzPervasives.fail_unless
            (OCaml.Stdlib.le (active_connections pool)
              (max_connections (config pool))) P2p_errors.Too_many_connections)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let canceler := Tezos_stdlib.Lwt_canceler.create tt in
              Tezos_base__TzPervasives.with_timeout (Some canceler)
                (Tezos_stdlib_unix.Systime_os.sleep timeout)
                (fun canceler =>
                  let point_info :=
                    register_point None pool (peer_id (identity (config pool)))
                      point in
                  match Tezos_p2p.P2p_point_state.Info.point point_info with
                  | (addr, port) as point =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_base__TzPervasives.fail_unless
                        (orb (negb (private_mode (config pool)))
                          (Tezos_p2p.P2p_point_state.Info.trusted point_info))
                        P2p_errors.Private_mode)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (fail_unless_disconnected_point point_info)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_p2p.P2p_point_state.set_requested None
                                  point_info canceler;
                                let fd :=
                                  Tezos_p2p.P2p_fd.socket PF_INET6 SOCK_STREAM 0
                                  in
                                let uaddr :=
                                  Lwt_unix.ADDR_INET
                                    (Ipaddr_unix.V6.to_inet_addr addr) port in
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (lwt_debug
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "connect: " % string
                                        (CamlinternalFormatBasics.Alpha
                                          CamlinternalFormatBasics.End_of_format))
                                      "connect: %a" % string)
                                    Tezos_base__TzPervasives.P2p_point.Id.pp
                                    point)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_base__TzPervasives.protect
                                          (Some
                                            (fun err =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (lwt_debug
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "connect: " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.String_literal
                                                          " -> disconnect" %
                                                            string
                                                          CamlinternalFormatBasics.End_of_format)))
                                                    "connect: %a -> disconnect"
                                                      % string)
                                                  Tezos_base__TzPervasives.P2p_point.Id.pp
                                                  point)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_p2p.P2p_point_state.set_disconnected
                                                      None None
                                                      (greylisting_config pool)
                                                      point_info;
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (Tezos_p2p.P2p_fd.close fd)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          match err with
                                                          |
                                                            cons
                                                              (Exn
                                                                (Unix.Unix_error
                                                                  Unix.ECONNREFUSED
                                                                  _ _)) [] =>
                                                            Tezos_base__TzPervasives.fail
                                                              P2p_errors.Connection_refused
                                                          | err =>
                                                            Lwt.return_error err
                                                          end
                                                        end)
                                                  end))) (Some canceler)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              log pool
                                                (Outgoing_connection point);
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (Tezos_p2p.P2p_fd.connect fd
                                                  uaddr)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.return_unit
                                                  end)
                                            end))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (lwt_debug
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "connect: " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        " -> authenticate" %
                                                          string
                                                        CamlinternalFormatBasics.End_of_format)))
                                                  "connect: %a -> authenticate"
                                                    % string)
                                                Tezos_base__TzPervasives.P2p_point.Id.pp
                                                point)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  authenticate pool
                                                    (Some point_info) canceler
                                                    fd point
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end)

with authenticate {A B C : Type}
  (pool : t A B C)
  (point_info :
    option (Tezos_p2p.P2p_point_state.Info.point_info (connection A B C)))
  (canceler : Tezos_stdlib.Lwt_canceler.t) (fd : Tezos_p2p.P2p_fd.t)
  (point : Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (connection A B C)) :=
  let fd := Tezos_p2p.P2p_io_scheduler.register (io_sched pool) fd in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (raw_authenticate pool point_info canceler fd point)
    (fun function_parameter =>
      match function_parameter with
      | inl connection => Tezos_base__TzPervasives._return connection
      | (inr _) as err =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_io_scheduler.close None fd)
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt._return err
            end)
      end)

with raw_authenticate {A B C : Type}
  (pool : t A B C)
  (point_info :
    option (Tezos_p2p.P2p_point_state.Info.point_info (connection A B C)))
  (canceler : Tezos_stdlib.Lwt_canceler.t)
  (fd : Tezos_p2p.P2p_io_scheduler.connection)
  (point : Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t (sum (connection A B C) (list Tezos_base__TzPervasives.error)) :=
  let incoming := equiv_decb point_info None in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_debug
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "authenticate: " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)))
        "authenticate: %a%s" % string) Tezos_base__TzPervasives.P2p_point.Id.pp
      point
      (if incoming then
        " incoming" % string
      else
        "" % string))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_base__TzPervasives.protect
            (Some
              (fun err =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  match err with
                  | cons Canceled [] =>
                    lwt_debug
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "authenticate: " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                " -> canceled" % string
                                CamlinternalFormatBasics.End_of_format))))
                        "authenticate: %a%s -> canceled" % string)
                      Tezos_base__TzPervasives.P2p_point.Id.pp point
                      (if incoming then
                        " incoming" % string
                      else
                        "" % string)
                  | err =>
                    Tezos_base__TzPervasives.List.iter
                      (fun function_parameter =>
                        match function_parameter with
                        |
                          P2p_errors.Not_enough_proof_of_work _ |
                            P2p_errors.Invalid_auth | P2p_errors.Decipher_error
                            | P2p_errors.Invalid_message_size |
                            P2p_errors.Encoding_error |
                            P2p_errors.Decoding_error |
                            P2p_errors.Invalid_chunks_size _ =>
                          greylist_addr pool (fst point)
                        | _ => tt
                        end) err;
                    lwt_debug
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (CamlinternalFormatBasics.String_literal
                            "authenticate: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " -> failed" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))
                        "@[authenticate: %a%s -> failed@ %a@]" % string)
                      Tezos_base__TzPervasives.P2p_point.Id.pp point
                      (if incoming then
                        " incoming" % string
                      else
                        "" % string) Tezos_base__TzPervasives.pp_print_error err
                  end
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      may_register_my_id_point pool err;
                      log pool (Authentication_failed point);
                      if incoming then
                        Tezos_base__TzPervasives.P2p_point.Table.remove
                          (incoming pool) point
                      else
                        Tezos_stdlib.Option.iter
                          (Tezos_p2p.P2p_point_state.set_disconnected None None
                            (greylisting_config pool)) point_info;
                      Lwt.return_error err
                    end))) (Some canceler)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_p2p.P2p_socket.authenticate canceler
                  (proof_of_work_target (config pool)) incoming fd point
                  (listening_port (config pool)) (identity (config pool))
                  (announced_version pool) (conn_meta_config pool)
              end))
          (fun function_parameter =>
            match function_parameter with
            | (info, auth_fd) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (lwt_debug
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "authenticate: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " -> auth " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))))
                    "authenticate: %a -> auth %a" % string)
                  Tezos_base__TzPervasives.P2p_point.Id.pp point
                  Tezos_base__TzPervasives.P2p_peer.Id.pp (peer_id info))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_base__TzPervasives.fail_when
                        (Peers.banned pool (peer_id info))
                        (P2p_errors.Peer_banned (peer_id info)))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let remote_point_info :=
                            match id_point info with
                            | _ => None
                            end in
                          let connection_point_info :=
                            match (point_info, remote_point_info) with
                            | (None, None) => None
                            |
                              ((Some _) as point_info, _) |
                                (_, (Some _) as point_info) => point_info
                            end in
                          let peer_info := register_peer pool (peer_id info) in
                          let acceptable_version :=
                            Tezos_base__TzPervasives.Network_version.select
                              (chain_name (message_config pool))
                              (distributed_db_versions (message_config pool))
                              (custom_p2p_versions pool)
                              (announced_version info) in
                          let acceptable_point :=
                            Tezos_stdlib.Option.unopt_map
                              (fun connection_point_info =>
                                match
                                  Tezos_p2p.P2p_point_state.get
                                    connection_point_info with
                                | Requested _ => negb incoming
                                | Disconnected =>
                                  let unexpected :=
                                    andb (private_mode (config pool))
                                      (negb
                                        (Tezos_p2p.P2p_point_state.Info.trusted
                                          connection_point_info)) in
                                  if unexpected then
                                    warn
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "[private node] incoming connection from untrused peer rejected!"
                                            % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "[private node] incoming connection from untrused peer rejected!"
                                          % string)
                                  else
                                    tt;
                                  negb unexpected
                                | Accepted _ | Running _ => false
                                end) (negb (private_mode (config pool)))
                              connection_point_info in
                          let acceptable_peer_id :=
                            match Tezos_p2p.P2p_peer_state.get peer_info with
                            | Accepted _ => false
                            | Running _ => false
                            | Disconnected => true
                            end in
                          if incoming then
                            Tezos_base__TzPervasives.P2p_point.Table.remove
                              (incoming pool) point
                          else
                            tt;
                          Tezos_stdlib.Option.iter
                            (fun point_info =>
                              Tezos_p2p.P2p_point_state.set_private point_info
                                (private_node info)) connection_point_info;
                          match acceptable_version with
                          | _ =>
                            log pool
                              (Rejecting_request point (id_point info)
                                (peer_id info));
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (lwt_debug
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "authenticate: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " -> kick " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            " point: " % string
                                            (CamlinternalFormatBasics.Bool
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.String_literal
                                                " peer_id: " % string
                                                (CamlinternalFormatBasics.Bool
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.End_of_format))))))))
                                  "authenticate: %a -> kick %a point: %B peer_id: %B"
                                    % string)
                                Tezos_base__TzPervasives.P2p_point.Id.pp point
                                Tezos_base__TzPervasives.P2p_peer.Id.pp
                                (peer_id info) acceptable_point
                                acceptable_peer_id)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_p2p.P2p_socket.kick auth_fd)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        if negb incoming then
                                          Tezos_stdlib.Option.iter
                                            (Tezos_p2p.P2p_point_state.set_disconnected
                                              None None
                                              (greylisting_config pool))
                                            point_info
                                        else
                                          tt;
                                        match acceptable_version with
                                        | None =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (lwt_debug
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "No common protocol" % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    (CamlinternalFormatBasics.String_literal
                                                      "(chains: local " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.String_literal
                                                          " - remote " % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Char_literal
                                                              ")" % char
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                CamlinternalFormatBasics.Flush_newline
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "(db_versions: local ["
                                                                    % string
                                                                  (CamlinternalFormatBasics.Alpha
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "] - remote "
                                                                        % string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Char_literal
                                                                          ")" %
                                                                            char
                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                            CamlinternalFormatBasics.Flush_newline
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              "(p2p_versions: local ["
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Alpha
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "] - remote "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                    (CamlinternalFormatBasics.Char_literal
                                                                                      ")"
                                                                                        %
                                                                                        char
                                                                                      CamlinternalFormatBasics.End_of_format)))))))))))))))))))
                                                "No common protocol@.(chains: local %a - remote %a)@.(db_versions: local [%a] - remote %a)@.(p2p_versions: local [%a] - remote %a)"
                                                  % string)
                                              Tezos_base__TzPervasives.Distributed_db_version.pp_name
                                              (chain_name (message_config pool))
                                              Tezos_base__TzPervasives.Distributed_db_version.pp_name
                                              (chain_name
                                                (announced_version info))
                                              (Stdlib.Format.pp_print_list None
                                                Tezos_base__TzPervasives.Distributed_db_version.pp)
                                              (distributed_db_versions
                                                (message_config pool))
                                              Tezos_base__TzPervasives.Distributed_db_version.pp
                                              (distributed_db_version
                                                (announced_version info))
                                              (Stdlib.Format.pp_print_list None
                                                Tezos_base__TzPervasives.P2p_version.pp)
                                              (custom_p2p_versions pool)
                                              Tezos_base__TzPervasives.P2p_version.pp
                                              (p2p_version
                                                (announced_version info)))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.fail
                                                  (P2p_errors.Rejected_no_common_protocol
                                                    {|
                                                      announced :=
                                                        announced_version info
                                                      |})
                                              end)
                                        | Some _ =>
                                          Tezos_base__TzPervasives.fail
                                            (P2p_errors.Rejected (peer_id info))
                                        end
                                      end)
                                end)
                          end
                        end)
                  end)
            end)
      end)

with create_connection {A B C : Type}
  (pool : t A B C)
  (p2p_conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t A) C)
  (id_point : Tezos_base__P2p_connection.Id.t)
  (point_info :
    option (Tezos_p2p.P2p_point_state.Info.point_info (connection A B C)))
  (peer_info : Tezos_p2p.P2p_peer_state.Info.peer_info (connection A B C) B C)
  (negotiated_version : Tezos_base__TzPervasives.Network_version.t)
  : connection A B C :=
  let peer_id := Tezos_p2p.P2p_peer_state.Info.peer_id peer_info in
  let canceler := Tezos_stdlib.Lwt_canceler.create tt in
  let size :=
    Tezos_stdlib.Option.map
      (fun qs =>
        (qs,
          (fun function_parameter =>
            match function_parameter with
            | (size, _) =>
              Z.add (Z.add (Z.mul (Z.div Stdlib.Sys.word_size 8) 11) size)
                Tezos_stdlib.Lwt_pipe.push_overhead
            end))) (incoming_app_message_queue_size (config pool)) in
  let messages := Tezos_stdlib.Lwt_pipe.create size tt in
  let fix callback_default : Tezos_p2p.P2p_answerer.callback A :=
    {|
      P2p_answerer.bootstrap :=
        fun function_parameter =>
          match function_parameter with
          | tt => list_known_points (Some true) pool conn
          end;
      P2p_answerer.advertise :=
        fun points =>
          register_new_points None pool conn points;
          Lwt.return_unit;
      P2p_answerer.message :=
        fun size => fun msg => Tezos_stdlib.Lwt_pipe.push messages (size, msg);
      P2p_answerer.swap_request :=
        fun point => fun peer_id => swap_request pool conn point peer_id;
      P2p_answerer.swap_ack :=
        fun point => fun peer_id => swap_ack pool conn point peer_id |}
  with callback_private : Tezos_p2p.P2p_answerer.callback A :=
    {|
      P2p_answerer.bootstrap :=
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (private_node_warn
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Receive requests for peers addresses from " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "Receive requests for peers addresses from %a" % string)
                Tezos_base__TzPervasives.P2p_peer.Id.pp peer_id)
              (fun function_parameter =>
                match function_parameter with
                | tt => Lwt.return_nil
                end)
          end;
      P2p_answerer.advertise :=
        fun _points =>
          private_node_warn
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Received new peers addresses from " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "Received new peers addresses from %a" % string)
            Tezos_base__TzPervasives.P2p_peer.Id.pp peer_id;
      P2p_answerer.message :=
        fun size => fun msg => Tezos_stdlib.Lwt_pipe.push messages (size, msg);
      P2p_answerer.swap_request :=
        fun _point =>
          fun _peer_id =>
            private_node_warn
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Received swap requests from " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "Received swap requests from %a" % string)
              Tezos_base__TzPervasives.P2p_peer.Id.pp peer_id;
      P2p_answerer.swap_ack :=
        fun _point =>
          fun _peer_id =>
            private_node_warn
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Received swap ack from " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "Received swap ack from %a" % string)
              Tezos_base__TzPervasives.P2p_peer.Id.pp peer_id |}
  with answerer : Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t A C) :=
    apply (Tezos_p2p.P2p_answerer.run p2p_conn canceler)
      (if private_mode (config pool) then
        callback_private
      else
        callback_default)
  with conn : connection A B C :=
    {| canceler := canceler; messages := messages; conn := p2p_conn;
      peer_info := peer_info; point_info := point_info;
      negotiated_version := negotiated_version; answerer := answerer;
      last_sent_swap_request := None; wait_close := false |} in
  OCaml.Stdlib.ignore (Stdlib.Lazy.force answerer);
  let conn_meta := Tezos_p2p.P2p_socket.remote_metadata p2p_conn in
  Tezos_stdlib.Option.iter
    (fun point_info =>
      let point := Tezos_p2p.P2p_point_state.Info.point point_info in
      Tezos_p2p.P2p_point_state.set_running None point_info peer_id conn;
      Tezos_base__TzPervasives.P2p_point.Table.add (connected_points pool) point
        point_info) point_info;
  log pool (Connection_established id_point peer_id);
  Tezos_p2p.P2p_peer_state.set_running None peer_info id_point conn conn_meta;
  Tezos_base__TzPervasives.P2p_peer.Table.add (connected_peer_ids pool) peer_id
    peer_info;
  Lwt_condition.broadcast (new_connection (events pool)) tt;
  Tezos_stdlib.Lwt_canceler.on_cancel canceler
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Disconnect: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))))
              "Disconnect: %a (%a)" % string)
            Tezos_base__TzPervasives.P2p_peer.Id.pp peer_id
            Tezos_base__TzPervasives.P2p_connection.Id.pp id_point)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_stdlib.Option.iter
                (Tezos_p2p.P2p_point_state.set_disconnected None None
                  (greylisting_config pool)) point_info;
              log pool (Disconnection peer_id);
              Tezos_p2p.P2p_peer_state.set_disconnected None None peer_info;
              Tezos_stdlib.Option.iter
                (fun point_info =>
                  Tezos_base__TzPervasives.P2p_point.Table.remove
                    (connected_points pool)
                    (Tezos_p2p.P2p_point_state.Info.point point_info))
                point_info;
              Tezos_base__TzPervasives.P2p_peer.Table.remove
                (connected_peer_ids pool) peer_id;
              if
                OCaml.Stdlib.le (max_connections (config pool))
                  (active_connections pool) then
                Lwt_condition.broadcast (too_many_connections (events pool)) tt;
                log pool Too_many_connections
              else
                tt;
              Tezos_stdlib.Lwt_pipe.close messages;
              Tezos_p2p.P2p_socket.close (Some (wait_close conn)) (conn conn)
            end)
      end);
  Tezos_base__TzPervasives.List.iter (fun f => f peer_id conn)
    (new_connection_hook pool);
  if OCaml.Stdlib.lt (active_connections pool) (min_connections (config pool))
    then
    Lwt_condition.broadcast (too_few_connections (events pool)) tt;
    log pool Too_few_connections
  else
    tt;
  conn

with disconnect {A B C : Type} (op_star_o_p_t_star : option bool)
  : (connection A B C) -> Lwt.t unit :=
  let wait :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun conn =>
    set_field;
    Tezos_p2p.P2p_answerer.shutdown (Stdlib.Lazy.force (answerer conn))

with register_new_points {A B C : Type}
  (trusted : option bool) (pool : t A B C) (conn : connection A B C)
  : (list Tezos_base__TzPervasives.P2p_point.Id.t) -> unit :=
  let source_peer_id := Tezos_p2p.P2p_peer_state.Info.peer_id (peer_info conn)
    in
  fun points =>
    Tezos_base__TzPervasives.List.iter
      (register_new_point trusted pool source_peer_id) points

with register_new_point {A B C : Type}
  (trusted : option bool) (pool : t A B C)
  (source_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
  (point : Tezos_base__TzPervasives.P2p_point.Id.t) : unit :=
  if
    negb
      (Tezos_base__TzPervasives.P2p_point.Table.mem (my_id_points pool) point)
    then
    OCaml.Stdlib.ignore (register_point trusted pool source_peer_id point)
  else
    tt

with list_known_points {A B C : Type} (op_star_o_p_t_star : option bool)
  : (t A B C) ->
    (connection A B C) -> Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t) :=
  let ignore_private :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun pool =>
    fun conn =>
      if Connection.private_node conn then
        Tezos_base__TzPervasives.op_gt_gt_eq
          (private_node_warn
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Private peer (" % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    ") asked other peers addresses" % string
                    CamlinternalFormatBasics.End_of_format)))
              "Private peer (%a) asked other peers addresses" % string)
            Tezos_base__TzPervasives.P2p_peer.Id.pp
            (Tezos_p2p.P2p_peer_state.Info.peer_id (peer_info conn)))
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt.return_nil
            end)
      else
        OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply
                (Tezos_base__TzPervasives.P2p_point.Table.fold
                  (fun point_id =>
                    fun point_info =>
                      fun acc =>
                        if
                          orb
                            (andb ignore_private
                              (negb
                                (Tezos_p2p.P2p_point_state.Info.known_public
                                  point_info))) (Points.banned pool point_id)
                          then
                          acc
                        else
                          cons point_info acc) (known_points pool) [])
                (Tezos_base__TzPervasives.List.sort compare_known_point_info))
              (sample 30 20))
            (Tezos_base__TzPervasives.List.map
              Tezos_p2p.P2p_point_state.Info.point)) Lwt._return

with active_connections {A B C : Type} (pool : t A B C) : Z :=
  Tezos_base__TzPervasives.P2p_peer.Table.length (connected_peer_ids pool)

with swap_request {A B C : Type}
  (pool : t A B C) (conn : connection A B C)
  (new_point : Tezos_base__TzPervasives.P2p_point.Id.t)
  (_new_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) : Lwt.t unit :=
  let source_peer_id := Tezos_p2p.P2p_peer_state.Info.peer_id (peer_info conn)
    in
  log pool (Swap_request_received {| source := source_peer_id |});
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Swap request received from " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Swap request received from %a" % string)
      Tezos_base__TzPervasives.P2p_peer.Id.pp source_peer_id)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let span_since_last_swap :=
          Ptime.diff (Tezos_stdlib_unix.Systime_os.now tt)
            (Tezos_base__TzPervasives.Time.System.max
              (latest_succesfull_swap pool) (latest_accepted_swap pool)) in
        let new_point_info := register_point None pool source_peer_id new_point
          in
        if
          orb
            (OCaml.Stdlib.lt
              (Ptime.Span.compare span_since_last_swap
                (swap_linger (config pool))) 0)
            (negb (Tezos_p2p.P2p_point_state.is_disconnected new_point_info))
          then
          log pool (Swap_request_ignored {| source := source_peer_id |});
          lwt_log_info
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Ignoring swap request from " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "Ignoring swap request from %a" % string)
            Tezos_base__TzPervasives.P2p_peer.Id.pp source_peer_id
        else
          match Connection.random_lowid None true pool with
          | None =>
            lwt_log_info
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No swap candidate for " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "No swap candidate for %a" % string)
              Tezos_base__TzPervasives.P2p_peer.Id.pp source_peer_id
          | Some (proposed_point, proposed_peer_id, _proposed_conn) =>
            match
              Tezos_p2p.P2p_socket.write_now (conn conn)
                (Swap_ack proposed_point proposed_peer_id) with
            | inl true =>
              log pool (Swap_ack_sent {| source := source_peer_id |});
              swap pool conn proposed_peer_id new_point
            | inl false =>
              log pool (Swap_request_received {| source := source_peer_id |});
              Lwt.return_unit
            | inr _ =>
              log pool (Swap_request_received {| source := source_peer_id |});
              Lwt.return_unit
            end
          end
      end)

with swap_ack {A B C : Type}
  (pool : t A B C) (conn : connection A B C)
  (new_point : Tezos_base__TzPervasives.P2p_point.Id.t)
  (_new_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) : Lwt.t unit :=
  let source_peer_id := Tezos_p2p.P2p_peer_state.Info.peer_id (peer_info conn)
    in
  log pool (Swap_ack_received {| source := source_peer_id |});
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Swap ack received from " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Swap ack received from %a" % string)
      Tezos_base__TzPervasives.P2p_peer.Id.pp source_peer_id)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        match last_sent_swap_request conn with
        | None => Lwt.return_unit
        | Some (_time, proposed_peer_id) =>
          match Connection.find_by_peer_id pool proposed_peer_id with
          | None => swap pool conn proposed_peer_id new_point
          | Some _ => Lwt.return_unit
          end
        end
      end)

with swap {A B C : Type}
  (pool : t A B C) (conn : connection A B C)
  (current_peer_id : Tezos_base.P2p_peer_id.t)
  (new_point : Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t unit :=
  let source_peer_id := Tezos_p2p.P2p_peer_state.Info.peer_id (peer_info conn)
    in
  set_field;
  Tezos_base__TzPervasives.op_gt_gt_eq (connect None pool new_point)
    (fun function_parameter =>
      match function_parameter with
      | inl _new_conn =>
        set_field;
        log pool (Swap_success {| source := source_peer_id |});
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_info
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Swap to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " succeeded" % string
                    CamlinternalFormatBasics.End_of_format)))
              "Swap to %a succeeded" % string)
            Tezos_base__TzPervasives.P2p_point.Id.pp new_point)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              match Connection.find_by_peer_id pool current_peer_id with
              | None => Lwt.return_unit
              | Some conn => disconnect None conn
              end
            end)
      | inr err =>
        set_field;
        log pool (Swap_failure {| source := source_peer_id |});
        match err with
        | cons Timeout [] =>
          lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Swap to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " was interrupted: " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))
              "Swap to %a was interrupted: %a" % string)
            Tezos_base__TzPervasives.P2p_point.Id.pp new_point
            Tezos_base__TzPervasives.pp_print_error err
        | _ =>
          lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Swap to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " failed: " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))
              "Swap to %a failed: %a" % string)
            Tezos_base__TzPervasives.P2p_point.Id.pp new_point
            Tezos_base__TzPervasives.pp_print_error err
        end
      end).

Definition accept {A B C : Type}
  (pool : t A B C) (fd : Tezos_p2p.P2p_fd.t) (point : Tezos_base.P2p_point.Id.t)
  : unit :=
  log pool (Incoming_connection point);
  let max_active_conns :=
    if Stdlib.Random.bool tt then
      Z.add (max_connections (config pool)) 1
    else
      max_connections (config pool) in
  if
    orb
      (OCaml.Stdlib.le (max_incoming_connections (config pool))
        (Tezos_base__TzPervasives.P2p_point.Table.length (incoming pool)))
      (orb (OCaml.Stdlib.le max_active_conns (active_connections pool))
        (Tezos_p2p.P2p_acl.banned_addr (acl pool) (fst point))) then
    Lwt.async
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_p2p.P2p_fd.close fd
        end)
  else
    let canceler := Tezos_stdlib.Lwt_canceler.create tt in
    Tezos_base__TzPervasives.P2p_point.Table.add (incoming pool) point canceler;
    Lwt.async
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.with_timeout (Some canceler)
            (Tezos_stdlib_unix.Systime_os.sleep
              (authentication_timeout (config pool)))
            (fun canceler => authenticate pool None canceler fd point)
        end).

Definition send_swap_request {A B C : Type} (pool : t A B C) : unit :=
  match Connection.random None true pool with
  | Some _ | None => tt
  end.

Definition create {A B C : Type}
  (op_star_o_p_t_star : option (list Tezos_base__TzPervasives.P2p_version.t))
  : config ->
    (peer_meta_config A) ->
      (Tezos_p2p.P2p_socket.metadata_config B) ->
        (message_config C) -> Tezos_p2p.P2p_io_scheduler.t -> Lwt.t (t C A B) :=
  let p2p_versions :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_base__TzPervasives.P2p_version.supported
    end in
  fun config =>
    fun peer_meta_config =>
      fun conn_meta_config =>
        fun message_config =>
          fun io_sched =>
            let events :=
              {| too_few_connections := Lwt_condition.create tt;
                too_many_connections := Lwt_condition.create tt;
                new_peer := Lwt_condition.create tt;
                new_point := Lwt_condition.create tt;
                new_connection := Lwt_condition.create tt |} in
            let pool :=
              {| config := config;
                announced_version :=
                  Tezos_base__TzPervasives.Network_version.announced
                    (chain_name message_config)
                    (distributed_db_versions message_config) p2p_versions;
                custom_p2p_versions := p2p_versions;
                greylisting_config := greylisting_config config;
                peer_meta_config := peer_meta_config;
                conn_meta_config := conn_meta_config;
                message_config := message_config;
                my_id_points :=
                  Tezos_base__TzPervasives.P2p_point.Table.create 7;
                known_peer_ids :=
                  Tezos_base__TzPervasives.P2p_peer.Table.create 53;
                connected_peer_ids :=
                  Tezos_base__TzPervasives.P2p_peer.Table.create 53;
                known_points :=
                  Tezos_base__TzPervasives.P2p_point.Table.create 53;
                connected_points :=
                  Tezos_base__TzPervasives.P2p_point.Table.create 53;
                incoming := Tezos_base__TzPervasives.P2p_point.Table.create 53;
                io_sched := io_sched;
                encoding :=
                  Tezos_p2p.P2p_message.encoding (encoding message_config);
                events := events;
                watcher := Tezos_stdlib.Lwt_watcher.create_input tt;
                acl := Tezos_p2p.P2p_acl.create 1023; new_connection_hook := [];
                latest_accepted_swap := Ptime.epoch;
                latest_succesfull_swap := Ptime.epoch |} in
            Tezos_base__TzPervasives.List.iter (Points.set_trusted pool)
              (trusted_points config);
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_p2p.P2p_peer_state.Info.File.load (peers_file config)
                (peer_meta_encoding peer_meta_config))
              (fun function_parameter =>
                match function_parameter with
                | inl peer_ids =>
                  Tezos_base__TzPervasives.List.iter
                    (fun peer_info =>
                      let peer_id :=
                        Tezos_p2p.P2p_peer_state.Info.peer_id peer_info in
                      Tezos_base__TzPervasives.P2p_peer.Table.add
                        (known_peer_ids pool) peer_id peer_info;
                      match Tezos_p2p.P2p_peer_state.Info.last_seen peer_info
                        with
                      | None | Some ((_, None), _) => tt
                      | Some ((addr, Some port), _) =>
                        OCaml.Stdlib.reverse_apply
                          (register_point None pool peer_id (addr, port))
                          OCaml.Stdlib.ignore
                      end) peer_ids;
                  Lwt._return pool
                | inr err =>
                  log_error
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Failed to parse peers file:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Failed to parse peers file:@ %a@]" % string)
                    Tezos_base__TzPervasives.pp_print_error err;
                  Lwt._return pool
                end).

Definition destroy {A B C : Type} (function_parameter : t A B C) : Lwt.t unit :=
  match function_parameter with
  | {| config := config; peer_meta_config := peer_meta_config |} as pool =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Saving metadata in " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format))
          "Saving metadata in %s" % string) (peers_file config))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_p2p.P2p_peer_state.Info.File.save (peers_file config)
                (peer_meta_encoding peer_meta_config)
                (Tezos_base__TzPervasives.P2p_peer.Table.fold
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => fun a => fun b => cons a b
                    end) (known_peer_ids pool) []))
              (fun function_parameter =>
                match function_parameter with
                | inr err =>
                  log_error
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Failed to save peers file:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Failed to save peers file:@ %a@]" % string)
                    Tezos_base__TzPervasives.pp_print_error err;
                  Lwt.return_unit
                | inl tt => Lwt.return_unit
                end))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                apply
                  (Tezos_base__TzPervasives.P2p_point.Table.fold
                    (fun _point =>
                      fun point_info =>
                        fun acc =>
                          match Tezos_p2p.P2p_point_state.get point_info with
                          |
                            Requested {| cancel := cancel |} |
                              Accepted {| cancel := cancel |} =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_stdlib.Lwt_canceler.cancel cancel)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => acc
                                end)
                          | Running {| data := conn |} =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (disconnect None conn)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => acc
                                end)
                          | Disconnected => acc
                          end) (known_points pool))
                  (apply
                    (Tezos_base__TzPervasives.P2p_peer.Table.fold
                      (fun _peer_id =>
                        fun peer_info =>
                          fun acc =>
                            match Tezos_p2p.P2p_peer_state.get peer_info with
                            | Accepted {| cancel := cancel |} =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_stdlib.Lwt_canceler.cancel cancel)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => acc
                                  end)
                            | Running {| data := conn |} =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (disconnect None conn)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => acc
                                  end)
                            | Disconnected => acc
                            end) (known_peer_ids pool))
                    (Tezos_base__TzPervasives.P2p_point.Table.fold
                      (fun _point =>
                        fun canceler =>
                          fun acc =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_stdlib.Lwt_canceler.cancel canceler)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => acc
                                end)) (incoming pool) Lwt.return_unit))
              end)
        end)
  end.

Definition on_new_connection {A B C : Type}
  (pool : t A B C)
  (f : Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> unit)
  : unit := set_field.
src/lib_p2p/p2p_pool.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Pool of connections. This module manages the connection pool that
    the peer-to-peer layer needs to maintain in order to function
    correctly.

    A pool and its connections are parametrized by the type of
    messages exchanged over the connection and the type of
    meta-information associated with a peer. The type
    [('msg, 'peer_meta,'conn_meta)
    connection] is a wrapper on top of [P2p_socket.t] that adds
    meta-informations, data-structures describing the detailed state of
    the peer and the connection, as well as a new message queue
    (referred to "app  message queue") that will only contain the
    messages from the internal [P2p_socket.t] that needs to be examined
    by the higher layers. Some messages are directly processed by an
    internal worker and thus never propagated above. *)

(** {1 Pool management} *)

type ('msg, 'peer_meta, 'conn_meta) t

(** The type of a pool of connections, parametrized by, resp., the type
    of messages and the meta-informations associated to an identity and
    a connection. *)
type ('msg, 'peer_meta, 'conn_meta) pool = ('msg, 'peer_meta, 'conn_meta) t

type config = {
  identity : P2p_identity.t;  (** Our identity. *)
  proof_of_work_target : Crypto_box.target;
      (** The proof of work target we require from peers. *)
  trusted_points : P2p_point.Id.t list;
      (** List of hard-coded known peers to bootstrap the network from. *)
  peers_file : string;
      (** The path to the JSON file where the metadata associated to
      peer_ids are loaded / stored. *)
  private_mode : bool;
      (** If [true], only open outgoing/accept incoming connections
      to/from peers whose addresses are in [trusted_peers], and inform
      these peers that the identity of this node should be revealed to
      the rest of the network. *)
  greylisting_config : P2p_point_state.Info.greylisting_config;
      (** The greylisting configuration. *)
  listening_port : P2p_addr.port option;
      (** If provided, it will be passed to [P2p_connection.authenticate]
      when we authenticate against a new peer. *)
  min_connections : int;
      (** Strict minimum number of connections
      (triggers [LogEvent.too_few_connections]). *)
  max_connections : int;
      (** Max number of connections. If it's reached, [connect] and
      [accept] will fail, i.e. not add more connections
      (also triggers [LogEvent.too_many_connections]). *)
  max_incoming_connections : int;
      (** Max not-yet-authenticated incoming connections.
      Above this number, [accept] will start dropping incoming
      connections. *)
  connection_timeout : Time.System.Span.t;
      (** Maximum time allowed to the establishment of a connection. *)
  authentication_timeout : Time.System.Span.t;
      (** Delay granted to a peer to perform authentication, in seconds. *)
  incoming_app_message_queue_size : int option;
      (** Size of the message queue for user messages (messages returned
      by this module's [read] function. *)
  incoming_message_queue_size : int option;
      (** Size of the incoming message queue internal of a peer's Reader
      (See [P2p_connection.accept]). *)
  outgoing_message_queue_size : int option;
      (** Size of the outgoing message queue internal to a peer's Writer
      (See [P2p_connection.accept]). *)
  known_peer_ids_history_size : int;
      (** Size of the known peer_ids log buffer (default: 50) *)
  known_points_history_size : int;
      (** Size of the known points log buffer (default: 50) *)
  max_known_points : (int * int) option;
      (** Parameters for the garbage collection of known points. If
      None, no garbage collection is performed. Otherwise, the first
      integer of the couple limits the size of the "known points"
      table. When this number is reached, the table is purged off of
      disconnected points, older first, to try to reach the amount of
      connections indicated by the second integer. *)
  max_known_peer_ids : (int * int) option;
      (** Like [max_known_points], but for known peer_ids. *)
  swap_linger : Time.System.Span.t;
      (** Peer swapping does not occur more than once during a timespan of
      [spap_linger] seconds. *)
  binary_chunks_size : int option;
      (** Size (in bytes) of binary blocks that are sent to other
      peers. Default value is 64 kB. *)
}

type 'peer_meta peer_meta_config = {
  peer_meta_encoding : 'peer_meta Data_encoding.t;
  peer_meta_initial : unit -> 'peer_meta;
  score : 'peer_meta -> float;
}

type 'msg message_config = {
  encoding : 'msg P2p_message.encoding list;
  chain_name : Distributed_db_version.name;
  distributed_db_versions : Distributed_db_version.t list;
}

(** [create config meta_cfg msg_cfg io_sched] is a freshly minted
    pool. *)
val create :
  ?p2p_versions:P2p_version.t list ->
  config ->
  'peer_meta peer_meta_config ->
  'conn_meta P2p_socket.metadata_config ->
  'msg message_config ->
  P2p_io_scheduler.t ->
  ('msg, 'peer_meta, 'conn_meta) pool Lwt.t

(** [destroy pool] returns when member connections are either
    disconnected or canceled. *)
val destroy : ('msg, 'peer_meta, 'conn_meta) pool -> unit Lwt.t

(** [active_connections pool] is the number of connections inside
    [pool]. *)
val active_connections : ('msg, 'peer_meta, 'conn_meta) pool -> int

(** [pool_stat pool] is a snapshot of current bandwidth usage for the
    entire [pool]. *)
val pool_stat : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_stat.t

(** [config pool] is the [config] argument passed to [pool] at
    creation. *)
val config : _ pool -> config

(** [send_swap_request pool] given two connected peers pi and pj (pi
    <> pj), suggest swap with pi for the peer pj. This behavior is
    disabled in private mode *)
val send_swap_request : ('msg, 'peer_meta, 'conn_meta) pool -> unit

(** [score pool peer_meta] returns the score of a peer in the pool
    whose peer_meta is provided *)
val score : ('msg, 'peer_meta, 'conn_meta) pool -> 'peer_meta -> float

(** {2 Pool events} *)

module Pool_event : sig
  (** [wait_too_few_connections pool] is determined when the number of
      connections drops below the desired level. *)
  val wait_too_few_connections :
    ('msg, 'peer_meta, 'conn_meta) pool -> unit Lwt.t

  (** [wait_too_many_connections pool] is determined when the number of
      connections exceeds the desired level. *)
  val wait_too_many_connections :
    ('msg, 'peer_meta, 'conn_meta) pool -> unit Lwt.t

  (** [wait_new_peer pool] is determined when a new peer
      (i.e. authentication successful) gets added to the pool. *)
  val wait_new_peer : ('msg, 'peer_meta, 'conn_meta) pool -> unit Lwt.t

  (** [wait_new_point pool] is determined when a new point gets registered
      to the pool. *)
  val wait_new_point : ('msg, 'peer_meta, 'conn_meta) pool -> unit Lwt.t

  (** [wait_new_connection pool] is determined when a new connection is
      successfully established in the pool. *)
  val wait_new_connection : ('msg, 'peer_meta, 'conn_meta) pool -> unit Lwt.t
end

(** {1 Connections management} *)

(** Type of a connection to a peer, parametrized by the type of
    messages exchanged as well as meta-information associated to a
    peer and a connection. It mostly wraps [P2p_connection.connection],
    adding meta-information and data-structures describing a more
    fine-grained logical state of the connection. *)
type ('msg, 'peer_meta, 'conn_meta) connection

(** [connect ?timeout pool point] tries to add a connection to [point]
    in [pool] in less than [timeout] seconds. *)
val connect :
  ?timeout:Time.System.Span.t ->
  ('msg, 'peer_meta, 'conn_meta) pool ->
  P2p_point.Id.t ->
  ('msg, 'peer_meta, 'conn_meta) connection tzresult Lwt.t

(** [accept pool fd point] instructs [pool] to start the process of
    accepting a connection from [fd]. Used by [P2p_welcome]. *)
val accept :
  ('msg, 'peer_meta, 'conn_meta) pool -> P2p_fd.t -> P2p_point.Id.t -> unit

(** [register_new_point pool source_peer_id point] tries to register [point]
    in pool's internal peer table. *)
val register_new_point :
  ?trusted:bool ->
  ('a, 'b, 'c) pool ->
  P2p_peer.Table.key ->
  P2p_point.Id.t ->
  unit

(** [disconnect conn] cleanly closes [conn] and returns after [conn]'s
    internal worker has returned. *)
val disconnect :
  ?wait:bool -> ('msg, 'peer_meta, 'conn_meta) connection -> unit Lwt.t

module Connection : sig
  val info :
    ('msg, 'peer_meta, 'conn_meta) connection ->
    'conn_meta P2p_connection.Info.t

  val local_metadata : ('msg, 'peer_meta, 'conn_meta) connection -> 'conn_meta

  val remote_metadata : ('msg, 'peer_meta, 'conn_meta) connection -> 'conn_meta

  (** [stat conn] is a snapshot of current bandwidth usage for
      [conn]. *)
  val stat : ('msg, 'peer_meta, 'conn_meta) connection -> P2p_stat.t

  val fold :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    init:'a ->
    f:(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> 'a -> 'a) ->
    'a

  val list :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    (P2p_peer.Id.t * ('msg, 'peer_meta, 'conn_meta) connection) list

  val find_by_point :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    P2p_point.Id.t ->
    ('msg, 'peer_meta, 'conn_meta) connection option

  val find_by_peer_id :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    P2p_peer.Id.t ->
    ('msg, 'peer_meta, 'conn_meta) connection option

  (** [private_node conn] returns 'true' if the node associated to this
      connection is in private mode *)
  val private_node : ('msg, 'peer_meta, 'conn_meta) connection -> bool

  (** [trusted_node conn] returns 'true' if the node associated to this
      connection is trusted *)
  val trusted_node : ('msg, 'peer_meta, 'conn_meta) connection -> bool
end

(** [on_new_connection pool f] installs [f] as a hook for new connections in [pool].   *)
val on_new_connection :
  ('msg, 'peer_meta, 'conn_meta) pool ->
  (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
  unit

(** {1 I/O on connections} *)

(** [read conn] returns a message popped from [conn]'s app message
    queue, or fails with [Connection_closed]. *)
val read : ('msg, 'peer_meta, 'conn_meta) connection -> 'msg tzresult Lwt.t

(** [is_readable conn] returns when there is at least one message
    ready to be read. *)
val is_readable :
  ('msg, 'peer_meta, 'conn_meta) connection -> unit tzresult Lwt.t

(** [write conn msg] is [P2p_connection.write conn' msg] where [conn']
    is the internal [P2p_connection.t] inside [conn]. *)
val write :
  ('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> unit tzresult Lwt.t

(** [write_sync conn msg] is [P2p_connection.write_sync conn' msg]
    where [conn'] is the internal [P2p_connection.t] inside [conn]. *)
val write_sync :
  ('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> unit tzresult Lwt.t

(**/**)

val raw_write_sync :
  ('msg, 'peer_meta, 'conn_meta) connection -> Bytes.t -> unit tzresult Lwt.t

(**/**)

(** [write_now conn msg] is [P2p_connection.write_now conn' msg] where
    [conn'] is the internal [P2p_connection.t] inside [conn]. *)
val write_now :
  ('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> bool tzresult

(** {2 Broadcast functions} *)

(** [write_all pool msg] is [write_now conn msg] for all member
    connections to [pool] in [Running] state. *)
val write_all : ('msg, 'peer_meta, 'conn_meta) pool -> 'msg -> unit

(** [broadcast_bootstrap_msg pool] is [P2P_connection.write_now conn Bootstrap]
    for all member connections to [pool] in [Running] state.
    This behavior is deactivated if the node is in private mode  *)
val broadcast_bootstrap_msg : ('msg, 'peer_meta, 'conn_meta) pool -> unit

(** [greylist_addr pool addr] adds [addr] to [pool]'s IP greylist. *)
val greylist_addr : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_addr.t -> unit

(** [greylist_peer pool peer] adds [peer] to [pool]'s peer greylist
    and [peer]'s address to [pool]'s IP greylist. *)
val greylist_peer :
  ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> unit

(** [gc_greylist ~older_than pool] *)
val gc_greylist :
  older_than:Time.System.t -> ('msg, 'peer_meta, 'conn_meta) pool -> unit

(** [acl_clear pool] clears ACL tables. *)
val acl_clear : ('msg, 'peer_meta, 'conn_meta) pool -> unit

(** {1 Functions on [Peer_id]} *)

module Peers : sig
  type ('msg, 'peer_meta, 'conn_meta) info =
    ( ('msg, 'peer_meta, 'conn_meta) connection,
      'peer_meta,
      'conn_meta )
    P2p_peer_state.Info.t

  val info :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    P2p_peer.Id.t ->
    ('msg, 'peer_meta, 'conn_meta) info option

  val get_peer_metadata :
    ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> 'peer_meta

  val set_peer_metadata :
    ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> 'peer_meta -> unit

  val get_score : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> float

  val get_trusted :
    ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> bool

  val set_trusted :
    ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> unit

  val unset_trusted :
    ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> unit

  val fold_known :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    init:'a ->
    f:(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) info -> 'a -> 'a) ->
    'a

  val fold_connected :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    init:'a ->
    f:(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) info -> 'a -> 'a) ->
    'a

  val ban : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> unit

  val unban : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> unit

  val trust : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> unit

  val untrust : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> unit

  val banned : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_peer.Id.t -> bool
end

(** {1 Functions on [Points]} *)

module Points : sig
  type ('msg, 'peer_meta, 'conn_meta) info =
    ('msg, 'peer_meta, 'conn_meta) connection P2p_point_state.Info.t

  val info :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    P2p_point.Id.t ->
    ('msg, 'peer_meta, 'conn_meta) info option

  val get_trusted :
    ('msg, 'peer_meta, 'conn_meta) pool -> P2p_point.Id.t -> bool

  val set_trusted :
    ('msg, 'peer_meta, 'conn_meta) pool -> P2p_point.Id.t -> unit

  val unset_trusted :
    ('msg, 'peer_meta, 'conn_meta) pool -> P2p_point.Id.t -> unit

  val fold_known :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    init:'a ->
    f:(P2p_point.Id.t -> ('msg, 'peer_meta, 'conn_meta) info -> 'a -> 'a) ->
    'a

  val fold_connected :
    ('msg, 'peer_meta, 'conn_meta) pool ->
    init:'a ->
    f:(P2p_point.Id.t -> ('msg, 'peer_meta, 'conn_meta) info -> 'a -> 'a) ->
    'a

  val ban : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_point.Id.t -> unit

  val unban : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_point.Id.t -> unit

  val trust : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_point.Id.t -> unit

  val untrust : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_point.Id.t -> unit

  val banned : ('msg, 'peer_meta, 'conn_meta) pool -> P2p_point.Id.t -> bool
end

(** [watch pool] is a [stream, close] a [stream] of events and a
    [close] function for this stream. *)
val watch :
  ('msg, 'peer_meta, 'conn_meta) pool ->
  P2p_connection.Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
src/lib_p2p/p2p_pool.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (msg peer_meta conn_meta : Type), Type.

Definition pool (msg peer_meta conn_meta : Type) := t msg peer_meta conn_meta.

Record config := {
  identity : Tezos_base__TzPervasives.P2p_identity.t;
  proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target;
  trusted_points : list Tezos_base__TzPervasives.P2p_point.Id.t;
  peers_file : string;
  private_mode : bool;
  greylisting_config : Tezos_p2p.P2p_point_state.Info.greylisting_config;
  listening_port : option Tezos_base__TzPervasives.P2p_addr.port;
  min_connections : Z;
  max_connections : Z;
  max_incoming_connections : Z;
  connection_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  authentication_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  incoming_app_message_queue_size : option Z;
  incoming_message_queue_size : option Z;
  outgoing_message_queue_size : option Z;
  known_peer_ids_history_size : Z;
  known_points_history_size : Z;
  max_known_points : option (Z * Z);
  max_known_peer_ids : option (Z * Z);
  swap_linger : Tezos_base__TzPervasives.Time.System.Span.t;
  binary_chunks_size : option Z }.

Record peer_meta_config {peer_meta : Type} := {
  peer_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t peer_meta;
  peer_meta_initial : unit -> peer_meta;
  score : peer_meta -> float }.
Arguments peer_meta_config : clear implicits.

Record message_config {msg : Type} := {
  encoding : list (Tezos_p2p.P2p_message.encoding msg);
  chain_name : Tezos_base__TzPervasives.Distributed_db_version.name;
  distributed_db_versions :
    list Tezos_base__TzPervasives.Distributed_db_version.t }.
Arguments message_config : clear implicits.

Parameter create : forall {conn_meta msg peer_meta : Type},
(option (list Tezos_base__TzPervasives.P2p_version.t)) ->
  config ->
    (peer_meta_config peer_meta) ->
      (Tezos_p2p.P2p_socket.metadata_config conn_meta) ->
        (message_config msg) ->
          Tezos_p2p.P2p_io_scheduler.t -> Lwt.t (pool msg peer_meta conn_meta).

Parameter destroy : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> Lwt.t unit.

Parameter active_connections : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> Z.

Parameter pool_stat : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_stat.t.

Parameter config : forall {_ : Type}, (pool _ _ _) -> config.

Parameter send_swap_request : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> unit.

Parameter score : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> peer_meta -> float.

Module Pool_event.
  Parameter wait_too_few_connections : forall {conn_meta msg peer_meta : Type}, (pool
    msg peer_meta conn_meta) -> Lwt.t unit.
  
  Parameter wait_too_many_connections : forall {conn_meta msg peer_meta : Type}, (pool
    msg peer_meta conn_meta) -> Lwt.t unit.
  
  Parameter wait_new_peer : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Lwt.t unit.
  
  Parameter wait_new_point : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Lwt.t unit.
  
  Parameter wait_new_connection : forall {conn_meta msg peer_meta : Type}, (pool
    msg peer_meta conn_meta) -> Lwt.t unit.
End Pool_event.

Parameter connection : forall (msg peer_meta conn_meta : Type), Type.

Parameter connect : forall {conn_meta msg peer_meta : Type},
(option Tezos_base__TzPervasives.Time.System.Span.t) ->
  (pool msg peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult (connection msg peer_meta conn_meta)).

Parameter accept : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) ->
  Tezos_p2p.P2p_fd.t -> Tezos_base__TzPervasives.P2p_point.Id.t -> unit.

Parameter register_new_point : forall {a b c : Type},
(option bool) ->
  (pool a b c) ->
    Tezos_base__TzPervasives.P2p_peer.Table.key ->
      Tezos_base__TzPervasives.P2p_point.Id.t -> unit.

Parameter disconnect : forall {conn_meta msg peer_meta : Type},
(option bool) -> (connection msg peer_meta conn_meta) -> Lwt.t unit.

Module Connection.
  Parameter info : forall {conn_meta msg peer_meta : Type}, (connection msg
    peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_connection.Info.t conn_meta.
  
  Parameter local_metadata : forall {conn_meta msg peer_meta : Type}, (connection
    msg peer_meta conn_meta) -> conn_meta.
  
  Parameter remote_metadata : forall {conn_meta msg peer_meta : Type}, (connection
    msg peer_meta conn_meta) -> conn_meta.
  
  Parameter stat : forall {conn_meta msg peer_meta : Type}, (connection msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_stat.t.
  
  Parameter fold : forall {a conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) ->
    a ->
      (Tezos_base__TzPervasives.P2p_peer.Id.t ->
        (connection msg peer_meta conn_meta) -> a -> a) -> a.
  
  Parameter list : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) ->
    list
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        (connection msg peer_meta conn_meta)).
  
  Parameter find_by_point : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      option (connection msg peer_meta conn_meta).
  
  Parameter find_by_peer_id : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      option (connection msg peer_meta conn_meta).
  
  Parameter private_node : forall {conn_meta msg peer_meta : Type}, (connection
    msg peer_meta conn_meta) -> bool.
  
  Parameter trusted_node : forall {conn_meta msg peer_meta : Type}, (connection
    msg peer_meta conn_meta) -> bool.
End Connection.

Parameter on_new_connection : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) ->
  (Tezos_base__TzPervasives.P2p_peer.Id.t ->
    (connection msg peer_meta conn_meta) -> unit) -> unit.

Parameter read : forall {conn_meta msg peer_meta : Type},
(connection msg peer_meta conn_meta) ->
  Lwt.t (Tezos_base__TzPervasives.tzresult msg).

Parameter is_readable : forall {conn_meta msg peer_meta : Type},
(connection msg peer_meta conn_meta) ->
  Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter write : forall {conn_meta msg peer_meta : Type},
(connection msg peer_meta conn_meta) ->
  msg -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter write_sync : forall {conn_meta msg peer_meta : Type},
(connection msg peer_meta conn_meta) ->
  msg -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter raw_write_sync : forall {conn_meta msg peer_meta : Type},
(connection msg peer_meta conn_meta) ->
  Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter write_now : forall {conn_meta msg peer_meta : Type},
(connection msg peer_meta conn_meta) ->
  msg -> Tezos_base__TzPervasives.tzresult bool.

Parameter write_all : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> msg -> unit.

Parameter broadcast_bootstrap_msg : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> unit.

Parameter greylist_addr : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_addr.t -> unit.

Parameter greylist_peer : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.

Parameter gc_greylist : forall {conn_meta msg peer_meta : Type},
Tezos_base__TzPervasives.Time.System.t -> (pool msg peer_meta conn_meta) -> unit.

Parameter acl_clear : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) -> unit.

Module Peers.
  Definition info (msg peer_meta conn_meta : Type) :=
    Tezos_p2p.P2p_peer_state.Info.t (connection msg peer_meta conn_meta)
      peer_meta conn_meta.
  
  Parameter info : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      option (info msg peer_meta conn_meta).
  
  Parameter get_peer_metadata : forall {conn_meta msg peer_meta : Type}, (pool
    msg peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta.
  
  Parameter set_peer_metadata : forall {conn_meta msg peer_meta : Type}, (pool
    msg peer_meta conn_meta) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta -> unit.
  
  Parameter get_score : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> float.
  
  Parameter get_trusted : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> bool.
  
  Parameter set_trusted : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter unset_trusted : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter fold_known : forall {a conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) ->
    a ->
      (Tezos_base__TzPervasives.P2p_peer.Id.t ->
        (info msg peer_meta conn_meta) -> a -> a) -> a.
  
  Parameter fold_connected : forall {a conn_meta msg peer_meta : Type}, (pool
    msg peer_meta conn_meta) ->
    a ->
      (Tezos_base__TzPervasives.P2p_peer.Id.t ->
        (info msg peer_meta conn_meta) -> a -> a) -> a.
  
  Parameter ban : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter unban : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter trust : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter untrust : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> unit.
  
  Parameter banned : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> bool.
End Peers.

Module Points.
  Definition info (msg peer_meta conn_meta : Type) :=
    Tezos_p2p.P2p_point_state.Info.t (connection msg peer_meta conn_meta).
  
  Parameter info : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      option (info msg peer_meta conn_meta).
  
  Parameter get_trusted : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_point.Id.t -> bool.
  
  Parameter set_trusted : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_point.Id.t -> unit.
  
  Parameter unset_trusted : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_point.Id.t -> unit.
  
  Parameter fold_known : forall {a conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) ->
    a ->
      (Tezos_base__TzPervasives.P2p_point.Id.t ->
        (info msg peer_meta conn_meta) -> a -> a) -> a.
  
  Parameter fold_connected : forall {a conn_meta msg peer_meta : Type}, (pool
    msg peer_meta conn_meta) ->
    a ->
      (Tezos_base__TzPervasives.P2p_point.Id.t ->
        (info msg peer_meta conn_meta) -> a -> a) -> a.
  
  Parameter ban : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) -> Tezos_base__TzPervasives.P2p_point.Id.t -> unit.
  
  Parameter unban : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) -> Tezos_base__TzPervasives.P2p_point.Id.t -> unit.
  
  Parameter trust : forall {conn_meta msg peer_meta : Type}, (pool msg peer_meta
    conn_meta) -> Tezos_base__TzPervasives.P2p_point.Id.t -> unit.
  
  Parameter untrust : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_point.Id.t -> unit.
  
  Parameter banned : forall {conn_meta msg peer_meta : Type}, (pool msg
    peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_point.Id.t -> bool.
End Points.

Parameter watch : forall {conn_meta msg peer_meta : Type},
(pool msg peer_meta conn_meta) ->
  (Lwt_stream.t Tezos_base__TzPervasives.P2p_connection.Pool_event.t) *
    Tezos_stdlib.Lwt_watcher.stopper.
src/lib_p2p/p2p_socket.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* TODO test `close ~wait:true`. *)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.connection"
end)

module Crypto = struct
  (* maximal size of the buffer *)
  let bufsize = (1 lsl 16) - 1

  let header_length = 2

  let max_content_length = bufsize - Crypto_box.zerobytes

  (* The size of extra data added by encryption. *)
  let boxextrabytes = Crypto_box.zerobytes - Crypto_box.boxzerobytes

  (* The number of bytes added by encryption + header *)
  let extrabytes = header_length + boxextrabytes

  type data = {
    channel_key : Crypto_box.channel_key;
    mutable local_nonce : Crypto_box.nonce;
    mutable remote_nonce : Crypto_box.nonce;
  }

  (* We do the following assumptions on the NaCl library.  Note that
     we also make the assumption, here, that the NaCl library allows
     in-place boxing and unboxing, since we use the same buffer for
     input and output. *)
  let () = assert (Crypto_box.boxzerobytes >= header_length)

  let write_chunk ?canceler fd cryptobox_data msg =
    let msglen = Bytes.length msg in
    fail_unless (msglen <= max_content_length) P2p_errors.Invalid_message_size
    >>=? fun () ->
    let buf_length = msglen + Crypto_box.zerobytes in
    let buf = Bytes.make buf_length '\x00' in
    Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
    let local_nonce = cryptobox_data.local_nonce in
    cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
    Crypto_box.fast_box_noalloc cryptobox_data.channel_key local_nonce buf ;
    let encrypted_length = buf_length - Crypto_box.boxzerobytes in
    let header_pos = Crypto_box.boxzerobytes - header_length in
    TzEndian.set_int16 buf header_pos encrypted_length ;
    let payload = Bytes.sub buf header_pos (buf_length - header_pos) in
    P2p_io_scheduler.write ?canceler fd payload

  let read_chunk ?canceler fd cryptobox_data =
    let header_buf = Bytes.create header_length in
    P2p_io_scheduler.read_full ?canceler ~len:header_length fd header_buf
    >>=? fun () ->
    let encrypted_length = TzEndian.get_uint16 header_buf 0 in
    let buf_length = encrypted_length + Crypto_box.boxzerobytes in
    let buf = Bytes.make buf_length '\x00' in
    P2p_io_scheduler.read_full
      ?canceler
      ~pos:Crypto_box.boxzerobytes
      ~len:encrypted_length
      fd
      buf
    >>=? fun () ->
    let remote_nonce = cryptobox_data.remote_nonce in
    cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
    match
      Crypto_box.fast_box_open_noalloc
        cryptobox_data.channel_key
        remote_nonce
        buf
    with
    | false ->
        fail P2p_errors.Decipher_error
    | true ->
        return
          (Bytes.sub
             buf
             Crypto_box.zerobytes
             (buf_length - Crypto_box.zerobytes))
end

(* Note: there is an inconsistency here, since we display an error in
   bytes, whereas the option is set in kbytes. Also, since the default
   size is 64kB-1, it is actually impossible to set the default
   size using the option (the max is 63 kB). *)
let check_binary_chunks_size size =
  let value = size - Crypto.extrabytes in
  fail_unless
    (value > 0 && value <= Crypto.max_content_length)
    (P2p_errors.Invalid_chunks_size
       {value = size; min = Crypto.extrabytes + 1; max = Crypto.bufsize})

module Connection_message = struct
  type t = {
    port : int option;
    public_key : Crypto_box.public_key;
    proof_of_work_stamp : Crypto_box.nonce;
    message_nonce : Crypto_box.nonce;
    version : Network_version.t;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {port; public_key; proof_of_work_stamp; message_nonce; version} ->
        let port = match port with None -> 0 | Some port -> port in
        (port, public_key, proof_of_work_stamp, message_nonce, version))
      (fun (port, public_key, proof_of_work_stamp, message_nonce, version) ->
        let port = if port = 0 then None else Some port in
        {port; public_key; proof_of_work_stamp; message_nonce; version})
      (obj5
         (req "port" uint16)
         (req "pubkey" Crypto_box.public_key_encoding)
         (req "proof_of_work_stamp" Crypto_box.nonce_encoding)
         (req "message_nonce" Crypto_box.nonce_encoding)
         (req "version" Network_version.encoding))

  let write ~canceler fd message =
    let encoded_message_len = Data_encoding.Binary.length encoding message in
    fail_unless
      (encoded_message_len < 1 lsl (Crypto.header_length * 8))
      P2p_errors.Encoding_error
    >>=? fun () ->
    let len = Crypto.header_length + encoded_message_len in
    let buf = Bytes.create len in
    match
      Data_encoding.Binary.write encoding message buf Crypto.header_length len
    with
    | None ->
        fail P2p_errors.Encoding_error
    | Some last ->
        fail_unless (last = len) P2p_errors.Encoding_error
        >>=? fun () ->
        TzEndian.set_int16 buf 0 encoded_message_len ;
        P2p_io_scheduler.write ~canceler fd buf
        >>=? fun () ->
        (* We return the raw message as it is used later to compute
           the nonces *)
        return buf

  let read ~canceler fd =
    let header_buf = Bytes.create Crypto.header_length in
    P2p_io_scheduler.read_full
      ~canceler
      ~len:Crypto.header_length
      fd
      header_buf
    >>=? fun () ->
    let len = TzEndian.get_uint16 header_buf 0 in
    let pos = Crypto.header_length in
    let buf = Bytes.create (pos + len) in
    TzEndian.set_int16 buf 0 len ;
    P2p_io_scheduler.read_full ~canceler ~len ~pos fd buf
    >>=? fun () ->
    match Data_encoding.Binary.read encoding buf pos len with
    | None ->
        fail P2p_errors.Decoding_error
    | Some (next_pos, message) ->
        if next_pos <> pos + len then fail P2p_errors.Decoding_error
        else return (message, buf)
end

type 'meta metadata_config = {
  conn_meta_encoding : 'meta Data_encoding.t;
  conn_meta_value : P2p_peer.Id.t -> 'meta;
  private_node : 'meta -> bool;
}

module Metadata = struct
  let write ~canceler metadata_config cryptobox_data fd message =
    let encoded_message_len =
      Data_encoding.Binary.length metadata_config.conn_meta_encoding message
    in
    let buf = Bytes.create encoded_message_len in
    match
      Data_encoding.Binary.write
        metadata_config.conn_meta_encoding
        message
        buf
        0
        encoded_message_len
    with
    | None ->
        fail P2p_errors.Encoding_error
    | Some last ->
        fail_unless (last = encoded_message_len) P2p_errors.Encoding_error
        >>=? fun () -> Crypto.write_chunk ~canceler cryptobox_data fd buf

  let read ~canceler metadata_config fd cryptobox_data =
    Crypto.read_chunk ~canceler fd cryptobox_data
    >>=? fun buf ->
    let length = Bytes.length buf in
    let encoding = metadata_config.conn_meta_encoding in
    match Data_encoding.Binary.read encoding buf 0 length with
    | None ->
        fail P2p_errors.Decoding_error
    | Some (read_len, message) ->
        if read_len <> length then fail P2p_errors.Decoding_error
        else return message
end

module Ack = struct
  type t = Ack | Nack

  let encoding =
    let open Data_encoding in
    let ack_encoding = obj1 (req "ack" empty) in
    let nack_encoding = obj1 (req "nack" empty) in
    let ack_case tag =
      case
        tag
        ack_encoding
        ~title:"Ack"
        (function Ack -> Some () | _ -> None)
        (fun () -> Ack)
    in
    let nack_case tag =
      case
        tag
        nack_encoding
        ~title:"Nack"
        (function Nack -> Some () | _ -> None)
        (fun _ -> Nack)
    in
    union [ack_case (Tag 0); nack_case (Tag 255)]

  let write ?canceler fd cryptobox_data message =
    let encoded_message_len = Data_encoding.Binary.length encoding message in
    let buf = Bytes.create encoded_message_len in
    match
      Data_encoding.Binary.write encoding message buf 0 encoded_message_len
    with
    | None ->
        fail P2p_errors.Encoding_error
    | Some last ->
        fail_unless (last = encoded_message_len) P2p_errors.Encoding_error
        >>=? fun () -> Crypto.write_chunk ?canceler fd cryptobox_data buf

  let read ?canceler fd cryptobox_data =
    Crypto.read_chunk ?canceler fd cryptobox_data
    >>=? fun buf ->
    let length = Bytes.length buf in
    match Data_encoding.Binary.read encoding buf 0 length with
    | None ->
        fail P2p_errors.Decoding_error
    | Some (read_len, message) ->
        if read_len <> length then fail P2p_errors.Decoding_error
        else return message
end

type 'meta authenticated_connection = {
  fd : P2p_io_scheduler.connection;
  info : 'meta P2p_connection.Info.t;
  cryptobox_data : Crypto.data;
}

let kick {fd; cryptobox_data; _} =
  Ack.write fd cryptobox_data Nack
  >>= fun _ -> P2p_io_scheduler.close fd >>= fun _ -> Lwt.return_unit

(* First step: write and read credentials, makes no difference
   whether we're trying to connect to a peer or checking an incoming
   connection, both parties must first introduce themselves. *)
let authenticate ~canceler ~proof_of_work_target ~incoming fd
    ((remote_addr, remote_socket_port) as point) ?listening_port identity
    announced_version metadata_config =
  let local_nonce_seed = Crypto_box.random_nonce () in
  lwt_debug "Sending authenfication to %a" P2p_point.Id.pp point
  >>= fun () ->
  Connection_message.write
    ~canceler
    fd
    {
      public_key = identity.P2p_identity.public_key;
      proof_of_work_stamp = identity.proof_of_work_stamp;
      message_nonce = local_nonce_seed;
      port = listening_port;
      version = announced_version;
    }
  >>=? fun sent_msg ->
  Connection_message.read ~canceler fd
  >>=? fun (msg, recv_msg) ->
  let remote_listening_port =
    if incoming then msg.port else Some remote_socket_port
  in
  let id_point = (remote_addr, remote_listening_port) in
  let remote_peer_id = Crypto_box.hash msg.public_key in
  fail_unless
    (remote_peer_id <> identity.P2p_identity.peer_id)
    (P2p_errors.Myself id_point)
  >>=? fun () ->
  fail_unless
    (Crypto_box.check_proof_of_work
       msg.public_key
       msg.proof_of_work_stamp
       proof_of_work_target)
    (P2p_errors.Not_enough_proof_of_work remote_peer_id)
  >>=? fun () ->
  let channel_key =
    Crypto_box.precompute identity.P2p_identity.secret_key msg.public_key
  in
  let (local_nonce, remote_nonce) =
    Crypto_box.generate_nonces ~incoming ~sent_msg ~recv_msg
  in
  let cryptobox_data = {Crypto.channel_key; local_nonce; remote_nonce} in
  let local_metadata = metadata_config.conn_meta_value remote_peer_id in
  Metadata.write ~canceler metadata_config fd cryptobox_data local_metadata
  >>=? fun () ->
  Metadata.read ~canceler metadata_config fd cryptobox_data
  >>=? fun remote_metadata ->
  let info =
    {
      P2p_connection.Info.peer_id = remote_peer_id;
      announced_version = msg.version;
      incoming;
      id_point;
      remote_socket_port;
      private_node = metadata_config.private_node remote_metadata;
      local_metadata;
      remote_metadata;
    }
  in
  return (info, {fd; info; cryptobox_data})

module Reader = struct
  type ('msg, 'meta) t = {
    canceler : Lwt_canceler.t;
    conn : 'meta authenticated_connection;
    encoding : 'msg Data_encoding.t;
    messages : (int * 'msg) tzresult Lwt_pipe.t;
    mutable worker : unit Lwt.t;
  }

  let read_message st init =
    let rec loop status =
      Lwt_unix.yield ()
      >>= fun () ->
      let open Data_encoding.Binary in
      match status with
      | Success {result; size; stream} ->
          return_some (result, size, stream)
      | Error _err ->
          lwt_debug "[read_message] incremental decoding error"
          >>= fun () -> return_none
      | Await decode_next_buf ->
          Crypto.read_chunk
            ~canceler:st.canceler
            st.conn.fd
            st.conn.cryptobox_data
          >>=? fun buf ->
          lwt_debug
            "reading %d bytes from %a"
            (Bytes.length buf)
            P2p_peer.Id.pp
            st.conn.info.peer_id
          >>= fun () -> loop (decode_next_buf buf)
    in
    loop (Data_encoding.Binary.read_stream ?init st.encoding)

  let rec worker_loop st stream =
    read_message st stream
    >>=? (fun msg ->
           match msg with
           | None ->
               protect ~canceler:st.canceler (fun () ->
                   Lwt_pipe.push st.messages (error P2p_errors.Decoding_error)
                   >>= fun () -> return_none)
           | Some (msg, size, stream) ->
               protect ~canceler:st.canceler (fun () ->
                   Lwt_pipe.push st.messages (Ok (size, msg))
                   >>= fun () -> return_some stream))
    >>= function
    | Ok (Some stream) ->
        worker_loop st (Some stream)
    | Ok None ->
        Lwt_canceler.cancel st.canceler
    | Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
        lwt_debug "connection closed to %a" P2p_peer.Id.pp st.conn.info.peer_id
    | Error _ as err ->
        Lwt_pipe.safe_push_now st.messages err ;
        Lwt_canceler.cancel st.canceler

  let run ?size conn encoding canceler =
    let compute_size = function
      | Ok (size, _) ->
          (Sys.word_size / 8 * 11) + size + Lwt_pipe.push_overhead
      | Error _ ->
          0
      (* we push Error only when we close the socket,
                        we don't fear memory leaks in that case... *)
    in
    let size = Option.map size ~f:(fun max -> (max, compute_size)) in
    let st =
      {
        canceler;
        conn;
        encoding;
        messages = Lwt_pipe.create ?size ();
        worker = Lwt.return_unit;
      }
    in
    Lwt_canceler.on_cancel st.canceler (fun () ->
        Lwt_pipe.close st.messages ; Lwt.return_unit) ;
    st.worker <-
      Lwt_utils.worker
        "reader"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop st None)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
    st

  let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
end

module Writer = struct
  type ('msg, 'meta) t = {
    canceler : Lwt_canceler.t;
    conn : 'meta authenticated_connection;
    encoding : 'msg Data_encoding.t;
    messages : (Bytes.t list * unit tzresult Lwt.u option) Lwt_pipe.t;
    mutable worker : unit Lwt.t;
    binary_chunks_size : int; (* in bytes *)
  }

  let send_message st buf =
    let rec loop = function
      | [] ->
          return_unit
      | buf :: l ->
          Crypto.write_chunk
            ~canceler:st.canceler
            st.conn.fd
            st.conn.cryptobox_data
            buf
          >>=? fun () ->
          lwt_debug
            "writing %d bytes to %a"
            (Bytes.length buf)
            P2p_peer.Id.pp
            st.conn.info.peer_id
          >>= fun () -> loop l
    in
    loop buf

  let encode_message st msg =
    try
      ok
        (Utils.cut
           st.binary_chunks_size
           (Data_encoding.Binary.to_bytes_exn st.encoding msg))
    with Data_encoding.Binary.Write_error _ ->
      error P2p_errors.Encoding_error

  let rec worker_loop st =
    Lwt_unix.yield ()
    >>= fun () ->
    protect ~canceler:st.canceler (fun () ->
        Lwt_pipe.pop st.messages >>= return)
    >>= function
    | Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
        lwt_debug "connection closed to %a" P2p_peer.Id.pp st.conn.info.peer_id
    | Error err ->
        lwt_log_error
          "@[<v 2>error writing to %a@ %a@]"
          P2p_peer.Id.pp
          st.conn.info.peer_id
          pp_print_error
          err
        >>= fun () -> Lwt_canceler.cancel st.canceler
    | Ok (buf, wakener) -> (
        send_message st buf
        >>= fun res ->
        match res with
        | Ok () ->
            Option.iter wakener ~f:(fun u -> Lwt.wakeup_later u res) ;
            worker_loop st
        | Error err -> (
            Option.iter wakener ~f:(fun u ->
                Lwt.wakeup_later u (error P2p_errors.Connection_closed)) ;
            match err with
            | (Canceled | Exn Lwt_pipe.Closed) :: _ ->
                lwt_debug
                  "connection closed to %a"
                  P2p_peer.Id.pp
                  st.conn.info.peer_id
            | P2p_errors.Connection_closed :: _ ->
                lwt_debug
                  "connection closed to %a"
                  P2p_peer.Id.pp
                  st.conn.info.peer_id
                >>= fun () -> Lwt_canceler.cancel st.canceler
            | err ->
                lwt_log_error
                  "@[<v 2>error writing to %a@ %a@]"
                  P2p_peer.Id.pp
                  st.conn.info.peer_id
                  pp_print_error
                  err
                >>= fun () -> Lwt_canceler.cancel st.canceler ) )

  let run ?size ?binary_chunks_size conn encoding canceler =
    let binary_chunks_size =
      match binary_chunks_size with
      | None ->
          Crypto.max_content_length
      | Some size ->
          let size = size - Crypto.extrabytes in
          assert (size > 0) ;
          assert (size <= Crypto.max_content_length) ;
          size
    in
    let compute_size =
      let buf_list_size =
        List.fold_left
          (fun sz buf -> sz + Bytes.length buf + (2 * Sys.word_size))
          0
      in
      function
      | (buf_l, None) ->
          Sys.word_size + buf_list_size buf_l + Lwt_pipe.push_overhead
      | (buf_l, Some _) ->
          (2 * Sys.word_size) + buf_list_size buf_l + Lwt_pipe.push_overhead
    in
    let size = Option.map size ~f:(fun max -> (max, compute_size)) in
    let st =
      {
        canceler;
        conn;
        encoding;
        messages = Lwt_pipe.create ?size ();
        worker = Lwt.return_unit;
        binary_chunks_size;
      }
    in
    Lwt_canceler.on_cancel st.canceler (fun () ->
        Lwt_pipe.close st.messages ;
        while not (Lwt_pipe.is_empty st.messages) do
          let (_, w) = Lwt_pipe.pop_now_exn st.messages in
          Option.iter w ~f:(fun u ->
              Lwt.wakeup_later u (error (Exn Lwt_pipe.Closed)))
        done ;
        Lwt.return_unit) ;
    st.worker <-
      Lwt_utils.worker
        "writer"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop st)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
    st

  let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
end

type ('msg, 'meta) t = {
  conn : 'meta authenticated_connection;
  reader : ('msg, 'meta) Reader.t;
  writer : ('msg, 'meta) Writer.t;
}

let equal {conn = {fd = fd2; _}; _} {conn = {fd = fd1; _}; _} =
  P2p_io_scheduler.id fd1 = P2p_io_scheduler.id fd2

let pp ppf {conn; _} = P2p_connection.Info.pp (fun _ _ -> ()) ppf conn.info

let info {conn; _} = conn.info

let local_metadata {conn; _} = conn.info.local_metadata

let remote_metadata {conn; _} = conn.info.remote_metadata

let private_node {conn; _} = conn.info.private_node

let accept ?incoming_message_queue_size ?outgoing_message_queue_size
    ?binary_chunks_size ~canceler conn encoding =
  protect
    (fun () ->
      Ack.write ~canceler conn.fd conn.cryptobox_data Ack
      >>=? fun () -> Ack.read ~canceler conn.fd conn.cryptobox_data)
    ~on_error:(fun err ->
      P2p_io_scheduler.close conn.fd
      >>= fun _ ->
      match err with
      | [P2p_errors.Connection_closed] ->
          fail P2p_errors.Rejected_socket_connection
      | [P2p_errors.Decipher_error] ->
          fail P2p_errors.Invalid_auth
      | err ->
          Lwt.return_error err)
  >>=? function
  | Ack ->
      let canceler = Lwt_canceler.create () in
      let reader =
        Reader.run ?size:incoming_message_queue_size conn encoding canceler
      and writer =
        Writer.run
          ?size:outgoing_message_queue_size
          ?binary_chunks_size
          conn
          encoding
          canceler
      in
      let conn = {conn; reader; writer} in
      Lwt_canceler.on_cancel canceler (fun () ->
          P2p_io_scheduler.close conn.conn.fd >>= fun _ -> Lwt.return_unit) ;
      return conn
  | Nack ->
      fail P2p_errors.Rejected_socket_connection

let catch_closed_pipe f =
  Lwt.catch f (function
      | Lwt_pipe.Closed ->
          fail P2p_errors.Connection_closed
      | exn ->
          fail (Exn exn))
  >>= function
  | Error (Exn Lwt_pipe.Closed :: _) ->
      fail P2p_errors.Connection_closed
  | (Error _ | Ok _) as v ->
      Lwt.return v

let pp_json encoding ppf msg =
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding msg)

let write {writer; conn; _} msg =
  catch_closed_pipe (fun () ->
      debug
        "Sending message to %a: %a"
        P2p_peer.Id.pp_short
        conn.info.peer_id
        (pp_json writer.encoding)
        msg ;
      Lwt.return (Writer.encode_message writer msg)
      >>=? fun buf ->
      Lwt_pipe.push writer.messages (buf, None) >>= fun () -> return_unit)

let write_sync {writer; conn; _} msg =
  catch_closed_pipe (fun () ->
      let (waiter, wakener) = Lwt.wait () in
      debug
        "Sending message to %a: %a"
        P2p_peer.Id.pp_short
        conn.info.peer_id
        (pp_json writer.encoding)
        msg ;
      Lwt.return (Writer.encode_message writer msg)
      >>=? fun buf ->
      Lwt_pipe.push writer.messages (buf, Some wakener) >>= fun () -> waiter)

let write_now {writer; conn; _} msg =
  debug
    "Try sending message to %a: %a"
    P2p_peer.Id.pp_short
    conn.info.peer_id
    (pp_json writer.encoding)
    msg ;
  Writer.encode_message writer msg
  >>? fun buf ->
  try Ok (Lwt_pipe.push_now writer.messages (buf, None))
  with Lwt_pipe.Closed -> error P2p_errors.Connection_closed

let rec split_bytes size bytes =
  if Bytes.length bytes <= size then [bytes]
  else
    Bytes.sub bytes 0 size
    :: split_bytes size (Bytes.sub bytes size (Bytes.length bytes - size))

let raw_write_sync {writer; _} bytes =
  let bytes = split_bytes writer.binary_chunks_size bytes in
  catch_closed_pipe (fun () ->
      let (waiter, wakener) = Lwt.wait () in
      Lwt_pipe.push writer.messages (bytes, Some wakener) >>= fun () -> waiter)

let is_readable {reader; _} = not (Lwt_pipe.is_empty reader.messages)

let wait_readable {reader; _} =
  catch_closed_pipe (fun () ->
      Lwt_pipe.values_available reader.messages >>= fun () -> return_unit)

let read {reader; _} =
  catch_closed_pipe (fun () -> Lwt_pipe.pop reader.messages)

let read_now {reader; _} =
  try Lwt_pipe.pop_now reader.messages
  with Lwt_pipe.Closed -> Some (error P2p_errors.Connection_closed)

let stat {conn = {fd; _}; _} = P2p_io_scheduler.stat fd

let close ?(wait = false) st =
  ( if not wait then Lwt.return_unit
  else (
    Lwt_pipe.close st.reader.messages ;
    Lwt_pipe.close st.writer.messages ;
    st.writer.worker ) )
  >>= fun () ->
  Reader.shutdown st.reader
  >>= fun () ->
  Writer.shutdown st.writer
  >>= fun () -> P2p_io_scheduler.close st.conn.fd >>= fun _ -> Lwt.return_unit
src/lib_p2p/p2p_socket.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Crypto.
  Definition bufsize : Z := Z.sub (Z.shiftl 1 16) 1.
  
  Definition header_length : Z := 2.
  
  Definition max_content_length : Z :=
    Z.sub bufsize Tezos_base__TzPervasives.Crypto_box.zerobytes.
  
  Definition boxextrabytes : Z :=
    Z.sub Tezos_base__TzPervasives.Crypto_box.zerobytes
      Tezos_base__TzPervasives.Crypto_box.boxzerobytes.
  
  Definition extrabytes : Z := Z.add header_length boxextrabytes.
  
  Record data := {
    channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key;
    local_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
    remote_nonce : Tezos_base__TzPervasives.Crypto_box.nonce }.
  
  Definition write_chunk
    (canceler : option Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : data)
    (msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let msglen := String.length msg in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.fail_unless
        (OCaml.Stdlib.le msglen max_content_length)
        P2p_errors.Invalid_message_size)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let buf_length :=
            Z.add msglen Tezos_base__TzPervasives.Crypto_box.zerobytes in
          let buf := Stdlib.Bytes.make buf_length "000" % char in
          Stdlib.Bytes.blit msg 0 buf
            Tezos_base__TzPervasives.Crypto_box.zerobytes msglen;
          let local_nonce := local_nonce cryptobox_data in
          set_field;
          Tezos_base__TzPervasives.Crypto_box.fast_box_noalloc
            (channel_key cryptobox_data) local_nonce buf;
          let encrypted_length :=
            Z.sub buf_length Tezos_base__TzPervasives.Crypto_box.boxzerobytes in
          let header_pos :=
            Z.sub Tezos_base__TzPervasives.Crypto_box.boxzerobytes header_length
            in
          Tezos_stdlib.TzEndian.set_int16 buf header_pos encrypted_length;
          let payload := String.sub buf header_pos (Z.sub buf_length header_pos)
            in
          Tezos_p2p.P2p_io_scheduler.write canceler fd payload
        end).
  
  Definition read_chunk
    (canceler : option Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    let header_buf := Stdlib.Bytes.create header_length in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_p2p.P2p_io_scheduler.read_full canceler fd None
        (Some header_length) header_buf)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let encrypted_length := Tezos_stdlib.TzEndian.get_uint16 header_buf 0
            in
          let buf_length :=
            Z.add encrypted_length
              Tezos_base__TzPervasives.Crypto_box.boxzerobytes in
          let buf := Stdlib.Bytes.make buf_length "000" % char in
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_io_scheduler.read_full canceler fd
              (Some Tezos_base__TzPervasives.Crypto_box.boxzerobytes)
              (Some encrypted_length) buf)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let remote_nonce := remote_nonce cryptobox_data in
                set_field;
                match
                  Tezos_base__TzPervasives.Crypto_box.fast_box_open_noalloc
                    (channel_key cryptobox_data) remote_nonce buf with
                | false =>
                  Tezos_base__TzPervasives.fail P2p_errors.Decipher_error
                | true =>
                  Tezos_base__TzPervasives._return
                    (String.sub buf
                      Tezos_base__TzPervasives.Crypto_box.zerobytes
                      (Z.sub buf_length
                        Tezos_base__TzPervasives.Crypto_box.zerobytes))
                end
              end)
        end).
End Crypto.

Definition check_binary_chunks_size (size : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let value := Z.sub size Crypto.extrabytes in
  Tezos_base__TzPervasives.fail_unless
    (andb (OCaml.Stdlib.gt value 0)
      (OCaml.Stdlib.le value Crypto.max_content_length))
    (P2p_errors.Invalid_chunks_size
      {| value := size; min := Z.add Crypto.extrabytes 1; max := Crypto.bufsize
        |}).

Module Connection_message.
  Record t := {
    port : option Z;
    public_key : Tezos_base__TzPervasives.Crypto_box.public_key;
    proof_of_work_stamp : Tezos_base__TzPervasives.Crypto_box.nonce;
    message_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
    version : Tezos_base__TzPervasives.Network_version.t }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          port := port;
            public_key := public_key;
            proof_of_work_stamp := proof_of_work_stamp;
            message_nonce := message_nonce;
            version := version
            |} =>
          let port :=
            match port with
            | None => 0
            | Some port => port
            end in
          (port, public_key, proof_of_work_stamp, message_nonce, version)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (port, public_key, proof_of_work_stamp, message_nonce, version) =>
          let port :=
            if equiv_decb port 0 then
              None
            else
              Some port in
          {| port := port; public_key := public_key;
            proof_of_work_stamp := proof_of_work_stamp;
            message_nonce := message_nonce; version := version |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj5
        (Tezos_base__TzPervasives.Data_encoding.req None None "port" % string
          Tezos_base__TzPervasives.Data_encoding.uint16)
        (Tezos_base__TzPervasives.Data_encoding.req None None "pubkey" % string
          Tezos_base__TzPervasives.Crypto_box.public_key_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "proof_of_work_stamp" % string
          Tezos_base__TzPervasives.Crypto_box.nonce_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "message_nonce" % string
          Tezos_base__TzPervasives.Crypto_box.nonce_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "version" % string
          Tezos_base__TzPervasives.Network_version.encoding)).
  
  Definition write
    (canceler : Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (message : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    let encoded_message_len :=
      Tezos_base__TzPervasives.Data_encoding.Binary.length encoding message in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.fail_unless
        (OCaml.Stdlib.lt encoded_message_len
          (Z.shiftl 1 (Z.mul Crypto.header_length 8))) P2p_errors.Encoding_error)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let len := Z.add Crypto.header_length encoded_message_len in
          let buf := Stdlib.Bytes.create len in
          match
            Tezos_base__TzPervasives.Data_encoding.Binary.write encoding message
              buf Crypto.header_length len with
          | None => Tezos_base__TzPervasives.fail P2p_errors.Encoding_error
          | Some last =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.fail_unless (equiv_decb last len)
                P2p_errors.Encoding_error)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_stdlib.TzEndian.set_int16 buf 0 encoded_message_len;
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_p2p.P2p_io_scheduler.write (Some canceler) fd buf)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives._return buf
                      end)
                end)
          end
        end).
  
  Definition read
    (canceler : Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (t * string)) :=
    let header_buf := Stdlib.Bytes.create Crypto.header_length in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_p2p.P2p_io_scheduler.read_full (Some canceler) fd None
        (Some Crypto.header_length) header_buf)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let len := Tezos_stdlib.TzEndian.get_uint16 header_buf 0 in
          let pos := Crypto.header_length in
          let buf := Stdlib.Bytes.create (Z.add pos len) in
          Tezos_stdlib.TzEndian.set_int16 buf 0 len;
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_io_scheduler.read_full (Some canceler) fd (Some pos)
              (Some len) buf)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                match
                  Tezos_base__TzPervasives.Data_encoding.Binary.read encoding
                    buf pos len with
                | None =>
                  Tezos_base__TzPervasives.fail P2p_errors.Decoding_error
                | Some (next_pos, message) =>
                  if nequiv_decb next_pos (Z.add pos len) then
                    Tezos_base__TzPervasives.fail P2p_errors.Decoding_error
                  else
                    Tezos_base__TzPervasives._return (message, buf)
                end
              end)
        end).
End Connection_message.

Record metadata_config {meta : Type} := {
  conn_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t meta;
  conn_meta_value : Tezos_base__TzPervasives.P2p_peer.Id.t -> meta;
  private_node : meta -> bool }.
Arguments metadata_config : clear implicits.

Module Metadata.
  Definition write {A : Type}
    (canceler : Tezos_stdlib.Lwt_canceler.t)
    (metadata_config : metadata_config A)
    (cryptobox_data : Tezos_p2p.P2p_io_scheduler.connection) (fd : Crypto.data)
    (message : A) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let encoded_message_len :=
      Tezos_base__TzPervasives.Data_encoding.Binary.length
        (conn_meta_encoding metadata_config) message in
    let buf := Stdlib.Bytes.create encoded_message_len in
    match
      Tezos_base__TzPervasives.Data_encoding.Binary.write
        (conn_meta_encoding metadata_config) message buf 0 encoded_message_len
      with
    | None => Tezos_base__TzPervasives.fail P2p_errors.Encoding_error
    | Some last =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_base__TzPervasives.fail_unless
          (equiv_decb last encoded_message_len) P2p_errors.Encoding_error)
        (fun function_parameter =>
          match function_parameter with
          | tt => Crypto.write_chunk (Some canceler) cryptobox_data fd buf
          end)
    end.
  
  Definition read {A : Type}
    (canceler : Tezos_stdlib.Lwt_canceler.t)
    (metadata_config : metadata_config A)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Crypto.read_chunk (Some canceler) fd cryptobox_data)
      (fun buf =>
        let length := String.length buf in
        let encoding := conn_meta_encoding metadata_config in
        match
          Tezos_base__TzPervasives.Data_encoding.Binary.read encoding buf 0
            length with
        | None => Tezos_base__TzPervasives.fail P2p_errors.Decoding_error
        | Some (read_len, message) =>
          if nequiv_decb read_len length then
            Tezos_base__TzPervasives.fail P2p_errors.Decoding_error
          else
            Tezos_base__TzPervasives._return message
        end).
End Metadata.

Module Ack.
  Inductive t : Type :=
  | Ack : t
  | Nack : t.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    let ack_encoding :=
      Tezos_base__TzPervasives.Data_encoding.obj1
        (Tezos_base__TzPervasives.Data_encoding.req None None "ack" % string
          Tezos_base__TzPervasives.Data_encoding.empty) in
    let nack_encoding :=
      Tezos_base__TzPervasives.Data_encoding.obj1
        (Tezos_base__TzPervasives.Data_encoding.req None None "nack" % string
          Tezos_base__TzPervasives.Data_encoding.empty) in
    let ack_case (tag : Tezos_base__TzPervasives.Data_encoding.case_tag)
      : Tezos_base__TzPervasives.Data_encoding.case t :=
      Tezos_base__TzPervasives.Data_encoding.case "Ack" % string None tag
        ack_encoding
        (fun function_parameter =>
          match function_parameter with
          | Ack => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | tt => Ack
          end) in
    let nack_case (tag : Tezos_base__TzPervasives.Data_encoding.case_tag)
      : Tezos_base__TzPervasives.Data_encoding.case t :=
      Tezos_base__TzPervasives.Data_encoding.case "Nack" % string None tag
        nack_encoding
        (fun function_parameter =>
          match function_parameter with
          | Nack => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | _ => Nack
          end) in
    Tezos_base__TzPervasives.Data_encoding.union None
      (cons (ack_case (Tag 0)) (cons (nack_case (Tag 255)) [])).
  
  Definition write
    (canceler : option Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
    (message : t) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let encoded_message_len :=
      Tezos_base__TzPervasives.Data_encoding.Binary.length encoding message in
    let buf := Stdlib.Bytes.create encoded_message_len in
    match
      Tezos_base__TzPervasives.Data_encoding.Binary.write encoding message buf 0
        encoded_message_len with
    | None => Tezos_base__TzPervasives.fail P2p_errors.Encoding_error
    | Some last =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_base__TzPervasives.fail_unless
          (equiv_decb last encoded_message_len) P2p_errors.Encoding_error)
        (fun function_parameter =>
          match function_parameter with
          | tt => Crypto.write_chunk canceler fd cryptobox_data buf
          end)
    end.
  
  Definition read
    (canceler : option Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Crypto.read_chunk canceler fd cryptobox_data)
      (fun buf =>
        let length := String.length buf in
        match
          Tezos_base__TzPervasives.Data_encoding.Binary.read encoding buf 0
            length with
        | None => Tezos_base__TzPervasives.fail P2p_errors.Decoding_error
        | Some (read_len, message) =>
          if nequiv_decb read_len length then
            Tezos_base__TzPervasives.fail P2p_errors.Decoding_error
          else
            Tezos_base__TzPervasives._return message
        end).
End Ack.

Record authenticated_connection {meta : Type} := {
  fd : Tezos_p2p.P2p_io_scheduler.connection;
  info : Tezos_base__TzPervasives.P2p_connection.Info.t meta;
  cryptobox_data : Crypto.data }.
Arguments authenticated_connection : clear implicits.

Definition kick {A : Type} (function_parameter : authenticated_connection A)
  : Lwt.t unit :=
  match function_parameter with
  | {| fd := fd; cryptobox_data := cryptobox_data |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq (Ack.write None fd cryptobox_data Nack)
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_p2p.P2p_io_scheduler.close None fd)
            (fun function_parameter =>
              match function_parameter with
              | _ => Lwt.return_unit
              end)
        end)
  end.

Definition authenticate {A : Type}
  (canceler : Tezos_stdlib.Lwt_canceler.t)
  (proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target)
  (incoming : bool) (fd : Tezos_p2p.P2p_io_scheduler.connection)
  (function_parameter : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
  : (option Z) ->
    Tezos_base__TzPervasives.P2p_identity.t ->
      Tezos_base__TzPervasives.Network_version.t ->
        (metadata_config A) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              ((Tezos_base__TzPervasives.P2p_connection.Info.t A) *
                (authenticated_connection A))) :=
  match function_parameter with
  | (remote_addr, remote_socket_port) as point =>
    fun listening_port =>
      fun identity =>
        fun announced_version =>
          fun metadata_config =>
            let local_nonce_seed :=
              Tezos_base__TzPervasives.Crypto_box.random_nonce tt in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_debug
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Sending authenfication to " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "Sending authenfication to %a" % string)
                Tezos_base__TzPervasives.P2p_point.Id.pp point)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Connection_message.write canceler fd
                      {| port := listening_port;
                        public_key := P2p_identity.public_key identity;
                        proof_of_work_stamp := proof_of_work_stamp identity;
                        message_nonce := local_nonce_seed;
                        version := announced_version |})
                    (fun sent_msg =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Connection_message.read canceler fd)
                        (fun function_parameter =>
                          match function_parameter with
                          | (msg, recv_msg) =>
                            let remote_listening_port :=
                              if incoming then
                                port msg
                              else
                                Some remote_socket_port in
                            let id_point := (remote_addr, remote_listening_port)
                              in
                            let remote_peer_id :=
                              Tezos_base__TzPervasives.Crypto_box.hash
                                (public_key msg) in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_base__TzPervasives.fail_unless
                                (nequiv_decb remote_peer_id
                                  (P2p_identity.peer_id identity))
                                (P2p_errors.Myself id_point))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_base__TzPervasives.fail_unless
                                      (Tezos_base__TzPervasives.Crypto_box.check_proof_of_work
                                        (public_key msg)
                                        (proof_of_work_stamp msg)
                                        proof_of_work_target)
                                      (P2p_errors.Not_enough_proof_of_work
                                        remote_peer_id))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        let channel_key :=
                                          Tezos_base__TzPervasives.Crypto_box.precompute
                                            (P2p_identity.secret_key identity)
                                            (public_key msg) in
                                        match
                                          Tezos_base__TzPervasives.Crypto_box.generate_nonces
                                            incoming sent_msg recv_msg with
                                        | (local_nonce, remote_nonce) =>
                                          let cryptobox_data :=
                                            {|
                                              Crypto.channel_key := channel_key;
                                              Crypto.local_nonce := local_nonce;
                                              Crypto.remote_nonce :=
                                                remote_nonce |} in
                                          let local_metadata :=
                                            (conn_meta_value metadata_config)
                                              remote_peer_id in
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            (Metadata.write canceler
                                              metadata_config fd cryptobox_data
                                              local_metadata)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Metadata.read canceler
                                                    metadata_config fd
                                                    cryptobox_data)
                                                  (fun remote_metadata =>
                                                    let info :=
                                                      {|
                                                        P2p_connection.Info.incoming :=
                                                          incoming;
                                                        P2p_connection.Info.peer_id :=
                                                          remote_peer_id;
                                                        P2p_connection.Info.id_point :=
                                                          id_point;
                                                        P2p_connection.Info.remote_socket_port :=
                                                          remote_socket_port;
                                                        P2p_connection.Info.announced_version :=
                                                          version msg;
                                                        P2p_connection.Info.private_node :=
                                                          (private_node
                                                            metadata_config)
                                                            remote_metadata;
                                                        P2p_connection.Info.local_metadata :=
                                                          local_metadata;
                                                        P2p_connection.Info.remote_metadata :=
                                                          remote_metadata |} in
                                                    Tezos_base__TzPervasives._return
                                                      (info,
                                                        {| fd := fd;
                                                          info := info;
                                                          cryptobox_data :=
                                                            cryptobox_data |}))
                                              end)
                                        end
                                      end)
                                end)
                          end))
                end)
  end.

Module Reader.
  Record t {msg meta : Type} := {
    canceler : Tezos_stdlib.Lwt_canceler.t;
    conn : authenticated_connection meta;
    encoding : Tezos_base__TzPervasives.Data_encoding.t msg;
    messages :
      Tezos_stdlib.Lwt_pipe.t (Tezos_base__TzPervasives.tzresult (Z * msg));
    worker : Lwt.t unit }.
  Arguments t : clear implicits.
  
  Definition read_message {A B : Type}
    (st : t A B) (init : option Tezos_data_encoding.Binary_stream.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option (A * Z * Tezos_data_encoding.Binary_stream.t))) :=
    let fix loop {C : Type}
      (status : Tezos_base__TzPervasives.Data_encoding.Binary.status C)
      : Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (option (C * Z * Tezos_data_encoding.Binary_stream.t))) :=
      Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            match status with
            | Success {| result := result; size := size; stream := stream |} =>
              Tezos_base__TzPervasives.return_some (result, size, stream)
            | inr _err =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (lwt_debug
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "[read_message] incremental decoding error" % string
                      CamlinternalFormatBasics.End_of_format)
                    "[read_message] incremental decoding error" % string))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_none
                  end)
            | Await decode_next_buf =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Crypto.read_chunk (Some (canceler st)) (fd (conn st))
                  (cryptobox_data (conn st)))
                (fun buf =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_debug
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "reading " % string
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.String_literal
                              " bytes from " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))))
                        "reading %d bytes from %a" % string) (String.length buf)
                      Tezos_base__TzPervasives.P2p_peer.Id.pp
                      (peer_id (info (conn st))))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => loop (decode_next_buf buf)
                      end))
            end
          end) in
    loop
      (Tezos_base__TzPervasives.Data_encoding.Binary.read_stream init
        (encoding st)).
  
  Fixpoint worker_loop {A B : Type}
    (st : t A B) (stream : option Tezos_data_encoding.Binary_stream.t)
    : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.op_gt_gt_eq_question (read_message st stream)
        (fun msg =>
          match msg with
          | None =>
            Tezos_base__TzPervasives.protect None (Some (canceler st))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_stdlib.Lwt_pipe.push (messages st)
                      (Tezos_base__TzPervasives.error P2p_errors.Decoding_error))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_none
                      end)
                end)
          | Some (msg, size, stream) =>
            Tezos_base__TzPervasives.protect None (Some (canceler st))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_stdlib.Lwt_pipe.push (messages st) (inl (size, msg)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_some stream
                      end)
                end)
          end))
      (fun function_parameter =>
        match function_parameter with
        | inl (Some stream) => worker_loop st (Some stream)
        | inl None => Tezos_stdlib.Lwt_canceler.cancel (canceler st)
        | inr (cons Canceled _) | inr (cons (Exn Lwt_pipe.Closed) _) =>
          lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "connection closed to " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "connection closed to %a" % string)
            Tezos_base__TzPervasives.P2p_peer.Id.pp (peer_id (info (conn st)))
        | (inr _) as err =>
          Tezos_stdlib.Lwt_pipe.safe_push_now (messages st) err;
          Tezos_stdlib.Lwt_canceler.cancel (canceler st)
        end).
  
  Definition run {A B : Type}
    (size : option Z) (conn : authenticated_connection A)
    (encoding : Tezos_base__TzPervasives.Data_encoding.t B)
    (canceler : Tezos_stdlib.Lwt_canceler.t) : t B A :=
    let compute_size {C D : Type} (function_parameter : sum (Z * C) D) : Z :=
      match function_parameter with
      | inl (size, _) =>
        Z.add (Z.add (Z.mul (Z.div Stdlib.Sys.word_size 8) 11) size)
          Tezos_stdlib.Lwt_pipe.push_overhead
      | inr _ => 0
      end in
    let size := Tezos_stdlib.Option.map (fun max => (max, compute_size)) size in
    let st :=
      {| canceler := canceler; conn := conn; encoding := encoding;
        messages := Tezos_stdlib.Lwt_pipe.create size tt;
        worker := Lwt.return_unit |} in
    Tezos_stdlib.Lwt_canceler.on_cancel (canceler st)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_stdlib.Lwt_pipe.close (messages st);
          Lwt.return_unit
        end);
    set_field;
    st.
  
  Definition shutdown {A B : Type} (st : t A B) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_stdlib.Lwt_canceler.cancel (canceler st))
      (fun function_parameter =>
        match function_parameter with
        | tt => worker st
        end).
End Reader.

Module Writer.
  Record t {msg meta : Type} := {
    canceler : Tezos_stdlib.Lwt_canceler.t;
    conn : authenticated_connection meta;
    encoding : Tezos_base__TzPervasives.Data_encoding.t msg;
    messages :
      Tezos_stdlib.Lwt_pipe.t
        ((list Stdlib.Bytes.t) *
          (option (Lwt.u (Tezos_base__TzPervasives.tzresult unit))));
    worker : Lwt.t unit;
    binary_chunks_size : Z }.
  Arguments t : clear implicits.
  
  Definition send_message {A B : Type} (st : t A B) (buf : list string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let fix loop (function_parameter : list string)
      : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
      match function_parameter with
      | [] => Tezos_base__TzPervasives.return_unit
      | cons buf l =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Crypto.write_chunk (Some (canceler st)) (fd (conn st))
            (cryptobox_data (conn st)) buf)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (lwt_debug
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "writing " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " bytes to " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))))
                    "writing %d bytes to %a" % string) (String.length buf)
                  Tezos_base__TzPervasives.P2p_peer.Id.pp
                  (peer_id (info (conn st))))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => loop l
                  end)
            end)
      end in
    loop buf.
  
  Definition encode_message {A B : Type} (st : t A B) (msg : A)
    : Tezos_base__TzPervasives.tzresult (list Stdlib.Bytes.t) := try.
  
  Fixpoint worker_loop {A B : Type} (st : t A B) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_base__TzPervasives.protect None (Some (canceler st))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_stdlib.Lwt_pipe.pop (messages st))
                    Tezos_base__TzPervasives._return
                end))
            (fun function_parameter =>
              match function_parameter with
              | inr (cons Canceled _) | inr (cons (Exn Lwt_pipe.Closed) _) =>
                lwt_debug
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "connection closed to " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))
                    "connection closed to %a" % string)
                  Tezos_base__TzPervasives.P2p_peer.Id.pp
                  (peer_id (info (conn st)))
              | inr err =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_error
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "error writing to " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format))))))
                      "@[<v 2>error writing to %a@ %a@]" % string)
                    Tezos_base__TzPervasives.P2p_peer.Id.pp
                    (peer_id (info (conn st)))
                    Tezos_base__TzPervasives.pp_print_error err)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_stdlib.Lwt_canceler.cancel (canceler st)
                    end)
              | inl (buf, wakener) =>
                Tezos_base__TzPervasives.op_gt_gt_eq (send_message st buf)
                  (fun res =>
                    match res with
                    | inl tt =>
                      Tezos_stdlib.Option.iter (fun u => Lwt.wakeup_later u res)
                        wakener;
                      worker_loop st
                    | inr err =>
                      Tezos_stdlib.Option.iter
                        (fun u =>
                          Lwt.wakeup_later u
                            (Tezos_base__TzPervasives.error
                              P2p_errors.Connection_closed)) wakener;
                      match err with
                      | cons (Canceled | Exn Lwt_pipe.Closed) _ =>
                        lwt_debug
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "connection closed to " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))
                            "connection closed to %a" % string)
                          Tezos_base__TzPervasives.P2p_peer.Id.pp
                          (peer_id (info (conn st)))
                      | cons P2p_errors.Connection_closed _ =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (lwt_debug
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "connection closed to " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))
                              "connection closed to %a" % string)
                            Tezos_base__TzPervasives.P2p_peer.Id.pp
                            (peer_id (info (conn st))))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_stdlib.Lwt_canceler.cancel (canceler st)
                            end)
                      | err =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (lwt_log_error
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "error writing to " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))))
                              "@[<v 2>error writing to %a@ %a@]" % string)
                            Tezos_base__TzPervasives.P2p_peer.Id.pp
                            (peer_id (info (conn st)))
                            Tezos_base__TzPervasives.pp_print_error err)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_stdlib.Lwt_canceler.cancel (canceler st)
                            end)
                      end
                    end)
              end)
        end).
  
  Definition run {A B : Type}
    (size : option Z) (binary_chunks_size : option Z)
    (conn : authenticated_connection A)
    (encoding : Tezos_base__TzPervasives.Data_encoding.t B)
    (canceler : Tezos_stdlib.Lwt_canceler.t) : t B A :=
    let binary_chunks_size :=
      match binary_chunks_size with
      | None => Crypto.max_content_length
      | Some size =>
        let size := Z.sub size Crypto.extrabytes in
        OCaml.Stdlib.gt size 0;
        OCaml.Stdlib.le size Crypto.max_content_length;
        size
      end in
    let compute_size :=
      let buf_list_size :=
        Tezos_base__TzPervasives.List.fold_left
          (fun sz =>
            fun buf =>
              Z.add (Z.add sz (String.length buf))
                (Z.mul 2 Stdlib.Sys.word_size)) 0 in
      fun function_parameter =>
        match function_parameter with
        | (buf_l, None) =>
          Z.add (Z.add Stdlib.Sys.word_size (buf_list_size buf_l))
            Tezos_stdlib.Lwt_pipe.push_overhead
        | (buf_l, Some _) =>
          Z.add (Z.add (Z.mul 2 Stdlib.Sys.word_size) (buf_list_size buf_l))
            Tezos_stdlib.Lwt_pipe.push_overhead
        end in
    let size := Tezos_stdlib.Option.map (fun max => (max, compute_size)) size in
    let st :=
      {| canceler := canceler; conn := conn; encoding := encoding;
        messages := Tezos_stdlib.Lwt_pipe.create size tt;
        worker := Lwt.return_unit; binary_chunks_size := binary_chunks_size |}
      in
    Tezos_stdlib.Lwt_canceler.on_cancel (canceler st)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_stdlib.Lwt_pipe.close (messages st);
          while;
          Lwt.return_unit
        end);
    set_field;
    st.
  
  Definition shutdown {A B : Type} (st : t A B) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_stdlib.Lwt_canceler.cancel (canceler st))
      (fun function_parameter =>
        match function_parameter with
        | tt => worker st
        end).
End Writer.

Record t {msg meta : Type} := {
  conn : authenticated_connection meta;
  reader : Reader.t msg meta;
  writer : Writer.t msg meta }.
Arguments t : clear implicits.

Definition equal {A B C D : Type} (function_parameter : t A B)
  : (t C D) -> bool :=
  match function_parameter with
  | {| conn := {| fd := fd2 |} |} =>
    fun function_parameter =>
      match function_parameter with
      | {| conn := {| fd := fd1 |} |} =>
        equiv_decb (Tezos_p2p.P2p_io_scheduler.id fd1)
          (Tezos_p2p.P2p_io_scheduler.id fd2)
      end
  end.

Definition pp {A B : Type}
  (ppf : Stdlib.Format.formatter) (function_parameter : t A B) : unit :=
  match function_parameter with
  | {| conn := conn |} =>
    Tezos_base__TzPervasives.P2p_connection.Info.pp
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => tt
            end
        end) ppf (info conn)
  end.

Definition info {A B : Type} (function_parameter : t A B)
  : Tezos_base__TzPervasives.P2p_connection.Info.t B :=
  match function_parameter with
  | {| conn := conn |} => info conn
  end.

Definition local_metadata {A B : Type} (function_parameter : t A B) : B :=
  match function_parameter with
  | {| conn := conn |} => local_metadata (info conn)
  end.

Definition remote_metadata {A B : Type} (function_parameter : t A B) : B :=
  match function_parameter with
  | {| conn := conn |} => remote_metadata (info conn)
  end.

Definition private_node {A B : Type} (function_parameter : t A B) : bool :=
  match function_parameter with
  | {| conn := conn |} => private_node (info conn)
  end.

Definition accept {A B : Type}
  (incoming_message_queue_size : option Z)
  (outgoing_message_queue_size : option Z) (binary_chunks_size : option Z)
  (canceler : Tezos_stdlib.Lwt_canceler.t) (conn : authenticated_connection A)
  (encoding : Tezos_base__TzPervasives.Data_encoding.t B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (t B A)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.protect
      (Some
        (fun err =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_p2p.P2p_io_scheduler.close None (fd conn))
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                match err with
                | cons P2p_errors.Connection_closed [] =>
                  Tezos_base__TzPervasives.fail
                    P2p_errors.Rejected_socket_connection
                | cons P2p_errors.Decipher_error [] =>
                  Tezos_base__TzPervasives.fail P2p_errors.Invalid_auth
                | err => Lwt.return_error err
                end
              end))) None
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Ack.write (Some canceler) (fd conn) (cryptobox_data conn) Ack)
            (fun function_parameter =>
              match function_parameter with
              | tt => Ack.read (Some canceler) (fd conn) (cryptobox_data conn)
              end)
        end))
    (fun function_parameter =>
      match function_parameter with
      | Ack =>
        let canceler := Tezos_stdlib.Lwt_canceler.create tt in
        let reader : Reader.t B A :=
          Reader.run incoming_message_queue_size conn encoding canceler
        with writer : Writer.t B A :=
          Writer.run outgoing_message_queue_size binary_chunks_size conn
            encoding canceler in
        let conn := {| conn := conn; reader := reader; writer := writer |} in
        Tezos_stdlib.Lwt_canceler.on_cancel canceler
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_p2p.P2p_io_scheduler.close None (fd (conn conn)))
                (fun function_parameter =>
                  match function_parameter with
                  | _ => Lwt.return_unit
                  end)
            end);
        Tezos_base__TzPervasives._return conn
      | Nack =>
        Tezos_base__TzPervasives.fail P2p_errors.Rejected_socket_connection
      end).

Definition catch_closed_pipe {A : Type}
  (f : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult A))
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Lwt.catch f
      (fun function_parameter =>
        match function_parameter with
        | Lwt_pipe.Closed =>
          Tezos_base__TzPervasives.fail P2p_errors.Connection_closed
        | exn => Tezos_base__TzPervasives.fail (Exn exn)
        end))
    (fun function_parameter =>
      match function_parameter with
      | inr (cons (Exn Lwt_pipe.Closed) _) =>
        Tezos_base__TzPervasives.fail P2p_errors.Connection_closed
      | (inr _ | inl _) as v => Lwt._return v
      end).

Definition pp_json {A : Type}
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (ppf : Stdlib.Format.formatter) (msg : A) : unit :=
  Tezos_base__TzPervasives.Data_encoding.Json.pp ppf
    (Tezos_base__TzPervasives.Data_encoding.Json.construct encoding msg).

Definition write {A B : Type} (function_parameter : t A B)
  : A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| conn := conn; writer := writer |} =>
    fun msg =>
      catch_closed_pipe
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Sending message to " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ": " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "Sending message to %a: %a" % string)
              Tezos_base__TzPervasives.P2p_peer.Id.pp_short
              (peer_id (info conn)) (pp_json (encoding writer)) msg;
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Lwt._return (Writer.encode_message writer msg))
              (fun buf =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_stdlib.Lwt_pipe.push (messages writer) (buf, None))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives.return_unit
                    end))
          end)
  end.

Definition write_sync {A B : Type} (function_parameter : t A B)
  : A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| conn := conn; writer := writer |} =>
    fun msg =>
      catch_closed_pipe
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            match Lwt.wait tt with
            | (waiter, wakener) =>
              debug
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Sending message to " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal ": " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))))
                  "Sending message to %a: %a" % string)
                Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                (peer_id (info conn)) (pp_json (encoding writer)) msg;
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Lwt._return (Writer.encode_message writer msg))
                (fun buf =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_stdlib.Lwt_pipe.push (messages writer)
                      (buf, (Some wakener)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => waiter
                      end))
            end
          end)
  end.

Definition write_now {A B : Type} (function_parameter : t A B)
  : A -> Tezos_base__TzPervasives.tzresult bool :=
  match function_parameter with
  | {| conn := conn; writer := writer |} =>
    fun msg =>
      debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Try sending message to " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal ": " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))))
          "Try sending message to %a: %a" % string)
        Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id (info conn))
        (pp_json (encoding writer)) msg;
      Tezos_base__TzPervasives.op_gt_gt_question
        (Writer.encode_message writer msg) (fun buf => try)
  end.

Fixpoint split_bytes (size : Z) (bytes : string) : list string :=
  if OCaml.Stdlib.le (String.length string) size then
    cons string []
  else
    cons (String.sub string 0 size)
      (split_bytes size
        (String.sub string size (Z.sub (String.length string) size))).

Definition raw_write_sync {A B : Type} (function_parameter : t A B)
  : string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| writer := writer |} =>
    fun bytes =>
      let bytes := split_bytes (binary_chunks_size writer) string in
      catch_closed_pipe
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            match Lwt.wait tt with
            | (waiter, wakener) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_stdlib.Lwt_pipe.push (messages writer)
                  (string, (Some wakener)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => waiter
                  end)
            end
          end)
  end.

Definition is_readable {A B : Type} (function_parameter : t A B) : bool :=
  match function_parameter with
  | {| reader := reader |} =>
    negb (Tezos_stdlib.Lwt_pipe.is_empty (messages reader))
  end.

Definition wait_readable {A B : Type} (function_parameter : t A B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {| reader := reader |} =>
    catch_closed_pipe
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_stdlib.Lwt_pipe.values_available (messages reader))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        end)
  end.

Definition read {A B : Type} (function_parameter : t A B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (Z * A)) :=
  match function_parameter with
  | {| reader := reader |} =>
    catch_closed_pipe
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_stdlib.Lwt_pipe.pop (messages reader)
        end)
  end.

Definition read_now {A B : Type} (function_parameter : t A B)
  : option (Tezos_base__TzPervasives.tzresult (Z * A)) :=
  match function_parameter with
  | {| reader := reader |} => try
  end.

Definition stat {A B : Type} (function_parameter : t A B)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  match function_parameter with
  | {| conn := {| fd := fd |} |} => Tezos_p2p.P2p_io_scheduler.stat fd
  end.

Definition close {A B : Type} (op_star_o_p_t_star : option bool)
  : (t A B) -> Lwt.t unit :=
  let wait :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun st =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (if negb wait then
        Lwt.return_unit
      else
        Tezos_stdlib.Lwt_pipe.close (messages (reader st));
        Tezos_stdlib.Lwt_pipe.close (messages (writer st));
        worker (writer st))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq (Reader.shutdown (reader st))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Writer.shutdown (writer st))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_p2p.P2p_io_scheduler.close None (fd (conn st)))
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => Lwt.return_unit
                          end)
                    end)
              end)
        end).
src/lib_p2p/p2p_socket.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Typed and encrypted connections to peers.

    This module defines:
    - primitive functions to implement a session-establishment protocol
      (set up an authentication/encryption symmetric session key,
       check proof of work target, authenticate hosts, exchange meta data),
    - a higher-level, authenticated and encrypted, type of connection.

    It is parametric in two (abstract data) types. ['msg] is the unit of
    communication. ['meta] is a type of message sent in session establishment.

    Connections defined in this module wrap a [P2p_io_scheduler.connection]
    (which is simply a file descriptor on which R/W are regulated.)

    Each connection has an associated internal read (resp. write) queue
    containing messages (of type ['msg]), whose size can be limited by
    providing corresponding arguments to [accept]. *)

(** {1 Types} *)

(** This defines an abstract data type ['meta]. Mainly a placeholder to be
    used by the calling layer. ['meta] objects are communicated at session
    initiation and both ends ['meta'] are known once session is set up. ['meta]
    object should at least contain the private status of the node. *)

(* TODO:
   - this type is duplicated at several places. Define it once for all in a
     separate module (with [msg_config] and [peer_config]).
   - the parameter [P2p_peer.Id.t] provides more control when constructing a
     ['meta] but may not be useful. *)
type 'meta metadata_config = {
  conn_meta_encoding : 'meta Data_encoding.t;
  conn_meta_value : P2p_peer.Id.t -> 'meta;
  private_node : 'meta -> bool;
}

(** Type of a connection that successfully passed the authentication
    phase, but has not been accepted yet. Parametrized by the type
    of expected parameter in the `ack` message. *)
type 'meta authenticated_connection

(** Type of an accepted connection, parametrized by the type of
    messages exchanged between peers. *)
type ('msg, 'meta) t

(** [equal t1 t2] returns true iff the identities of the underlying
    [P2p_io_scheduler.connection]s are equal. *)
val equal : ('mst, 'meta) t -> ('msg, 'meta) t -> bool

val pp : Format.formatter -> ('msg, 'meta) t -> unit

val info : ('msg, 'meta) t -> 'meta P2p_connection.Info.t

(** [local_metadata t] returns the metadata provided when calling
    [authenticate]. *)
val local_metadata : ('msg, 'meta) t -> 'meta

(** [local_metadata t] returns the remote metadata, communicated by the
    remote host when the session was established. *)
val remote_metadata : ('msg, 'meta) t -> 'meta

val private_node : ('msg, 'meta) t -> bool

(** {1 Session-establishment functions} these should be used together
    to implement the session establishment protocol. Session establishment
    proceeds in three synchronous, symmetric, steps. First two steps are
    implemented by [authenticate]. Third step is implemented by either [accept]
    or [kick].

    1. Hosts send each other an authentication message. The message contains
       notably a public key, a nonce, and proof of work stamp computed from
       the public key. PoW work is checked, and a session key is established
       (authenticated key exchange). The session key will be used to
       encrypt/authenticate all subsequent messages over this connection.

    2. Hosts send each other a ['meta] message.

    3. Each host send either an [Ack] message ([accept] function) or an [Nack]
       message ([kick] function). If both hosts send an [Ack], the connection
       is established and they can start to read/write ['msg].

    Note that [P2p_errors.Decipher_error] can be raised from all functions
    receiving messages after step 1, when a message can't be decrypted.

    Typically, the calling module will make additional checks after step 2 to
    decide what to do in step 3. For instance, based on network version or
    ['meta] information. *)

(** [authenticate canceler pow incoming conn point ?port identity version meta]
    returns a couple [(info, auth_conn) tries to set up a session with
    the host connected via [conn].

    Can fail with
    - [P2p_errors.Not_enough_proof_of_work] if PoW target isn't reached
    - [P2p_errors.Myself] if both hosts are the same peer *)
val authenticate :
  canceler:Lwt_canceler.t ->
  proof_of_work_target:Crypto_box.target ->
  incoming:bool ->
  P2p_io_scheduler.connection ->
  P2p_point.Id.t ->
  ?listening_port:int ->
  P2p_identity.t ->
  Network_version.t ->
  'meta metadata_config ->
  ('meta P2p_connection.Info.t * 'meta authenticated_connection) tzresult Lwt.t

(** [kick ac] sends a [Nack] message to the remote peer, notifying it
    that its connection is rejected. It then closes the connection. *)
val kick : 'meta authenticated_connection -> unit Lwt.t

(** [Accepts] sends an [Ack message] to the remote peer and wait for an [Ack]
    from the remote peer to complete session set up. This can fail with errors:
    - [P2p_errors.Rejected_socket_connection] (connection closed or [Nack]
      received)
    - [P2p_errors.Invalid_auth] thrown if [P2p_error.Decipher_error]
      TODO why not let propagate [P2p_error.Decipher_error] *)
val accept :
  ?incoming_message_queue_size:int ->
  ?outgoing_message_queue_size:int ->
  ?binary_chunks_size:int ->
  canceler:Lwt_canceler.t ->
  'meta authenticated_connection ->
  'msg Data_encoding.t ->
  ('msg, 'meta) t tzresult Lwt.t

(** Check for the [?binary_chunks_size] parameter of [accept]. *)
val check_binary_chunks_size : int -> unit tzresult Lwt.t

(** {1 IO functions on connections} *)

(** {2 Output functions} *)

(** [write conn msg] returns when [msg] has successfully been added to
    [conn]'s internal write queue or fails with a corresponding
    error. *)
val write : ('msg, 'meta) t -> 'msg -> unit tzresult Lwt.t

(** [write_now conn msg] is [Ok true] if [msg] has been added to
    [conn]'s internal write queue, [Ok false] if [msg] has been
    dropped, or fails with a corresponding error otherwise. *)
val write_now : ('msg, 'meta) t -> 'msg -> bool tzresult

(** [write_sync conn msg] returns when [msg] has been successfully
    sent to the remote end of [conn], or fails accordingly. *)
val write_sync : ('msg, 'meta) t -> 'msg -> unit tzresult Lwt.t

(** {2 Input functions} *)

(** [is_readable conn] is [true] iff [conn] internal read queue is not
    empty. *)
val is_readable : ('msg, 'meta) t -> bool

(** (Cancelable) [wait_readable conn] returns when [conn]'s internal
    read queue becomes readable (i.e. not empty). *)
val wait_readable : ('msg, 'meta) t -> unit tzresult Lwt.t

(** [read conn msg] returns when [msg] has successfully been popped
    from [conn]'s internal read queue or fails with a corresponding
    error. *)
val read : ('msg, 'meta) t -> (int * 'msg) tzresult Lwt.t

(** [read_now conn msg] is [Some msg] if [conn]'s internal read queue
    is not empty, [None] if it is empty, or fails with a corresponding
    error otherwise. *)
val read_now : ('msg, 'meta) t -> (int * 'msg) tzresult option

(** [stat conn] is a snapshot of current bandwidth usage for
    [conn]. *)
val stat : ('msg, 'meta) t -> P2p_stat.t

val close : ?wait:bool -> ('msg, 'meta) t -> unit Lwt.t

(**/**)

(** for testing only *)
val raw_write_sync : ('msg, 'meta) t -> Bytes.t -> unit tzresult Lwt.t
src/lib_p2p/p2p_socket.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record metadata_config {meta : Type} := {
  conn_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t meta;
  conn_meta_value : Tezos_base__TzPervasives.P2p_peer.Id.t -> meta;
  private_node : meta -> bool }.
Arguments metadata_config : clear implicits.

Parameter authenticated_connection : forall (meta : Type), Type.

Parameter t : forall (msg meta : Type), Type.

Parameter equal : forall {meta msg mst : Type},
(t mst meta) -> (t msg meta) -> bool.

Parameter pp : forall {meta msg : Type},
Stdlib.Format.formatter -> (t msg meta) -> unit.

Parameter info : forall {meta msg : Type},
(t msg meta) -> Tezos_base__TzPervasives.P2p_connection.Info.t meta.

Parameter local_metadata : forall {meta msg : Type}, (t msg meta) -> meta.

Parameter remote_metadata : forall {meta msg : Type}, (t msg meta) -> meta.

Parameter private_node : forall {meta msg : Type}, (t msg meta) -> bool.

Parameter authenticate : forall {meta : Type},
Tezos_stdlib.Lwt_canceler.t ->
  Tezos_base__TzPervasives.Crypto_box.target ->
    bool ->
      Tezos_p2p.P2p_io_scheduler.connection ->
        Tezos_base__TzPervasives.P2p_point.Id.t ->
          (option Z) ->
            Tezos_base__TzPervasives.P2p_identity.t ->
              Tezos_base__TzPervasives.Network_version.t ->
                (metadata_config meta) ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      ((Tezos_base__TzPervasives.P2p_connection.Info.t meta) *
                        (authenticated_connection meta))).

Parameter kick : forall {meta : Type},
(authenticated_connection meta) -> Lwt.t unit.

Parameter accept : forall {meta msg : Type},
(option Z) ->
  (option Z) ->
    (option Z) ->
      Tezos_stdlib.Lwt_canceler.t ->
        (authenticated_connection meta) ->
          (Tezos_base__TzPervasives.Data_encoding.t msg) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult (t msg meta)).

Parameter check_binary_chunks_size :
Z -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter write : forall {meta msg : Type},
(t msg meta) -> msg -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter write_now : forall {meta msg : Type},
(t msg meta) -> msg -> Tezos_base__TzPervasives.tzresult bool.

Parameter write_sync : forall {meta msg : Type},
(t msg meta) -> msg -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter is_readable : forall {meta msg : Type}, (t msg meta) -> bool.

Parameter wait_readable : forall {meta msg : Type},
(t msg meta) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter read : forall {meta msg : Type},
(t msg meta) -> Lwt.t (Tezos_base__TzPervasives.tzresult (Z * msg)).

Parameter read_now : forall {meta msg : Type},
(t msg meta) -> option (Tezos_base__TzPervasives.tzresult (Z * msg)).

Parameter stat : forall {meta msg : Type},
(t msg meta) -> Tezos_base__TzPervasives.P2p_stat.t.

Parameter close : forall {meta msg : Type},
(option bool) -> (t msg meta) -> Lwt.t unit.

Parameter raw_write_sync : forall {meta msg : Type},
(t msg meta) -> Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/lib_p2p/p2p_welcome.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.welcome"
end)

type pool = Pool : ('msg, 'meta, 'meta_conn) P2p_pool.t -> pool

type t = {
  socket : Lwt_unix.file_descr;
  canceler : Lwt_canceler.t;
  pool : pool;
  mutable worker : unit Lwt.t;
}

let rec worker_loop st =
  let (Pool pool) = st.pool in
  Lwt_unix.yield ()
  >>= fun () ->
  protect ~canceler:st.canceler (fun () -> P2p_fd.accept st.socket >>= return)
  >>= function
  | Ok (fd, addr) ->
      let point =
        match addr with
        | Lwt_unix.ADDR_UNIX _ ->
            assert false
        | Lwt_unix.ADDR_INET (addr, port) ->
            (Ipaddr_unix.V6.of_inet_addr_exn addr, port)
      in
      P2p_pool.accept pool fd point ;
      worker_loop st
  (* Unix errors related to the failure to create one connection,
     No reason to abort just now, but we want to stress out that we
     have a problem preventing us from accepting new connections. *)
  | Error
      ( Exn
          (Unix.Unix_error
            ( ( EMFILE (* Too many open files by the process *)
              | ENFILE (* Too many open files in the system *)
              | ENETDOWN (* Network is down *) ),
              _,
              _ ))
        :: _ as err ) ->
      lwt_log_error
        "@[<v 2>Incoming connection failed with %a in the\n\
        \      Welcome worker. Resuming in 5s.@]"
        pp_print_error
        err
      >>= fun () ->
      (* These are temporary system errors, giving some time for the system to
         recover *)
      Lwt_unix.sleep 5. >>= fun () -> worker_loop st
  | Error
      ( Exn
          (Unix.Unix_error
            ( ( EAGAIN (* Resource temporarily unavailable; try again *)
              | EWOULDBLOCK (* Operation would block *)
              | ENOPROTOOPT (* Protocol not available *)
              | EOPNOTSUPP (* Operation not supported on socket *)
              | ENETUNREACH (* Network is unreachable *)
              | ECONNABORTED (* Software caused connection abort *)
              | ECONNRESET (* Connection reset by peer *)
              | ETIMEDOUT (* Connection timed out *)
              | EHOSTDOWN (* Host is down *)
              | EHOSTUNREACH (* No route to host *)
              (* Ugly hack to catch EPROTO and ENONET, Protocol error, which are not
       defined in the Unix module (which is 20 years late on the POSIX
       standard). A better solution is to use the package ocaml-unix-errno or
       redo the work *)
              | EUNKNOWNERR (71 | 64)
              (* On Linux EPROTO is 71, ENONET is 64
       On BSD systems, accept cannot raise EPROTO.
       71 is EREMOTE   for openBSD, NetBSD, Darwin, which is irrelevant here
       64 is EHOSTDOWN for openBSD, NetBSD, Darwin, which is already caught
    *)
                ),
              _,
              _ ))
        :: _ as err ) ->
      (* These are socket-specific errors, ignoring. *)
      lwt_log_error
        "@[<v 2>Incoming connection failed with %a in the Welcome worker@]"
        pp_print_error
        err
      >>= fun () -> worker_loop st
  | Error (Canceled :: _) ->
      Lwt.return_unit
  | Error err ->
      lwt_log_error
        "@[<v 2>Unexpected error in the Welcome worker@ %a@]"
        pp_print_error
        err

let create_listening_socket ~backlog ?(addr = Ipaddr.V6.unspecified) port =
  let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
  Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
  Lwt_unix.bind
    main_socket
    Unix.(ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port))
  >>= fun () ->
  Lwt_unix.listen main_socket backlog ;
  Lwt.return main_socket

let create ?addr ~backlog pool port =
  Lwt.catch
    (fun () ->
      create_listening_socket ~backlog ?addr port
      >>= fun socket ->
      let canceler = Lwt_canceler.create () in
      Lwt_canceler.on_cancel canceler (fun () ->
          Lwt_utils_unix.safe_close socket) ;
      let st =
        {socket; canceler; pool = Pool pool; worker = Lwt.return_unit}
      in
      Lwt.return st)
    (fun exn ->
      lwt_log_error
        "@[<v 2>Cannot accept incoming connections@ %a@]"
        pp_exn
        exn
      >>= fun () -> Lwt.fail exn)

let activate st =
  st.worker <-
    Lwt_utils.worker
      "welcome"
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> worker_loop st)
      ~cancel:(fun () -> Lwt_canceler.cancel st.canceler)

let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
src/lib_p2p/p2p_welcome.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive pool : Type :=
| Pool : forall {meta meta_conn msg : Type},
  (Tezos_p2p.P2p_pool.t msg meta meta_conn) -> pool.

Record t := {
  socket : Lwt_unix.file_descr;
  canceler : Tezos_stdlib.Lwt_canceler.t;
  pool : pool;
  worker : Lwt.t unit }.

Fixpoint worker_loop (st : t) : Lwt.t unit :=
  match pool st with
  | Pool pool =>
    Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_base__TzPervasives.protect None (Some (canceler st))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_p2p.P2p_fd.accept (socket st))
                    Tezos_base__TzPervasives._return
                end))
            (fun function_parameter =>
              match function_parameter with
              | inl (fd, addr) =>
                let point :=
                  match addr with
                  | Lwt_unix.ADDR_UNIX _ => false
                  | Lwt_unix.ADDR_INET addr port =>
                    ((Ipaddr_unix.V6.of_inet_addr_exn addr), port)
                  end in
                Tezos_p2p.P2p_pool.accept pool fd point;
                worker_loop st
              |
                inr
                  ((cons
                    (Exn (Unix.Unix_error (EMFILE | ENFILE | ENETDOWN) _ _)) _)
                    as err) =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_error
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Incoming connection failed with " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " in the
      Welcome worker. Resuming in 5s." %
                                string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[<v 2>Incoming connection failed with %a in the
      Welcome worker. Resuming in 5s.@]"
                        % string) Tezos_base__TzPervasives.pp_print_error err)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.sleep 5)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => worker_loop st
                          end)
                    end)
              |
                inr
                  ((cons
                    (Exn
                      (Unix.Unix_error
                        (EAGAIN | EWOULDBLOCK | ENOPROTOOPT | EOPNOTSUPP |
                          ENETUNREACH | ECONNABORTED | ECONNRESET | ETIMEDOUT |
                          EHOSTDOWN | EHOSTUNREACH | EUNKNOWNERR (71 | 64)) _ _))
                    _) as err) =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_error
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Incoming connection failed with " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " in the Welcome worker" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[<v 2>Incoming connection failed with %a in the Welcome worker@]"
                        % string) Tezos_base__TzPervasives.pp_print_error err)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => worker_loop st
                    end)
              | inr (cons Canceled _) => Lwt.return_unit
              | inr err =>
                lwt_log_error
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Unexpected error in the Welcome worker" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))
                    "@[<v 2>Unexpected error in the Welcome worker@ %a@]" %
                      string) Tezos_base__TzPervasives.pp_print_error err
              end)
        end)
  end.

Definition create_listening_socket
  (backlog : Z) (op_star_o_p_t_star : option Ipaddr.V6.t)
  : Z -> Lwt.t Lwt_unix.file_descr :=
  let addr :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Ipaddr.V6.unspecified
    end in
  fun port =>
    let main_socket := Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
    Lwt_unix.setsockopt main_socket SO_REUSEADDR true;
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Lwt_unix.bind main_socket
        (ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Lwt_unix.listen main_socket backlog;
          Lwt._return main_socket
        end).

Definition create {A B C : Type}
  (addr : option Ipaddr.V6.t) (backlog : Z) (pool : Tezos_p2p.P2p_pool.t A B C)
  (port : Z) : Lwt.t t :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (create_listening_socket backlog addr port)
          (fun socket =>
            let canceler := Tezos_stdlib.Lwt_canceler.create tt in
            Tezos_stdlib.Lwt_canceler.on_cancel canceler
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_stdlib_unix.Lwt_utils_unix.safe_close socket
                end);
            let st :=
              {| socket := socket; canceler := canceler; pool := Pool pool;
                worker := Lwt.return_unit |} in
            Lwt._return st)
      end)
    (fun exn =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (lwt_log_error
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Cannot accept incoming connections" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<v 2>Cannot accept incoming connections@ %a@]" % string)
          Tezos_base__TzPervasives.pp_exn exn)
        (fun function_parameter =>
          match function_parameter with
          | tt => Lwt.fail exn
          end)).

Definition activate (st : t) : unit := set_field.

Definition shutdown (st : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_stdlib.Lwt_canceler.cancel (canceler st))
    (fun function_parameter =>
      match function_parameter with
      | tt => worker st
      end).
src/lib_p2p/p2p_welcome.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Welcome worker.

    Accept incoming connections and add them to the pool.
*)

(** Type of a welcome worker. *)
type t

(** [create ?addr ~backlog pool port] returns a running welcome worker
    adding connections into [pool] listening on [addr:port]. [backlog]
    is passed to [Lwt_unix.listen]. *)
val create :
  ?addr:P2p_addr.t ->
  backlog:int ->
  ('msg, 'meta, 'meta_conn) P2p_pool.t ->
  P2p_addr.port ->
  t Lwt.t

(** [activate t] start the worker that will accept connections *)
val activate : t -> unit

(** [shutdown t] returns when [t] has completed shutdown. *)
val shutdown : t -> unit Lwt.t
src/lib_p2p/p2p_welcome.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create : forall {meta meta_conn msg : Type},
(option Tezos_base__TzPervasives.P2p_addr.t) ->
  Z ->
    (Tezos_p2p.P2p_pool.t msg meta meta_conn) ->
      Tezos_base__TzPervasives.P2p_addr.port -> Lwt.t t.

Parameter activate : t -> unit.

Parameter shutdown : t -> Lwt.t unit.
src/lib_p2p/test/process.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

let () = Lwt_unix.set_default_async_method Async_none

let section = Lwt_log.Section.make "process"

let log_f ~level format =
  if level < Lwt_log.Section.level section then
    Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format
  else Format.kasprintf (fun msg -> Lwt_log.log ~section ~level msg) format

let lwt_debug fmt = log_f ~level:Lwt_log.Debug fmt

let lwt_log_notice fmt = log_f ~level:Lwt_log.Notice fmt

let lwt_log_info fmt = log_f ~level:Lwt_log.Info fmt

let lwt_log_error fmt = log_f ~level:Lwt_log.Error fmt

exception Exited of int

exception Signaled of int

exception Stopped of int

let handle_error f =
  Lwt.catch f (fun exn -> Lwt.return_error [Exn exn])
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error err ->
      lwt_debug "%a" pp_print_error err >>= fun () -> exit 1

module Channel = struct
  type ('a, 'b) t = Lwt_io.input_channel * Lwt_io.output_channel

  let push (_, outch) v =
    Lwt.catch
      (fun () -> Lwt_io.write_value outch v >>= Lwt.return_ok)
      (fun exn -> Lwt.return_error [Exn exn])

  let pop (inch, _) =
    Lwt.catch
      (fun () -> Lwt_io.read_value inch >>= Lwt.return_ok)
      (fun exn -> Lwt.return_error [Exn exn])
end

let wait pid =
  Lwt.catch
    (fun () ->
      Lwt_unix.waitpid [] pid
      >>= function
      | (_, Lwt_unix.WEXITED 0) ->
          Lwt.return_ok ()
      | (_, Lwt_unix.WEXITED n) ->
          Lwt.return_error [Exn (Exited n)]
      | (_, Lwt_unix.WSIGNALED n) ->
          Lwt.return_error [Exn (Signaled n)]
      | (_, Lwt_unix.WSTOPPED n) ->
          Lwt.return_error [Exn (Stopped n)])
    (function
      | Lwt.Canceled ->
          Unix.kill pid Sys.sigkill ; Lwt.return_ok ()
      | exn ->
          Lwt.return_error [Exn exn])

type ('a, 'b) t = {
  termination : unit tzresult Lwt.t;
  channel : ('b, 'a) Channel.t;
}

let template = "$(date) - $(section): $(message)"

let detach ?(prefix = "") f =
  Lwt_io.flush_all ()
  >>= fun () ->
  let (main_in, child_out) = Lwt_io.pipe () in
  let (child_in, main_out) = Lwt_io.pipe () in
  match Lwt_unix.fork () with
  | 0 ->
      Lwt_log.default :=
        Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () ;
      Random.self_init () ;
      let template = Format.asprintf "%s$(message)" prefix in
      Lwt_main.run
        ( Lwt_io.close main_in
        >>= fun () ->
        Lwt_io.close main_out
        >>= fun () ->
        Lwt_log.default :=
          Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () ;
        lwt_log_notice "PID: %d" (Unix.getpid ())
        >>= fun () -> handle_error (fun () -> f (child_in, child_out)) ) ;
      exit 0
  | pid ->
      let termination = wait pid in
      Lwt_io.close child_in
      >>= fun () ->
      Lwt_io.close child_out
      >>= fun () -> Lwt.return {termination; channel = (main_in, main_out)}

let signal_name =
  let names =
    [ (Sys.sigabrt, "ABRT");
      (Sys.sigalrm, "ALRM");
      (Sys.sigfpe, "FPE");
      (Sys.sighup, "HUP");
      (Sys.sigill, "ILL");
      (Sys.sigint, "INT");
      (Sys.sigkill, "KILL");
      (Sys.sigpipe, "PIPE");
      (Sys.sigquit, "QUIT");
      (Sys.sigsegv, "SEGV");
      (Sys.sigterm, "TERM");
      (Sys.sigusr1, "USR1");
      (Sys.sigusr2, "USR2");
      (Sys.sigchld, "CHLD");
      (Sys.sigcont, "CONT");
      (Sys.sigstop, "STOP");
      (Sys.sigtstp, "TSTP");
      (Sys.sigttin, "TTIN");
      (Sys.sigttou, "TTOU");
      (Sys.sigvtalrm, "VTALRM");
      (Sys.sigprof, "PROF");
      (Sys.sigbus, "BUS");
      (Sys.sigpoll, "POLL");
      (Sys.sigsys, "SYS");
      (Sys.sigtrap, "TRAP");
      (Sys.sigurg, "URG");
      (Sys.sigxcpu, "XCPU");
      (Sys.sigxfsz, "XFSZ") ]
  in
  fun n -> List.assoc n names

let wait_all processes =
  let rec loop processes =
    match processes with
    | [] ->
        Lwt.return_none
    | processes -> (
        Lwt.nchoose_split processes
        >>= function
        | (finished, remaining) ->
            let rec handle = function
              | [] ->
                  loop remaining
              | Ok () :: finished ->
                  handle finished
              | Error err :: _ ->
                  Lwt.return_some (err, remaining)
            in
            handle finished )
  in
  loop (List.map (fun p -> p.termination) processes)
  >>= function
  | None ->
      lwt_log_info "All done!" >>= fun () -> Lwt.return_ok ()
  | Some ([Exn (Exited n)], remaining) ->
      lwt_log_error "Early error!"
      >>= fun () ->
      List.iter Lwt.cancel remaining ;
      join remaining
      >>= fun _ -> failwith "A process finished with error %d !" n
  | Some ([Exn (Signaled n)], remaining) ->
      lwt_log_error "Early error!"
      >>= fun () ->
      List.iter Lwt.cancel remaining ;
      join remaining
      >>= fun _ -> failwith "A process was killed by a SIG%s !" (signal_name n)
  | Some ([Exn (Stopped n)], remaining) ->
      lwt_log_error "Early error!"
      >>= fun () ->
      List.iter Lwt.cancel remaining ;
      join remaining
      >>= fun _ ->
      failwith "A process was stopped by a SIG%s !" (signal_name n)
  | Some (err, remaining) ->
      lwt_log_error "@[<v 2>Unexpected error!@,%a@]" pp_print_error err
      >>= fun () ->
      List.iter Lwt.cancel remaining ;
      join remaining
      >>= fun _ -> failwith "A process finished with an unexpected error !"
src/lib_p2p/test/process.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Error_monad.

Definition section : Lwt_log_core.section :=
  Lwt_log.Section.make "process" % string.

Definition log_f {A : Type}
  (level : Lwt_log.level)
  (format : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  if OCaml.Stdlib.lt level (Lwt_log.Section.level section) then
    Stdlib.Format.ikfprintf
      (fun function_parameter =>
        match function_parameter with
        | _ => Lwt.return_unit
        end) Stdlib.Format.std_formatter format
  else
    Stdlib.Format.kasprintf
      (fun msg => Lwt_log.log None (Some section) None None level msg) format.

Definition lwt_debug {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  log_f Lwt_log.Debug fmt.

Definition lwt_log_notice {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  log_f Lwt_log.Notice fmt.

Definition lwt_log_info {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  log_f Lwt_log.Info fmt.

Definition lwt_log_error {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  log_f Lwt_log.Error fmt.

Definition handle_error
  (f :
    unit ->
      Lwt.t
        (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)))
  : Lwt.t unit :=
  Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
    (Lwt.catch f (fun exn => Lwt.return_error (cons (Exn exn) [])))
    (fun function_parameter =>
      match function_parameter with
      | inl tt => Lwt.return_unit
      | inr err =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Tezos_base__TzPervasives.Error_monad.pp_print_error err)
          (fun function_parameter =>
            match function_parameter with
            | tt => Stdlib.exit 1
            end)
      end).

Module Channel.
  Definition t (a b : Type) := Lwt_io.input_channel * Lwt_io.output_channel.
  
  Definition push {A B : Type} (function_parameter : A * Lwt_io.output_channel)
    : B ->
      Lwt.t
        (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)) :=
    match function_parameter with
    | (_, outch) =>
      fun v =>
        Lwt.catch
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                (Lwt_io.write_value outch None v) Lwt.return_ok
            end) (fun exn => Lwt.return_error (cons (Exn exn) []))
    end.
  
  Definition pop {A B : Type} (function_parameter : Lwt_io.input_channel * A)
    : Lwt.t (Result.result B (list Tezos_base__TzPervasives.Error_monad.error)) :=
    match function_parameter with
    | (inch, _) =>
      Lwt.catch
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
              (Lwt_io.read_value inch) Lwt.return_ok
          end) (fun exn => Lwt.return_error (cons (Exn exn) []))
    end.
End Channel.

Definition wait (pid : Z)
  : Lwt.t (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)) :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (Lwt_unix.waitpid [] pid)
          (fun function_parameter =>
            match function_parameter with
            | (_, Lwt_unix.WEXITED 0) => Lwt.return_ok tt
            | (_, Lwt_unix.WEXITED n) =>
              Lwt.return_error (cons (Exn (Exited n)) [])
            | (_, Lwt_unix.WSIGNALED n) =>
              Lwt.return_error (cons (Exn (Signaled n)) [])
            | (_, Lwt_unix.WSTOPPED n) =>
              Lwt.return_error (cons (Exn (Stopped n)) [])
            end)
      end)
    (fun function_parameter =>
      match function_parameter with
      | Lwt.Canceled =>
        Unix.kill pid Stdlib.Sys.sigkill;
        Lwt.return_ok tt
      | exn => Lwt.return_error (cons (Exn exn) [])
      end).

Record t {a b : Type} := {
  termination : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit);
  channel : Channel.t b a }.
Arguments t : clear implicits.

Definition template : string := "$(date) - $(section): $(message)" % string.

Definition detach {A B : Type} (op_star_o_p_t_star : option string)
  : ((Lwt_io.input_channel * Lwt_io.output_channel) ->
    Lwt.t (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)))
    -> Lwt.t (t A B) :=
  let prefix :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun f =>
    Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq (Lwt_io.flush_all tt)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          match Lwt_io.pipe None None tt with
          | (main_in, child_out) =>
            match Lwt_io.pipe None None tt with
            | (child_in, main_out) =>
              match Lwt_unix.fork tt with
              | 0 =>
                Stdlib.op_colon_eq Lwt_log.default
                  (Lwt_log.channel (Some template) variant Lwt_io.stderr tt);
                Stdlib.Random.self_init tt;
                let template :=
                  Stdlib.Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          "$(message)" % string
                          CamlinternalFormatBasics.End_of_format))
                      "%s$(message)" % string) prefix in
                Lwt_main.run
                  (Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                    (Lwt_io.close main_in)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                          (Lwt_io.close main_out)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Stdlib.op_colon_eq Lwt_log.default
                                (Lwt_log.channel (Some template) variant
                                  Lwt_io.stderr tt);
                              Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                                (lwt_log_notice
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "PID: " % string
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        CamlinternalFormatBasics.End_of_format))
                                    "PID: %d" % string) (Unix.getpid tt))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    handle_error
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt => f (child_in, child_out)
                                        end)
                                  end)
                            end)
                      end));
                Stdlib.exit 0
              | pid =>
                let termination := wait pid in
                Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                  (Lwt_io.close child_in)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                        (Lwt_io.close child_out)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Lwt._return
                              {| termination := termination;
                                channel := (main_in, main_out) |}
                          end)
                    end)
              end
            end
          end
        end).

Definition signal_name : Z -> string :=
  let names :=
    cons (Stdlib.Sys.sigabrt, "ABRT" % string)
      (cons (Stdlib.Sys.sigalrm, "ALRM" % string)
        (cons (Stdlib.Sys.sigfpe, "FPE" % string)
          (cons (Stdlib.Sys.sighup, "HUP" % string)
            (cons (Stdlib.Sys.sigill, "ILL" % string)
              (cons (Stdlib.Sys.sigint, "INT" % string)
                (cons (Stdlib.Sys.sigkill, "KILL" % string)
                  (cons (Stdlib.Sys.sigpipe, "PIPE" % string)
                    (cons (Stdlib.Sys.sigquit, "QUIT" % string)
                      (cons (Stdlib.Sys.sigsegv, "SEGV" % string)
                        (cons (Stdlib.Sys.sigterm, "TERM" % string)
                          (cons (Stdlib.Sys.sigusr1, "USR1" % string)
                            (cons (Stdlib.Sys.sigusr2, "USR2" % string)
                              (cons (Stdlib.Sys.sigchld, "CHLD" % string)
                                (cons (Stdlib.Sys.sigcont, "CONT" % string)
                                  (cons (Stdlib.Sys.sigstop, "STOP" % string)
                                    (cons (Stdlib.Sys.sigtstp, "TSTP" % string)
                                      (cons
                                        (Stdlib.Sys.sigttin, "TTIN" % string)
                                        (cons
                                          (Stdlib.Sys.sigttou, "TTOU" % string)
                                          (cons
                                            (Stdlib.Sys.sigvtalrm,
                                              "VTALRM" % string)
                                            (cons
                                              (Stdlib.Sys.sigprof,
                                                "PROF" % string)
                                              (cons
                                                (Stdlib.Sys.sigbus,
                                                  "BUS" % string)
                                                (cons
                                                  (Stdlib.Sys.sigpoll,
                                                    "POLL" % string)
                                                  (cons
                                                    (Stdlib.Sys.sigsys,
                                                      "SYS" % string)
                                                    (cons
                                                      (Stdlib.Sys.sigtrap,
                                                        "TRAP" % string)
                                                      (cons
                                                        (Stdlib.Sys.sigurg,
                                                          "URG" % string)
                                                        (cons
                                                          (Stdlib.Sys.sigxcpu,
                                                            "XCPU" % string)
                                                          (cons
                                                            (Stdlib.Sys.sigxfsz,
                                                              "XFSZ" % string)
                                                            [])))))))))))))))))))))))))))
    in
  fun n => Tezos_base__TzPervasives.List.assoc n names.

Definition wait_all {A B : Type} (processes : list (t A B))
  : Lwt.t (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)) :=
  let fix loop {C : Type} (processes : list (Lwt.t (sum unit C)))
    : Lwt.t (option (C * (list (Lwt.t (sum unit C))))) :=
    match processes with
    | [] => Lwt.return_none
    | processes =>
      Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
        (Lwt.nchoose_split processes)
        (fun function_parameter =>
          match function_parameter with
          | (finished, remaining) =>
            let fix handle (function_parameter : list (sum unit C))
              : Lwt.t (option (C * (list (Lwt.t (sum unit C))))) :=
              match function_parameter with
              | [] => loop remaining
              | cons (inl tt) finished => handle finished
              | cons (inr err) _ => Lwt.return_some (err, remaining)
              end in
            handle finished
          end)
    end in
  Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
    (loop (Tezos_base__TzPervasives.List.map (fun p => termination p) processes))
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (lwt_log_info
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "All done!" % string
                CamlinternalFormatBasics.End_of_format) "All done!" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt.return_ok tt
            end)
      | Some (cons (Exn (Exited n)) [], remaining) =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Early error!" % string
                CamlinternalFormatBasics.End_of_format) "Early error!" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.List.iter Lwt.cancel remaining;
              Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                (Tezos_base__TzPervasives.Error_monad.join remaining)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_base__TzPervasives.Error_monad.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "A process finished with error " % string
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.String_literal
                              " !" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "A process finished with error %d !" % string) n
                  end)
            end)
      | Some (cons (Exn (Signaled n)) [], remaining) =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Early error!" % string
                CamlinternalFormatBasics.End_of_format) "Early error!" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.List.iter Lwt.cancel remaining;
              Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                (Tezos_base__TzPervasives.Error_monad.join remaining)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_base__TzPervasives.Error_monad.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "A process was killed by a SIG" % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              " !" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "A process was killed by a SIG%s !" % string)
                      (signal_name n)
                  end)
            end)
      | Some (cons (Exn (Stopped n)) [], remaining) =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Early error!" % string
                CamlinternalFormatBasics.End_of_format) "Early error!" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.List.iter Lwt.cancel remaining;
              Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                (Tezos_base__TzPervasives.Error_monad.join remaining)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_base__TzPervasives.Error_monad.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "A process was stopped by a SIG" % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              " !" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "A process was stopped by a SIG%s !" % string)
                      (signal_name n)
                  end)
            end)
      | Some (err, remaining) =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Unexpected error!" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))
              "@[<v 2>Unexpected error!@,%a@]" % string)
            Tezos_base__TzPervasives.Error_monad.pp_print_error err)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.List.iter Lwt.cancel remaining;
              Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
                (Tezos_base__TzPervasives.Error_monad.join remaining)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_base__TzPervasives.Error_monad.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "A process finished with an unexpected error !" %
                            string CamlinternalFormatBasics.End_of_format)
                        "A process finished with an unexpected error !" % string)
                  end)
            end)
      end).
src/lib_p2p/test/process.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

exception Exited of int

module Channel : sig
  type ('a, 'b) t

  val push : ('a, 'b) t -> 'a -> unit tzresult Lwt.t

  val pop : ('a, 'b) t -> 'b tzresult Lwt.t
end

type ('a, 'b) t = {
  termination : unit tzresult Lwt.t;
  channel : ('b, 'a) Channel.t;
}

val detach :
  ?prefix:string ->
  (('a, 'b) Channel.t -> unit tzresult Lwt.t) ->
  ('a, 'b) t Lwt.t

val wait_all : ('a, 'b) t list -> unit tzresult Lwt.t
src/lib_p2p/test/process.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

exception

Module Channel.
  Parameter t : forall (a b : Type), Type.
  
  Parameter push : forall {a b : Type}, (t a b) ->
    a -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit).
  
  Parameter pop : forall {a b : Type}, (t a b) ->
    Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult b).
End Channel.

Record t {a b : Type} := {
  termination : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit);
  channel : Channel.t b a }.
Arguments t : clear implicits.

Parameter detach : forall {a b : Type},
(option string) ->
  ((Channel.t a b) -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit))
    -> Lwt.t (t a b).

Parameter wait_all : forall {a b : Type},
(list (t a b)) -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit).
src/lib_p2p/test/test_p2p_banned_peers.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test-p2p-banned_peers"
end)

let assert_equal_bool ~msg a b = if a <> b then Alcotest.fail msg

let a (peer, addr) =
  (P2p_peer.Id.hash_string [peer], Ipaddr.V6.of_string_exn addr)

let foo = a ("foo", "ffff::3")

let bar = a ("bar", "ffff:00::ff")

let baz = a ("baz", "a::2")

let peers = [foo; bar; baz]

let test_empty _ =
  let empty = P2p_acl.create 10 in
  List.iter
    (fun (_peer, addr) ->
      assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr empty addr))
    peers ;
  Lwt.return_unit

let test_ban _ =
  let set = P2p_acl.create 10 in
  List.iter
    (fun (_, addr) -> P2p_acl.IPGreylist.add set addr Ptime.epoch)
    peers ;
  List.iter
    (fun (_, addr) ->
      assert_equal_bool ~msg:__LOC__ true (P2p_acl.banned_addr set addr))
    peers ;
  Lwt.return_unit

let test_gc _ =
  let set = P2p_acl.create 10 in
  List.iter
    (fun (_, addr) -> P2p_acl.IPGreylist.add set addr Ptime.epoch)
    peers ;
  List.iter
    (fun (_peer, addr) ->
      assert_equal_bool ~msg:__LOC__ true (P2p_acl.banned_addr set addr))
    peers ;
  (* remove all peers *)
  P2p_acl.IPGreylist.remove_old set ~older_than:Ptime.max ;
  List.iter
    (fun (_peer, addr) ->
      assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr set addr))
    peers ;
  Lwt.return_unit

let () =
  let init_logs = lazy (Internal_event_unix.init ()) in
  let wrap (n, f) =
    Alcotest_lwt.test_case n `Quick (fun _ () ->
        Lazy.force init_logs >>= fun () -> f ())
  in
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p.peerset",
        List.map
          wrap
          [("empty", test_empty); ("ban", test_ban); ("gc", test_gc)] ) ]
src/lib_p2p/test/test_p2p_banned_peers.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition assert_equal_bool {A B : Type} (msg : A) (a : B) (b : B) : unit :=
  if nequiv_decb a b then
    op_star_t_y_p_e_minus_e_r_r_o_r_star msg
  else
    tt.

Definition a (function_parameter : string * string)
  : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
  match function_parameter with
  | (peer, addr) =>
    ((Tezos_base__TzPervasives.P2p_peer.Id.hash_string None (cons peer [])),
      (Ipaddr.V6.of_string_exn addr))
  end.

Definition foo : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
  a ("foo" % string, "ffff::3" % string).

Definition bar : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
  a ("bar" % string, "ffff:00::ff" % string).

Definition baz : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
  a ("baz" % string, "a::2" % string).

Definition peers
  : list (Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t) :=
  cons foo (cons bar (cons baz [])).

Definition test_empty {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ =>
    let empty := Tezos_p2p.P2p_acl.create 10 in
    Tezos_base__TzPervasives.List.iter
      (fun function_parameter =>
        match function_parameter with
        | (_peer, addr) =>
          assert_equal_bool Stdlib.__LOC__ false
            (Tezos_p2p.P2p_acl.banned_addr empty addr)
        end) peers;
    Lwt.return_unit
  end.

Definition test_ban {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ =>
    let set := Tezos_p2p.P2p_acl.create 10 in
    Tezos_base__TzPervasives.List.iter
      (fun function_parameter =>
        match function_parameter with
        | (_, addr) => Tezos_p2p.P2p_acl.IPGreylist.add set addr Ptime.epoch
        end) peers;
    Tezos_base__TzPervasives.List.iter
      (fun function_parameter =>
        match function_parameter with
        | (_, addr) =>
          assert_equal_bool Stdlib.__LOC__ true
            (Tezos_p2p.P2p_acl.banned_addr set addr)
        end) peers;
    Lwt.return_unit
  end.

Definition test_gc {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ =>
    let set := Tezos_p2p.P2p_acl.create 10 in
    Tezos_base__TzPervasives.List.iter
      (fun function_parameter =>
        match function_parameter with
        | (_, addr) => Tezos_p2p.P2p_acl.IPGreylist.add set addr Ptime.epoch
        end) peers;
    Tezos_base__TzPervasives.List.iter
      (fun function_parameter =>
        match function_parameter with
        | (_peer, addr) =>
          assert_equal_bool Stdlib.__LOC__ true
            (Tezos_p2p.P2p_acl.banned_addr set addr)
        end) peers;
    Tezos_p2p.P2p_acl.IPGreylist.remove_old set Ptime.max;
    Tezos_base__TzPervasives.List.iter
      (fun function_parameter =>
        match function_parameter with
        | (_peer, addr) =>
          assert_equal_bool Stdlib.__LOC__ false
            (Tezos_p2p.P2p_acl.banned_addr set addr)
        end) peers;
    Lwt.return_unit
  end.
src/lib_p2p/test/test_p2p_io_scheduler.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test-p2p-io-scheduler"
end)

exception Error of error list

let rec listen ?port addr =
  let tentative_port =
    match port with None -> 1024 + Random.int 8192 | Some port -> port
  in
  let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
  let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
  Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
  Lwt.catch
    (fun () ->
      Lwt_unix.bind main_socket (ADDR_INET (uaddr, tentative_port))
      >>= fun () ->
      Lwt_unix.listen main_socket 50 ;
      Lwt.return (main_socket, tentative_port))
    (function
      | Unix.Unix_error ((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _)
        when port = None ->
          listen addr
      | exn ->
          Lwt.fail exn)

let accept main_socket =
  P2p_fd.accept main_socket >>= fun (fd, _sockaddr) -> return fd

let rec accept_n main_socket n =
  if n <= 0 then return_nil
  else
    accept_n main_socket (n - 1)
    >>=? fun acc -> accept main_socket >>=? fun conn -> return (conn :: acc)

let connect addr port =
  let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
  let uaddr = Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
  P2p_fd.connect fd uaddr >>= fun () -> return fd

let simple_msgs =
  [| Bytes.create (1 lsl 6);
     Bytes.create (1 lsl 7);
     Bytes.create (1 lsl 8);
     Bytes.create (1 lsl 9);
     Bytes.create (1 lsl 10);
     Bytes.create (1 lsl 11);
     Bytes.create (1 lsl 12);
     Bytes.create (1 lsl 13);
     Bytes.create (1 lsl 14);
     Bytes.create (1 lsl 15);
     Bytes.create (1 lsl 16) |]

let nb_simple_msgs = Array.length simple_msgs

let receive conn =
  let buf = Bytes.create (1 lsl 16) in
  let rec loop () =
    P2p_io_scheduler.read conn buf
    >>= function
    | Ok _ ->
        loop ()
    | Error (P2p_errors.Connection_closed :: _) ->
        Lwt.return_unit
    | Error err ->
        Lwt.fail (Error err)
  in
  loop ()

let server ?(display_client_stat = true) ?max_download_speed ?read_queue_size
    ~read_buffer_size main_socket n =
  let sched =
    P2p_io_scheduler.create
      ?max_download_speed
      ?read_queue_size
      ~read_buffer_size
      ()
  in
  Moving_average.on_update (fun () ->
      log_notice "Stat: %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ;
      if display_client_stat then
        P2p_io_scheduler.iter_connection sched (fun conn ->
            log_notice
              " client(%d) %a"
              (P2p_io_scheduler.id conn)
              P2p_stat.pp
              (P2p_io_scheduler.stat conn))) ;
  (* Accept and read message until the connection is closed. *)
  accept_n main_socket n
  >>=? fun conns ->
  let conns = List.map (P2p_io_scheduler.register sched) conns in
  Lwt.join (List.map receive conns)
  >>= fun () ->
  iter_p P2p_io_scheduler.close conns
  >>=? fun () ->
  log_notice "OK %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ;
  return_unit

let max_size ?max_upload_speed () =
  match max_upload_speed with
  | None ->
      nb_simple_msgs
  | Some max_upload_speed ->
      let rec loop n =
        if n <= 1 then 1
        else if Bytes.length simple_msgs.(n - 1) <= max_upload_speed then n
        else loop (n - 1)
      in
      loop nb_simple_msgs

let rec send conn nb_simple_msgs =
  Lwt_main.yield ()
  >>= fun () ->
  let msg = simple_msgs.(Random.int nb_simple_msgs) in
  P2p_io_scheduler.write conn msg >>=? fun () -> send conn nb_simple_msgs

let client ?max_upload_speed ?write_queue_size addr port time _n =
  let sched =
    P2p_io_scheduler.create
      ?max_upload_speed
      ?write_queue_size
      ~read_buffer_size:(1 lsl 12)
      ()
  in
  connect addr port
  >>=? fun conn ->
  let conn = P2p_io_scheduler.register sched conn in
  let nb_simple_msgs = max_size ?max_upload_speed () in
  Lwt.pick [send conn nb_simple_msgs; Lwt_unix.sleep time >>= return]
  >>=? fun () ->
  P2p_io_scheduler.close conn
  >>=? fun () ->
  let stat = P2p_io_scheduler.stat conn in
  lwt_log_notice "Client OK %a" P2p_stat.pp stat >>= fun () -> return_unit

let run ?display_client_stat ?max_download_speed ?max_upload_speed
    ~read_buffer_size ?read_queue_size ?write_queue_size addr port time n =
  Internal_event_unix.init ()
  >>= fun () ->
  listen ?port addr
  >>= fun (main_socket, port) ->
  Process.detach ~prefix:"server: " (fun _ ->
      server
        ?display_client_stat
        ?max_download_speed
        ~read_buffer_size
        ?read_queue_size
        main_socket
        n)
  >>= fun server_node ->
  let client n =
    let prefix = Printf.sprintf "client(%d): " n in
    Process.detach ~prefix (fun _ ->
        Lwt_utils_unix.safe_close main_socket
        >>= fun () ->
        client ?max_upload_speed ?write_queue_size addr port time n)
  in
  Lwt_list.map_p client (1 -- n)
  >>= fun client_nodes -> Process.wait_all (server_node :: client_nodes)

let () = Random.self_init ()

let addr = ref Ipaddr.V6.localhost

let port = ref None

let max_download_speed = ref None

let max_upload_speed = ref None

let read_buffer_size = ref (1 lsl 14)

let read_queue_size = ref (Some (1 lsl 14))

let write_queue_size = ref (Some (1 lsl 14))

let delay = ref 60.

let clients = ref 8

let display_client_stat = ref None

let spec =
  Arg.
    [ ("--port", Int (fun p -> port := Some p), " Listening port");
      ( "--addr",
        String (fun p -> addr := Ipaddr.V6.of_string_exn p),
        " Listening addr" );
      ( "--max-download-speed",
        Int (fun i -> max_download_speed := Some i),
        " Max download speed in B/s (default: unbounded)" );
      ( "--max-upload-speed",
        Int (fun i -> max_upload_speed := Some i),
        " Max upload speed in B/s (default: unbounded)" );
      ( "--read-buffer-size",
        Set_int read_buffer_size,
        " Size of the read buffers" );
      ( "--read-queue-size",
        Int (fun i -> read_queue_size := if i <= 0 then None else Some i),
        " Size of the read queue (0=unbounded)" );
      ( "--write-queue-size",
        Int (fun i -> write_queue_size := if i <= 0 then None else Some i),
        " Size of the write queue (0=unbounded)" );
      ("--delay", Set_float delay, " Client execution time.");
      ("--clients", Set_int clients, " Number of concurrent clients.");
      ( "--hide-clients-stat",
        Unit (fun () -> display_client_stat := Some false),
        " Hide the client bandwidth statistic." );
      ( "--display_clients_stat",
        Unit (fun () -> display_client_stat := Some true),
        " Display the client bandwidth statistic." ) ]

let () =
  let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
  let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
  Arg.parse spec anon_fun usage_msg

let init_logs = lazy (Internal_event_unix.init ())

let wrap n f =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lazy.force init_logs
      >>= fun () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p.io-scheduler",
        [ wrap "trivial-quota" (fun () ->
              run
                ?display_client_stat:!display_client_stat
                ?max_download_speed:!max_download_speed
                ?max_upload_speed:!max_upload_speed
                ~read_buffer_size:!read_buffer_size
                ?read_queue_size:!read_queue_size
                ?write_queue_size:!write_queue_size
                !addr
                !port
                !delay
                !clients) ] ) ]
src/lib_p2p/test/test_p2p_io_scheduler.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Fixpoint listen (port : option Z) (addr : Ipaddr.V6.t)
  : Lwt.t (Lwt_unix.file_descr * Z) :=
  let tentative_port :=
    match port with
    | None => Z.add 1024 (Stdlib.Random.int 8192)
    | Some port => port
    end in
  let uaddr := Ipaddr_unix.V6.to_inet_addr addr in
  let main_socket := Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
  Lwt_unix.setsockopt main_socket SO_REUSEADDR true;
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Lwt_unix.bind main_socket (ADDR_INET uaddr tentative_port))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Lwt_unix.listen main_socket 50;
              Lwt._return (main_socket, tentative_port)
            end)
      end)
    (fun function_parameter =>
      match function_parameter with
      | Unix.Unix_error (Unix.EADDRINUSE | Unix.EADDRNOTAVAIL) _ _ =>
        listen None addr
      | exn => Lwt.fail exn
      end).

Definition accept (main_socket : Lwt_unix.file_descr)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_p2p.P2p_fd.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_p2p.P2p_fd.accept main_socket)
    (fun function_parameter =>
      match function_parameter with
      | (fd, _sockaddr) => Tezos_base__TzPervasives._return fd
      end).

Fixpoint accept_n (main_socket : Lwt_unix.file_descr) (n : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (list Tezos_p2p.P2p_fd.t)) :=
  if OCaml.Stdlib.le n 0 then
    Tezos_base__TzPervasives.return_nil
  else
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (accept_n main_socket (Z.sub n 1))
      (fun acc =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question (accept main_socket)
          (fun conn => Tezos_base__TzPervasives._return (cons conn acc))).

Definition connect (addr : Ipaddr.V6.t) (port : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_p2p.P2p_fd.t) :=
  let fd := Tezos_p2p.P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
  let uaddr := Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port in
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_p2p.P2p_fd.connect fd uaddr)
    (fun function_parameter =>
      match function_parameter with
      | tt => Tezos_base__TzPervasives._return fd
      end).

Definition simple_msgs : array string :=
  ((Stdlib.Bytes.create (Z.shiftl 1 6)), (Stdlib.Bytes.create (Z.shiftl 1 7)),
    (Stdlib.Bytes.create (Z.shiftl 1 8)), (Stdlib.Bytes.create (Z.shiftl 1 9)),
    (Stdlib.Bytes.create (Z.shiftl 1 10)),
    (Stdlib.Bytes.create (Z.shiftl 1 11)),
    (Stdlib.Bytes.create (Z.shiftl 1 12)),
    (Stdlib.Bytes.create (Z.shiftl 1 13)),
    (Stdlib.Bytes.create (Z.shiftl 1 14)),
    (Stdlib.Bytes.create (Z.shiftl 1 15)), (Stdlib.Bytes.create (Z.shiftl 1 16))).

Definition nb_simple_msgs : Z := Stdlib.Array.length simple_msgs.

Definition receive (conn : Tezos_p2p.P2p_io_scheduler.connection)
  : Lwt.t unit :=
  let buf := Stdlib.Bytes.create (Z.shiftl 1 16) in
  let fix loop (function_parameter : unit) : Lwt.t unit :=
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_p2p.P2p_io_scheduler.read None conn None None buf)
        (fun function_parameter =>
          match function_parameter with
          | inl _ => loop tt
          | inr (cons P2p_errors.Connection_closed _) => Lwt.return_unit
          | inr err => Lwt.fail (inr err)
          end)
    end in
  loop tt.

Definition server (op_star_o_p_t_star : option bool)
  : (option Z) ->
    (option Z) ->
      Z ->
        Lwt_unix.file_descr ->
          Z -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let display_client_stat :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun max_download_speed =>
    fun read_queue_size =>
      fun read_buffer_size =>
        fun main_socket =>
          fun n =>
            let sched :=
              Tezos_p2p.P2p_io_scheduler.create None max_download_speed
                read_queue_size None read_buffer_size tt in
            Tezos_stdlib_unix.Moving_average.on_update
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  log_notice
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "Stat: " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))
                      "Stat: %a" % string) Tezos_base__TzPervasives.P2p_stat.pp
                    (Tezos_p2p.P2p_io_scheduler.global_stat sched);
                  if display_client_stat then
                    Tezos_p2p.P2p_io_scheduler.iter_connection sched
                      (fun conn =>
                        log_notice
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              " client(" % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.String_literal
                                  ") " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))))
                            " client(%d) %a" % string)
                          (Tezos_p2p.P2p_io_scheduler.id conn)
                          Tezos_base__TzPervasives.P2p_stat.pp
                          (Tezos_p2p.P2p_io_scheduler.stat conn))
                  else
                    tt
                end);
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (accept_n main_socket n)
              (fun conns =>
                let conns :=
                  Tezos_base__TzPervasives.List.map
                    (Tezos_p2p.P2p_io_scheduler.register sched) conns in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Lwt.join (Tezos_base__TzPervasives.List.map receive conns))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_base__TzPervasives.iter_p
                          (let arg := Tezos_p2p.P2p_io_scheduler.close in
                          fun eta => arg None eta) conns)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            log_notice
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "OK " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))
                                "OK %a" % string)
                              Tezos_base__TzPervasives.P2p_stat.pp
                              (Tezos_p2p.P2p_io_scheduler.global_stat sched);
                            Tezos_base__TzPervasives.return_unit
                          end)
                    end)).

Definition max_size (max_upload_speed : option Z) (function_parameter : unit)
  : Z :=
  match function_parameter with
  | tt =>
    match max_upload_speed with
    | None => nb_simple_msgs
    | Some max_upload_speed =>
      let fix loop (n : Z) : Z :=
        if OCaml.Stdlib.le n 1 then
          1
        else
          if
            OCaml.Stdlib.le
              (String.length (Stdlib.Array.get simple_msgs (Z.sub n 1)))
              max_upload_speed then
            n
          else
            loop (Z.sub n 1) in
      loop nb_simple_msgs
    end
  end.

Fixpoint send {A : Type}
  (conn : Tezos_p2p.P2p_io_scheduler.connection) (nb_simple_msgs : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_main.yield tt)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let msg :=
          Stdlib.Array.get simple_msgs (Stdlib.Random.int nb_simple_msgs) in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_io_scheduler.write None conn msg)
          (fun function_parameter =>
            match function_parameter with
            | tt => send conn nb_simple_msgs
            end)
      end).

Definition client {A : Type}
  (max_upload_speed : option Z) (write_queue_size : option Z)
  (addr : Ipaddr.V6.t) (port : Z) (time : float) (_n : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let sched :=
    Tezos_p2p.P2p_io_scheduler.create max_upload_speed None None
      write_queue_size (Z.shiftl 1 12) tt in
  Tezos_base__TzPervasives.op_gt_gt_eq_question (connect addr port)
    (fun conn =>
      let conn := Tezos_p2p.P2p_io_scheduler.register sched conn in
      let nb_simple_msgs := max_size max_upload_speed tt in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Lwt.pick
          (cons (send conn nb_simple_msgs)
            (cons
              (Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.sleep time)
                Tezos_base__TzPervasives._return) [])))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_p2p.P2p_io_scheduler.close None conn)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  let stat := Tezos_p2p.P2p_io_scheduler.stat conn in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_log_notice
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Client OK " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        "Client OK %a" % string)
                      Tezos_base__TzPervasives.P2p_stat.pp stat)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end)
          end)).

Definition run {A : Type}
  (display_client_stat : option bool) (max_download_speed : option Z)
  (max_upload_speed : option Z) (read_buffer_size : Z)
  (read_queue_size : option Z) (write_queue_size : option Z)
  (addr : Ipaddr.V6.t) (port : option Z) (time : float) (n : Z) : Lwt.t A :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_stdlib_unix.Internal_event_unix.init None None tt)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq (listen port addr)
          (fun function_parameter =>
            match function_parameter with
            | (main_socket, port) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (op_star_t_y_p_e_minus_e_r_r_o_r_star "server: " % string
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      server display_client_stat max_download_speed
                        read_queue_size read_buffer_size main_socket n
                    end))
                (fun server_node =>
                  let client {B : Type} (n : Z) : B :=
                    let prefix :=
                      Stdlib.Printf.sprintf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "client(" % string
                            (CamlinternalFormatBasics.Int
                              CamlinternalFormatBasics.Int_d
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.No_precision
                              (CamlinternalFormatBasics.String_literal
                                "): " % string
                                CamlinternalFormatBasics.End_of_format)))
                          "client(%d): " % string) n in
                    op_star_t_y_p_e_minus_e_r_r_o_r_star prefix
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_stdlib_unix.Lwt_utils_unix.safe_close
                              main_socket)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                client max_upload_speed write_queue_size addr
                                  port time n
                              end)
                        end) in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Lwt_list.map_p client
                      (Tezos_base__TzPervasives.op_minus_minus 1 n))
                    (fun client_nodes =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (cons server_node client_nodes)))
            end)
      end).

Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.

Definition port : Stdlib.ref (option Z) := Stdlib.ref None.

Definition max_download_speed : Stdlib.ref (option Z) := Stdlib.ref None.

Definition max_upload_speed : Stdlib.ref (option Z) := Stdlib.ref None.

Definition read_buffer_size : Stdlib.ref Z := Stdlib.ref (Z.shiftl 1 14).

Definition read_queue_size : Stdlib.ref (option Z) :=
  Stdlib.ref (Some (Z.shiftl 1 14)).

Definition write_queue_size : Stdlib.ref (option Z) :=
  Stdlib.ref (Some (Z.shiftl 1 14)).

Definition delay : Stdlib.ref float := Stdlib.ref 60.

Definition clients : Stdlib.ref Z := Stdlib.ref 8.

Definition display_client_stat : Stdlib.ref (option bool) := Stdlib.ref None.

Definition spec : list (string * Stdlib.Arg.spec * string) :=
  cons
    ("--port" % string, (Int (fun p => Stdlib.op_colon_eq port (Some p))),
      " Listening port" % string)
    (cons
      ("--addr" % string,
        (String (fun p => Stdlib.op_colon_eq addr (Ipaddr.V6.of_string_exn p))),
        " Listening addr" % string)
      (cons
        ("--max-download-speed" % string,
          (Int (fun i => Stdlib.op_colon_eq max_download_speed (Some i))),
          " Max download speed in B/s (default: unbounded)" % string)
        (cons
          ("--max-upload-speed" % string,
            (Int (fun i => Stdlib.op_colon_eq max_upload_speed (Some i))),
            " Max upload speed in B/s (default: unbounded)" % string)
          (cons
            ("--read-buffer-size" % string, (Set_int read_buffer_size),
              " Size of the read buffers" % string)
            (cons
              ("--read-queue-size" % string,
                (Int
                  (fun i =>
                    Stdlib.op_colon_eq read_queue_size
                      (if OCaml.Stdlib.le i 0 then
                        None
                      else
                        Some i))),
                " Size of the read queue (0=unbounded)" % string)
              (cons
                ("--write-queue-size" % string,
                  (Int
                    (fun i =>
                      Stdlib.op_colon_eq write_queue_size
                        (if OCaml.Stdlib.le i 0 then
                          None
                        else
                          Some i))),
                  " Size of the write queue (0=unbounded)" % string)
                (cons
                  ("--delay" % string, (Set_float delay),
                    " Client execution time." % string)
                  (cons
                    ("--clients" % string, (Set_int clients),
                      " Number of concurrent clients." % string)
                    (cons
                      ("--hide-clients-stat" % string,
                        (Unit
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Stdlib.op_colon_eq display_client_stat
                                (Some false)
                            end)),
                        " Hide the client bandwidth statistic." % string)
                      (cons
                        ("--display_clients_stat" % string,
                          (Unit
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Stdlib.op_colon_eq display_client_stat
                                  (Some true)
                              end)),
                          " Display the client bandwidth statistic." % string)
                        [])))))))))).

Definition init_logs : lazy_t (Lwt.t unit) :=
  Tezos_stdlib_unix.Internal_event_unix.init None None tt.

Definition wrap {A B : Type}
  (n : A) (f : unit -> Lwt.t (sum unit (list Tezos_base__TzPervasives.error)))
  : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq (Stdlib.Lazy.force init_logs)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (f tt)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl tt => Lwt.return_unit
                      | inr error =>
                        Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string)
                          Tezos_base__TzPervasives.pp_print_error error
                      end)
                end)
          end
      end).
src/lib_p2p/test/test_p2p_ipv6set.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test-p2p-banned_ip"
end)

let assert_equal ?(eq = ( = )) ?prn ~msg a b =
  let msg =
    match prn with
    | None ->
        msg
    | Some prn ->
        Format.asprintf "@[<v 2>%s@,n(%a)@,<>@,(%a)@]" msg prn a prn b
  in
  if not (eq a b) then Alcotest.fail msg

let assert_equal_bool = assert_equal

let a = Ipaddr.V6.of_string_exn

let p = Ipaddr.V6.Prefix.of_string_exn

let timenow = Systime_os.now ()

let of_list l =
  List.fold_left
    (fun acc k -> P2p_acl.IpSet.add_prefix k timenow acc)
    P2p_acl.IpSet.empty
    l

let test_empty _ =
  let addrs = List.map a ["::"; "ffff::"; "a::2"] in
  List.iter
    (fun addr ->
      assert_equal_bool
        ~msg:__LOC__
        false
        (P2p_acl.IpSet.mem addr P2p_acl.IpSet.empty))
    addrs

let test_inclusion _ =
  let set =
    P2p_acl.IpSet.add_prefix (p "ffff::/16") timenow P2p_acl.IpSet.empty
  in
  let included = List.map a ["ffff::3"; "ffff:ffff::"; "ffff:00::ff"] in
  let not_included = List.map a ["fffe::3"; "ffee:ffff::"; "::"] in
  List.iter
    (fun addr ->
      assert_equal_bool ~msg:__LOC__ true (P2p_acl.IpSet.mem addr set))
    included ;
  List.iter
    (fun addr ->
      assert_equal_bool ~msg:__LOC__ false (P2p_acl.IpSet.mem addr set))
    not_included ;
  let set =
    P2p_acl.IpSet.add_prefix (p "f000::/4") timenow P2p_acl.IpSet.empty
  in
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "e000::") set) ;
  (* Add one IP *)
  let set =
    P2p_acl.IpSet.add_prefix (p "::/128") timenow P2p_acl.IpSet.empty
  in
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "1::") set) ;
  let set =
    P2p_acl.IpSet.add_prefix (p "ffff:eeee::/32") timenow P2p_acl.IpSet.empty
  in
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "eeee:ffff::1") set) ;
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "ffff:eeee::1") set) ;
  let set = P2p_acl.IpSet.add_prefix (p "::/17") timenow P2p_acl.IpSet.empty in
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "0000:0000::") set) ;
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "0000:7000::") set) ;
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "0000:8000::1") set) ;
  let setlist = [p "e000::/4"; p "a000::/4"; p "ffff::/16"] in
  let set = of_list setlist in
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "ffff::1") set) ;
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "a111:8000::1") set) ;
  let set =
    of_list [p "e000::/4"; p "a000::/4"; p "1234:5678::1/128"; p "ffff::/16"]
  in
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "1234:5678::1") set) ;
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "a111:8000::1") set) ;
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "b111:8000::1") set) ;
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "1234:5678::100") set)

let test_contiguous _ =
  let set = of_list [p "::/1"; p "8000::/1"] in
  List.iter
    (fun addr -> assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem addr set))
    [a "00::"; a "01::"; a "ff::"]

module PSet = Set.Make (Ipaddr.V6.Prefix)

let test_fold _ =
  let addr_list = [p "::/1"; p "8000::/1"; p "ffff:ffff::/32"] in
  let pset = PSet.of_list addr_list in
  let ipv6set =
    P2p_acl.IpSet.fold
      (fun prefix _value s -> PSet.add prefix s)
      (of_list addr_list)
      PSet.empty
  in
  assert_equal ~eq:PSet.equal ~msg:__LOC__ ipv6set pset

let print_pset ppf pset =
  PSet.iter (fun p -> Format.fprintf ppf "%a " Ipaddr.V6.Prefix.pp p) pset

let print_list ppf l =
  List.iter (fun p -> Format.fprintf ppf "%a " Ipaddr.V6.Prefix.pp p) l

let test_to_list _ =
  let to_list s = P2p_acl.IpSet.fold (fun k _v acc -> k :: acc) s [] in
  let list_eq = List.for_all2 (fun x y -> Ipaddr.V6.Prefix.compare x y = 0) in
  let assert_equal_set ~msg a b =
    let a = List.sort compare a in
    let b = List.sort compare (to_list b) in
    assert_equal ~prn:print_list ~eq:list_eq ~msg a b
  in
  let set = P2p_acl.IpSet.add_prefix (p "::/0") timenow P2p_acl.IpSet.empty in
  assert_equal
    ~eq:list_eq
    ~prn:print_list
    ~msg:__LOC__
    [p "::/0"]
    (to_list set) ;
  let set = of_list [p "::/1"; p "8000::/1"] in
  assert_equal
    ~eq:list_eq
    ~prn:print_list
    ~msg:__LOC__
    [p "8000::/1"; p "::/1"]
    (to_list set) ;
  let setlist = [p "1234:5678::/32"] in
  let set = of_list setlist in
  assert_equal_set ~msg:__LOC__ setlist set ;
  let setlist =
    [p "e000::/4"; p "a000::/4"; p "ffff::/16"; p "1234:5678::/32"]
  in
  let set = of_list setlist in
  assert_equal_set ~msg:__LOC__ setlist set

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p.ipv6set",
        [ ("empty", `Quick, test_empty);
          ("inclusion", `Quick, test_inclusion);
          ("contiguous", `Quick, test_contiguous);
          ("test_fold", `Quick, test_fold);
          ("to_list", `Quick, test_to_list) ] ) ]
src/lib_p2p/test/test_p2p_ipv6set.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition assert_equal {A : Type}
  (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (Stdlib.Format.formatter -> A -> unit)) -> string -> A -> A -> unit :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun prn =>
    fun msg =>
      fun a =>
        fun b =>
          let msg :=
            match prn with
            | None => msg
            | Some prn =>
              Stdlib.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal "n(" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "<>" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Char_literal
                                      "(" % char
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          ")" % char
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))))))))))
                  "@[<v 2>%s@,n(%a)@,<>@,(%a)@]" % string) msg prn a prn b
            end in
          if negb (eq a b) then
            op_star_t_y_p_e_minus_e_r_r_o_r_star msg
          else
            tt.

Definition assert_equal_bool {A : Type}
  : (option (A -> A -> bool)) ->
    (option (Stdlib.Format.formatter -> A -> unit)) -> string -> A -> A -> unit :=
  assert_equal.

Definition a : string -> Ipaddr.V6.t := Ipaddr.V6.of_string_exn.

Definition p : string -> Ipaddr.V6.Prefix.t := Ipaddr.V6.Prefix.of_string_exn.

Definition timenow : Ptime.t := Tezos_stdlib_unix.Systime_os.now tt.

Definition of_list (l : list Ipaddr.V6.Prefix.t) : Tezos_p2p.P2p_acl.IpSet.t :=
  Tezos_base__TzPervasives.List.fold_left
    (fun acc => fun k => Tezos_p2p.P2p_acl.IpSet.add_prefix k timenow acc)
    Tezos_p2p.P2p_acl.IpSet.empty l.

Definition test_empty {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let addrs :=
      Tezos_base__TzPervasives.List.map a
        (cons "::" % string (cons "ffff::" % string (cons "a::2" % string [])))
      in
    Tezos_base__TzPervasives.List.iter
      (fun addr =>
        assert_equal_bool None None Stdlib.__LOC__ false
          (Tezos_p2p.P2p_acl.IpSet.mem addr Tezos_p2p.P2p_acl.IpSet.empty))
      addrs
  end.

Definition test_inclusion {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let set :=
      Tezos_p2p.P2p_acl.IpSet.add_prefix (p "ffff::/16" % string) timenow
        Tezos_p2p.P2p_acl.IpSet.empty in
    let included :=
      Tezos_base__TzPervasives.List.map a
        (cons "ffff::3" % string
          (cons "ffff:ffff::" % string (cons "ffff:00::ff" % string []))) in
    let not_included :=
      Tezos_base__TzPervasives.List.map a
        (cons "fffe::3" % string
          (cons "ffee:ffff::" % string (cons "::" % string []))) in
    Tezos_base__TzPervasives.List.iter
      (fun addr =>
        assert_equal_bool None None Stdlib.__LOC__ true
          (Tezos_p2p.P2p_acl.IpSet.mem addr set)) included;
    Tezos_base__TzPervasives.List.iter
      (fun addr =>
        assert_equal_bool None None Stdlib.__LOC__ false
          (Tezos_p2p.P2p_acl.IpSet.mem addr set)) not_included;
    let set :=
      Tezos_p2p.P2p_acl.IpSet.add_prefix (p "f000::/4" % string) timenow
        Tezos_p2p.P2p_acl.IpSet.empty in
    assert_equal None None Stdlib.__LOC__ false
      (Tezos_p2p.P2p_acl.IpSet.mem (a "e000::" % string) set);
    let set :=
      Tezos_p2p.P2p_acl.IpSet.add_prefix (p "::/128" % string) timenow
        Tezos_p2p.P2p_acl.IpSet.empty in
    assert_equal None None Stdlib.__LOC__ false
      (Tezos_p2p.P2p_acl.IpSet.mem (a "1::" % string) set);
    let set :=
      Tezos_p2p.P2p_acl.IpSet.add_prefix (p "ffff:eeee::/32" % string) timenow
        Tezos_p2p.P2p_acl.IpSet.empty in
    assert_equal None None Stdlib.__LOC__ false
      (Tezos_p2p.P2p_acl.IpSet.mem (a "eeee:ffff::1" % string) set);
    assert_equal None None Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.IpSet.mem (a "ffff:eeee::1" % string) set);
    let set :=
      Tezos_p2p.P2p_acl.IpSet.add_prefix (p "::/17" % string) timenow
        Tezos_p2p.P2p_acl.IpSet.empty in
    assert_equal None None Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.IpSet.mem (a "0000:0000::" % string) set);
    assert_equal None None Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.IpSet.mem (a "0000:7000::" % string) set);
    assert_equal None None Stdlib.__LOC__ false
      (Tezos_p2p.P2p_acl.IpSet.mem (a "0000:8000::1" % string) set);
    let setlist :=
      cons (p "e000::/4" % string)
        (cons (p "a000::/4" % string) (cons (p "ffff::/16" % string) [])) in
    let set := of_list setlist in
    assert_equal None None Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.IpSet.mem (a "ffff::1" % string) set);
    assert_equal None None Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.IpSet.mem (a "a111:8000::1" % string) set);
    let set :=
      of_list
        (cons (p "e000::/4" % string)
          (cons (p "a000::/4" % string)
            (cons (p "1234:5678::1/128" % string)
              (cons (p "ffff::/16" % string) [])))) in
    assert_equal None None Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.IpSet.mem (a "1234:5678::1" % string) set);
    assert_equal None None Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.IpSet.mem (a "a111:8000::1" % string) set);
    assert_equal None None Stdlib.__LOC__ false
      (Tezos_p2p.P2p_acl.IpSet.mem (a "b111:8000::1" % string) set);
    assert_equal None None Stdlib.__LOC__ false
      (Tezos_p2p.P2p_acl.IpSet.mem (a "1234:5678::100" % string) set)
  end.

Definition test_contiguous {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let set :=
      of_list (cons (p "::/1" % string) (cons (p "8000::/1" % string) [])) in
    Tezos_base__TzPervasives.List.iter
      (fun addr =>
        assert_equal None None Stdlib.__LOC__ true
          (Tezos_p2p.P2p_acl.IpSet.mem addr set))
      (cons (a "00::" % string)
        (cons (a "01::" % string) (cons (a "ff::" % string) [])))
  end.

Definition test_fold {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let addr_list :=
      cons (p "::/1" % string)
        (cons (p "8000::/1" % string) (cons (p "ffff:ffff::/32" % string) []))
      in
    let pset := PSet.of_list addr_list in
    let ipv6set :=
      Tezos_p2p.P2p_acl.IpSet.fold
        (fun prefix => fun _value => fun s => PSet.add prefix s)
        (of_list addr_list) PSet.empty in
    assert_equal (Some PSet.equal) None Stdlib.__LOC__ ipv6set pset
  end.

Definition print_pset (ppf : Stdlib.Format.formatter) (pset : PSet.t) : unit :=
  PSet.iter
    (fun p =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal " " % char
              CamlinternalFormatBasics.End_of_format)) "%a " % string)
        Ipaddr.V6.Prefix.pp p) pset.

Definition print_list
  (ppf : Stdlib.Format.formatter) (l : list Ipaddr.V6.Prefix.t) : unit :=
  Tezos_base__TzPervasives.List.iter
    (fun p =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal " " % char
              CamlinternalFormatBasics.End_of_format)) "%a " % string)
        Ipaddr.V6.Prefix.pp p) l.

Definition test_to_list {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let to_list (s : Tezos_p2p.P2p_acl.IpSet.t) : list Ipaddr.V6.Prefix.t :=
      Tezos_p2p.P2p_acl.IpSet.fold (fun k => fun _v => fun acc => cons k acc) s
        [] in
    let list_eq :=
      Tezos_base__TzPervasives.List.for_all2
        (fun x => fun y => equiv_decb (Ipaddr.V6.Prefix.compare x y) 0) in
    let assert_equal_set
      (msg : string) (a : list Ipaddr.V6.Prefix.t) (b :
      Tezos_p2p.P2p_acl.IpSet.t) : unit :=
      let a := Tezos_base__TzPervasives.List.sort OCaml.Stdlib.compare a in
      let b :=
        Tezos_base__TzPervasives.List.sort OCaml.Stdlib.compare (to_list b) in
      assert_equal (Some list_eq) (Some print_list) msg a b in
    let set :=
      Tezos_p2p.P2p_acl.IpSet.add_prefix (p "::/0" % string) timenow
        Tezos_p2p.P2p_acl.IpSet.empty in
    assert_equal (Some list_eq) (Some print_list) Stdlib.__LOC__
      (cons (p "::/0" % string) []) (to_list set);
    let set :=
      of_list (cons (p "::/1" % string) (cons (p "8000::/1" % string) [])) in
    assert_equal (Some list_eq) (Some print_list) Stdlib.__LOC__
      (cons (p "8000::/1" % string) (cons (p "::/1" % string) [])) (to_list set);
    let setlist := cons (p "1234:5678::/32" % string) [] in
    let set := of_list setlist in
    assert_equal_set Stdlib.__LOC__ setlist set;
    let setlist :=
      cons (p "e000::/4" % string)
        (cons (p "a000::/4" % string)
          (cons (p "ffff::/16" % string) (cons (p "1234:5678::/32" % string) [])))
      in
    let set := of_list setlist in
    assert_equal_set Stdlib.__LOC__ setlist set
  end.
src/lib_p2p/test/test_p2p_peerset.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test-p2p-banned_peers"
end)

let assert_equal_bool ~msg a b = if a <> b then Alcotest.fail msg

let a s = P2p_peer.Id.hash_string [s]

let test_empty _ =
  let peers = List.map a ["foo"; "bar"; "baz"] in
  let empty = P2p_acl.PeerRing.create 10 in
  List.iter
    (fun peer ->
      assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem empty peer))
    peers

let test_add _ =
  let peers = List.map a ["foo"; "bar"; "baz"] in
  let set = P2p_acl.PeerRing.create 10 in
  List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
  List.iter
    (fun peer ->
      assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set peer))
    peers

let test_remove _ =
  let peers = List.map a ["foo"; "bar"; "baz"] in
  let set = P2p_acl.PeerRing.create 10 in
  List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "bar")) ;
  P2p_acl.PeerRing.remove set (a "bar") ;
  assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem set (a "bar"))

let test_overflow _ =
  let peers = List.map a ["foo"; "bar"; "baz"] in
  let set = P2p_acl.PeerRing.create 3 in
  List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "baz")) ;
  P2p_acl.PeerRing.add set (a "zor") ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "zor")) ;
  assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem set (a "foo")) ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "bar")) ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "baz"))

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p.peerset",
        [ ("empty", `Quick, test_empty);
          ("add", `Quick, test_add);
          ("overflow", `Quick, test_overflow);
          ("remove", `Quick, test_remove) ] ) ]
src/lib_p2p/test/test_p2p_peerset.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition assert_equal_bool {A B : Type} (msg : A) (a : B) (b : B) : unit :=
  if nequiv_decb a b then
    op_star_t_y_p_e_minus_e_r_r_o_r_star msg
  else
    tt.

Definition a (s : string) : Tezos_base__TzPervasives.P2p_peer.Id.t :=
  Tezos_base__TzPervasives.P2p_peer.Id.hash_string None (cons s []).

Definition test_empty {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let peers :=
      Tezos_base__TzPervasives.List.map a
        (cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
    let empty := Tezos_p2p.P2p_acl.PeerRing.create 10 in
    Tezos_base__TzPervasives.List.iter
      (fun peer =>
        assert_equal_bool Stdlib.__LOC__ false
          (Tezos_p2p.P2p_acl.PeerRing.mem empty peer)) peers
  end.

Definition test_add {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let peers :=
      Tezos_base__TzPervasives.List.map a
        (cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
    let set := Tezos_p2p.P2p_acl.PeerRing.create 10 in
    Tezos_base__TzPervasives.List.iter
      (fun peer => Tezos_p2p.P2p_acl.PeerRing.add set peer) peers;
    Tezos_base__TzPervasives.List.iter
      (fun peer =>
        assert_equal_bool Stdlib.__LOC__ true
          (Tezos_p2p.P2p_acl.PeerRing.mem set peer)) peers
  end.

Definition test_remove {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let peers :=
      Tezos_base__TzPervasives.List.map a
        (cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
    let set := Tezos_p2p.P2p_acl.PeerRing.create 10 in
    Tezos_base__TzPervasives.List.iter
      (fun peer => Tezos_p2p.P2p_acl.PeerRing.add set peer) peers;
    assert_equal_bool Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.PeerRing.mem set (a "bar" % string));
    Tezos_p2p.P2p_acl.PeerRing.remove set (a "bar" % string);
    assert_equal_bool Stdlib.__LOC__ false
      (Tezos_p2p.P2p_acl.PeerRing.mem set (a "bar" % string))
  end.

Definition test_overflow {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    let peers :=
      Tezos_base__TzPervasives.List.map a
        (cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
    let set := Tezos_p2p.P2p_acl.PeerRing.create 3 in
    Tezos_base__TzPervasives.List.iter
      (fun peer => Tezos_p2p.P2p_acl.PeerRing.add set peer) peers;
    assert_equal_bool Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.PeerRing.mem set (a "baz" % string));
    Tezos_p2p.P2p_acl.PeerRing.add set (a "zor" % string);
    assert_equal_bool Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.PeerRing.mem set (a "zor" % string));
    assert_equal_bool Stdlib.__LOC__ false
      (Tezos_p2p.P2p_acl.PeerRing.mem set (a "foo" % string));
    assert_equal_bool Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.PeerRing.mem set (a "bar" % string));
    assert_equal_bool Stdlib.__LOC__ true
      (Tezos_p2p.P2p_acl.PeerRing.mem set (a "baz" % string))
  end.
src/lib_p2p/test/test_p2p_pool.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test.p2p.connection-pool"
end)

type message = Ping

let msg_config : message P2p_pool.message_config =
  {
    encoding =
      [ P2p_message.Encoding
          {
            tag = 0x10;
            title = "Ping";
            encoding = Data_encoding.empty;
            wrap = (function () -> Ping);
            unwrap = (function Ping -> Some ());
            max_length = None;
          } ];
    chain_name = Distributed_db_version.sandboxed_chain_name;
    distributed_db_versions = [Distributed_db_version.zero];
  }

type metadata = unit

let peer_meta_config : metadata P2p_pool.peer_meta_config =
  {
    peer_meta_encoding = Data_encoding.empty;
    peer_meta_initial = (fun _ -> ());
    score = (fun () -> 0.);
  }

let conn_meta_config : metadata P2p_socket.metadata_config =
  {
    conn_meta_encoding = Data_encoding.empty;
    conn_meta_value = (fun _ -> ());
    private_node = (fun _ -> false);
  }

let sync ch =
  Process.Channel.push ch ()
  >>=? fun () -> Process.Channel.pop ch >>=? fun () -> return_unit

let rec sync_nodes nodes =
  iter_p (fun {Process.channel; _} -> Process.Channel.pop channel) nodes
  >>=? fun () ->
  iter_p (fun {Process.channel; _} -> Process.Channel.push channel ()) nodes
  >>=? fun () -> sync_nodes nodes

let sync_nodes nodes =
  sync_nodes nodes
  >>= function
  | Ok () | Error (Exn End_of_file :: _) ->
      return_unit
  | Error _ as err ->
      Lwt.return err

let detach_node f points n =
  let ((addr, port), points) = List.select n points in
  let proof_of_work_target = Crypto_box.make_target 0. in
  let identity = P2p_identity.generate proof_of_work_target in
  let nb_points = List.length points in
  let config =
    P2p_pool.
      {
        identity;
        proof_of_work_target;
        trusted_points = points;
        peers_file = "/dev/null";
        private_mode = true;
        listening_port = Some port;
        min_connections = nb_points;
        max_connections = nb_points;
        max_incoming_connections = nb_points;
        connection_timeout = Time.System.Span.of_seconds_exn 10.;
        authentication_timeout = Time.System.Span.of_seconds_exn 2.;
        incoming_app_message_queue_size = None;
        incoming_message_queue_size = None;
        outgoing_message_queue_size = None;
        known_peer_ids_history_size = 100;
        known_points_history_size = 100;
        max_known_points = None;
        max_known_peer_ids = None;
        swap_linger = Time.System.Span.of_seconds_exn 0.;
        binary_chunks_size = None;
        greylisting_config = P2p_point_state.Info.default_greylisting_config;
      }
  in
  Process.detach
    ~prefix:(Format.asprintf "%a: " P2p_peer.Id.pp_short identity.peer_id)
    (fun channel ->
      let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
      P2p_pool.create config peer_meta_config conn_meta_config msg_config sched
      >>= fun pool ->
      P2p_welcome.create ~backlog:10 pool ~addr port
      >>= fun welcome ->
      P2p_welcome.activate welcome ;
      lwt_log_info "Node ready (port: %d)" port
      >>= fun () ->
      sync channel
      >>=? fun () ->
      f channel pool points
      >>=? fun () ->
      lwt_log_info "Shutting down..."
      >>= fun () ->
      P2p_welcome.shutdown welcome
      >>= fun () ->
      P2p_pool.destroy pool
      >>= fun () ->
      P2p_io_scheduler.shutdown sched
      >>= fun () -> lwt_log_info "Bye." >>= fun () -> return_unit)

let detach_nodes run_node points =
  let clients = List.length points in
  Lwt_list.map_p (detach_node run_node points) (0 -- (clients - 1))
  >>= fun nodes ->
  Lwt.ignore_result (sync_nodes nodes) ;
  Process.wait_all nodes

type error += Connect | Write | Read

module Simple = struct
  let rec connect ~timeout pool point =
    lwt_log_info "Connect to %a" P2p_point.Id.pp point
    >>= fun () ->
    P2p_pool.connect pool point ~timeout
    >>= function
    | Error (P2p_errors.Connected :: _) -> (
      match P2p_pool.Connection.find_by_point pool point with
      | Some conn ->
          return conn
      | None ->
          failwith "Woops..." )
    | Error
        (( ( P2p_errors.Connection_refused
           | P2p_errors.Pending_connection
           | P2p_errors.Rejected_socket_connection
           | Canceled
           | Timeout
           | P2p_errors.Rejected _ ) as head_err )
        :: _) ->
        lwt_log_info
          "Connection to %a failed (%a)"
          P2p_point.Id.pp
          point
          (fun ppf err ->
            match err with
            | P2p_errors.Connection_refused ->
                Format.fprintf ppf "connection refused"
            | P2p_errors.Pending_connection ->
                Format.fprintf ppf "pending connection"
            | P2p_errors.Rejected_socket_connection ->
                Format.fprintf ppf "rejected"
            | Canceled ->
                Format.fprintf ppf "canceled"
            | Timeout ->
                Format.fprintf ppf "timeout"
            | P2p_errors.Rejected peer ->
                Format.fprintf ppf "rejected (%a)" P2p_peer.Id.pp peer
            | _ ->
                assert false)
          head_err
        >>= fun () ->
        Lwt_unix.sleep (0.5 +. Random.float 2.)
        >>= fun () -> connect ~timeout pool point
    | (Ok _ | Error _) as res ->
        Lwt.return res

  let connect_all ~timeout pool points = map_p (connect ~timeout pool) points

  let write_all conns msg =
    iter_p (fun conn -> trace Write @@ P2p_pool.write_sync conn msg) conns

  let read_all conns =
    iter_p
      (fun conn ->
        trace Read @@ P2p_pool.read conn >>=? fun Ping -> return_unit)
      conns

  let close_all conns = Lwt_list.iter_p P2p_pool.disconnect conns

  let node channel pool points =
    connect_all ~timeout:(Time.System.Span.of_seconds_exn 2.) pool points
    >>=? fun conns ->
    lwt_log_info "Bootstrap OK"
    >>= fun () ->
    sync channel
    >>=? fun () ->
    write_all conns Ping
    >>=? fun () ->
    lwt_log_info "Sent all messages."
    >>= fun () ->
    sync channel
    >>=? fun () ->
    read_all conns
    >>=? fun () ->
    lwt_log_info "Read all messages."
    >>= fun () ->
    sync channel
    >>=? fun () ->
    close_all conns
    >>= fun () ->
    lwt_log_info "All connections successfully closed."
    >>= fun () -> return_unit

  let run points = detach_nodes node points
end

module Random_connections = struct
  let rec connect_random pool total rem point n =
    Lwt_unix.sleep (0.2 +. Random.float 1.0)
    >>= fun () ->
    trace Connect
    @@ Simple.connect ~timeout:(Time.System.Span.of_seconds_exn 2.) pool point
    >>=? fun conn ->
    trace Write @@ P2p_pool.write conn Ping
    >>= fun _ ->
    trace Read @@ P2p_pool.read conn
    >>=? fun Ping ->
    Lwt_unix.sleep (0.2 +. Random.float 1.0)
    >>= fun () ->
    P2p_pool.disconnect conn
    >>= fun () ->
    ( decr rem ;
      if !rem mod total = 0 then lwt_log_info "Remaining: %d." (!rem / total)
      else Lwt.return_unit )
    >>= fun () ->
    if n > 1 then connect_random pool total rem point (pred n) else return_unit

  let connect_random_all pool points n =
    let total = List.length points in
    let rem = ref (n * total) in
    iter_p (fun point -> connect_random pool total rem point n) points

  let node repeat _channel pool points =
    lwt_log_info "Begin random connections."
    >>= fun () ->
    connect_random_all pool points repeat
    >>=? fun () ->
    lwt_log_info "Random connections OK." >>= fun () -> return_unit

  let run points repeat = detach_nodes (node repeat) points
end

module Garbled = struct
  let is_connection_closed = function
    | Error ((Write | Read) :: P2p_errors.Connection_closed :: _) ->
        true
    | Ok _ ->
        false
    | Error err ->
        log_info "Unexpected error: %a" pp_print_error err ;
        false

  let write_bad_all conns =
    let bad_msg = Bytes.of_string (String.make 16 '\000') in
    iter_p
      (fun conn -> trace Write @@ P2p_pool.raw_write_sync conn bad_msg)
      conns

  let node ch pool points =
    Simple.connect_all
      ~timeout:(Time.System.Span.of_seconds_exn 2.)
      pool
      points
    >>=? fun conns ->
    sync ch
    >>=? fun () ->
    write_bad_all conns
    >>=? (fun () -> Simple.read_all conns)
    >>= fun err -> _assert (is_connection_closed err) __LOC__ ""

  let run points = detach_nodes node points
end

let () = Random.self_init ()

let addr = ref Ipaddr.V6.localhost

let port = ref (1024 + Random.int 8192)

let clients = ref 10

let repeat_connections = ref 5

let log_config = ref None

let spec =
  Arg.
    [ ("--port", Int (fun p -> port := p), " Listening port of the first peer.");
      ( "--addr",
        String (fun p -> addr := Ipaddr.V6.of_string_exn p),
        " Listening addr" );
      ("--clients", Set_int clients, " Number of concurrent clients.");
      ( "--repeat",
        Set_int repeat_connections,
        " Number of connections/disconnections." );
      ( "-v",
        Unit
          (fun () ->
            log_config :=
              Some
                (Lwt_log_sink_unix.create_cfg
                   ~rules:
                     "test.p2p.connection-pool -> info; p2p.connection-pool \
                      -> info"
                   ())),
        " Log up to info msgs" );
      ( "-vv",
        Unit
          (fun () ->
            log_config :=
              Some
                (Lwt_log_sink_unix.create_cfg
                   ~rules:
                     "test.p2p.connection-pool -> debug; p2p.connection-pool \
                      -> debug"
                   ())),
        " Log up to debug msgs" ) ]

let init_logs = lazy (Internal_event_unix.init ?lwt_log_sink:!log_config ())

let wrap n f =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lazy.force init_logs
      >>= fun () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let main () =
  let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
  let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
  Arg.parse spec anon_fun usage_msg ;
  let ports = !port -- (!port + !clients - 1) in
  let points = List.map (fun port -> (!addr, port)) ports in
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p-connection-pool",
        [ wrap "simple" (fun _ -> Simple.run points);
          wrap "random" (fun _ ->
              Random_connections.run points !repeat_connections);
          wrap "garbled" (fun _ -> Garbled.run points) ] ) ]

let () =
  Sys.catch_break true ;
  try main () with _ -> ()
src/lib_p2p/test/test_p2p_pool.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive message : Type :=
| Ping : message.

Definition msg_config : Tezos_p2p.P2p_pool.message_config message :=
  {|
    encoding :=
      cons
        (P2p_message.Encoding
          {| tag := 16; title := "Ping" % string;
            encoding := Tezos_base__TzPervasives.Data_encoding.empty;
            wrap :=
              fun function_parameter =>
                match function_parameter with
                | tt => Ping
                end;
            unwrap :=
              fun function_parameter =>
                match function_parameter with
                | Ping => Some tt
                end; max_length := None |}) [];
    chain_name :=
      Tezos_base__TzPervasives.Distributed_db_version.sandboxed_chain_name;
    distributed_db_versions :=
      cons Tezos_base__TzPervasives.Distributed_db_version.zero [] |}.

Definition metadata := unit.

Definition peer_meta_config : Tezos_p2p.P2p_pool.peer_meta_config metadata :=
  {| peer_meta_encoding := Tezos_base__TzPervasives.Data_encoding.empty;
    peer_meta_initial :=
      fun function_parameter =>
        match function_parameter with
        | _ => tt
        end;
    score :=
      fun function_parameter =>
        match function_parameter with
        | tt => 0
        end |}.

Definition conn_meta_config : Tezos_p2p.P2p_socket.metadata_config metadata :=
  {| conn_meta_encoding := Tezos_base__TzPervasives.Data_encoding.empty;
    conn_meta_value :=
      fun function_parameter =>
        match function_parameter with
        | _ => tt
        end;
    private_node :=
      fun function_parameter =>
        match function_parameter with
        | _ => false
        end |}.

Definition sync {A : Type} (ch : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ch tt)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star ch)
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Fixpoint sync_nodes {A B : Type} (nodes : list A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.iter_p
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
        end) nodes)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_base__TzPervasives.iter_p
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star tt
              end) nodes)
          (fun function_parameter =>
            match function_parameter with
            | tt => sync_nodes nodes
            end)
      end).

Definition sync_nodes {A : Type} (nodes : list A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (sync_nodes nodes)
    (fun function_parameter =>
      match function_parameter with
      | inl tt | inr (cons (Exn OCaml.End_of_file) _) =>
        Tezos_base__TzPervasives.return_unit
      | (inr _) as err => Lwt._return err
      end).

Definition detach_node {A B : Type}
  (f :
    A ->
      (Tezos_p2p.P2p_pool.pool message metadata metadata) ->
        (list Tezos_base__TzPervasives.P2p_point.Id.t) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (points : list Tezos_base__TzPervasives.P2p_point.Id.t) (n : Z) : B :=
  match Tezos_base__TzPervasives.List.select n points with
  | ((addr, port), points) =>
    let proof_of_work_target :=
      Tezos_base__TzPervasives.Crypto_box.make_target 0 in
    let identity :=
      Tezos_base__TzPervasives.P2p_identity.generate proof_of_work_target in
    let nb_points := Tezos_base__TzPervasives.List.length points in
    let config :=
      {| identity := identity; proof_of_work_target := proof_of_work_target;
        trusted_points := points; peers_file := "/dev/null" % string;
        private_mode := true;
        greylisting_config :=
          Tezos_p2p.P2p_point_state.Info.default_greylisting_config;
        listening_port := Some port; min_connections := nb_points;
        max_connections := nb_points; max_incoming_connections := nb_points;
        connection_timeout :=
          Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 10;
        authentication_timeout :=
          Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 2;
        incoming_app_message_queue_size := None;
        incoming_message_queue_size := None;
        outgoing_message_queue_size := None; known_peer_ids_history_size := 100;
        known_points_history_size := 100; max_known_points := None;
        max_known_peer_ids := None;
        swap_linger :=
          Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 0;
        binary_chunks_size := None |} in
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal ": " % string
              CamlinternalFormatBasics.End_of_format)) "%a: " % string)
        Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id identity))
      (fun channel =>
        let sched :=
          Tezos_p2p.P2p_io_scheduler.create None None None None (Z.shiftl 1 12)
            tt in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_p2p.P2p_pool.create None config peer_meta_config
            conn_meta_config msg_config sched)
          (fun pool =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_p2p.P2p_welcome.create (Some addr) 10 pool port)
              (fun welcome =>
                Tezos_p2p.P2p_welcome.activate welcome;
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_info
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Node ready (port: " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))
                      "Node ready (port: %d)" % string) port)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (sync channel)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (f channel pool points)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (lwt_log_info
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Shutting down..." % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "Shutting down..." % string))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (Tezos_p2p.P2p_welcome.shutdown
                                            welcome)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (Tezos_p2p.P2p_pool.destroy pool)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (Tezos_p2p.P2p_io_scheduler.shutdown
                                                        None sched)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (lwt_log_info
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "Bye." %
                                                                    string
                                                                  CamlinternalFormatBasics.End_of_format)
                                                                "Bye." % string))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_base__TzPervasives.return_unit
                                                              end)
                                                        end)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end))))
  end.

Definition detach_nodes {A B : Type}
  (run_node :
    A ->
      (Tezos_p2p.P2p_pool.pool message metadata metadata) ->
        (list Tezos_base__TzPervasives.P2p_point.Id.t) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t B :=
  let clients := Tezos_base__TzPervasives.List.length points in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Lwt_list.map_p (detach_node run_node points)
      (Tezos_base__TzPervasives.op_minus_minus 0 (Z.sub clients 1)))
    (fun nodes =>
      Lwt.ignore_result (sync_nodes nodes);
      op_star_t_y_p_e_minus_e_r_r_o_r_star nodes).

Module Simple.
  Fixpoint connect {A B C : Type}
    (timeout : Tezos_base__TzPervasives.Time.System.Span.t)
    (pool : Tezos_p2p.P2p_pool.pool A B C)
    (point : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_pool.connection A B C)) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Connect to " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "Connect to %a" % string)
        Tezos_base__TzPervasives.P2p_point.Id.pp point)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_p2p.P2p_pool.connect (Some timeout) pool point)
            (fun function_parameter =>
              match function_parameter with
              | inr (cons P2p_errors.Connected _) =>
                match Tezos_p2p.P2p_pool.Connection.find_by_point pool point
                  with
                | Some conn => Tezos_base__TzPervasives._return conn
                | None =>
                  Tezos_base__TzPervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Woops..." % string
                        CamlinternalFormatBasics.End_of_format)
                      "Woops..." % string)
                end
              |
                inr
                  (cons
                    ((P2p_errors.Connection_refused |
                      P2p_errors.Pending_connection |
                      P2p_errors.Rejected_socket_connection | Canceled | Timeout
                      | P2p_errors.Rejected _) as head_err) _) =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_info
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Connection to " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " failed (" % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                CamlinternalFormatBasics.End_of_format)))))
                      "Connection to %a failed (%a)" % string)
                    Tezos_base__TzPervasives.P2p_point.Id.pp point
                    (fun ppf =>
                      fun err =>
                        match err with
                        | P2p_errors.Connection_refused =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "connection refused" % string
                                CamlinternalFormatBasics.End_of_format)
                              "connection refused" % string)
                        | P2p_errors.Pending_connection =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "pending connection" % string
                                CamlinternalFormatBasics.End_of_format)
                              "pending connection" % string)
                        | P2p_errors.Rejected_socket_connection =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "rejected" % string
                                CamlinternalFormatBasics.End_of_format)
                              "rejected" % string)
                        | Canceled =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "canceled" % string
                                CamlinternalFormatBasics.End_of_format)
                              "canceled" % string)
                        | Timeout =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "timeout" % string
                                CamlinternalFormatBasics.End_of_format)
                              "timeout" % string)
                        | P2p_errors.Rejected peer =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "rejected (" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    ")" % char
                                    CamlinternalFormatBasics.End_of_format)))
                              "rejected (%a)" % string)
                            Tezos_base__TzPervasives.P2p_peer.Id.pp peer
                        | _ => false
                        end) head_err)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Lwt_unix.sleep
                          (Stdlib.op_plus_point 0 (Stdlib.Random.float 2)))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => connect timeout pool point
                          end)
                    end)
              | (inl _ | inr _) as res => Lwt._return res
              end)
        end).
  
  Definition connect_all {A B C : Type}
    (timeout : Tezos_base__TzPervasives.Time.System.Span.t)
    (pool : Tezos_p2p.P2p_pool.pool A B C)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list (Tezos_p2p.P2p_pool.connection A B C))) :=
    Tezos_base__TzPervasives.map_p (connect timeout pool) points.
  
  Definition write_all {A B C : Type}
    (conns : list (Tezos_p2p.P2p_pool.connection A B C)) (msg : A)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.iter_p
      (fun conn =>
        apply (Tezos_base__TzPervasives.trace Write)
          (Tezos_p2p.P2p_pool.write_sync conn msg)) conns.
  
  Definition read_all {A B : Type}
    (conns : list (Tezos_p2p.P2p_pool.connection message A B))
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.iter_p
      (fun conn =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (apply (Tezos_base__TzPervasives.trace Read)
            (Tezos_p2p.P2p_pool.read conn))
          (fun function_parameter =>
            match function_parameter with
            | Ping => Tezos_base__TzPervasives.return_unit
            end)) conns.
  
  Definition close_all {A B C : Type}
    (conns : list (Tezos_p2p.P2p_pool.connection A B C)) : Lwt.t unit :=
    Lwt_list.iter_p
      (let arg := Tezos_p2p.P2p_pool.disconnect in
      fun eta => arg None eta) conns.
  
  Definition node {A B C : Type}
    (channel : A) (pool : Tezos_p2p.P2p_pool.pool message B C)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (connect_all (Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 2)
        pool points)
      (fun conns =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_info
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Bootstrap OK" % string
                CamlinternalFormatBasics.End_of_format) "Bootstrap OK" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question (sync channel)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (write_all conns Ping)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (lwt_log_info
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Sent all messages." % string
                                  CamlinternalFormatBasics.End_of_format)
                                "Sent all messages." % string))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (sync channel)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (read_all conns)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (lwt_log_info
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Read all messages." %
                                                      string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "Read all messages." % string))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    (sync channel)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (close_all conns)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (lwt_log_info
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "All connections successfully closed."
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "All connections successfully closed."
                                                                      % string))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_base__TzPervasives.return_unit
                                                                  end)
                                                            end)
                                                      end)
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)).
  
  Definition run {A : Type}
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t A :=
    detach_nodes node points.
End Simple.

Module Random_connections.
  Fixpoint connect_random {A B : Type}
    (pool : Tezos_p2p.P2p_pool.pool message A B) (total : Z)
    (rem : Stdlib.ref Z) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
    (n : Z) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Lwt_unix.sleep (Stdlib.op_plus_point 0 (Stdlib.Random.float 1)))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (apply (Tezos_base__TzPervasives.trace Connect)
              (Simple.connect
                (Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 2)
                pool point))
            (fun conn =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (apply (Tezos_base__TzPervasives.trace Write)
                  (Tezos_p2p.P2p_pool.write conn Ping))
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (apply (Tezos_base__TzPervasives.trace Read)
                        (Tezos_p2p.P2p_pool.read conn))
                      (fun function_parameter =>
                        match function_parameter with
                        | Ping =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Lwt_unix.sleep
                              (Stdlib.op_plus_point 0 (Stdlib.Random.float 1)))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Tezos_p2p.P2p_pool.disconnect None conn)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Stdlib.decr rem;
                                        if
                                          equiv_decb
                                            (Z.modulo
                                              (Stdlib.op_exclamation rem) total)
                                            0 then
                                          lwt_log_info
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Remaining: " % string
                                                (CamlinternalFormatBasics.Int
                                                  CamlinternalFormatBasics.Int_d
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.No_precision
                                                  (CamlinternalFormatBasics.Char_literal
                                                    "." % char
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "Remaining: %d." % string)
                                            (Z.div (Stdlib.op_exclamation rem)
                                              total)
                                        else
                                          Lwt.return_unit)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            if OCaml.Stdlib.gt n 1 then
                                              connect_random pool total rem
                                                point (Z.pred n)
                                            else
                                              Tezos_base__TzPervasives.return_unit
                                          end)
                                    end)
                              end)
                        end)
                  end))
        end).
  
  Definition connect_random_all {A B : Type}
    (pool : Tezos_p2p.P2p_pool.pool message A B)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) (n : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let total := Tezos_base__TzPervasives.List.length points in
    let rem := Stdlib.ref (Z.mul n total) in
    Tezos_base__TzPervasives.iter_p
      (fun point => connect_random pool total rem point n) points.
  
  Definition node {A B C : Type}
    (repeat : Z) (_channel : A) (pool : Tezos_p2p.P2p_pool.pool message B C)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Begin random connections." % string
            CamlinternalFormatBasics.End_of_format)
          "Begin random connections." % string))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (connect_random_all pool points repeat)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_info
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Random connections OK." % string
                        CamlinternalFormatBasics.End_of_format)
                      "Random connections OK." % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives.return_unit
                    end)
              end)
        end).
  
  Definition run {A : Type}
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) (repeat : Z)
    : Lwt.t A := detach_nodes (node repeat) points.
End Random_connections.

Module Garbled.
  Definition is_connection_closed {A : Type}
    (function_parameter : sum A (list Tezos_base__TzPervasives.error)) : bool :=
    match function_parameter with
    | inr (cons (Write | Read) (cons P2p_errors.Connection_closed _)) => true
    | inl _ => false
    | inr err =>
      log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Unexpected error: " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "Unexpected error: %a" % string)
        Tezos_base__TzPervasives.pp_print_error err;
      false
    end.
  
  Definition write_bad_all {A B C : Type}
    (conns : list (Tezos_p2p.P2p_pool.connection A B C))
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let bad_msg :=
      Stdlib.Bytes.of_string
        (Tezos_base__TzPervasives.String.make 16 "000" % char) in
    Tezos_base__TzPervasives.iter_p
      (fun conn =>
        apply (Tezos_base__TzPervasives.trace Write)
          (Tezos_p2p.P2p_pool.raw_write_sync conn bad_msg)) conns.
  
  Definition node {A B C : Type}
    (ch : A) (pool : Tezos_p2p.P2p_pool.pool message B C)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Simple.connect_all
        (Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 2) pool points)
      (fun conns =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question (sync ch)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (write_bad_all conns)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Simple.read_all conns
                    end))
                (fun err =>
                  Tezos_base__TzPervasives._assert (is_connection_closed err)
                    Stdlib.__LOC__
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
            end)).
  
  Definition run {A : Type}
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t A :=
    detach_nodes node points.
End Garbled.

Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.

Definition port : Stdlib.ref Z :=
  Stdlib.ref (Z.add 1024 (Stdlib.Random.int 8192)).

Definition clients : Stdlib.ref Z := Stdlib.ref 10.

Definition repeat_connections : Stdlib.ref Z := Stdlib.ref 5.

Definition log_config
  : Stdlib.ref (option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg) :=
  Stdlib.ref None.

Definition spec : list (string * Stdlib.Arg.spec * string) :=
  cons
    ("--port" % string, (Int (fun p => Stdlib.op_colon_eq port p)),
      " Listening port of the first peer." % string)
    (cons
      ("--addr" % string,
        (String (fun p => Stdlib.op_colon_eq addr (Ipaddr.V6.of_string_exn p))),
        " Listening addr" % string)
      (cons
        ("--clients" % string, (Set_int clients),
          " Number of concurrent clients." % string)
        (cons
          ("--repeat" % string, (Set_int repeat_connections),
            " Number of connections/disconnections." % string)
          (cons
            ("-v" % string,
              (Unit
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Stdlib.op_colon_eq log_config
                      (Some
                        (Tezos_stdlib_unix.Lwt_log_sink_unix.create_cfg None
                          None
                          (Some
                            "test.p2p.connection-pool -> info; p2p.connection-pool -> info"
                              % string) None tt))
                  end)), " Log up to info msgs" % string)
            (cons
              ("-vv" % string,
                (Unit
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Stdlib.op_colon_eq log_config
                        (Some
                          (Tezos_stdlib_unix.Lwt_log_sink_unix.create_cfg None
                            None
                            (Some
                              "test.p2p.connection-pool -> debug; p2p.connection-pool -> debug"
                                % string) None tt))
                    end)), " Log up to debug msgs" % string) []))))).

Definition init_logs : lazy_t (Lwt.t unit) :=
  Tezos_stdlib_unix.Internal_event_unix.init (Stdlib.op_exclamation log_config)
    None tt.

Definition wrap {A B : Type}
  (n : A) (f : unit -> Lwt.t (sum unit (list Tezos_base__TzPervasives.error)))
  : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq (Stdlib.Lazy.force init_logs)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (f tt)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl tt => Lwt.return_unit
                      | inr error =>
                        Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string)
                          Tezos_base__TzPervasives.pp_print_error error
                      end)
                end)
          end
      end).

Definition main {A : Type} (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    let anon_fun {B C : Type} (_num_peers : B) : C :=
      Stdlib.raise (Arg.Bad "No anonymous argument." % string) in
    let usage_msg := "Usage: %s <num_peers>.
Arguments are:" % string in
    Stdlib.Arg.parse spec anon_fun usage_msg;
    let ports :=
      Tezos_base__TzPervasives.op_minus_minus (Stdlib.op_exclamation port)
        (Z.sub
          (Z.add (Stdlib.op_exclamation port) (Stdlib.op_exclamation clients)) 1)
      in
    let points :=
      Tezos_base__TzPervasives.List.map
        (fun port => ((Stdlib.op_exclamation addr), port)) ports in
    op_star_t_y_p_e_minus_e_r_r_o_r_star ("" % string) "tezos-p2p" % string
      (cons
        ("p2p-connection-pool" % string,
          (cons
            (wrap "simple" % string
              (fun function_parameter =>
                match function_parameter with
                | _ => Simple.run points
                end))
            (cons
              (wrap "random" % string
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Random_connections.run points
                      (Stdlib.op_exclamation repeat_connections)
                  end))
              (cons
                (wrap "garbled" % string
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => Garbled.run points
                    end)) [])))) [])
  end.
src/lib_p2p/test/test_p2p_socket.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test.p2p.connection"
end)

let addr = ref Ipaddr.V6.localhost

let canceler = Lwt_canceler.create () (* unused *)

let proof_of_work_target = Crypto_box.make_target 16.

let id1 = P2p_identity.generate proof_of_work_target

let id2 = P2p_identity.generate proof_of_work_target

let id0 =
  (* Luckilly, this will be an insuficient proof of work! *)
  P2p_identity.generate (Crypto_box.make_target 0.)

let version =
  {
    Network_version.chain_name = Distributed_db_version.sandboxed_chain_name;
    distributed_db_version = Distributed_db_version.zero;
    p2p_version = P2p_version.zero;
  }

type metadata = unit

let conn_meta_config : metadata P2p_socket.metadata_config =
  {
    conn_meta_encoding = Data_encoding.empty;
    conn_meta_value = (fun _ -> ());
    private_node = (fun _ -> false);
  }

let rec listen ?port addr =
  let tentative_port =
    match port with None -> 1024 + Random.int 8192 | Some port -> port
  in
  let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
  let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
  Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
  Lwt.catch
    (fun () ->
      Lwt_unix.bind main_socket (ADDR_INET (uaddr, tentative_port))
      >>= fun () ->
      Lwt_unix.listen main_socket 1 ;
      Lwt.return (main_socket, tentative_port))
    (function
      | Unix.Unix_error ((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _)
        when port = None ->
          listen addr
      | exn ->
          Lwt.fail exn)

let sync ch =
  Process.Channel.push ch ()
  >>=? fun () -> Process.Channel.pop ch >>=? fun () -> return_unit

let rec sync_nodes nodes =
  iter_p (fun {Process.channel; _} -> Process.Channel.pop channel) nodes
  >>=? fun () ->
  iter_p (fun {Process.channel; _} -> Process.Channel.push channel ()) nodes
  >>=? fun () -> sync_nodes nodes

let sync_nodes nodes =
  sync_nodes nodes
  >>= function
  | Ok () | Error (Exn End_of_file :: _) ->
      return_unit
  | Error _ as err ->
      Lwt.return err

let run_nodes client server =
  listen !addr
  >>= fun (main_socket, port) ->
  Process.detach ~prefix:"server: " (fun channel ->
      let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
      server channel sched main_socket
      >>=? fun () -> P2p_io_scheduler.shutdown sched >>= fun () -> return_unit)
  >>= fun server_node ->
  Process.detach ~prefix:"client: " (fun channel ->
      Lwt_utils_unix.safe_close main_socket
      >>= fun () ->
      let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
      client channel sched !addr port
      >>=? fun () -> P2p_io_scheduler.shutdown sched >>= fun () -> return_unit)
  >>= fun client_node ->
  let nodes = [server_node; client_node] in
  Lwt.ignore_result (sync_nodes nodes) ;
  Process.wait_all nodes

let raw_accept sched main_socket =
  P2p_fd.accept main_socket
  >>= fun (fd, sockaddr) ->
  let fd = P2p_io_scheduler.register sched fd in
  let point =
    match sockaddr with
    | Lwt_unix.ADDR_UNIX _ ->
        assert false
    | Lwt_unix.ADDR_INET (addr, port) ->
        (Ipaddr_unix.V6.of_inet_addr_exn addr, port)
  in
  Lwt.return (fd, point)

let accept sched main_socket =
  raw_accept sched main_socket
  >>= fun (fd, point) ->
  P2p_socket.authenticate
    ~canceler
    ~proof_of_work_target
    ~incoming:true
    fd
    point
    id1
    version
    conn_meta_config

let raw_connect sched addr port =
  let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
  let uaddr = Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
  P2p_fd.connect fd uaddr
  >>= fun () ->
  let fd = P2p_io_scheduler.register sched fd in
  Lwt.return fd

let connect sched addr port id =
  raw_connect sched addr port
  >>= fun fd ->
  P2p_socket.authenticate
    ~canceler
    ~proof_of_work_target
    ~incoming:false
    fd
    (addr, port)
    id
    version
    conn_meta_config
  >>=? fun (info, auth_fd) ->
  _assert (not info.incoming) __LOC__ ""
  >>=? fun () ->
  _assert (P2p_peer.Id.compare info.peer_id id1.peer_id = 0) __LOC__ ""
  >>=? fun () -> return auth_fd

let is_connection_closed = function
  | Error (P2p_errors.Connection_closed :: _) ->
      true
  | Ok _ ->
      false
  | Error err ->
      log_notice "Error: %a" pp_print_error err ;
      false

let is_decoding_error = function
  | Error (P2p_errors.Decoding_error :: _) ->
      true
  | Ok _ ->
      false
  | Error err ->
      log_notice "Error: %a" pp_print_error err ;
      false

module Crypto_test = struct
  (* maximal size of the buffer *)
  let bufsize = (1 lsl 16) - 1

  let header_length = 2

  let max_content_length = bufsize - Crypto_box.zerobytes

  (* The size of extra data added by encryption. *)
  let boxextrabytes = Crypto_box.zerobytes - Crypto_box.boxzerobytes

  (* The number of bytes added by encryption + header *)
  let extrabytes = header_length + boxextrabytes

  type data = {
    channel_key : Crypto_box.channel_key;
    mutable local_nonce : Crypto_box.nonce;
    mutable remote_nonce : Crypto_box.nonce;
  }

  let () = assert (Crypto_box.boxzerobytes >= header_length)

  let write_chunk fd cryptobox_data msg =
    let msglen = Bytes.length msg in
    fail_unless (msglen <= max_content_length) P2p_errors.Invalid_message_size
    >>=? fun () ->
    let buf_length = msglen + Crypto_box.zerobytes in
    let buf = Bytes.make buf_length '\x00' in
    Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
    let local_nonce = cryptobox_data.local_nonce in
    cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
    Crypto_box.fast_box_noalloc cryptobox_data.channel_key local_nonce buf ;
    let encrypted_length = buf_length - Crypto_box.boxzerobytes in
    let header_pos = Crypto_box.boxzerobytes - header_length in
    TzEndian.set_int16 buf header_pos encrypted_length ;
    let payload = Bytes.sub buf header_pos (buf_length - header_pos) in
    return (Unix.write fd payload 0 (buf_length - header_pos))
    >>=? fun i ->
    _assert (buf_length - header_pos = i) __LOC__ "" >>=? fun () -> return_unit

  let read_chunk fd cryptobox_data =
    let header_buf = Bytes.create header_length in
    return (Unix.read fd header_buf 0 header_length)
    >>=? fun i ->
    _assert (header_length = i) __LOC__ ""
    >>=? fun () ->
    let encrypted_length = TzEndian.get_uint16 header_buf 0 in
    let buf_length = encrypted_length + Crypto_box.boxzerobytes in
    let buf = Bytes.make buf_length '\x00' in
    return (Unix.read fd buf Crypto_box.boxzerobytes encrypted_length)
    >>=? fun i ->
    _assert (encrypted_length = i) __LOC__ ""
    >>=? fun () ->
    let remote_nonce = cryptobox_data.remote_nonce in
    cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
    match
      Crypto_box.fast_box_open_noalloc
        cryptobox_data.channel_key
        remote_nonce
        buf
    with
    | false ->
        fail P2p_errors.Decipher_error
    | true ->
        return
          (Bytes.sub
             buf
             Crypto_box.zerobytes
             (buf_length - Crypto_box.zerobytes))

  let (sk, pk, pkh) = Crypto_box.random_keypair ()

  let zero_nonce = Crypto_box.zero_nonce

  let channel_key = Crypto_box.precompute sk pk

  let (in_fd, out_fd) = Unix.pipe ()

  let data = {channel_key; local_nonce = zero_nonce; remote_nonce = zero_nonce}

  let wrap () =
    Alcotest_lwt.test_case "ACK" `Quick (fun _ () ->
        let msg = Bytes.of_string "test" in
        write_chunk out_fd data msg
        >>= fun _ ->
        read_chunk in_fd data
        >>= function
        | Ok res when Bytes.equal msg res ->
            Lwt.return_unit
        | Ok res ->
            Format.kasprintf
              Pervasives.failwith
              "Error : %s <> %s"
              (Bytes.to_string res)
              (Bytes.to_string msg)
        | Error error ->
            Format.kasprintf Pervasives.failwith "%a" pp_print_error error)
end

module Low_level = struct
  let simple_msg = Rand.generate (1 lsl 4)

  let client _ch sched addr port =
    let msg = Bytes.create (Bytes.length simple_msg) in
    raw_connect sched addr port
    >>= fun fd ->
    P2p_io_scheduler.read_full fd msg
    >>=? fun () ->
    _assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
    >>=? fun () -> P2p_io_scheduler.close fd >>=? fun () -> return_unit

  let server _ch sched socket =
    raw_accept sched socket
    >>= fun (fd, _point) ->
    P2p_io_scheduler.write fd simple_msg
    >>=? fun () -> P2p_io_scheduler.close fd >>=? fun _ -> return_unit

  let run _dir = run_nodes client server
end

module Kick = struct
  let encoding = Data_encoding.bytes

  let is_rejected = function
    | Error (P2p_errors.Rejected_socket_connection :: _) ->
        true
    | Ok _ ->
        false
    | Error err ->
        log_notice "Error: %a" pp_print_error err ;
        false

  let server _ch sched socket =
    accept sched socket
    >>=? fun (info, auth_fd) ->
    _assert info.incoming __LOC__ ""
    >>=? fun () ->
    _assert (P2p_peer.Id.compare info.peer_id id2.peer_id = 0) __LOC__ ""
    >>=? fun () -> P2p_socket.kick auth_fd >>= fun () -> return_unit

  let client _ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>= fun conn ->
    _assert (is_rejected conn) __LOC__ "" >>=? fun () -> return_unit

  let run _dir = run_nodes client server
end

module Kicked = struct
  let encoding = Data_encoding.bytes

  let server _ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>= fun conn ->
    _assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () -> return_unit

  let client _ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd -> P2p_socket.kick auth_fd >>= fun () -> return_unit

  let run _dir = run_nodes client server
end

module Simple_message = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 4)

  let simple_msg2 = Rand.generate (1 lsl 4)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg2
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Chunked_message = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 8)

  let simple_msg2 = Rand.generate (1 lsl 8)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler ~binary_chunks_size:21 auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler ~binary_chunks_size:21 auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg2
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Oversized_message = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 17)

  let simple_msg2 = Rand.generate (1 lsl 17)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg2
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Close_on_read = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 4)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    sync ch
    >>=? fun () ->
    P2p_socket.read conn
    >>= fun err ->
    _assert (is_connection_closed err) __LOC__ ""
    >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Close_on_write = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 4)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.close conn >>= fun _stat -> sync ch >>=? fun () -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    sync ch
    >>=? fun () ->
    Lwt_unix.sleep 0.1
    >>= fun () ->
    P2p_socket.write_sync conn simple_msg
    >>= fun err ->
    _assert (is_connection_closed err) __LOC__ ""
    >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Garbled_data = struct
  let encoding =
    let open Data_encoding in
    dynamic_size @@ option @@ string

  (* generate a fixed garbled_msg to avoid 'Data_encoding.Binary.Await
     _', which blocks 'make test' *)
  let garbled_msg =
    let buf = Bytes.create (1 lsl 4) in
    TzEndian.set_int32 buf 0 (Int32.of_int 4) ;
    TzEndian.set_int32 buf 4 (Int32.of_int (-1)) ;
    TzEndian.set_int32 buf 8 (Int32.of_int (-1)) ;
    TzEndian.set_int32 buf 12 (Int32.of_int (-1)) ;
    buf

  let server _ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.raw_write_sync conn garbled_msg
    >>=? fun () ->
    P2p_socket.read conn
    >>= fun err ->
    _assert (is_connection_closed err) __LOC__ ""
    >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client _ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.read conn
    >>= fun err ->
    _assert (is_decoding_error err) __LOC__ ""
    >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

let log_config = ref None

let spec =
  Arg.
    [ ( "--addr",
        String (fun p -> addr := Ipaddr.V6.of_string_exn p),
        " Listening addr" );
      ( "-v",
        Unit
          (fun () ->
            log_config :=
              Some
                (Lwt_log_sink_unix.create_cfg
                   ~rules:"test.p2p.connection -> info; p2p.connection -> info"
                   ())),
        " Log up to info msgs" );
      ( "-vv",
        Unit
          (fun () ->
            log_config :=
              Some
                (Lwt_log_sink_unix.create_cfg
                   ~rules:
                     "test.p2p.connection -> debug; p2p.connection -> debug"
                   ())),
        " Log up to debug msgs" ) ]

let init_logs = lazy (Internal_event_unix.init ?lwt_log_sink:!log_config ())

let wrap n f =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lazy.force init_logs
      >>= fun () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let main () =
  let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
  let usage_msg = "Usage: %s.\nArguments are:" in
  Arg.parse spec anon_fun usage_msg ;
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p-connection.",
        [ wrap "low-level" Low_level.run;
          wrap "kick" Kick.run;
          wrap "kicked" Kicked.run;
          wrap "simple-message" Simple_message.run;
          wrap "chunked-message" Chunked_message.run;
          wrap "oversized-message" Oversized_message.run;
          wrap "close-on-read" Close_on_read.run;
          wrap "close-on-write" Close_on_write.run;
          wrap "garbled-data" Garbled_data.run;
          Crypto_test.wrap () ] ) ]

let () =
  Sys.catch_break true ;
  try main () with _ -> ()
src/lib_p2p/test/test_p2p_socket.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.

Definition canceler : Tezos_stdlib.Lwt_canceler.t :=
  Tezos_stdlib.Lwt_canceler.create tt.

Definition proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target :=
  Tezos_base__TzPervasives.Crypto_box.make_target 16.

Definition id1 : Tezos_base__TzPervasives.P2p_identity.t :=
  Tezos_base__TzPervasives.P2p_identity.generate proof_of_work_target.

Definition id2 : Tezos_base__TzPervasives.P2p_identity.t :=
  Tezos_base__TzPervasives.P2p_identity.generate proof_of_work_target.

Definition id0 : Tezos_base__TzPervasives.P2p_identity.t :=
  Tezos_base__TzPervasives.P2p_identity.generate
    (Tezos_base__TzPervasives.Crypto_box.make_target 0).

Definition version : Tezos_base__TzPervasives.Network_version.t :=
  {|
    Network_version.chain_name :=
      Tezos_base__TzPervasives.Distributed_db_version.sandboxed_chain_name;
    Network_version.distributed_db_version :=
      Tezos_base__TzPervasives.Distributed_db_version.zero;
    Network_version.p2p_version := Tezos_base__TzPervasives.P2p_version.zero |}.

Definition metadata := unit.

Definition conn_meta_config : Tezos_p2p.P2p_socket.metadata_config metadata :=
  {| conn_meta_encoding := Tezos_base__TzPervasives.Data_encoding.empty;
    conn_meta_value :=
      fun function_parameter =>
        match function_parameter with
        | _ => tt
        end;
    private_node :=
      fun function_parameter =>
        match function_parameter with
        | _ => false
        end |}.

Fixpoint listen (port : option Z) (addr : Ipaddr.V6.t)
  : Lwt.t (Lwt_unix.file_descr * Z) :=
  let tentative_port :=
    match port with
    | None => Z.add 1024 (Stdlib.Random.int 8192)
    | Some port => port
    end in
  let uaddr := Ipaddr_unix.V6.to_inet_addr addr in
  let main_socket := Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
  Lwt_unix.setsockopt main_socket SO_REUSEADDR true;
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Lwt_unix.bind main_socket (ADDR_INET uaddr tentative_port))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Lwt_unix.listen main_socket 1;
              Lwt._return (main_socket, tentative_port)
            end)
      end)
    (fun function_parameter =>
      match function_parameter with
      | Unix.Unix_error (Unix.EADDRINUSE | Unix.EADDRNOTAVAIL) _ _ =>
        listen None addr
      | exn => Lwt.fail exn
      end).

Definition sync {A : Type} (ch : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ch tt)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star ch)
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Fixpoint sync_nodes {A B : Type} (nodes : list A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.iter_p
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
        end) nodes)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_base__TzPervasives.iter_p
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star tt
              end) nodes)
          (fun function_parameter =>
            match function_parameter with
            | tt => sync_nodes nodes
            end)
      end).

Definition sync_nodes {A : Type} (nodes : list A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (sync_nodes nodes)
    (fun function_parameter =>
      match function_parameter with
      | inl tt | inr (cons (Exn OCaml.End_of_file) _) =>
        Tezos_base__TzPervasives.return_unit
      | (inr _) as err => Lwt._return err
      end).

Definition run_nodes {A B C : Type}
  (client :
    A ->
      Tezos_p2p.P2p_io_scheduler.t ->
        Ipaddr.V6.t -> Z -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (server :
    B ->
      Tezos_p2p.P2p_io_scheduler.t ->
        Lwt_unix.file_descr -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t C :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (listen None (Stdlib.op_exclamation addr))
    (fun function_parameter =>
      match function_parameter with
      | (main_socket, port) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (op_star_t_y_p_e_minus_e_r_r_o_r_star "server: " % string
            (fun channel =>
              let sched :=
                Tezos_p2p.P2p_io_scheduler.create None None None None
                  (Z.shiftl 1 12) tt in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (server channel sched main_socket)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_p2p.P2p_io_scheduler.shutdown None sched)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_base__TzPervasives.return_unit
                        end)
                  end)))
          (fun server_node =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (op_star_t_y_p_e_minus_e_r_r_o_r_star "client: " % string
                (fun channel =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_stdlib_unix.Lwt_utils_unix.safe_close main_socket)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        let sched :=
                          Tezos_p2p.P2p_io_scheduler.create None None None None
                            (Z.shiftl 1 12) tt in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (client channel sched (Stdlib.op_exclamation addr)
                            port)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_p2p.P2p_io_scheduler.shutdown None sched)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                            end)
                      end)))
              (fun client_node =>
                let nodes := cons server_node (cons client_node []) in
                Lwt.ignore_result (sync_nodes nodes);
                op_star_t_y_p_e_minus_e_r_r_o_r_star nodes))
      end).

Definition raw_accept
  (sched : Tezos_p2p.P2p_io_scheduler.t) (main_socket : Lwt_unix.file_descr)
  : Lwt.t (Tezos_p2p.P2p_io_scheduler.connection * (Ipaddr.V6.t * Z)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_p2p.P2p_fd.accept main_socket)
    (fun function_parameter =>
      match function_parameter with
      | (fd, sockaddr) =>
        let fd := Tezos_p2p.P2p_io_scheduler.register sched fd in
        let point :=
          match sockaddr with
          | Lwt_unix.ADDR_UNIX _ => false
          | Lwt_unix.ADDR_INET addr port =>
            ((Ipaddr_unix.V6.of_inet_addr_exn addr), port)
          end in
        Lwt._return (fd, point)
      end).

Definition accept
  (sched : Tezos_p2p.P2p_io_scheduler.t) (main_socket : Lwt_unix.file_descr)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_base__TzPervasives.P2p_connection.Info.t metadata) *
        (Tezos_p2p.P2p_socket.authenticated_connection metadata))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (raw_accept sched main_socket)
    (fun function_parameter =>
      match function_parameter with
      | (fd, point) =>
        Tezos_p2p.P2p_socket.authenticate canceler proof_of_work_target true fd
          point None id1 version conn_meta_config
      end).

Definition raw_connect
  (sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Ipaddr.V6.t) (port : Z)
  : Lwt.t Tezos_p2p.P2p_io_scheduler.connection :=
  let fd := Tezos_p2p.P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
  let uaddr := Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port in
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_p2p.P2p_fd.connect fd uaddr)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let fd := Tezos_p2p.P2p_io_scheduler.register sched fd in
        Lwt._return fd
      end).

Definition connect
  (sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Tezos_base.P2p_addr.t)
  (port : Tezos_base.P2p_addr.port)
  (id : Tezos_base__TzPervasives.P2p_identity.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_p2p.P2p_socket.authenticated_connection metadata)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (raw_connect sched addr port)
    (fun fd =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_p2p.P2p_socket.authenticate canceler proof_of_work_target false
          fd (addr, port) None id version conn_meta_config)
        (fun function_parameter =>
          match function_parameter with
          | (info, auth_fd) =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives._assert (negb (incoming info))
                Stdlib.__LOC__
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_base__TzPervasives._assert
                      (equiv_decb
                        (Tezos_base__TzPervasives.P2p_peer.Id.compare
                          (peer_id info) (peer_id id1)) 0) Stdlib.__LOC__
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives._return auth_fd
                      end)
                end)
          end)).

Definition is_connection_closed {A : Type}
  (function_parameter : sum A (list Tezos_base__TzPervasives.error)) : bool :=
  match function_parameter with
  | inr (cons P2p_errors.Connection_closed _) => true
  | inl _ => false
  | inr err =>
    log_notice
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Error: " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Error: %a" % string) Tezos_base__TzPervasives.pp_print_error err;
    false
  end.

Definition is_decoding_error {A : Type}
  (function_parameter : sum A (list Tezos_base__TzPervasives.error)) : bool :=
  match function_parameter with
  | inr (cons P2p_errors.Decoding_error _) => true
  | inl _ => false
  | inr err =>
    log_notice
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Error: " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Error: %a" % string) Tezos_base__TzPervasives.pp_print_error err;
    false
  end.

Module Crypto_test.
  Definition bufsize : Z := Z.sub (Z.shiftl 1 16) 1.
  
  Definition header_length : Z := 2.
  
  Definition max_content_length : Z :=
    Z.sub bufsize Tezos_base__TzPervasives.Crypto_box.zerobytes.
  
  Definition boxextrabytes : Z :=
    Z.sub Tezos_base__TzPervasives.Crypto_box.zerobytes
      Tezos_base__TzPervasives.Crypto_box.boxzerobytes.
  
  Definition extrabytes : Z := Z.add header_length boxextrabytes.
  
  Record data := {
    channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key;
    local_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
    remote_nonce : Tezos_base__TzPervasives.Crypto_box.nonce }.
  
  Definition write_chunk
    (fd : Unix.file_descr) (cryptobox_data : data) (msg : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let msglen := String.length msg in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.fail_unless
        (OCaml.Stdlib.le msglen max_content_length)
        P2p_errors.Invalid_message_size)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let buf_length :=
            Z.add msglen Tezos_base__TzPervasives.Crypto_box.zerobytes in
          let buf := Stdlib.Bytes.make buf_length "000" % char in
          Stdlib.Bytes.blit msg 0 buf
            Tezos_base__TzPervasives.Crypto_box.zerobytes msglen;
          let local_nonce := local_nonce cryptobox_data in
          set_field;
          Tezos_base__TzPervasives.Crypto_box.fast_box_noalloc
            (channel_key cryptobox_data) local_nonce buf;
          let encrypted_length :=
            Z.sub buf_length Tezos_base__TzPervasives.Crypto_box.boxzerobytes in
          let header_pos :=
            Z.sub Tezos_base__TzPervasives.Crypto_box.boxzerobytes header_length
            in
          Tezos_stdlib.TzEndian.set_int16 buf header_pos encrypted_length;
          let payload := String.sub buf header_pos (Z.sub buf_length header_pos)
            in
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_base__TzPervasives._return
              (Unix.write fd payload 0 (Z.sub buf_length header_pos)))
            (fun i =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives._assert
                  (equiv_decb (Z.sub buf_length header_pos) i) Stdlib.__LOC__
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end))
        end).
  
  Definition read_chunk (fd : Unix.file_descr) (cryptobox_data : data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    let header_buf := Stdlib.Bytes.create header_length in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives._return
        (Unix.read fd header_buf 0 header_length))
      (fun i =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_base__TzPervasives._assert (equiv_decb header_length i)
            Stdlib.__LOC__
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let encrypted_length :=
                Tezos_stdlib.TzEndian.get_uint16 header_buf 0 in
              let buf_length :=
                Z.add encrypted_length
                  Tezos_base__TzPervasives.Crypto_box.boxzerobytes in
              let buf := Stdlib.Bytes.make buf_length "000" % char in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives._return
                  (Unix.read fd buf
                    Tezos_base__TzPervasives.Crypto_box.boxzerobytes
                    encrypted_length))
                (fun i =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_base__TzPervasives._assert
                      (equiv_decb encrypted_length i) Stdlib.__LOC__
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        let remote_nonce := remote_nonce cryptobox_data in
                        set_field;
                        match
                          Tezos_base__TzPervasives.Crypto_box.fast_box_open_noalloc
                            (channel_key cryptobox_data) remote_nonce buf with
                        | false =>
                          Tezos_base__TzPervasives.fail
                            P2p_errors.Decipher_error
                        | true =>
                          Tezos_base__TzPervasives._return
                            (String.sub buf
                              Tezos_base__TzPervasives.Crypto_box.zerobytes
                              (Z.sub buf_length
                                Tezos_base__TzPervasives.Crypto_box.zerobytes))
                        end
                      end))
            end)).
  
  Definition zero_nonce : Tezos_base__TzPervasives.Crypto_box.nonce :=
    Tezos_base__TzPervasives.Crypto_box.zero_nonce.
  
  Definition channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key :=
    Tezos_base__TzPervasives.Crypto_box.precompute sk pk.
  
  Definition data : data :=
    {| channel_key := channel_key; local_nonce := zero_nonce;
      remote_nonce := zero_nonce |}.
  
  Definition wrap {A : Type} (function_parameter : unit) : A :=
    match function_parameter with
    | tt =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star "ACK" % string variant
        (fun function_parameter =>
          match function_parameter with
          | _ =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                let msg := Stdlib.Bytes.of_string "test" % string in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (write_chunk out_fd data msg)
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (read_chunk in_fd data)
                        (fun function_parameter =>
                          match function_parameter with
                          | inl res => Lwt.return_unit
                          | inl res =>
                            Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Error : " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String_literal
                                      " <> " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))))
                                "Error : %s <> %s" % string)
                              (Stdlib.Bytes.to_string res)
                              (Stdlib.Bytes.to_string msg)
                          | inr error =>
                            Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)
                                "%a" % string)
                              Tezos_base__TzPervasives.pp_print_error error
                          end)
                    end)
              end
          end)
    end.
End Crypto_test.

Module Low_level.
  Definition simple_msg : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 4).
  
  Definition client {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Ipaddr.V6.t)
    (port : Z) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let msg := Stdlib.Bytes.create (String.length simple_msg) in
    Tezos_base__TzPervasives.op_gt_gt_eq (raw_connect sched addr port)
      (fun fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_io_scheduler.read_full None fd None None msg)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives._assert
                  (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
                  Stdlib.__LOC__
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_p2p.P2p_io_scheduler.close None fd)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_base__TzPervasives.return_unit
                        end)
                  end)
            end)).
  
  Definition server {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq (raw_accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (fd, _point) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_io_scheduler.write None fd simple_msg)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_p2p.P2p_io_scheduler.close None fd)
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => Tezos_base__TzPervasives.return_unit
                    end)
              end)
        end).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Low_level.

Module Kick.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.bytes.
  
  Definition is_rejected {A : Type}
    (function_parameter : sum A (list Tezos_base__TzPervasives.error)) : bool :=
    match function_parameter with
    | inr (cons P2p_errors.Rejected_socket_connection _) => true
    | inl _ => false
    | inr err =>
      log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Error: " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "Error: %a" % string)
        Tezos_base__TzPervasives.pp_print_error err;
      false
    end.
  
  Definition server {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (info, auth_fd) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_base__TzPervasives._assert (incoming info) Stdlib.__LOC__
              (CamlinternalFormatBasics.Format
                CamlinternalFormatBasics.End_of_format "" % string))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_base__TzPervasives._assert
                    (equiv_decb
                      (Tezos_base__TzPervasives.P2p_peer.Id.compare
                        (peer_id info) (peer_id id2)) 0) Stdlib.__LOC__
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_p2p.P2p_socket.kick auth_fd)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives.return_unit
                          end)
                    end)
              end)
        end).
  
  Definition client {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (connect sched addr port id2)
      (fun auth_fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives._assert (is_rejected conn)
                Stdlib.__LOC__
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives.return_unit
                end))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Kick.

Module Kicked.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.bytes.
  
  Definition server {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (_info, auth_fd) =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd
              encoding)
            (fun conn =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives._assert (Kick.is_rejected conn)
                  Stdlib.__LOC__
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end))
        end).
  
  Definition client {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (connect sched addr port id2)
      (fun auth_fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_p2p.P2p_socket.kick auth_fd)
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Kicked.

Module Simple_message.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 4).
  
  Definition simple_msg2 : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 4).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (_info, auth_fd) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd
              encoding)
            (fun conn =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_p2p.P2p_socket.write_sync conn simple_msg)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_p2p.P2p_socket.read conn)
                      (fun function_parameter =>
                        match function_parameter with
                        | (_msg_size, msg) =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_base__TzPervasives._assert
                              (equiv_decb (Stdlib.Bytes.compare simple_msg2 msg)
                                0) Stdlib.__LOC__
                              (CamlinternalFormatBasics.Format
                                CamlinternalFormatBasics.End_of_format
                                "" % string))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (sync ch)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_p2p.P2p_socket.close None conn)
                                        (fun _stat =>
                                          Tezos_base__TzPervasives.return_unit)
                                    end)
                              end)
                        end)
                  end))
        end).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (connect sched addr port id2)
      (fun auth_fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_p2p.P2p_socket.write_sync conn simple_msg2)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_p2p.P2p_socket.read conn)
                    (fun function_parameter =>
                      match function_parameter with
                      | (_msg_size, msg) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base__TzPervasives._assert
                            (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
                            Stdlib.__LOC__
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (sync ch)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Tezos_p2p.P2p_socket.close None conn)
                                      (fun _stat =>
                                        Tezos_base__TzPervasives.return_unit)
                                  end)
                            end)
                      end)
                end))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Simple_message.

Module Chunked_message.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 8).
  
  Definition simple_msg2 : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 8).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (_info, auth_fd) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_socket.accept None None (Some 21) canceler auth_fd
              encoding)
            (fun conn =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_p2p.P2p_socket.write_sync conn simple_msg)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_p2p.P2p_socket.read conn)
                      (fun function_parameter =>
                        match function_parameter with
                        | (_msg_size, msg) =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_base__TzPervasives._assert
                              (equiv_decb (Stdlib.Bytes.compare simple_msg2 msg)
                                0) Stdlib.__LOC__
                              (CamlinternalFormatBasics.Format
                                CamlinternalFormatBasics.End_of_format
                                "" % string))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (sync ch)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_p2p.P2p_socket.close None conn)
                                        (fun _stat =>
                                          Tezos_base__TzPervasives.return_unit)
                                    end)
                              end)
                        end)
                  end))
        end).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (connect sched addr port id2)
      (fun auth_fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_socket.accept None None (Some 21) canceler auth_fd
            encoding)
          (fun conn =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_p2p.P2p_socket.write_sync conn simple_msg2)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_p2p.P2p_socket.read conn)
                    (fun function_parameter =>
                      match function_parameter with
                      | (_msg_size, msg) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base__TzPervasives._assert
                            (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
                            Stdlib.__LOC__
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (sync ch)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Tezos_p2p.P2p_socket.close None conn)
                                      (fun _stat =>
                                        Tezos_base__TzPervasives.return_unit)
                                  end)
                            end)
                      end)
                end))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Chunked_message.

Module Oversized_message.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 17).
  
  Definition simple_msg2 : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 17).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (_info, auth_fd) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd
              encoding)
            (fun conn =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_p2p.P2p_socket.write_sync conn simple_msg)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_p2p.P2p_socket.read conn)
                      (fun function_parameter =>
                        match function_parameter with
                        | (_msg_size, msg) =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_base__TzPervasives._assert
                              (equiv_decb (Stdlib.Bytes.compare simple_msg2 msg)
                                0) Stdlib.__LOC__
                              (CamlinternalFormatBasics.Format
                                CamlinternalFormatBasics.End_of_format
                                "" % string))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (sync ch)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_p2p.P2p_socket.close None conn)
                                        (fun _stat =>
                                          Tezos_base__TzPervasives.return_unit)
                                    end)
                              end)
                        end)
                  end))
        end).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (connect sched addr port id2)
      (fun auth_fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_p2p.P2p_socket.write_sync conn simple_msg2)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_p2p.P2p_socket.read conn)
                    (fun function_parameter =>
                      match function_parameter with
                      | (_msg_size, msg) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base__TzPervasives._assert
                            (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
                            Stdlib.__LOC__
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (sync ch)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Tezos_p2p.P2p_socket.close None conn)
                                      (fun _stat =>
                                        Tezos_base__TzPervasives.return_unit)
                                  end)
                            end)
                      end)
                end))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Oversized_message.

Module Close_on_read.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 4).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (_info, auth_fd) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd
              encoding)
            (fun conn =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question (sync ch)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_p2p.P2p_socket.close None conn)
                      (fun _stat => Tezos_base__TzPervasives.return_unit)
                  end))
        end).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (connect sched addr port id2)
      (fun auth_fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question (sync ch)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_p2p.P2p_socket.read conn)
                    (fun err =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_base__TzPervasives._assert
                          (is_connection_closed err) Stdlib.__LOC__
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_p2p.P2p_socket.close None conn)
                              (fun _stat => Tezos_base__TzPervasives.return_unit)
                          end))
                end))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Close_on_read.

Module Close_on_write.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Rand.generate (Z.shiftl 1 4).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (_info, auth_fd) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd
              encoding)
            (fun conn =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_p2p.P2p_socket.close None conn)
                (fun _stat =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question (sync ch)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)))
        end).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (connect sched addr port id2)
      (fun auth_fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question (sync ch)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.sleep 0)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_p2p.P2p_socket.write_sync conn simple_msg)
                          (fun err =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_base__TzPervasives._assert
                                (is_connection_closed err) Stdlib.__LOC__
                                (CamlinternalFormatBasics.Format
                                  CamlinternalFormatBasics.End_of_format
                                  "" % string))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_p2p.P2p_socket.close None conn)
                                    (fun _stat =>
                                      Tezos_base__TzPervasives.return_unit)
                                end))
                      end)
                end))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Close_on_write.

Module Garbled_data.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding (option string) :=
    apply
      (let arg := Tezos_base__TzPervasives.Data_encoding.dynamic_size in
      fun eta => arg None eta)
      (apply Tezos_base__TzPervasives.Data_encoding.option
        Tezos_base__TzPervasives.Data_encoding.string).
  
  Definition garbled_msg : string :=
    let buf := Stdlib.Bytes.create (Z.shiftl 1 4) in
    Tezos_stdlib.TzEndian.set_int32 buf 0 (Stdlib.Int32.of_int 4);
    Tezos_stdlib.TzEndian.set_int32 buf 4 (Stdlib.Int32.of_int (-1));
    Tezos_stdlib.TzEndian.set_int32 buf 8 (Stdlib.Int32.of_int (-1));
    Tezos_stdlib.TzEndian.set_int32 buf 12 (Stdlib.Int32.of_int (-1));
    buf.
  
  Definition server {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (accept sched socket)
      (fun function_parameter =>
        match function_parameter with
        | (_info, auth_fd) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd
              encoding)
            (fun conn =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_p2p.P2p_socket.raw_write_sync conn garbled_msg)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_p2p.P2p_socket.read conn)
                      (fun err =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base__TzPervasives._assert
                            (is_connection_closed err) Stdlib.__LOC__
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_p2p.P2p_socket.close None conn)
                                (fun _stat =>
                                  Tezos_base__TzPervasives.return_unit)
                            end))
                  end))
        end).
  
  Definition client {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (connect sched addr port id2)
      (fun auth_fd =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_p2p.P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_p2p.P2p_socket.read conn)
              (fun err =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_base__TzPervasives._assert (is_decoding_error err)
                    Stdlib.__LOC__
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_p2p.P2p_socket.close None conn)
                        (fun _stat => Tezos_base__TzPervasives.return_unit)
                    end)))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Garbled_data.

Definition log_config
  : Stdlib.ref (option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg) :=
  Stdlib.ref None.

Definition spec : list (string * Stdlib.Arg.spec * string) :=
  cons
    ("--addr" % string,
      (String (fun p => Stdlib.op_colon_eq addr (Ipaddr.V6.of_string_exn p))),
      " Listening addr" % string)
    (cons
      ("-v" % string,
        (Unit
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Stdlib.op_colon_eq log_config
                (Some
                  (Tezos_stdlib_unix.Lwt_log_sink_unix.create_cfg None None
                    (Some
                      "test.p2p.connection -> info; p2p.connection -> info" %
                        string) None tt))
            end)), " Log up to info msgs" % string)
      (cons
        ("-vv" % string,
          (Unit
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Stdlib.op_colon_eq log_config
                  (Some
                    (Tezos_stdlib_unix.Lwt_log_sink_unix.create_cfg None None
                      (Some
                        "test.p2p.connection -> debug; p2p.connection -> debug"
                          % string) None tt))
              end)), " Log up to debug msgs" % string) [])).

Definition init_logs : lazy_t (Lwt.t unit) :=
  Tezos_stdlib_unix.Internal_event_unix.init (Stdlib.op_exclamation log_config)
    None tt.

Definition wrap {A B : Type}
  (n : A) (f : unit -> Lwt.t (sum unit (list Tezos_base__TzPervasives.error)))
  : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq (Stdlib.Lazy.force init_logs)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (f tt)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl tt => Lwt.return_unit
                      | inr error =>
                        Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string)
                          Tezos_base__TzPervasives.pp_print_error error
                      end)
                end)
          end
      end).

Definition main {A : Type} (function_parameter : unit) : A :=
  match function_parameter with
  | tt =>
    let anon_fun {B C : Type} (_num_peers : B) : C :=
      Stdlib.raise (Arg.Bad "No anonymous argument." % string) in
    let usage_msg := "Usage: %s.
Arguments are:" % string in
    Stdlib.Arg.parse spec anon_fun usage_msg;
    op_star_t_y_p_e_minus_e_r_r_o_r_star ("" % string) "tezos-p2p" % string
      (cons
        ("p2p-connection." % string,
          (cons (wrap "low-level" % string Low_level.run)
            (cons (wrap "kick" % string Kick.run)
              (cons (wrap "kicked" % string Kicked.run)
                (cons (wrap "simple-message" % string Simple_message.run)
                  (cons (wrap "chunked-message" % string Chunked_message.run)
                    (cons
                      (wrap "oversized-message" % string Oversized_message.run)
                      (cons (wrap "close-on-read" % string Close_on_read.run)
                        (cons
                          (wrap "close-on-write" % string Close_on_write.run)
                          (cons (wrap "garbled-data" % string Garbled_data.run)
                            (cons (Crypto_test.wrap tt) []))))))))))) [])
  end.
src/lib_protocol_compiler/byte.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The OCaml compiler not being implemented with Lwt, the compilation
    take place in a separated process (by using [Lwt_process.exec]).

    The [main] function is the entry point for the forked process.
    While [Updater.compile] is the 'forking' function to be called by
    the [tezos-node] process.

*)

(** Semi-generic compilation functions *)

let pack_objects output objects =
  let output = output ^ ".cmo" in
  Compmisc.init_path true ;
  Bytepackager.package_files
    Format.err_formatter
    Env.initial_safe_string
    objects
    output ;
  Warnings.check_fatal () ;
  output

let link_shared output objects =
  Compenv.(readenv Format.err_formatter Before_link) ;
  Compmisc.init_path true ;
  Bytelink.link Format.err_formatter objects output ;
  Warnings.check_fatal ()

let compile_ml ?for_pack ml =
  let target = Filename.chop_extension ml in
  Clflags.for_package := for_pack ;
  Compenv.(readenv Format.err_formatter (Before_compile ml)) ;
  Compile.implementation Format.err_formatter ml target ;
  Clflags.for_package := None ;
  target ^ ".cmo"

let () = Clflags.native_code := false

let driver = Compiler.{compile_ml; link_shared; pack_objects}
src/lib_protocol_compiler/byte.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition pack_objects (output : string) (objects : list string) : string :=
  let output := String.append output ".cmo" % string in
  Compmisc.init_path None true;
  Bytepackager.package_files Stdlib.Format.err_formatter Env.initial_safe_string
    objects output;
  Warnings.check_fatal tt;
  output.

Definition link_shared (output : string) (objects : list string) : unit :=
  Compenv.readenv Stdlib.Format.err_formatter Before_link;
  Compmisc.init_path None true;
  Bytelink.link Stdlib.Format.err_formatter objects output;
  Warnings.check_fatal tt.

Definition compile_ml (for_pack : option string) (ml : Compenv.filename)
  : string :=
  let target := Stdlib.Filename.chop_extension ml in
  Stdlib.op_colon_eq Clflags.for_package for_pack;
  Compenv.readenv Stdlib.Format.err_formatter (Before_compile ml);
  Compile.implementation Stdlib.Format.err_formatter ml target;
  Stdlib.op_colon_eq Clflags.for_package None;
  String.append target ".cmo" % string.

Definition driver : Tezos_protocol_compiler.Compiler.driver :=
  {| compile_ml := compile_ml; pack_objects := pack_objects;
    link_shared := link_shared |}.
src/lib_protocol_compiler/byte.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val driver : Compiler.driver
src/lib_protocol_compiler/byte.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter driver : Tezos_protocol_compiler.Compiler.driver.
src/lib_protocol_compiler/compiler.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let warnings = "+a-4-6-7-9-29-40..42-44-45-48"

let warn_error = "-a+8"

let () = Clflags.unsafe_string := false

(** Override the default 'Env.Persistent_signature.load'
    with a lookup in locally defined hashtable.
*)

let preloaded_cmis : (string, Env.Persistent_signature.t) Hashtbl.t =
  Hashtbl.create ~random:true 42

(* Set hook *)
let () =
  Env.Persistent_signature.load :=
    fun ~unit_name ->
      try
        Some (Hashtbl.find preloaded_cmis (String.capitalize_ascii unit_name))
      with Not_found -> None

let load_cmi_from_file file =
  Hashtbl.add
    preloaded_cmis
    (String.capitalize_ascii Filename.(basename (chop_extension file)))
    {filename = file; cmi = Cmi_format.read_cmi file}

let load_embeded_cmi (unit_name, content) =
  let content = Bytes.of_string content in
  (* Read cmi magic *)
  let magic_len = String.length Config.cmi_magic_number in
  let magic = Bytes.sub content 0 magic_len in
  assert (magic = Bytes.of_string Config.cmi_magic_number) ;
  (* Read cmi_name and cmi_sign *)
  let pos = magic_len in
  let (cmi_name, cmi_sign) = Marshal.from_bytes content pos in
  let pos = pos + Marshal.total_size content pos in
  (* Read cmi_crcs *)
  let cmi_crcs = Marshal.from_bytes content pos in
  let pos = pos + Marshal.total_size content pos in
  (* Read cmi_flags *)
  let cmi_flags = Marshal.from_bytes content pos in
  (* TODO check crcrs... *)
  Hashtbl.add
    preloaded_cmis
    (String.capitalize_ascii unit_name)
    {
      filename = unit_name ^ ".cmi";
      cmi = {cmi_name; cmi_sign; cmi_crcs; cmi_flags};
    }

let load_embeded_cmis cmis = List.iter load_embeded_cmi cmis

(** Compilation environment.

    [tezos_protocol_env] defines the list of [cmi] available while compiling
    the protocol version. The [cmi] are packed into the [tezos-node]
    binary by using [ocp-ocamlres], see the Makefile.

    [register_env] defines a complementary list of [cmi] available
    while compiling the generated [register.ml] file (that register
    the protocol first-class module into the [Updater.versions]
    hashtable).

*)

let tezos_protocol_env =
  let open Embedded_cmis in
  [ ("CamlinternalFormatBasics", camlinternalFormatBasics_cmi);
    ("Tezos_protocol_environment_sigs", tezos_protocol_environment_sigs_cmi);
    ( "Tezos_protocol_environment_sigs__V1",
      tezos_protocol_environment_sigs__V1_cmi ) ]

let register_env =
  let open Embedded_cmis in
  [ ( "tezos_protocol_registerer__Registerer",
      tezos_protocol_registerer__Registerer_cmi ) ]

(** Helpers *)

let ( // ) = Filename.concat

let create_file ?(perm = 0o644) name content =
  let open Unix in
  let fd = openfile name [O_TRUNC; O_CREAT; O_WRONLY] perm in
  ignore (write_substring fd content 0 (String.length content)) ;
  close fd

let safe_unlink file =
  try Unix.unlink file with Unix.Unix_error (Unix.ENOENT, _, _) -> ()

let unlink_cmi dir (file, _) = safe_unlink ((dir // file) ^ ".cmi")

let unlink_object obj =
  safe_unlink obj ;
  safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".cmi") ;
  safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".o")

let debug_flag = ref false

let debug fmt =
  if !debug_flag then Format.eprintf fmt
  else Format.ifprintf Format.err_formatter fmt

let mktemp_dir () =
  Filename.get_temp_dir_name ()
  // Printf.sprintf "tezos-protocol-build-%06X" (Random.int 0xFFFFFF)

(** Main *)

type driver = {
  compile_ml : ?for_pack:string -> string -> string;
  pack_objects : string -> string list -> string;
  link_shared : string -> string list -> unit;
}

let main {compile_ml; pack_objects; link_shared} =
  Random.self_init () ;
  let anonymous = ref []
  and static = ref false
  and register = ref false
  and build_dir = ref None
  and output_file = ref None
  and output_dep = ref false
  and hash_only = ref false
  and check_protocol_hash = ref true in
  let args_spec =
    [ ("-o", Arg.String (fun s -> output_file := Some s), "");
      ( "-hash-only",
        Arg.Set hash_only,
        " Only display the hash of the protocol and don't compile" );
      ( "-no-hash-check",
        Arg.Clear check_protocol_hash,
        " Don't check that TEZOS_PROTOCOL declares the expected protocol hash \
         (if existent)" );
      ("-static", Arg.Set static, " Only build the static library (no .cmxs)");
      ("-register", Arg.Set register, " Generate the `Registerer` module");
      ("-bin-annot", Arg.Set Clflags.binary_annotations, " (see ocamlopt)");
      ("-g", Arg.Set Clflags.debug, " (see ocamlopt)");
      ("-output-dep", Arg.Set output_dep, " ...");
      ( "-build-dir",
        Arg.String (fun s -> build_dir := Some s),
        "use custom build directory and preserve build artifacts" ) ]
  in
  let usage_msg =
    Printf.sprintf "Usage: %s [options] <srcdir>\nOptions are:" Sys.argv.(0)
  in
  Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ;
  let source_dir =
    match List.rev !anonymous with
    | [protocol_dir] ->
        protocol_dir
    | _ ->
        Arg.usage args_spec usage_msg ;
        Pervasives.exit 1
  in
  let (announced_hash, protocol) =
    match
      Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir)
    with
    | Ok (hash, proto) ->
        (hash, proto)
    | Error err ->
        Format.eprintf "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err ;
        exit 2
  in
  let real_hash = Protocol.hash protocol in
  if !hash_only then (
    Format.printf "%a@." Protocol_hash.pp real_hash ;
    exit 0 ) ;
  let hash =
    match announced_hash with
    | None ->
        real_hash
    | Some hash
      when !check_protocol_hash && not (Protocol_hash.equal real_hash hash) ->
        Format.eprintf
          "Inconsistent hash for protocol in TEZOS_PROTOCOL.@\n\
           Found: %a@\n\
           Expected: %a@."
          Protocol_hash.pp
          hash
          Protocol_hash.pp
          real_hash ;
        exit 2
    | Some hash ->
        hash
  in
  let build_dir =
    match !build_dir with
    | None ->
        let dir = mktemp_dir () in
        at_exit (fun () -> Lwt_main.run (Lwt_utils_unix.remove_dir dir)) ;
        dir
    | Some dir ->
        dir
  in
  let output =
    match !output_file with
    | Some output ->
        output
    | None ->
        Format.asprintf "proto_%a" Protocol_hash.pp hash
  in
  Lwt_main.run (Lwt_utils_unix.create_dir ~perm:0o755 build_dir) ;
  Lwt_main.run
    (Lwt_utils_unix.create_dir ~perm:0o755 (Filename.dirname output)) ;
  (* Generate the 'functor' *)
  let functor_file = build_dir // "functor.ml" in
  let oc = open_out functor_file in
  Packer.dump
    oc
    hash
    (Array.map
       (fun {Protocol.name; _} ->
         let name_lowercase = String.uncapitalize_ascii name in
         (source_dir // name_lowercase) ^ ".ml")
       (Array.of_list protocol.components)) ;
  close_out oc ;
  (* Compile the protocol *)
  let proto_cmi = Filename.chop_extension functor_file ^ ".cmi" in
  let functor_unit =
    String.capitalize_ascii Filename.(basename (chop_extension functor_file))
  in
  let for_pack = String.capitalize_ascii (Filename.basename output) in
  (* Initialize the compilers *)
  Compenv.(readenv Format.err_formatter Before_args) ;
  Clflags.nopervasives := true ;
  Clflags.no_std_include := true ;
  Clflags.include_dirs := [Filename.dirname functor_file] ;
  Warnings.parse_options false warnings ;
  Warnings.parse_options true warn_error ;
  load_embeded_cmis tezos_protocol_env ;
  let packed_protocol_object = compile_ml ~for_pack functor_file in
  let register_objects =
    if not !register then []
    else (
      load_embeded_cmis register_env ;
      load_cmi_from_file proto_cmi ;
      (* Compiler the 'registering module' *)
      let register_file = Filename.dirname functor_file // "register.ml" in
      create_file
        register_file
        (Printf.sprintf
           "module Name = struct let name = %S end\n\
           \ let () = Tezos_protocol_registerer__Registerer.register \
            Name.name (module %s.Make)"
           (Protocol_hash.to_b58check hash)
           functor_unit) ;
      let register_object = compile_ml ~for_pack register_file in
      [register_object] )
  in
  let resulting_object =
    pack_objects output (packed_protocol_object :: register_objects)
  in
  (* Create the final [cmxs] *)
  if not !static then (
    Clflags.link_everything := true ;
    link_shared (output ^ ".cmxs") [resulting_object] ) ;
  if !output_dep then (
    let dsrc = Digest.file functor_file in
    let dimpl = Digest.file resulting_object in
    let dintf =
      Digest.file (Filename.chop_extension resulting_object ^ ".cmi")
    in
    Format.printf "module Toto = struct include %s end ;; \n" for_pack ;
    Format.printf "let src_digest = %S ;;\n" (Digest.to_hex dsrc) ;
    Format.printf "let impl_digest = %S ;;\n" (Digest.to_hex dimpl) ;
    Format.printf "let intf_digest = %S ;;\n" (Digest.to_hex dintf) ) ;
  Format.printf "Success: %a.@." Protocol_hash.pp hash
src/lib_protocol_compiler/compiler.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition warnings : string := "+a-4-6-7-9-29-40..42-44-45-48" % string.

Definition warn_error : string := "-a+8" % string.

Definition preloaded_cmis
  : Stdlib.Hashtbl.t string Env.Persistent_signature.t :=
  Stdlib.Hashtbl.create (Some true) 42.

Definition load_cmi_from_file (file : string) : unit :=
  Stdlib.Hashtbl.add preloaded_cmis
    (Tezos_base__TzPervasives.String.capitalize_ascii
      (Stdlib.Filename.basename (Stdlib.Filename.chop_extension file)))
    {| filename := file; cmi := Cmi_format.read_cmi file |}.

Definition load_embeded_cmi (function_parameter : string * string) : unit :=
  match function_parameter with
  | (unit_name, content) =>
    let content := Stdlib.Bytes.of_string content in
    let magic_len :=
      Tezos_base__TzPervasives.String.length Config.cmi_magic_number in
    let magic := String.sub content 0 magic_len in
    equiv_decb magic (Stdlib.Bytes.of_string Config.cmi_magic_number);
    let pos := magic_len in
    match Stdlib.Marshal.from_bytes content pos with
    | (cmi_name, cmi_sign) =>
      let pos := Z.add pos (Stdlib.Marshal.total_size content pos) in
      let cmi_crcs := Stdlib.Marshal.from_bytes content pos in
      let pos := Z.add pos (Stdlib.Marshal.total_size content pos) in
      let cmi_flags := Stdlib.Marshal.from_bytes content pos in
      Stdlib.Hashtbl.add preloaded_cmis
        (Tezos_base__TzPervasives.String.capitalize_ascii unit_name)
        {| filename := String.append unit_name ".cmi" % string;
          cmi :=
            {| cmi_name := cmi_name; cmi_sign := cmi_sign; cmi_crcs := cmi_crcs;
              cmi_flags := cmi_flags |} |}
    end
  end.

Definition load_embeded_cmis (cmis : list (string * string)) : unit :=
  Tezos_base__TzPervasives.List.iter load_embeded_cmi cmis.

Definition tezos_protocol_env : list (string * string) :=
  cons
    ("CamlinternalFormatBasics" % string,
      Tezos_protocol_compiler.Embedded_cmis.camlinternalFormatBasics_cmi)
    (cons
      ("Tezos_protocol_environment_sigs" % string,
        Tezos_protocol_compiler.Embedded_cmis.tezos_protocol_environment_sigs_cmi)
      (cons
        ("Tezos_protocol_environment_sigs__V1" % string,
          Tezos_protocol_compiler.Embedded_cmis.tezos_protocol_environment_sigs__V1_cmi)
        [])).

Definition register_env : list (string * string) :=
  cons
    ("tezos_protocol_registerer__Registerer" % string,
      Tezos_protocol_compiler.Embedded_cmis.tezos_protocol_registerer__Registerer_cmi)
    [].

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition create_file (op_star_o_p_t_star : option Unix.file_perm)
  : string -> string -> unit :=
  let perm :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 420
    end in
  fun name =>
    fun content =>
      let fd :=
        Unix.openfile name (cons O_TRUNC (cons O_CREAT (cons O_WRONLY []))) perm
        in
      OCaml.Stdlib.ignore
        (Unix.write_substring fd content 0
          (Tezos_base__TzPervasives.String.length content));
      Unix.close fd.

Definition safe_unlink (file : string) : unit := try.

Definition unlink_cmi {A : Type}
  (dir : string) (function_parameter : string * A) : unit :=
  match function_parameter with
  | (file, _) =>
    safe_unlink (String.append (op_div_div dir file) ".cmi" % string)
  end.

Definition unlink_object (obj : string) : unit :=
  safe_unlink obj;
  safe_unlink
    (String.append (Stdlib.Filename.chop_suffix obj ".cmx" % string)
      ".cmi" % string);
  safe_unlink
    (String.append (Stdlib.Filename.chop_suffix obj ".cmx" % string)
      ".o" % string).

Definition debug_flag : Stdlib.ref bool := Stdlib.ref false.

Definition debug {A : Type} (fmt : Stdlib.format A Stdlib.Format.formatter unit)
  : A :=
  if Stdlib.op_exclamation debug_flag then
    Stdlib.Format.eprintf fmt
  else
    Stdlib.Format.ifprintf Stdlib.Format.err_formatter fmt.

Definition mktemp_dir (function_parameter : unit) : string :=
  match function_parameter with
  | tt =>
    op_div_div (Stdlib.Filename.get_temp_dir_name tt)
      (Stdlib.Printf.sprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "tezos-protocol-build-" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_X
              (CamlinternalFormatBasics.Lit_padding
                CamlinternalFormatBasics.Zeros 6)
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))
          "tezos-protocol-build-%06X" % string) (Stdlib.Random.int 16777215))
  end.

Record driver := {
  compile_ml : (option string) -> string -> string;
  pack_objects : string -> (list string) -> string;
  link_shared : string -> (list string) -> unit }.

Definition main (function_parameter : driver) : unit :=
  match function_parameter with
  | {|
    compile_ml := compile_ml;
      pack_objects := pack_objects;
      link_shared := link_shared
      |} =>
    Stdlib.Random.self_init tt;
    let anonymous : Stdlib.ref (list string) :=
      Stdlib.ref []
    with static : Stdlib.ref bool :=
      Stdlib.ref false
    with register : Stdlib.ref bool :=
      Stdlib.ref false
    with build_dir : Stdlib.ref (option string) :=
      Stdlib.ref None
    with output_file : Stdlib.ref (option string) :=
      Stdlib.ref None
    with output_dep : Stdlib.ref bool :=
      Stdlib.ref false
    with hash_only : Stdlib.ref bool :=
      Stdlib.ref false
    with check_protocol_hash : Stdlib.ref bool :=
      Stdlib.ref true in
    let args_spec :=
      cons
        ("-o" % string,
          (Arg.String (fun s => Stdlib.op_colon_eq output_file (Some s))),
          "" % string)
        (cons
          ("-hash-only" % string, (Arg.Set hash_only),
            " Only display the hash of the protocol and don't compile" % string)
          (cons
            ("-no-hash-check" % string, (Arg.Clear check_protocol_hash),
              " Don't check that TEZOS_PROTOCOL declares the expected protocol hash (if existent)"
                % string)
            (cons
              ("-static" % string, (Arg.Set static),
                " Only build the static library (no .cmxs)" % string)
              (cons
                ("-register" % string, (Arg.Set register),
                  " Generate the `Registerer` module" % string)
                (cons
                  ("-bin-annot" % string, (Arg.Set Clflags.binary_annotations),
                    " (see ocamlopt)" % string)
                  (cons
                    ("-g" % string, (Arg.Set Clflags.debug),
                      " (see ocamlopt)" % string)
                    (cons
                      ("-output-dep" % string, (Arg.Set output_dep),
                        " ..." % string)
                      (cons
                        ("-build-dir" % string,
                          (Arg.String
                            (fun s => Stdlib.op_colon_eq build_dir (Some s))),
                          "use custom build directory and preserve build artifacts"
                            % string) [])))))))) in
    let usage_msg :=
      Stdlib.Printf.sprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Usage: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " [options] <srcdir>
Options are:" % string
                CamlinternalFormatBasics.End_of_format)))
          "Usage: %s [options] <srcdir>
Options are:" % string)
        (Stdlib.Array.get Stdlib.Sys.argv 0) in
    Stdlib.Arg.parse args_spec
      (fun s =>
        Stdlib.op_colon_eq anonymous (cons s (Stdlib.op_exclamation anonymous)))
      usage_msg;
    let source_dir :=
      match Tezos_base__TzPervasives.List.rev (Stdlib.op_exclamation anonymous)
        with
      | cons protocol_dir [] => protocol_dir
      | _ =>
        Stdlib.Arg.usage args_spec usage_msg;
        Stdlib.Pervasives.exit 1
      end in
    match
      match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir)
        with
      | inl (hash, proto) => (hash, proto)
      | inr err =>
        Stdlib.Format.eprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Failed to read TEZOS_PROTOCOL: " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Failed to read TEZOS_PROTOCOL: %a" % string)
          Tezos_base__TzPervasives.pp_print_error err;
        Stdlib.exit 2
      end with
    | (announced_hash, protocol) =>
      let real_hash := Tezos_base__TzPervasives.Protocol.hash protocol in
      if Stdlib.op_exclamation hash_only then
        Stdlib.Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Flush_newline
                CamlinternalFormatBasics.End_of_format)) "%a@." % string)
          Tezos_base__TzPervasives.Protocol_hash.pp real_hash;
        Stdlib.exit 0
      else
        tt;
      let hash :=
        match announced_hash with
        | None => real_hash
        | Some hash => hash
        end in
      let build_dir :=
        match Stdlib.op_exclamation build_dir with
        | None =>
          let dir := mktemp_dir tt in
          Stdlib.at_exit
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Lwt_main.run (Tezos_stdlib_unix.Lwt_utils_unix.remove_dir dir)
              end);
          dir
        | Some dir => dir
        end in
      let output :=
        match Stdlib.op_exclamation output_file with
        | Some output => output
        | None =>
          Stdlib.Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "proto_" % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)) "proto_%a" % string)
            Tezos_base__TzPervasives.Protocol_hash.pp hash
        end in
      Lwt_main.run
        (Tezos_stdlib_unix.Lwt_utils_unix.create_dir (Some 493) build_dir);
      Lwt_main.run
        (Tezos_stdlib_unix.Lwt_utils_unix.create_dir (Some 493)
          (Stdlib.Filename.dirname output));
      let functor_file := op_div_div build_dir "functor.ml" % string in
      let oc := Stdlib.open_out functor_file in
      Tezos_protocol_compiler.Packer.dump oc hash
        (Stdlib.Array.map
          (fun function_parameter =>
            match function_parameter with
            | {| Protocol.name := name |} =>
              let name_lowercase :=
                Tezos_base__TzPervasives.String.uncapitalize_ascii name in
              String.append (op_div_div source_dir name_lowercase)
                ".ml" % string
            end) (Stdlib.Array.of_list (components protocol)));
      Stdlib.close_out oc;
      let proto_cmi :=
        String.append (Stdlib.Filename.chop_extension functor_file)
          ".cmi" % string in
      let functor_unit :=
        Tezos_base__TzPervasives.String.capitalize_ascii
          (Stdlib.Filename.basename
            (Stdlib.Filename.chop_extension functor_file)) in
      let for_pack :=
        Tezos_base__TzPervasives.String.capitalize_ascii
          (Stdlib.Filename.basename output) in
      Compenv.readenv Stdlib.Format.err_formatter Before_args;
      Stdlib.op_colon_eq Clflags.nopervasives true;
      Stdlib.op_colon_eq Clflags.no_std_include true;
      Stdlib.op_colon_eq Clflags.include_dirs
        (cons (Stdlib.Filename.dirname functor_file) []);
      Warnings.parse_options false warnings;
      Warnings.parse_options true warn_error;
      load_embeded_cmis tezos_protocol_env;
      let packed_protocol_object := compile_ml (Some for_pack) functor_file in
      let register_objects :=
        if negb (Stdlib.op_exclamation register) then
          []
        else
          load_embeded_cmis register_env;
          load_cmi_from_file proto_cmi;
          let register_file :=
            op_div_div (Stdlib.Filename.dirname functor_file)
              "register.ml" % string in
          create_file None register_file
            (Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "module Name = struct let name = " % string
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " end
 let () = Tezos_protocol_registerer__Registerer.register Name.name (module "
                        % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          ".Make)" % string
                          CamlinternalFormatBasics.End_of_format)))))
                "module Name = struct let name = %S end
 let () = Tezos_protocol_registerer__Registerer.register Name.name (module %s.Make)"
                  % string)
              (Tezos_base__TzPervasives.Protocol_hash.to_b58check hash)
              functor_unit);
          let register_object := compile_ml (Some for_pack) register_file in
          cons register_object [] in
      let resulting_object :=
        pack_objects output (cons packed_protocol_object register_objects) in
      if negb (Stdlib.op_exclamation static) then
        Stdlib.op_colon_eq Clflags.link_everything true;
        link_shared (String.append output ".cmxs" % string)
          (cons resulting_object [])
      else
        tt;
      if Stdlib.op_exclamation output_dep then
        let dsrc := Stdlib.Digest.file functor_file in
        let dimpl := Stdlib.Digest.file resulting_object in
        let dintf :=
          Stdlib.Digest.file
            (String.append (Stdlib.Filename.chop_extension resulting_object)
              ".cmi" % string) in
        Stdlib.Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "module Toto = struct include " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " end ;; 
" % string
                  CamlinternalFormatBasics.End_of_format)))
            "module Toto = struct include %s end ;; 
" % string) for_pack;
        Stdlib.Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "let src_digest = " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " ;;
" % string
                  CamlinternalFormatBasics.End_of_format)))
            "let src_digest = %S ;;
" % string) (Stdlib.Digest.to_hex dsrc);
        Stdlib.Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "let impl_digest = " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " ;;
" % string
                  CamlinternalFormatBasics.End_of_format)))
            "let impl_digest = %S ;;
" % string) (Stdlib.Digest.to_hex dimpl);
        Stdlib.Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "let intf_digest = " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " ;;
" % string
                  CamlinternalFormatBasics.End_of_format)))
            "let intf_digest = %S ;;
" % string) (Stdlib.Digest.to_hex dintf)
      else
        tt;
      Stdlib.Format.printf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Success: " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal "." % char
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Flush_newline
                  CamlinternalFormatBasics.End_of_format))))
          "Success: %a.@." % string) Tezos_base__TzPervasives.Protocol_hash.pp
        hash
    end
  end.
src/lib_protocol_compiler/embedded_cmis.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val camlinternalFormatBasics_cmi : string

val tezos_protocol_environment_sigs_cmi : string

val tezos_protocol_environment_sigs__V1_cmi : string

val tezos_protocol_registerer__Registerer_cmi : string
src/lib_protocol_compiler/embedded_cmis.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter camlinternalFormatBasics_cmi : string.

Parameter tezos_protocol_environment_sigs_cmi : string.

Parameter tezos_protocol_environment_sigs__V1_cmi : string.

Parameter tezos_protocol_registerer__Registerer_cmi : string.
src/lib_protocol_compiler/main_byte.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  try
    Tezos_protocol_compiler.Compiler.main
      Tezos_protocol_compiler_byte.Byte.driver ;
    Pervasives.exit 0
  with exn ->
    Format.eprintf "%a\n%!" Errors.report_error exn ;
    Pervasives.exit 1
src/lib_protocol_compiler/main_byte.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_protocol_compiler/main_embedded_packer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let srcdir = Sys.argv.(1)

let version = Sys.argv.(2)

let srcdir =
  if Filename.basename srcdir = "TEZOS_PROTOCOL" then Filename.dirname srcdir
  else srcdir

let (hash, sources) =
  match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir srcdir) with
  | Ok (None, proto) ->
      (Protocol.hash proto, proto)
  | Ok (Some hash, proto) ->
      (hash, proto)
  | Error err ->
      Format.kasprintf
        Pervasives.failwith
        "Failed to read TEZOS_PROTOCOL: %a"
        pp_print_error
        err

let () =
  Format.printf
    {|
module Source = struct
  let hash =
    Some (Tezos_crypto.Protocol_hash.of_b58check_exn %S)
  let sources = Tezos_base.Protocol.%a
end
@.|}
    (Protocol_hash.to_b58check hash)
    Protocol.pp_ocaml
    sources

let () =
  Format.printf
    {|
module Registered =
  Tezos_protocol_updater.Registered_protocol.Register_embedded
    (Tezos_protocol_environment_%s.Environment)
    (Tezos_raw_protocol_%s.Main)
    (Source)
@.|}
    version
    version
src/lib_protocol_compiler/main_embedded_packer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition srcdir : string := Stdlib.Array.get Stdlib.Sys.argv 1.

Definition version : string := Stdlib.Array.get Stdlib.Sys.argv 2.

Definition srcdir : string :=
  if equiv_decb (Stdlib.Filename.basename srcdir) "TEZOS_PROTOCOL" % string then
    Stdlib.Filename.dirname srcdir
  else
    srcdir.
src/lib_protocol_compiler/main_native.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  try
    Tezos_protocol_compiler.Compiler.main
      Tezos_protocol_compiler_native.Native.driver ;
    Pervasives.exit 0
  with exn ->
    Format.eprintf "%a\n%!" Opterrors.report_error exn ;
    Pervasives.exit 1
src/lib_protocol_compiler/main_native.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_protocol_compiler/main_packer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

let () =
  Random.self_init () ;
  let anonymous = ref [] in
  let args_spec = [] in
  let usage_msg = Printf.sprintf "Usage: %s [options] <srcdir>" Sys.argv.(0) in
  Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ;
  let source_dir =
    match List.rev !anonymous with
    | [source_dir] when Filename.basename source_dir = "TEZOS_PROTOCOL" ->
        Filename.dirname source_dir
    | [source_dir] ->
        source_dir
    | _ ->
        Arg.usage args_spec usage_msg ;
        Pervasives.exit 1
  in
  let (hash, protocol) =
    match
      Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir)
    with
    | Ok (None, proto) ->
        (Protocol.hash proto, proto)
    | Ok (Some hash, proto) ->
        (hash, proto)
    | Error err ->
        Format.kasprintf
          Pervasives.failwith
          "Failed to read TEZOS_PROTOCOL: %a"
          pp_print_error
          err
  in
  (* Generate the 'functor' *)
  Packer.dump
    stdout
    hash
    (Array.map
       (fun {Protocol.name; _} ->
         let name_lowercase = String.uncapitalize_ascii name in
         (source_dir // name_lowercase) ^ ".ml")
       (Array.of_list protocol.components))
src/lib_protocol_compiler/main_packer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.
src/lib_protocol_compiler/native.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The OCaml compiler not being implemented with Lwt, the compilation
    take place in a separated process (by using [Lwt_process.exec]).

    The [main] function is the entry point for the forked process.
    While [Updater.compile] is the 'forking' function to be called by
    the [tezos-node] process.

*)

open Compiler

(* TODO: fail in the presence of "external" *)

module Backend = struct
  (* See backend_intf.mli. *)

  let symbol_for_global' = Compilenv.symbol_for_global'

  let closure_symbol = Compilenv.closure_symbol

  let really_import_approx = Import_approx.really_import_approx

  let import_symbol = Import_approx.import_symbol

  let size_int = Arch.size_int

  let big_endian = Arch.big_endian

  let max_sensible_number_of_arguments =
    (* The "-1" is to allow for a potential closure environment parameter. *)
    Proc.max_arguments_for_tailcalls - 1
end

let backend = (module Backend : Backend_intf.S)

(** Semi-generic compilation functions *)

let pack_objects output objects =
  let output = output ^ ".cmx" in
  Compmisc.init_path true ;
  Asmpackager.package_files
    ~backend
    Format.err_formatter
    Env.initial_safe_string
    objects
    output ;
  Warnings.check_fatal () ;
  output

let link_shared output objects =
  Compenv.(readenv Format.err_formatter Before_link) ;
  Compmisc.init_path true ;
  Asmlink.link_shared Format.err_formatter objects output ;
  Warnings.check_fatal ()

let compile_ml ?for_pack ml =
  let target = Filename.chop_extension ml in
  Clflags.for_package := for_pack ;
  Compenv.(readenv Format.err_formatter (Before_compile ml)) ;
  Optcompile.implementation ~backend Format.err_formatter ml target ;
  Clflags.for_package := None ;
  target ^ ".cmx"

let () = Clflags.native_code := true

let driver = {compile_ml; link_shared; pack_objects}
src/lib_protocol_compiler/native.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_compiler.Compiler.

Module Backend.
  Definition symbol_for_global' : Ident.t -> Symbol.t :=
    Compilenv.symbol_for_global'.
  
  Definition closure_symbol : Closure_id.t -> Symbol.t :=
    Compilenv.closure_symbol.
  
  Definition really_import_approx
    : Simple_value_approx.t -> Simple_value_approx.t :=
    Import_approx.really_import_approx.
  
  Definition import_symbol : Symbol.t -> Simple_value_approx.t :=
    Import_approx.import_symbol.
  
  Definition size_int : Z := Arch.size_int.
  
  Definition big_endian : bool := Arch.big_endian.
  
  Definition max_sensible_number_of_arguments : Z :=
    Z.sub Proc.max_arguments_for_tailcalls 1.
End Backend.

Definition backend : {_ : unit & Backend_intf.S.signature } := Backend.

Definition pack_objects (output : string) (objects : list string) : string :=
  let output := String.append output ".cmx" % string in
  Compmisc.init_path None true;
  Asmpackager.package_files Stdlib.Format.err_formatter Env.initial_safe_string
    objects output backend;
  Warnings.check_fatal tt;
  output.

Definition link_shared (output : string) (objects : list string) : unit :=
  Compenv.readenv Stdlib.Format.err_formatter Before_link;
  Compmisc.init_path None true;
  Asmlink.link_shared Stdlib.Format.err_formatter objects output;
  Warnings.check_fatal tt.

Definition compile_ml (for_pack : option string) (ml : Compenv.filename)
  : string :=
  let target := Stdlib.Filename.chop_extension ml in
  Stdlib.op_colon_eq Clflags.for_package for_pack;
  Compenv.readenv Stdlib.Format.err_formatter (Before_compile ml);
  Optcompile.implementation backend Stdlib.Format.err_formatter ml target;
  Stdlib.op_colon_eq Clflags.for_package None;
  String.append target ".cmx" % string.

Definition driver : Tezos_protocol_compiler.Compiler.driver :=
  {| compile_ml := compile_ml; pack_objects := pack_objects;
    link_shared := link_shared |}.
src/lib_protocol_compiler/native.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val driver : Compiler.driver
src/lib_protocol_compiler/native.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter driver : Tezos_protocol_compiler.Compiler.driver.
src/lib_protocol_compiler/packer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let dump_file oc file =
  let ic = open_in file in
  let buflen = 8096 in
  let buf = Bytes.create buflen in
  let rec loop () =
    let len = input ic buf 0 buflen in
    if len <> 0 then (
      Printf.fprintf
        oc
        "%s"
        ( if len = buflen then Bytes.unsafe_to_string buf
        else Bytes.sub_string buf 0 len ) ;
      loop () )
  in
  loop () ; close_in ic

let include_ml oc file =
  let unit =
    String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
  in
  (* FIXME insert .mli... *)
  Printf.fprintf oc "module %s " unit ;
  if Sys.file_exists (file ^ "i") then (
    Printf.fprintf oc ": sig\n" ;
    Printf.fprintf oc "# 1 %S\n" (file ^ "i") ;
    dump_file oc (file ^ "i") ;
    Printf.fprintf oc "end " ) ;
  Printf.fprintf oc "= struct\n" ;
  Printf.fprintf oc "# 1 %S\n" file ;
  dump_file oc file ;
  Printf.fprintf oc "end\n%!"

let opened_modules =
  ["Tezos_protocol_environment"; "Pervasives"; "Error_monad"; "Logging"]

let dump oc hash files =
  Printf.fprintf
    oc
    "module Make (Tezos_protocol_environment : \
     Tezos_protocol_environment_sigs__V1.T) = struct\n" ;
  Printf.fprintf oc "[@@@ocaml.warning \"-33\"]\n" ;
  List.iter (Printf.fprintf oc "open %s\n") opened_modules ;
  Printf.fprintf oc "[@@@ocaml.warning \"+33\"]\n" ;
  Printf.fprintf
    oc
    "let hash = Protocol_hash.of_b58check_exn %S;;\n"
    (Protocol_hash.to_b58check hash) ;
  for i = 0 to Array.length files - 1 do
    include_ml oc files.(i)
  done ;
  Printf.fprintf
    oc
    "  include %s\n"
    (String.capitalize_ascii
       (Filename.basename
          (Filename.chop_extension files.(Array.length files - 1)))) ;
  Printf.fprintf oc "end\n%!"
src/lib_protocol_compiler/packer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition dump_file (oc : Stdlib.out_channel) (file : string) : unit :=
  let ic := Stdlib.open_in file in
  let buflen := 8096 in
  let buf := Stdlib.Bytes.create buflen in
  let fix loop (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      let len := Stdlib.input ic buf 0 buflen in
      if nequiv_decb len 0 then
        Stdlib.Printf.fprintf oc
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format) "%s" % string)
          (if equiv_decb len buflen then
            Stdlib.Bytes.unsafe_to_string buf
          else
            Stdlib.Bytes.sub_string buf 0 len);
        loop tt
      else
        tt
    end in
  loop tt;
  Stdlib.close_in ic.

Definition include_ml (oc : Stdlib.out_channel) (file : string) : unit :=
  let unit :=
    Tezos_base__TzPervasives.String.capitalize_ascii
      (Stdlib.Filename.chop_extension (Stdlib.Filename.basename file)) in
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "module " % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal " " % char
            CamlinternalFormatBasics.End_of_format))) "module %s " % string)
    unit;
  if Stdlib.Sys.file_exists (String.append file "i" % string) then
    Stdlib.Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal ": sig
" % string
          CamlinternalFormatBasics.End_of_format) ": sig
" % string);
    Stdlib.Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "# 1 " % string
          (CamlinternalFormatBasics.Caml_string
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string)
      (String.append file "i" % string);
    dump_file oc (String.append file "i" % string);
    Stdlib.Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "end " % string
          CamlinternalFormatBasics.End_of_format) "end " % string)
  else
    tt;
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "= struct
" % string
        CamlinternalFormatBasics.End_of_format) "= struct
" % string);
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "# 1 " % string
        (CamlinternalFormatBasics.Caml_string
          CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "010" % char
            CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string) file;
  dump_file oc file;
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "end
" % string
        (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
      "end
%!" % string).

Definition opened_modules : list string :=
  cons "Tezos_protocol_environment" % string
    (cons "Pervasives" % string
      (cons "Error_monad" % string (cons "Logging" % string []))).

Definition dump
  (oc : Stdlib.out_channel) (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  (files : array string) : unit :=
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal
        "module Make (Tezos_protocol_environment : Tezos_protocol_environment_sigs__V1.T) = struct
"
          % string CamlinternalFormatBasics.End_of_format)
      "module Make (Tezos_protocol_environment : Tezos_protocol_environment_sigs__V1.T) = struct
"
        % string);
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "[" % char
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Escaped_at
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Scan_indic "o" % char)
            (CamlinternalFormatBasics.String_literal
              "caml.warning ""-33""]
" % string
              CamlinternalFormatBasics.End_of_format))))
      "[@@@ocaml.warning ""-33""]
" % string);
  Tezos_base__TzPervasives.List.iter
    (Stdlib.Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "open " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "open %s
" % string))
    opened_modules;
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "[" % char
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Escaped_at
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Scan_indic "o" % char)
            (CamlinternalFormatBasics.String_literal
              "caml.warning ""+33""]
" % string
              CamlinternalFormatBasics.End_of_format))))
      "[@@@ocaml.warning ""+33""]
" % string);
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal
        "let hash = Protocol_hash.of_b58check_exn " % string
        (CamlinternalFormatBasics.Caml_string
          CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal ";;
" % string
            CamlinternalFormatBasics.End_of_format)))
      "let hash = Protocol_hash.of_b58check_exn %S;;
" % string)
    (Tezos_base__TzPervasives.Protocol_hash.to_b58check hash);
  for;
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "  include " % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "010" % char
            CamlinternalFormatBasics.End_of_format))) "  include %s
" % string)
    (Tezos_base__TzPervasives.String.capitalize_ascii
      (Stdlib.Filename.basename
        (Stdlib.Filename.chop_extension
          (Stdlib.Array.get files (Z.sub (Stdlib.Array.length files) 1)))));
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "end
" % string
        (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
      "end
%!" % string).
src/lib_protocol_compiler/packer.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val dump : out_channel -> Protocol_hash.t -> string array -> unit
src/lib_protocol_compiler/packer.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter dump :
Stdlib.out_channel ->
  Tezos_base__TzPervasives.Protocol_hash.t -> (array string) -> unit.
src/lib_protocol_compiler/registerer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type PROTOCOL_V1 = functor
  (Env : Tezos_protocol_environment_sigs.V1.T)
  -> Env.Updater.PROTOCOL

module VersionTable = Protocol_hash.Table

let versions : (module PROTOCOL_V1) VersionTable.t = VersionTable.create 20

let register hash proto =
  let hash = Protocol_hash.of_b58check_exn hash in
  VersionTable.add versions hash proto

let mem hash = VersionTable.mem versions hash

let get hash =
  try Some (VersionTable.find versions hash) with Not_found -> None
src/lib_protocol_compiler/registerer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition versions : VersionTable.t {_ : unit & PROTOCOL_V1.signature } :=
  VersionTable.create 20.

Definition register
  (hash : string) (proto : {_ : unit & PROTOCOL_V1.signature }) : unit :=
  let hash := Tezos_base__TzPervasives.Protocol_hash.of_b58check_exn hash in
  VersionTable.add versions hash proto.

Definition mem (hash : VersionTable.key) : bool :=
  VersionTable.mem versions hash.

Definition get (hash : VersionTable.key)
  : option {_ : unit & PROTOCOL_V1.signature } := try.
src/lib_protocol_compiler/registerer.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type PROTOCOL_V1 = functor
  (Env : Tezos_protocol_environment_sigs.V1.T)
  -> Env.Updater.PROTOCOL

val register : string -> (module PROTOCOL_V1) -> unit

val mem : Protocol_hash.t -> bool

val get : Protocol_hash.t -> (module PROTOCOL_V1) option
src/lib_protocol_compiler/registerer.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

Parameter register : string -> {_ : unit & PROTOCOL_V1.signature } -> unit.

Parameter mem : Tezos_base__TzPervasives.Protocol_hash.t -> bool.

Parameter get :
Tezos_base__TzPervasives.Protocol_hash.t ->
  option {_ : unit & PROTOCOL_V1.signature }.
src/lib_protocol_compiler/replace.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module StringMap = Map.Make (String)
open Re

let regexp = Str.regexp "%%[^%]*%%"

let current_dir = Sys.getcwd ()

let guess_version () =
  let prefix = "proto_" in
  let rec loop dir =
    let dirname = Filename.basename dir in
    let x = String.length prefix in
    let n = String.length dirname in
    if n >= x && String.sub dirname 0 x = prefix then
      String.sub dirname x (n - x)
    else
      let updir = Filename.dirname dir in
      if updir = dir then (
        Format.eprintf
          "Cannot guess protocol version in path!@.Looking for `%s*` in `%s`@."
          prefix
          current_dir ;
        exit 1 ) ;
      loop updir
  in
  loop (Sys.getcwd ())

let warning_message =
  {|

;
;        /!\ /!\ Do not modify this file /!\ /!\
;
; but the original template in `tezos-protocol-compiler`
;

|}

let replace ~template ~destination vars =
  let inch = open_in template in
  let outch = open_out destination in
  output_string outch warning_message ;
  try
    while true do
      let line = input_line inch in
      let line =
        Str.global_substitute
          regexp
          (fun s ->
            let matched = Str.matched_string s in
            let var = String.sub matched 2 (String.length matched - 4) in
            match StringMap.find_opt var vars with
            | Some value ->
                value
            | None ->
                prerr_endline ("Unknown variable: " ^ var) ;
                exit 1)
          line
      in
      output_string outch line ; output_string outch "\n"
    done
  with End_of_file -> flush outch ; close_out outch ; ()

let module_name (c : Protocol.component) = String.capitalize_ascii c.name

let sources_name (c : Protocol.component) =
  let name = String.lowercase_ascii c.name in
  match c.interface with
  | None ->
      Printf.sprintf "%s.ml" name
  | Some _ ->
      Printf.sprintf "%s.mli %s.ml" name name

let process ~template ~destination (protocol : Protocol.t) lib_version hash =
  let version = String.concat "-" (String.split_on_char '_' lib_version) in
  let vars =
    StringMap.empty
    |> StringMap.add "VERSION" version
    |> StringMap.add "LIB_VERSION" lib_version
    |> StringMap.add "HASH" (Protocol_hash.to_b58check hash)
    |> StringMap.add
         "MODULES"
         (String.concat " " (List.map module_name protocol.components))
    |> StringMap.add
         "SOURCES"
         (String.concat " " (List.map sources_name protocol.components))
  in
  replace ~template ~destination vars

let read_proto destination =
  let source_dir =
    if Filename.is_relative destination then
      Filename.concat current_dir (Filename.dirname destination)
    else Filename.dirname destination
  in
  match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with
  | Ok (None, proto) ->
      (Protocol.hash proto, proto)
  | Ok (Some hash, proto) ->
      (hash, proto)
  | Error err ->
      Format.kasprintf
        Pervasives.failwith
        "Failed to read TEZOS_PROTOCOL in %s:@ %a"
        source_dir
        pp_print_error
        err

let main () =
  let template = Sys.argv.(1) in
  let destination = Sys.argv.(2) in
  let version = try Sys.argv.(3) with _ -> guess_version () in
  let (hash, proto) = read_proto destination in
  process ~template ~destination proto version hash

let () = main ()
src/lib_protocol_compiler/replace.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Re.

Definition regexp : Re.Str.regexp := Re.Str.regexp "%%[^%]*%%" % string.

Definition current_dir : string := Stdlib.Sys.getcwd tt.

Definition guess_version (function_parameter : unit) : string :=
  match function_parameter with
  | tt =>
    let prefix := "proto_" % string in
    let fix loop (dir : string) : string :=
      let dirname := Stdlib.Filename.basename dir in
      let x := Tezos_base__TzPervasives.String.length prefix in
      let n := Tezos_base__TzPervasives.String.length dirname in
      if
        andb (OCaml.Stdlib.ge n x)
          (equiv_decb (Tezos_base__TzPervasives.String.sub dirname 0 x) prefix)
        then
        Tezos_base__TzPervasives.String.sub dirname x (Z.sub n x)
      else
        let updir := Stdlib.Filename.dirname dir in
        if equiv_decb updir dir then
          Stdlib.Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Cannot guess protocol version in path!" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Flush_newline
                  (CamlinternalFormatBasics.String_literal
                    "Looking for `" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        "*` in `" % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal "`" % char
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              CamlinternalFormatBasics.End_of_format))))))))
              "Cannot guess protocol version in path!@.Looking for `%s*` in `%s`@."
                % string) prefix current_dir;
          Stdlib.exit 1
        else
          tt;
        loop updir in
    loop (Stdlib.Sys.getcwd tt)
  end.

Definition warning_message : string :=
  "

;
;        /!\ /!\ Do not modify this file /!\ /!\
;
; but the original template in `tezos-protocol-compiler`
;

"
    % string.

Definition replace
  (template : string) (destination : string) (vars : StringMap.t string)
  : unit :=
  let inch := Stdlib.open_in template in
  let outch := Stdlib.open_out destination in
  Stdlib.output_string outch warning_message;
  try.

Definition module_name (c : Tezos_base__TzPervasives.Protocol.component)
  : string := Tezos_base__TzPervasives.String.capitalize_ascii (name c).

Definition sources_name (c : Tezos_base__TzPervasives.Protocol.component)
  : string :=
  let name := Tezos_base__TzPervasives.String.lowercase_ascii (name c) in
  match interface c with
  | None =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal ".ml" % string
            CamlinternalFormatBasics.End_of_format)) "%s.ml" % string) name
  | Some _ =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal ".mli " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal ".ml" % string
                CamlinternalFormatBasics.End_of_format))))
        "%s.mli %s.ml" % string) name name
  end.

Definition process
  (template : string) (destination : string)
  (protocol : Tezos_base__TzPervasives.Protocol.t) (lib_version : string)
  (hash : Tezos_base__TzPervasives.Protocol_hash.t) : unit :=
  let version :=
    Tezos_base__TzPervasives.String.concat "-" % string
      (Tezos_base__TzPervasives.String.split_on_char "_" % char lib_version) in
  let vars :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply StringMap.empty
              (StringMap.add "VERSION" % string version))
            (StringMap.add "LIB_VERSION" % string lib_version))
          (StringMap.add "HASH" % string
            (Tezos_base__TzPervasives.Protocol_hash.to_b58check hash)))
        (StringMap.add "MODULES" % string
          (Tezos_base__TzPervasives.String.concat " " % string
            (Tezos_base__TzPervasives.List.map module_name (components protocol)))))
      (StringMap.add "SOURCES" % string
        (Tezos_base__TzPervasives.String.concat " " % string
          (Tezos_base__TzPervasives.List.map sources_name (components protocol))))
    in
  replace template destination vars.

Definition read_proto (destination : string)
  : Tezos_crypto.Protocol_hash.t * Tezos_base.Protocol.t :=
  let source_dir :=
    if Stdlib.Filename.is_relative destination then
      Stdlib.Filename.concat current_dir (Stdlib.Filename.dirname destination)
    else
      Stdlib.Filename.dirname destination in
  match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with
  | inl (None, proto) => ((Tezos_base__TzPervasives.Protocol.hash proto), proto)
  | inl (Some hash, proto) => (hash, proto)
  | inr err =>
    Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to read TEZOS_PROTOCOL in " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal ":" % char
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))))
        "Failed to read TEZOS_PROTOCOL in %s:@ %a" % string) source_dir
      Tezos_base__TzPervasives.pp_print_error err
  end.

Definition main (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let template := Stdlib.Array.get Stdlib.Sys.argv 1 in
    let destination := Stdlib.Array.get Stdlib.Sys.argv 2 in
    let version := try in
    match read_proto destination with
    | (hash, proto) => process template destination proto version hash
    end
  end.
src/lib_protocol_environment/dummy_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module M = struct
  type t = unit

  type key = string list

  type value = MBytes.t

  let mem _ _ = assert false

  let dir_mem _ _ = assert false

  let get _ _ = assert false

  let set _ _ _ = assert false

  let copy _ ~from:_ ~to_:_ = assert false

  let del _ _ = assert false

  let remove_rec _ _ = assert false

  let fold _ _ ~init:_ ~f:_ = assert false

  let set_protocol _ _ = assert false

  let fork_test_chain _ ~protocol:_ ~expiration:_ = assert false
end

open Tezos_protocol_environment

type _ Context.kind += Faked : unit Context.kind

let ops = (module M : CONTEXT with type t = 'ctxt)

let empty = Context.Context {ops; ctxt = (); kind = Faked}
src/lib_protocol_environment/dummy_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module M.
  Definition t := unit.
  
  Definition key := list string.
  
  Definition value := Tezos_base__TzPervasives.MBytes.t.
  
  Definition mem {A B C : Type} (function_parameter : A) : B -> C :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => false
        end
    end.
  
  Definition dir_mem {A B C : Type} (function_parameter : A) : B -> C :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => false
        end
    end.
  
  Definition get {A B C : Type} (function_parameter : A) : B -> C :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => false
        end
    end.
  
  Definition set {A B C D : Type} (function_parameter : A) : B -> C -> D :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => false
            end
        end
    end.
  
  Definition copy {A B C D : Type} (function_parameter : A) : B -> C -> D :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => false
            end
        end
    end.
  
  Definition del {A B C : Type} (function_parameter : A) : B -> C :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => false
        end
    end.
  
  Definition remove_rec {A B C : Type} (function_parameter : A) : B -> C :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => false
        end
    end.
  
  Definition fold {A B C D E : Type} (function_parameter : A)
    : B -> C -> D -> E :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ =>
              fun function_parameter =>
                match function_parameter with
                | _ => false
                end
            end
        end
    end.
  
  Definition set_protocol {A B C : Type} (function_parameter : A) : B -> C :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => false
        end
    end.
  
  Definition fork_test_chain {A B C D : Type} (function_parameter : A)
    : B -> C -> D :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => false
            end
        end
    end.
End M.

Import Tezos_protocol_environment.

Definition ops
  : {_ : unit &
    Tezos_protocol_environment.CONTEXT.signature
      M.(Tezos_protocol_environment.CONTEXT.t)} := M.

Definition empty : Tezos_protocol_environment.Context.t :=
  Context.Context {| kind := Faked; ctxt := tt; ops := ops |}.
src/lib_protocol_environment/dummy_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Tezos_protocol_environment

type _ Context.kind += Faked : unit Context.kind

val empty : Context.t
src/lib_protocol_environment/dummy_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

Parameter empty : Tezos_protocol_environment.Context.t.
src/lib_protocol_environment/memory_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module M = struct
  module StringMap = Map.Make (String)

  type key = string list

  type value = MBytes.t

  type t = Dir of t StringMap.t | Key of value

  let empty = Dir StringMap.empty

  let rec raw_get m k =
    match (k, m) with
    | ([], m) ->
        Some m
    | (n :: k, Dir m) -> (
      match StringMap.find_opt n m with
      | Some res ->
          raw_get res k
      | None ->
          None )
    | (_ :: _, Key _) ->
        None

  let rec raw_set m k v =
    match (k, m, v) with
    | ([], (Key _ as m), Some v) ->
        if m = v then None else Some v
    | ([], (Dir _ as m), Some v) ->
        if m == v then None else Some v
    | ([], (Key _ | Dir _), None) ->
        Some empty
    | (n :: k, Dir m, _) -> (
      match
        raw_set (Option.unopt ~default:empty (StringMap.find_opt n m)) k v
      with
      | None ->
          None
      | Some rm when rm = empty ->
          Some (Dir (StringMap.remove n m))
      | Some rm ->
          Some (Dir (StringMap.add n rm m)) )
    | (_ :: _, Key _, None) ->
        None
    | (_ :: _, Key _, Some _) ->
        Pervasives.failwith "Mem_context.set"

  let mem m k =
    match raw_get m k with
    | Some (Key _) ->
        Lwt.return_true
    | Some (Dir _) | None ->
        Lwt.return_false

  let dir_mem m k =
    match raw_get m k with
    | Some (Dir _) ->
        Lwt.return_true
    | Some (Key _) | None ->
        Lwt.return_false

  let get m k =
    match raw_get m k with
    | Some (Key v) ->
        Lwt.return_some v
    | Some (Dir _) | None ->
        Lwt.return_none

  let set m k v =
    match raw_set m k (Some (Key v)) with
    | None ->
        Lwt.return m
    | Some m ->
        Lwt.return m

  let del m k =
    (* TODO assert key *)
    match raw_set m k None with None -> Lwt.return m | Some m -> Lwt.return m

  let remove_rec m k =
    match raw_set m k None with None -> Lwt.return m | Some m -> Lwt.return m

  let copy m ~from ~to_ =
    match raw_get m from with
    | None ->
        Lwt.return_none
    | Some v ->
        Lwt.return (raw_set m to_ (Some v))

  let fold m k ~init ~f =
    match raw_get m k with
    | None ->
        Lwt.return init
    | Some (Key _) ->
        Lwt.return init
    | Some (Dir m) ->
        StringMap.fold
          (fun n m acc ->
            acc
            >>= fun acc ->
            match m with
            | Key _ ->
                f (`Key (k @ [n])) acc
            | Dir _ ->
                f (`Dir (k @ [n])) acc)
          m
          (Lwt.return init)

  let current_protocol_key = ["protocol"]

  let set_protocol v key =
    raw_set v current_protocol_key (Some (Key (Protocol_hash.to_bytes key)))
    |> function Some m -> Lwt.return m | None -> assert false

  let fork_test_chain c ~protocol:_ ~expiration:_ = Lwt.return c
end

open Tezos_protocol_environment

type t = M.t

type _ Context.kind += Memory : t Context.kind

let ops = (module M : CONTEXT with type t = 'ctxt)

let empty =
  let ctxt = M.empty in
  Context.Context {ops; ctxt; kind = Memory}
src/lib_protocol_environment/memory_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module M.
  Definition key := list string.
  
  Definition value := Tezos_base__TzPervasives.MBytes.t.
  
  Inductive t : Type :=
  | Dir : (StringMap.t t) -> t
  | Key : value -> t.
  
  Definition empty : t := Dir StringMap.empty.
  
  Fixpoint raw_get (m : t) (k : list StringMap.key) : option t :=
    match (k, m) with
    | ([], m) => Some m
    | (cons n k, Dir m) =>
      match StringMap.find_opt n m with
      | Some res => raw_get res k
      | None => None
      end
    | (cons _ _, Key _) => None
    end.
  
  Fixpoint raw_set (m : t) (k : list StringMap.key) (v : option t) : option t :=
    match (k, m, v) with
    | ([], (Key _) as m, Some v) =>
      if equiv_decb m v then
        None
      else
        Some v
    | ([], (Dir _) as m, Some v) =>
      if Stdlib.op_eq_eq m v then
        None
      else
        Some v
    | ([], Key _ | Dir _, None) => Some empty
    | (cons n k, Dir m, _) =>
      match
        raw_set
          (Tezos_base__TzPervasives.Option.unopt empty (StringMap.find_opt n m))
          k v with
      | None => None
      | Some rm => Some (Dir (StringMap.add n rm m))
      end
    | (cons _ _, Key _, None) => None
    | (cons _ _, Key _, Some _) =>
      Stdlib.Pervasives.failwith "Mem_context.set" % string
    end.
  
  Definition mem (m : t) (k : list StringMap.key) : Lwt.t bool :=
    match raw_get m k with
    | Some (Key _) => Lwt.return_true
    | Some (Dir _) | None => Lwt.return_false
    end.
  
  Definition dir_mem (m : t) (k : list StringMap.key) : Lwt.t bool :=
    match raw_get m k with
    | Some (Dir _) => Lwt.return_true
    | Some (Key _) | None => Lwt.return_false
    end.
  
  Definition get (m : t) (k : list StringMap.key) : Lwt.t (option value) :=
    match raw_get m k with
    | Some (Key v) => Lwt.return_some v
    | Some (Dir _) | None => Lwt.return_none
    end.
  
  Definition set (m : t) (k : list StringMap.key) (v : value) : Lwt.t t :=
    match raw_set m k (Some (Key v)) with
    | None => Lwt._return m
    | Some m => Lwt._return m
    end.
  
  Definition del (m : t) (k : list StringMap.key) : Lwt.t t :=
    match raw_set m k None with
    | None => Lwt._return m
    | Some m => Lwt._return m
    end.
  
  Definition remove_rec (m : t) (k : list StringMap.key) : Lwt.t t :=
    match raw_set m k None with
    | None => Lwt._return m
    | Some m => Lwt._return m
    end.
  
  Definition copy (m : t) (from : list StringMap.key) (to_ : list StringMap.key)
    : Lwt.t (option t) :=
    match raw_get m from with
    | None => Lwt.return_none
    | Some v => Lwt._return (raw_set m to_ (Some v))
    end.
  
  Definition fold {A : Type}
    (m : t) (k : list StringMap.key) (init : A) (f : variant -> A -> Lwt.t A)
    : Lwt.t A :=
    match raw_get m k with
    | None => Lwt._return init
    | Some (Key _) => Lwt._return init
    | Some (Dir m) =>
      StringMap.fold
        (fun n =>
          fun m =>
            fun acc =>
              Tezos_base__TzPervasives.op_gt_gt_eq acc
                (fun acc =>
                  match m with
                  | Key _ => f variant acc
                  | Dir _ => f variant acc
                  end)) m (Lwt._return init)
    end.
  
  Definition current_protocol_key : list string := cons "protocol" % string [].
  
  Definition set_protocol
    (v : t) (key : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t t :=
    OCaml.Stdlib.reverse_apply
      (raw_set v current_protocol_key
        (Some (Key (Tezos_base__TzPervasives.Protocol_hash.to_bytes key))))
      (fun function_parameter =>
        match function_parameter with
        | Some m => Lwt._return m
        | None => false
        end).
  
  Definition fork_test_chain {A B C : Type} (c : A) (function_parameter : B)
    : C -> Lwt.t A :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => Lwt._return c
        end
    end.
End M.

Import Tezos_protocol_environment.

Definition t := M.t.

Definition ops
  : {_ : unit & Tezos_protocol_environment.CONTEXT.signature M.t} := M.

Definition empty : Tezos_protocol_environment.Context.t :=
  let ctxt := M.empty in
  Context.Context {| kind := Memory; ctxt := ctxt; ops := ops |}.
src/lib_protocol_environment/memory_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Tezos_protocol_environment

type t

type _ Context.kind += Memory : t Context.kind

val empty : Context.t
src/lib_protocol_environment/memory_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

extensible_type

Parameter empty : Tezos_protocol_environment.Context.t.
src/lib_protocol_environment/shell_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Tezos_protocol_environment
open Context

let ( >>= ) = Lwt.( >>= )

type _ Context.kind += Shell : Tezos_storage.Context.t Context.kind

let ops = (module Tezos_storage.Context : CONTEXT with type t = 'ctxt)

let checkout index context_hash =
  Tezos_storage.Context.checkout index context_hash
  >>= function
  | Some ctxt ->
      Lwt.return_some (Context.Context {ops; ctxt; kind = Shell})
  | None ->
      Lwt.return_none

let checkout_exn index context_hash =
  Tezos_storage.Context.checkout_exn index context_hash
  >>= fun ctxt -> Lwt.return (Context.Context {ops; ctxt; kind = Shell})

let wrap_disk_context ctxt = Context.Context {ops; ctxt; kind = Shell}

let unwrap_disk_context : t -> Tezos_storage.Context.t = function
  | Context.Context {ctxt; kind = Shell; _} ->
      ctxt
  | _ ->
      assert false
src/lib_protocol_environment/shell_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_environment.

Import Tezos_protocol_environment.Context.

Definition op_gt_gt_eq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.op_gt_gt_eq.

Definition ops
  : {_ : unit &
    Tezos_protocol_environment.CONTEXT.signature Tezos_storage.Context.t} :=
  Tezos_storage.Context.

Definition checkout
  (index : Tezos_storage.Context.index)
  (context_hash : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t (option Tezos_protocol_environment.Context.t) :=
  op_gt_gt_eq (Tezos_storage.Context.checkout index context_hash)
    (fun function_parameter =>
      match function_parameter with
      | Some ctxt =>
        Lwt.return_some
          (Context.Context {| kind := Shell; ctxt := ctxt; ops := ops |})
      | None => Lwt.return_none
      end).

Definition checkout_exn
  (index : Tezos_storage.Context.index)
  (context_hash : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t Tezos_protocol_environment.Context.t :=
  op_gt_gt_eq (Tezos_storage.Context.checkout_exn index context_hash)
    (fun ctxt =>
      Lwt._return
        (Context.Context {| kind := Shell; ctxt := ctxt; ops := ops |})).

Definition wrap_disk_context (ctxt : Tezos_storage.Context.t)
  : Tezos_protocol_environment.Context.t :=
  Context.Context {| kind := Shell; ctxt := ctxt; ops := ops |}.

Definition unwrap_disk_context
  (function_parameter : Tezos_protocol_environment.Context.t)
  : Tezos_storage.Context.t :=
  match function_parameter with
  | Context.Context {| kind := Shell; ctxt := ctxt |} => ctxt
  | _ => false
  end.
src/lib_protocol_environment/shell_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Tezos_protocol_environment
open Tezos_crypto

type _ Context.kind += Shell : Tezos_storage.Context.t Context.kind

val checkout :
  Tezos_storage.Context.index -> Context_hash.t -> Context.t option Lwt.t

val checkout_exn :
  Tezos_storage.Context.index -> Context_hash.t -> Context.t Lwt.t

val wrap_disk_context : Tezos_storage.Context.t -> Context.t

val unwrap_disk_context : Context.t -> Tezos_storage.Context.t
src/lib_protocol_environment/shell_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

Parameter checkout :
Tezos_storage.Context.index ->
  Tezos_crypto.Context_hash.t ->
    Lwt.t (option Tezos_protocol_environment.Context.t).

Parameter checkout_exn :
Tezos_storage.Context.index ->
  Tezos_crypto.Context_hash.t -> Lwt.t Tezos_protocol_environment.Context.t.

Parameter wrap_disk_context :
Tezos_storage.Context.t -> Tezos_protocol_environment.Context.t.

Parameter unwrap_disk_context :
Tezos_protocol_environment.Context.t -> Tezos_storage.Context.t.
src/lib_protocol_environment/sigs/v1/RPC_arg.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a t

type 'a arg = 'a t

val make :
  ?descr:string ->
  name:string ->
  destruct:(string -> ('a, string) result) ->
  construct:('a -> string) ->
  unit ->
  'a arg

type descr = {name : string; descr : string option}

val descr : 'a arg -> descr

val int : int arg

val int32 : int32 arg

val int64 : int64 arg

val float : float arg

val string : string arg

val like : 'a arg -> ?descr:string -> string -> 'a arg

type ('a, 'b) eq = Eq : ('a, 'a) eq

val eq : 'a arg -> 'b arg -> ('a, 'b) eq option
src/lib_protocol_environment/sigs/v1/RPC_arg.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (a : Type), Type.

Definition arg (a : Type) := t a.

Record descr := {
  name : string;
  descr : option string }.

Parameter descr : forall {a : Type}, (arg a) -> descr.

Parameter int : arg Z.

Parameter int32 : arg int32.

Parameter int64 : arg int64.

Parameter float : arg float.

Parameter string : arg string.

Parameter like : forall {a : Type},
(arg a) -> (option string) -> string -> arg a.

Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.

Arguments Eq {_}.

Parameter eq : forall {a b : Type}, (arg a) -> (arg b) -> option (eq a b).
src/lib_protocol_environment/sigs/v1/RPC_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Dispatch tree *)
type 'prefix t

type 'prefix directory = 'prefix t

(** Empty list of dispatch trees *)
val empty : 'prefix directory

val map : ('a -> 'b Lwt.t) -> 'b directory -> 'a directory

val prefix : ('pr, 'p) RPC_path.path -> 'p directory -> 'pr directory

val merge : 'a directory -> 'a directory -> 'a directory

(** Possible error while registring services. *)
type step =
  | Static of string
  | Dynamic of RPC_arg.descr
  | DynamicTail of RPC_arg.descr

type conflict =
  | CService of RPC_service.meth
  | CDir
  | CBuilder
  | CTail
  | CTypes of RPC_arg.descr * RPC_arg.descr
  | CType of RPC_arg.descr * string list

exception Conflict of step list * conflict

(** Registring handler in service tree. *)
val register :
  'prefix directory ->
  ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t ->
  ('params -> 'query -> 'input -> 'output tzresult Lwt.t) ->
  'prefix directory

val opt_register :
  'prefix directory ->
  ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t ->
  ('params -> 'query -> 'input -> 'output option tzresult Lwt.t) ->
  'prefix directory

val gen_register :
  'prefix directory ->
  ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t ->
  ('params -> 'query -> 'input -> [< 'output RPC_answer.t] Lwt.t) ->
  'prefix directory

val lwt_register :
  'prefix directory ->
  ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t ->
  ('params -> 'query -> 'input -> 'output Lwt.t) ->
  'prefix directory

(** Registring handler in service tree. Curryfied variant.  *)

val register0 :
  unit directory ->
  ('m, unit, unit, 'q, 'i, 'o) RPC_service.t ->
  ('q -> 'i -> 'o tzresult Lwt.t) ->
  unit directory

val register1 :
  'prefix directory ->
  ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val register2 :
  'prefix directory ->
  ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val register3 :
  'prefix directory ->
  ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val register4 :
  'prefix directory ->
  ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val register5 :
  'prefix directory ->
  ( 'm,
    'prefix,
    ((((unit * 'a) * 'b) * 'c) * 'd) * 'e,
    'q,
    'i,
    'o )
  RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val opt_register0 :
  unit directory ->
  ('m, unit, unit, 'q, 'i, 'o) RPC_service.t ->
  ('q -> 'i -> 'o option tzresult Lwt.t) ->
  unit directory

val opt_register1 :
  'prefix directory ->
  ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val opt_register2 :
  'prefix directory ->
  ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val opt_register3 :
  'prefix directory ->
  ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val opt_register4 :
  'prefix directory ->
  ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val opt_register5 :
  'prefix directory ->
  ( 'm,
    'prefix,
    ((((unit * 'a) * 'b) * 'c) * 'd) * 'e,
    'q,
    'i,
    'o )
  RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val gen_register0 :
  unit directory ->
  ('m, unit, unit, 'q, 'i, 'o) RPC_service.t ->
  ('q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  unit directory

val gen_register1 :
  'prefix directory ->
  ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val gen_register2 :
  'prefix directory ->
  ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val gen_register3 :
  'prefix directory ->
  ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val gen_register4 :
  'prefix directory ->
  ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val gen_register5 :
  'prefix directory ->
  ( 'm,
    'prefix,
    ((((unit * 'a) * 'b) * 'c) * 'd) * 'e,
    'q,
    'i,
    'o )
  RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val lwt_register0 :
  unit directory ->
  ('m, unit, unit, 'q, 'i, 'o) RPC_service.t ->
  ('q -> 'i -> 'o Lwt.t) ->
  unit directory

val lwt_register1 :
  'prefix directory ->
  ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

val lwt_register2 :
  'prefix directory ->
  ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

val lwt_register3 :
  'prefix directory ->
  ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

val lwt_register4 :
  'prefix directory ->
  ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

val lwt_register5 :
  'prefix directory ->
  ( 'm,
    'prefix,
    ((((unit * 'a) * 'b) * 'c) * 'd) * 'e,
    'q,
    'i,
    'o )
  RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

(** Registring dynamic subtree. *)
val register_dynamic_directory :
  ?descr:string ->
  'prefix directory ->
  ('prefix, 'a) RPC_path.t ->
  ('a -> 'a directory Lwt.t) ->
  'prefix directory
src/lib_protocol_environment/sigs/v1/RPC_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (prefix : Type), Type.

Definition directory (prefix : Type) := t prefix.

Parameter empty : forall {prefix : Type}, directory prefix.

Parameter merge : forall {a : Type},
(directory a) -> (directory a) -> directory a.
src/lib_protocol_environment/sigs/v1/RPC_path.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type ('prefix, 'params) t

type ('prefix, 'params) path = ('prefix, 'params) t

type 'prefix context = ('prefix, 'prefix) path

val root : unit context

val open_root : 'a context

val add_suffix : ('prefix, 'params) path -> string -> ('prefix, 'params) path

val ( / ) : ('prefix, 'params) path -> string -> ('prefix, 'params) path

val add_arg :
  ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a) path

val ( /: ) :
  ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a) path

val add_final_args :
  ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path

val ( /:* ) :
  ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path
src/lib_protocol_environment/sigs/v1/RPC_path.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (prefix params : Type), Type.

Definition path (prefix params : Type) := t prefix params.

Definition context (prefix : Type) := path prefix prefix.

Parameter root : context unit.

Parameter open_root : forall {a : Type}, context a.

Parameter add_suffix : forall {params prefix : Type},
(path prefix params) -> string -> path prefix params.

Parameter op_div : forall {params prefix : Type},
(path prefix params) -> string -> path prefix params.
src/lib_protocol_environment/sigs/v1/RPC_query.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a t

type 'a query = 'a t

val empty : unit query

type ('a, 'b) field

val field :
  ?descr:string -> string -> 'a RPC_arg.t -> 'a -> ('b -> 'a) -> ('b, 'a) field

val opt_field :
  ?descr:string ->
  string ->
  'a RPC_arg.t ->
  ('b -> 'a option) ->
  ('b, 'a option) field

val flag : ?descr:string -> string -> ('b -> bool) -> ('b, bool) field

val multi_field :
  ?descr:string ->
  string ->
  'a RPC_arg.t ->
  ('b -> 'a list) ->
  ('b, 'a list) field

type ('a, 'b, 'c) open_query

val query : 'b -> ('a, 'b, 'b) open_query

val ( |+ ) :
  ('a, 'b, 'c -> 'd) open_query -> ('a, 'c) field -> ('a, 'b, 'd) open_query

val seal : ('a, 'b, 'a) open_query -> 'a t

type untyped = (string * string) list

exception Invalid of string

val parse : 'a query -> untyped -> 'a
src/lib_protocol_environment/sigs/v1/RPC_query.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (a : Type), Type.

Definition query (a : Type) := t a.

Parameter empty : query unit.

Parameter field : forall (a b : Type), Type.

Parameter flag : forall {b : Type},
(option string) -> string -> (b -> bool) -> field b bool.

Parameter open_query : forall (a b c : Type), Type.

Parameter query : forall {a b : Type}, b -> open_query a b b.

Parameter op_pipe_plus : forall {a b c d : Type},
(open_query a b (c -> d)) -> (field a c) -> open_query a b d.

Parameter seal : forall {a b : Type}, (open_query a b a) -> t a.

Definition untyped := list (string * string).

exception

Parameter parse : forall {a : Type}, (query a) -> untyped -> a.
src/lib_protocol_environment/sigs/v1/RPC_service.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** HTTP methods. *)
type meth = [`GET | `POST | `DELETE | `PUT | `PATCH]

type (+'meth, 'prefix, 'params, 'query, 'input, 'output) t
  constraint 'meth = [< meth]

type (+'meth, 'prefix, 'params, 'query, 'input, 'output) service =
  ('meth, 'prefix, 'params, 'query, 'input, 'output) t

val get_service :
  ?description:string ->
  query:'query RPC_query.t ->
  output:'output Data_encoding.t ->
  ('prefix, 'params) RPC_path.t ->
  ([`GET], 'prefix, 'params, 'query, unit, 'output) service

val post_service :
  ?description:string ->
  query:'query RPC_query.t ->
  input:'input Data_encoding.t ->
  output:'output Data_encoding.t ->
  ('prefix, 'params) RPC_path.t ->
  ([`POST], 'prefix, 'params, 'query, 'input, 'output) service

val delete_service :
  ?description:string ->
  query:'query RPC_query.t ->
  output:'output Data_encoding.t ->
  ('prefix, 'params) RPC_path.t ->
  ([`DELETE], 'prefix, 'params, 'query, unit, 'output) service

val patch_service :
  ?description:string ->
  query:'query RPC_query.t ->
  input:'input Data_encoding.t ->
  output:'output Data_encoding.t ->
  ('prefix, 'params) RPC_path.t ->
  ([`PATCH], 'prefix, 'params, 'query, 'input, 'output) service

val put_service :
  ?description:string ->
  query:'query RPC_query.t ->
  input:'input Data_encoding.t ->
  output:'output Data_encoding.t ->
  ('prefix, 'params) RPC_path.t ->
  ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service
src/lib_protocol_environment/sigs/v1/RPC_service.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition meth := variant.

Parameter t : forall
  (expected_variable prefix params query input output : Type), Type.

Definition service (expected_variable prefix params query input output : Type)
  := t variant prefix params query input output.
src/lib_protocol_environment/sigs/v1/base58.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a encoding

val simple_decode : 'a encoding -> string -> 'a option

val simple_encode : 'a encoding -> 'a -> string

type data = ..

val register_encoding :
  prefix:string ->
  length:int ->
  to_raw:('a -> string) ->
  of_raw:(string -> 'a option) ->
  wrap:('a -> data) ->
  'a encoding

val check_encoded_prefix : 'a encoding -> string -> int -> unit

val decode : string -> data option
src/lib_protocol_environment/sigs/v1/base58.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter encoding : forall (a : Type), Type.

Parameter simple_decode : forall {a : Type}, (encoding a) -> string -> option a.

Parameter simple_encode : forall {a : Type}, (encoding a) -> a -> string.

Definition data := False.

Parameter register_encoding : forall {a : Type},
string ->
  Z -> (a -> string) -> (string -> option a) -> (a -> data) -> encoding a.

Parameter check_encoded_prefix : forall {a : Type},
(encoding a) -> string -> Z -> unit.

Parameter decode : string -> option data.
src/lib_protocol_environment/sigs/v1/blake2B.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Builds a new Hash type using Blake2B. *)

(** The parameters for creating a new Hash type using
    {!Make_Blake2B}. Both {!name} and {!title} are only informative,
    used in error messages and serializers. *)

module type Name = sig
  val name : string

  val title : string

  val size : int option
end

module type PrefixedName = sig
  include Name

  val b58check_prefix : string
end

module Make_minimal (Name : Name) : S.MINIMAL_HASH

module Make (Register : sig
  val register_encoding :
    prefix:string ->
    length:int ->
    to_raw:('a -> string) ->
    of_raw:(string -> 'a option) ->
    wrap:('a -> Base58.data) ->
    'a Base58.encoding
end)
(Name : PrefixedName) : S.HASH
src/lib_protocol_environment/sigs/v1/blake2B.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type
src/lib_protocol_environment/sigs/v1/compare.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type COMPARABLE = sig
  type t

  val compare : t -> t -> int
end

module type S = sig
  type t

  val ( = ) : t -> t -> bool

  val ( <> ) : t -> t -> bool

  val ( < ) : t -> t -> bool

  val ( <= ) : t -> t -> bool

  val ( >= ) : t -> t -> bool

  val ( > ) : t -> t -> bool

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val max : t -> t -> t

  val min : t -> t -> t
end

module Make (P : COMPARABLE) : S with type t := P.t

module Char : S with type t = char

module Bool : S with type t = bool

module Int : S with type t = int

module Int32 : S with type t = int32

module Uint32 : S with type t = int32

module Int64 : S with type t = int64

module Uint64 : S with type t = int64

module Float : S with type t = float

module String : S with type t = string

module Z : S with type t = Z.t

module List (P : COMPARABLE) : S with type t = P.t list

module Option (P : COMPARABLE) : S with type t = P.t option
src/lib_protocol_environment/sigs/v1/compare.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module
src/lib_protocol_environment/sigs/v1/context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** View over the context store, restricted to types, access and
    functional manipulation of an existing context. *)

type t

(** Keys in (kex x value) database implementations *)
type key = string list

(** Values in (kex x value) database implementations *)
type value = MBytes.t

val mem : t -> key -> bool Lwt.t

val dir_mem : t -> key -> bool Lwt.t

val get : t -> key -> value option Lwt.t

val set : t -> key -> value -> t Lwt.t

(** [copy] returns None if the [from] key is not bound *)
val copy : t -> from:key -> to_:key -> t option Lwt.t

val del : t -> key -> t Lwt.t

val remove_rec : t -> key -> t Lwt.t

val fold :
  t ->
  key ->
  init:'a ->
  f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
  'a Lwt.t

val keys : t -> key -> key list Lwt.t

val fold_keys : t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

val register_resolver :
  'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit

val complete : t -> string -> string list Lwt.t
src/lib_protocol_environment/sigs/v1/context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition key := list string.
src/lib_protocol_environment/sigs/v1/data_encoding.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** In memory JSON data *)
type json =
  [ `O of (string * json) list
  | `Bool of bool
  | `Float of float
  | `A of json list
  | `Null
  | `String of string ]

type json_schema

type 'a t

type 'a encoding = 'a t

val classify : 'a encoding -> [`Fixed of int | `Dynamic | `Variable]

val splitted : json:'a encoding -> binary:'a encoding -> 'a encoding

val null : unit encoding

val empty : unit encoding

val unit : unit encoding

val constant : string -> unit encoding

val int8 : int encoding

val uint8 : int encoding

val int16 : int encoding

val uint16 : int encoding

val int31 : int encoding

val int32 : int32 encoding

val int64 : int64 encoding

val n : Z.t encoding

val z : Z.t encoding

val bool : bool encoding

val string : string encoding

val bytes : MBytes.t encoding

val float : float encoding

val option : 'a encoding -> 'a option encoding

val string_enum : (string * 'a) list -> 'a encoding

module Fixed : sig
  val string : int -> string encoding

  val bytes : int -> MBytes.t encoding

  val add_padding : 'a encoding -> int -> 'a encoding
end

module Variable : sig
  val string : string encoding

  val bytes : MBytes.t encoding

  val array : ?max_length:int -> 'a encoding -> 'a array encoding

  val list : ?max_length:int -> 'a encoding -> 'a list encoding
end

module Bounded : sig
  val string : int -> string encoding

  val bytes : int -> MBytes.t encoding
end

val dynamic_size :
  ?kind:[`Uint30 | `Uint16 | `Uint8] -> 'a encoding -> 'a encoding

val json : json encoding

val json_schema : json_schema encoding

type 'a field

val req :
  ?title:string -> ?description:string -> string -> 't encoding -> 't field

val opt :
  ?title:string ->
  ?description:string ->
  string ->
  't encoding ->
  't option field

val varopt :
  ?title:string ->
  ?description:string ->
  string ->
  't encoding ->
  't option field

val dft :
  ?title:string ->
  ?description:string ->
  string ->
  't encoding ->
  't ->
  't field

val obj1 : 'f1 field -> 'f1 encoding

val obj2 : 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding

val obj3 : 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding

val obj4 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  ('f1 * 'f2 * 'f3 * 'f4) encoding

val obj5 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding

val obj6 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding

val obj7 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  'f7 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding

val obj8 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  'f7 field ->
  'f8 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding

val obj9 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  'f7 field ->
  'f8 field ->
  'f9 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding

val obj10 :
  'f1 field ->
  'f2 field ->
  'f3 field ->
  'f4 field ->
  'f5 field ->
  'f6 field ->
  'f7 field ->
  'f8 field ->
  'f9 field ->
  'f10 field ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding

val tup1 : 'f1 encoding -> 'f1 encoding

val tup2 : 'f1 encoding -> 'f2 encoding -> ('f1 * 'f2) encoding

val tup3 :
  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> ('f1 * 'f2 * 'f3) encoding

val tup4 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4) encoding

val tup5 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding

val tup6 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding

val tup7 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  'f7 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding

val tup8 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  'f7 encoding ->
  'f8 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding

val tup9 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  'f7 encoding ->
  'f8 encoding ->
  'f9 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding

val tup10 :
  'f1 encoding ->
  'f2 encoding ->
  'f3 encoding ->
  'f4 encoding ->
  'f5 encoding ->
  'f6 encoding ->
  'f7 encoding ->
  'f8 encoding ->
  'f9 encoding ->
  'f10 encoding ->
  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding

val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding

val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding

val array : ?max_length:int -> 'a encoding -> 'a array encoding

val list : ?max_length:int -> 'a encoding -> 'a list encoding

val assoc : 'a encoding -> (string * 'a) list encoding

type case_tag = Tag of int | Json_only

type 't case

val case :
  title:string ->
  ?description:string ->
  case_tag ->
  'a encoding ->
  ('t -> 'a option) ->
  ('a -> 't) ->
  't case

val union : ?tag_size:[`Uint8 | `Uint16] -> 't case list -> 't encoding

val def :
  string -> ?title:string -> ?description:string -> 't encoding -> 't encoding

val conv :
  ('a -> 'b) -> ('b -> 'a) -> ?schema:json_schema -> 'b encoding -> 'a encoding

val mu :
  string ->
  ?title:string ->
  ?description:string ->
  ('a encoding -> 'a encoding) ->
  'a encoding

type 'a lazy_t

val lazy_encoding : 'a encoding -> 'a lazy_t encoding

val force_decode : 'a lazy_t -> 'a option

val force_bytes : 'a lazy_t -> MBytes.t

val make_lazy : 'a encoding -> 'a -> 'a lazy_t

val apply_lazy :
  fun_value:('a -> 'b) ->
  fun_bytes:(MBytes.t -> 'b) ->
  fun_combine:('b -> 'b -> 'b) ->
  'a lazy_t ->
  'b

module Json : sig
  val schema : ?definitions_path:string -> 'a encoding -> json_schema

  val construct : 't encoding -> 't -> json

  val destruct : 't encoding -> json -> 't

  (** JSON Error *)

  type path = path_item list

  and path_item =
    [ `Field of string  (** A field in an object. *)
    | `Index of int  (** An index in an array. *)
    | `Star  (** Any / every field or index. *)
    | `Next  (** The next element after an array. *) ]

  (** Exception raised by destructors, with the location in the original
      JSON structure and the specific error. *)
  exception Cannot_destruct of (path * exn)

  (** Unexpected kind of data encountered (w/ the expectation). *)
  exception Unexpected of string * string

  (** Some {!union} couldn't be destructed, w/ the reasons for each {!case}. *)
  exception No_case_matched of exn list

  (** Array of unexpected size encountered  (w/ the expectation). *)
  exception Bad_array_size of int * int

  (** Missing field in an object. *)
  exception Missing_field of string

  (** Supernumerary field in an object. *)
  exception Unexpected_field of string

  val print_error :
    ?print_unknown:(Format.formatter -> exn -> unit) ->
    Format.formatter ->
    exn ->
    unit

  (** Helpers for writing encoders. *)
  val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a

  val wrap_error : ('a -> 'b) -> 'a -> 'b

  val pp : Format.formatter -> json -> unit
end

module Binary : sig
  val length : 'a encoding -> 'a -> int

  val fixed_length : 'a encoding -> int option

  val read : 'a encoding -> MBytes.t -> int -> int -> (int * 'a) option

  val write : 'a encoding -> 'a -> MBytes.t -> int -> int -> int option

  val to_bytes : 'a encoding -> 'a -> MBytes.t option

  val to_bytes_exn : 'a encoding -> 'a -> MBytes.t

  val of_bytes : 'a encoding -> MBytes.t -> 'a option

  type write_error

  exception Write_error of write_error
end

(** [check_size size encoding] ensures that the binary encoding
    of a value will not be allowed to exceed [size] bytes. The reader
    and the writer fails otherwise. This function do not modify
    the JSON encoding. *)
val check_size : int -> 'a encoding -> 'a encoding
src/lib_protocol_environment/sigs/v1/data_encoding.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition json := variant.

Parameter json_schema : Type.

Parameter t : forall (a : Type), Type.

Definition encoding (a : Type) := t a.

Parameter classify : forall {a variant : Type}, (encoding a) -> variant.

Parameter splitted : forall {a : Type},
(encoding a) -> (encoding a) -> encoding a.

Parameter null : encoding unit.

Parameter empty : encoding unit.

Parameter unit : encoding unit.

Parameter constant : string -> encoding unit.

Parameter int8 : encoding Z.

Parameter uint8 : encoding Z.

Parameter int16 : encoding Z.

Parameter uint16 : encoding Z.

Parameter int31 : encoding Z.

Parameter int32 : encoding int32.

Parameter int64 : encoding int64.

Parameter bool : encoding bool.

Parameter string : encoding string.

Parameter float : encoding float.

Parameter option : forall {a : Type}, (encoding a) -> encoding (option a).

Parameter string_enum : forall {a : Type}, (list (string * a)) -> encoding a.

Module Fixed.
  Parameter string : Z -> encoding string.
  
  Parameter add_padding : forall {a : Type}, (encoding a) -> Z -> encoding a.
End Fixed.

Module Variable.
  Parameter string : encoding string.
  
  Parameter array : forall {a : Type}, (option Z) ->
    (encoding a) -> encoding (array a).
  
  Parameter list : forall {a : Type}, (option Z) ->
    (encoding a) -> encoding (list a).
End Variable.

Module Bounded.
  Parameter string : Z -> encoding string.
End Bounded.

Parameter dynamic_size : forall {a variant : Type},
(option variant) -> (encoding a) -> encoding a.

Parameter json : encoding json.

Parameter json_schema : encoding json_schema.

Parameter field : forall (a : Type), Type.

Parameter req : forall {t : Type},
(option string) -> (option string) -> string -> (encoding t) -> field t.

Parameter opt : forall {t : Type},
(option string) -> (option string) -> string -> (encoding t) -> field (option t).

Parameter varopt : forall {t : Type},
(option string) -> (option string) -> string -> (encoding t) -> field (option t).

Parameter dft : forall {t : Type},
(option string) -> (option string) -> string -> (encoding t) -> t -> field t.

Parameter obj1 : forall {f1 : Type}, (field f1) -> encoding f1.

Parameter obj2 : forall {f1 f2 : Type},
(field f1) -> (field f2) -> encoding (f1 * f2).

Parameter obj3 : forall {f1 f2 f3 : Type},
(field f1) -> (field f2) -> (field f3) -> encoding (f1 * f2 * f3).

Parameter obj4 : forall {f1 f2 f3 f4 : Type},
(field f1) ->
  (field f2) -> (field f3) -> (field f4) -> encoding (f1 * f2 * f3 * f4).

Parameter obj5 : forall {f1 f2 f3 f4 f5 : Type},
(field f1) ->
  (field f2) ->
    (field f3) -> (field f4) -> (field f5) -> encoding (f1 * f2 * f3 * f4 * f5).

Parameter obj6 : forall {f1 f2 f3 f4 f5 f6 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) -> (field f6) -> encoding (f1 * f2 * f3 * f4 * f5 * f6).

Parameter obj7 : forall {f1 f2 f3 f4 f5 f6 f7 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) ->
          (field f6) ->
            (field f7) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7).

Parameter obj8 : forall {f1 f2 f3 f4 f5 f6 f7 f8 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) ->
          (field f6) ->
            (field f7) ->
              (field f8) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8).

Parameter obj9 : forall {f1 f2 f3 f4 f5 f6 f7 f8 f9 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) ->
          (field f6) ->
            (field f7) ->
              (field f8) ->
                (field f9) ->
                  encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9).

Parameter obj10 : forall {f1 f10 f2 f3 f4 f5 f6 f7 f8 f9 : Type},
(field f1) ->
  (field f2) ->
    (field f3) ->
      (field f4) ->
        (field f5) ->
          (field f6) ->
            (field f7) ->
              (field f8) ->
                (field f9) ->
                  (field f10) ->
                    encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9 * f10).

Parameter tup1 : forall {f1 : Type}, (encoding f1) -> encoding f1.

Parameter tup2 : forall {f1 f2 : Type},
(encoding f1) -> (encoding f2) -> encoding (f1 * f2).

Parameter tup3 : forall {f1 f2 f3 : Type},
(encoding f1) -> (encoding f2) -> (encoding f3) -> encoding (f1 * f2 * f3).

Parameter tup4 : forall {f1 f2 f3 f4 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) -> (encoding f4) -> encoding (f1 * f2 * f3 * f4).

Parameter tup5 : forall {f1 f2 f3 f4 f5 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) -> (encoding f5) -> encoding (f1 * f2 * f3 * f4 * f5).

Parameter tup6 : forall {f1 f2 f3 f4 f5 f6 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) -> (encoding f6) -> encoding (f1 * f2 * f3 * f4 * f5 * f6).

Parameter tup7 : forall {f1 f2 f3 f4 f5 f6 f7 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) ->
          (encoding f6) ->
            (encoding f7) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7).

Parameter tup8 : forall {f1 f2 f3 f4 f5 f6 f7 f8 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) ->
          (encoding f6) ->
            (encoding f7) ->
              (encoding f8) -> encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8).

Parameter tup9 : forall {f1 f2 f3 f4 f5 f6 f7 f8 f9 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) ->
          (encoding f6) ->
            (encoding f7) ->
              (encoding f8) ->
                (encoding f9) ->
                  encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9).

Parameter tup10 : forall {f1 f10 f2 f3 f4 f5 f6 f7 f8 f9 : Type},
(encoding f1) ->
  (encoding f2) ->
    (encoding f3) ->
      (encoding f4) ->
        (encoding f5) ->
          (encoding f6) ->
            (encoding f7) ->
              (encoding f8) ->
                (encoding f9) ->
                  (encoding f10) ->
                    encoding (f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9 * f10).

Parameter merge_objs : forall {o1 o2 : Type},
(encoding o1) -> (encoding o2) -> encoding (o1 * o2).

Parameter merge_tups : forall {a1 a2 : Type},
(encoding a1) -> (encoding a2) -> encoding (a1 * a2).

Parameter array : forall {a : Type},
(option Z) -> (encoding a) -> encoding (array a).

Parameter list : forall {a : Type},
(option Z) -> (encoding a) -> encoding (list a).

Parameter assoc : forall {a : Type},
(encoding a) -> encoding (list (string * a)).

Inductive case_tag : Type :=
| Tag : Z -> case_tag
| Json_only : case_tag.

Parameter case : forall (t : Type), Type.

Parameter case : forall {a t : Type},
string ->
  (option string) ->
    case_tag -> (encoding a) -> (t -> option a) -> (a -> t) -> case t.

Parameter union : forall {t variant : Type},
(option variant) -> (list (case t)) -> encoding t.

Parameter def : forall {t : Type},
string -> (option string) -> (option string) -> (encoding t) -> encoding t.

Parameter conv : forall {a b : Type},
(a -> b) -> (b -> a) -> (option json_schema) -> (encoding b) -> encoding a.

Parameter mu : forall {a : Type},
string ->
  (option string) ->
    (option string) -> ((encoding a) -> encoding a) -> encoding a.

Parameter lazy_t : forall (a : Type), Type.

Parameter lazy_encoding : forall {a : Type},
(encoding a) -> encoding (lazy_t a).

Parameter force_decode : forall {a : Type}, (lazy_t a) -> option a.

Parameter make_lazy : forall {a : Type}, (encoding a) -> a -> lazy_t a.

Module Json.
  Parameter schema : forall {a : Type}, (option string) ->
    (encoding a) -> json_schema.
  
  Parameter construct : forall {t : Type}, (encoding t) -> t -> json.
  
  Parameter destruct : forall {t : Type}, (encoding t) -> json -> t.
  
  Reserved Notation "'path".
  Reserved Notation "'path_item".
  
  
  
  where "'path" := ( list 'path_item)
  
  and "'path_item" := ( variant).
  
  Definition path := 'path.
  Definition path_item := 'path_item.
  
  exception
  
  exception
  
  exception
  
  exception
  
  exception
  
  exception
  
  Parameter wrap_error : forall {a b : Type}, (a -> b) -> a -> b.
End Json.

Module Binary.
  Parameter length : forall {a : Type}, (encoding a) -> a -> Z.
  
  Parameter fixed_length : forall {a : Type}, (encoding a) -> option Z.
  
  Parameter write_error : Type.
  
  exception
End Binary.

Parameter check_size : forall {a : Type}, Z -> (encoding a) -> encoding a.
src/lib_protocol_environment/sigs/v1/error_monad.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Error Monad *)

(** {2 Error classification} *)

(** Categories of error *)
type error_category =
  [ `Branch  (** Errors that may not happen in another context *)
  | `Temporary  (** Errors that may not happen in a later context *)
  | `Permanent  (** Errors that will happen no matter the context *) ]

(** Custom error handling for economic protocols. *)

type error = ..

val pp : Format.formatter -> error -> unit

(** A JSON error serializer *)
val error_encoding : error Data_encoding.t

val json_of_error : error -> Data_encoding.json

val error_of_json : Data_encoding.json -> error

(** Error information *)
type error_info = {
  category : error_category;
  id : string;
  title : string;
  description : string;
  schema : Data_encoding.json_schema;
}

val pp_info : Format.formatter -> error_info -> unit

(** Retrieves information of registered errors *)
val get_registered_errors : unit -> error_info list

(** For other modules to register specialized error serializers *)
val register_error_kind :
  error_category ->
  id:string ->
  title:string ->
  description:string ->
  ?pp:(Format.formatter -> 'err -> unit) ->
  'err Data_encoding.t ->
  (error -> 'err option) ->
  ('err -> error) ->
  unit

(** Classify an error using the registered kinds *)
val classify_errors : error list -> error_category

(** {2 Monad definition} *)

(** The error monad wrapper type, the error case holds a stack of
    error, initialized by the first call to {!fail} and completed by
    each call to {!trace} as the stack is rewinded. The most general
    error is thus at the top of the error stack, going down to the
    specific error that actually caused the failure. *)
type 'a tzresult = ('a, error list) result

(** A JSON serializer for result of a given type *)
val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding

(** Sucessful result *)
val ok : 'a -> 'a tzresult

(** Sucessful return *)
val return : 'a -> 'a tzresult Lwt.t

(** Sucessful return of [()] *)
val return_unit : unit tzresult Lwt.t

(** Sucessful return of [None] *)
val return_none : 'a option tzresult Lwt.t

(** [return_some x] is a sucessful return of [Some x] *)
val return_some : 'a -> 'a option tzresult Lwt.t

(** Sucessful return of [[]] *)
val return_nil : 'a list tzresult Lwt.t

(** Sucessful return of [true] *)
val return_true : bool tzresult Lwt.t

(** Sucessful return of [false] *)
val return_false : bool tzresult Lwt.t

(** Erroneous result *)
val error : error -> 'a tzresult

(** Erroneous return *)
val fail : error -> 'a tzresult Lwt.t

(** Non-Lwt bind operator *)
val ( >>? ) : 'a tzresult -> ('a -> 'b tzresult) -> 'b tzresult

(** Bind operator *)
val ( >>=? ) :
  'a tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t

(** Lwt's bind reexported *)
val ( >>= ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t

val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t

(** To operator *)
val ( >>|? ) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t

(** Non-Lwt to operator *)
val ( >|? ) : 'a tzresult -> ('a -> 'b) -> 'b tzresult

(** Enrich an error report (or do nothing on a successful result) manually *)
val record_trace : error -> 'a tzresult -> 'a tzresult

(** Automatically enrich error reporting on stack rewind *)
val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t

(** Same as record_trace, for unevaluated error *)
val record_trace_eval : (unit -> error tzresult) -> 'a tzresult -> 'a tzresult

(** Same as trace, for unevaluated Lwt error *)
val trace_eval :
  (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t

(** Erroneous return on failed assertion *)
val fail_unless : bool -> error -> unit tzresult Lwt.t

(** Erroneous return on successful assertion *)
val fail_when : bool -> error -> unit tzresult Lwt.t

(** {2 In-monad list iterators} *)

(** A {!List.iter} in the monad *)
val iter_s : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t

val iter_p : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t

(** A {!List.map} in the monad *)
val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

val map_p : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

(** A {!List.map2} in the monad *)
val map2 : ('a -> 'b -> 'c tzresult) -> 'a list -> 'b list -> 'c list tzresult

(** A {!List.map2} in the monad *)
val map2_s :
  ('a -> 'b -> 'c tzresult Lwt.t) ->
  'a list ->
  'b list ->
  'c list tzresult Lwt.t

(** A {!List.filter_map} in the monad *)
val filter_map_s :
  ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

(** A {!List.fold_left} in the monad *)
val fold_left_s :
  ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b list -> 'a tzresult Lwt.t

(** A {!List.fold_right} in the monad *)
val fold_right_s :
  ('a -> 'b -> 'b tzresult Lwt.t) -> 'a list -> 'b -> 'b tzresult Lwt.t

(**/**)

type shell_error

type 'a shell_tzresult = ('a, shell_error list) result
src/lib_protocol_environment/sigs/v1/error_monad.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition error_category := variant.

Definition error := False.

Parameter classify_errors : (list error) -> error_category.

Parameter shell_error : Type.
src/lib_protocol_environment/sigs/v1/format.mli 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Pierre Weis, projet Cristal, INRIA Rocquencourt            *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* TEZOS CHANGES

   * Import version 4.06.1
   * Remove channel functions
   * Remove toplevel effect based functions
   * Remove deprecated functions
   * Remove redirecting the standard formatter output
   * Remove redefining formatter output and output functions
   * Remove redefining semantic tag operations (too complex and
     imperative for the need of error message generation)
   * Remove defining formatters and symbolic pretty printing
*)

(** Pretty-printing.

    This module implements a pretty-printing facility to format values
    within {{!boxes}'pretty-printing boxes'} and {{!tags}'semantic tags'}
    combined with a set of {{!fpp}printf-like functions}.
    The pretty-printer splits lines at specified {{!breaks}break hints},
    and indents lines according to the box structure.
    Similarly, {{!tags}semantic tags} can be used to decouple text
    presentation from its contents.

    This pretty-printing facility is implemented as an overlay on top of
    abstract {{!section:formatter}formatters} which provide basic output
    functions.
    Some formatters are predefined, notably:
    - {!std_formatter} outputs to {{!Pervasives.stdout}stdout}
    - {!err_formatter} outputs to {{!Pervasives.stderr}stderr}

    Most functions in the {!Format} module come in two variants:
    a short version that operates on {!std_formatter} and the
    generic version prefixed by [pp_] that takes a formatter
    as its first argument.

    More formatters can be created with {!formatter_of_out_channel},
    {!formatter_of_buffer}, {!formatter_of_symbolic_output_buffer}
    or using {{!section:formatter}custom formatters}.

*)

(** {1 Introduction}
    For a gentle introduction to the basics of pretty-printing using
    [Format], read
    {{:http://caml.inria.fr/resources/doc/guides/format.en.html}
    http://caml.inria.fr/resources/doc/guides/format.en.html}.

    You may consider this module as providing an extension to the
    [printf] facility to provide automatic line splitting. The addition of
    pretty-printing annotations to your regular [printf] format strings gives
    you fancy indentation and line breaks.
    Pretty-printing annotations are described below in the documentation of
    the function {!Format.fprintf}.

    You may also use the explicit pretty-printing box management and printing
    functions provided by this module. This style is more basic but more
    verbose than the concise [fprintf] format strings.

    For instance, the sequence
    [open_box 0; print_string "x ="; print_space ();
    print_int 1; close_box (); print_newline ()]
    that prints [x = 1] within a pretty-printing box, can be
    abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter
    [printf "@[x =@ %i@]@." 1].

    Rule of thumb for casual users of this library:
    - use simple pretty-printing boxes (as obtained by [open_box 0]);
    - use simple break hints as obtained by [print_cut ()] that outputs a
    simple break hint, or by [print_space ()] that outputs a space
    indicating a break hint;
    - once a pretty-printing box is open, display its material with basic
    printing functions (e. g. [print_int] and [print_string]);
    - when the material for a pretty-printing box has been printed, call
    [close_box ()] to close the box;
    - at the end of pretty-printing, flush the pretty-printer to display all
    the remaining material, e.g. evaluate [print_newline ()].

    The behavior of pretty-printing commands is unspecified
    if there is no open pretty-printing box. Each box opened by
    one of the [open_] functions below must be closed using [close_box]
    for proper formatting. Otherwise, some of the material printed in the
    boxes may not be output, or may be formatted incorrectly.

    In case of interactive use, each phrase is executed in the initial state
    of the standard pretty-printer: after each phrase execution, the
    interactive system closes all open pretty-printing boxes, flushes all
    pending text, and resets the standard pretty-printer.

    Warning: mixing calls to pretty-printing functions of this module with
    calls to {!Pervasives} low level output functions is error prone.

    The pretty-printing functions output material that is delayed in the
    pretty-printer queue and stacks in order to compute proper line
    splitting. In contrast, basic I/O output functions write directly in
    their output device. As a consequence, the output of a basic I/O function
    may appear before the output of a pretty-printing function that has been
    called before. For instance,
    [
    Pervasives.print_string "<";
    Format.print_string "PRETTY";
    Pervasives.print_string ">";
    Format.print_string "TEXT";
    ]
    leads to output [<>PRETTYTEXT].

*)

(** Abstract data corresponding to a pretty-printer (also called a
    formatter) and all its machinery. See also {!section:formatter}. *)
type formatter

(** {1:boxes Pretty-printing boxes} *)

(** The pretty-printing engine uses the concepts of pretty-printing box and
    break hint to drive indentation and line splitting behavior of the
    pretty-printer.

    Each different pretty-printing box kind introduces a specific line splitting
    policy:

    - within an {e horizontal} box, break hints never split the line (but the
    line may be split in a box nested deeper),
    - within a {e vertical} box, break hints always split the line,
    - within an {e horizontal/vertical} box, if the box fits on the current line
    then break hints never split the line, otherwise break hint always split
    the line,
    - within a {e compacting} box, a break hint never splits the line,
    unless there is no more room on the current line.

    Note that line splitting policy is box specific: the policy of a box does
    not rule the policy of inner boxes. For instance, if a vertical box is
    nested in an horizontal box, all break hints within the vertical box will
    split the line.
*)

(** [pp_open_box ppf d] opens a new compacting pretty-printing box with
    offset [d] in the formatter [ppf].

    Within this box, the pretty-printer prints as much as possible material on
    every line.

    A break hint splits the line if there is no more room on the line to
    print the remainder of the box.

    Within this box, the pretty-printer emphasizes the box structure: a break
    hint also splits the line if the splitting ``moves to the left''
    (i.e. the new line gets an indentation smaller than the one of the current
    line).

    This box is the general purpose pretty-printing box.

    If the pretty-printer splits the line in the box, offset [d] is added to
    the current indentation.
*)
val pp_open_box : formatter -> int -> unit

(** Closes the most recently open pretty-printing box. *)
val pp_close_box : formatter -> unit -> unit

(** [pp_open_hbox ppf ()] opens a new 'horizontal' pretty-printing box.

    This box prints material on a single line.

    Break hints in a horizontal box never split the line.
    (Line splitting may still occur inside boxes nested deeper).
*)
val pp_open_hbox : formatter -> unit -> unit

(** [pp_open_vbox ppf d] opens a new 'vertical' pretty-printing box
    with offset [d].

    This box prints material on as many lines as break hints in the box.

    Every break hint in a vertical box splits the line.

    If the pretty-printer splits the line in the box, [d] is added to the
    current indentation.
*)
val pp_open_vbox : formatter -> int -> unit

(** [pp_open_hvbox ppf d] opens a new 'horizontal/vertical' pretty-printing box
    with offset [d].

    This box behaves as an horizontal box if it fits on a single line,
    otherwise it behaves as a vertical box.

    If the pretty-printer splits the line in the box, [d] is added to the
    current indentation.
*)
val pp_open_hvbox : formatter -> int -> unit

(** [pp_open_hovbox ppf d] opens a new 'horizontal-or-vertical'
    pretty-printing box with offset [d].

    This box prints material as much as possible on every line.

    A break hint splits the line if there is no more room on the line to
    print the remainder of the box.

    If the pretty-printer splits the line in the box, [d] is added to the
    current indentation.
*)
val pp_open_hovbox : formatter -> int -> unit

(** {1 Formatting functions} *)

(** [pp_print_string ppf s] prints [s] in the current pretty-printing box. *)
val pp_print_string : formatter -> string -> unit

(** [pp_print_as ppf len s] prints [s] in the current pretty-printing box.
    The pretty-printer formats [s] as if it were of length [len].
*)
val pp_print_as : formatter -> int -> string -> unit

(** Print an integer in the current pretty-printing box. *)
val pp_print_int : formatter -> int -> unit

(** Print a floating point number in the current pretty-printing box. *)
val pp_print_float : formatter -> float -> unit

(** Print a character in the current pretty-printing box. *)
val pp_print_char : formatter -> char -> unit

(** Print a boolean in the current pretty-printing box. *)
val pp_print_bool : formatter -> bool -> unit

(** {1:breaks Break hints} *)

(** A 'break hint' tells the pretty-printer to output some space or split the
    line whichever way is more appropriate to the current pretty-printing box
    splitting rules.

    Break hints are used to separate printing items and are mandatory to let
    the pretty-printer correctly split lines and indent items.

    Simple break hints are:
    - the 'space': output a space or split the line if appropriate,
    - the 'cut': split the line if appropriate.

    Note: the notions of space and line splitting are abstract for the
    pretty-printing engine, since those notions can be completely redefined
    by the programmer.
    However, in the pretty-printer default setting, ``output a space'' simply
    means printing a space character (ASCII code 32) and ``split the line''
    means printing a newline character (ASCII code 10).
*)

(** [pp_print_space ppf ()] emits a 'space' break hint:
    the pretty-printer may split the line at this point,
    otherwise it prints one space.

    [pp_print_space ppf ()] is equivalent to [pp_print_break ppf 1 0].
*)
val pp_print_space : formatter -> unit -> unit

(** [pp_print_cut ppf ()] emits a 'cut' break hint:
    the pretty-printer may split the line at this point,
    otherwise it prints nothing.

    [pp_print_cut ppf ()] is equivalent to [pp_print_break ppf 0 0].
*)
val pp_print_cut : formatter -> unit -> unit

(** [pp_print_break ppf nspaces offset] emits a 'full' break hint:
    the pretty-printer may split the line at this point,
    otherwise it prints [nspaces] spaces.

    If the pretty-printer splits the line, [offset] is added to
    the current indentation.
*)
val pp_print_break : formatter -> int -> int -> unit

(** Force a new line in the current pretty-printing box.

    The pretty-printer must split the line at this point,

    Not the normal way of pretty-printing, since imperative line splitting may
    interfere with current line counters and box size calculation.
    Using break hints within an enclosing vertical box is a better
    alternative.
*)
val pp_force_newline : formatter -> unit -> unit

(** Execute the next formatting command if the preceding line
    has just been split. Otherwise, ignore the next formatting
    command.
*)
val pp_print_if_newline : formatter -> unit -> unit

(** {1 Pretty-printing termination} *)

(** End of pretty-printing: resets the pretty-printer to initial state.

    All open pretty-printing boxes are closed, all pending text is printed.
    In addition, the pretty-printer low level output device is flushed to
    ensure that all pending text is really displayed.

    Note: never use [print_flush] in the normal course of a pretty-printing
    routine, since the pretty-printer uses a complex buffering machinery to
    properly indent the output; manually flushing those buffers at random
    would conflict with the pretty-printer strategy and result to poor
    rendering.

    Only consider using [print_flush] when displaying all pending material is
    mandatory (for instance in case of interactive use when you want the user
    to read some text) and when resetting the pretty-printer state will not
    disturb further pretty-printing.

    Warning: If the output device of the pretty-printer is an output channel,
    repeated calls to [print_flush] means repeated calls to {!Pervasives.flush}
    to flush the out channel; these explicit flush calls could foil the
    buffering strategy of output channels and could dramatically impact
    efficiency.
*)
val pp_print_flush : formatter -> unit -> unit

(** End of pretty-printing: resets the pretty-printer to initial state.

    All open pretty-printing boxes are closed, all pending text is printed.

    Equivalent to {!print_flush} followed by a new line.
    See corresponding words of caution for {!print_flush}.

    Note: this is not the normal way to output a new line;
    the preferred method is using break hints within a vertical pretty-printing
    box.
*)
val pp_print_newline : formatter -> unit -> unit

(** {1 Margin} *)

(** [pp_set_margin ppf d] sets the right margin to [d] (in characters):
    the pretty-printer splits lines that overflow the right margin according to
    the break hints given.
    Nothing happens if [d] is smaller than 2.
    If [d] is too large, the right margin is set to the maximum
    admissible value (which is greater than [10 ^ 9]).
    If [d] is less than the current maximum indentation limit, the
    maximum indentation limit is decreased while trying to preserve
    a minimal ratio [max_indent/margin>=50%] and if possible
    the current difference [margin - max_indent].
*)
val pp_set_margin : formatter -> int -> unit

(** Returns the position of the right margin. *)
val pp_get_margin : formatter -> unit -> int

(** {1 Maximum indentation limit} *)

(** [pp_set_max_indent ppf d] sets the maximum indentation limit of lines
    to [d] (in characters):
    once this limit is reached, new pretty-printing boxes are rejected to the
    left, if they do not fit on the current line.

    Nothing happens if [d] is smaller than 2.
    If [d] is too large, the limit is set to the maximum
    admissible value (which is greater than [10 ^ 9]).

    If [d] is greater or equal than the current margin, it is ignored,
    and the current maximum indentation limit is kept.
*)
val pp_set_max_indent : formatter -> int -> unit

(** Return the maximum indentation limit (in characters). *)
val pp_get_max_indent : formatter -> unit -> int

(** {1 Maximum formatting depth} *)

(** The maximum formatting depth is the maximum number of pretty-printing
    boxes simultaneously open.

    Material inside boxes nested deeper is printed as an ellipsis (more
    precisely as the text returned by {!get_ellipsis_text} [()]).
*)

(** [pp_set_max_boxes ppf max] sets the maximum number of pretty-printing
    boxes simultaneously open.

    Material inside boxes nested deeper is printed as an ellipsis (more
    precisely as the text returned by {!get_ellipsis_text} [()]).

    Nothing happens if [max] is smaller than 2.
*)
val pp_set_max_boxes : formatter -> int -> unit

(** Returns the maximum number of pretty-printing boxes allowed before
    ellipsis.
*)
val pp_get_max_boxes : formatter -> unit -> int

(** Tests if the maximum number of pretty-printing boxes allowed have already
    been opened.
*)
val pp_over_max_boxes : formatter -> unit -> bool

(** {1 Tabulation boxes} *)

(**

   A {e tabulation box} prints material on lines divided into cells of fixed
   length. A tabulation box provides a simple way to display vertical columns
   of left adjusted text.

   This box features command [set_tab] to define cell boundaries, and command
   [print_tab] to move from cell to cell and split the line when there is no
   more cells to print on the line.

   Note: printing within tabulation box is line directed, so arbitrary line
   splitting inside a tabulation box leads to poor rendering. Yet, controlled
   use of tabulation boxes allows simple printing of columns within
   module {!Format}.
*)

(** [open_tbox ()] opens a new tabulation box.

    This box prints lines separated into cells of fixed width.

    Inside a tabulation box, special {e tabulation markers} defines points of
    interest on the line (for instance to delimit cell boundaries).
    Function {!Format.set_tab} sets a tabulation marker at insertion point.

    A tabulation box features specific {e tabulation breaks} to move to next
    tabulation marker or split the line. Function {!Format.print_tbreak} prints
    a tabulation break.
*)
val pp_open_tbox : formatter -> unit -> unit

(** Closes the most recently opened tabulation box. *)
val pp_close_tbox : formatter -> unit -> unit

(** Sets a tabulation marker at current insertion point. *)
val pp_set_tab : formatter -> unit -> unit

(** [print_tab ()] emits a 'next' tabulation break hint: if not already set on
    a tabulation marker, the insertion point moves to the first tabulation
    marker on the right, or the pretty-printer splits the line and insertion
    point moves to the leftmost tabulation marker.

    It is equivalent to [print_tbreak 0 0]. *)
val pp_print_tab : formatter -> unit -> unit

(** [print_tbreak nspaces offset] emits a 'full' tabulation break hint.

    If not already set on a tabulation marker, the insertion point moves to the
    first tabulation marker on the right and the pretty-printer prints
    [nspaces] spaces.

    If there is no next tabulation marker on the right, the pretty-printer
    splits the line at this point, then insertion point moves to the leftmost
    tabulation marker of the box.

    If the pretty-printer splits the line, [offset] is added to
    the current indentation.
*)
val pp_print_tbreak : formatter -> int -> int -> unit

(** {1 Ellipsis} *)

(** Set the text of the ellipsis printed when too many pretty-printing boxes
    are open (a single dot, [.], by default).
*)
val pp_set_ellipsis_text : formatter -> string -> unit

(** Return the text of the ellipsis. *)
val pp_get_ellipsis_text : formatter -> unit -> string

(** {1:tags Semantic tags} *)

type tag = string

(** {i Semantic tags} (or simply {e tags}) are user's defined delimiters
    to associate user's specific operations to printed entities.

    Common usage of semantic tags is text decoration to get specific font or
    text size rendering for a display device, or marking delimitation of
    entities (e.g. HTML or TeX elements or terminal escape sequences).
    More sophisticated usage of semantic tags could handle dynamic
    modification of the pretty-printer behavior to properly print the material
    within some specific tags.

    In order to properly delimit printed entities, a semantic tag must be
    opened before and closed after the entity. Semantic tags must be properly
    nested like parentheses.

    Tag specific operations occur any time a tag is opened or closed, At each
    occurrence, two kinds of operations are performed {e tag-marking} and
    {e tag-printing}:
    - The tag-marking operation is the simpler tag specific operation: it simply
    writes a tag specific string into the output device of the
    formatter. Tag-marking does not interfere with line-splitting computation.
    - The tag-printing operation is the more involved tag specific operation: it
    can print arbitrary material to the formatter. Tag-printing is tightly
    linked to the current pretty-printer operations.

    Roughly speaking, tag-marking is commonly used to get a better rendering of
    texts in the rendering device, while tag-printing allows fine tuning of
    printing routines to print the same entity differently according to the
    semantic tags (i.e. print additional material or even omit parts of the
    output).

    More precisely: when a semantic tag is opened or closed then both and
    successive 'tag-printing' and 'tag-marking' operations occur:
    - Tag-printing a semantic tag means calling the formatter specific function
    [print_open_tag] (resp. [print_close_tag]) with the name of the tag as
    argument: that tag-printing function can then print any regular material
    to the formatter (so that this material is enqueued as usual in the
    formatter queue for further line splitting computation).
    - Tag-marking a semantic tag means calling the formatter specific function
    [mark_open_tag] (resp. [mark_close_tag]) with the name of the tag as
    argument: that tag-marking function can then return the 'tag-opening
    marker' (resp. `tag-closing marker') for direct output into the output
    device of the formatter.

    Being written directly into the output device of the formatter, semantic
    tag marker strings are not considered as part of the printing material that
    drives line splitting (in other words, the length of the strings
    corresponding to tag markers is considered as zero for line splitting).

    Thus, semantic tag handling is in some sense transparent to pretty-printing
    and does not interfere with usual indentation. Hence, a single
    pretty-printing routine can output both simple 'verbatim' material or
    richer decorated output depending on the treatment of tags. By default,
    tags are not active, hence the output is not decorated with tag
    information. Once [set_tags] is set to [true], the pretty-printer engine
    honors tags and decorates the output accordingly.

    Default tag-marking functions behave the HTML way: tags are enclosed in "<"
    and ">"; hence, opening marker for tag [t] is ["<t>"] and closing marker is
    ["</t>"].

    Default tag-printing functions just do nothing.

    Tag-marking and tag-printing functions are user definable and can
    be set by calling {!set_formatter_tag_functions}.

    Semantic tag operations may be set on or off with {!set_tags}.
    Tag-marking operations may be set on or off with {!set_mark_tags}.
    Tag-printing operations may be set on or off with {!set_print_tags}.
*)

(** [pp_open_tag ppf t] opens the semantic tag named [t].

    The [print_open_tag] tag-printing function of the formatter is called with
    [t] as argument; then the opening tag marker for [t], as given by
    [mark_open_tag t], is written into the output device of the formatter.
*)
val pp_open_tag : formatter -> string -> unit

(** [pp_close_tag ppf ()] closes the most recently opened semantic tag [t].

    The closing tag marker, as given by [mark_close_tag t], is written into the
    output device of the formatter; then the [print_close_tag] tag-printing
    function of the formatter is called with [t] as argument.
*)
val pp_close_tag : formatter -> unit -> unit

(** [pp_set_tags ppf b] turns on or off the treatment of semantic tags
    (default is off).
*)
val pp_set_tags : formatter -> bool -> unit

(** [pp_set_print_tags ppf b] turns on or off the tag-printing operations. *)
val pp_set_print_tags : formatter -> bool -> unit

(** [pp_set_mark_tags ppf b] turns on or off the tag-marking operations. *)
val pp_set_mark_tags : formatter -> bool -> unit

(** Return the current status of tag-printing operations. *)
val pp_get_print_tags : formatter -> unit -> bool

(** Return the current status of tag-marking operations. *)
val pp_get_mark_tags : formatter -> unit -> bool

(** {1 Convenience formatting functions.} *)

(** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l],
    using [pp_v] to print each item, and calling [pp_sep]
    between items ([pp_sep] defaults to {!pp_print_cut}.
    Does nothing on empty lists.

    @since 4.02.0
*)
val pp_print_list :
  ?pp_sep:(formatter -> unit -> unit) ->
  (formatter -> 'a -> unit) ->
  formatter ->
  'a list ->
  unit

(** [pp_print_text ppf s] prints [s] with spaces and newlines respectively
    printed using {!pp_print_space} and {!pp_force_newline}.

    @since 4.02.0
*)
val pp_print_text : formatter -> string -> unit

(** {1:fpp Formatted pretty-printing} *)

(**
   Module [Format] provides a complete set of [printf] like functions for
   pretty-printing using format string specifications.

   Specific annotations may be added in the format strings to give
   pretty-printing commands to the pretty-printing engine.

   Those annotations are introduced in the format strings using the [@]
   character. For instance, [@ ] means a space break, [@,] means a cut,
   [@\[] opens a new box, and [@\]] closes the last open box.

*)

val fprintf : formatter -> ('a, formatter, unit) format -> 'a

(** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN]
    according to the format string [fmt], and outputs the resulting string on
    the formatter [ff].

    The format string [fmt] is a character string which contains three types of
    objects: plain characters and conversion specifications as specified in
    the {!Printf} module, and pretty-printing indications specific to the
    [Format] module.

    The pretty-printing indication characters are introduced by
    a [@] character, and their meanings are:
    - [@\[]: open a pretty-printing box. The type and offset of the
    box may be optionally specified with the following syntax:
    the [<] character, followed by an optional box type indication,
    then an optional integer offset, and the closing [>] character.
    Pretty-printing box type is one of [h], [v], [hv], [b], or [hov].
    '[h]' stands for an 'horizontal' pretty-printing box,
    '[v]' stands for a 'vertical' pretty-printing box,
    '[hv]' stands for an 'horizontal/vertical' pretty-printing box,
    '[b]' stands for an 'horizontal-or-vertical' pretty-printing box
    demonstrating indentation,
    '[hov]' stands a simple 'horizontal-or-vertical' pretty-printing box.
    For instance, [@\[<hov 2>] opens an 'horizontal-or-vertical'
    pretty-printing box with indentation 2 as obtained with [open_hovbox 2].
    For more details about pretty-printing boxes, see the various box opening
    functions [open_*box].
    - [@\]]: close the most recently opened pretty-printing box.
    - [@,]: output a 'cut' break hint, as with [print_cut ()].
    - [@ ]: output a 'space' break hint, as with [print_space ()].
    - [@;]: output a 'full' break hint as with [print_break]. The
    [nspaces] and [offset] parameters of the break hint may be
    optionally specified with the following syntax:
    the [<] character, followed by an integer [nspaces] value,
    then an integer [offset], and a closing [>] character.
    If no parameters are provided, the good break defaults to a
    'space' break hint.
    - [@.]: flush the pretty-printer and split the line, as with
    [print_newline ()].
    - [@<n>]: print the following item as if it were of length [n].
    Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string.
    If [@<n>] is not followed by a conversion specification,
    then the following character of the format is printed as if
    it were of length [n].
    - [@\{]: open a semantic tag. The name of the tag may be optionally
    specified with the following syntax:
    the [<] character, followed by an optional string
    specification, and the closing [>] character. The string
    specification is any character string that does not contain the
    closing character ['>']. If omitted, the tag name defaults to the
    empty string.
    For more details about semantic tags, see the functions {!open_tag} and
    {!close_tag}.
    - [@\}]: close the most recently opened semantic tag.
    - [@?]: flush the pretty-printer as with [print_flush ()].
    This is equivalent to the conversion [%!].
    - [@\n]: force a newline, as with [force_newline ()], not the normal way
    of pretty-printing, you should prefer using break hints inside a vertical
    pretty-printing box.

    Note: To prevent the interpretation of a [@] character as a
    pretty-printing indication, escape it with a [%] character.
    Old quotation mode [@@] is deprecated since it is not compatible with
    formatted input interpretation of character ['@'].

    Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to
    [open_box (); print_string "x ="; print_space ();
    print_int 1; close_box (); print_newline ()].
    It prints [x = 1] within a pretty-printing 'horizontal-or-vertical' box.

*)

(** Same as [printf] above, but instead of printing on a formatter,
    returns a string containing the result of formatting the arguments.
    Note that the pretty-printer queue is flushed at the end of {e each
    call} to [sprintf].

    In case of multiple and related calls to [sprintf] to output
    material on a single string, you should consider using [fprintf]
    with the predefined formatter [str_formatter] and call
    [flush_str_formatter ()] to get the final result.

    Alternatively, you can use [Format.fprintf] with a formatter writing to a
    buffer of your own: flushing the formatter and the buffer at the end of
    pretty-printing returns the desired string.
*)
val sprintf : ('a, unit, string) format -> 'a

(** Same as [printf] above, but instead of printing on a formatter,
    returns a string containing the result of formatting the arguments.
    The type of [asprintf] is general enough to interact nicely with [%a]
    conversions.

    @since 4.01.0
*)
val asprintf : ('a, formatter, unit, string) format4 -> 'a

(** Same as [fprintf] above, but does not print anything.
    Useful to ignore some material when conditionally printing.

    @since 3.10.0
*)
val ifprintf : formatter -> ('a, formatter, unit) format -> 'a

(** Formatted Pretty-Printing with continuations. *)

(** Same as [fprintf] above, but instead of returning immediately,
    passes the formatter to its first argument at the end of printing. *)
val kfprintf :
  (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b

(** Same as [kfprintf] above, but does not print anything.
    Useful to ignore some material when conditionally printing.

    @since 3.12.0
*)
val ikfprintf :
  (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b

(** Same as [sprintf] above, but instead of returning the string,
    passes it to the first argument. *)
val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b

(** Same as [asprintf] above, but instead of returning the string,
    passes it to the first argument.

    @since 4.03
*)
val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b
src/lib_protocol_environment/sigs/v1/format.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter formatter : Type.

Parameter pp_open_box : formatter -> Z -> unit.

Parameter pp_close_box : formatter -> unit -> unit.

Parameter pp_open_hbox : formatter -> unit -> unit.

Parameter pp_open_vbox : formatter -> Z -> unit.

Parameter pp_open_hvbox : formatter -> Z -> unit.

Parameter pp_open_hovbox : formatter -> Z -> unit.

Parameter pp_print_string : formatter -> string -> unit.

Parameter pp_print_as : formatter -> Z -> string -> unit.

Parameter pp_print_int : formatter -> Z -> unit.

Parameter pp_print_float : formatter -> float -> unit.

Parameter pp_print_char : formatter -> ascii -> unit.

Parameter pp_print_bool : formatter -> bool -> unit.

Parameter pp_print_space : formatter -> unit -> unit.

Parameter pp_print_cut : formatter -> unit -> unit.

Parameter pp_print_break : formatter -> Z -> Z -> unit.

Parameter pp_force_newline : formatter -> unit -> unit.

Parameter pp_print_if_newline : formatter -> unit -> unit.

Parameter pp_print_flush : formatter -> unit -> unit.

Parameter pp_print_newline : formatter -> unit -> unit.

Parameter pp_set_margin : formatter -> Z -> unit.

Parameter pp_get_margin : formatter -> unit -> Z.

Parameter pp_set_max_indent : formatter -> Z -> unit.

Parameter pp_get_max_indent : formatter -> unit -> Z.

Parameter pp_set_max_boxes : formatter -> Z -> unit.

Parameter pp_get_max_boxes : formatter -> unit -> Z.

Parameter pp_over_max_boxes : formatter -> unit -> bool.

Parameter pp_open_tbox : formatter -> unit -> unit.

Parameter pp_close_tbox : formatter -> unit -> unit.

Parameter pp_set_tab : formatter -> unit -> unit.

Parameter pp_print_tab : formatter -> unit -> unit.

Parameter pp_print_tbreak : formatter -> Z -> Z -> unit.

Parameter pp_set_ellipsis_text : formatter -> string -> unit.

Parameter pp_get_ellipsis_text : formatter -> unit -> string.

Definition tag := string.

Parameter pp_open_tag : formatter -> string -> unit.

Parameter pp_close_tag : formatter -> unit -> unit.

Parameter pp_set_tags : formatter -> bool -> unit.

Parameter pp_set_print_tags : formatter -> bool -> unit.

Parameter pp_set_mark_tags : formatter -> bool -> unit.

Parameter pp_get_print_tags : formatter -> unit -> bool.

Parameter pp_get_mark_tags : formatter -> unit -> bool.

Parameter pp_print_list : forall {a : Type},
(option (formatter -> unit -> unit)) ->
  (formatter -> a -> unit) -> formatter -> (list a) -> unit.

Parameter pp_print_text : formatter -> string -> unit.
src/lib_protocol_environment/sigs/v1/int32.mli 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* TEZOS CHANGES

   * Import version 4.06.1
   * Remove deprecated functions

*)

(** 32-bit integers.

    This module provides operations on the type [int32]
    of signed 32-bit integers.  Unlike the built-in [int] type,
    the type [int32] is guaranteed to be exactly 32-bit wide on all
    platforms.  All arithmetic operations over [int32] are taken
    modulo 2{^32}.

    Performance notice: values of type [int32] occupy more memory
    space than values of type [int], and arithmetic operations on
    [int32] are generally slower than those on [int].  Use [int32]
    only when the application requires exact 32-bit arithmetic. *)

(** The 32-bit integer 0. *)
val zero : int32

(** The 32-bit integer 1. *)
val one : int32

(** The 32-bit integer -1. *)
val minus_one : int32

(** Unary negation. *)
external neg : int32 -> int32 = "%int32_neg"

(** Addition. *)
external add : int32 -> int32 -> int32 = "%int32_add"

(** Subtraction. *)
external sub : int32 -> int32 -> int32 = "%int32_sub"

(** Multiplication. *)
external mul : int32 -> int32 -> int32 = "%int32_mul"

(** Integer division.  Raise [Division_by_zero] if the second
    argument is zero.  This division rounds the real quotient of
    its arguments towards zero, as specified for {!Pervasives.(/)}. *)
external div : int32 -> int32 -> int32 = "%int32_div"

(** Integer remainder.  If [y] is not zero, the result
    of [Int32.rem x y] satisfies the following property:
    [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)].
    If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *)
external rem : int32 -> int32 -> int32 = "%int32_mod"

(** Successor.  [Int32.succ x] is [Int32.add x Int32.one]. *)
val succ : int32 -> int32

(** Predecessor.  [Int32.pred x] is [Int32.sub x Int32.one]. *)
val pred : int32 -> int32

(** Return the absolute value of its argument. *)
val abs : int32 -> int32

(** The greatest representable 32-bit integer, 2{^31} - 1. *)
val max_int : int32

(** The smallest representable 32-bit integer, -2{^31}. *)
val min_int : int32

(** Bitwise logical and. *)
external logand : int32 -> int32 -> int32 = "%int32_and"

(** Bitwise logical or. *)
external logor : int32 -> int32 -> int32 = "%int32_or"

(** Bitwise logical exclusive or. *)
external logxor : int32 -> int32 -> int32 = "%int32_xor"

(** Bitwise logical negation. *)
val lognot : int32 -> int32

(** [Int32.shift_left x y] shifts [x] to the left by [y] bits.
    The result is unspecified if [y < 0] or [y >= 32]. *)
external shift_left : int32 -> int -> int32 = "%int32_lsl"

(** [Int32.shift_right x y] shifts [x] to the right by [y] bits.
    This is an arithmetic shift: the sign bit of [x] is replicated
    and inserted in the vacated bits.
    The result is unspecified if [y < 0] or [y >= 32]. *)
external shift_right : int32 -> int -> int32 = "%int32_asr"

(** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits.
    This is a logical shift: zeroes are inserted in the vacated bits
    regardless of the sign of [x].
    The result is unspecified if [y < 0] or [y >= 32]. *)
external shift_right_logical : int32 -> int -> int32 = "%int32_lsr"

(** Convert the given integer (type [int]) to a 32-bit integer
    (type [int32]). *)
external of_int : int -> int32 = "%int32_of_int"

(** Convert the given 32-bit integer (type [int32]) to an
    integer (type [int]).  On 32-bit platforms, the 32-bit integer
    is taken modulo 2{^31}, i.e. the high-order bit is lost
    during the conversion.  On 64-bit platforms, the conversion
    is exact. *)
external to_int : int32 -> int = "%int32_to_int"

(** Convert the given floating-point number to a 32-bit integer,
    discarding the fractional part (truncate towards 0).
    The result of the conversion is undefined if, after truncation,
    the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *)
external of_float : float -> int32
  = "caml_int32_of_float" "caml_int32_of_float_unboxed"
  [@@unboxed] [@@noalloc]

(** Convert the given 32-bit integer to a floating-point number. *)
external to_float : int32 -> float
  = "caml_int32_to_float" "caml_int32_to_float_unboxed"
  [@@unboxed] [@@noalloc]

(** Convert the given string to a 32-bit integer.
    The string is read in decimal (by default, or if the string
    begins with [0u]) or in hexadecimal, octal or binary if the
    string begins with [0x], [0o] or [0b] respectively.

    The [0u] prefix reads the input as an unsigned integer in the range
    [[0, 2*Int32.max_int+1]].  If the input exceeds {!Int32.max_int}
    it is converted to the signed integer
    [Int32.min_int + input - Int32.max_int - 1].

    The [_] (underscore) character can appear anywhere in the string
    and is ignored.
    Raise [Failure "Int32.of_string"] if the given string is not
    a valid representation of an integer, or if the integer represented
    exceeds the range of integers representable in type [int32]. *)
external of_string : string -> int32 = "caml_int32_of_string"

(** Same as [of_string], but return [None] instead of raising.
    @since 4.05 *)
val of_string_opt : string -> int32 option

(** Return the string representation of its argument, in signed decimal. *)
val to_string : int32 -> string

(** Return the internal representation of the given float according
    to the IEEE 754 floating-point 'single format' bit layout.
    Bit 31 of the result represents the sign of the float;
    bits 30 to 23 represent the (biased) exponent; bits 22 to 0
    represent the mantissa. *)
external bits_of_float : float -> int32
  = "caml_int32_bits_of_float" "caml_int32_bits_of_float_unboxed"
  [@@unboxed] [@@noalloc]

(** Return the floating-point number whose internal representation,
    according to the IEEE 754 floating-point 'single format' bit layout,
    is the given [int32]. *)
external float_of_bits : int32 -> float
  = "caml_int32_float_of_bits" "caml_int32_float_of_bits_unboxed"
  [@@unboxed] [@@noalloc]

(** An alias for the type of 32-bit integers. *)
type t = int32

(** The comparison function for 32-bit integers, with the same specification as
    {!Pervasives.compare}.  Along with the type [t], this function [compare]
    allows the module [Int32] to be passed as argument to the functors
    {!Set.Make} and {!Map.Make}. *)
val compare : t -> t -> int

(** The equal function for int32s.
    @since 4.03.0 *)
val equal : t -> t -> bool
src/lib_protocol_environment/sigs/v1/int32.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter zero : int32.

Parameter one : int32.

Parameter minus_one : int32.

Parameter neg : int32 -> int32.

Parameter add : int32 -> int32 -> int32.

Parameter sub : int32 -> int32 -> int32.

Parameter mul : int32 -> int32 -> int32.

Parameter div : int32 -> int32 -> int32.

Parameter rem : int32 -> int32 -> int32.

Parameter succ : int32 -> int32.

Parameter pred : int32 -> int32.

Parameter abs : int32 -> int32.

Parameter max_int : int32.

Parameter min_int : int32.

Parameter logand : int32 -> int32 -> int32.

Parameter logor : int32 -> int32 -> int32.

Parameter logxor : int32 -> int32 -> int32.

Parameter lognot : int32 -> int32.

Parameter shift_left : int32 -> Z -> int32.

Parameter shift_right : int32 -> Z -> int32.

Parameter shift_right_logical : int32 -> Z -> int32.

Parameter of_int : Z -> int32.

Parameter to_int : int32 -> Z.

Parameter of_float : float -> int32.

Parameter to_float : int32 -> float.

Parameter of_string : string -> int32.

Parameter of_string_opt : string -> option int32.

Parameter to_string : int32 -> string.

Parameter bits_of_float : float -> int32.

Parameter float_of_bits : int32 -> float.

Definition t := int32.

Parameter compare : t -> t -> Z.

Parameter equal : t -> t -> bool.
src/lib_protocol_environment/sigs/v1/int64.mli 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* TEZOS CHANGES

   * Import version 4.06.1
   * Remove deprecated functions

*)
(** 64-bit integers.

    This module provides operations on the type [int64] of
    signed 64-bit integers.  Unlike the built-in [int] type,
    the type [int64] is guaranteed to be exactly 64-bit wide on all
    platforms.  All arithmetic operations over [int64] are taken
    modulo 2{^64}

    Performance notice: values of type [int64] occupy more memory
    space than values of type [int], and arithmetic operations on
    [int64] are generally slower than those on [int].  Use [int64]
    only when the application requires exact 64-bit arithmetic.
*)

(** The 64-bit integer 0. *)
val zero : int64

(** The 64-bit integer 1. *)
val one : int64

(** The 64-bit integer -1. *)
val minus_one : int64

(** Unary negation. *)
external neg : int64 -> int64 = "%int64_neg"

(** Addition. *)
external add : int64 -> int64 -> int64 = "%int64_add"

(** Subtraction. *)
external sub : int64 -> int64 -> int64 = "%int64_sub"

(** Multiplication. *)
external mul : int64 -> int64 -> int64 = "%int64_mul"

(** Integer division.  Raise [Division_by_zero] if the second
    argument is zero.  This division rounds the real quotient of
    its arguments towards zero, as specified for {!Pervasives.(/)}. *)
external div : int64 -> int64 -> int64 = "%int64_div"

(** Integer remainder.  If [y] is not zero, the result
    of [Int64.rem x y] satisfies the following property:
    [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)].
    If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *)
external rem : int64 -> int64 -> int64 = "%int64_mod"

(** Successor.  [Int64.succ x] is [Int64.add x Int64.one]. *)
val succ : int64 -> int64

(** Predecessor.  [Int64.pred x] is [Int64.sub x Int64.one]. *)
val pred : int64 -> int64

(** Return the absolute value of its argument. *)
val abs : int64 -> int64

(** The greatest representable 64-bit integer, 2{^63} - 1. *)
val max_int : int64

(** The smallest representable 64-bit integer, -2{^63}. *)
val min_int : int64

(** Bitwise logical and. *)
external logand : int64 -> int64 -> int64 = "%int64_and"

(** Bitwise logical or. *)
external logor : int64 -> int64 -> int64 = "%int64_or"

(** Bitwise logical exclusive or. *)
external logxor : int64 -> int64 -> int64 = "%int64_xor"

(** Bitwise logical negation. *)
val lognot : int64 -> int64

(** [Int64.shift_left x y] shifts [x] to the left by [y] bits.
    The result is unspecified if [y < 0] or [y >= 64]. *)
external shift_left : int64 -> int -> int64 = "%int64_lsl"

(** [Int64.shift_right x y] shifts [x] to the right by [y] bits.
    This is an arithmetic shift: the sign bit of [x] is replicated
    and inserted in the vacated bits.
    The result is unspecified if [y < 0] or [y >= 64]. *)
external shift_right : int64 -> int -> int64 = "%int64_asr"

(** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits.
    This is a logical shift: zeroes are inserted in the vacated bits
    regardless of the sign of [x].
    The result is unspecified if [y < 0] or [y >= 64]. *)
external shift_right_logical : int64 -> int -> int64 = "%int64_lsr"

(** Convert the given integer (type [int]) to a 64-bit integer
    (type [int64]). *)
external of_int : int -> int64 = "%int64_of_int"

(** Convert the given 64-bit integer (type [int64]) to an
    integer (type [int]).  On 64-bit platforms, the 64-bit integer
    is taken modulo 2{^63}, i.e. the high-order bit is lost
    during the conversion.  On 32-bit platforms, the 64-bit integer
    is taken modulo 2{^31}, i.e. the top 33 bits are lost
    during the conversion. *)
external to_int : int64 -> int = "%int64_to_int"

(** Convert the given floating-point number to a 64-bit integer,
    discarding the fractional part (truncate towards 0).
    The result of the conversion is undefined if, after truncation,
    the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *)
external of_float : float -> int64
  = "caml_int64_of_float" "caml_int64_of_float_unboxed"
  [@@unboxed] [@@noalloc]

(** Convert the given 64-bit integer to a floating-point number. *)
external to_float : int64 -> float
  = "caml_int64_to_float" "caml_int64_to_float_unboxed"
  [@@unboxed] [@@noalloc]

(** Convert the given 32-bit integer (type [int32])
    to a 64-bit integer (type [int64]). *)
external of_int32 : int32 -> int64 = "%int64_of_int32"

(** Convert the given 64-bit integer (type [int64]) to a
    32-bit integer (type [int32]). The 64-bit integer
    is taken modulo 2{^32}, i.e. the top 32 bits are lost
    during the conversion.  *)
external to_int32 : int64 -> int32 = "%int64_to_int32"

(** Convert the given native integer (type [nativeint])
    to a 64-bit integer (type [int64]). *)
external of_nativeint : nativeint -> int64 = "%int64_of_nativeint"

(** Convert the given 64-bit integer (type [int64]) to a
    native integer.  On 32-bit platforms, the 64-bit integer
    is taken modulo 2{^32}.  On 64-bit platforms,
    the conversion is exact. *)
external to_nativeint : int64 -> nativeint = "%int64_to_nativeint"

(** Convert the given string to a 64-bit integer.
    The string is read in decimal (by default, or if the string
    begins with [0u]) or in hexadecimal, octal or binary if the
    string begins with [0x], [0o] or [0b] respectively.

    The [0u] prefix reads the input as an unsigned integer in the range
    [[0, 2*Int64.max_int+1]].  If the input exceeds {!Int64.max_int}
    it is converted to the signed integer
    [Int64.min_int + input - Int64.max_int - 1].

    The [_] (underscore) character can appear anywhere in the string
    and is ignored.
    Raise [Failure "Int64.of_string"] if the given string is not
    a valid representation of an integer, or if the integer represented
    exceeds the range of integers representable in type [int64]. *)
external of_string : string -> int64 = "caml_int64_of_string"

(** Same as [of_string], but return [None] instead of raising.
    @since 4.05 *)
val of_string_opt : string -> int64 option

(** Return the string representation of its argument, in decimal. *)
val to_string : int64 -> string

(** Return the internal representation of the given float according
    to the IEEE 754 floating-point 'double format' bit layout.
    Bit 63 of the result represents the sign of the float;
    bits 62 to 52 represent the (biased) exponent; bits 51 to 0
    represent the mantissa. *)
external bits_of_float : float -> int64
  = "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed"
  [@@unboxed] [@@noalloc]

(** Return the floating-point number whose internal representation,
    according to the IEEE 754 floating-point 'double format' bit layout,
    is the given [int64]. *)
external float_of_bits : int64 -> float
  = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
  [@@unboxed] [@@noalloc]

(** An alias for the type of 64-bit integers. *)
type t = int64

(** The comparison function for 64-bit integers, with the same specification as
    {!Pervasives.compare}.  Along with the type [t], this function [compare]
    allows the module [Int64] to be passed as argument to the functors
    {!Set.Make} and {!Map.Make}. *)
val compare : t -> t -> int

(** The equal function for int64s.
    @since 4.03.0 *)
val equal : t -> t -> bool
src/lib_protocol_environment/sigs/v1/int64.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter zero : int64.

Parameter one : int64.

Parameter minus_one : int64.

Parameter neg : int64 -> int64.

Parameter add : int64 -> int64 -> int64.

Parameter sub : int64 -> int64 -> int64.

Parameter mul : int64 -> int64 -> int64.

Parameter div : int64 -> int64 -> int64.

Parameter rem : int64 -> int64 -> int64.

Parameter succ : int64 -> int64.

Parameter pred : int64 -> int64.

Parameter abs : int64 -> int64.

Parameter max_int : int64.

Parameter min_int : int64.

Parameter logand : int64 -> int64 -> int64.

Parameter logor : int64 -> int64 -> int64.

Parameter logxor : int64 -> int64 -> int64.

Parameter lognot : int64 -> int64.

Parameter shift_left : int64 -> Z -> int64.

Parameter shift_right : int64 -> Z -> int64.

Parameter shift_right_logical : int64 -> Z -> int64.

Parameter of_int : Z -> int64.

Parameter to_int : int64 -> Z.

Parameter of_float : float -> int64.

Parameter to_float : int64 -> float.

Parameter of_int32 : int32 -> int64.

Parameter to_int32 : int64 -> int32.

Parameter of_nativeint : nativeint -> int64.

Parameter to_nativeint : int64 -> nativeint.

Parameter of_string : string -> int64.

Parameter of_string_opt : string -> option int64.

Parameter to_string : int64 -> string.

Parameter bits_of_float : float -> int64.

Parameter float_of_bits : int64 -> float.

Definition t := int64.

Parameter compare : t -> t -> Z.

Parameter equal : t -> t -> bool.
src/lib_protocol_environment/sigs/v1/json.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** In memory JSON data *)
type json =
  [ `O of (string * json) list
  | `Bool of bool
  | `Float of float
  | `A of json list
  | `Null
  | `String of string ]

(** Read a JSON document from a string. *)
val from_string : string -> (json, string) result

(** Write a JSON document to a string. This goes via an intermediate
    buffer and so may be slow on large documents. *)
val to_string : json -> string

(** Helpers for [Data_encoding] *)
val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a

val wrap_error : ('a -> 'b) -> 'a -> 'b
src/lib_protocol_environment/sigs/v1/json.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition json := variant.

Parameter to_string : json -> string.

Parameter wrap_error : forall {a b : Type}, (a -> b) -> a -> b.
src/lib_protocol_environment/sigs/v1/list.mli 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** List operations.

    Some functions are flagged as not tail-recursive.  A tail-recursive
    function uses constant stack space, while a non-tail-recursive function
    uses stack space proportional to the length of its list argument, which
    can be a problem with very long lists.  When the function takes several
    list arguments, an approximate formula giving stack usage (in some
    unspecified constant unit) is shown in parentheses.

    The above considerations can usually be ignored if your lists are not
    longer than about 10000 elements.
*)

(** Return the length (number of elements) of the given list. *)
val length : 'a list -> int

(** Compare the lengths of two lists. [compare_lengths l1 l2] is
    equivalent to [compare (length l1) (length l2)], except that
    the computation stops after itering on the shortest list.
    @since 4.05.0
*)
val compare_lengths : 'a list -> 'b list -> int

(** Compare the length of a list to an integer. [compare_length_with l n] is
    equivalent to [compare (length l) n], except that
    the computation stops after at most [n] iterations on the list.
    @since 4.05.0
*)
val compare_length_with : 'a list -> int -> int

(** [cons x xs] is [x :: xs]
    @since 4.03.0
*)
val cons : 'a -> 'a list -> 'a list

(** Return the first element of the given list. Raise
    [Failure "hd"] if the list is empty. *)
val hd : 'a list -> 'a

(** Return the given list without its first element. Raise
    [Failure "tl"] if the list is empty. *)
val tl : 'a list -> 'a list

(** Return the [n]-th element of the given list.
    The first element (head of the list) is at position 0.
    Return [None] if the list is too short.
    Raise [Invalid_argument "List.nth"] if [n] is negative.
    @since 4.05
*)
val nth_opt : 'a list -> int -> 'a option

(** List reversal. *)
val rev : 'a list -> 'a list

(** [List.init len f] is [f 0; f 1; ...; f (len-1)], evaluated left to right.

    @raise Invalid_argument if len < 0.
    @since 4.06.0
*)
val init : int -> (int -> 'a) -> 'a list

(** Concatenate two lists.  Same as the infix operator [@].
    Not tail-recursive (length of the first argument).  *)
val append : 'a list -> 'a list -> 'a list

(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2].
    This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is
    tail-recursive and more efficient. *)
val rev_append : 'a list -> 'a list -> 'a list

(** Concatenate a list of lists.  The elements of the argument are all
    concatenated together (in the same order) to give the result.
    Not tail-recursive
    (length of the argument + length of the longest sub-list). *)
val concat : 'a list list -> 'a list

(** An alias for [concat]. *)
val flatten : 'a list list -> 'a list

(** {1 Iterators} *)

(** [List.iter f [a1; ...; an]] applies function [f] in turn to
    [a1; ...; an]. It is equivalent to
    [begin f a1; f a2; ...; f an; () end]. *)
val iter : ('a -> unit) -> 'a list -> unit

(** Same as {!List.iter}, but the function is applied to the index of
    the element as first argument (counting from 0), and the element
    itself as second argument.
    @since 4.00.0
*)
val iteri : (int -> 'a -> unit) -> 'a list -> unit

(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
    and builds the list [[f a1; ...; f an]]
    with the results returned by [f].  Not tail-recursive. *)
val map : ('a -> 'b) -> 'a list -> 'b list

(** Same as {!List.map}, but the function is applied to the index of
    the element as first argument (counting from 0), and the element
    itself as second argument.  Not tail-recursive.
    @since 4.00.0
*)
val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list

(** [List.rev_map f l] gives the same result as
    {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and
    more efficient. *)
val rev_map : ('a -> 'b) -> 'a list -> 'b list

(** [List.fold_left f a [b1; ...; bn]] is
    [f (... (f (f a b1) b2) ...) bn]. *)
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a

(** [List.fold_right f [a1; ...; an] b] is
    [f a1 (f a2 (... (f an b) ...))].  Not tail-recursive. *)
val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b

(** {1 Iterators on two lists} *)

(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
    [f a1 b1; ...; f an bn].
    Raise [Invalid_argument] if the two lists are determined
    to have different lengths. *)
val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit

(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is
    [[f a1 b1; ...; f an bn]].
    Raise [Invalid_argument] if the two lists are determined
    to have different lengths.  Not tail-recursive. *)
val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list

(** [List.rev_map2 f l1 l2] gives the same result as
    {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and
    more efficient. *)
val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list

(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
    [f (... (f (f a b1 c1) b2 c2) ...) bn cn].
    Raise [Invalid_argument] if the two lists are determined
    to have different lengths. *)
val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a

(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
    [f a1 b1 (f a2 b2 (... (f an bn c) ...))].
    Raise [Invalid_argument] if the two lists are determined
    to have different lengths.  Not tail-recursive. *)
val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c

(** {1 List scanning} *)

(** [for_all p [a1; ...; an]] checks if all elements of the list
    satisfy the predicate [p]. That is, it returns
    [(p a1) && (p a2) && ... && (p an)]. *)
val for_all : ('a -> bool) -> 'a list -> bool

(** [exists p [a1; ...; an]] checks if at least one element of
    the list satisfies the predicate [p]. That is, it returns
    [(p a1) || (p a2) || ... || (p an)]. *)
val exists : ('a -> bool) -> 'a list -> bool

(** Same as {!List.for_all}, but for a two-argument predicate.
    Raise [Invalid_argument] if the two lists are determined
    to have different lengths. *)
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool

(** Same as {!List.exists}, but for a two-argument predicate.
    Raise [Invalid_argument] if the two lists are determined
    to have different lengths. *)
val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool

(** [mem a l] is true if and only if [a] is equal
    to an element of [l]. *)
val mem : 'a -> 'a list -> bool

(** Same as {!List.mem}, but uses physical equality instead of structural
    equality to compare list elements. *)
val memq : 'a -> 'a list -> bool

(** {1 List searching} *)

(** [find_opt p l] returns the first element of the list [l] that
    satisfies the predicate [p], or [None] if there is no value that
    satisfies [p] in the list [l].
    @since 4.05 *)
val find_opt : ('a -> bool) -> 'a list -> 'a option

(** [filter p l] returns all the elements of the list [l]
    that satisfy the predicate [p].  The order of the elements
    in the input list is preserved.  *)
val filter : ('a -> bool) -> 'a list -> 'a list

(** [find_all] is another name for {!List.filter}. *)
val find_all : ('a -> bool) -> 'a list -> 'a list

(** [partition p l] returns a pair of lists [(l1, l2)], where
    [l1] is the list of all the elements of [l] that
    satisfy the predicate [p], and [l2] is the list of all the
    elements of [l] that do not satisfy [p].
    The order of the elements in the input list is preserved. *)
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list

(** {1 Association lists} *)

(** [assoc_opt a l] returns the value associated with key [a] in the list of
    pairs [l]. That is,
    [assoc_opt a [ ...; (a,b); ...] = b]
    if [(a,b)] is the leftmost binding of [a] in list [l].
    Returns [None] if there is no value associated with [a] in the
    list [l].
    @since 4.05 *)
val assoc_opt : 'a -> ('a * 'b) list -> 'b option

(** Same as {!List.assoc_opt}, but uses physical equality instead of structural
    equality to compare keys.
    @since 4.05 *)
val assq_opt : 'a -> ('a * 'b) list -> 'b option

(** Same as {!List.assoc}, but simply return true if a binding exists,
    and false if no bindings exist for the given key. *)
val mem_assoc : 'a -> ('a * 'b) list -> bool

(** Same as {!List.mem_assoc}, but uses physical equality instead of
    structural equality to compare keys. *)
val mem_assq : 'a -> ('a * 'b) list -> bool

(** [remove_assoc a l] returns the list of
    pairs [l] without the first pair with key [a], if any.
    Not tail-recursive. *)
val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list

(** Same as {!List.remove_assoc}, but uses physical equality instead
    of structural equality to compare keys.  Not tail-recursive. *)
val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list

(** {1 Lists of pairs} *)

(** Transform a list of pairs into a pair of lists:
    [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])].
    Not tail-recursive.
*)
val split : ('a * 'b) list -> 'a list * 'b list

(** Transform a pair of lists into a list of pairs:
    [combine [a1; ...; an] [b1; ...; bn]] is
    [[(a1,b1); ...; (an,bn)]].
    Raise [Invalid_argument] if the two lists
    have different lengths.  Not tail-recursive. *)
val combine : 'a list -> 'b list -> ('a * 'b) list

(** {1 Sorting} *)

(** Sort a list in increasing order according to a comparison
    function.  The comparison function must return 0 if its arguments
    compare as equal, a positive integer if the first is greater,
    and a negative integer if the first is smaller (see Array.sort for
    a complete specification).  For example,
    {!Pervasives.compare} is a suitable comparison function.
    The resulting list is sorted in increasing order.
    [List.sort] is guaranteed to run in constant heap space
    (in addition to the size of the result list) and logarithmic
    stack space.

    The current implementation uses Merge Sort. It runs in constant
    heap space and logarithmic stack space.
*)
val sort : ('a -> 'a -> int) -> 'a list -> 'a list

(** Same as {!List.sort}, but the sorting algorithm is guaranteed to
    be stable (i.e. elements that compare equal are kept in their
    original order) .

    The current implementation uses Merge Sort. It runs in constant
    heap space and logarithmic stack space.
*)
val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list

(** Same as {!List.sort} or {!List.stable_sort}, whichever is faster
    on typical input. *)
val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list

(** Same as {!List.sort}, but also remove duplicates.
    @since 4.02.0 *)
val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list

(** Merge two lists:
    Assuming that [l1] and [l2] are sorted according to the
    comparison function [cmp], [merge cmp l1 l2] will return a
    sorted list containing all the elements of [l1] and [l2].
    If several elements compare equal, the elements of [l1] will be
    before the elements of [l2].
    Not tail-recursive (sum of the lengths of the arguments).
*)
val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
src/lib_protocol_environment/sigs/v1/list.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter length : forall {a : Type}, (list a) -> Z.

Parameter compare_lengths : forall {a b : Type}, (list a) -> (list b) -> Z.

Parameter compare_length_with : forall {a : Type}, (list a) -> Z -> Z.

Parameter cons : forall {a : Type}, a -> (list a) -> list a.

Parameter hd : forall {a : Type}, (list a) -> a.

Parameter tl : forall {a : Type}, (list a) -> list a.

Parameter nth_opt : forall {a : Type}, (list a) -> Z -> option a.

Parameter rev : forall {a : Type}, (list a) -> list a.

Parameter init : forall {a : Type}, Z -> (Z -> a) -> list a.

Parameter append : forall {a : Type}, (list a) -> (list a) -> list a.

Parameter rev_append : forall {a : Type}, (list a) -> (list a) -> list a.

Parameter concat : forall {a : Type}, (list (list a)) -> list a.

Parameter flatten : forall {a : Type}, (list (list a)) -> list a.

Parameter iter : forall {a : Type}, (a -> unit) -> (list a) -> unit.

Parameter iteri : forall {a : Type}, (Z -> a -> unit) -> (list a) -> unit.

Parameter map : forall {a b : Type}, (a -> b) -> (list a) -> list b.

Parameter mapi : forall {a b : Type}, (Z -> a -> b) -> (list a) -> list b.

Parameter rev_map : forall {a b : Type}, (a -> b) -> (list a) -> list b.

Parameter fold_left : forall {a b : Type}, (a -> b -> a) -> a -> (list b) -> a.

Parameter fold_right : forall {a b : Type}, (a -> b -> b) -> (list a) -> b -> b.

Parameter iter2 : forall {a b : Type},
(a -> b -> unit) -> (list a) -> (list b) -> unit.

Parameter map2 : forall {a b c : Type},
(a -> b -> c) -> (list a) -> (list b) -> list c.

Parameter rev_map2 : forall {a b c : Type},
(a -> b -> c) -> (list a) -> (list b) -> list c.

Parameter fold_left2 : forall {a b c : Type},
(a -> b -> c -> a) -> a -> (list b) -> (list c) -> a.

Parameter fold_right2 : forall {a b c : Type},
(a -> b -> c -> c) -> (list a) -> (list b) -> c -> c.

Parameter for_all : forall {a : Type}, (a -> bool) -> (list a) -> bool.

Parameter _exists : forall {a : Type}, (a -> bool) -> (list a) -> bool.

Parameter for_all2 : forall {a b : Type},
(a -> b -> bool) -> (list a) -> (list b) -> bool.

Parameter exists2 : forall {a b : Type},
(a -> b -> bool) -> (list a) -> (list b) -> bool.

Parameter mem : forall {a : Type}, a -> (list a) -> bool.

Parameter memq : forall {a : Type}, a -> (list a) -> bool.

Parameter find_opt : forall {a : Type}, (a -> bool) -> (list a) -> option a.

Parameter filter : forall {a : Type}, (a -> bool) -> (list a) -> list a.

Parameter find_all : forall {a : Type}, (a -> bool) -> (list a) -> list a.

Parameter partition : forall {a : Type},
(a -> bool) -> (list a) -> (list a) * (list a).

Parameter assoc_opt : forall {a b : Type}, a -> (list (a * b)) -> option b.

Parameter assq_opt : forall {a b : Type}, a -> (list (a * b)) -> option b.

Parameter mem_assoc : forall {a b : Type}, a -> (list (a * b)) -> bool.

Parameter mem_assq : forall {a b : Type}, a -> (list (a * b)) -> bool.

Parameter remove_assoc : forall {a b : Type},
a -> (list (a * b)) -> list (a * b).

Parameter remove_assq : forall {a b : Type},
a -> (list (a * b)) -> list (a * b).

Parameter split : forall {a b : Type}, (list (a * b)) -> (list a) * (list b).

Parameter combine : forall {a b : Type}, (list a) -> (list b) -> list (a * b).

Parameter sort : forall {a : Type}, (a -> a -> Z) -> (list a) -> list a.

Parameter stable_sort : forall {a : Type}, (a -> a -> Z) -> (list a) -> list a.

Parameter fast_sort : forall {a : Type}, (a -> a -> Z) -> (list a) -> list a.

Parameter sort_uniq : forall {a : Type}, (a -> a -> Z) -> (list a) -> list a.

Parameter merge : forall {a : Type},
(a -> a -> Z) -> (list a) -> (list a) -> list a.
src/lib_protocol_environment/sigs/v1/lwt.mli 
(* Lightweight thread library for OCaml
 * http://www.ocsigen.org/lwt
 * Interface Lwt
 * Copyright (C) 2005-2008 J�r�me Vouillon
 * Laboratoire PPS - CNRS Universit� Paris Diderot
 *               2009-2012 J�r�mie Dimino
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as
 * published by the Free Software Foundation, with linking exceptions;
 * either version 2.1 of the License, or (at your option) any later
 * version. See COPYING file for details.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 * 02111-1307, USA.
 *)

(* TEZOS CHANGES

   * import version 2.4.5
   * Comment a few function that shouldn't be used in the protocol:
     * choose: scheduling may be system dependent.
     * wait/wakeup
     * state
     * cancel
     * pause
     * async
     * thread storage
     * lwt exceptions
*)

(** Module [Lwt]: cooperative light-weight threads. *)

(** This module defines {e cooperative light-weight threads} with
    their primitives. A {e light-weight thread} represent a
    computation that may be not terminated, for example because it is
    waiting for some event to happen.

    Lwt threads are cooperative in the sense that switching to another
    thread is awlays explicit (with {!wakeup} or {!wakeup_exn}). When a
    thread is running, it executes as much as possible, and then
    returns (a value or an eror) or sleeps.

    Note that inside a Lwt thread, exceptions must be raised with
    {!fail} instead of [raise]. Also the [try ... with ...]
    construction will not catch Lwt errors. You must use {!catch}
    instead. You can also use {!wrap} for functions that may raise
    normal exception.

    Lwt also provides the syntax extension {!Pa_lwt} to make code
    using Lwt more readable.
*)

(** {2 Definitions and basics} *)

(** The type of threads returning a result of type ['a]. *)
type +'a t

(** [return e] is a thread whose return value is the value of the
    expression [e]. *)
val return : 'a -> 'a t

(* val fail : exn -> 'a t *)
(*   (\** [fail e] is a thread that fails with the exception [e]. *\) *)

(** [bind t f] is a thread which first waits for the thread [t] to
    terminate and then, if the thread succeeds, behaves as the
    application of function [f] to the return value of [t].  If the
    thread [t] fails, [bind t f] also fails, with the same
    exception.

    The expression [bind t (fun x -> t')] can intuitively be read as
    [let x = t in t'], and if you use the {e lwt.syntax} syntax
    extension, you can write a bind operation like that: [lwt x = t in t'].

    Note that [bind] is also often used just for synchronization
    purpose: [t'] will not execute before [t] is terminated.

    The result of a thread can be bound several time. *)
val bind : 'a t -> ('a -> 'b t) -> 'b t

(** [t >>= f] is an alternative notation for [bind t f]. *)
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t

(** [f =<< t] is [t >>= f] *)
val ( =<< ) : ('a -> 'b t) -> 'a t -> 'b t

(** [map f m] map the result of a thread. This is the same as [bind
    m (fun x -> return (f x))] *)
val map : ('a -> 'b) -> 'a t -> 'b t

(** [m >|= f] is [map f m] *)
val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t

(** [f =|< m] is [map f m] *)
val ( =|< ) : ('a -> 'b) -> 'a t -> 'b t

(** {3 Pre-allocated threads} *)

(** [return_unit = return ()] *)
val return_unit : unit t

(** [return_none = return None] *)
val return_none : 'a option t

(** [return_nil = return \[\]] *)
val return_nil : 'a list t

(** [return_true = return true] *)
val return_true : bool t

(** [return_false = return false] *)
val return_false : bool t

(* (\** {2 Thread storage} *\) *)

(* type 'a key *)
(*   (\** Type of a key. Keys are used to store local values into *)
(*       threads *\) *)

(* val new_key : unit -> 'a key *)
(*   (\** [new_key ()] creates a new key. *\) *)

(* val get : 'a key -> 'a option *)
(*   (\** [get key] returns the value associated with [key] in the current *)
(*       thread. *\) *)

(* val with_value : 'a key -> 'a option -> (unit -> 'b) -> 'b *)
(*   (\** [with_value key value f] executes [f] with [value] associated to *)
(*       [key]. The previous value associated to [key] is restored after *)
(*       [f] terminates. *\) *)

(* (\** {2 Exceptions handling} *\) *)

(* val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t *)
(*   (\** [catch t f] is a thread that behaves as the thread [t ()] if *)
(*       this thread succeeds.  If the thread [t ()] fails with some *)
(*       exception, [catch t f] behaves as the application of [f] to this *)
(*       exception. *\) *)

(* val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t *)
(*   (\** [try_bind t f g] behaves as [bind (t ()) f] if [t] does not *)
(*       fail.  Otherwise, it behaves as the application of [g] to the *)
(*       exception associated to [t ()]. *\) *)

(* val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t *)
(*   (\** [finalize f g] returns the same result as [f ()] whether it *)
(*       fails or not. In both cases, [g ()] is executed after [f]. *\) *)

(* val wrap : (unit -> 'a) -> 'a t *)
(*   (\** [wrap f] calls [f] and transform the result into a monad. If [f] *)
(*       raise an exception, it is catched by Lwt. *)

(*       This is actually the same as: *)

(*       {[ *)
(*         try *)
(*           return (f ()) *)
(*         with exn -> *)
(*           fail exn *)
(*       ]} *)
(*   *\) *)

(* val wrap1 : ('a -> 'b) -> 'a -> 'b t *)
(*   (\** [wrap1 f x] applies [f] on [x] and returns the result as a *)
(*       thread. If the application of [f] to [x] raise an exception it *)
(*       is catched and a thread is returned. *)

(*       Note that you must use {!wrap} instead of {!wrap1} if the *)
(*       evaluation of [x] may raise an exception. *)

(*       for example the following code is not ok: *)

(*       {[ *)
(*         wrap1 f (Hashtbl.find table key) *)
(*       ]} *)

(*       you should write instead: *)

(*       {[ *)
(*         wrap (fun () -> f (Hashtbl.find table key)) *)
(*       ]} *)
(*   *\) *)

(* val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t *)
(* val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t *)
(* val wrap4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e t *)
(* val wrap5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f t *)
(* val wrap6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g t *)
(* val wrap7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h t *)

(** {2 Multi-threads composition} *)

(* we shouldn't use choose: the scheduling may be system dependent *)

(* val choose : 'a t list -> 'a t *)
(*   (\** [choose l] behaves as the first thread in [l] to terminate.  If *)
(*       several threads are already terminated, one is choosen at *)
(*       random. *)

(*       Note: {!choose} leaves the local values of the current thread *)
(*       unchanged. *\) *)

(* val nchoose : 'a t list -> 'a list t *)
(*   (\** [nchoose l] returns the value of all that have succcessfully *)
(*       terminated. If all threads are sleeping, it waits for at least *)
(*       one to terminates. If one the threads of [l] fails, [nchoose] *)
(*       fails with the same exception. *)

(*       Note: {!nchoose} leaves the local values of the current thread *)
(*       unchanged. *\) *)

(* val nchoose_split : 'a t list -> ('a list * 'a t list) t *)
(*   (\** [nchoose_split l] does the same as {!nchoose} but also retrurns *)
(*       the list of threads that have not yet terminated. *\) *)

(** [join l] waits for all threads in [l] to terminate. If one of
    the threads fails, then [join l] will fails with the same
    exception as the first one to terminate.

    Note: {!join} leaves the local values of the current thread
    unchanged. *)
val join : unit t list -> unit t

(* val ( <?> ) : 'a t -> 'a t -> 'a t *)
(*   (\** [t <?> t'] is the same as [choose [t; t']] *\) *)

(** [t <&> t'] is the same as [join [t; t']] *)
val ( <&> ) : unit t -> unit t -> unit t

(* val async : (unit -> 'a t) -> unit *)
(*   (\** [async f] starts a thread without waiting for the result. If it *)
(*       fails (now or later), the exception is given to *)
(*       {!async_exception_hook}. *)

(*       You should use this function if you want to start a thread that *)
(*       might fail and don't care what its return value is, nor when it *)
(*       terminates (for instance, because it is looping). *\) *)

(* val ignore_result : 'a t -> unit *)
(*   (\** [ignore_result t] is like [Pervasives.ignore t] except that: *)

(*       - if [t] already failed, it raises the exception now, *)
(*       - if [t] is sleeping and fails later, the exception will be *)
(*         given to {!async_exception_hook}. *\) *)

(* val async_exception_hook : (exn -> unit) ref *)
(*   (\** Function called when a asynchronous exception is thrown. *)

(*       The default behavior is to print an error message with a *)
(*       backtrace if available and to exit the program. *)

(*       The behavior is undefined if this function raise an *)
(*       exception. *\) *)

(* (\** {2 Sleeping and resuming} *\) *)

(* type 'a u *)
(*   (\** The type of thread wakeners. *\) *)

(* val wait : unit -> 'a t * 'a u *)
(*   (\** [wait ()] is a pair of a thread which sleeps forever (unless it *)
(*       is resumed by one of the functions [wakeup], [wakeup_exn] below) *)
(*       and the corresponding wakener.  This thread does not block the *)
(*       execution of the remainder of the program (except of course, if *)
(*       another thread tries to wait for its termination). *\) *)

(* val wakeup : 'a u -> 'a -> unit *)
(*   (\** [wakeup t e] makes the sleeping thread [t] terminate and return *)
(*       the value of the expression [e]. *\) *)

(* val wakeup_exn : 'a u -> exn -> unit *)
(*   (\** [wakeup_exn t e] makes the sleeping thread [t] fail with the *)
(*       exception [e]. *\) *)

(* val wakeup_later : 'a u -> 'a -> unit *)
(*   (\** Same as {!wakeup} but it is not guaranteed that the thread will *)
(*       be woken up immediately. *\) *)

(* val wakeup_later_exn : 'a u -> exn -> unit *)
(*   (\** Same as {!wakeup_exn} but it is not guaranteed that the thread *)
(*       will be woken up immediately. *\) *)

(* val waiter_of_wakener : 'a u -> 'a t *)
(*   (\** Returns the thread associated to a wakener. *\) *)

(* type +'a result *)
(*   (\** Either a value of type ['a], either an exception. *\) *)

(* val make_value : 'a -> 'a result *)
(*   (\** [value x] creates a result containing the value [x]. *\) *)

(* val make_error : exn -> 'a result *)
(*   (\** [error e] creates a result containing the exception [e]. *\) *)

(* val of_result : 'a result -> 'a t *)
(*   (\** Returns a thread from a result. *\) *)

(* val wakeup_result : 'a u -> 'a result -> unit *)
(*   (\** [wakeup_result t r] makes the sleeping thread [t] terminate with *)
(*       the result [r]. *\) *)

(* val wakeup_later_result : 'a u -> 'a result -> unit *)
(*   (\** Same as {!wakeup_result} but it is not guaranteed that the *)
(*       thread will be woken up immediately. *\) *)

(* (\** {2 Threads state} *\) *)

(* (\** State of a thread *\) *)
(* type 'a state = *)
(*   | Return of 'a *)
(*       (\** The thread which has successfully terminated *\) *)
(*   | Fail of exn *)
(*       (\** The thread raised an exception *\) *)
(*   | Sleep *)
(*       (\** The thread is sleeping *\) *)

(* val state : 'a t -> 'a state *)
(*   (\** [state t] returns the state of a thread *\) *)

(* val is_sleeping : 'a t -> bool *)
(*   (\** [is_sleeping t] returns [true] iff [t] is sleeping. *\) *)

(* (\** {2 Cancelable threads} *\) *)

(* (\** Cancelable threads are the same as regular threads except that *)
(*     they can be canceled. *\) *)

(* exception Canceled *)
(*   (\** Canceled threads fails with this exception *\) *)

(* val task : unit -> 'a t * 'a u *)
(*   (\** [task ()] is the same as [wait ()] except that threads created *)
(*       with [task] can be canceled. *\) *)

(* val on_cancel : 'a t -> (unit -> unit) -> unit *)
(*   (\** [on_cancel t f] executes [f] when [t] is canceled. [f] will be *)
(*       executed before all other threads waiting on [t]. *)

(*       If [f] raises an exception it is given to *)
(*       {!async_exception_hook}. *\) *)

(* val add_task_r : 'a u Lwt_sequence.t -> 'a t *)
(*   (\** [add_task_r seq] creates a sleeping thread, adds its wakener to *)
(*       the right of [seq] and returns its waiter. When the thread is *)
(*       canceled, it is removed from [seq]. *\) *)

(* val add_task_l : 'a u Lwt_sequence.t -> 'a t *)
(*   (\** [add_task_l seq] creates a sleeping thread, adds its wakener to *)
(*       the left of [seq] and returns its waiter. When the thread is *)
(*       canceled, it is removed from [seq]. *\) *)

(* val cancel : 'a t -> unit *)
(*   (\** [cancel t] cancels the threads [t]. This means that the deepest *)
(*       sleeping thread created with [task] and connected to [t] is *)
(*       woken up with the exception {!Canceled}. *)

(*       For example, in the following code: *)

(*       {[ *)
(*         let waiter, wakener = task () in *)
(*         cancel (waiter >> printl "plop") *)
(*       ]} *)

(*       [waiter] will be woken up with {!Canceled}. *)
(*   *\) *)

(* val pick : 'a t list -> 'a t *)
(*   (\** [pick l] is the same as {!choose}, except that it cancels all *)
(*       sleeping threads when one terminates. *)

(*       Note: {!pick} leaves the local values of the current thread *)
(*       unchanged. *\) *)

(* val npick : 'a t list -> 'a list t *)
(*   (\** [npick l] is the same as {!nchoose}, except that it cancels all *)
(*       sleeping threads when one terminates. *)

(*       Note: {!npick} leaves the local values of the current thread *)
(*       unchanged. *\) *)

(* val protected : 'a t -> 'a t *)
(*   (\** [protected thread] creates a new cancelable thread which behave *)
(*       as [thread] except that cancelling it does not cancel *)
(*       [thread]. *\) *)

(* val no_cancel : 'a t -> 'a t *)
(*   (\** [no_cancel thread] creates a thread which behave as [thread] *)
(*       except that it cannot be canceled. *\) *)

(* (\** {2 Pause} *\) *)

(* val pause : unit -> unit t *)
(*   (\** [pause ()] is a sleeping thread which is wake up on the next *)
(*       call to {!wakeup_paused}. A thread created with [pause] can be *)
(*       canceled. *\) *)

(* val wakeup_paused : unit -> unit *)
(*   (\** [wakeup_paused ()] wakes up all threads which suspended *)
(*       themselves with {!pause}. *)

(*       This function is called by the scheduler, before entering the *)
(*       main loop. You usually do not have to call it directly, except *)
(*       if you are writing a custom scheduler. *)

(*       Note that if a paused thread resumes and pauses again, it will not *)
(*       be woken up at this point. *\) *)

(* val paused_count : unit -> int *)
(*   (\** [paused_count ()] returns the number of currently paused *)
(*       threads. *\) *)

(* val register_pause_notifier : (int -> unit) -> unit *)
(*   (\** [register_pause_notifier f] register a function [f] that will be *)
(*       called each time pause is called. The parameter passed to [f] is *)
(*       the new number of threads paused. It is usefull to be able to *)
(*       call {!wakeup_paused} when there is no scheduler *\) *)

(* (\** {2 Misc} *\) *)

(* val on_success : 'a t -> ('a -> unit) -> unit *)
(*   (\** [on_success t f] executes [f] when [t] terminates without *)
(*       failing. If [f] raises an exception it is given to *)
(*       {!async_exception_hook}. *\) *)

(* val on_failure : 'a t -> (exn -> unit) -> unit *)
(*   (\** [on_failure t f] executes [f] when [t] terminates and fails. If *)
(*       [f] raises an exception it is given to *)
(*       {!async_exception_hook}. *\) *)

(* val on_termination : 'a t -> (unit -> unit) -> unit *)
(*   (\** [on_termination t f] executes [f] when [t] terminates. If [f] *)
(*       raises an exception it is given to {!async_exception_hook}. *\) *)

(* val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit *)
(*   (\** [on_any t f g] executes [f] or [g] when [t] terminates. If [f] *)
(*       or [g] raises an exception it is given to *)
(*       {!async_exception_hook}. *\) *)

(* (\**/**\) *)

(* (\* The functions below are probably not useful for the casual user. *)
(*    They provide the basic primitives on which can be built multi- *)
(*    threaded libraries such as Lwt_unix. *\) *)

(* val poll : 'a t -> 'a option *)
(*       (\* [poll e] returns [Some v] if the thread [e] is terminated and *)
(*          returned the value [v].  If the thread failed with some *)
(*          exception, this exception is raised.  If the thread is still *)
(*          running, [poll e] returns [None] without blocking. *\) *)

(* val apply : ('a -> 'b t) -> 'a -> 'b t *)
(*       (\* [apply f e] apply the function [f] to the expression [e].  If *)
(*          an exception is raised during this application, it is caught *)
(*          and the resulting thread fails with this exception. *\) *)
(* (\* Q: Could be called 'glue' or 'trap' or something? *\) *)

(* val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t *)
(* val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t *)
(* val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t *)
(* val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t *)
src/lib_protocol_environment/sigs/v1/lwt.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (a : Type), Type.

Parameter _return : forall {a : Type}, a -> t a.

Parameter bind : forall {a b : Type}, (t a) -> (a -> t b) -> t b.

Parameter op_gt_gt_eq : forall {a b : Type}, (t a) -> (a -> t b) -> t b.

Parameter op_eq_lt_lt : forall {a b : Type}, (a -> t b) -> (t a) -> t b.

Parameter map : forall {a b : Type}, (a -> b) -> (t a) -> t b.

Parameter op_gt_pipe_eq : forall {a b : Type}, (t a) -> (a -> b) -> t b.

Parameter op_eq_pipe_lt : forall {a b : Type}, (a -> b) -> (t a) -> t b.

Parameter return_unit : t unit.

Parameter return_none : forall {a : Type}, t (option a).

Parameter return_nil : forall {a : Type}, t (list a).

Parameter return_true : t bool.

Parameter return_false : t bool.

Parameter join : (list (t unit)) -> t unit.

Parameter op_lt_and_gt : (t unit) -> (t unit) -> t unit.
src/lib_protocol_environment/sigs/v1/mBytes.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

val create : int -> t

val length : t -> int

val copy : t -> t

(** [sub src ofs len] extract a sub-array of [src] starting at [ofs]
    and of length [len]. No copying of elements is involved: the
    sub-array and the original array share the same storage space. *)
val sub : t -> int -> int -> t

(** [blit src ofs_src dst ofs_dst len] copy [len] bytes from [src]
    starting at [ofs_src] into [dst] starting at [ofs_dst]. *)
val blit : t -> int -> t -> int -> int -> unit

(** See [blit] *)
val blit_of_string : string -> int -> t -> int -> int -> unit

(** See [blit] *)
val blit_to_bytes : t -> int -> bytes -> int -> int -> unit

(** [of_string s] create an byte array filled with the same content than [s]. *)
val of_string : string -> t

(** [to_string b] dump the array content in a [string]. *)
val to_string : t -> string

(** [sub_string b ofs len] is equivalent to [to_string (sub b ofs len)]. *)
val sub_string : t -> int -> int -> string

(** Functions reading and writing bytes  *)

(** [get_char buff i] reads 1 byte at offset i as a char *)
val get_char : t -> int -> char

(** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
    bits. i.e. It returns a value between 0 and 2^8-1 *)
val get_uint8 : t -> int -> int

(** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
    bits. i.e. It returns a value between -2^7 and 2^7-1 *)
val get_int8 : t -> int -> int

(** [set_char buff i v] writes [v] to [buff] at offset [i] *)
val set_char : t -> int -> char -> unit

(** [set_int8 buff i v] writes the least significant 8 bits of [v]
    to [buff] at offset [i] *)
val set_int8 : t -> int -> int -> unit

(** Functions reading according to Big Endian byte order *)

(** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
      of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
val get_uint16 : t -> int -> int

(** [get_int16 buff i] reads 2 byte at offset i as a signed int of
      16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
val get_int16 : t -> int -> int

(** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
val get_int32 : t -> int -> int32

(** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
val get_int64 : t -> int -> int64

(** [set_int16 buff i v] writes the least significant 16 bits of [v]
      to [buff] at offset [i] *)
val set_int16 : t -> int -> int -> unit

(** [set_int32 buff i v] writes [v] to [buff] at offset [i] *)
val set_int32 : t -> int -> int32 -> unit

(** [set_int64 buff i v] writes [v] to [buff] at offset [i] *)
val set_int64 : t -> int -> int64 -> unit

module LE : sig
  (** Functions reading according to Little Endian byte order *)

  (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
      of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
  val get_uint16 : t -> int -> int

  (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
      16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
  val get_int16 : t -> int -> int

  (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
  val get_int32 : t -> int -> int32

  (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
  val get_int64 : t -> int -> int64

  (** [set_int16 buff i v] writes the least significant 16 bits of [v]
      to [buff] at offset [i] *)
  val set_int16 : t -> int -> int -> unit

  (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *)
  val set_int32 : t -> int -> int32 -> unit

  (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *)
  val set_int64 : t -> int -> int64 -> unit
end

val ( = ) : t -> t -> bool

val ( <> ) : t -> t -> bool

val ( < ) : t -> t -> bool

val ( <= ) : t -> t -> bool

val ( >= ) : t -> t -> bool

val ( > ) : t -> t -> bool

val compare : t -> t -> int

val concat : string -> t list -> t

val to_hex : t -> [`Hex of string]

val of_hex : [`Hex of string] -> t
src/lib_protocol_environment/sigs/v1/mBytes.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create : Z -> t.

Parameter length : t -> Z.

Parameter copy : t -> t.

Parameter sub : t -> Z -> Z -> t.

Parameter blit : t -> Z -> t -> Z -> Z -> unit.

Parameter blit_of_string : string -> Z -> t -> Z -> Z -> unit.

Parameter blit_to_bytes : t -> Z -> string -> Z -> Z -> unit.

Parameter of_string : string -> t.

Parameter to_string : t -> string.

Parameter sub_string : t -> Z -> Z -> string.

Parameter get_char : t -> Z -> ascii.

Parameter get_uint8 : t -> Z -> Z.

Parameter get_int8 : t -> Z -> Z.

Parameter set_char : t -> Z -> ascii -> unit.

Parameter set_int8 : t -> Z -> Z -> unit.

Parameter get_uint16 : t -> Z -> Z.

Parameter get_int16 : t -> Z -> Z.

Parameter get_int32 : t -> Z -> int32.

Parameter get_int64 : t -> Z -> int64.

Parameter set_int16 : t -> Z -> Z -> unit.

Parameter set_int32 : t -> Z -> int32 -> unit.

Parameter set_int64 : t -> Z -> int64 -> unit.

Module LE.
  Parameter get_uint16 : t -> Z -> Z.
  
  Parameter get_int16 : t -> Z -> Z.
  
  Parameter get_int32 : t -> Z -> int32.
  
  Parameter get_int64 : t -> Z -> int64.
  
  Parameter set_int16 : t -> Z -> Z -> unit.
  
  Parameter set_int32 : t -> Z -> int32 -> unit.
  
  Parameter set_int64 : t -> Z -> int64 -> unit.
End LE.

Parameter op_eq : t -> t -> bool.

Parameter op_lt_gt : t -> t -> bool.

Parameter op_lt : t -> t -> bool.

Parameter op_lt_eq : t -> t -> bool.

Parameter op_gt_eq : t -> t -> bool.

Parameter op_gt : t -> t -> bool.

Parameter compare : t -> t -> Z.

Parameter concat : string -> (list t) -> t.

Parameter to_hex : forall {variant : Type}, t -> variant.

Parameter of_hex : forall {variant : Type}, variant -> t.
src/lib_protocol_environment/sigs/v1/map.mli 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Association tables over ordered types.

    This module implements applicative association tables, also known as
    finite maps or dictionaries, given a total ordering function
    over the keys.
    All operations over maps are purely applicative (no side-effects).
    The implementation uses balanced binary trees, and therefore searching
    and insertion take time logarithmic in the size of the map.

    For instance:
    {[
      module IntPairs =
      struct
        type t = int * int
        let compare (x0,y0) (x1,y1) =
          match Pervasives.compare x0 x1 with
            0 -> Pervasives.compare y0 y1
          | c -> c
      end

      module PairsMap = Map.Make(IntPairs)

      let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world")
    ]}

    This creates a new module [PairsMap], with a new type ['a PairsMap.t]
    of maps from [int * int] to ['a]. In this example, [m] contains [string]
    values so its type is [string PairsMap.t].
*)

(** Input signature of the functor {!Map.Make}. *)
module type OrderedType = sig
  (** The type of the map keys. *)
  type t

  (** A total ordering function over the keys.
      This is a two-argument function [f] such that
      [f e1 e2] is zero if the keys [e1] and [e2] are equal,
      [f e1 e2] is strictly negative if [e1] is smaller than [e2],
      and [f e1 e2] is strictly positive if [e1] is greater than [e2].
      Example: a suitable ordering function is the generic structural
      comparison function {!Pervasives.compare}. *)
  val compare : t -> t -> int
end

(** Functor building an implementation of the map structure
    given a totally ordered type. *)
module Make (Ord : OrderedType) : S.MAP with type key = Ord.t
src/lib_protocol_environment/sigs/v1/map.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type
src/lib_protocol_environment/sigs/v1/micheline.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type annot = string list

type ('l, 'p) node =
  | Int of 'l * Z.t
  | String of 'l * string
  | Bytes of 'l * MBytes.t
  | Prim of 'l * 'p * ('l, 'p) node list * annot
  | Seq of 'l * ('l, 'p) node list

type 'p canonical

type canonical_location = int

val root : 'p canonical -> (canonical_location, 'p) node

val canonical_location_encoding : canonical_location Data_encoding.encoding

val canonical_encoding :
  variant:string ->
  'l Data_encoding.encoding ->
  'l canonical Data_encoding.encoding

val canonical_encoding_v1 :
  variant:string ->
  'l Data_encoding.encoding ->
  'l canonical Data_encoding.encoding

(*
val erased_encoding : variant:string -> 'l -> 'p Data_encoding.encoding -> ('l, 'p) node Data_encoding.encoding
val table_encoding : variant:string -> 'l Data_encoding.encoding -> 'p Data_encoding.encoding -> ('l, 'p) node Data_encoding.encoding
*)
val location : ('l, 'p) node -> 'l

val annotations : ('l, 'p) node -> string list

val strip_locations : (_, 'p) node -> 'p canonical

val extract_locations :
  ('l, 'p) node -> 'p canonical * (canonical_location * 'l) list

val inject_locations :
  (canonical_location -> 'l) -> 'p canonical -> ('l, 'p) node
src/lib_protocol_environment/sigs/v1/micheline.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition annot := list string.

Parameter canonical : forall (p : Type), Type.

Definition canonical_location := Z.
src/lib_protocol_environment/sigs/v1/option.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val map : f:('a -> 'b) -> 'a option -> 'b option

val apply : f:('a -> 'b option) -> 'a option -> 'b option

val iter : f:('a -> unit) -> 'a option -> unit

val unopt : default:'a -> 'a option -> 'a

val unopt_map : f:('a -> 'b) -> default:'b -> 'a option -> 'b

val first_some : 'a option -> 'a option -> 'a option

val try_with : (unit -> 'a) -> 'a option

val some : 'a -> 'a option
src/lib_protocol_environment/sigs/v1/option.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter map : forall {a b : Type}, (a -> b) -> (option a) -> option b.

Parameter apply : forall {a b : Type},
(a -> option b) -> (option a) -> option b.

Parameter iter : forall {a : Type}, (a -> unit) -> (option a) -> unit.

Parameter unopt : forall {a : Type}, a -> (option a) -> a.

Parameter unopt_map : forall {a b : Type}, (a -> b) -> b -> (option a) -> b.

Parameter first_some : forall {a : Type}, (option a) -> (option a) -> option a.

Parameter try_with : forall {a : Type}, (unit -> a) -> option a.

Parameter some : forall {a : Type}, a -> option a.
src/lib_protocol_environment/sigs/v1/pervasives.mli 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* TEZOS CHANGES

   * Import version 4.06.1
   * Remove [channel], [exit], ...
   * Remove polymorphic comparisons
   * Remove floating-point arithmetic
   * Remove string conversion functions for float
   * Remove deprecated functions

*)

(** The initially opened module.

    This module provides the basic operations over the built-in types
    (numbers, booleans, byte sequences, strings, exceptions, references,
    lists, arrays, input-output channels, ...).

    This module is automatically opened at the beginning of each compilation.
    All components of this module can therefore be referred by their short
    name, without prefixing them by [Pervasives].
*)

(** {1 Exceptions} *)

(** Raise the given exception value *)
external raise : exn -> 'a = "%raise"

(** A faster version [raise] which does not record the backtrace.
    @since 4.02.0
*)
external raise_notrace : exn -> 'a = "%raise_notrace"

(** Raise exception [Invalid_argument] with the given string. *)
val invalid_arg : string -> 'a

(** Raise exception [Failure] with the given string. *)
val failwith : string -> 'a

(** The [Exit] exception is not raised by any library function.  It is
    provided for use in your programs. *)
exception Exit

(** {1 Boolean operations} *)

(** The boolean negation. *)
external not : bool -> bool = "%boolnot"

(** The boolean 'and'. Evaluation is sequential, left-to-right:
    in [e1 && e2], [e1] is evaluated first, and if it returns [false],
    [e2] is not evaluated at all.
    Right-associative operator at precedence level 3/11. *)
external ( && ) : bool -> bool -> bool = "%sequand"

(** The boolean 'or'. Evaluation is sequential, left-to-right:
    in [e1 || e2], [e1] is evaluated first, and if it returns [true],
    [e2] is not evaluated at all.
    Right-associative operator at precedence level 2/11.
*)
external ( || ) : bool -> bool -> bool = "%sequor"

(** {1 Debugging} *)

(** [__LOC__] returns the location at which this expression appears in
    the file currently being parsed by the compiler, with the standard
    error format of OCaml: "File %S, line %d, characters %d-%d".
    @since 4.02.0
*)
external __LOC__ : string = "%loc_LOC"

(** [__FILE__] returns the name of the file currently being
    parsed by the compiler.
    @since 4.02.0
*)
external __FILE__ : string = "%loc_FILE"

(** [__LINE__] returns the line number at which this expression
    appears in the file currently being parsed by the compiler.
    @since 4.02.0
*)
external __LINE__ : int = "%loc_LINE"

(** [__MODULE__] returns the module name of the file being
    parsed by the compiler.
    @since 4.02.0
*)
external __MODULE__ : string = "%loc_MODULE"

(** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding
    to the location at which this expression appears in the file
    currently being parsed by the compiler. [file] is the current
    filename, [lnum] the line number, [cnum] the character position in
    the line and [enum] the last character position in the line.
    @since 4.02.0
*)
external __POS__ : string * int * int * int = "%loc_POS"

(** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the
    location of [expr] in the file currently being parsed by the
    compiler, with the standard error format of OCaml: "File %S, line
    %d, characters %d-%d".
    @since 4.02.0
*)
external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"

(** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the
    line number at which the expression [expr] appears in the file
    currently being parsed by the compiler.
    @since 4.02.0
*)
external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"

(** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a
    tuple [(file,lnum,cnum,enum)] corresponding to the location at
    which the expression [expr] appears in the file currently being
    parsed by the compiler. [file] is the current filename, [lnum] the
    line number, [cnum] the character position in the line and [enum]
    the last character position in the line.
    @since 4.02.0
*)
external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"

(** {1 Composition operators} *)

(** Reverse-application operator: [x |> f |> g] is exactly equivalent
    to [g (f (x))].
    Left-associative operator at precedence level 4/11.
    @since 4.01
*)
external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"

(** Application operator: [g @@ f @@ x] is exactly equivalent to
    [g (f (x))].
    Right-associative operator at precedence level 5/11.
    @since 4.01
*)
external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"

(** {1 Integer arithmetic} *)

(** Integers are 31 bits wide (or 63 bits on 64-bit processors).
    All operations are taken modulo 2{^31} (or 2{^63}).
    They do not fail on overflow. *)

(** Unary negation. You can also write [- e] instead of [~- e].
    Unary operator at precedence level 9/11 for [- e]
    and 11/11 for [~- e]. *)
external ( ~- ) : int -> int = "%negint"

(** Unary addition. You can also write [+ e] instead of [~+ e].
    Unary operator at precedence level 9/11 for [+ e]
    and 11/11 for [~+ e].
    @since 3.12.0
*)
external ( ~+ ) : int -> int = "%identity"

(** [succ x] is [x + 1]. *)
external succ : int -> int = "%succint"

(** [pred x] is [x - 1]. *)
external pred : int -> int = "%predint"

(** Integer addition.
    Left-associative operator at precedence level 6/11. *)
external ( + ) : int -> int -> int = "%addint"

(** Integer subtraction.
    Left-associative operator at precedence level 6/11. *)
external ( - ) : int -> int -> int = "%subint"

(** Integer multiplication.
    Left-associative operator at precedence level 7/11. *)
external ( * ) : int -> int -> int = "%mulint"

(** Integer division.
    Raise [Division_by_zero] if the second argument is 0.
    Integer division rounds the real quotient of its arguments towards zero.
    More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer
    less than or equal to the real quotient of [x] by [y].  Moreover,
    [(- x) / y = x / (- y) = - (x / y)].
    Left-associative operator at precedence level 7/11. *)
external ( / ) : int -> int -> int = "%divint"

(** Integer remainder.  If [y] is not zero, the result
    of [x mod y] satisfies the following properties:
    [x = (x / y) * y + x mod y] and
    [abs(x mod y) <= abs(y) - 1].
    If [y = 0], [x mod y] raises [Division_by_zero].
    Note that [x mod y] is negative only if [x < 0].
    Raise [Division_by_zero] if [y] is zero.
    Left-associative operator at precedence level 7/11. *)
external ( mod ) : int -> int -> int = "%modint"

(** Return the absolute value of the argument.  Note that this may be
    negative if the argument is [min_int]. *)
val abs : int -> int

(** The greatest representable integer. *)
val max_int : int

(** The smallest representable integer. *)
val min_int : int

(** {2 Bitwise operations} *)

(** Bitwise logical and.
    Left-associative operator at precedence level 7/11. *)
external ( land ) : int -> int -> int = "%andint"

(** Bitwise logical or.
    Left-associative operator at precedence level 7/11. *)
external ( lor ) : int -> int -> int = "%orint"

(** Bitwise logical exclusive or.
    Left-associative operator at precedence level 7/11. *)
external ( lxor ) : int -> int -> int = "%xorint"

(** Bitwise logical negation. *)
val lnot : int -> int

(** [n lsl m] shifts [n] to the left by [m] bits.
    The result is unspecified if [m < 0] or [m >= bitsize],
    where [bitsize] is [32] on a 32-bit platform and
    [64] on a 64-bit platform.
    Right-associative operator at precedence level 8/11. *)
external ( lsl ) : int -> int -> int = "%lslint"

(** [n lsr m] shifts [n] to the right by [m] bits.
    This is a logical shift: zeroes are inserted regardless of
    the sign of [n].
    The result is unspecified if [m < 0] or [m >= bitsize].
    Right-associative operator at precedence level 8/11. *)
external ( lsr ) : int -> int -> int = "%lsrint"

(** [n asr m] shifts [n] to the right by [m] bits.
    This is an arithmetic shift: the sign bit of [n] is replicated.
    The result is unspecified if [m < 0] or [m >= bitsize].
    Right-associative operator at precedence level 8/11. *)
external ( asr ) : int -> int -> int = "%asrint"

(** {1 String operations}

    More string operations are provided in module {!String}.
*)

(** String concatenation.
    Right-associative operator at precedence level 5/11. *)
val ( ^ ) : string -> string -> string

(** {1 Character operations}

    More character operations are provided in module {!Char}.
*)

(** Return the ASCII code of the argument. *)
external int_of_char : char -> int = "%identity"

(** Return the character with the given ASCII code.
    Raise [Invalid_argument "char_of_int"] if the argument is
    outside the range 0--255. *)
val char_of_int : int -> char

(** {1 Unit operations} *)

(** Discard the value of its argument and return [()].
    For instance, [ignore(f x)] discards the result of
    the side-effecting function [f].  It is equivalent to
    [f x; ()], except that the latter may generate a
    compiler warning; writing [ignore(f x)] instead
    avoids the warning. *)
external ignore : 'a -> unit = "%ignore"

(** {1 String conversion functions} *)

(** Return the string representation of a boolean. As the returned values
    may be shared, the user should not modify them directly.
*)
val string_of_bool : bool -> string

(** Convert the given string to a boolean.
    Return [None] if the string is not
    ["true"] or ["false"].
    @since 4.05
*)
val bool_of_string_opt : string -> bool option

(** Return the string representation of an integer, in decimal. *)
val string_of_int : int -> string

(** Convert the given string to an integer.
    The string is read in decimal (by default, or if the string
    begins with [0u]), in hexadecimal (if it begins with [0x] or
    [0X]), in octal (if it begins with [0o] or [0O]), or in binary
    (if it begins with [0b] or [0B]).

    The [0u] prefix reads the input as an unsigned integer in the range
    [[0, 2*max_int+1]].  If the input exceeds {!max_int}
    it is converted to the signed integer
    [min_int + input - max_int - 1].

    The [_] (underscore) character can appear anywhere in the string
    and is ignored.

    Return [None] if the given string is not a valid representation of
    an integer, or if the integer represented exceeds the range of
    integers representable in type [int].
    @since 4.05
*)
val int_of_string_opt : string -> int option

(** {1 Pair operations} *)

(** Return the first component of a pair. *)
external fst : 'a * 'b -> 'a = "%field0"

(** Return the second component of a pair. *)
external snd : 'a * 'b -> 'b = "%field1"

(** {1 List operations}

    More list operations are provided in module {!List}.
*)

(** List concatenation.  Not tail-recursive (length of the first argument).
    Right-associative operator at precedence level 5/11. *)
val ( @ ) : 'a list -> 'a list -> 'a list

(** {1 References} *)

(** The type of references (mutable indirection cells) containing
    a value of type ['a]. *)
type 'a ref = {mutable contents : 'a}

(** Return a fresh reference containing the given value. *)
external ref : 'a -> 'a ref = "%makemutable"

(** [!r] returns the current contents of reference [r].
    Equivalent to [fun r -> r.contents].
    Unary operator at precedence level 11/11.*)
external ( ! ) : 'a ref -> 'a = "%field0"

(** [r := a] stores the value of [a] in reference [r].
    Equivalent to [fun r v -> r.contents <- v].
    Right-associative operator at precedence level 1/11. *)
external ( := ) : 'a ref -> 'a -> unit = "%setfield0"

(** Increment the integer contained in the given reference.
    Equivalent to [fun r -> r := succ !r]. *)
external incr : int ref -> unit = "%incr"

(** Decrement the integer contained in the given reference.
    Equivalent to [fun r -> r := pred !r]. *)
external decr : int ref -> unit = "%decr"

(** {1 Result type} *)

(** @since 4.03.0 *)
type ('a, 'b) result = Ok of 'a | Error of 'b

(** {1 Operations on format strings} *)

(** Format strings are character strings with special lexical conventions
    that defines the functionality of formatted input/output functions. Format
    strings are used to read data with formatted input functions from module
    {!Scanf} and to print data with formatted output functions from modules
    {!Printf} and {!Format}.

    Format strings are made of three kinds of entities:
    - {e conversions specifications}, introduced by the special character ['%']
    followed by one or more characters specifying what kind of argument to
    read or print,
    - {e formatting indications}, introduced by the special character ['@']
    followed by one or more characters specifying how to read or print the
    argument,
    - {e plain characters} that are regular characters with usual lexical
    conventions. Plain characters specify string literals to be read in the
    input or printed in the output.

    There is an additional lexical rule to escape the special characters ['%']
    and ['@'] in format strings: if a special character follows a ['%']
    character, it is treated as a plain character. In other words, ["%%"] is
    considered as a plain ['%'] and ["%@"] as a plain ['@'].

    For more information about conversion specifications and formatting
    indications available, read the documentation of modules {!Scanf},
    {!Printf} and {!Format}.
*)

(** Format strings have a general and highly polymorphic type
    [('a, 'b, 'c, 'd, 'e, 'f) format6].
    The two simplified types, [format] and [format4] below are
    included for backward compatibility with earlier releases of
    OCaml.

    The meaning of format string type parameters is as follows:

    - ['a] is the type of the parameters of the format for formatted output
      functions ([printf]-style functions);
      ['a] is the type of the values read by the format for formatted input
      functions ([scanf]-style functions).

    - ['b] is the type of input source for formatted input functions and the
      type of output target for formatted output functions.
      For [printf]-style functions from module {!Printf}, ['b] is typically
      [out_channel];
      for [printf]-style functions from module {!Format}, ['b] is typically
      {!Format.formatter};
      for [scanf]-style functions from module {!Scanf}, ['b] is typically
      {!Scanf.Scanning.in_channel}.

      Type argument ['b] is also the type of the first argument given to
      user's defined printing functions for [%a] and [%t] conversions,
      and user's defined reading functions for [%r] conversion.

    - ['c] is the type of the result of the [%a] and [%t] printing
      functions, and also the type of the argument transmitted to the
      first argument of [kprintf]-style functions or to the
      [kscanf]-style functions.

    - ['d] is the type of parameters for the [scanf]-style functions.

    - ['e] is the type of the receiver function for the [scanf]-style functions.

    - ['f] is the final result type of a formatted input/output function
      invocation: for the [printf]-style functions, it is typically [unit];
      for the [scanf]-style functions, it is typically the result type of the
      receiver function.
*)

type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6

type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6

type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4

(** Converts a format string into a string. *)
val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string

(** [format_of_string s] returns a format string read from the string
    literal [s].
    Note: [format_of_string] can not convert a string argument that is not a
    literal. If you need this functionality, use the more general
    {!Scanf.format_from_string} function.
*)
external format_of_string :
  ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6
  = "%identity"

(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
    format string that behaves as the concatenation of format strings [f1] and
    [f2]: in case of formatted output, it accepts arguments from [f1], then
    arguments from [f2]; in case of formatted input, it returns results from
    [f1], then results from [f2].
    Right-associative operator at precedence level 5/11. *)
val ( ^^ ) :
  ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
  ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
  ('a, 'b, 'c, 'd, 'g, 'h) format6
src/lib_protocol_environment/sigs/v1/pervasives.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter raise : forall {a : Type}, exn -> a.

Parameter raise_notrace : forall {a : Type}, exn -> a.

Parameter invalid_arg : forall {a : Type}, string -> a.

Parameter failwith : forall {a : Type}, string -> a.

exception

Parameter not : bool -> bool.

Parameter op_and_and : bool -> bool -> bool.

Parameter op_pipe_pipe : bool -> bool -> bool.

Parameter __LOC__ : string.

Parameter __FILE__ : string.

Parameter __LINE__ : Z.

Parameter __MODULE__ : string.

Parameter __POS__ : string * Z * Z * Z.

Parameter __LOC_OF__ : forall {a : Type}, a -> string * a.

Parameter __LINE_OF__ : forall {a : Type}, a -> Z * a.

Parameter __POS_OF__ : forall {a : Type}, a -> (string * Z * Z * Z) * a.

Parameter op_pipe_gt : forall {a b : Type}, a -> (a -> b) -> b.

Parameter op_at_at : forall {a b : Type}, (a -> b) -> a -> b.

Parameter op_tilde_minus : Z -> Z.

Parameter op_tilde_plus : Z -> Z.

Parameter succ : Z -> Z.

Parameter pred : Z -> Z.

Parameter op_plus : Z -> Z -> Z.

Parameter op_minus : Z -> Z -> Z.

Parameter op_star : Z -> Z -> Z.

Parameter op_div : Z -> Z -> Z.

Parameter mod : Z -> Z -> Z.

Parameter abs : Z -> Z.

Parameter max_int : Z.

Parameter min_int : Z.

Parameter land : Z -> Z -> Z.

Parameter lor : Z -> Z -> Z.

Parameter lxor : Z -> Z -> Z.

Parameter lnot : Z -> Z.

Parameter lsl : Z -> Z -> Z.

Parameter lsr : Z -> Z -> Z.

Parameter asr : Z -> Z -> Z.

Parameter op_caret : string -> string -> string.

Parameter int_of_char : ascii -> Z.

Parameter char_of_int : Z -> ascii.

Parameter ignore : forall {a : Type}, a -> unit.

Parameter string_of_bool : bool -> string.

Parameter bool_of_string_opt : string -> option bool.

Parameter string_of_int : Z -> string.

Parameter int_of_string_opt : string -> option Z.

Parameter fst : forall {a b : Type}, (a * b) -> a.

Parameter snd : forall {a b : Type}, (a * b) -> b.

Parameter op_at : forall {a : Type}, (list a) -> (list a) -> list a.

Record ref {a : Type} := {
  contents : a }.
Arguments ref : clear implicits.

Parameter ref : forall {a : Type}, a -> ref a.

Parameter op_exclamation : forall {a : Type}, (ref a) -> a.

Parameter op_colon_eq : forall {a : Type}, (ref a) -> a -> unit.

Parameter incr : (ref Z) -> unit.

Parameter decr : (ref Z) -> unit.

Inductive result (a b : Type) : Type :=
| Ok : a -> result a b
| Error : b -> result a b.

Arguments Ok {_ _}.
Arguments Error {_ _}.

Definition format6 (a b c d e f : Type) :=
  CamlinternalFormatBasics.format6 a b c d e f.

Definition format4 (a b c d : Type) := format6 a b c c c d.

Definition format (a b c : Type) := format4 a b c c.

Parameter string_of_format : forall {a b c d e f : Type},
(format6 a b c d e f) -> string.

Parameter format_of_string : forall {a b c d e f : Type},
(format6 a b c d e f) -> format6 a b c d e f.

Parameter op_caret_caret : forall {a b c d e f g h : Type},
(format6 a b c d e f) -> (format6 f b c e g h) -> format6 a b c d g h.
src/lib_protocol_environment/sigs/v1/protocol.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {expected_env : env_version; components : component list}

(** An OCaml source component of a protocol implementation. *)
and component = {
  (* The OCaml module name. *)
  name : string;
  (* The OCaml interface source code *)
  interface : string option;
  (* The OCaml source code *)
  implementation : string;
}

and env_version = V1

val component_encoding : component Data_encoding.t

val env_version_encoding : env_version Data_encoding.t

include S.HASHABLE with type t := t and type hash := Protocol_hash.t
src/lib_protocol_environment/sigs/v1/protocol.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive env_version : Type :=
| V1 : env_version.
src/lib_protocol_environment/sigs/v1/s.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Generic interface for a datatype with comparison, pretty-printer
    and serialization functions. *)
module type T = sig
  type t

  include Compare.S with type t := t

  val pp : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t

  val to_bytes : t -> MBytes.t

  val of_bytes : MBytes.t -> t option
end

(** Generic interface for a datatype with comparison, pretty-printer,
    serialization functions and a hashing function. *)
module type HASHABLE = sig
  include T

  type hash

  val hash : t -> hash

  val hash_raw : MBytes.t -> hash
end

(** {2 Hash Types} *)

(** The signature of an abstract hash type, as produced by functor
    {!Make_SHA256}. The {!t} type is abstracted for separating the
    various kinds of hashes in the system at typing time. Each type is
    equipped with functions to use it as is of as keys in the database
    or in memory sets and maps. *)

module type MINIMAL_HASH = sig
  type t

  val name : string

  val title : string

  val pp : Format.formatter -> t -> unit

  val pp_short : Format.formatter -> t -> unit

  include Compare.S with type t := t

  val hash_bytes : ?key:MBytes.t -> MBytes.t list -> t

  val hash_string : ?key:string -> string list -> t

  val zero : t
end

module type RAW_DATA = sig
  type t

  val size : int (* in bytes *)

  val to_bytes : t -> MBytes.t

  val of_bytes_opt : MBytes.t -> t option

  val of_bytes_exn : MBytes.t -> t
end

module type B58_DATA = sig
  type t

  val to_b58check : t -> string

  val to_short_b58check : t -> string

  val of_b58check_exn : string -> t

  val of_b58check_opt : string -> t option

  type Base58.data += Data of t

  val b58check_encoding : t Base58.encoding
end

module type ENCODER = sig
  type t

  val encoding : t Data_encoding.t

  val rpc_arg : t RPC_arg.t
end

module type SET = sig
  type elt

  type t

  val empty : t

  val is_empty : t -> bool

  val mem : elt -> t -> bool

  val add : elt -> t -> t

  val singleton : elt -> t

  val remove : elt -> t -> t

  val union : t -> t -> t

  val inter : t -> t -> t

  val diff : t -> t -> t

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val subset : t -> t -> bool

  val iter : (elt -> unit) -> t -> unit

  val map : (elt -> elt) -> t -> t

  val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a

  val for_all : (elt -> bool) -> t -> bool

  val exists : (elt -> bool) -> t -> bool

  val filter : (elt -> bool) -> t -> t

  val partition : (elt -> bool) -> t -> t * t

  val cardinal : t -> int

  val elements : t -> elt list

  val min_elt_opt : t -> elt option

  val max_elt_opt : t -> elt option

  val choose_opt : t -> elt option

  val split : elt -> t -> t * bool * t

  val find_opt : elt -> t -> elt option

  val find_first_opt : (elt -> bool) -> t -> elt option

  val find_last_opt : (elt -> bool) -> t -> elt option

  val of_list : elt list -> t
end

module type MAP = sig
  type key

  type +'a t

  val empty : 'a t

  val is_empty : 'a t -> bool

  val mem : key -> 'a t -> bool

  val add : key -> 'a -> 'a t -> 'a t

  val update : key -> ('a option -> 'a option) -> 'a t -> 'a t

  val singleton : key -> 'a -> 'a t

  val remove : key -> 'a t -> 'a t

  val merge :
    (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t

  val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t

  val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int

  val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool

  val iter : (key -> 'a -> unit) -> 'a t -> unit

  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val for_all : (key -> 'a -> bool) -> 'a t -> bool

  val exists : (key -> 'a -> bool) -> 'a t -> bool

  val filter : (key -> 'a -> bool) -> 'a t -> 'a t

  val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t

  val cardinal : 'a t -> int

  val bindings : 'a t -> (key * 'a) list

  val min_binding_opt : 'a t -> (key * 'a) option

  val max_binding_opt : 'a t -> (key * 'a) option

  val choose_opt : 'a t -> (key * 'a) option

  val split : key -> 'a t -> 'a t * 'a option * 'a t

  val find_opt : key -> 'a t -> 'a option

  val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option

  val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option

  val map : ('a -> 'b) -> 'a t -> 'b t

  val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
end

module type INDEXES = sig
  type t

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  val of_path_exn : string list -> t

  val prefix_path : string -> string list

  val path_length : int

  module Set : sig
    include Stdlib.Set.S with type elt = t

    val encoding : t Data_encoding.t
  end

  module Map : sig
    include Stdlib.Map.S with type key = t

    val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
  end
end

module type HASH = sig
  include MINIMAL_HASH

  include RAW_DATA with type t := t

  include B58_DATA with type t := t

  include ENCODER with type t := t

  include INDEXES with type t := t
end

module type MERKLE_TREE = sig
  type elt

  include HASH

  val compute : elt list -> t

  val empty : t

  type path = Left of path * t | Right of t * path | Op

  val compute_path : elt list -> int -> path

  val check_path : path -> elt -> t * int

  val path_encoding : path Data_encoding.t
end

module type SIGNATURE = sig
  module Public_key_hash : sig
    type t

    val pp : Format.formatter -> t -> unit

    val pp_short : Format.formatter -> t -> unit

    include Compare.S with type t := t

    include RAW_DATA with type t := t

    include B58_DATA with type t := t

    include ENCODER with type t := t

    include INDEXES with type t := t

    val zero : t
  end

  module Public_key : sig
    type t

    val pp : Format.formatter -> t -> unit

    include Compare.S with type t := t

    include B58_DATA with type t := t

    include ENCODER with type t := t

    val hash : t -> Public_key_hash.t
  end

  type t

  val pp : Format.formatter -> t -> unit

  include RAW_DATA with type t := t

  include Compare.S with type t := t

  include B58_DATA with type t := t

  include ENCODER with type t := t

  val zero : t

  type watermark

  (** Check a signature *)
  val check : ?watermark:watermark -> Public_key.t -> t -> MBytes.t -> bool
end
src/lib_protocol_environment/sigs/v1/s.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

module_type

module_type

module_type

module_type

module_type

module_type

module_type

module_type

module_type

module_type
src/lib_protocol_environment/sigs/v1/set.mli 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Sets over ordered types.

    This module implements the set data structure, given a total ordering
    function over the set elements. All operations over sets
    are purely applicative (no side-effects).
    The implementation uses balanced binary trees, and is therefore
    reasonably efficient: insertion and membership take time
    logarithmic in the size of the set, for instance.

    The {!Make} functor constructs implementations for any type, given a
    [compare] function.
    For instance:
    {[
      module IntPairs =
      struct
        type t = int * int
        let compare (x0,y0) (x1,y1) =
          match Pervasives.compare x0 x1 with
            0 -> Pervasives.compare y0 y1
          | c -> c
      end

      module PairsSet = Set.Make(IntPairs)

      let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13))
    ]}

    This creates a new module [PairsSet], with a new type [PairsSet.t]
    of sets of [int * int].
*)

(** Input signature of the functor {!Set.Make}. *)
module type OrderedType = sig
  (** The type of the set elements. *)
  type t

  (** A total ordering function over the set elements.
      This is a two-argument function [f] such that
      [f e1 e2] is zero if the elements [e1] and [e2] are equal,
      [f e1 e2] is strictly negative if [e1] is smaller than [e2],
      and [f e1 e2] is strictly positive if [e1] is greater than [e2].
      Example: a suitable ordering function is the generic structural
      comparison function {!Pervasives.compare}. *)
  val compare : t -> t -> int
end

(** Functor building an implementation of the set structure
    given a totally ordered type. *)
module Make (Ord : OrderedType) : S.SET with type elt = Ord.t
src/lib_protocol_environment/sigs/v1/set.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type
src/lib_protocol_environment/sigs/v1/string.mli 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* TEZOS CHANGES

   * Import version 4.06.1
   * Remove unsafe functions
   * Remove deprecated functions (enforcing string immutability)
   * Add binary data extraction functions

*)

(** String operations.

    A string is an immutable data structure that contains a
    fixed-length sequence of (single-byte) characters. Each character
    can be accessed in constant time through its index.

    Given a string [s] of length [l], we can access each of the [l]
    characters of [s] via its index in the sequence. Indexes start at
    [0], and we will call an index valid in [s] if it falls within the
    range [[0...l-1]] (inclusive). A position is the point between two
    characters or at the beginning or end of the string.  We call a
    position valid in [s] if it falls within the range [[0...l]]
    (inclusive). Note that the character at index [n] is between
    positions [n] and [n+1].

    Two parameters [start] and [len] are said to designate a valid
    substring of [s] if [len >= 0] and [start] and [start+len] are
    valid positions in [s].

    OCaml strings used to be modifiable in place, for instance via the
    {!String.set} and {!String.blit} functions described below. This
    usage is deprecated and only possible when the compiler is put in
    "unsafe-string" mode by giving the [-unsafe-string] command-line
    option (which is currently the default for reasons of backward
    compatibility). This is done by making the types [string] and
    [bytes] (see module {!Bytes}) interchangeable so that functions
    expecting byte sequences can also accept strings as arguments and
    modify them.

    All new code should avoid this feature and be compiled with the
    [-safe-string] command-line option to enforce the separation between
    the types [string] and [bytes].

*)

(** Return the length (number of characters) of the given string. *)
external length : string -> int = "%string_length"

(** [String.get s n] returns the character at index [n] in string [s].
    You can also write [s.[n]] instead of [String.get s n].

    Raise [Invalid_argument] if [n] not a valid index in [s]. *)
external get : string -> int -> char = "%string_safe_get"

(** [String.make n c] returns a fresh string of length [n],
    filled with the character [c].

    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
val make : int -> char -> string

(** [String.init n f] returns a string of length [n], with character
    [i] initialized to the result of [f i] (called in increasing
    index order).

    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.

    @since 4.02.0
*)
val init : int -> (int -> char) -> string

(** [String.sub s start len] returns a fresh string of length [len],
    containing the substring of [s] that starts at position [start] and
    has length [len].

    Raise [Invalid_argument] if [start] and [len] do not
    designate a valid substring of [s]. *)
val sub : string -> int -> int -> string

(** Same as {!Bytes.blit_string}. *)
val blit : string -> int -> bytes -> int -> int -> unit

(** [String.concat sep sl] concatenates the list of strings [sl],
    inserting the separator string [sep] between each.

    Raise [Invalid_argument] if the result is longer than
    {!Sys.max_string_length} bytes. *)
val concat : string -> string list -> string

(** [String.iter f s] applies function [f] in turn to all
    the characters of [s].  It is equivalent to
    [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *)
val iter : (char -> unit) -> string -> unit

(** Same as {!String.iter}, but the
    function is applied to the index of the element as first argument
    (counting from 0), and the character itself as second argument.
    @since 4.00.0 *)
val iteri : (int -> char -> unit) -> string -> unit

(** [String.map f s] applies function [f] in turn to all the
    characters of [s] (in increasing index order) and stores the
    results in a new string that is returned.
    @since 4.00.0 *)
val map : (char -> char) -> string -> string

(** [String.mapi f s] calls [f] with each character of [s] and its
    index (in increasing index order) and stores the results in a new
    string that is returned.
    @since 4.02.0 *)
val mapi : (int -> char -> char) -> string -> string

(** Return a copy of the argument, without leading and trailing
    whitespace.  The characters regarded as whitespace are: [' '],
    ['\012'], ['\n'], ['\r'], and ['\t'].  If there is neither leading nor
    trailing whitespace character in the argument, return the original
    string itself, not a copy.
    @since 4.00.0 *)
val trim : string -> string

(** Return a copy of the argument, with special characters
    represented by escape sequences, following the lexical
    conventions of OCaml.
    All characters outside the ASCII printable range (32..126) are
    escaped, as well as backslash and double-quote.

    If there is no special character in the argument that needs
    escaping, return the original string itself, not a copy.

    Raise [Invalid_argument] if the result is longer than
    {!Sys.max_string_length} bytes.

    The function {!Scanf.unescaped} is a left inverse of [escaped],
    i.e. [Scanf.unescaped (escaped s) = s] for any string [s] (unless
    [escape s] fails). *)
val escaped : string -> string

(** [String.index_opt s c] returns the index of the first
    occurrence of character [c] in string [s], or
    [None] if [c] does not occur in [s].
    @since 4.05 *)
val index_opt : string -> char -> int option

(** [String.rindex_opt s c] returns the index of the last occurrence
    of character [c] in string [s], or [None] if [c] does not occur in
    [s].
    @since 4.05 *)
val rindex_opt : string -> char -> int option

(** [String.index_from_opt s i c] returns the index of the
    first occurrence of character [c] in string [s] after position [i]
    or [None] if [c] does not occur in [s] after position [i].

    [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c].
    Raise [Invalid_argument] if [i] is not a valid position in [s].

    @since 4.05
*)
val index_from_opt : string -> int -> char -> int option

(** [String.rindex_from_opt s i c] returns the index of the
    last occurrence of character [c] in string [s] before position [i+1]
    or [None] if [c] does not occur in [s] before position [i+1].

    [String.rindex_opt s c] is equivalent to
    [String.rindex_from_opt s (String.length s - 1) c].

    Raise [Invalid_argument] if [i+1] is not a valid position in [s].

    @since 4.05
*)
val rindex_from_opt : string -> int -> char -> int option

(** [String.contains s c] tests if character [c]
    appears in the string [s]. *)
val contains : string -> char -> bool

(** [String.contains_from s start c] tests if character [c]
    appears in [s] after position [start].
    [String.contains s c] is equivalent to
    [String.contains_from s 0 c].

    Raise [Invalid_argument] if [start] is not a valid position in [s]. *)
val contains_from : string -> int -> char -> bool

(** [String.rcontains_from s stop c] tests if character [c]
    appears in [s] before position [stop+1].

    Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid
    position in [s]. *)
val rcontains_from : string -> int -> char -> bool

(** Return a copy of the argument, with all lowercase letters
    translated to uppercase, using the US-ASCII character set.
    @since 4.03.0 *)
val uppercase_ascii : string -> string

(** Return a copy of the argument, with all uppercase letters
    translated to lowercase, using the US-ASCII character set.
    @since 4.03.0 *)
val lowercase_ascii : string -> string

(** Return a copy of the argument, with the first character set to uppercase,
    using the US-ASCII character set.
    @since 4.03.0 *)
val capitalize_ascii : string -> string

(** Return a copy of the argument, with the first character set to lowercase,
    using the US-ASCII character set.
    @since 4.03.0 *)
val uncapitalize_ascii : string -> string

(** An alias for the type of strings. *)
type t = string

(** The comparison function for strings, with the same specification as
    {!Pervasives.compare}.  Along with the type [t], this function [compare]
    allows the module [String] to be passed as argument to the functors
    {!Set.Make} and {!Map.Make}. *)
val compare : t -> t -> int

(** The equal function for strings.
    @since 4.03.0 *)
val equal : t -> t -> bool

(** [String.split_on_char sep s] returns the list of all (possibly empty)
    substrings of [s] that are delimited by the [sep] character.

    The function's output is specified by the following invariants:

    - The list is not empty.
    - Concatenating its elements using [sep] as a separator returns a
      string equal to the input ([String.concat (String.make 1 sep)
      (String.split_on_char sep s) = s]).
    - No string in the result contains the [sep] character.

    @since 4.04.0
*)
val split_on_char : char -> string -> string list

(** Functions reading bytes  *)

(** [get_char buff i] reads 1 byte at offset i as a char *)
val get_char : t -> int -> char

(** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
    bits. i.e. It returns a value between 0 and 2^8-1 *)
val get_uint8 : t -> int -> int

(** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
    bits. i.e. It returns a value between -2^7 and 2^7-1 *)
val get_int8 : t -> int -> int

(** Functions reading according to Big Endian byte order *)

(** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
      of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
val get_uint16 : t -> int -> int

(** [get_int16 buff i] reads 2 byte at offset i as a signed int of
      16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
val get_int16 : t -> int -> int

(** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
val get_int32 : t -> int -> int32

(** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
val get_int64 : t -> int -> int64

module LE : sig
  (** Functions reading according to Little Endian byte order *)

  (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
      of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
  val get_uint16 : t -> int -> int

  (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
      16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
  val get_int16 : t -> int -> int

  (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
  val get_int32 : t -> int -> int32

  (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
  val get_int64 : t -> int -> int64
end
src/lib_protocol_environment/sigs/v1/string.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter length : string -> Z.

Parameter get : string -> Z -> ascii.

Parameter make : Z -> ascii -> string.

Parameter init : Z -> (Z -> ascii) -> string.

Parameter sub : string -> Z -> Z -> string.

Parameter blit : string -> Z -> string -> Z -> Z -> unit.

Parameter concat : string -> (list string) -> string.

Parameter iter : (ascii -> unit) -> string -> unit.

Parameter iteri : (Z -> ascii -> unit) -> string -> unit.

Parameter map : (ascii -> ascii) -> string -> string.

Parameter mapi : (Z -> ascii -> ascii) -> string -> string.

Parameter trim : string -> string.

Parameter escaped : string -> string.

Parameter index_opt : string -> ascii -> option Z.

Parameter rindex_opt : string -> ascii -> option Z.

Parameter index_from_opt : string -> Z -> ascii -> option Z.

Parameter rindex_from_opt : string -> Z -> ascii -> option Z.

Parameter contains : string -> ascii -> bool.

Parameter contains_from : string -> Z -> ascii -> bool.

Parameter rcontains_from : string -> Z -> ascii -> bool.

Parameter uppercase_ascii : string -> string.

Parameter lowercase_ascii : string -> string.

Parameter capitalize_ascii : string -> string.

Parameter uncapitalize_ascii : string -> string.

Definition t := string.

Parameter compare : t -> t -> Z.

Parameter equal : t -> t -> bool.

Parameter split_on_char : ascii -> string -> list string.

Parameter get_char : t -> Z -> ascii.

Parameter get_uint8 : t -> Z -> Z.

Parameter get_int8 : t -> Z -> Z.

Parameter get_uint16 : t -> Z -> Z.

Parameter get_int16 : t -> Z -> Z.

Parameter get_int32 : t -> Z -> int32.

Parameter get_int64 : t -> Z -> int64.

Module LE.
  Parameter get_uint16 : t -> Z -> Z.
  
  Parameter get_int16 : t -> Z -> Z.
  
  Parameter get_int32 : t -> Z -> int32.
  
  Parameter get_int64 : t -> Z -> int64.
End LE.
src/lib_protocol_environment/sigs/v1/tezos_data.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Protocol : sig end
src/lib_protocol_environment/sigs/v1/tezos_data.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Protocol.

End Protocol.
src/lib_protocol_environment/sigs/v1/time.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

include Compare.S with type t := t

val add : t -> int64 -> t

val diff : t -> t -> int64

val of_seconds : int64 -> t

val to_seconds : t -> int64

val of_notation : string -> t option

val of_notation_exn : string -> t

val to_notation : t -> string

val encoding : t Data_encoding.t

val rfc_encoding : t Data_encoding.t

val pp_hum : Format.formatter -> t -> unit
src/lib_protocol_environment/sigs/v1/time.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter add : t -> int64 -> t.

Parameter diff : t -> t -> int64.

Parameter of_seconds : int64 -> t.

Parameter to_seconds : t -> int64.

Parameter of_notation : string -> option t.

Parameter of_notation_exn : string -> t.

Parameter to_notation : t -> string.
src/lib_protocol_environment/sigs/v1/updater.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Environment - Protocol updater. *)

(** Validation result: the record returned by the protocol
    on the successfull validation of a block. *)
type validation_result = {
  context : Context.t;
      (** The resulting context, it will be used for the next block. *)
  fitness : Fitness.t;
      (** The effective fitness of the block (to be compared with
      the 'announced' one in the block header. *)
  message : string option;
      (** An optional informative message to be used as in the 'git
      commit' of the block's context. *)
  max_operations_ttl : int;
      (** The "time-to-live" of operation for the next block: any
      operations whose 'branch' is older than 'ttl' blocks in the
      past cannot be included in the next block. *)
  last_allowed_fork_level : Int32.t;
      (** The level of the last block for which the node might consider an
      alternate branch. The shell should consider as invalid any
      branch whose fork point is older than the given level *)
}

type quota = {
  max_size : int;
      (** The maximum size (in bytes) of the serialized list of
      operations. *)
  max_op : int option;
      (** The maximum number of operation.
      [None] means no limit. *)
}

type rpc_context = {
  block_hash : Block_hash.t;
  block_header : Block_header.shell_header;
  context : Context.t;
}

(** This is the signature of a Tezos protocol implementation. It has
    access to the standard library and the Environment module. *)
module type PROTOCOL = sig
  (** The maximum size of a block header in bytes. *)
  val max_block_length : int

  (** The maximum size of an operation in bytes. *)
  val max_operation_data_length : int

  (** The number of validation passes (length of the list) and the
      operation's quota for each pass. *)
  val validation_passes : quota list

  (** The version specific type of blocks. *)
  type block_header_data

  (** Encoding for version specific part of block headers.  *)
  val block_header_data_encoding : block_header_data Data_encoding.t

  (** A fully parsed block header. *)
  type block_header = {
    shell : Block_header.shell_header;
    protocol_data : block_header_data;
  }

  (** Version-specific side information computed by the protocol
      during the validation of a block. Should not include information
      about the evaluation of operations which is handled separately by
      {!operation_metadata}. To be used as an execution trace by tools
      (client, indexer). Not necessary for validation. *)
  type block_header_metadata

  (** Encoding for version-specific block metadata. *)
  val block_header_metadata_encoding : block_header_metadata Data_encoding.t

  (** The version specific type of operations. *)
  type operation_data

  (** Version-specific side information computed by the protocol
      during the validation of each operation, to be used conjointly
      with {!block_header_metadata}. *)
  type operation_receipt

  (** A fully parsed operation. *)
  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  (** Encoding for version-specific operation data. *)
  val operation_data_encoding : operation_data Data_encoding.t

  (** Encoding for version-specific operation receipts. *)
  val operation_receipt_encoding : operation_receipt Data_encoding.t

  (** Encoding that mixes an operation data and its receipt. *)
  val operation_data_and_receipt_encoding :
    (operation_data * operation_receipt) Data_encoding.t

  (** The Validation passes in which an operation can appear.
      For instance [[0]] if it only belongs to the first pass.
      An answer of [[]] means that the operation is ill-formed
      and cannot be included at all. *)
  val acceptable_passes : operation -> int list

  (** Basic ordering of operations. [compare_operations op1 op2] means
      that [op1] should appear before [op2] in a block. *)
  val compare_operations : operation -> operation -> int

  (** A functional state that is transmitted through the steps of a
      block validation sequence. It must retain the current state of
      the store (that can be extracted from the outside using
      {!current_context}, and whose final value is produced by
      {!finalize_block}). It can also contain the information that
      must be remembered during the validation, which must be
      immutable (as validator or baker implementations are allowed to
      pause, replay or backtrack during the validation process). *)
  type validation_state

  (** Access the context at a given validation step. *)
  val current_context : validation_state -> Context.t tzresult Lwt.t

  (** Checks that a block is well formed in a given context. This
      function should run quickly, as its main use is to reject bad
      blocks from the chain as early as possible. The input context
      is the one resulting of an ancestor block of same protocol
      version. This ancestor of the current head is guaranteed to be
      more recent than `last_allowed_fork_level`.

      The resulting `validation_state` will be used for multi-pass
      validation. *)
  val begin_partial_application :
    chain_id:Chain_id.t ->
    ancestor_context:Context.t ->
    predecessor_timestamp:Time.t ->
    predecessor_fitness:Fitness.t ->
    block_header ->
    validation_state tzresult Lwt.t

  (** The first step in a block validation sequence. Initializes a
      validation context for validating a block. Takes as argument the
      {!Block_header.t} to initialize the context for this block. The
      function {!precheck_block} may not have been called before
      [begin_application], so all the check performed by the former
      must be repeated in the latter. *)
  val begin_application :
    chain_id:Chain_id.t ->
    predecessor_context:Context.t ->
    predecessor_timestamp:Time.t ->
    predecessor_fitness:Fitness.t ->
    block_header ->
    validation_state tzresult Lwt.t

  (** Initializes a validation context for constructing a new block
      (as opposed to validating an existing block). When the
      [protocol_data] argument is specified, it should contains a
      'prototype' of a the protocol specific part of a block header,
      and the function should produce the exact same effect on the
      context than would produce the validation of a block containing
      an "equivalent" (but complete) header. For instance, if the
      block header usually includes a signature, the header provided
      to {!begin_construction} should includes a faked signature. *)
  val begin_construction :
    chain_id:Chain_id.t ->
    predecessor_context:Context.t ->
    predecessor_timestamp:Time.t ->
    predecessor_level:Int32.t ->
    predecessor_fitness:Fitness.t ->
    predecessor:Block_hash.t ->
    timestamp:Time.t ->
    ?protocol_data:block_header_data ->
    unit ->
    validation_state tzresult Lwt.t

  (** Called after {!begin_application} (or {!begin_construction}) and
      before {!finalize_block}, with each operation in the block. *)
  val apply_operation :
    validation_state ->
    operation ->
    (validation_state * operation_receipt) tzresult Lwt.t

  (** The last step in a block validation sequence. It produces the
      context that will be used as input for the validation of its
      successor block candidates. *)
  val finalize_block :
    validation_state ->
    (validation_result * block_header_metadata) tzresult Lwt.t

  (** The list of remote procedures exported by this implementation *)
  val rpc_services : rpc_context RPC_directory.t

  (** Initialize the context (or upgrade the context after a protocol
      amendment). This function receives the context resulting of the
      application of a block that triggered the amendment. It also
      receives the header of the block that triggered the amendment. *)
  val init :
    Context.t -> Block_header.shell_header -> validation_result tzresult Lwt.t
end

(** Activates a given protocol version from a given context. This
    means that the context used for the next block will use this
    version (this is not an immediate change). The version must have
    been previously compiled successfully. *)
val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t

(** Fork a test chain. The forkerd chain will use the current block
    as genesis, and [protocol] as economic protocol. The chain will
    be destroyed when a (successor) block will have a timestamp greater
    than [expiration]. The protocol must have been previously compiled
    successfully. *)
val fork_test_chain :
  Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t
src/lib_protocol_environment/sigs/v1/updater.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record quota := {
  max_size : Z;
  max_op : option Z }.

module_type
src/lib_protocol_environment/sigs/v1/z.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Environment - Arbitrary precision arithmetic. *)

type t

val zero : t

val one : t

(** Returns its argument plus one. *)
val succ : t -> t

(** Absolute value. *)
val abs : t -> t

(** Unary negation. *)
val neg : t -> t

(** Addition. *)
val add : t -> t -> t

(** Subtraction. *)
val sub : t -> t -> t

(** Multiplication. *)
val mul : t -> t -> t

(** Euclidean division and remainder.  [ediv_rem a b] returns a pair [(q, r)]
    such that [a = b * q + r] and [0 <= r < |b|].
    Raises [Division_by_zero] if [b = 0].
*)
val ediv_rem : t -> t -> t * t

(** Bitwise logical and. *)
val logand : t -> t -> t

(** Bitwise logical or. *)
val logor : t -> t -> t

(** Bitwise logical exclusive or. *)
val logxor : t -> t -> t

(** Bitwise logical negation.
    The identity [lognot a]=[-a-1] always hold.
*)
val lognot : t -> t

(** Shifts to the left.
    Equivalent to a multiplication by a power of 2.
    The second argument must be non-negative.
*)
val shift_left : t -> int -> t

(** Shifts to the right.
    This is an arithmetic shift,
    equivalent to a division by a power of 2 with rounding towards -oo.
    The second argument must be non-negative.
*)
val shift_right : t -> int -> t

(** Gives a human-readable, decimal string representation of the argument. *)
val to_string : t -> string

(** Converts a string to an integer.
    An optional [-] prefix indicates a negative number, while a [+]
    prefix is ignored.
    An optional prefix [0x], [0o], or [0b] (following the optional [-]
    or [+] prefix) indicates that the number is,
    represented, in hexadecimal, octal, or binary, respectively.
    Otherwise, base 10 is assumed.
    (Unlike C, a lone [0] prefix does not denote octal.)
    Raises an [Invalid_argument] exception if the string is not a
    syntactically correct representation of an integer.
*)
val of_string : string -> t

(** Converts to a 64-bit integer. May raise [Overflow]. *)
val to_int64 : t -> int64

(** Converts from a 64-bit integer. *)
val of_int64 : int64 -> t

(** Converts to a base integer. May raise an [Overflow]. *)
val to_int : t -> int

(** Converts from a base integer. *)
val of_int : int -> t

val to_bits : ?pad_to:int -> t -> MBytes.t

val of_bits : MBytes.t -> t

val equal : t -> t -> bool

val compare : t -> t -> int

(** Returns the number of significant bits in the given number.
    If [x] is zero, [numbits x] returns 0.  Otherwise,
    [numbits x] returns a positive integer [n] such that
    [2^{n-1} <= |x| < 2^n].  Note that [numbits] is defined
    for negative arguments, and that [numbits (-x) = numbits x]. *)
val numbits : t -> int
src/lib_protocol_environment/sigs/v1/z.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter zero : t.

Parameter one : t.

Parameter succ : t -> t.

Parameter abs : t -> t.

Parameter neg : t -> t.

Parameter add : t -> t -> t.

Parameter sub : t -> t -> t.

Parameter mul : t -> t -> t.

Parameter ediv_rem : t -> t -> t * t.

Parameter logand : t -> t -> t.

Parameter logor : t -> t -> t.

Parameter logxor : t -> t -> t.

Parameter lognot : t -> t.

Parameter shift_left : t -> Z -> t.

Parameter shift_right : t -> Z -> t.

Parameter to_string : t -> string.

Parameter of_string : string -> t.

Parameter to_int64 : t -> int64.

Parameter of_int64 : int64 -> t.

Parameter to_int : t -> Z.

Parameter of_int : Z -> t.

Parameter equal : t -> t -> bool.

Parameter compare : t -> t -> Z.

Parameter numbits : t -> Z.
src/lib_protocol_environment/sigs_packer/sigs_packer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let dump_file oc file =
  let ic = open_in file in
  let buflen = 8096 in
  let buf = Bytes.create buflen in
  let rec loop () =
    let len = input ic buf 0 buflen in
    if len <> 0 then (
      Printf.fprintf
        oc
        "%s"
        (Bytes.to_string (if len = buflen then buf else Bytes.sub buf 0 len)) ;
      loop () )
  in
  loop () ; close_in ic

let opened_modules = ["Pervasives"; "Error_monad"]

let include_mli oc file =
  let unit =
    String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
  in
  Printf.fprintf oc "module %s : sig\n" unit ;
  Printf.fprintf oc "# 1 %S\n" file ;
  dump_file oc file ;
  Printf.fprintf oc "end\n" ;
  if unit = "Result" then
    Printf.fprintf
      oc
      "type ('a, 'b) result = ('a, 'b) Result.result =  Ok of 'a | Error of 'b\n" ;
  if List.mem unit opened_modules then Printf.fprintf oc "open %s\n" unit

let () =
  Printf.fprintf stdout "module type T = sig\n" ;
  for i = 1 to Array.length Sys.argv - 1 do
    let file = Sys.argv.(i) in
    include_mli stdout file
  done ;
  Printf.fprintf stdout "end\n%!"
src/lib_protocol_environment/sigs_packer/sigs_packer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition dump_file (oc : Stdlib.out_channel) (file : string) : unit :=
  let ic := Stdlib.open_in file in
  let buflen := 8096 in
  let buf := Stdlib.Bytes.create buflen in
  let fix loop (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      let len := Stdlib.input ic buf 0 buflen in
      if nequiv_decb len 0 then
        Stdlib.Printf.fprintf oc
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format) "%s" % string)
          (Stdlib.Bytes.to_string
            (if equiv_decb len buflen then
              buf
            else
              String.sub buf 0 len));
        loop tt
      else
        tt
    end in
  loop tt;
  Stdlib.close_in ic.

Definition opened_modules : list string :=
  cons "Pervasives" % string (cons "Error_monad" % string []).

Definition include_mli (oc : Stdlib.out_channel) (file : string) : unit :=
  let unit :=
    Stdlib.String.capitalize_ascii
      (Stdlib.Filename.chop_extension (Stdlib.Filename.basename file)) in
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "module " % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal " : sig
" % string
            CamlinternalFormatBasics.End_of_format)))
      "module %s : sig
" % string) unit;
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "# 1 " % string
        (CamlinternalFormatBasics.Caml_string
          CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "010" % char
            CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string) file;
  dump_file oc file;
  Stdlib.Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "end
" % string
        CamlinternalFormatBasics.End_of_format) "end
" % string);
  if equiv_decb unit "Result" % string then
    Stdlib.Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "type ('a, 'b) result = ('a, 'b) Result.result =  Ok of 'a | Error of 'b
"
            % string CamlinternalFormatBasics.End_of_format)
        "type ('a, 'b) result = ('a, 'b) Result.result =  Ok of 'a | Error of 'b
"
          % string)
  else
    tt;
  if Stdlib.List.mem unit opened_modules then
    Stdlib.Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "open " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "open %s
" % string)
      unit
  else
    tt.
src/lib_protocol_environment/test/assert.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg

let equal_string_option ?msg o1 o2 =
  let prn = function None -> "None" | Some s -> s in
  equal ?msg ~prn o1 o2

let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg

let make_equal_list eq prn ?(msg = "") x y =
  let rec iter i x y =
    match (x, y) with
    | (hd_x :: tl_x, hd_y :: tl_y) ->
        if eq hd_x hd_y then iter (succ i) tl_x tl_y
        else
          let fm = Printf.sprintf "%s (at index %d)" msg i in
          fail (prn hd_x) (prn hd_y) fm
    | (_ :: _, []) | ([], _ :: _) ->
        let fm = Printf.sprintf "%s (lists of different sizes)" msg in
        fail_msg "%s" fm
    | ([], []) ->
        ()
  in
  iter 0 x y

let equal_string_list_list ?msg l1 l2 =
  let pr_persist l =
    let res =
      String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
    in
    Printf.sprintf "[%s]" res
  in
  make_equal_list ?msg ( = ) pr_persist l1 l2
src/lib_protocol_environment/test/assert.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Stdlib.Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  match function_parameter with
  | _ => "" % string
  end.

Definition equal {A : Type} (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun op_star_o_p_t_star =>
    let prn :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

Definition equal_string_option
  (msg : option string) (o1 : option string) (o2 : option string) : unit :=
  let prn (function_parameter : option string) : string :=
    match function_parameter with
    | None => "None" % string
    | Some s => s
    end in
  equal None (Some prn) msg o1 o2.

Definition is_none {A : Type} (op_star_o_p_t_star : option string)
  : (option A) -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    if nequiv_decb x None then
      fail "None" % string "Some _" % string msg
    else
      tt.

Definition make_equal_list {A : Type}
  (eq : A -> A -> bool) (prn : A -> string) (op_star_o_p_t_star : option string)
  : (list A) -> (list A) -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    fun y =>
      let fix iter (i : Z) (x : list A) (y : list A) : unit :=
        match (x, y) with
        | (cons hd_x tl_x, cons hd_y tl_y) =>
          if eq hd_x hd_y then
            iter (Z.succ i) tl_x tl_y
          else
            let fm :=
              Stdlib.Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " (at index " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format))))
                  "%s (at index %d)" % string) msg i in
            fail (prn hd_x) (prn hd_y) fm
        | (cons _ _, []) | ([], cons _ _) =>
          let fm :=
            Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " (lists of different sizes)" % string
                    CamlinternalFormatBasics.End_of_format))
                "%s (lists of different sizes)" % string) msg in
          fail_msg
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string) fm
        | ([], []) => tt
        end in
      iter 0 x y.

Definition equal_string_list_list
  (msg : option string) (l1 : list (list string)) (l2 : list (list string))
  : unit :=
  let pr_persist (l : list string) : string :=
    let res :=
      Tezos_base__TzPervasives.String.concat ";" % string
        (Tezos_base__TzPervasives.List.map
          (fun s =>
            Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
      in
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "]" % char
              CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
  make_equal_list equiv_decb pr_persist msg l1 l2.
src/lib_protocol_environment/test/test.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Alcotest.run "tezos-shell-context" [("mem_context", Test_mem_context.tests)]
src/lib_protocol_environment/test/test.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_protocol_environment/test/test_mem_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Context creation *)

let create_block2 ctxt =
  Context.set ctxt ["a"; "b"] (MBytes.of_string "Novembre")
  >>= fun ctxt ->
  Context.set ctxt ["a"; "c"] (MBytes.of_string "Juin")
  >>= fun ctxt ->
  Context.set ctxt ["version"] (MBytes.of_string "0.0")
  >>= fun ctxt -> Lwt.return ctxt

let create_block3a ctxt =
  Context.del ctxt ["a"; "b"]
  >>= fun ctxt ->
  Context.set ctxt ["a"; "d"] (MBytes.of_string "Mars")
  >>= fun ctxt -> Lwt.return ctxt

let create_block3b ctxt =
  Context.del ctxt ["a"; "c"]
  >>= fun ctxt ->
  Context.set ctxt ["a"; "d"] (MBytes.of_string "Février")
  >>= fun ctxt -> Lwt.return ctxt

type t = {
  genesis : Context.t;
  block2 : Context.t;
  block3a : Context.t;
  block3b : Context.t;
}

let wrap_context_init f _ () =
  let genesis = Memory_context.empty in
  create_block2 genesis
  >>= fun block2 ->
  create_block3a block2
  >>= fun block3a ->
  create_block3b block2
  >>= fun block3b ->
  f {genesis; block2; block3a; block3b} >>= fun result -> Lwt.return result

(** Simple test *)

let c = function None -> None | Some s -> Some (MBytes.to_string s)

let test_simple {block2 = ctxt; _} =
  Context.get ctxt ["version"]
  >>= fun version ->
  Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ;
  Context.get ctxt ["a"; "b"]
  >>= fun novembre ->
  Assert.equal_string_option (Some "Novembre") (c novembre) ;
  Context.get ctxt ["a"; "c"]
  >>= fun juin ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
  Lwt.return_unit

let test_continuation {block3a = ctxt; _} =
  Context.get ctxt ["version"]
  >>= fun version ->
  Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
  Context.get ctxt ["a"; "b"]
  >>= fun novembre ->
  Assert.is_none ~msg:__LOC__ (c novembre) ;
  Context.get ctxt ["a"; "c"]
  >>= fun juin ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
  Context.get ctxt ["a"; "d"]
  >>= fun mars ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
  Lwt.return_unit

let test_fork {block3b = ctxt; _} =
  Context.get ctxt ["version"]
  >>= fun version ->
  Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
  Context.get ctxt ["a"; "b"]
  >>= fun novembre ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
  Context.get ctxt ["a"; "c"]
  >>= fun juin ->
  Assert.is_none ~msg:__LOC__ (c juin) ;
  Context.get ctxt ["a"; "d"]
  >>= fun mars ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
  Lwt.return_unit

let test_replay {genesis = ctxt0; _} =
  Context.set ctxt0 ["version"] (MBytes.of_string "0.0")
  >>= fun ctxt1 ->
  Context.set ctxt1 ["a"; "b"] (MBytes.of_string "Novembre")
  >>= fun ctxt2 ->
  Context.set ctxt2 ["a"; "c"] (MBytes.of_string "Juin")
  >>= fun ctxt3 ->
  Context.set ctxt3 ["a"; "d"] (MBytes.of_string "July")
  >>= fun ctxt4a ->
  Context.set ctxt3 ["a"; "d"] (MBytes.of_string "Juillet")
  >>= fun ctxt4b ->
  Context.set ctxt4a ["a"; "b"] (MBytes.of_string "November")
  >>= fun ctxt5a ->
  Context.get ctxt4a ["a"; "b"]
  >>= fun novembre ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
  Context.get ctxt5a ["a"; "b"]
  >>= fun november ->
  Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ;
  Context.get ctxt5a ["a"; "d"]
  >>= fun july ->
  Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ;
  Context.get ctxt4b ["a"; "b"]
  >>= fun novembre ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
  Context.get ctxt4b ["a"; "d"]
  >>= fun juillet ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
  Lwt.return_unit

let fold_keys s k ~init ~f =
  let rec loop k acc =
    Context.fold s k ~init:acc ~f:(fun file acc ->
        match file with `Key k -> f k acc | `Dir k -> loop k acc)
  in
  loop k init

let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

let test_fold {genesis = ctxt; _} =
  Context.set ctxt ["a"; "b"] (MBytes.of_string "Novembre")
  >>= fun ctxt ->
  Context.set ctxt ["a"; "c"] (MBytes.of_string "Juin")
  >>= fun ctxt ->
  Context.set ctxt ["a"; "d"; "e"] (MBytes.of_string "Septembre")
  >>= fun ctxt ->
  Context.set ctxt ["f"] (MBytes.of_string "Avril")
  >>= fun ctxt ->
  Context.set ctxt ["g"; "h"] (MBytes.of_string "Avril")
  >>= fun ctxt ->
  keys ctxt []
  >>= fun l ->
  Assert.equal_string_list_list
    ~msg:__LOC__
    [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
    (List.sort compare l) ;
  keys ctxt ["a"]
  >>= fun l ->
  Assert.equal_string_list_list
    ~msg:__LOC__
    [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
    (List.sort compare l) ;
  keys ctxt ["f"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [] l ;
  keys ctxt ["g"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] l ;
  keys ctxt ["i"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [] l ;
  Lwt.return_unit

(******************************************************************************)

let tests =
  [ ("simple", test_simple);
    ("continuation", test_continuation);
    ("fork", test_fork);
    ("replay", test_replay);
    ("fold", test_fold) ]

let tests =
  List.map
    (fun (n, f) -> Alcotest_lwt.test_case n `Quick (wrap_context_init f))
    tests
src/lib_protocol_environment/test/test_mem_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition create_block2 {A B : Type} (ctxt : A) : Lwt.t B :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
      (cons "a" % string (cons "b" % string []))
      (Tezos_base__TzPervasives.MBytes.of_string "Novembre" % string))
    (fun ctxt =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
          (cons "a" % string (cons "c" % string []))
          (Tezos_base__TzPervasives.MBytes.of_string "Juin" % string))
        (fun ctxt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
              (cons "version" % string [])
              (Tezos_base__TzPervasives.MBytes.of_string "0.0" % string))
            (fun ctxt => Lwt._return ctxt))).

Definition create_block3a {A B : Type} (ctxt : A) : Lwt.t B :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
      (cons "a" % string (cons "b" % string [])))
    (fun ctxt =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
          (cons "a" % string (cons "d" % string []))
          (Tezos_base__TzPervasives.MBytes.of_string "Mars" % string))
        (fun ctxt => Lwt._return ctxt)).

Definition create_block3b {A B : Type} (ctxt : A) : Lwt.t B :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
      (cons "a" % string (cons "c" % string [])))
    (fun ctxt =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
          (cons "a" % string (cons "d" % string []))
          (Tezos_base__TzPervasives.MBytes.of_string "Février" % string))
        (fun ctxt => Lwt._return ctxt)).

Definition wrap_context_init {A B C : Type}
  (f : A -> Lwt.t B) (function_parameter : C) : unit -> Lwt.t B :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | tt =>
        let genesis := Memory_context.empty in
        Tezos_base__TzPervasives.op_gt_gt_eq (create_block2 genesis)
          (fun block2 =>
            Tezos_base__TzPervasives.op_gt_gt_eq (create_block3a block2)
              (fun block3a =>
                Tezos_base__TzPervasives.op_gt_gt_eq (create_block3b block2)
                  (fun block3b =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (f op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (fun result => Lwt._return result))))
      end
  end.

Definition c (function_parameter : option Tezos_base__TzPervasives.MBytes.t)
  : option string :=
  match function_parameter with
  | None => None
  | Some s => Some (Tezos_base__TzPervasives.MBytes.to_string s)
  end.

Definition test_simple {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
        (cons "version" % string []))
      (fun version =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ (c version)
          (Some "0.0" % string);
        Tezos_base__TzPervasives.op_gt_gt_eq
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
            (cons "a" % string (cons "b" % string [])))
          (fun novembre =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star (Some "Novembre" % string)
              (c novembre);
            Tezos_base__TzPervasives.op_gt_gt_eq
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                (cons "a" % string (cons "c" % string [])))
              (fun juin =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                  (Some "Juin" % string) (c juin);
                Lwt.return_unit)))
  end.

Definition test_continuation {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
        (cons "version" % string []))
      (fun version =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
          (Some "0.0" % string) (c version);
        Tezos_base__TzPervasives.op_gt_gt_eq
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
            (cons "a" % string (cons "b" % string [])))
          (fun novembre =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ (c novembre);
            Tezos_base__TzPervasives.op_gt_gt_eq
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                (cons "a" % string (cons "c" % string [])))
              (fun juin =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                  (Some "Juin" % string) (c juin);
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (cons "a" % string (cons "d" % string [])))
                  (fun mars =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                      (Some "Mars" % string) (c mars);
                    Lwt.return_unit))))
  end.

Definition test_fork {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
        (cons "version" % string []))
      (fun version =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
          (Some "0.0" % string) (c version);
        Tezos_base__TzPervasives.op_gt_gt_eq
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
            (cons "a" % string (cons "b" % string [])))
          (fun novembre =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
              (Some "Novembre" % string) (c novembre);
            Tezos_base__TzPervasives.op_gt_gt_eq
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                (cons "a" % string (cons "c" % string [])))
              (fun juin =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ (c juin);
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (cons "a" % string (cons "d" % string [])))
                  (fun mars =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                      (Some "Février" % string) (c mars);
                    Lwt.return_unit))))
  end.

Definition test_replay {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
        (cons "version" % string [])
        (Tezos_base__TzPervasives.MBytes.of_string "0.0" % string))
      (fun ctxt1 =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt1
            (cons "a" % string (cons "b" % string []))
            (Tezos_base__TzPervasives.MBytes.of_string "Novembre" % string))
          (fun ctxt2 =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt2
                (cons "a" % string (cons "c" % string []))
                (Tezos_base__TzPervasives.MBytes.of_string "Juin" % string))
              (fun ctxt3 =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt3
                    (cons "a" % string (cons "d" % string []))
                    (Tezos_base__TzPervasives.MBytes.of_string "July" % string))
                  (fun ctxt4a =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt3
                        (cons "a" % string (cons "d" % string []))
                        (Tezos_base__TzPervasives.MBytes.of_string
                          "Juillet" % string))
                      (fun ctxt4b =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt4a
                            (cons "a" % string (cons "b" % string []))
                            (Tezos_base__TzPervasives.MBytes.of_string
                              "November" % string))
                          (fun ctxt5a =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt4a
                                (cons "a" % string (cons "b" % string [])))
                              (fun novembre =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Stdlib.__LOC__ (Some "Novembre" % string)
                                  (c novembre);
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt5a
                                    (cons "a" % string (cons "b" % string [])))
                                  (fun november =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      Stdlib.__LOC__ (Some "November" % string)
                                      (c november);
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        ctxt5a
                                        (cons "a" % string
                                          (cons "d" % string [])))
                                      (fun july =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Stdlib.__LOC__ (Some "July" % string)
                                          (c july);
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            ctxt4b
                                            (cons "a" % string
                                              (cons "b" % string [])))
                                          (fun novembre =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Stdlib.__LOC__
                                              (Some "Novembre" % string)
                                              (c novembre);
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                ctxt4b
                                                (cons "a" % string
                                                  (cons "d" % string [])))
                                              (fun juillet =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Stdlib.__LOC__
                                                  (Some "Juillet" % string)
                                                  (c juillet);
                                                Lwt.return_unit)))))))))))
  end.

Definition fold_keys {A B C D E : Type}
  (s : A) (k : B) (init : C) (f : D -> C -> E) : E :=
  let fix loop {F : Type} (k : F) (acc : C) : E :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star s k acc
      (fun file =>
        fun acc =>
          match file with
          | Key k => f k acc
          | Dir k => loop k acc
          end) in
  loop k init.

Definition keys {A B C : Type} (t : A) : B -> Lwt.t (list C) :=
  fold_keys t expected_argument []
    (fun k => fun acc => Lwt._return (cons k acc)).

Definition test_fold {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
        (cons "a" % string (cons "b" % string []))
        (Tezos_base__TzPervasives.MBytes.of_string "Novembre" % string))
      (fun ctxt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
            (cons "a" % string (cons "c" % string []))
            (Tezos_base__TzPervasives.MBytes.of_string "Juin" % string))
          (fun ctxt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
                (cons "a" % string (cons "d" % string (cons "e" % string [])))
                (Tezos_base__TzPervasives.MBytes.of_string "Septembre" % string))
              (fun ctxt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
                    (cons "f" % string [])
                    (Tezos_base__TzPervasives.MBytes.of_string "Avril" % string))
                  (fun ctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt
                        (cons "g" % string (cons "h" % string []))
                        (Tezos_base__TzPervasives.MBytes.of_string
                          "Avril" % string))
                      (fun ctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq (keys ctxt [])
                          (fun l =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                              (cons (cons "a" % string (cons "b" % string []))
                                (cons (cons "a" % string (cons "c" % string []))
                                  (cons
                                    (cons "a" % string
                                      (cons "d" % string (cons "e" % string [])))
                                    (cons (cons "f" % string [])
                                      (cons
                                        (cons "g" % string
                                          (cons "h" % string [])) [])))))
                              (Tezos_base__TzPervasives.List.sort
                                OCaml.Stdlib.compare l);
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (keys ctxt (cons "a" % string []))
                              (fun l =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Stdlib.__LOC__
                                  (cons
                                    (cons "a" % string (cons "b" % string []))
                                    (cons
                                      (cons "a" % string (cons "c" % string []))
                                      (cons
                                        (cons "a" % string
                                          (cons "d" % string
                                            (cons "e" % string []))) [])))
                                  (Tezos_base__TzPervasives.List.sort
                                    OCaml.Stdlib.compare l);
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (keys ctxt (cons "f" % string []))
                                  (fun l =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      Stdlib.__LOC__ [] l;
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (keys ctxt (cons "g" % string []))
                                      (fun l =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Stdlib.__LOC__
                                          (cons
                                            (cons "g" % string
                                              (cons "h" % string [])) []) l;
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (keys ctxt (cons "i" % string []))
                                          (fun l =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Stdlib.__LOC__ [] l;
                                            Lwt.return_unit))))))))))
  end.

Definition tests {A : Type} : list (string * (A -> Lwt.t unit)) :=
  cons ("simple" % string, test_simple)
    (cons ("continuation" % string, test_continuation)
      (cons ("fork" % string, test_fork)
        (cons ("replay" % string, test_replay)
          (cons ("fold" % string, test_fold) [])))).

Definition tests {A : Type} : list A :=
  Tezos_base__TzPervasives.List.map
    (fun function_parameter =>
      match function_parameter with
      | (n, f) =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star n variant (wrap_context_init f)
      end) tests.
src/lib_protocol_environment/tezos_protocol_environment.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module type CONTEXT = sig
  type t

  type key = string list

  type value = MBytes.t

  val mem : t -> key -> bool Lwt.t

  val dir_mem : t -> key -> bool Lwt.t

  val get : t -> key -> value option Lwt.t

  val set : t -> key -> value -> t Lwt.t

  val copy : t -> from:key -> to_:key -> t option Lwt.t

  val del : t -> key -> t Lwt.t

  val remove_rec : t -> key -> t Lwt.t

  val fold :
    t ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val set_protocol : t -> Protocol_hash.t -> t Lwt.t

  val fork_test_chain :
    t -> protocol:Protocol_hash.t -> expiration:Time.Protocol.t -> t Lwt.t
end

module Context = struct
  type key = string list

  type value = MBytes.t

  type 'ctxt ops = (module CONTEXT with type t = 'ctxt)

  type _ kind = ..

  type t = Context : {kind : 'a kind; ctxt : 'a; ops : 'a ops} -> t

  let mem (Context {ops = (module Ops); ctxt; _}) key = Ops.mem ctxt key

  let set (Context {ops = (module Ops) as ops; ctxt; kind}) key value =
    Ops.set ctxt key value
    >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})

  let dir_mem (Context {ops = (module Ops); ctxt; _}) key =
    Ops.dir_mem ctxt key

  let get (Context {ops = (module Ops); ctxt; _}) key = Ops.get ctxt key

  let copy (Context {ops = (module Ops) as ops; ctxt; kind}) ~from ~to_ =
    Ops.copy ctxt ~from ~to_
    >>= function
    | Some ctxt ->
        Lwt.return_some (Context {ops; ctxt; kind})
    | None ->
        Lwt.return_none

  let del (Context {ops = (module Ops) as ops; ctxt; kind}) key =
    Ops.del ctxt key >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})

  let remove_rec (Context {ops = (module Ops) as ops; ctxt; kind}) key =
    Ops.remove_rec ctxt key
    >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})

  let fold (Context {ops = (module Ops); ctxt; _}) key ~init ~f =
    Ops.fold ctxt key ~init ~f

  let set_protocol (Context {ops = (module Ops) as ops; ctxt; kind})
      protocol_hash =
    Ops.set_protocol ctxt protocol_hash
    >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})

  let fork_test_chain (Context {ops = (module Ops) as ops; ctxt; kind})
      ~protocol ~expiration =
    Ops.fork_test_chain ctxt ~protocol ~expiration
    >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})
end

type validation_result = {
  context : Context.t;
  fitness : Fitness.t;
  message : string option;
  max_operations_ttl : int;
  last_allowed_fork_level : Int32.t;
}

type quota = {max_size : int; max_op : int option}

type rpc_context = {
  block_hash : Block_hash.t;
  block_header : Block_header.shell_header;
  context : Context.t;
}

module type T = sig
  type context

  type quota

  type validation_result

  type rpc_context

  type 'a tzresult

  val max_block_length : int

  val max_operation_data_length : int

  val validation_passes : quota list

  type block_header_data

  val block_header_data_encoding : block_header_data Data_encoding.t

  type block_header = {
    shell : Block_header.shell_header;
    protocol_data : block_header_data;
  }

  type block_header_metadata

  val block_header_metadata_encoding : block_header_metadata Data_encoding.t

  type operation_data

  type operation_receipt

  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  val operation_data_encoding : operation_data Data_encoding.t

  val operation_receipt_encoding : operation_receipt Data_encoding.t

  val operation_data_and_receipt_encoding :
    (operation_data * operation_receipt) Data_encoding.t

  val acceptable_passes : operation -> int list

  val compare_operations : operation -> operation -> int

  type validation_state

  val current_context : validation_state -> context tzresult Lwt.t

  val begin_partial_application :
    chain_id:Chain_id.t ->
    ancestor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_fitness:Fitness.t ->
    block_header ->
    validation_state tzresult Lwt.t

  val begin_application :
    chain_id:Chain_id.t ->
    predecessor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_fitness:Fitness.t ->
    block_header ->
    validation_state tzresult Lwt.t

  val begin_construction :
    chain_id:Chain_id.t ->
    predecessor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_level:Int32.t ->
    predecessor_fitness:Fitness.t ->
    predecessor:Block_hash.t ->
    timestamp:Time.Protocol.t ->
    ?protocol_data:block_header_data ->
    unit ->
    validation_state tzresult Lwt.t

  val apply_operation :
    validation_state ->
    operation ->
    (validation_state * operation_receipt) tzresult Lwt.t

  val finalize_block :
    validation_state ->
    (validation_result * block_header_metadata) tzresult Lwt.t

  val rpc_services : rpc_context RPC_directory.t

  val init :
    context -> Block_header.shell_header -> validation_result tzresult Lwt.t
end

module type PROTOCOL =
  T
    with type context := Context.t
     and type quota := quota
     and type validation_result := validation_result
     and type rpc_context := rpc_context
     and type 'a tzresult := 'a Error_monad.tzresult

module type V1 = sig
  include
    Tezos_protocol_environment_sigs.V1.T
      with type Format.formatter = Format.formatter
       and type 'a Data_encoding.t = 'a Data_encoding.t
       and type 'a Data_encoding.lazy_t = 'a Data_encoding.lazy_t
       and type 'a Lwt.t = 'a Lwt.t
       and type ('a, 'b) Pervasives.result = ('a, 'b) result
       and type Chain_id.t = Chain_id.t
       and type Block_hash.t = Block_hash.t
       and type Operation_hash.t = Operation_hash.t
       and type Operation_list_hash.t = Operation_list_hash.t
       and type Operation_list_list_hash.t = Operation_list_list_hash.t
       and type Context.t = Context.t
       and type Context_hash.t = Context_hash.t
       and type Protocol_hash.t = Protocol_hash.t
       and type Time.t = Time.Protocol.t
       and type MBytes.t = MBytes.t
       and type Operation.shell_header = Operation.shell_header
       and type Operation.t = Operation.t
       and type Block_header.shell_header = Block_header.shell_header
       and type Block_header.t = Block_header.t
       and type 'a RPC_directory.t = 'a RPC_directory.t
       and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t
       and type Ed25519.Public_key.t = Ed25519.Public_key.t
       and type Ed25519.t = Ed25519.t
       and type Secp256k1.Public_key_hash.t = Secp256k1.Public_key_hash.t
       and type Secp256k1.Public_key.t = Secp256k1.Public_key.t
       and type Secp256k1.t = Secp256k1.t
       and type P256.Public_key_hash.t = P256.Public_key_hash.t
       and type P256.Public_key.t = P256.Public_key.t
       and type P256.t = P256.t
       and type Signature.public_key_hash = Signature.public_key_hash
       and type Signature.public_key = Signature.public_key
       and type Signature.t = Signature.t
       and type Signature.watermark = Signature.watermark
       and type 'a Micheline.canonical = 'a Micheline.canonical
       and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t
       and type Z.t = Z.t
       and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node
       and type Data_encoding.json_schema = Data_encoding.json_schema
       and type RPC_service.meth = RPC_service.meth
       and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t =
            ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t
       and type Error_monad.shell_error = Error_monad.error
       and type Z.t = Z.t

  type error += Ecoproto_error of Error_monad.error

  val wrap_error : 'a Error_monad.tzresult -> 'a tzresult

  module Lift (P : Updater.PROTOCOL) :
    PROTOCOL
      with type block_header_data = P.block_header_data
       and type block_header = P.block_header
       and type operation_data = P.operation_data
       and type operation_receipt = P.operation_receipt
       and type operation = P.operation
       and type validation_state = P.validation_state

  class ['chain, 'block] proto_rpc_context :
    Tezos_rpc.RPC_context.t
    -> (unit, (unit * 'chain) * 'block) RPC_path.t
    -> ['chain * 'block] RPC_context.simple

  class ['block] proto_rpc_context_of_directory :
    ('block -> RPC_context.t)
    -> RPC_context.t RPC_directory.t
    -> ['block] RPC_context.simple
end

module MakeV1 (Param : sig
  val name : string
end)
() =
struct
  include Pervasives
  module Pervasives = Pervasives
  module Compare = Compare
  module Array = Array
  module List = List

  module Bytes = struct
    include Bytes
    include EndianBytes.BigEndian
    module LE = EndianBytes.LittleEndian
  end

  module String = struct
    include String
    include EndianString.BigEndian
    module LE = EndianString.LittleEndian
  end

  module Set = Set
  module Map = Map
  module Int32 = Int32
  module Int64 = Int64
  module Nativeint = Nativeint
  module Buffer = Buffer
  module Format = Format
  module Option = Option
  module MBytes = MBytes

  module Raw_hashes = struct
    let conv f x = Bigstring.to_bytes (f (Bigstring.of_bytes x))

    let sha256 msg = conv Hacl.Hash.SHA256.digest msg

    let sha512 msg = conv Hacl.Hash.SHA512.digest msg

    let blake2b msg = Blake2B.to_bytes (Blake2B.hash_bytes [msg])
  end

  module Z = struct
    include Z

    let to_bits ?(pad_to = 0) z =
      let bits = to_bits z in
      let len = Pervasives.((numbits z + 7) / 8) in
      let full_len = Tezos_stdlib.Compare.Int.max pad_to len in
      if full_len = 0 then MBytes.create 0
      else
        let res = MBytes.create full_len in
        Bytes.fill res 0 full_len '\000' ;
        MBytes.blit_of_string bits 0 res 0 len ;
        res

    let of_bits bytes = of_bits (MBytes.to_string bytes)
  end

  module Lwt_sequence = Lwt_sequence
  module Lwt = Lwt
  module Lwt_list = Lwt_list
  module Uri = Uri
  module Data_encoding = Data_encoding
  module Time = Time.Protocol
  module Ed25519 = Ed25519
  module Secp256k1 = Secp256k1
  module P256 = P256
  module Signature = Signature

  module S = struct
    module type T = Tezos_base.S.T

    module type HASHABLE = Tezos_base.S.HASHABLE

    module type MINIMAL_HASH = S.MINIMAL_HASH

    module type B58_DATA = sig
      type t

      val to_b58check : t -> string

      val to_short_b58check : t -> string

      val of_b58check_exn : string -> t

      val of_b58check_opt : string -> t option

      type Base58.data += Data of t

      val b58check_encoding : t Base58.encoding
    end

    module type RAW_DATA = sig
      type t

      val size : int (* in bytes *)

      val to_bytes : t -> MBytes.t

      val of_bytes_opt : MBytes.t -> t option

      val of_bytes_exn : MBytes.t -> t
    end

    module type ENCODER = sig
      type t

      val encoding : t Data_encoding.t

      val rpc_arg : t RPC_arg.t
    end

    module type SET = Tezos_base.S.SET

    module type MAP = Tezos_base.S.MAP

    module type INDEXES = sig
      type t

      val to_path : t -> string list -> string list

      val of_path : string list -> t option

      val of_path_exn : string list -> t

      val prefix_path : string -> string list

      val path_length : int

      module Set : sig
        include Set.S with type elt = t

        val encoding : t Data_encoding.t
      end

      module Map : sig
        include Map.S with type key = t

        val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
      end
    end

    module type HASH = sig
      include MINIMAL_HASH

      include RAW_DATA with type t := t

      include B58_DATA with type t := t

      include ENCODER with type t := t

      include INDEXES with type t := t
    end

    module type MERKLE_TREE = sig
      type elt

      include HASH

      val compute : elt list -> t

      val empty : t

      type path = Left of path * t | Right of t * path | Op

      val compute_path : elt list -> int -> path

      val check_path : path -> elt -> t * int

      val path_encoding : path Data_encoding.t
    end

    module type SIGNATURE = sig
      module Public_key_hash : sig
        type t

        val pp : Format.formatter -> t -> unit

        val pp_short : Format.formatter -> t -> unit

        include Compare.S with type t := t

        include RAW_DATA with type t := t

        include B58_DATA with type t := t

        include ENCODER with type t := t

        include INDEXES with type t := t

        val zero : t
      end

      module Public_key : sig
        type t

        val pp : Format.formatter -> t -> unit

        include Compare.S with type t := t

        include B58_DATA with type t := t

        include ENCODER with type t := t

        val hash : t -> Public_key_hash.t
      end

      type t

      val pp : Format.formatter -> t -> unit

      include RAW_DATA with type t := t

      include Compare.S with type t := t

      include B58_DATA with type t := t

      include ENCODER with type t := t

      val zero : t

      type watermark

      (** Check a signature *)
      val check : ?watermark:watermark -> Public_key.t -> t -> MBytes.t -> bool
    end
  end

  module Error_monad = struct
    type 'a shell_tzresult = 'a Error_monad.tzresult

    type shell_error = Error_monad.error = ..

    type error_category = [`Branch | `Temporary | `Permanent]

    include Error_monad.Make (struct
      let id = Format.asprintf "proto.%s." Param.name
    end)
  end

  type error += Ecoproto_error of Error_monad.error

  module Wrapped_error_monad = struct
    type unwrapped = Error_monad.error = ..

    include (Error_monad : Error_monad_sig.S with type error := unwrapped)

    let unwrap = function
      | Ecoproto_error ecoerror ->
          Some ecoerror
      | _ ->
          None

    let wrap ecoerror = Ecoproto_error ecoerror
  end

  let () =
    let id = Format.asprintf "proto.%s.wrapper" Param.name in
    register_wrapped_error_kind
      (module Wrapped_error_monad)
      ~id
      ~title:("Error returned by protocol " ^ Param.name)
      ~description:("Wrapped error for economic protocol " ^ Param.name ^ ".")

  let wrap_error = function
    | Ok _ as ok ->
        ok
    | Error errors ->
        Error (List.map (fun error -> Ecoproto_error error) errors)

  module Chain_id = Chain_id
  module Block_hash = Block_hash
  module Operation_hash = Operation_hash
  module Operation_list_hash = Operation_list_hash
  module Operation_list_list_hash = Operation_list_list_hash
  module Context_hash = Context_hash
  module Protocol_hash = Protocol_hash
  module Blake2B = Blake2B
  module Fitness = Fitness
  module Operation = Operation
  module Block_header = Block_header
  module Protocol = Protocol
  module RPC_arg = RPC_arg
  module RPC_path = RPC_path
  module RPC_query = RPC_query
  module RPC_service = RPC_service

  module RPC_answer = struct
    type 'o t =
      [ `Ok of 'o (* 200 *)
      | `OkStream of 'o stream (* 200 *)
      | `Created of string option (* 201 *)
      | `No_content (* 204 *)
      | `Unauthorized of Error_monad.error list option (* 401 *)
      | `Forbidden of Error_monad.error list option (* 403 *)
      | `Not_found of Error_monad.error list option (* 404 *)
      | `Conflict of Error_monad.error list option (* 409 *)
      | `Error of Error_monad.error list option (* 500 *) ]

    and 'a stream = 'a Resto_directory.Answer.stream = {
      next : unit -> 'a option Lwt.t;
      shutdown : unit -> unit;
    }

    let return x = Lwt.return (`Ok x)

    let return_stream x = Lwt.return (`OkStream x)

    let not_found = Lwt.return (`Not_found None)

    let fail err = Lwt.return (`Error (Some err))
  end

  module RPC_directory = struct
    include RPC_directory

    let gen_register dir service handler =
      gen_register dir service (fun p q i ->
          handler p q i
          >>= function
          | `Ok o ->
              RPC_answer.return o
          | `OkStream s ->
              RPC_answer.return_stream s
          | `Created s ->
              Lwt.return (`Created s)
          | `No_content ->
              Lwt.return `No_content
          | `Unauthorized e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Unauthorized e)
          | `Forbidden e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Forbidden e)
          | `Not_found e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Not_found e)
          | `Conflict e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Conflict e)
          | `Error e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Error e))

    let register dir service handler =
      gen_register dir service (fun p q i ->
          handler p q i
          >>= function
          | Ok o -> RPC_answer.return o | Error e -> RPC_answer.fail e)

    let opt_register dir service handler =
      gen_register dir service (fun p q i ->
          handler p q i
          >>= function
          | Ok (Some o) ->
              RPC_answer.return o
          | Ok None ->
              RPC_answer.not_found
          | Error e ->
              RPC_answer.fail e)

    let lwt_register dir service handler =
      gen_register dir service (fun p q i ->
          handler p q i >>= fun o -> RPC_answer.return o)

    open Curry

    let register0 root s f = register root s (curry Z f)

    let register1 root s f = register root s (curry (S Z) f)

    let register2 root s f = register root s (curry (S (S Z)) f)

    let register3 root s f = register root s (curry (S (S (S Z))) f)

    let register4 root s f = register root s (curry (S (S (S (S Z)))) f)

    let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f)

    let opt_register0 root s f = opt_register root s (curry Z f)

    let opt_register1 root s f = opt_register root s (curry (S Z) f)

    let opt_register2 root s f = opt_register root s (curry (S (S Z)) f)

    let opt_register3 root s f = opt_register root s (curry (S (S (S Z))) f)

    let opt_register4 root s f =
      opt_register root s (curry (S (S (S (S Z)))) f)

    let opt_register5 root s f =
      opt_register root s (curry (S (S (S (S (S Z))))) f)

    let gen_register0 root s f = gen_register root s (curry Z f)

    let gen_register1 root s f = gen_register root s (curry (S Z) f)

    let gen_register2 root s f = gen_register root s (curry (S (S Z)) f)

    let gen_register3 root s f = gen_register root s (curry (S (S (S Z))) f)

    let gen_register4 root s f =
      gen_register root s (curry (S (S (S (S Z)))) f)

    let gen_register5 root s f =
      gen_register root s (curry (S (S (S (S (S Z))))) f)

    let lwt_register0 root s f = lwt_register root s (curry Z f)

    let lwt_register1 root s f = lwt_register root s (curry (S Z) f)

    let lwt_register2 root s f = lwt_register root s (curry (S (S Z)) f)

    let lwt_register3 root s f = lwt_register root s (curry (S (S (S Z))) f)

    let lwt_register4 root s f =
      lwt_register root s (curry (S (S (S (S Z)))) f)

    let lwt_register5 root s f =
      lwt_register root s (curry (S (S (S (S (S Z))))) f)
  end

  module RPC_context = struct
    type t = rpc_context

    class type ['pr] simple =
      object
        method call_proto_service0 :
          'm 'q 'i 'o.
          (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t ->
          'pr -> 'q -> 'i -> 'o Error_monad.shell_tzresult Lwt.t

        method call_proto_service1 :
          'm 'a 'q 'i 'o.
          (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t ->
          'pr -> 'a -> 'q -> 'i -> 'o Error_monad.shell_tzresult Lwt.t

        method call_proto_service2 :
          'm 'a 'b 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            t,
            (t * 'a) * 'b,
            'q,
            'i,
            'o )
          RPC_service.t -> 'pr -> 'a -> 'b -> 'q -> 'i ->
          'o Error_monad.shell_tzresult Lwt.t

        method call_proto_service3 :
          'm 'a 'b 'c 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            t,
            ((t * 'a) * 'b) * 'c,
            'q,
            'i,
            'o )
          RPC_service.t -> 'pr -> 'a -> 'b -> 'c -> 'q -> 'i ->
          'o Error_monad.shell_tzresult Lwt.t
      end

    let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s

    let make_call0 = (make_call0 : _ -> _ simple -> _ :> _ -> _ #simple -> _)

    let make_call1 s (ctxt : _ simple) = ctxt#call_proto_service1 s

    let make_call1 = (make_call1 : _ -> _ simple -> _ :> _ -> _ #simple -> _)

    let make_call2 s (ctxt : _ simple) = ctxt#call_proto_service2 s

    let make_call2 = (make_call2 : _ -> _ simple -> _ :> _ -> _ #simple -> _)

    let make_call3 s (ctxt : _ simple) = ctxt#call_proto_service3 s

    let make_call3 = (make_call3 : _ -> _ simple -> _ :> _ -> _ #simple -> _)

    let make_opt_call0 s ctxt block q i =
      make_call0 s ctxt block q i
      >>= function
      | Error [RPC_context.Not_found _] ->
          Lwt.return_ok None
      | Error _ as v ->
          Lwt.return v
      | Ok v ->
          Lwt.return_ok (Some v)

    let make_opt_call1 s ctxt block a1 q i =
      make_call1 s ctxt block a1 q i
      >>= function
      | Error [RPC_context.Not_found _] ->
          Lwt.return_ok None
      | Error _ as v ->
          Lwt.return v
      | Ok v ->
          Lwt.return_ok (Some v)

    let make_opt_call2 s ctxt block a1 a2 q i =
      make_call2 s ctxt block a1 a2 q i
      >>= function
      | Error [RPC_context.Not_found _] ->
          Lwt.return_ok None
      | Error _ as v ->
          Lwt.return v
      | Ok v ->
          Lwt.return_ok (Some v)

    let make_opt_call3 s ctxt block a1 a2 a3 q i =
      make_call3 s ctxt block a1 a2 a3 q i
      >>= function
      | Error [RPC_context.Not_found _] ->
          Lwt.return_ok None
      | Error _ as v ->
          Lwt.return v
      | Ok v ->
          Lwt.return_ok (Some v)
  end

  module Micheline = struct
    include Micheline

    let canonical_encoding_v1 = canonical_encoding_v1

    let canonical_encoding = canonical_encoding_v0
  end

  module Logging = Internal_event.Legacy_logging.Make (Param)

  module Updater = struct
    type nonrec validation_result = validation_result = {
      context : Context.t;
      fitness : Fitness.t;
      message : string option;
      max_operations_ttl : int;
      last_allowed_fork_level : Int32.t;
    }

    type nonrec quota = quota = {max_size : int; max_op : int option}

    type nonrec rpc_context = rpc_context = {
      block_hash : Block_hash.t;
      block_header : Block_header.shell_header;
      context : Context.t;
    }

    let activate = Context.set_protocol

    let fork_test_chain = Context.fork_test_chain

    module type PROTOCOL =
      T
        with type context := Context.t
         and type quota := quota
         and type validation_result := validation_result
         and type rpc_context := rpc_context
         and type 'a tzresult := 'a Error_monad.tzresult
  end

  module Base58 = struct
    include Tezos_crypto.Base58

    let simple_encode enc s = simple_encode enc s

    let simple_decode enc s = simple_decode enc s

    include Make (struct
      type context = Context.t
    end)

    let decode s = decode s
  end

  module Context = struct
    include Context

    let fold_keys s k ~init ~f =
      let rec loop k acc =
        fold s k ~init:acc ~f:(fun file acc ->
            match file with `Key k -> f k acc | `Dir k -> loop k acc)
      in
      loop k init

    let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

    let register_resolver = Base58.register_resolver

    let complete ctxt s = Base58.complete ctxt s
  end

  module Lift (P : Updater.PROTOCOL) = struct
    include P

    let begin_partial_application ~chain_id ~ancestor_context
        ~predecessor_timestamp ~predecessor_fitness raw_block =
      begin_partial_application
        ~chain_id
        ~ancestor_context
        ~predecessor_timestamp
        ~predecessor_fitness
        raw_block
      >|= wrap_error

    let begin_application ~chain_id ~predecessor_context ~predecessor_timestamp
        ~predecessor_fitness raw_block =
      begin_application
        ~chain_id
        ~predecessor_context
        ~predecessor_timestamp
        ~predecessor_fitness
        raw_block
      >|= wrap_error

    let begin_construction ~chain_id ~predecessor_context
        ~predecessor_timestamp ~predecessor_level ~predecessor_fitness
        ~predecessor ~timestamp ?protocol_data () =
      begin_construction
        ~chain_id
        ~predecessor_context
        ~predecessor_timestamp
        ~predecessor_level
        ~predecessor_fitness
        ~predecessor
        ~timestamp
        ?protocol_data
        ()
      >|= wrap_error

    let current_context c = current_context c >|= wrap_error

    let apply_operation c o = apply_operation c o >|= wrap_error

    let finalize_block c = finalize_block c >|= wrap_error

    let init c bh = init c bh >|= wrap_error
  end

  class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t)
    (prefix : (unit, (unit * 'chain) * 'block) RPC_path.t) =
    object
      method call_proto_service0
          : 'm 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              RPC_context.t,
              'q,
              'i,
              'o )
            RPC_service.t -> 'chain * 'block -> 'q -> 'i -> 'o tzresult Lwt.t =
        fun s (chain, block) q i ->
          let s = RPC_service.subst0 s in
          let s = RPC_service.prefix prefix s in
          t#call_service s (((), chain), block) q i

      method call_proto_service1
          : 'm 'a 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              RPC_context.t * 'a,
              'q,
              'i,
              'o )
            RPC_service.t -> 'chain * 'block -> 'a -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s (chain, block) a1 q i ->
          let s = RPC_service.subst1 s in
          let s = RPC_service.prefix prefix s in
          t#call_service s ((((), chain), block), a1) q i

      method call_proto_service2
          : 'm 'a 'b 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              (RPC_context.t * 'a) * 'b,
              'q,
              'i,
              'o )
            RPC_service.t -> 'chain * 'block -> 'a -> 'b -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s (chain, block) a1 a2 q i ->
          let s = RPC_service.subst2 s in
          let s = RPC_service.prefix prefix s in
          t#call_service s (((((), chain), block), a1), a2) q i

      method call_proto_service3
          : 'm 'a 'b 'c 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              ((RPC_context.t * 'a) * 'b) * 'c,
              'q,
              'i,
              'o )
            RPC_service.t -> 'chain * 'block -> 'a -> 'b -> 'c -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s (chain, block) a1 a2 a3 q i ->
          let s = RPC_service.subst3 s in
          let s = RPC_service.prefix prefix s in
          t#call_service s ((((((), chain), block), a1), a2), a3) q i
    end

  class ['block] proto_rpc_context_of_directory conv dir :
    ['block] RPC_context.simple =
    let lookup = new Tezos_rpc.RPC_context.of_directory dir in
    object
      method call_proto_service0
          : 'm 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              RPC_context.t,
              'q,
              'i,
              'o )
            RPC_service.t -> 'block -> 'q -> 'i -> 'o tzresult Lwt.t =
        fun s block q i ->
          let rpc_context = conv block in
          lookup#call_service s rpc_context q i

      method call_proto_service1
          : 'm 'a 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              RPC_context.t * 'a,
              'q,
              'i,
              'o )
            RPC_service.t -> 'block -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t =
        fun s block a1 q i ->
          let rpc_context = conv block in
          lookup#call_service s (rpc_context, a1) q i

      method call_proto_service2
          : 'm 'a 'b 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              (RPC_context.t * 'a) * 'b,
              'q,
              'i,
              'o )
            RPC_service.t -> 'block -> 'a -> 'b -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s block a1 a2 q i ->
          let rpc_context = conv block in
          lookup#call_service s ((rpc_context, a1), a2) q i

      method call_proto_service3
          : 'm 'a 'b 'c 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              ((RPC_context.t * 'a) * 'b) * 'c,
              'q,
              'i,
              'o )
            RPC_service.t -> 'block -> 'a -> 'b -> 'c -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s block a1 a2 a3 q i ->
          let rpc_context = conv block in
          lookup#call_service s (((rpc_context, a1), a2), a3) q i
    end
end
src/lib_protocol_environment/tezos_protocol_environment.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Error_monad.

Module CONTEXT.
  Record signature {t : Type} := {
    t := t;
    key := list string;
    value := Tezos_base__TzPervasives.MBytes.t;
    mem : t -> key -> Lwt.t bool;
    dir_mem : t -> key -> Lwt.t bool;
    get : t -> key -> Lwt.t (option value);
    set : t -> key -> value -> Lwt.t t;
    copy : t -> key -> key -> Lwt.t (option t);
    del : t -> key -> Lwt.t t;
    remove_rec : t -> key -> Lwt.t t;
    fold : forall {a variant : Type}, t ->
      key -> a -> (variant -> a -> Lwt.t a) -> Lwt.t a;
    set_protocol : t -> Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t t;
    fork_test_chain : t ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Tezos_base__TzPervasives.Time.Protocol.t -> Lwt.t t;
  }.
  Arguments signature : clear implicits.
End CONTEXT.

Module Context.
  Definition key := list string.
  
  Definition value := Tezos_base__TzPervasives.MBytes.t.
  
  Definition ops (ctxt : Type) := {_ : unit & CONTEXT.signature ctxt}.
  
  Definition kind := False.
  
  Inductive t : Type :=
  | Context : forall {a : Type}, (kind a) -> a -> (ops a) -> t.
  
  Definition mem (function_parameter : t) : (list string) -> Lwt.t bool :=
    match function_parameter with
    | Context {| ctxt := ctxt; ops := Ops |} =>
      let Ops := projT2 Ops in
      fun key => Ops.(CONTEXT.mem) ctxt key
    end.
  
  Definition set (function_parameter : t)
    : (list string) -> Tezos_base__TzPervasives.MBytes.t -> Lwt.t t :=
    match function_parameter with
    | Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} =>
      let Ops := projT2 Ops in
      fun key =>
        fun value =>
          Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
            (Ops.(CONTEXT.set) ctxt key value)
            (fun ctxt =>
              Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |}))
    end.
  
  Definition dir_mem (function_parameter : t) : (list string) -> Lwt.t bool :=
    match function_parameter with
    | Context {| ctxt := ctxt; ops := Ops |} =>
      let Ops := projT2 Ops in
      fun key => Ops.(CONTEXT.dir_mem) ctxt key
    end.
  
  Definition get (function_parameter : t)
    : (list string) -> Lwt.t (option Tezos_base__TzPervasives.MBytes.t) :=
    match function_parameter with
    | Context {| ctxt := ctxt; ops := Ops |} =>
      let Ops := projT2 Ops in
      fun key => Ops.(CONTEXT.get) ctxt key
    end.
  
  Definition copy (function_parameter : t)
    : (list string) -> (list string) -> Lwt.t (option t) :=
    match function_parameter with
    | Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} =>
      let Ops := projT2 Ops in
      fun from =>
        fun to_ =>
          Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
            (Ops.(CONTEXT.copy) ctxt from to_)
            (fun function_parameter =>
              match function_parameter with
              | Some ctxt =>
                Lwt.return_some
                  (Context {| kind := kind; ctxt := ctxt; ops := ops |})
              | None => Lwt.return_none
              end)
    end.
  
  Definition del (function_parameter : t) : (list string) -> Lwt.t t :=
    match function_parameter with
    | Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} =>
      let Ops := projT2 Ops in
      fun key =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (Ops.(CONTEXT.del) ctxt key)
          (fun ctxt =>
            Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |}))
    end.
  
  Definition remove_rec (function_parameter : t) : (list string) -> Lwt.t t :=
    match function_parameter with
    | Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} =>
      let Ops := projT2 Ops in
      fun key =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (Ops.(CONTEXT.remove_rec) ctxt key)
          (fun ctxt =>
            Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |}))
    end.
  
  Definition fold {A : Type} (function_parameter : t)
    : (list string) -> A -> (variant -> A -> Lwt.t A) -> Lwt.t A :=
    match function_parameter with
    | Context {| ctxt := ctxt; ops := Ops |} =>
      let Ops := projT2 Ops in
      fun key => fun init => fun f => Ops.(CONTEXT.fold) ctxt key init f
    end.
  
  Definition set_protocol (function_parameter : t)
    : Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t t :=
    match function_parameter with
    | Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} =>
      let Ops := projT2 Ops in
      fun protocol_hash =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
          (Ops.(CONTEXT.set_protocol) ctxt protocol_hash)
          (fun ctxt =>
            Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |}))
    end.
  
  Definition fork_test_chain (function_parameter : t)
    : Tezos_base__TzPervasives.Protocol_hash.t ->
      Tezos_base__TzPervasives.Time.Protocol.t -> Lwt.t t :=
    match function_parameter with
    | Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} =>
      let Ops := projT2 Ops in
      fun protocol =>
        fun expiration =>
          Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
            (Ops.(CONTEXT.fork_test_chain) ctxt protocol expiration)
            (fun ctxt =>
              Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |}))
    end.
End Context.

Record validation_result := {
  context : Context.t;
  fitness : Tezos_base__TzPervasives.Fitness.t;
  message : option string;
  max_operations_ttl : Z;
  last_allowed_fork_level : Stdlib.Int32.t }.

Record quota := {
  max_size : Z;
  max_op : option Z }.

Record rpc_context := {
  block_hash : Tezos_base__TzPervasives.Block_hash.t;
  block_header : Tezos_base__TzPervasives.Block_header.shell_header;
  context : Context.t }.

Module T.
  Record signature {context quota validation_result rpc_context tzresult
    block_header_data block_header block_header_metadata operation_data
    operation_receipt operation validation_state : Type} := {
    context := context;
    quota := quota;
    validation_result := validation_result;
    rpc_context := rpc_context;
    polymorphic_abstract_type;
    max_block_length : Z;
    max_operation_data_length : Z;
    validation_passes : list quota;
    block_header_data := block_header_data;
    block_header_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
      block_header_data;
    block_header := block_header;
    block_header_metadata := block_header_metadata;
    block_header_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.t
      block_header_metadata;
    operation_data := operation_data;
    operation_receipt := operation_receipt;
    operation := operation;
    operation_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
      operation_data;
    operation_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
      operation_receipt;
    operation_data_and_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
      (operation_data * operation_receipt);
    acceptable_passes : operation -> list Z;
    compare_operations : operation -> operation -> Z;
    validation_state := validation_state;
    current_context : validation_state -> Lwt.t (tzresult context);
    begin_partial_application : Tezos_base__TzPervasives.Chain_id.t ->
      context ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Fitness.t ->
            block_header -> Lwt.t (tzresult validation_state);
    begin_application : Tezos_base__TzPervasives.Chain_id.t ->
      context ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Fitness.t ->
            block_header -> Lwt.t (tzresult validation_state);
    begin_construction : Tezos_base__TzPervasives.Chain_id.t ->
      context ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Stdlib.Int32.t ->
            Tezos_base__TzPervasives.Fitness.t ->
              Tezos_base__TzPervasives.Block_hash.t ->
                Tezos_base__TzPervasives.Time.Protocol.t ->
                  (option block_header_data) ->
                    unit -> Lwt.t (tzresult validation_state);
    apply_operation : validation_state ->
      operation -> Lwt.t (tzresult (validation_state * operation_receipt));
    finalize_block : validation_state ->
      Lwt.t (tzresult (validation_result * block_header_metadata));
    rpc_services : Tezos_base__TzPervasives.RPC_directory.t rpc_context;
    init : context ->
      Tezos_base__TzPervasives.Block_header.shell_header ->
        Lwt.t (tzresult validation_result);
  }.
  Arguments signature : clear implicits.
End T.

Module V1.
  Record signature {Pervasives_ref Data_encoding_field Data_encoding_case_tag
    Data_encoding_case Data_encoding_Binary_write_error Error_monad_error
    Error_monad_error_info RPC_arg_t RPC_arg_descr RPC_arg_eq RPC_query_t
    RPC_query_field RPC_query_open_query RPC_answer_stream RPC_directory_step
    RPC_directory_conflict Base58_encoding Base58_data
    Ed25519_Public_key_hash_Set_t Ed25519_Public_key_hash_Map_t
    Secp256k1_Public_key_hash_Set_t Secp256k1_Public_key_hash_Map_t
    P256_Public_key_hash_Set_t P256_Public_key_hash_Map_t Chain_id_Set_t
    Chain_id_Map_t Signature_Public_key_hash_Set_t
    Signature_Public_key_hash_Map_t Block_hash_Set_t Block_hash_Map_t
    Operation_hash_Set_t Operation_hash_Map_t Operation_list_hash_Set_t
    Operation_list_hash_Map_t Operation_list_hash_path
    Operation_list_list_hash_Set_t Operation_list_list_hash_Map_t
    Operation_list_list_hash_path Protocol_hash_Set_t Protocol_hash_Map_t
    Context_hash_Set_t Context_hash_Map_t Protocol_t Protocol_component
    Protocol_env_version Updater_validation_result Updater_quota
    Updater_rpc_context : Type} := {
    include;
    extensible_type;
    wrap_error : forall {a : Type}, (Error_monad.tzresult a) ->
      Tezos_base__TzPervasives.Error_monad.tzresult a;
    Lift : functor;
    class;
    class;
  }.
  Arguments signature : clear implicits.
End V1.
src/lib_protocol_environment/tezos_protocol_environment.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module type CONTEXT = sig
  type t

  type key = string list

  type value = MBytes.t

  val mem : t -> key -> bool Lwt.t

  val dir_mem : t -> key -> bool Lwt.t

  val get : t -> key -> value option Lwt.t

  val set : t -> key -> value -> t Lwt.t

  val copy : t -> from:key -> to_:key -> t option Lwt.t

  val del : t -> key -> t Lwt.t

  val remove_rec : t -> key -> t Lwt.t

  val fold :
    t ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val set_protocol : t -> Protocol_hash.t -> t Lwt.t

  val fork_test_chain :
    t -> protocol:Protocol_hash.t -> expiration:Time.Protocol.t -> t Lwt.t
end

module Context : sig
  type 'ctxt ops = (module CONTEXT with type t = 'ctxt)

  type _ kind = ..

  type t = Context : {kind : 'a kind; ctxt : 'a; ops : 'a ops} -> t

  include CONTEXT with type t := t
end

type validation_result = {
  context : Context.t;
  fitness : Fitness.t;
  message : string option;
  max_operations_ttl : int;
  last_allowed_fork_level : Int32.t;
}

type quota = {max_size : int; max_op : int option}

type rpc_context = {
  block_hash : Block_hash.t;
  block_header : Block_header.shell_header;
  context : Context.t;
}

module type T = sig
  type context

  type quota

  type validation_result

  type rpc_context

  type 'a tzresult

  val max_block_length : int

  val max_operation_data_length : int

  val validation_passes : quota list

  type block_header_data

  val block_header_data_encoding : block_header_data Data_encoding.t

  type block_header = {
    shell : Block_header.shell_header;
    protocol_data : block_header_data;
  }

  type block_header_metadata

  val block_header_metadata_encoding : block_header_metadata Data_encoding.t

  type operation_data

  type operation_receipt

  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  val operation_data_encoding : operation_data Data_encoding.t

  val operation_receipt_encoding : operation_receipt Data_encoding.t

  val operation_data_and_receipt_encoding :
    (operation_data * operation_receipt) Data_encoding.t

  val acceptable_passes : operation -> int list

  val compare_operations : operation -> operation -> int

  type validation_state

  val current_context : validation_state -> context tzresult Lwt.t

  val begin_partial_application :
    chain_id:Chain_id.t ->
    ancestor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_fitness:Fitness.t ->
    block_header ->
    validation_state tzresult Lwt.t

  val begin_application :
    chain_id:Chain_id.t ->
    predecessor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_fitness:Fitness.t ->
    block_header ->
    validation_state tzresult Lwt.t

  val begin_construction :
    chain_id:Chain_id.t ->
    predecessor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_level:Int32.t ->
    predecessor_fitness:Fitness.t ->
    predecessor:Block_hash.t ->
    timestamp:Time.Protocol.t ->
    ?protocol_data:block_header_data ->
    unit ->
    validation_state tzresult Lwt.t

  val apply_operation :
    validation_state ->
    operation ->
    (validation_state * operation_receipt) tzresult Lwt.t

  val finalize_block :
    validation_state ->
    (validation_result * block_header_metadata) tzresult Lwt.t

  val rpc_services : rpc_context RPC_directory.t

  val init :
    context -> Block_header.shell_header -> validation_result tzresult Lwt.t
end

module type PROTOCOL =
  T
    with type context := Context.t
     and type quota := quota
     and type validation_result := validation_result
     and type rpc_context := rpc_context
     and type 'a tzresult := 'a Error_monad.tzresult

module type V1 = sig
  include
    Tezos_protocol_environment_sigs.V1.T
      with type Format.formatter = Format.formatter
       and type 'a Data_encoding.t = 'a Data_encoding.t
       and type 'a Data_encoding.lazy_t = 'a Data_encoding.lazy_t
       and type 'a Lwt.t = 'a Lwt.t
       and type ('a, 'b) Pervasives.result = ('a, 'b) result
       and type Chain_id.t = Chain_id.t
       and type Block_hash.t = Block_hash.t
       and type Operation_hash.t = Operation_hash.t
       and type Operation_list_hash.t = Operation_list_hash.t
       and type Operation_list_list_hash.t = Operation_list_list_hash.t
       and type Context.t = Context.t
       and type Context_hash.t = Context_hash.t
       and type Protocol_hash.t = Protocol_hash.t
       and type Time.t = Time.Protocol.t
       and type MBytes.t = MBytes.t
       and type Operation.shell_header = Operation.shell_header
       and type Operation.t = Operation.t
       and type Block_header.shell_header = Block_header.shell_header
       and type Block_header.t = Block_header.t
       and type 'a RPC_directory.t = 'a RPC_directory.t
       and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t
       and type Ed25519.Public_key.t = Ed25519.Public_key.t
       and type Ed25519.t = Ed25519.t
       and type Secp256k1.Public_key_hash.t = Secp256k1.Public_key_hash.t
       and type Secp256k1.Public_key.t = Secp256k1.Public_key.t
       and type Secp256k1.t = Secp256k1.t
       and type P256.Public_key_hash.t = P256.Public_key_hash.t
       and type P256.Public_key.t = P256.Public_key.t
       and type P256.t = P256.t
       and type Signature.public_key_hash = Signature.public_key_hash
       and type Signature.public_key = Signature.public_key
       and type Signature.t = Signature.t
       and type Signature.watermark = Signature.watermark
       and type 'a Micheline.canonical = 'a Micheline.canonical
       and type Z.t = Z.t
       and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node
       and type Data_encoding.json_schema = Data_encoding.json_schema
       and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t
       and type RPC_service.meth = RPC_service.meth
       and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t =
            ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t
       and type Error_monad.shell_error = Error_monad.error
       and type Z.t = Z.t

  type error += Ecoproto_error of Error_monad.error

  val wrap_error : 'a Error_monad.tzresult -> 'a tzresult

  module Lift (P : Updater.PROTOCOL) :
    PROTOCOL
      with type block_header_data = P.block_header_data
       and type block_header = P.block_header
       and type operation_data = P.operation_data
       and type operation_receipt = P.operation_receipt
       and type operation = P.operation
       and type validation_state = P.validation_state

  class ['chain, 'block] proto_rpc_context :
    Tezos_rpc.RPC_context.t
    -> (unit, (unit * 'chain) * 'block) RPC_path.t
    -> ['chain * 'block] RPC_context.simple

  class ['block] proto_rpc_context_of_directory :
    ('block -> RPC_context.t)
    -> RPC_context.t RPC_directory.t
    -> ['block] RPC_context.simple
end

module MakeV1 (Param : sig
  val name : string
end)
() :
  V1
    with type Context.t = Context.t
     and type Updater.validation_result = validation_result
     and type Updater.quota = quota
     and type Updater.rpc_context = rpc_context
src/lib_protocol_environment/tezos_protocol_environment.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

Module Context.
  Definition ops (ctxt : Type) := {_ : unit & CONTEXT.signature ctxt}.
  
  Definition kind := False.
  
  Inductive t : Type :=
  | Context : forall {a : Type}, (kind a) -> a -> (ops a) -> t.
  
  include
End Context.

Record validation_result := {
  context : Context.t;
  fitness : Tezos_base__TzPervasives.Fitness.t;
  message : option string;
  max_operations_ttl : Z;
  last_allowed_fork_level : Stdlib.Int32.t }.

Record quota := {
  max_size : Z;
  max_op : option Z }.

Record rpc_context := {
  block_hash : Tezos_base__TzPervasives.Block_hash.t;
  block_header : Tezos_base__TzPervasives.Block_header.shell_header;
  context : Context.t }.

module_type

module_type

module_type

unhandled_module
src/lib_protocol_updater/registered_protocol.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type T = sig
  module P : sig
    val hash : Protocol_hash.t

    include Tezos_protocol_environment.PROTOCOL
  end

  include module type of struct
    include P
  end

  module Block_services : module type of struct
    include Block_services.Make (P) (P)
  end

  val complete_b58prefix :
    Tezos_protocol_environment.Context.t -> string -> string list Lwt.t
end

type t = (module T)

let build_v1 hash =
  match Tezos_protocol_registerer.Registerer.get hash with
  | None ->
      None
  | Some protocol ->
      let (module F) = protocol in
      let module Name = struct
        let name = Protocol_hash.to_b58check hash
      end in
      let module Env = Tezos_protocol_environment.MakeV1 (Name) () in
      Some
        ( module struct
          module Raw = F (Env)

          module P = struct
            let hash = hash

            include Env.Lift (Raw)
          end

          include P
          module Block_services = Block_services.Make (P) (P)

          let complete_b58prefix = Env.Context.complete
        end : T )

module VersionTable = Protocol_hash.Table

let versions : (module T) VersionTable.t = VersionTable.create 20

let sources : Protocol.t VersionTable.t = VersionTable.create 20

let mem hash =
  VersionTable.mem versions hash
  || Tezos_protocol_registerer.Registerer.mem hash

let get hash =
  try Some (VersionTable.find versions hash)
  with Not_found -> (
    match build_v1 hash with
    | Some proto ->
        VersionTable.add versions hash proto ;
        Some proto
    | None ->
        None )

let list () = VersionTable.fold (fun _ p acc -> p :: acc) versions []

let list_embedded () = VersionTable.fold (fun k _ acc -> k :: acc) sources []

let get_embedded_sources_exn hash = VersionTable.find sources hash

let get_embedded_sources hash =
  try Some (get_embedded_sources_exn hash) with Not_found -> None

module Register_embedded
    (Env : Tezos_protocol_environment.V1)
    (Proto : Env.Updater.PROTOCOL) (Source : sig
      val hash : Protocol_hash.t option

      val sources : Protocol.t
    end) =
struct
  let hash =
    match Source.hash with
    | None ->
        Protocol.hash Source.sources
    | Some hash ->
        hash

  module Self = struct
    module P = struct
      let hash = hash

      include Env.Lift (Proto)
    end

    include P
    module Block_services = Block_services.Make (P) (P)

    let complete_b58prefix = Env.Context.complete
  end

  let () =
    VersionTable.add sources hash Source.sources ;
    VersionTable.add versions hash (module Self : T)

  include Self
end
src/lib_protocol_updater/registered_protocol.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module T.
  Record signature {P_block_header_data P_block_header P_block_header_metadata
    P_operation_data P_operation_receipt P_operation P_validation_state : Type}
    := {
    P : signature;
    include;
    Block_services : typeof;
    complete_b58prefix : Tezos_protocol_environment.Context.t ->
      string -> Lwt.t (list string);
  }.
  Arguments signature : clear implicits.
End T.

Definition t :=
  {'(P_block_header_data, P_block_header, P_block_header_metadata,
    P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
    &
    T.signature P_block_header_data P_block_header P_block_header_metadata
      P_operation_data P_operation_receipt P_operation P_validation_state}.

Definition build_v1 (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  : option
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      T.signature P_block_header_data P_block_header P_block_header_metadata
        P_operation_data P_operation_receipt P_operation P_validation_state} :=
  match Tezos_protocol_registerer.Registerer.get hash with
  | None => None
  | Some protocol =>
    let F := protocol in
    let F := projT2 F in
    let Name :=
      existT _ _
        {|
          unknown_signature_name.name :=
            Tezos_base__TzPervasives.Protocol_hash.to_b58check hash
          |} in
    let Env := unsupported_functor_application in
    Some
      (existT _ ((((((_, _), _), _), _), _), _)
        {|
          T.Raw := unsupported_functor_application;
          T.P :=
            existT _ _
              {|
                unknown_signature_name.hash := hash
                |};
          T.Block_services := unsupported_functor_application;
          T.complete_b58prefix := Env.Context.complete
          |})
  end.

Definition versions
  : VersionTable.t
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      T.signature P_block_header_data P_block_header P_block_header_metadata
        P_operation_data P_operation_receipt P_operation P_validation_state} :=
  VersionTable.create 20.

Definition sources : VersionTable.t Tezos_base__TzPervasives.Protocol.t :=
  VersionTable.create 20.

Definition mem (hash : VersionTable.key) : bool :=
  orb (VersionTable.mem versions hash)
    (Tezos_protocol_registerer.Registerer.mem hash).

Definition get (hash : VersionTable.key)
  : option
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      T.signature P_block_header_data P_block_header P_block_header_metadata
        P_operation_data P_operation_receipt P_operation P_validation_state} :=
  try.

Definition list (function_parameter : unit)
  : list
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      T.signature P_block_header_data P_block_header P_block_header_metadata
        P_operation_data P_operation_receipt P_operation P_validation_state} :=
  match function_parameter with
  | tt =>
    VersionTable.fold
      (fun function_parameter =>
        match function_parameter with
        | _ => fun p => fun acc => cons p acc
        end) versions []
  end.

Definition list_embedded (function_parameter : unit) : list VersionTable.key :=
  match function_parameter with
  | tt =>
    VersionTable.fold
      (fun k =>
        fun function_parameter =>
          match function_parameter with
          | _ => fun acc => cons k acc
          end) sources []
  end.

Definition get_embedded_sources_exn (hash : VersionTable.key)
  : Tezos_base__TzPervasives.Protocol.t := VersionTable.find sources hash.

Definition get_embedded_sources (hash : VersionTable.key)
  : option Tezos_base__TzPervasives.Protocol.t := try.
src/lib_protocol_updater/registered_protocol.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type T = sig
  module P : sig
    val hash : Protocol_hash.t

    include Tezos_protocol_environment.PROTOCOL
  end

  include module type of struct
    include P
  end

  module Block_services : module type of struct
    include Block_services.Make (P) (P)
  end

  val complete_b58prefix :
    Tezos_protocol_environment.Context.t -> string -> string list Lwt.t
end

type t = (module T)

val mem : Protocol_hash.t -> bool

val list : unit -> t list

val get : Protocol_hash.t -> t option

val list_embedded : unit -> Protocol_hash.t list

val get_embedded_sources : Protocol_hash.t -> Protocol.t option

val get_embedded_sources_exn : Protocol_hash.t -> Protocol.t

module Register_embedded
    (Env : Tezos_protocol_environment.V1)
    (Proto : Env.Updater.PROTOCOL) (Source : sig
      val hash : Protocol_hash.t option

      val sources : Protocol.t
    end) :
  T
    with type P.block_header_data = Proto.block_header_data
     and type P.operation_data = Proto.operation_data
     and type P.operation_receipt = Proto.operation_receipt
     and type P.validation_state = Proto.validation_state
src/lib_protocol_updater/registered_protocol.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

Definition t :=
  {'(P_block_header_data, P_block_header, P_block_header_metadata,
    P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
    &
    T.signature P_block_header_data P_block_header P_block_header_metadata
      P_operation_data P_operation_receipt P_operation P_validation_state}.

Parameter mem : Tezos_base__TzPervasives.Protocol_hash.t -> bool.

Parameter list : unit -> list t.

Parameter get : Tezos_base__TzPervasives.Protocol_hash.t -> option t.

Parameter list_embedded : unit -> list Tezos_base__TzPervasives.Protocol_hash.t.

Parameter get_embedded_sources :
Tezos_base__TzPervasives.Protocol_hash.t ->
  option Tezos_base__TzPervasives.Protocol.t.

Parameter get_embedded_sources_exn :
Tezos_base__TzPervasives.Protocol_hash.t -> Tezos_base__TzPervasives.Protocol.t.

unhandled_module
src/lib_protocol_updater/updater.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Updater_logging

let ( // ) = Filename.concat

(** Compiler *)

let datadir = ref None

let get_datadir () =
  match !datadir with
  | None ->
      fatal_error "Node not initialized" ;
      Lwt_exit.exit 1
  | Some m ->
      m

let init dir = datadir := Some dir

let compiler_name = "tezos-protocol-compiler"

let do_compile hash p =
  assert (p.Protocol.expected_env = V1) ;
  let datadir = get_datadir () in
  let source_dir = datadir // Protocol_hash.to_short_b58check hash // "src" in
  let log_file = datadir // Protocol_hash.to_short_b58check hash // "LOG" in
  let plugin_file =
    datadir
    // Protocol_hash.to_short_b58check hash
    // Format.asprintf "protocol_%a" Protocol_hash.pp hash
  in
  Tezos_base_unix.Protocol_files.write_dir source_dir ~hash p
  >>=? (fun () ->
         let compiler_command =
           ( Sys.executable_name,
             Array.of_list
               [compiler_name; "-register"; "-o"; plugin_file; source_dir] )
         in
         let fd =
           Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644)
         in
         Lwt_process.exec
           ~stdin:`Close
           ~stdout:(`FD_copy fd)
           ~stderr:(`FD_move fd)
           compiler_command
         >>= return)
  >>= function
  | Error err ->
      log_error "Error %a" pp_print_error err ;
      Lwt.return_false
  | Ok (Unix.WSIGNALED _ | Unix.WSTOPPED _) ->
      log_error "INTERRUPTED COMPILATION (%s)" log_file ;
      Lwt.return_false
  | Ok (Unix.WEXITED x) when x <> 0 ->
      log_error "COMPILATION ERROR (%s)" log_file ;
      Lwt.return_false
  | Ok (Unix.WEXITED _) -> (
    try
      Dynlink.loadfile_private (plugin_file ^ ".cmxs") ;
      Lwt.return_true
    with Dynlink.Error err ->
      log_error
        "Can't load plugin: %s (%s)"
        (Dynlink.error_message err)
        plugin_file ;
      Lwt.return_false )

let compile hash p =
  if Tezos_protocol_registerer.Registerer.mem hash then Lwt.return_true
  else
    do_compile hash p
    >>= fun success ->
    let loaded = Tezos_protocol_registerer.Registerer.mem hash in
    if success && not loaded then
      log_error "Internal error while compiling %a" Protocol_hash.pp hash ;
    Lwt.return loaded
src/lib_protocol_updater/updater.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_updater.Updater_logging.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition datadir : Stdlib.ref (option string) := Stdlib.ref None.

Definition get_datadir (function_parameter : unit) : string :=
  match function_parameter with
  | tt =>
    match Stdlib.op_exclamation datadir with
    | None =>
      Tezos_protocol_updater.Updater_logging.fatal_error
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Node not initialized" % string
            CamlinternalFormatBasics.End_of_format)
          "Node not initialized" % string);
      Tezos_stdlib_unix.Lwt_exit.exit 1
    | Some m => m
    end
  end.

Definition init (dir : string) : unit := Stdlib.op_colon_eq datadir (Some dir).

Definition compiler_name : string := "tezos-protocol-compiler" % string.

Definition do_compile
  (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  (p : Tezos_base__TzPervasives.Protocol.t) : Lwt.t bool :=
  equiv_decb (Protocol.expected_env p) V1;
  let datadir := get_datadir tt in
  let source_dir :=
    op_div_div
      (op_div_div datadir
        (Tezos_base__TzPervasives.Protocol_hash.to_short_b58check hash))
      "src" % string in
  let log_file :=
    op_div_div
      (op_div_div datadir
        (Tezos_base__TzPervasives.Protocol_hash.to_short_b58check hash))
      "LOG" % string in
  let plugin_file :=
    op_div_div
      (op_div_div datadir
        (Tezos_base__TzPervasives.Protocol_hash.to_short_b58check hash))
      (Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "protocol_" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "protocol_%a" % string)
        Tezos_base__TzPervasives.Protocol_hash.pp hash) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base_unix.Protocol_files.write_dir source_dir (Some hash) p)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let compiler_command :=
            (Stdlib.Sys.executable_name,
              (Stdlib.Array.of_list
                (cons compiler_name
                  (cons "-register" % string
                    (cons "-o" % string (cons plugin_file (cons source_dir [])))))))
            in
          let fd :=
            Unix.openfile log_file
              (cons O_WRONLY (cons O_CREAT (cons O_TRUNC []))) 420 in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Lwt_process.exec None None (Some variant) (Some variant)
              (Some variant) compiler_command) Tezos_base__TzPervasives._return
        end))
    (fun function_parameter =>
      match function_parameter with
      | inr err =>
        Tezos_protocol_updater.Updater_logging.log_error
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Error " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "Error %a" % string)
          Tezos_base__TzPervasives.pp_print_error err;
        Lwt.return_false
      | inl (Unix.WSIGNALED _ | Unix.WSTOPPED _) =>
        Tezos_protocol_updater.Updater_logging.log_error
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "INTERRUPTED COMPILATION (" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))
            "INTERRUPTED COMPILATION (%s)" % string) log_file;
        Lwt.return_false
      | inl (Unix.WEXITED x) =>
        Tezos_protocol_updater.Updater_logging.log_error
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "COMPILATION ERROR (" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))
            "COMPILATION ERROR (%s)" % string) log_file;
        Lwt.return_false
      | inl (Unix.WEXITED _) => try
      end).

Definition compile
  (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  (p : Tezos_base__TzPervasives.Protocol.t) : Lwt.t bool :=
  if Tezos_protocol_registerer.Registerer.mem hash then
    Lwt.return_true
  else
    Tezos_base__TzPervasives.op_gt_gt_eq (do_compile hash p)
      (fun success =>
        let loaded := Tezos_protocol_registerer.Registerer.mem hash in
        if andb success (negb loaded) then
          Tezos_protocol_updater.Updater_logging.log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Internal error while compiling " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "Internal error while compiling %a" % string)
            Tezos_base__TzPervasives.Protocol_hash.pp hash
        else
          tt;
        Lwt._return loaded).
src/lib_protocol_updater/updater.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val compile : Protocol_hash.t -> Protocol.t -> bool Lwt.t

val init : string -> unit

val compiler_name : string
src/lib_protocol_updater/updater.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter compile :
Tezos_base__TzPervasives.Protocol_hash.t ->
  Tezos_base__TzPervasives.Protocol.t -> Lwt.t bool.

Parameter init : string -> unit.

Parameter compiler_name : string.
src/lib_protocol_updater/updater_logging.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "updater"
end)
src/lib_protocol_updater/updater_logging.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_protocol_updater/updater_logging.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.LOG
src/lib_protocol_updater/updater_logging.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_rpc/RPC_answer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Return type for service handler *)
type 'o t =
  [ `Ok of 'o (* 200 *)
  | `OkStream of 'o stream (* 200 *)
  | `Created of string option (* 201 *)
  | `No_content (* 204 *)
  | `Unauthorized of RPC_service.error option (* 401 *)
  | `Forbidden of RPC_service.error option (* 403 *)
  | `Not_found of RPC_service.error option (* 404 *)
  | `Conflict of RPC_service.error option (* 409 *)
  | `Error of RPC_service.error option (* 500 *) ]

and 'a stream = 'a Resto_directory.Answer.stream = {
  next : unit -> 'a option Lwt.t;
  shutdown : unit -> unit;
}

let return x = Lwt.return (`Ok x)

let return_unit = Lwt.return (`Ok ())

let return_stream x = Lwt.return (`OkStream x)

let not_found = Lwt.return (`Not_found None)

let fail err = Lwt.return (`Error (Some err))
src/lib_rpc/RPC_answer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Reserved Notation "'t".



where "'t" := (fun (o : Type) => variant).

Definition t := 't.

Definition _return {A : Type} (x : A) : Lwt.t variant := Lwt._return variant.

Definition return_unit : Lwt.t variant := Lwt._return variant.

Definition return_stream {A : Type} (x : A) : Lwt.t variant :=
  Lwt._return variant.

Definition not_found : Lwt.t variant := Lwt._return variant.

Definition fail {A : Type} (err : A) : Lwt.t variant := Lwt._return variant.
src/lib_rpc/RPC_answer.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Return type for service handler *)
type 'o t =
  [ `Ok of 'o (* 200 *)
  | `OkStream of 'o stream (* 200 *)
  | `Created of string option (* 201 *)
  | `No_content (* 204 *)
  | `Unauthorized of RPC_service.error option (* 401 *)
  | `Forbidden of RPC_service.error option (* 403 *)
  | `Not_found of RPC_service.error option (* 404 *)
  | `Conflict of RPC_service.error option (* 409 *)
  | `Error of RPC_service.error option (* 500 *) ]

and 'a stream = 'a Resto_directory.Answer.stream = {
  next : unit -> 'a option Lwt.t;
  shutdown : unit -> unit;
}

val return : 'o -> 'o t Lwt.t

val return_unit : unit t Lwt.t

val return_stream : 'o stream -> 'o t Lwt.t

val not_found : 'o t Lwt.t

val fail : Error_monad.error list -> 'a t Lwt.t
src/lib_rpc/RPC_answer.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Reserved Notation "'t".



where "'t" := (fun (o : Type) => variant).

Definition t := 't.

Parameter _return : forall {o : Type}, o -> Lwt.t (t o).

Parameter return_unit : Lwt.t (t unit).

Parameter return_stream : forall {o : Type}, (stream o) -> Lwt.t (t o).

Parameter not_found : forall {o : Type}, Lwt.t (t o).

Parameter fail : forall {a : Type},
(list Tezos_error_monad.Error_monad.error) -> Lwt.t (t a).
src/lib_rpc/RPC_arg.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type ('i, 'j) eq = ('i, 'j) Resto.eq = Eq : ('a, 'a) eq

include Resto.Arg
src/lib_rpc/RPC_arg.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive eq : forall (i j : Type), Type :=
| Eq : forall {a : Type}, eq a a.
src/lib_rpc/RPC_arg.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type ('i, 'j) eq = ('i, 'j) Resto.eq = Eq : ('a, 'a) eq

include module type of struct
  include Resto.Arg
end
src/lib_rpc/RPC_arg.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive eq : forall (i j : Type), Type :=
| Eq : forall {a : Type}, eq a a.

include
src/lib_rpc/RPC_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

class type ['pr] gen_simple =
  object
    method call_service :
      'm 'p 'q 'i 'o.
      (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
      'q -> 'i -> 'o tzresult Lwt.t
  end

class type ['pr] gen_streamed =
  object
    method call_streamed_service :
      'm 'p 'q 'i 'o.
      (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
      on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
      (unit -> unit) tzresult Lwt.t
  end

class type ['pr] gen =
  object
    inherit ['pr] gen_simple

    inherit ['pr] gen_streamed
  end

class type simple =
  object
    inherit [unit] gen_simple
  end

class type streamed =
  object
    inherit [unit] gen_streamed
  end

class type t =
  object
    inherit simple

    inherit streamed
  end

type ('o, 'e) rest_result =
  [ `Ok of 'o
  | `Conflict of 'e
  | `Error of 'e
  | `Forbidden of 'e
  | `Not_found of 'e
  | `Unauthorized of 'e ]
  tzresult

class type json =
  object
    inherit t

    method generic_json_call :
      RPC_service.meth ->
      ?body:Data_encoding.json ->
      Uri.t ->
      (Data_encoding.json, Data_encoding.json option) rest_result Lwt.t

    method base : Uri.t
  end

type error +=
  | Not_found of {meth : RPC_service.meth; uri : Uri.t}
  | Generic_error of {meth : RPC_service.meth; uri : Uri.t}

let base = Uri.make ~scheme:"ocaml" ()

let not_found s p q =
  let {RPC_service.meth; uri; _} =
    RPC_service.forge_partial_request s ~base p q
  in
  fail (Not_found {meth; uri})

let generic_error s p q =
  let {RPC_service.meth; uri; _} =
    RPC_service.forge_partial_request s ~base p q
  in
  fail (Generic_error {meth; uri})

class ['pr] of_directory (dir : 'pr RPC_directory.t) =
  object
    method call_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
          'q -> 'i -> 'o tzresult Lwt.t =
      fun s p q i ->
        RPC_directory.transparent_lookup dir s p q i
        >>= function
        | `Ok v ->
            return v
        | `OkStream {next; shutdown} -> (
            next ()
            >>= function
            | Some v ->
                shutdown () ; return v
            | None ->
                shutdown () ; not_found s p q )
        | `Not_found None ->
            not_found s p q
        | `Unauthorized (Some err)
        | `Forbidden (Some err)
        | `Not_found (Some err)
        | `Conflict (Some err)
        | `Error (Some err) ->
            Lwt.return_error err
        | `Unauthorized None
        | `Error None
        | `Forbidden None
        | `Created _
        | `Conflict None
        | `No_content ->
            generic_error s p q

    method call_streamed_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
          on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
          (unit -> unit) tzresult Lwt.t =
      fun s ~on_chunk ~on_close p q i ->
        RPC_directory.transparent_lookup dir s p q i
        >>= function
        | `OkStream {next; shutdown} ->
            let rec loop () =
              next ()
              >>= function
              | None ->
                  on_close () ; Lwt.return_unit
              | Some v ->
                  on_chunk v ; loop ()
            in
            let _ = loop () in
            return shutdown
        | `Ok v ->
            on_chunk v ;
            on_close () ;
            return (fun () -> ())
        | `Not_found None ->
            not_found s p q
        | `Unauthorized (Some err)
        | `Forbidden (Some err)
        | `Not_found (Some err)
        | `Conflict (Some err)
        | `Error (Some err) ->
            Lwt.return_error err
        | `Unauthorized None
        | `Error None
        | `Forbidden None
        | `Created _
        | `Conflict None
        | `No_content ->
            generic_error s p q
  end

let make_call s (ctxt : #simple) = ctxt#call_service s

let make_call1 s ctxt x = make_call s ctxt ((), x)

let make_call2 s ctxt x y = make_call s ctxt (((), x), y)

let make_call3 s ctxt x y z = make_call s ctxt ((((), x), y), z)

type stopper = unit -> unit

let make_streamed_call s (ctxt : #streamed) p q i =
  let (stream, push) = Lwt_stream.create () in
  let on_chunk v = push (Some v) and on_close () = push None in
  ctxt#call_streamed_service s ~on_chunk ~on_close p q i
  >>=? fun close -> return (stream, close)

let () =
  let open Data_encoding in
  register_error_kind
    `Branch
    ~id:"RPC_context.Not_found"
    ~title:"RPC lookup failed"
    ~description:
      "RPC lookup failed. No RPC exists at the URL or the RPC tried to access \
       non-existent data."
    (obj2
       (req "method" RPC_service.meth_encoding)
       (req "uri" RPC_encoding.uri_encoding))
    ~pp:(fun ppf (meth, uri) ->
      Format.fprintf
        ppf
        "Did not find service: %s %a"
        (RPC_service.string_of_meth meth)
        Uri.pp_hum
        uri)
    (function Not_found {meth; uri} -> Some (meth, uri) | _ -> None)
    (fun (meth, uri) -> Not_found {meth; uri})
src/lib_rpc/RPC_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Definition rest_result (o e : Type) :=
  Tezos_error_monad.Error_monad.tzresult variant.

Definition base : Uri.t :=
  Uri.make (Some "ocaml" % string) None None None None None None tt.

Definition not_found {A B C D E F G : Type}
  (s : Tezos_rpc.RPC_service.raw variant A B C D E F) (p : B) (q : C)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult G) :=
  match Tezos_rpc.RPC_service.forge_partial_request s (Some base) p q with
  | {| RPC_service.meth := meth; RPC_service.uri := uri |} =>
    Tezos_error_monad.Error_monad.fail
      (OCaml.Not_found {| meth := meth; uri := uri |})
  end.

Definition generic_error {A B C D E F G : Type}
  (s : Tezos_rpc.RPC_service.raw variant A B C D E F) (p : B) (q : C)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult G) :=
  match Tezos_rpc.RPC_service.forge_partial_request s (Some base) p q with
  | {| RPC_service.meth := meth; RPC_service.uri := uri |} =>
    Tezos_error_monad.Error_monad.fail
      (Generic_error {| meth := meth; uri := uri |})
  end.

Definition make_call {A B C D I J i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit A B C D)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (I * p * q * i * o)) * J) * J)
  : A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D) := send s.

Definition make_call1 {A B C D I J i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (I * p * q * i * o)) * J) * J) (x : A)
  : B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D) :=
  make_call s ctxt (tt, x).

Definition make_call2 {A B C D E J K i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit ((unit * A) * B) C D E)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (J * p * q * i * o)) * K) * K) (x : A) (y : B)
  : C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E) :=
  make_call s ctxt ((tt, x), y).

Definition make_call3 {A B C D E F K L i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit (((unit * A) * B) * C) D E F)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (K * p * q * i * o)) * L) * L) (x : A) (y : B) (z : C)
  : D -> E -> Lwt.t (Tezos_error_monad.Error_monad.tzresult F) :=
  make_call s ctxt (((tt, x), y), z).

Definition stopper := unit -> unit.

Definition make_streamed_call {A B C D I J i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit A B C D)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (I * p * q * i * o)) * J) * J) (p : A) (q : B) (i : C)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult ((Lwt_stream.t D) * (unit -> unit))) :=
  match Lwt_stream.create tt with
  | (stream, push) =>
    let on_chunk (v : D) : unit :=
      push (Some v)
    with on_close (function_parameter : unit) : unit :=
      match function_parameter with
      | tt => push None
      end in
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
      (send s on_chunk on_close p q i)
      (fun close => Tezos_error_monad.Error_monad._return (stream, close))
  end.
src/lib_rpc/RPC_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

class type ['pr] gen_simple =
  object
    method call_service :
      'm 'p 'q 'i 'o.
      (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
      'q -> 'i -> 'o tzresult Lwt.t
  end

class type ['pr] gen_streamed =
  object
    method call_streamed_service :
      'm 'p 'q 'i 'o.
      (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
      on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
      (unit -> unit) tzresult Lwt.t
  end

class type ['pr] gen =
  object
    inherit ['pr] gen_simple

    inherit ['pr] gen_streamed
  end

class type simple =
  object
    inherit [unit] gen_simple
  end

class type streamed =
  object
    inherit [unit] gen_streamed
  end

class type t =
  object
    inherit simple

    inherit streamed
  end

type ('o, 'e) rest_result =
  [ `Ok of 'o
  | `Conflict of 'e
  | `Error of 'e
  | `Forbidden of 'e
  | `Not_found of 'e
  | `Unauthorized of 'e ]
  tzresult

class type json =
  object
    inherit t

    method generic_json_call :
      RPC_service.meth ->
      ?body:Data_encoding.json ->
      Uri.t ->
      (Data_encoding.json, Data_encoding.json option) rest_result Lwt.t

    method base : Uri.t
  end

class ['pr] of_directory : 'pr RPC_directory.t -> ['pr] gen

type error +=
  | Not_found of {meth : RPC_service.meth; uri : Uri.t}
  | Generic_error of {meth : RPC_service.meth; uri : Uri.t}

val make_call :
  ([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
  #simple ->
  'p ->
  'q ->
  'i ->
  'o tzresult Lwt.t

val make_call1 :
  ([< Resto.meth], unit, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  #simple ->
  'a ->
  'q ->
  'i ->
  'o tzresult Lwt.t

val make_call2 :
  ([< Resto.meth], unit, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  #simple ->
  'a ->
  'b ->
  'q ->
  'i ->
  'o tzresult Lwt.t

val make_call3 :
  ([< Resto.meth], unit, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  #simple ->
  'a ->
  'b ->
  'c ->
  'q ->
  'i ->
  'o tzresult Lwt.t

type stopper = unit -> unit

val make_streamed_call :
  ([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
  #streamed ->
  'p ->
  'q ->
  'i ->
  ('o Lwt_stream.t * stopper) tzresult Lwt.t
src/lib_rpc/RPC_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

class_type

class_type

class_type

class_type

class_type

class_type

Definition rest_result (o e : Type) :=
  Tezos_error_monad.Error_monad.tzresult variant.

class_type

class

extensible_type

Parameter make_call : forall {_ i o p q variant : Type},
(Tezos_rpc.RPC_service.t variant unit p q i o) ->
  (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o).

Parameter make_call1 : forall {_ a i o p q variant : Type},
(Tezos_rpc.RPC_service.t variant unit (unit * a) q i o) ->
  (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    a -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o).

Parameter make_call2 : forall {_ a b i o p q variant : Type},
(Tezos_rpc.RPC_service.t variant unit ((unit * a) * b) q i o) ->
  (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    a -> b -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o).

Parameter make_call3 : forall {_ a b c i o p q variant : Type},
(Tezos_rpc.RPC_service.t variant unit (((unit * a) * b) * c) q i o) ->
  (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    a -> b -> c -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o).

Definition stopper := unit -> unit.

Parameter make_streamed_call : forall {_ i o p q variant : Type},
(Tezos_rpc.RPC_service.t variant unit p q i o) ->
  (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
    (o -> unit) ->
      (unit -> unit) ->
        p ->
          q ->
            i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
    * (_ * p * q * i * o)) * _) * _) ->
    p ->
      q ->
        i ->
          Lwt.t
            (Tezos_error_monad.Error_monad.tzresult ((Lwt_stream.t o) * stopper)).
src/lib_rpc/RPC_description.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto.Description

let describe ctxt ?(recurse = false) path =
  RPC_context.make_call1 RPC_service.description_service ctxt path {recurse} ()
src/lib_rpc/RPC_description.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition describe {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_star_o_p_t_star : option bool)
  : (list string) ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Resto.Description.directory Tezos_rpc.RPC_encoding.schema)) :=
  let recurse :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun path =>
    Tezos_rpc.RPC_context.make_call1 Tezos_rpc.RPC_service.description_service
      ctxt path {| recurse := recurse |} tt.
src/lib_rpc/RPC_description.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

include module type of struct
  include Resto.Description
end

val describe :
  #RPC_context.simple ->
  ?recurse:bool ->
  string list ->
  RPC_encoding.schema directory tzresult Lwt.t
src/lib_rpc/RPC_description.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter describe : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  (option bool) ->
    (list string) ->
      Lwt.t
        (Tezos_error_monad.Error_monad.tzresult
          (directory Tezos_rpc.RPC_encoding.schema)).
src/lib_rpc/RPC_directory.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad
include Resto_directory.Make (RPC_encoding)

let gen_register dir service handler =
  register dir service (fun p q i ->
      Lwt.catch
        (fun () -> handler p q i)
        (function
          | Not_found -> RPC_answer.not_found | exn -> RPC_answer.fail [Exn exn]))

let gen_register =
  ( gen_register
    : _ -> _ -> (_ -> _ -> _ -> _ RPC_answer.t Lwt.t) -> _
    :> _ -> _ -> (_ -> _ -> _ -> [< _ RPC_answer.t] Lwt.t) -> _ )

let register dir service handler =
  gen_register dir service (fun p q i ->
      handler p q i
      >>= function Ok o -> RPC_answer.return o | Error e -> RPC_answer.fail e)

let opt_register dir service handler =
  gen_register dir service (fun p q i ->
      handler p q i
      >>= function
      | Ok (Some o) ->
          RPC_answer.return o
      | Ok None ->
          RPC_answer.not_found
      | Error e ->
          RPC_answer.fail e)

let lwt_register dir service handler =
  gen_register dir service (fun p q i ->
      handler p q i >>= fun o -> RPC_answer.return o)

open Curry

let register0 root s f = register root s (curry Z f)

let register1 root s f = register root s (curry (S Z) f)

let register2 root s f = register root s (curry (S (S Z)) f)

let register3 root s f = register root s (curry (S (S (S Z))) f)

let register4 root s f = register root s (curry (S (S (S (S Z)))) f)

let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f)

let opt_register0 root s f = opt_register root s (curry Z f)

let opt_register1 root s f = opt_register root s (curry (S Z) f)

let opt_register2 root s f = opt_register root s (curry (S (S Z)) f)

let opt_register3 root s f = opt_register root s (curry (S (S (S Z))) f)

let opt_register4 root s f = opt_register root s (curry (S (S (S (S Z)))) f)

let opt_register5 root s f =
  opt_register root s (curry (S (S (S (S (S Z))))) f)

let gen_register0 root s f = gen_register root s (curry Z f)

let gen_register1 root s f = gen_register root s (curry (S Z) f)

let gen_register2 root s f = gen_register root s (curry (S (S Z)) f)

let gen_register3 root s f = gen_register root s (curry (S (S (S Z))) f)

let gen_register4 root s f = gen_register root s (curry (S (S (S (S Z)))) f)

let gen_register5 root s f =
  gen_register root s (curry (S (S (S (S (S Z))))) f)

let lwt_register0 root s f = lwt_register root s (curry Z f)

let lwt_register1 root s f = lwt_register root s (curry (S Z) f)

let lwt_register2 root s f = lwt_register root s (curry (S (S Z)) f)

let lwt_register3 root s f = lwt_register root s (curry (S (S (S Z))) f)

let lwt_register4 root s f = lwt_register root s (curry (S (S (S (S Z)))) f)

let lwt_register5 root s f =
  lwt_register root s (curry (S (S (S (S (S Z))))) f)
src/lib_rpc/RPC_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Definition gen_register {A B C D E : Type}
  (dir : directory A)
  (service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
  (handler : B -> C -> D -> Lwt.t (Tezos_rpc.RPC_answer.t E)) : directory A :=
  register dir service
    (fun p =>
      fun q =>
        fun i =>
          Lwt.catch
            (fun function_parameter =>
              match function_parameter with
              | tt => handler p q i
              end)
            (fun function_parameter =>
              match function_parameter with
              | OCaml.Not_found => Tezos_rpc.RPC_answer.not_found
              | exn => Tezos_rpc.RPC_answer.fail (cons (Exn exn) [])
              end)).

Definition gen_register {A B C D E : Type}
  : (directory A) ->
    (Service.t variant A B C D E Tezos_rpc.RPC_service.error) ->
      (B -> C -> D -> Lwt.t variant) -> directory A := gen_register.

Definition register {A B C D E : Type}
  (dir : directory A)
  (service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
  (handler :
    B -> C -> D -> Lwt.t (sum E (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  gen_register dir service
    (fun p =>
      fun q =>
        fun i =>
          Tezos_error_monad.Error_monad.op_gt_gt_eq (handler p q i)
            (fun function_parameter =>
              match function_parameter with
              | inl o => Tezos_rpc.RPC_answer._return o
              | inr e => Tezos_rpc.RPC_answer.fail e
              end)).

Definition opt_register {A B C D E : Type}
  (dir : directory A)
  (service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
  (handler :
    B ->
      C ->
        D -> Lwt.t (sum (option E) (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  gen_register dir service
    (fun p =>
      fun q =>
        fun i =>
          Tezos_error_monad.Error_monad.op_gt_gt_eq (handler p q i)
            (fun function_parameter =>
              match function_parameter with
              | inl (Some o) => Tezos_rpc.RPC_answer._return o
              | inl None => Tezos_rpc.RPC_answer.not_found
              | inr e => Tezos_rpc.RPC_answer.fail e
              end)).

Definition lwt_register {A B C D E : Type}
  (dir : directory A)
  (service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
  (handler : B -> C -> D -> Lwt.t E) : directory A :=
  gen_register dir service
    (fun p =>
      fun q =>
        fun i =>
          Tezos_error_monad.Error_monad.op_gt_gt_eq (handler p q i)
            (fun o => Tezos_rpc.RPC_answer._return o)).

Import Curry.

Definition register0 {A B C D : Type}
  (root : directory A)
  (s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
  (f : B -> C -> Lwt.t (sum D (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (Curry.curry Z f).

Definition register1 {A B C D E : Type}
  (root : directory A)
  (s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> Lwt.t (sum E (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (Curry.curry (S Z) f).

Definition register2 {A B C D E F : Type}
  (root : directory A)
  (s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
  (f :
    B -> C -> D -> E -> Lwt.t (sum F (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (Curry.curry (S (S Z)) f).

Definition register3 {A B C D E F G : Type}
  (root : directory A)
  (s :
    Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D -> E -> F -> Lwt.t (sum G (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (Curry.curry (S (S (S Z))) f).

Definition register4 {A B C D E F G H : Type}
  (root : directory A)
  (s :
    Service.t variant A ((((unit * B) * C) * D) * E) F G H
      Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F -> G -> Lwt.t (sum H (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (Curry.curry (S (S (S (S Z)))) f).

Definition register5 {A B C D E F G H I : Type}
  (root : directory A)
  (s :
    Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
      Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F ->
              G -> H -> Lwt.t (sum I (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (Curry.curry (S (S (S (S (S Z))))) f).

Definition opt_register0 {A B C D : Type}
  (root : directory A)
  (s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
  (f :
    B -> C -> Lwt.t (sum (option D) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (Curry.curry Z f).

Definition opt_register1 {A B C D E : Type}
  (root : directory A)
  (s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D -> Lwt.t (sum (option E) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (Curry.curry (S Z) f).

Definition opt_register2 {A B C D E F : Type}
  (root : directory A)
  (s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E -> Lwt.t (sum (option F) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (Curry.curry (S (S Z)) f).

Definition opt_register3 {A B C D E F G : Type}
  (root : directory A)
  (s :
    Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F ->
              Lwt.t (sum (option G) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (Curry.curry (S (S (S Z))) f).

Definition opt_register4 {A B C D E F G H : Type}
  (root : directory A)
  (s :
    Service.t variant A ((((unit * B) * C) * D) * E) F G H
      Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F ->
              G ->
                Lwt.t
                  (sum (option H) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (Curry.curry (S (S (S (S Z)))) f).

Definition opt_register5 {A B C D E F G H I : Type}
  (root : directory A)
  (s :
    Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
      Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F ->
              G ->
                H ->
                  Lwt.t
                    (sum (option I) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (Curry.curry (S (S (S (S (S Z))))) f).

Definition gen_register0 {A B C D : Type}
  (root : directory A)
  (s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
  (f : B -> C -> Lwt.t variant) : directory A :=
  gen_register root s (Curry.curry Z f).

Definition gen_register1 {A B C D E : Type}
  (root : directory A)
  (s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> Lwt.t variant) : directory A :=
  gen_register root s (Curry.curry (S Z) f).

Definition gen_register2 {A B C D E F : Type}
  (root : directory A)
  (s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> Lwt.t variant) : directory A :=
  gen_register root s (Curry.curry (S (S Z)) f).

Definition gen_register3 {A B C D E F G : Type}
  (root : directory A)
  (s :
    Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> Lwt.t variant) : directory A :=
  gen_register root s (Curry.curry (S (S (S Z))) f).

Definition gen_register4 {A B C D E F G H : Type}
  (root : directory A)
  (s :
    Service.t variant A ((((unit * B) * C) * D) * E) F G H
      Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> G -> Lwt.t variant) : directory A :=
  gen_register root s (Curry.curry (S (S (S (S Z)))) f).

Definition gen_register5 {A B C D E F G H I : Type}
  (root : directory A)
  (s :
    Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
      Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> G -> H -> Lwt.t variant) : directory A :=
  gen_register root s (Curry.curry (S (S (S (S (S Z))))) f).

Definition lwt_register0 {A B C D : Type}
  (root : directory A)
  (s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
  (f : B -> C -> Lwt.t D) : directory A := lwt_register root s (Curry.curry Z f).

Definition lwt_register1 {A B C D E : Type}
  (root : directory A)
  (s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> Lwt.t E) : directory A :=
  lwt_register root s (Curry.curry (S Z) f).

Definition lwt_register2 {A B C D E F : Type}
  (root : directory A)
  (s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> Lwt.t F) : directory A :=
  lwt_register root s (Curry.curry (S (S Z)) f).

Definition lwt_register3 {A B C D E F G : Type}
  (root : directory A)
  (s :
    Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> Lwt.t G) : directory A :=
  lwt_register root s (Curry.curry (S (S (S Z))) f).

Definition lwt_register4 {A B C D E F G H : Type}
  (root : directory A)
  (s :
    Service.t variant A ((((unit * B) * C) * D) * E) F G H
      Tezos_rpc.RPC_service.error) (f : B -> C -> D -> E -> F -> G -> Lwt.t H)
  : directory A := lwt_register root s (Curry.curry (S (S (S (S Z)))) f).

Definition lwt_register5 {A B C D E F G H I : Type}
  (root : directory A)
  (s :
    Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
      Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> G -> H -> Lwt.t I) : directory A :=
  lwt_register root s (Curry.curry (S (S (S (S (S Z))))) f).
src/lib_rpc/RPC_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

include module type of struct
  include Resto_directory.Make (RPC_encoding)
end

(** Registring handler in service tree. *)
val register :
  'prefix directory ->
  ([< Resto.meth], 'prefix, 'p, 'q, 'i, 'o) RPC_service.t ->
  ('p -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val opt_register :
  'prefix directory ->
  ([< Resto.meth], 'prefix, 'p, 'q, 'i, 'o) RPC_service.t ->
  ('p -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val gen_register :
  'prefix directory ->
  ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t ->
  ('params -> 'query -> 'input -> [< 'output RPC_answer.t] Lwt.t) ->
  'prefix directory

val lwt_register :
  'prefix directory ->
  ([< Resto.meth], 'prefix, 'p, 'q, 'i, 'o) RPC_service.t ->
  ('p -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

(** Registring handler in service tree. Curryfied variant.  *)

val register0 :
  unit directory ->
  ('m, unit, unit, 'q, 'i, 'o) RPC_service.t ->
  ('q -> 'i -> 'o tzresult Lwt.t) ->
  unit directory

val register1 :
  'prefix directory ->
  ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val register2 :
  'prefix directory ->
  ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val register3 :
  'prefix directory ->
  ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val register4 :
  'prefix directory ->
  ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val register5 :
  'prefix directory ->
  ( 'm,
    'prefix,
    ((((unit * 'a) * 'b) * 'c) * 'd) * 'e,
    'q,
    'i,
    'o )
  RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o tzresult Lwt.t) ->
  'prefix directory

val opt_register0 :
  unit directory ->
  ('m, unit, unit, 'q, 'i, 'o) RPC_service.t ->
  ('q -> 'i -> 'o option tzresult Lwt.t) ->
  unit directory

val opt_register1 :
  'prefix directory ->
  ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val opt_register2 :
  'prefix directory ->
  ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val opt_register3 :
  'prefix directory ->
  ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val opt_register4 :
  'prefix directory ->
  ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val opt_register5 :
  'prefix directory ->
  ( 'm,
    'prefix,
    ((((unit * 'a) * 'b) * 'c) * 'd) * 'e,
    'q,
    'i,
    'o )
  RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o option tzresult Lwt.t) ->
  'prefix directory

val gen_register0 :
  unit directory ->
  ('m, unit, unit, 'q, 'i, 'o) RPC_service.t ->
  ('q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  unit directory

val gen_register1 :
  'prefix directory ->
  ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val gen_register2 :
  'prefix directory ->
  ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val gen_register3 :
  'prefix directory ->
  ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val gen_register4 :
  'prefix directory ->
  ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val gen_register5 :
  'prefix directory ->
  ( 'm,
    'prefix,
    ((((unit * 'a) * 'b) * 'c) * 'd) * 'e,
    'q,
    'i,
    'o )
  RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> [< 'o RPC_answer.t] Lwt.t) ->
  'prefix directory

val lwt_register0 :
  unit directory ->
  ('m, unit, unit, 'q, 'i, 'o) RPC_service.t ->
  ('q -> 'i -> 'o Lwt.t) ->
  unit directory

val lwt_register1 :
  'prefix directory ->
  ('m, 'prefix, unit * 'a, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

val lwt_register2 :
  'prefix directory ->
  ('m, 'prefix, (unit * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

val lwt_register3 :
  'prefix directory ->
  ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

val lwt_register4 :
  'prefix directory ->
  ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o) RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory

val lwt_register5 :
  'prefix directory ->
  ( 'm,
    'prefix,
    ((((unit * 'a) * 'b) * 'c) * 'd) * 'e,
    'q,
    'i,
    'o )
  RPC_service.t ->
  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o Lwt.t) ->
  'prefix directory
src/lib_rpc/RPC_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter register : forall {i o p prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix p q i o) ->
    (p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) ->
      directory prefix.

Parameter opt_register : forall {i o p prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix p q i o) ->
    (p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (option o)))
      -> directory prefix.

Parameter gen_register : forall
{input output params prefix query variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix params query input output) ->
    (params -> query -> input -> Lwt.t variant) -> directory prefix.

Parameter lwt_register : forall {i o p prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix p q i o) ->
    (p -> q -> i -> Lwt.t o) -> directory prefix.

Parameter register0 : forall {i o q variant : Type},
(directory unit) ->
  (Tezos_rpc.RPC_service.t variant unit unit q i o) ->
    (q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) ->
      directory unit.

Parameter register1 : forall {a i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (unit * a) q i o) ->
    (a -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) ->
      directory prefix.

Parameter register2 : forall {a b i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix ((unit * a) * b) q i o) ->
    (a -> b -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) ->
      directory prefix.

Parameter register3 : forall {a b c i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (((unit * a) * b) * c) q i o) ->
    (a -> b -> c -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
      -> directory prefix.

Parameter register4 : forall {a b c d i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix ((((unit * a) * b) * c) * d) q i o) ->
    (a ->
      b -> c -> d -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
      -> directory prefix.

Parameter register5 : forall {a b c d e i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (((((unit * a) * b) * c) * d) * e) q i
    o) ->
    (a ->
      b ->
        c ->
          d -> e -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
      -> directory prefix.

Parameter opt_register0 : forall {i o q variant : Type},
(directory unit) ->
  (Tezos_rpc.RPC_service.t variant unit unit q i o) ->
    (q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (option o))) ->
      directory unit.

Parameter opt_register1 : forall {a i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (unit * a) q i o) ->
    (a -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (option o)))
      -> directory prefix.

Parameter opt_register2 : forall {a b i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix ((unit * a) * b) q i o) ->
    (a ->
      b -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (option o)))
      -> directory prefix.

Parameter opt_register3 : forall {a b c i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (((unit * a) * b) * c) q i o) ->
    (a ->
      b ->
        c -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (option o)))
      -> directory prefix.

Parameter opt_register4 : forall {a b c d i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix ((((unit * a) * b) * c) * d) q i o) ->
    (a ->
      b ->
        c ->
          d ->
            q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (option o)))
      -> directory prefix.

Parameter opt_register5 : forall {a b c d e i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (((((unit * a) * b) * c) * d) * e) q i
    o) ->
    (a ->
      b ->
        c ->
          d ->
            e ->
              q ->
                i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (option o)))
      -> directory prefix.

Parameter gen_register0 : forall {i o q variant : Type},
(directory unit) ->
  (Tezos_rpc.RPC_service.t variant unit unit q i o) ->
    (q -> i -> Lwt.t variant) -> directory unit.

Parameter gen_register1 : forall {a i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (unit * a) q i o) ->
    (a -> q -> i -> Lwt.t variant) -> directory prefix.

Parameter gen_register2 : forall {a b i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix ((unit * a) * b) q i o) ->
    (a -> b -> q -> i -> Lwt.t variant) -> directory prefix.

Parameter gen_register3 : forall {a b c i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (((unit * a) * b) * c) q i o) ->
    (a -> b -> c -> q -> i -> Lwt.t variant) -> directory prefix.

Parameter gen_register4 : forall {a b c d i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix ((((unit * a) * b) * c) * d) q i o) ->
    (a -> b -> c -> d -> q -> i -> Lwt.t variant) -> directory prefix.

Parameter gen_register5 : forall {a b c d e i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (((((unit * a) * b) * c) * d) * e) q i
    o) -> (a -> b -> c -> d -> e -> q -> i -> Lwt.t variant) -> directory prefix.

Parameter lwt_register0 : forall {i o q variant : Type},
(directory unit) ->
  (Tezos_rpc.RPC_service.t variant unit unit q i o) ->
    (q -> i -> Lwt.t o) -> directory unit.

Parameter lwt_register1 : forall {a i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (unit * a) q i o) ->
    (a -> q -> i -> Lwt.t o) -> directory prefix.

Parameter lwt_register2 : forall {a b i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix ((unit * a) * b) q i o) ->
    (a -> b -> q -> i -> Lwt.t o) -> directory prefix.

Parameter lwt_register3 : forall {a b c i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (((unit * a) * b) * c) q i o) ->
    (a -> b -> c -> q -> i -> Lwt.t o) -> directory prefix.

Parameter lwt_register4 : forall {a b c d i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix ((((unit * a) * b) * c) * d) q i o) ->
    (a -> b -> c -> d -> q -> i -> Lwt.t o) -> directory prefix.

Parameter lwt_register5 : forall {a b c d e i o prefix q variant : Type},
(directory prefix) ->
  (Tezos_rpc.RPC_service.t variant prefix (((((unit * a) * b) * c) * d) * e) q i
    o) -> (a -> b -> c -> d -> e -> q -> i -> Lwt.t o) -> directory prefix.
src/lib_rpc/RPC_encoding.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a t = 'a Data_encoding.t

type schema = Data_encoding.json_schema * Data_encoding.Binary_schema.t

let unit = Data_encoding.empty

let untyped = Data_encoding.(obj1 (req "untyped" string))

let conv f g t = Data_encoding.conv ~schema:(Data_encoding.Json.schema t) f g t

let schema ?definitions_path t =
  ( Data_encoding.Json.schema ?definitions_path t,
    Data_encoding.Binary.describe t )

let schema_encoding =
  let open Data_encoding in
  obj2
    (req "json_schema" json_schema)
    (req "binary_schema" Data_encoding.Binary_schema.encoding)

module StringMap = Resto.StringMap

let arg_encoding =
  let open Data_encoding in
  conv
    (fun {Resto.Arg.name; descr} -> ((), name, descr))
    (fun ((), name, descr) -> {name; descr})
    (obj3
       (req "id" (constant "single"))
       (req "name" string)
       (opt "descr" string))

let multi_arg_encoding =
  let open Data_encoding in
  conv
    (fun {Resto.Arg.name; descr} -> ((), name, descr))
    (fun ((), name, descr) -> {name; descr})
    (obj3
       (req "id" (constant "multiple"))
       (req "name" string)
       (opt "descr" string))

open Resto.Description

let meth_encoding =
  Data_encoding.string_enum
    [ ("GET", `GET);
      ("POST", `POST);
      ("DELETE", `DELETE);
      ("PUT", `PUT);
      ("PATCH", `PATCH) ]

let path_item_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        string
        ~title:"PStatic"
        (function PStatic s -> Some s | _ -> None)
        (fun s -> PStatic s);
      case
        (Tag 1)
        arg_encoding
        ~title:"PDynamic"
        (function PDynamic s -> Some s | _ -> None)
        (fun s -> PDynamic s);
      case
        (Tag 2)
        multi_arg_encoding
        ~title:"PDynamicTail"
        (function PDynamicTail s -> Some s | _ -> None)
        (fun s -> PDynamicTail s) ]

let query_kind_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Single"
        (obj1 (req "single" arg_encoding))
        (function Single s -> Some s | _ -> None)
        (fun s -> Single s);
      case
        (Tag 1)
        ~title:"Optional"
        (obj1 (req "optional" arg_encoding))
        (function Optional s -> Some s | _ -> None)
        (fun s -> Optional s);
      case
        (Tag 2)
        ~title:"Flag"
        (obj1 (req "flag" empty))
        (function Flag -> Some () | _ -> None)
        (fun () -> Flag);
      case
        (Tag 3)
        ~title:"Multi"
        (obj1 (req "multi" arg_encoding))
        (function Multi s -> Some s | _ -> None)
        (fun s -> Multi s) ]

let query_item_encoding =
  let open Data_encoding in
  conv
    (fun {name; description; kind} -> (name, description, kind))
    (fun (name, description, kind) -> {name; description; kind})
    (obj3
       (req "name" string)
       (opt "description" string)
       (req "kind" query_kind_encoding))

let service_descr_encoding =
  let open Data_encoding in
  conv
    (fun {meth; path; description; query; input; output; error} ->
      (meth, path, description, query, input, output, error))
    (fun (meth, path, description, query, input, output, error) ->
      {meth; path; description; query; input; output; error})
    (obj7
       (req "meth" meth_encoding)
       (req "path" (list path_item_encoding))
       (opt "description" string)
       (req "query" (list query_item_encoding))
       (opt "input" schema_encoding)
       (req "output" schema_encoding)
       (req "error" schema_encoding))

let directory_descr_encoding =
  let open Data_encoding in
  mu "service_tree"
  @@ fun directory_descr_encoding ->
  let static_subdirectories_descr_encoding =
    union
      [ case
          (Tag 0)
          ~title:"Suffixes"
          (obj1
             (req
                "suffixes"
                (list
                   (obj2
                      (req "name" string)
                      (req "tree" directory_descr_encoding)))))
          (function
            | Suffixes map -> Some (StringMap.bindings map) | _ -> None)
          (fun m ->
            let add acc (n, t) = StringMap.add n t acc in
            Suffixes (List.fold_left add StringMap.empty m));
        case
          (Tag 1)
          ~title:"Arg"
          (obj1
             (req
                "dynamic_dispatch"
                (obj2
                   (req "arg" arg_encoding)
                   (req "tree" directory_descr_encoding))))
          (function Arg (ty, tree) -> Some (ty, tree) | _ -> None)
          (fun (ty, tree) -> Arg (ty, tree)) ]
  in
  let static_directory_descr_encoding =
    conv
      (fun {services; subdirs} ->
        let find s =
          try Some (Resto.MethMap.find s services) with Not_found -> None
        in
        (find `GET, find `POST, find `DELETE, find `PUT, find `PATCH, subdirs))
      (fun (get, post, delete, put, patch, subdirs) ->
        let add meth s services =
          match s with
          | None ->
              services
          | Some s ->
              Resto.MethMap.add meth s services
        in
        let services =
          Resto.MethMap.empty
          |> add `GET get
          |> add `POST post
          |> add `DELETE delete
          |> add `PUT put
          |> add `PATCH patch
        in
        {services; subdirs})
      (obj6
         (opt "get_service" service_descr_encoding)
         (opt "post_service" service_descr_encoding)
         (opt "delete_service" service_descr_encoding)
         (opt "put_service" service_descr_encoding)
         (opt "patch_service" service_descr_encoding)
         (opt "subdirs" static_subdirectories_descr_encoding))
  in
  union
    [ case
        (Tag 0)
        ~title:"Static"
        (obj1 (req "static" static_directory_descr_encoding))
        (function Static descr -> Some descr | _ -> None)
        (fun descr -> Static descr);
      case
        (Tag 1)
        ~title:"Dynamic"
        (obj1 (req "dynamic" (option string)))
        (function Dynamic descr -> Some descr | _ -> None)
        (fun descr -> Dynamic descr) ]

let description_request_encoding =
  let open Data_encoding in
  conv
    (fun {recurse} -> recurse)
    (function recurse -> {recurse})
    (obj1 (dft "recursive" bool false))

let description_answer_encoding = directory_descr_encoding

let uri_encoding =
  let open Data_encoding in
  conv Uri.to_string Uri.of_string string
src/lib_rpc/RPC_encoding.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t (a : Type) := Tezos_data_encoding.Data_encoding.t a.

Definition schema :=
  Tezos_data_encoding.Data_encoding.json_schema *
    Tezos_data_encoding.Data_encoding.Binary_schema.t.

Definition unit : Tezos_data_encoding.Data_encoding.encoding unit :=
  Tezos_data_encoding.Data_encoding.empty.

Definition untyped : Tezos_data_encoding.Data_encoding.encoding string :=
  Tezos_data_encoding.Data_encoding.obj1
    (Tezos_data_encoding.Data_encoding.req None None "untyped" % string
      Tezos_data_encoding.Data_encoding.string).

Definition conv {A B : Type}
  (f : A -> B) (g : B -> A)
  (t : Tezos_data_encoding__Data_encoding.Encoding.t B)
  : Tezos_data_encoding.Data_encoding.encoding A :=
  Tezos_data_encoding.Data_encoding.conv f g
    (Some (Tezos_data_encoding.Data_encoding.Json.schema None t)) t.

Definition schema {A : Type}
  (definitions_path : option string)
  (t : Tezos_data_encoding__Data_encoding.Encoding.t A)
  : Tezos_data_encoding.Data_encoding.Json.schema *
    Tezos_data_encoding__Data_encoding.Binary_schema.t :=
  ((Tezos_data_encoding.Data_encoding.Json.schema definitions_path t),
    (Tezos_data_encoding.Data_encoding.Binary.describe t)).

Definition schema_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_data_encoding.Data_encoding.json_schema *
      Tezos_data_encoding.Data_encoding.Binary_schema.t) :=
  Tezos_data_encoding.Data_encoding.obj2
    (Tezos_data_encoding.Data_encoding.req None None "json_schema" % string
      Tezos_data_encoding.Data_encoding.json_schema)
    (Tezos_data_encoding.Data_encoding.req None None "binary_schema" % string
      Tezos_data_encoding.Data_encoding.Binary_schema.encoding).

Definition arg_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Arg.descr :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| Resto.Arg.name := name; Resto.Arg.descr := descr |} =>
        (tt, name, descr)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (tt, name, descr) => {| name := name; descr := descr |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj3
      (Tezos_data_encoding.Data_encoding.req None None "id" % string
        (Tezos_data_encoding.Data_encoding.constant "single" % string))
      (Tezos_data_encoding.Data_encoding.req None None "name" % string
        Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.opt None None "descr" % string
        Tezos_data_encoding.Data_encoding.string)).

Definition multi_arg_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Arg.descr :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| Resto.Arg.name := name; Resto.Arg.descr := descr |} =>
        (tt, name, descr)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (tt, name, descr) => {| name := name; descr := descr |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj3
      (Tezos_data_encoding.Data_encoding.req None None "id" % string
        (Tezos_data_encoding.Data_encoding.constant "multiple" % string))
      (Tezos_data_encoding.Data_encoding.req None None "name" % string
        Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.opt None None "descr" % string
        Tezos_data_encoding.Data_encoding.string)).

Import Resto.Description.

Definition meth_encoding : Tezos_data_encoding.Data_encoding.encoding variant :=
  Tezos_data_encoding.Data_encoding.string_enum
    (cons ("GET" % string, variant)
      (cons ("POST" % string, variant)
        (cons ("DELETE" % string, variant)
          (cons ("PUT" % string, variant) (cons ("PATCH" % string, variant) []))))).

Definition path_item_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Description.path_item :=
  Tezos_data_encoding.Data_encoding.union None
    (cons
      (Tezos_data_encoding.Data_encoding.case "PStatic" % string None (Tag 0)
        Tezos_data_encoding.Data_encoding.string
        (fun function_parameter =>
          match function_parameter with
          | PStatic s => Some s
          | _ => None
          end) (fun s => PStatic s))
      (cons
        (Tezos_data_encoding.Data_encoding.case "PDynamic" % string None (Tag 1)
          arg_encoding
          (fun function_parameter =>
            match function_parameter with
            | PDynamic s => Some s
            | _ => None
            end) (fun s => PDynamic s))
        (cons
          (Tezos_data_encoding.Data_encoding.case "PDynamicTail" % string None
            (Tag 2) multi_arg_encoding
            (fun function_parameter =>
              match function_parameter with
              | PDynamicTail s => Some s
              | _ => None
              end) (fun s => PDynamicTail s)) []))).

Definition query_kind_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Description.query_kind :=
  Tezos_data_encoding.Data_encoding.union None
    (cons
      (Tezos_data_encoding.Data_encoding.case "Single" % string None (Tag 0)
        (Tezos_data_encoding.Data_encoding.obj1
          (Tezos_data_encoding.Data_encoding.req None None "single" % string
            arg_encoding))
        (fun function_parameter =>
          match function_parameter with
          | Single s => Some s
          | _ => None
          end) (fun s => Single s))
      (cons
        (Tezos_data_encoding.Data_encoding.case "Optional" % string None (Tag 1)
          (Tezos_data_encoding.Data_encoding.obj1
            (Tezos_data_encoding.Data_encoding.req None None "optional" % string
              arg_encoding))
          (fun function_parameter =>
            match function_parameter with
            | Optional s => Some s
            | _ => None
            end) (fun s => Optional s))
        (cons
          (Tezos_data_encoding.Data_encoding.case "Flag" % string None (Tag 2)
            (Tezos_data_encoding.Data_encoding.obj1
              (Tezos_data_encoding.Data_encoding.req None None "flag" % string
                Tezos_data_encoding.Data_encoding.empty))
            (fun function_parameter =>
              match function_parameter with
              | Flag => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => Flag
              end))
          (cons
            (Tezos_data_encoding.Data_encoding.case "Multi" % string None
              (Tag 3)
              (Tezos_data_encoding.Data_encoding.obj1
                (Tezos_data_encoding.Data_encoding.req None None
                  "multi" % string arg_encoding))
              (fun function_parameter =>
                match function_parameter with
                | Multi s => Some s
                | _ => None
                end) (fun s => Multi s)) [])))).

Definition query_item_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Description.query_item :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| name := name; description := description; kind := kind |} =>
        (name, description, kind)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (name, description, kind) =>
        {| name := name; description := description; kind := kind |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj3
      (Tezos_data_encoding.Data_encoding.req None None "name" % string
        Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.opt None None "description" % string
        Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.req None None "kind" % string
        query_kind_encoding)).

Definition service_descr_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Resto.Description.service
      (Tezos_data_encoding.Data_encoding.json_schema *
        Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        description := description;
          path := path;
          meth := meth;
          query := query;
          input := input;
          output := output;
          error := error
          |} => (meth, path, description, query, input, output, error)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (meth, path, description, query, input, output, error) =>
        {| description := description; path := path; meth := meth;
          query := query; input := input; output := output; error := error |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj7
      (Tezos_data_encoding.Data_encoding.req None None "meth" % string
        meth_encoding)
      (Tezos_data_encoding.Data_encoding.req None None "path" % string
        (Tezos_data_encoding.Data_encoding.list None path_item_encoding))
      (Tezos_data_encoding.Data_encoding.opt None None "description" % string
        Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.req None None "query" % string
        (Tezos_data_encoding.Data_encoding.list None query_item_encoding))
      (Tezos_data_encoding.Data_encoding.opt None None "input" % string
        schema_encoding)
      (Tezos_data_encoding.Data_encoding.req None None "output" % string
        schema_encoding)
      (Tezos_data_encoding.Data_encoding.req None None "error" % string
        schema_encoding)).

Definition directory_descr_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Resto.Description.directory
      (Tezos_data_encoding.Data_encoding.json_schema *
        Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
  apply
    (let arg := Tezos_data_encoding.Data_encoding.mu "service_tree" % string in
    fun eta => arg None None eta)
    (fun directory_descr_encoding =>
      let static_subdirectories_descr_encoding :=
        Tezos_data_encoding.Data_encoding.union None
          (cons
            (Tezos_data_encoding.Data_encoding.case "Suffixes" % string None
              (Tag 0)
              (Tezos_data_encoding.Data_encoding.obj1
                (Tezos_data_encoding.Data_encoding.req None None
                  "suffixes" % string
                  (Tezos_data_encoding.Data_encoding.list None
                    (Tezos_data_encoding.Data_encoding.obj2
                      (Tezos_data_encoding.Data_encoding.req None None
                        "name" % string Tezos_data_encoding.Data_encoding.string)
                      (Tezos_data_encoding.Data_encoding.req None None
                        "tree" % string directory_descr_encoding)))))
              (fun function_parameter =>
                match function_parameter with
                | Suffixes map => Some (StringMap.bindings map)
                | _ => None
                end)
              (fun m =>
                let add {A : Type}
                  (acc : StringMap.t A) (function_parameter : StringMap.key * A)
                  : StringMap.t A :=
                  match function_parameter with
                  | (n, t) => StringMap.add n t acc
                  end in
                Suffixes (Stdlib.List.fold_left add StringMap.empty m)))
            (cons
              (Tezos_data_encoding.Data_encoding.case "Arg" % string None
                (Tag 1)
                (Tezos_data_encoding.Data_encoding.obj1
                  (Tezos_data_encoding.Data_encoding.req None None
                    "dynamic_dispatch" % string
                    (Tezos_data_encoding.Data_encoding.obj2
                      (Tezos_data_encoding.Data_encoding.req None None
                        "arg" % string arg_encoding)
                      (Tezos_data_encoding.Data_encoding.req None None
                        "tree" % string directory_descr_encoding))))
                (fun function_parameter =>
                  match function_parameter with
                  | Arg ty tree => Some (ty, tree)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (ty, tree) => Arg ty tree
                  end)) [])) in
      let static_directory_descr_encoding :=
        Tezos_data_encoding.Data_encoding.conv
          (fun function_parameter =>
            match function_parameter with
            | {| services := services; subdirs := subdirs |} =>
              let find (s : Resto.MethMap.key)
                : option
                  (Resto.Description.service
                    (Tezos_data_encoding.Data_encoding.json_schema *
                      Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
                try in
              ((find variant), (find variant), (find variant), (find variant),
                (find variant), subdirs)
            end)
          (fun function_parameter =>
            match function_parameter with
            | (get, post, delete, put, patch, subdirs) =>
              let add {A : Type}
                (meth : Resto.MethMap.key) (s : option A) (services :
                Resto.MethMap.t A) : Resto.MethMap.t A :=
                match s with
                | None => services
                | Some s => Resto.MethMap.add meth s services
                end in
              let services :=
                OCaml.Stdlib.reverse_apply
                  (OCaml.Stdlib.reverse_apply
                    (OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply
                        (OCaml.Stdlib.reverse_apply Resto.MethMap.empty
                          (add variant get)) (add variant post))
                      (add variant delete)) (add variant put))
                  (add variant patch) in
              {| services := services; subdirs := subdirs |}
            end) None
          (Tezos_data_encoding.Data_encoding.obj6
            (Tezos_data_encoding.Data_encoding.opt None None
              "get_service" % string service_descr_encoding)
            (Tezos_data_encoding.Data_encoding.opt None None
              "post_service" % string service_descr_encoding)
            (Tezos_data_encoding.Data_encoding.opt None None
              "delete_service" % string service_descr_encoding)
            (Tezos_data_encoding.Data_encoding.opt None None
              "put_service" % string service_descr_encoding)
            (Tezos_data_encoding.Data_encoding.opt None None
              "patch_service" % string service_descr_encoding)
            (Tezos_data_encoding.Data_encoding.opt None None "subdirs" % string
              static_subdirectories_descr_encoding)) in
      Tezos_data_encoding.Data_encoding.union None
        (cons
          (Tezos_data_encoding.Data_encoding.case "Static" % string None (Tag 0)
            (Tezos_data_encoding.Data_encoding.obj1
              (Tezos_data_encoding.Data_encoding.req None None "static" % string
                static_directory_descr_encoding))
            (fun function_parameter =>
              match function_parameter with
              | Static descr => Some descr
              | _ => None
              end) (fun descr => Static descr))
          (cons
            (Tezos_data_encoding.Data_encoding.case "Dynamic" % string None
              (Tag 1)
              (Tezos_data_encoding.Data_encoding.obj1
                (Tezos_data_encoding.Data_encoding.req None None
                  "dynamic" % string
                  (Tezos_data_encoding.Data_encoding.option
                    Tezos_data_encoding.Data_encoding.string)))
              (fun function_parameter =>
                match function_parameter with
                | Dynamic descr => Some descr
                | _ => None
                end) (fun descr => Dynamic descr)) []))).

Definition description_request_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Description.request :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| recurse := recurse |} => recurse
      end) (fun recurse => {| recurse := recurse |}) None
    (Tezos_data_encoding.Data_encoding.obj1
      (Tezos_data_encoding.Data_encoding.dft None None "recursive" % string
        Tezos_data_encoding.Data_encoding.bool false)).

Definition description_answer_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Resto.Description.directory
      (Tezos_data_encoding.Data_encoding.json_schema *
        Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
  directory_descr_encoding.

Definition uri_encoding : Tezos_data_encoding.Data_encoding.encoding Uri.t :=
  Tezos_data_encoding.Data_encoding.conv Uri.to_string Uri.of_string None
    Tezos_data_encoding.Data_encoding.string.
src/lib_rpc/RPC_encoding.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type schema = Data_encoding.json_schema * Data_encoding.Binary_schema.t

include
  Resto.ENCODING with type 'a t = 'a Data_encoding.t and type schema := schema

val uri_encoding : Uri.t Data_encoding.t
src/lib_rpc/RPC_encoding.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition schema :=
  Tezos_data_encoding.Data_encoding.json_schema *
    Tezos_data_encoding.Data_encoding.Binary_schema.t.

include

Parameter uri_encoding : Tezos_data_encoding.Data_encoding.t Uri.t.
src/lib_rpc/RPC_error.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let list ctxt = RPC_context.make_call RPC_service.error_service ctxt () () ()

let encoding = RPC_service.error_encoding
src/lib_rpc/RPC_error.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition list {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult Json_schema.schema) :=
  Tezos_rpc.RPC_context.make_call Tezos_rpc.RPC_service.error_service ctxt tt tt
    tt.

Definition encoding
  : Tezos_data_encoding.Data_encoding.t Tezos_rpc.RPC_service.error :=
  Tezos_rpc.RPC_service.error_encoding.
src/lib_rpc/RPC_error.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

val list : #RPC_context.simple -> Json_schema.schema tzresult Lwt.t

val encoding : error list Data_encoding.t
src/lib_rpc/RPC_error.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter list : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t (Tezos_error_monad.Error_monad.tzresult Json_schema.schema).

Parameter encoding :
Tezos_data_encoding.Data_encoding.t (list Tezos_error_monad.Error_monad.error).
src/lib_rpc/RPC_path.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto.Path
src/lib_rpc/RPC_path.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_rpc/RPC_path.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include module type of struct
  include Resto.Path
end
src/lib_rpc/RPC_path.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_rpc/RPC_query.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto.Query
src/lib_rpc/RPC_query.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_rpc/RPC_query.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include module type of struct
  include Resto.Query
end
src/lib_rpc/RPC_query.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_rpc_http/RPC_client.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type S = sig
  module type LOGGER = sig
    type request

    val log_empty_request : Uri.t -> request Lwt.t

    val log_request :
      ?media:Media_type.t ->
      'a Data_encoding.t ->
      Uri.t ->
      string ->
      request Lwt.t

    val log_response :
      request ->
      ?media:Media_type.t ->
      'a Data_encoding.t ->
      Cohttp.Code.status_code ->
      string Lwt.t Lazy.t ->
      unit Lwt.t
  end

  type logger = (module LOGGER)

  val null_logger : logger

  val timings_logger :
    gettimeofday:(unit -> float) -> Format.formatter -> logger

  val full_logger : Format.formatter -> logger

  type config = {host : string; port : int; tls : bool; logger : logger}

  val config_encoding : config Data_encoding.t

  val default_config : config

  class http_ctxt : config -> Media_type.t list -> RPC_context.json

  (**/**)

  val call_service :
    Media_type.t list ->
    ?logger:logger ->
    ?headers:(string * string) list ->
    base:Uri.t ->
    ([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
    'p ->
    'q ->
    'i ->
    'o tzresult Lwt.t

  val call_streamed_service :
    Media_type.t list ->
    ?logger:logger ->
    ?headers:(string * string) list ->
    base:Uri.t ->
    ([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
    on_chunk:('o -> unit) ->
    on_close:(unit -> unit) ->
    'p ->
    'q ->
    'i ->
    (unit -> unit) tzresult Lwt.t

  val generic_json_call :
    ?headers:(string * string) list ->
    ?body:Data_encoding.json ->
    [< RPC_service.meth] ->
    Uri.t ->
    (Data_encoding.json, Data_encoding.json option) RPC_context.rest_result
    Lwt.t

  type content_type = string * string

  type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option

  val generic_call :
    ?headers:(string * string) list ->
    ?accept:Media_type.t list ->
    ?body:Cohttp_lwt.Body.t ->
    ?media:Media_type.t ->
    [< RPC_service.meth] ->
    Uri.t ->
    (content, content) RPC_context.rest_result Lwt.t
end

module Make (Client : Cohttp_lwt.S.Client) = struct
  module Client = Resto_cohttp_client.Client.Make (RPC_encoding) (Client)

  module type LOGGER = Client.LOGGER

  type logger = (module LOGGER)

  let null_logger = Client.null_logger

  let timings_logger = Client.timings_logger

  let full_logger = Client.full_logger

  type content_type = string * string

  type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option

  let request_failed meth uri error =
    let meth = (meth : [< RPC_service.meth] :> RPC_service.meth) in
    fail (RPC_client_errors.Request_failed {meth; uri; error})

  let generic_call ?headers ?accept ?body ?media meth uri :
      (content, content) RPC_context.rest_result Lwt.t =
    Client.generic_call meth ?headers ?accept ?body ?media uri
    >>= function
    | `Ok (Some v) ->
        return (`Ok v)
    | `Ok None ->
        request_failed meth uri Empty_answer
    | (`Conflict _ | `Error _ | `Forbidden _ | `Unauthorized _ | `Not_found _)
      as v ->
        return v
    | `Unexpected_status_code (code, (content, _, media_type)) ->
        let media_type = Option.map media_type ~f:Media_type.name in
        Cohttp_lwt.Body.to_string content
        >>= fun content ->
        request_failed
          meth
          uri
          (Unexpected_status_code {code; content; media_type})
    | `Method_not_allowed allowed ->
        let allowed = List.filter_map RPC_service.meth_of_string allowed in
        request_failed meth uri (Method_not_allowed allowed)
    | `Unsupported_media_type ->
        let media = Option.map media ~f:Media_type.name in
        request_failed meth uri (Unsupported_media_type media)
    | `Not_acceptable acceptable ->
        let proposed =
          Option.unopt_map accept ~default:"" ~f:Media_type.accept_header
        in
        request_failed meth uri (Not_acceptable {proposed; acceptable})
    | `Bad_request msg ->
        request_failed meth uri (Bad_request msg)
    | `Connection_failed msg ->
        request_failed meth uri (Connection_failed msg)
    | `OCaml_exception msg ->
        request_failed meth uri (OCaml_exception msg)
    | `Unauthorized_host host ->
        request_failed meth uri (Unauthorized_host host)

  let handle_error meth uri (body, media, _) f =
    Cohttp_lwt.Body.is_empty body
    >>= fun empty ->
    if empty then return (f None)
    else
      match media with
      | Some ("application", "json") | None -> (
          Cohttp_lwt.Body.to_string body
          >>= fun body ->
          match Data_encoding.Json.from_string body with
          | Ok body ->
              return (f (Some body))
          | Error msg ->
              request_failed
                meth
                uri
                (Unexpected_content
                   {
                     content = body;
                     media_type = Media_type.(name json);
                     error = msg;
                   }) )
      | Some (l, r) ->
          Cohttp_lwt.Body.to_string body
          >>= fun body ->
          request_failed
            meth
            uri
            (Unexpected_content_type
               {
                 received = l ^ "/" ^ r;
                 acceptable = [Media_type.(name json)];
                 body;
               })

  let generic_json_call ?headers ?body meth uri :
      (Data_encoding.json, Data_encoding.json option) RPC_context.rest_result
      Lwt.t =
    let body =
      Option.map body ~f:(fun b ->
          Cohttp_lwt.Body.of_string (Data_encoding.Json.to_string b))
    in
    let media = Media_type.json in
    generic_call meth ?headers ~accept:Media_type.[bson; json] ?body ~media uri
    >>=? function
    | `Ok (body, (Some ("application", "json") | None), _) -> (
        Cohttp_lwt.Body.to_string body
        >>= fun body ->
        match Data_encoding.Json.from_string body with
        | Ok json ->
            return (`Ok json)
        | Error msg ->
            request_failed
              meth
              uri
              (Unexpected_content
                 {
                   content = body;
                   media_type = Media_type.(name json);
                   error = msg;
                 }) )
    | `Ok (body, Some ("application", "bson"), _) -> (
        Cohttp_lwt.Body.to_string body
        >>= fun body ->
        match
          Json_repr_bson.bytes_to_bson
            ~laziness:false
            ~copy:false
            (Bytes.unsafe_of_string body)
        with
        | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) ->
            let error = Format.asprintf "(at offset: %d) %s" pos msg in
            request_failed
              meth
              uri
              (Unexpected_content
                 {content = body; media_type = Media_type.(name bson); error})
        | bson ->
            return
              (`Ok
                (Json_repr.convert
                   (module Json_repr_bson.Repr)
                   (module Json_repr.Ezjsonm)
                   bson)) )
    | `Ok (body, Some (l, r), _) ->
        Cohttp_lwt.Body.to_string body
        >>= fun body ->
        request_failed
          meth
          uri
          (Unexpected_content_type
             {
               received = l ^ "/" ^ r;
               acceptable = [Media_type.(name json)];
               body;
             })
    | `Conflict body ->
        handle_error meth uri body (fun v -> `Conflict v)
    | `Error body ->
        handle_error meth uri body (fun v -> `Error v)
    | `Forbidden body ->
        handle_error meth uri body (fun v -> `Forbidden v)
    | `Not_found body ->
        handle_error meth uri body (fun v -> `Not_found v)
    | `Unauthorized body ->
        handle_error meth uri body (fun v -> `Unauthorized v)

  let handle accept (meth, uri, ans) =
    match ans with
    | `Ok (Some v) ->
        return v
    | `Ok None ->
        request_failed meth uri Empty_answer
    | `Not_found None ->
        fail (RPC_context.Not_found {meth; uri})
    | `Conflict (Some err)
    | `Error (Some err)
    | `Forbidden (Some err)
    | `Unauthorized (Some err)
    | `Not_found (Some err) ->
        Lwt.return_error err
    | `Conflict None | `Error None | `Forbidden None | `Unauthorized None ->
        fail (RPC_context.Generic_error {meth; uri})
    | `Unexpected_status_code (code, (content, _, media_type)) ->
        let media_type = Option.map media_type ~f:Media_type.name in
        Cohttp_lwt.Body.to_string content
        >>= fun content ->
        request_failed
          meth
          uri
          (Unexpected_status_code {code; content; media_type})
    | `Method_not_allowed allowed ->
        let allowed = List.filter_map RPC_service.meth_of_string allowed in
        request_failed meth uri (Method_not_allowed allowed)
    | `Unsupported_media_type ->
        let name =
          match Media_type.first_complete_media accept with
          | None ->
              None
          | Some ((l, r), _) ->
              Some (l ^ "/" ^ r)
        in
        request_failed meth uri (Unsupported_media_type name)
    | `Not_acceptable acceptable ->
        let proposed =
          Option.unopt_map
            (Some accept)
            ~default:""
            ~f:Media_type.accept_header
        in
        request_failed meth uri (Not_acceptable {proposed; acceptable})
    | `Bad_request msg ->
        request_failed meth uri (Bad_request msg)
    | `Unexpected_content ((content, media_type), error)
    | `Unexpected_error_content ((content, media_type), error) ->
        let media_type = Media_type.name media_type in
        request_failed
          meth
          uri
          (Unexpected_content {content; media_type; error})
    | `Unexpected_error_content_type (body, media)
    | `Unexpected_content_type (body, media) ->
        Cohttp_lwt.Body.to_string body
        >>= fun body ->
        let received =
          Option.unopt_map media ~default:"" ~f:(fun (l, r) -> l ^ "/" ^ r)
        in
        request_failed
          meth
          uri
          (Unexpected_content_type
             {received; acceptable = List.map Media_type.name accept; body})
    | `Connection_failed msg ->
        request_failed meth uri (Connection_failed msg)
    | `OCaml_exception msg ->
        request_failed meth uri (OCaml_exception msg)
    | `Unauthorized_host host ->
        request_failed meth uri (Unauthorized_host host)

  let call_streamed_service (type p q i o) accept ?logger ?headers ~base
      (service : (_, _, p, q, i, o) RPC_service.t) ~on_chunk ~on_close
      (params : p) (query : q) (body : i) : (unit -> unit) tzresult Lwt.t =
    Client.call_streamed_service
      accept
      ?logger
      ?headers
      ~base
      ~on_chunk
      ~on_close
      service
      params
      query
      body
    >>= fun ans -> handle accept ans

  let call_service (type p q i o) accept ?logger ?headers ~base
      (service : (_, _, p, q, i, o) RPC_service.t) (params : p) (query : q)
      (body : i) : o tzresult Lwt.t =
    Client.call_service ?logger ?headers ~base accept service params query body
    >>= fun ans -> handle accept ans

  type config = {host : string; port : int; tls : bool; logger : logger}

  let config_encoding =
    let open Data_encoding in
    conv
      (fun {host; port; tls; logger = _} -> (host, port, tls))
      (fun (host, port, tls) -> {host; port; tls; logger = null_logger})
      (obj3 (req "host" string) (req "port" uint16) (req "tls" bool))

  let default_config =
    {host = "localhost"; port = 8732; tls = false; logger = null_logger}

  class http_ctxt config media_types : RPC_context.json =
    let base =
      Uri.make
        ~scheme:(if config.tls then "https" else "http")
        ~host:config.host
        ~port:config.port
        ()
    in
    let logger = config.logger in
    object
      method generic_json_call meth ?body uri =
        let path = Uri.path uri and query = Uri.query uri in
        let uri = Uri.with_path base path in
        let uri = Uri.with_query uri query in
        generic_json_call meth ?body uri

      method call_service
          : 'm 'p 'q 'i 'o.
            (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
            'p -> 'q -> 'i -> 'o tzresult Lwt.t =
        fun service params query body ->
          call_service media_types ~logger ~base service params query body

      method call_streamed_service
          : 'm 'p 'q 'i 'o.
            (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
            on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q ->
            'i -> (unit -> unit) tzresult Lwt.t =
        fun service ~on_chunk ~on_close params query body ->
          call_streamed_service
            media_types
            service
            ~logger
            ~base
            ~on_chunk
            ~on_close
            params
            query
            body

      method base = base
    end
end
src/lib_rpc_http/RPC_client.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Record signature {config : Type} := {
    module_type;
    logger := {request : _ & LOGGER.signature request};
    null_logger : logger;
    timings_logger : (unit -> float) -> Stdlib.Format.formatter -> logger;
    full_logger : Stdlib.Format.formatter -> logger;
    config := config;
    config_encoding : Tezos_base__TzPervasives.Data_encoding.t config;
    default_config : config;
    class;
    call_service : forall {i o p q variant : Type}, (list
      Tezos_rpc_http.Media_type.t) ->
      (option logger) ->
        (option (list (string * string))) ->
          Uri.t ->
            (Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o);
    call_streamed_service : forall {i o p q variant : Type}, (list
      Tezos_rpc_http.Media_type.t) ->
      (option logger) ->
        (option (list (string * string))) ->
          Uri.t ->
            (Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult (unit -> unit));
    generic_json_call : forall {variant : Type}, (option
      (list (string * string))) ->
      (option Tezos_base__TzPervasives.Data_encoding.json) ->
        variant ->
          Uri.t ->
            Lwt.t
              (Tezos_rpc.RPC_context.rest_result
                Tezos_base__TzPervasives.Data_encoding.json
                (option Tezos_base__TzPervasives.Data_encoding.json));
    content_type := string * string;
    content := Cohttp_lwt.Body.t * (option content_type) *
      (option Tezos_rpc_http.Media_type.t);
    generic_call : forall {variant : Type}, (option (list (string * string))) ->
      (option (list Tezos_rpc_http.Media_type.t)) ->
        (option Cohttp_lwt.Body.t) ->
          (option Tezos_rpc_http.Media_type.t) ->
            variant ->
              Uri.t -> Lwt.t (Tezos_rpc.RPC_context.rest_result content content);
  }.
  Arguments signature : clear implicits.
End S.
src/lib_rpc_http/RPC_client.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type S = sig
  module type LOGGER = sig
    type request

    val log_empty_request : Uri.t -> request Lwt.t

    val log_request :
      ?media:Media_type.t ->
      'a Data_encoding.t ->
      Uri.t ->
      string ->
      request Lwt.t

    val log_response :
      request ->
      ?media:Media_type.t ->
      'a Data_encoding.t ->
      Cohttp.Code.status_code ->
      string Lwt.t Lazy.t ->
      unit Lwt.t
  end

  type logger = (module LOGGER)

  val null_logger : logger

  val timings_logger :
    gettimeofday:(unit -> float) -> Format.formatter -> logger

  val full_logger : Format.formatter -> logger

  type config = {host : string; port : int; tls : bool; logger : logger}

  val config_encoding : config Data_encoding.t

  val default_config : config

  class http_ctxt : config -> Media_type.t list -> RPC_context.json

  (**/**)

  val call_service :
    Media_type.t list ->
    ?logger:logger ->
    ?headers:(string * string) list ->
    base:Uri.t ->
    ([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
    'p ->
    'q ->
    'i ->
    'o tzresult Lwt.t

  val call_streamed_service :
    Media_type.t list ->
    ?logger:logger ->
    ?headers:(string * string) list ->
    base:Uri.t ->
    ([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
    on_chunk:('o -> unit) ->
    on_close:(unit -> unit) ->
    'p ->
    'q ->
    'i ->
    (unit -> unit) tzresult Lwt.t

  val generic_json_call :
    ?headers:(string * string) list ->
    ?body:Data_encoding.json ->
    [< RPC_service.meth] ->
    Uri.t ->
    (Data_encoding.json, Data_encoding.json option) RPC_context.rest_result
    Lwt.t

  type content_type = string * string

  type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option

  val generic_call :
    ?headers:(string * string) list ->
    ?accept:Media_type.t list ->
    ?body:Cohttp_lwt.Body.t ->
    ?media:Media_type.t ->
    [< RPC_service.meth] ->
    Uri.t ->
    (content, content) RPC_context.rest_result Lwt.t
end

module Make (Client : Cohttp_lwt.S.Client) : S
src/lib_rpc_http/RPC_client.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

unhandled_module
src/lib_rpc_http/RPC_client_errors.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type rpc_error =
  | Empty_answer
  | Connection_failed of string
  | Bad_request of string
  | Method_not_allowed of RPC_service.meth list
  | Unsupported_media_type of string option
  | Not_acceptable of {proposed : string; acceptable : string}
  | Unexpected_status_code of {
      code : Cohttp.Code.status_code;
      content : string;
      media_type : string option;
    }
  | Unexpected_content_type of {
      received : string;
      acceptable : string list;
      body : string;
    }
  | Unexpected_content of {
      content : string;
      media_type : string;
      error : string;
    }
  | OCaml_exception of string
  | Unauthorized_host of string option

type error +=
  | Request_failed of {meth : RPC_service.meth; uri : Uri.t; error : rpc_error}

let rpc_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Empty_answer"
        (obj1 (req "kind" (constant "empty_answer")))
        (function Empty_answer -> Some () | _ -> None)
        (fun () -> Empty_answer);
      case
        (Tag 1)
        ~title:"Connection_failed"
        (obj2
           (req "kind" (constant "connection_failed"))
           (req "message" string))
        (function Connection_failed msg -> Some ((), msg) | _ -> None)
        (function ((), msg) -> Connection_failed msg);
      case
        (Tag 2)
        ~title:"Bad_request"
        (obj2 (req "kind" (constant "bad_request")) (req "message" string))
        (function Bad_request msg -> Some ((), msg) | _ -> None)
        (function ((), msg) -> Bad_request msg);
      case
        (Tag 3)
        ~title:"Method_not_allowed"
        (obj2
           (req "kind" (constant "method_not_allowed"))
           (req "allowed" (list RPC_service.meth_encoding)))
        (function Method_not_allowed meths -> Some ((), meths) | _ -> None)
        (function ((), meths) -> Method_not_allowed meths);
      case
        (Tag 4)
        ~title:"Unsupported_media_type"
        (obj2
           (req "kind" (constant "unsupported_media_type"))
           (opt "content_type" string))
        (function Unsupported_media_type m -> Some ((), m) | _ -> None)
        (function ((), m) -> Unsupported_media_type m);
      case
        (Tag 5)
        ~title:"Not_acceptable"
        (obj3
           (req "kind" (constant "not_acceptable"))
           (req "proposed" string)
           (req "acceptable" string))
        (function
          | Not_acceptable {proposed; acceptable} ->
              Some ((), proposed, acceptable)
          | _ ->
              None)
        (function
          | ((), proposed, acceptable) -> Not_acceptable {proposed; acceptable});
      case
        (Tag 6)
        ~title:"Unexpected_status_code"
        (obj4
           (req "kind" (constant "unexpected_status_code"))
           (req "code" uint16)
           (req "content" string)
           (opt "media_type" string))
        (function
          | Unexpected_status_code {code; content; media_type} ->
              Some ((), Cohttp.Code.code_of_status code, content, media_type)
          | _ ->
              None)
        (function
          | ((), code, content, media_type) ->
              let code = Cohttp.Code.status_of_code code in
              Unexpected_status_code {code; content; media_type});
      case
        (Tag 7)
        ~title:"Unexpected_content_type"
        (obj4
           (req "kind" (constant "unexpected_content_type"))
           (req "received" string)
           (req "acceptable" (list string))
           (req "body" string))
        (function
          | Unexpected_content_type {received; acceptable; body} ->
              Some ((), received, acceptable, body)
          | _ ->
              None)
        (function
          | ((), received, acceptable, body) ->
              Unexpected_content_type {received; acceptable; body});
      case
        (Tag 8)
        ~title:"Unexpected_content"
        (obj4
           (req "kind" (constant "unexpected_content"))
           (req "content" string)
           (req "media_type" string)
           (req "error" string))
        (function
          | Unexpected_content {content; media_type; error} ->
              Some ((), content, media_type, error)
          | _ ->
              None)
        (function
          | ((), content, media_type, error) ->
              Unexpected_content {content; media_type; error});
      case
        (Tag 9)
        ~title:"OCaml_exception"
        (obj2 (req "kind" (constant "ocaml_exception")) (req "content" string))
        (function OCaml_exception msg -> Some ((), msg) | _ -> None)
        (function ((), msg) -> OCaml_exception msg) ]

let pp_rpc_error ppf err =
  match err with
  | Empty_answer ->
      Format.fprintf ppf "The server answered with an empty response."
  | Connection_failed msg ->
      Format.fprintf ppf "Unable to connect to the node: \"%s\"" msg
  | Bad_request msg ->
      Format.fprintf
        ppf
        "@[<v 2>Oups! It looks like we forged an invalid HTTP request.@,%s@]"
        msg
  | Method_not_allowed meths ->
      Format.fprintf
        ppf
        "@[<v 2>The requested service only accepts the following method:@ %a@]"
        (Format.pp_print_list (fun ppf m ->
             Format.pp_print_string ppf (RPC_service.string_of_meth m)))
        meths
  | Unsupported_media_type None ->
      Format.fprintf
        ppf
        "@[<v 2>The server wants to known the media type we used.@]"
  | Unsupported_media_type (Some media) ->
      Format.fprintf
        ppf
        "@[<v 2>The server does not support the media type we used: %s.@]"
        media
  | Not_acceptable {proposed; acceptable} ->
      Format.fprintf
        ppf
        "@[<v 2>No intersection between the media types we accept and  the \
         ones the server is able to send.@,\
        \ We proposed: %s@,\
        \ The server is only able to serve: %s."
        proposed
        acceptable
  | Unexpected_status_code {code; content; _} ->
      Format.fprintf
        ppf
        "@[<v 2>Unexpected error %d:@,%S"
        (Cohttp.Code.code_of_status code)
        content
  | Unexpected_content_type {received; acceptable = _; body} ->
      Format.fprintf
        ppf
        "@[<v 0>The server answered with a media type we do not understand: \
         %s.@,\
         The response body was:@,\
         %s@]"
        received
        body
  | Unexpected_content {content; media_type; error} ->
      Format.fprintf
        ppf
        "@[<v 2>Failed to parse the answer (%s):@,\
         @[<v 2>error:@ %s@]@,\
         @[<v 2>content:@ %S@]@]"
        media_type
        error
        content
  | OCaml_exception msg ->
      Format.fprintf
        ppf
        "@[<v 2>The server failed with an unexpected exception:@ %s@]"
        msg
  | Unauthorized_host host ->
      Format.fprintf
        ppf
        "@[<v 2>The server refused connection to host \"%s\", please check \
         the node settings for CORS allowed origins.@]"
        (Option.unopt ~default:"" host)

let () =
  register_error_kind
    `Permanent
    ~id:"rpc_client.request_failed"
    ~title:""
    ~description:""
    ~pp:(fun ppf (meth, uri, error) ->
      Format.fprintf
        ppf
        "@[<v 2>Rpc request failed:@  - meth: %s@  - uri: %s@  - error: %a@]"
        (RPC_service.string_of_meth meth)
        (Uri.to_string uri)
        pp_rpc_error
        error)
    Data_encoding.(
      obj3
        (req "meth" RPC_service.meth_encoding)
        (req "uri" RPC_encoding.uri_encoding)
        (req "error" rpc_error_encoding))
    (function
      | Request_failed {uri; error; meth} ->
          Some (meth, uri, error)
      | _ ->
          None)
    (fun (meth, uri, error) -> Request_failed {uri; meth; error})
src/lib_rpc_http/RPC_client_errors.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive rpc_error : Type :=
| Empty_answer : rpc_error
| Connection_failed : string -> rpc_error
| Bad_request : string -> rpc_error
| Method_not_allowed : (list Tezos_rpc.RPC_service.meth) -> rpc_error
| Unsupported_media_type : (option string) -> rpc_error
| Not_acceptable : string -> string -> rpc_error
| Unexpected_status_code : Cohttp.Code.status_code -> string -> (option string)
  -> rpc_error
| Unexpected_content_type : string -> (list string) -> string -> rpc_error
| Unexpected_content : string -> string -> string -> rpc_error
| OCaml_exception : string -> rpc_error
| Unauthorized_host : (option string) -> rpc_error.

Definition rpc_error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding rpc_error :=
  Tezos_base__TzPervasives.Data_encoding.union None
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case "Empty_answer" % string None
        (Tag 0)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None "kind" % string
            (Tezos_base__TzPervasives.Data_encoding.constant
              "empty_answer" % string)))
        (fun function_parameter =>
          match function_parameter with
          | Empty_answer => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | tt => Empty_answer
          end))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case
          "Connection_failed" % string None (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.obj2
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "kind" % string
              (Tezos_base__TzPervasives.Data_encoding.constant
                "connection_failed" % string))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "message" % string Tezos_base__TzPervasives.Data_encoding.string))
          (fun function_parameter =>
            match function_parameter with
            | Connection_failed msg => Some (tt, msg)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (tt, msg) => Connection_failed msg
            end))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Bad_request" % string
            None (Tag 2)
            (Tezos_base__TzPervasives.Data_encoding.obj2
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "kind" % string
                (Tezos_base__TzPervasives.Data_encoding.constant
                  "bad_request" % string))
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "message" % string Tezos_base__TzPervasives.Data_encoding.string))
            (fun function_parameter =>
              match function_parameter with
              | Bad_request msg => Some (tt, msg)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tt, msg) => Bad_request msg
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case
              "Method_not_allowed" % string None (Tag 3)
              (Tezos_base__TzPervasives.Data_encoding.obj2
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "kind" % string
                  (Tezos_base__TzPervasives.Data_encoding.constant
                    "method_not_allowed" % string))
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "allowed" % string
                  (Tezos_base__TzPervasives.Data_encoding.list None
                    Tezos_rpc.RPC_service.meth_encoding)))
              (fun function_parameter =>
                match function_parameter with
                | Method_not_allowed meths => Some (tt, meths)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (tt, meths) => Method_not_allowed meths
                end))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case
                "Unsupported_media_type" % string None (Tag 4)
                (Tezos_base__TzPervasives.Data_encoding.obj2
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "kind" % string
                    (Tezos_base__TzPervasives.Data_encoding.constant
                      "unsupported_media_type" % string))
                  (Tezos_base__TzPervasives.Data_encoding.opt None None
                    "content_type" % string
                    Tezos_base__TzPervasives.Data_encoding.string))
                (fun function_parameter =>
                  match function_parameter with
                  | Unsupported_media_type m => Some (tt, m)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (tt, m) => Unsupported_media_type m
                  end))
              (cons
                (Tezos_base__TzPervasives.Data_encoding.case
                  "Not_acceptable" % string None (Tag 5)
                  (Tezos_base__TzPervasives.Data_encoding.obj3
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "kind" % string
                      (Tezos_base__TzPervasives.Data_encoding.constant
                        "not_acceptable" % string))
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "proposed" % string
                      Tezos_base__TzPervasives.Data_encoding.string)
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "acceptable" % string
                      Tezos_base__TzPervasives.Data_encoding.string))
                  (fun function_parameter =>
                    match function_parameter with
                    |
                      Not_acceptable {|
                        proposed := proposed; acceptable := acceptable |} =>
                      Some (tt, proposed, acceptable)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | (tt, proposed, acceptable) =>
                      Not_acceptable
                        {| proposed := proposed; acceptable := acceptable |}
                    end))
                (cons
                  (Tezos_base__TzPervasives.Data_encoding.case
                    "Unexpected_status_code" % string None (Tag 6)
                    (Tezos_base__TzPervasives.Data_encoding.obj4
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "kind" % string
                        (Tezos_base__TzPervasives.Data_encoding.constant
                          "unexpected_status_code" % string))
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "code" % string
                        Tezos_base__TzPervasives.Data_encoding.uint16)
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "content" % string
                        Tezos_base__TzPervasives.Data_encoding.string)
                      (Tezos_base__TzPervasives.Data_encoding.opt None None
                        "media_type" % string
                        Tezos_base__TzPervasives.Data_encoding.string))
                    (fun function_parameter =>
                      match function_parameter with
                      |
                        Unexpected_status_code {|
                          code := code;
                            content := content;
                            media_type := media_type
                            |} =>
                        Some
                          (tt, (Cohttp.Code.code_of_status code), content,
                            media_type)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | (tt, code, content, media_type) =>
                        let code := Cohttp.Code.status_of_code code in
                        Unexpected_status_code
                          {| code := code; content := content;
                            media_type := media_type |}
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Data_encoding.case
                      "Unexpected_content_type" % string None (Tag 7)
                      (Tezos_base__TzPervasives.Data_encoding.obj4
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "kind" % string
                          (Tezos_base__TzPervasives.Data_encoding.constant
                            "unexpected_content_type" % string))
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "received" % string
                          Tezos_base__TzPervasives.Data_encoding.string)
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "acceptable" % string
                          (Tezos_base__TzPervasives.Data_encoding.list None
                            Tezos_base__TzPervasives.Data_encoding.string))
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "body" % string
                          Tezos_base__TzPervasives.Data_encoding.string))
                      (fun function_parameter =>
                        match function_parameter with
                        |
                          Unexpected_content_type {|
                            received := received;
                              acceptable := acceptable;
                              body := body
                              |} => Some (tt, received, acceptable, body)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | (tt, received, acceptable, body) =>
                          Unexpected_content_type
                            {| received := received; acceptable := acceptable;
                              body := body |}
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Data_encoding.case
                        "Unexpected_content" % string None (Tag 8)
                        (Tezos_base__TzPervasives.Data_encoding.obj4
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "kind" % string
                            (Tezos_base__TzPervasives.Data_encoding.constant
                              "unexpected_content" % string))
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "content" % string
                            Tezos_base__TzPervasives.Data_encoding.string)
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "media_type" % string
                            Tezos_base__TzPervasives.Data_encoding.string)
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "error" % string
                            Tezos_base__TzPervasives.Data_encoding.string))
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Unexpected_content {|
                              content := content;
                                media_type := media_type;
                                error := error
                                |} => Some (tt, content, media_type, error)
                          | _ => None
                          end)
                        (fun function_parameter =>
                          match function_parameter with
                          | (tt, content, media_type, error) =>
                            Unexpected_content
                              {| content := content; media_type := media_type;
                                error := error |}
                          end))
                      (cons
                        (Tezos_base__TzPervasives.Data_encoding.case
                          "OCaml_exception" % string None (Tag 9)
                          (Tezos_base__TzPervasives.Data_encoding.obj2
                            (Tezos_base__TzPervasives.Data_encoding.req None
                              None "kind" % string
                              (Tezos_base__TzPervasives.Data_encoding.constant
                                "ocaml_exception" % string))
                            (Tezos_base__TzPervasives.Data_encoding.req None
                              None "content" % string
                              Tezos_base__TzPervasives.Data_encoding.string))
                          (fun function_parameter =>
                            match function_parameter with
                            | OCaml_exception msg => Some (tt, msg)
                            | _ => None
                            end)
                          (fun function_parameter =>
                            match function_parameter with
                            | (tt, msg) => OCaml_exception msg
                            end)) [])))))))))).

Definition pp_rpc_error (ppf : Stdlib.Format.formatter) (err : rpc_error)
  : unit :=
  match err with
  | Empty_answer =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "The server answered with an empty response." % string
          CamlinternalFormatBasics.End_of_format)
        "The server answered with an empty response." % string)
  | Connection_failed msg =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Unable to connect to the node: """ % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal """" % char
              CamlinternalFormatBasics.End_of_format)))
        "Unable to connect to the node: ""%s""" % string) msg
  | Bad_request msg =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Oups! It looks like we forged an invalid HTTP request." % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>Oups! It looks like we forged an invalid HTTP request.@,%s@]" %
          string) msg
  | Method_not_allowed meths =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The requested service only accepts the following method:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>The requested service only accepts the following method:@ %a@]"
          % string)
      (Stdlib.Format.pp_print_list None
        (fun ppf =>
          fun m =>
            Stdlib.Format.pp_print_string ppf
              (Tezos_rpc.RPC_service.string_of_meth m))) meths
  | Unsupported_media_type None =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server wants to known the media type we used." % string
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format)))
        "@[<v 2>The server wants to known the media type we used.@]" % string)
  | Unsupported_media_type (Some media) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server does not support the media type we used: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "." % char
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>The server does not support the media type we used: %s.@]" %
          string) media
  | Not_acceptable {| proposed := proposed; acceptable := acceptable |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "No intersection between the media types we accept and  the ones the server is able to send."
              % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal " We proposed: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      " The server is only able to serve: " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "." % char
                          CamlinternalFormatBasics.End_of_format)))))))))
        "@[<v 2>No intersection between the media types we accept and  the ones the server is able to send.@, We proposed: %s@, The server is only able to serve: %s."
          % string) proposed acceptable
  | Unexpected_status_code {| code := code; content := content |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Unexpected error " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))))))
        "@[<v 2>Unexpected error %d:@,%S" % string)
      (Cohttp.Code.code_of_status code) content
  |
    Unexpected_content_type {|
      received := received; acceptable := _; body := body |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server answered with a media type we do not understand: " %
              string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "." % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal
                    "The response body was:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))))))
        "@[<v 0>The server answered with a media type we do not understand: %s.@,The response body was:@,%s@]"
          % string) received body
  |
    Unexpected_content {|
      content := content; media_type := media_type; error := error |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Failed to parse the answer (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "):" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal "error:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "content:" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.Caml_string
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format)))))))))))))))))
        "@[<v 2>Failed to parse the answer (%s):@,@[<v 2>error:@ %s@]@,@[<v 2>content:@ %S@]@]"
          % string) media_type error content
  | OCaml_exception msg =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server failed with an unexpected exception:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>The server failed with an unexpected exception:@ %s@]" % string)
      msg
  | Unauthorized_host host =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server refused connection to host """ % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                """, please check the node settings for CORS allowed origins." %
                  string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>The server refused connection to host ""%s"", please check the node settings for CORS allowed origins.@]"
          % string) (Tezos_base__TzPervasives.Option.unopt "" % string host)
  end.
src/lib_rpc_http/RPC_client_errors.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type rpc_error =
  | Empty_answer
  | Connection_failed of string
  | Bad_request of string
  | Method_not_allowed of RPC_service.meth list
  | Unsupported_media_type of string option
  | Not_acceptable of {proposed : string; acceptable : string}
  | Unexpected_status_code of {
      code : Cohttp.Code.status_code;
      content : string;
      media_type : string option;
    }
  | Unexpected_content_type of {
      received : string;
      acceptable : string list;
      body : string;
    }
  | Unexpected_content of {
      content : string;
      media_type : string;
      error : string;
    }
  | OCaml_exception of string
  | Unauthorized_host of string option

type error +=
  | Request_failed of {meth : RPC_service.meth; uri : Uri.t; error : rpc_error}
src/lib_rpc_http/RPC_client_errors.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive rpc_error : Type :=
| Empty_answer : rpc_error
| Connection_failed : string -> rpc_error
| Bad_request : string -> rpc_error
| Method_not_allowed : (list Tezos_rpc.RPC_service.meth) -> rpc_error
| Unsupported_media_type : (option string) -> rpc_error
| Not_acceptable : string -> string -> rpc_error
| Unexpected_status_code : Cohttp.Code.status_code -> string -> (option string)
  -> rpc_error
| Unexpected_content_type : string -> (list string) -> string -> rpc_error
| Unexpected_content : string -> string -> string -> rpc_error
| OCaml_exception : string -> rpc_error
| Unauthorized_host : (option string) -> rpc_error.

extensible_type
src/lib_rpc_http/RPC_client_unix.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type attempt_event = {attempt : int; delay : float; text : string}

module Attempt_logging = Internal_event.Make (struct
  type t = attempt_event

  let name = "rpc_http_attempt"

  let doc = "Error emmited when an HTTP request returned a 502 error."

  let encoding =
    Data_encoding.(
      conv
        (fun {attempt; delay; text} -> (attempt, delay, text))
        (fun (attempt, delay, text) -> {attempt; delay; text})
        (obj3 (req "attempt" int8) (req "delay" float) (req "text" string)))

  let pp f {attempt; delay; text} =
    Format.fprintf
      f
      "Attempt number %d/10, will retry after %g seconds.\n\
       Original body follows.\n\
       %s"
      attempt
      delay
      text

  let level _ = Internal_event.Error
end)

include RPC_client.Make (struct
  include Cohttp_lwt_unix.Client

  let clone_body = function
    | `Stream s ->
        `Stream (Lwt_stream.clone s)
    | x ->
        x

  let call ?ctx ?headers ?body ?chunked meth uri =
    let rec call_and_retry_on_502 attempt delay =
      call ?ctx ?headers ?body ?chunked meth uri
      >>= fun (response, ansbody) ->
      let status = Cohttp.Response.status response in
      match status with
      | `Bad_gateway ->
          let log_ansbody = clone_body ansbody in
          Cohttp_lwt.Body.to_string log_ansbody
          >>= fun text ->
          Attempt_logging.emit (fun () -> {attempt; delay; text})
          >>= fun _ ->
          if attempt >= 10 then Lwt.return (response, ansbody)
          else
            Lwt_unix.sleep delay
            >>= fun () -> call_and_retry_on_502 (attempt + 1) (delay +. 0.1)
      | _ ->
          Lwt.return (response, ansbody)
    in
    call_and_retry_on_502 1 0.
end)
src/lib_rpc_http/RPC_client_unix.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record attempt_event := {
  attempt : Z;
  delay : float;
  text : string }.
src/lib_rpc_http/RPC_client_unix.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include RPC_client.S
src/lib_rpc_http/RPC_client_unix.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_rpc_http/RPC_server.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type cors = Resto_cohttp.Cors.t = {
  allowed_headers : string list;
  allowed_origins : string list;
}

module RPC_logging = Internal_event.Legacy_logging.Make (struct
  let name = "rpc"
end)

include Resto_cohttp_server.Server.Make (RPC_encoding) (RPC_logging)
src/lib_rpc_http/RPC_server.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record cors := {
  allowed_headers : list string;
  allowed_origins : list string }.
src/lib_rpc_http/RPC_server.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Typed RPC services: server implementation. *)

type cors = {allowed_headers : string list; allowed_origins : string list}

(** A handle on the server worker. *)
type server

(** Promise a running RPC server.*)
val launch :
  ?host:string ->
  ?cors:cors ->
  media_types:Media_type.t list ->
  Conduit_lwt_unix.server ->
  unit RPC_directory.t ->
  server Lwt.t

(** Kill an RPC server. *)
val shutdown : server -> unit Lwt.t
src/lib_rpc_http/RPC_server.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record cors := {
  allowed_headers : list string;
  allowed_origins : list string }.

Parameter server : Type.

Parameter launch :
(option string) ->
  (option cors) ->
    (list Tezos_rpc_http.Media_type.t) ->
      Conduit_lwt_unix.server ->
        (Tezos_rpc.RPC_directory.t unit) -> Lwt.t server.

Parameter shutdown : server -> Lwt.t unit.
src/lib_rpc_http/media_type.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto_cohttp.Media_type.Make (RPC_encoding)

let json =
  {
    name = Cohttp.Accept.MediaType ("application", "json");
    q = Some 1000;
    pp =
      (fun _enc ppf raw ->
        match Data_encoding.Json.from_string raw with
        | Error err ->
            Format.fprintf
              ppf
              "@[Invalid JSON:@  - @[<v 2>Error:@ %s@] - @[<v 2>Raw data:@ \
               %s@]@]"
              err
              raw
        | Ok json ->
            Data_encoding.Json.pp ppf json);
    construct =
      (fun enc v ->
        Data_encoding.Json.to_string ~newline:true ~minify:true
        @@ Data_encoding.Json.construct enc v);
    destruct =
      (fun enc body ->
        match Data_encoding.Json.from_string body with
        | Error _ as err ->
            err
        | Ok json -> (
          try Ok (Data_encoding.Json.destruct enc json)
          with Data_encoding.Json.Cannot_destruct (_, exn) ->
            Error
              (Format.asprintf
                 "%a"
                 (fun fmt -> Data_encoding.Json.print_error fmt)
                 exn) ));
  }

let bson =
  {
    name = Cohttp.Accept.MediaType ("application", "bson");
    q = Some 100;
    pp =
      (fun _enc ppf raw ->
        match
          Json_repr_bson.bytes_to_bson
            ~laziness:false
            ~copy:false
            (Bytes.unsafe_of_string raw)
        with
        | exception Json_repr_bson.Bson_decoding_error (msg, _, _) ->
            Format.fprintf ppf "@[Invalid BSON:@ %s@]" msg
        | bson ->
            let json =
              Json_repr.convert
                (module Json_repr_bson.Repr)
                (module Json_repr.Ezjsonm)
                bson
            in
            Data_encoding.Json.pp ppf json);
    construct =
      (fun enc v ->
        Bytes.unsafe_to_string @@ Json_repr_bson.bson_to_bytes
        @@ Data_encoding.Bson.construct enc v);
    destruct =
      (fun enc body ->
        match
          Json_repr_bson.bytes_to_bson
            ~laziness:false
            ~copy:false
            (Bytes.unsafe_of_string body)
        with
        | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) ->
            Error (Format.asprintf "(at offset: %d) %s" pos msg)
        | bson -> (
          try Ok (Data_encoding.Bson.destruct enc bson)
          with Data_encoding.Json.Cannot_destruct (_, exn) ->
            Error
              (Format.asprintf
                 "%a"
                 (fun fmt -> Data_encoding.Json.print_error fmt)
                 exn) ));
  }

let octet_stream =
  {
    name = Cohttp.Accept.MediaType ("application", "octet-stream");
    q = Some 200;
    pp =
      (fun enc ppf raw ->
        match Data_encoding.Binary.of_bytes enc (Bytes.of_string raw) with
        | None ->
            Format.fprintf ppf "Invalid binary data."
        | Some v ->
            Format.fprintf
              ppf
              ";; binary equivalent of the following json@.%a"
              Data_encoding.Json.pp
              (Data_encoding.Json.construct enc v));
    construct =
      (fun enc v -> Bytes.to_string @@ Data_encoding.Binary.to_bytes_exn enc v);
    destruct =
      (fun enc s ->
        match Data_encoding.Binary.of_bytes enc (Bytes.of_string s) with
        | None ->
            Error "Failed to parse binary data."
        | Some data ->
            Ok data);
  }

let all_media_types = [json; bson; octet_stream]
src/lib_rpc_http/media_type.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition json : t :=
  {| name := Cohttp.Accept.MediaType "application" % string "json" % string;
    q := Some 1000;
    pp :=
      fun _enc =>
        fun ppf =>
          fun raw =>
            match Tezos_base__TzPervasives.Data_encoding.Json.from_string raw
              with
            | inr err =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Invalid JSON:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.String_literal " - " % string
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_box
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<v 2>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<v 2>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "Error:" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.String_literal
                                      " - " % string
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 2>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 2>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Raw data:" % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_box
                                                  CamlinternalFormatBasics.End_of_format))))))))))))))))
                  "@[Invalid JSON:@  - @[<v 2>Error:@ %s@] - @[<v 2>Raw data:@ %s@]@]"
                    % string) err raw
            | inl json =>
              Tezos_base__TzPervasives.Data_encoding.Json.pp ppf json
            end;
    construct :=
      fun enc =>
        fun v =>
          apply
            (Tezos_base__TzPervasives.Data_encoding.Json.to_string (Some true)
              (Some true))
            (Tezos_base__TzPervasives.Data_encoding.Json.construct enc v);
    destruct :=
      fun enc =>
        fun body =>
          match Tezos_base__TzPervasives.Data_encoding.Json.from_string body
            with
          | (inr _) as err => err
          | inl json => try
          end |}.

Definition bson : t :=
  {| name := Cohttp.Accept.MediaType "application" % string "bson" % string;
    q := Some 100;
    pp :=
      fun _enc =>
        fun ppf =>
          fun raw =>
            match
              Json_repr_bson.bytes_to_bson (Some false) None None false
                (Stdlib.Bytes.unsafe_of_string raw) with
            | bson =>
              let json :=
                Json_repr.convert Json_repr_bson.Repr Json_repr.Ezjsonm bson in
              Tezos_base__TzPervasives.Data_encoding.Json.pp ppf json
            end;
    construct :=
      fun enc =>
        fun v =>
          apply Stdlib.Bytes.unsafe_to_string
            (apply
              (let arg := Json_repr_bson.bson_to_bytes in
              fun eta => arg None None eta)
              (Tezos_base__TzPervasives.Data_encoding.Bson.construct enc v));
    destruct :=
      fun enc =>
        fun body =>
          match
            Json_repr_bson.bytes_to_bson (Some false) None None false
              (Stdlib.Bytes.unsafe_of_string body) with
          | bson => try
          end |}.

Definition octet_stream : t :=
  {|
    name :=
      Cohttp.Accept.MediaType "application" % string "octet-stream" % string;
    q := Some 200;
    pp :=
      fun enc =>
        fun ppf =>
          fun raw =>
            match
              Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes enc
                (Stdlib.Bytes.of_string raw) with
            | None =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Invalid binary data." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Invalid binary data." % string)
            | Some v =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    ";; binary equivalent of the following json" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Flush_newline
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)))
                  ";; binary equivalent of the following json@.%a" % string)
                Tezos_base__TzPervasives.Data_encoding.Json.pp
                (Tezos_base__TzPervasives.Data_encoding.Json.construct enc v)
            end;
    construct :=
      fun enc =>
        fun v =>
          apply Stdlib.Bytes.to_string
            (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn enc v);
    destruct :=
      fun enc =>
        fun s =>
          match
            Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes enc
              (Stdlib.Bytes.of_string s) with
          | None => inr "Failed to parse binary data." % string
          | Some data => inl data
          end |}.

Definition all_media_types : list t :=
  cons json (cons bson (cons octet_stream [])).
src/lib_rpc_http/media_type.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Resto_cohttp.Media_type.Make(RPC_encoding).t = {
  name : Cohttp.Accept.media_range;
  q : int option;
  pp : 'a. 'a Data_encoding.t -> Format.formatter -> string -> unit;
  construct : 'a. 'a Data_encoding.t -> 'a -> string;
  destruct : 'a. 'a Data_encoding.t -> string -> ('a, string) result;
}

val name : t -> string

val json : t

val bson : t

val octet_stream : t

val all_media_types : t list

val accept_header : t list -> string

val first_complete_media : t list -> ((string * string) * t) option
src/lib_rpc_http/media_type.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  name : Cohttp.Accept.media_range;
  q : option Z;
  pp :
    ((Tezos_base__TzPervasives.Data_encoding.t a) ->
      Stdlib.Format.formatter -> string -> unit) * (a);
  construct :
    ((Tezos_base__TzPervasives.Data_encoding.t a) -> a -> string) * (a);
  destruct :
    ((Tezos_base__TzPervasives.Data_encoding.t a) -> string -> sum a string) *
      (a) }.

Parameter name : t -> string.

Parameter json : t.

Parameter bson : t.

Parameter octet_stream : t.

Parameter all_media_types : list t.

Parameter accept_header : (list t) -> string.

Parameter first_complete_media : (list t) -> option ((string * string) * t).
src/lib_shell/bench/bench_simple.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let make_simple blocks =
  let rec loop pred n =
    if n <= 0 then return pred
    else Block.bake pred >>=? fun block -> loop block (n - 1)
  in
  Context.init 5 >>=? fun (genesis, _) -> loop genesis blocks

type args = {blocks : int; accounts : int}

let default_args = {blocks = 1000; accounts = 5}

let set_blocks cf blocks = cf := {!cf with blocks}

let set_accounts cf accounts = cf := {!cf with accounts}

let read_args () =
  let args = ref default_args in
  let specific =
    [ ("--blocks", Arg.Int (set_blocks args), "number of blocks");
      ("--accounts", Arg.Int (set_accounts args), "number of acount") ]
  in
  let usage = "Usage: [--blocks n] [--accounts n] " in
  Arg.parse specific (fun _ -> ()) usage ;
  !args

let () =
  let args = read_args () in
  match Lwt_main.run (make_simple args.blocks) with
  | Ok _head ->
      Format.printf "Success.@." ; exit 0
  | Error err ->
      Format.eprintf "%a@." pp_print_error err ;
      exit 1
src/lib_shell/bench/bench_simple.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition make_simple {A : Type} (blocks : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  let fix loop {B : Type} (pred : B) (n : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
    if OCaml.Stdlib.le n 0 then
      Tezos_base__TzPervasives._return pred
    else
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (op_star_t_y_p_e_minus_e_r_r_o_r_star pred)
        (fun block => loop block (Z.sub n 1)) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    op_star_t_y_p_e_minus_e_r_r_o_r_star
    (fun function_parameter =>
      match function_parameter with
      | (genesis, _) => loop genesis blocks
      end).

Record args := {
  blocks : Z;
  accounts : Z }.

Definition default_args : args := {| blocks := 1000; accounts := 5 |}.

Definition set_blocks (cf : Stdlib.ref args) (blocks : Z) : unit :=
  Stdlib.op_colon_eq cf record.

Definition set_accounts (cf : Stdlib.ref args) (accounts : Z) : unit :=
  Stdlib.op_colon_eq cf record.

Definition read_args (function_parameter : unit) : args :=
  match function_parameter with
  | tt =>
    let args := Stdlib.ref default_args in
    let specific :=
      cons
        ("--blocks" % string, (Arg.Int (set_blocks args)),
          "number of blocks" % string)
        (cons
          ("--accounts" % string, (Arg.Int (set_accounts args)),
            "number of acount" % string) []) in
    let usage := "Usage: [--blocks n] [--accounts n] " % string in
    Stdlib.Arg.parse specific
      (fun function_parameter =>
        match function_parameter with
        | _ => tt
        end) usage;
    Stdlib.op_exclamation args
  end.
src/lib_shell/bench/bench_tool.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Helpers_Nonce = Nonce
open Protocol
open Parameters_repr
open Constants_repr
open Alpha_context

(** Args *)

type args = {
  mutable length : int;
  mutable seed : int;
  mutable accounts : int;
  mutable nb_commitments : int;
  mutable params : Parameters_repr.t;
}

let default_args =
  {
    length = 100;
    seed = 0;
    accounts = 100;
    nb_commitments = 200;
    params =
      {
        bootstrap_accounts = [];
        commitments = [];
        bootstrap_contracts = [];
        constants = Default_parameters.constants_mainnet;
        security_deposit_ramp_up_cycles = None;
        no_reward_cycles = None;
      };
  }

let debug = ref false

let if_debug k = if !debug then k ()

let if_debug_s k = if !debug then k () else return_unit

let args = default_args

let parse_param_file name =
  if not (Sys.file_exists name) then
    failwith "Parameters : Inexistent JSON file"
  else
    Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file name
    >>=? fun json ->
    match Data_encoding.Json.destruct Parameters_repr.encoding json with
    | exception exn ->
        failwith "Parameters : Invalid JSON file - %a" Error_monad.pp_exn exn
    | param ->
        return param

let read_args () =
  let parse_param name =
    parse_param_file name
    >>= (function
          | Ok p ->
              Lwt.return p
          | Error errs ->
              Format.printf
                "Parameters parsing error : %a ==> using default parameters\n\
                 %!"
                Error_monad.pp_print_error
                errs ;
              Lwt.return default_args.params)
    |> Lwt_main.run
  in
  let specific =
    [ ( "--length",
        Arg.Int (fun n -> args.length <- n),
        "Length of the chain (nb of blocks)" );
      ("--seed", Arg.Int (fun n -> args.seed <- n), "Used seed (default 0)");
      ( "--random-commitments",
        Arg.Int (fun n -> args.nb_commitments <- n),
        "Number of randomly generated commitments. Defaults to 200. If less \
         than 0, commitments in protocol parameter files are used." );
      ( "--accounts",
        Arg.Int (fun n -> args.accounts <- n),
        "Number of initial randomly generated accounts. Still adds bootstrap \
         account if present in the parameters file." );
      ( "--parameters",
        Arg.String (fun s -> args.params <- parse_param s),
        "JSON protocol parameters file" );
      ("--debug", Arg.Set debug, "Print more info") ]
  in
  let usage =
    "Usage: [--length n] [--seed n] [--accounts n] [--parameters json_file]"
  in
  Arg.parse specific (fun _ -> ()) usage

(** Utils *)

let choose_exp_nat n =
  (* seems fine *)
  let lambda = 1. /. log (float n) in
  let u = Random.float 1. in
  -.log u /. lambda |> int_of_float

let pi = 3.1415926502

let two_pi = 2. *. 3.1415926502

let round x = x +. 0.5 |> int_of_float

let rec choose_gaussian_nat (a, b) =
  assert (b >= a) ;
  let sigma = 4. in
  let mu = ((b - a) / 2) + a |> float in
  let gauss () =
    let u1 = Random.float 1. (* |> fun x -> 1. -. x *) in
    let u2 = Random.float 1. in
    let r = sqrt (-.(2. *. log u1)) in
    let theta = cos (two_pi *. u2) in
    r *. theta
  in
  let z = gauss () in
  let z = (z *. sigma) +. mu |> round in
  if z > a && z < b then z else choose_gaussian_nat (a, b)

let list_shuffle l =
  List.map (fun c -> (Random.bits (), c)) l
  |> List.sort compare |> List.map snd

(******************************************************************)

type gen_state = {
  mutable possible_transfers : (Account.t * Account.t) list;
  mutable remaining_transfers : (Account.t * Account.t) list;
  mutable remaining_activations : (Account.t * Commitment_repr.t) list;
  mutable nonce_to_reveal : (Cycle.t * Raw_level.t * Nonce.t) list;
}

let get_n_endorsements ctxt n =
  Context.get_endorsers ctxt
  >>=? fun endorsing_rights ->
  let endorsing_rights = List.sub endorsing_rights n in
  map_s
    (fun {Delegate_services.Endorsing_rights.delegate; level; _} ->
      Op.endorsement ~delegate ~level ctxt ())
    endorsing_rights

let generate_and_add_random_endorsements inc =
  let pred inc = Incremental.predecessor inc in
  let nb_endorsements =
    let n = args.params.constants.endorsers_per_block in
    n - choose_exp_nat n
  in
  if_debug (fun () ->
      Format.printf
        "[DEBUG] Generating up to %d endorsements...\n%!"
        nb_endorsements) ;
  get_n_endorsements (B (pred inc)) (nb_endorsements - 1)
  >>=? fun endorsements ->
  let compare op1 op2 =
    Operation_hash.compare (Operation.hash op1) (Operation.hash op2)
  in
  let endorsements = List.sort_uniq compare endorsements in
  let endorsements = List.map Operation.pack endorsements in
  fold_left_s Incremental.add_operation inc endorsements

let regenerate_transfers = ref false

let generate_random_activation ({remaining_activations; _} as gen_state) inc =
  regenerate_transfers := true ;
  let open Account in
  match remaining_activations with
  | [] ->
      assert false
  | (({pkh; _} as account), _) :: l ->
      if_debug (fun () ->
          Format.printf "[DEBUG] Generating an activation.\n%!") ;
      gen_state.remaining_activations <- l ;
      add_account account ;
      Op.activation inc pkh Account.commitment_secret

exception No_transfer_left

let rec generate_random_transfer ({remaining_transfers; _} as gen_state) ctxt =
  if remaining_transfers = [] then raise No_transfer_left ;
  let (a1, a2) = List.hd remaining_transfers in
  gen_state.remaining_transfers <- List.tl remaining_transfers ;
  let open Account in
  let c1 = Alpha_context.Contract.implicit_contract a1.pkh in
  let c2 = Alpha_context.Contract.implicit_contract a2.pkh in
  Context.Contract.balance ctxt c1
  >>=? fun b1 ->
  if Tez.(b1 < Tez.one) then generate_random_transfer gen_state ctxt
  else Op.transaction ctxt c1 c2 Tez.one

let generate_random_operation (inc : Incremental.t) gen_state =
  let rnd = Random.int 100 in
  match rnd with
  | x when x < 2 && gen_state.remaining_activations <> [] ->
      generate_random_activation gen_state (I inc)
  | _ ->
      generate_random_transfer gen_state (I inc)

(* Build a random block *)
let step gen_state blk : Block.t tzresult Lwt.t =
  let priority = choose_exp_nat 5 in
  (* let nb_operations_per_block = choose_gaussian_nat (10, List.length (Account.get_known_accounts ())) in *)
  let nb_operations_per_block = choose_gaussian_nat (10, 100) in
  if !regenerate_transfers then (
    let l =
      Signature.Public_key_hash.Table.fold
        (fun _ v acc -> v :: acc)
        Account.known_accounts
        []
    in
    (* TODO : make possible transfer computations efficient.. *)
    gen_state.possible_transfers <-
      List.product l l |> List.filter (fun (a, b) -> a <> b) ;
    regenerate_transfers := false ) ;
  gen_state.remaining_transfers <- list_shuffle gen_state.possible_transfers ;
  let nb_operations =
    min nb_operations_per_block (List.length gen_state.remaining_transfers)
  in
  (* Nonce *)
  Alpha_services.Helpers.current_level ~offset:1l Block.rpc_ctxt blk
  >>|? (function
         | Level.{expected_commitment = true; cycle; level; _} ->
             if_debug (fun () -> Format.printf "[DEBUG] Commiting a nonce\n%!") ;
             let (hash, nonce) = Helpers_Nonce.generate () in
             gen_state.nonce_to_reveal <-
               (cycle, level, nonce) :: gen_state.nonce_to_reveal ;
             Some hash
         | _ ->
             None)
  >>=? fun seed_nonce_hash ->
  Incremental.begin_construction ~priority ?seed_nonce_hash blk
  >>=? fun inc ->
  let open Cycle in
  if_debug (fun () ->
      Format.printf
        "[DEBUG] Generating %d random operations...\n%!"
        nb_operations) ;
  (* Generate random operations *)
  fold_left_s
    (fun inc _ ->
      try
        generate_random_operation inc gen_state
        >>=? fun op -> Incremental.add_operation inc op
      with No_transfer_left -> return inc)
    inc
    (1 -- nb_operations)
  >>=? fun inc ->
  (* Endorsements *)
  generate_and_add_random_endorsements inc
  >>=? fun inc ->
  (* Revelations *)
  (* TODO debug cycle *)
  Alpha_services.Helpers.current_level ~offset:1l Incremental.rpc_ctxt inc
  >>|? (function
         | {cycle; level; _} -> (
             if_debug (fun () ->
                 Format.printf "[DEBUG] Current cycle : %a\n%!" Cycle.pp cycle) ;
             if_debug (fun () ->
                 Format.printf
                   "[DEBUG] Current level : %a\n%!"
                   Raw_level.pp
                   level) ;
             match gen_state.nonce_to_reveal with
             | (pred_cycle, _, _) :: _ as l when succ pred_cycle = cycle ->
                 if_debug (fun () ->
                     Format.printf
                       "[DEBUG] Seed nonce revelation : %d nonces to reveal.\n\
                        %!"
                     @@ List.length l) ;
                 gen_state.nonce_to_reveal <- [] ;
                 (* fold_left_s (fun inc (_, level, nonce) -> *)
                 (* Op.seed_nonce_revelation inc level nonce >>=? fun op ->
                  * Incremental.add_operation inc op *)
                 (* return *)
                 inc
             (* TODO reactivate the seeds *)
             (* ) inc l *)
             | _ ->
                 inc ))
  >>=? fun inc ->
  (* (\* Shuffle the operations a bit (why not) *\)
   * let operations = endorsements @ operations |> list_shuffle in *)
  Incremental.finalize_block inc

let init () =
  Random.init args.seed ;
  let parameters = args.params in
  (* keys randomness is delegated to module Signature's bindings *)
  (* TODO : distribute the tokens randomly *)
  (* Right now, we split half of 80.000 rolls between generated accounts *)
  (* TODO : ensure we don't overflow with the underlying commitments *)
  Tez_repr.(
    Lwt.return @@ Environment.wrap_error
    @@ args.params.Parameters_repr.constants.Constants_repr.tokens_per_roll
       *? 80_000L
    >>=? fun total_amount ->
    Lwt.return @@ Environment.wrap_error @@ (total_amount /? 2L)
    >>=? fun amount ->
    Lwt.return @@ Environment.wrap_error
    @@ (amount /? Int64.of_int args.accounts))
  >>=? fun initial_amount ->
  (* Ensure a deterministic run *)
  let new_seed () : Bytes.t =
    Bytes.(make 32 '\000' |> map (fun _ -> Random.int 0x100 |> char_of_int))
  in
  map_s
    (fun _ ->
      return (Account.new_account ~seed:(new_seed ()) (), initial_amount))
    (1 -- args.accounts)
  >>=? fun initial_accounts ->
  if_debug (fun () ->
      List.iter
        (fun (Account.{pkh; _}, _) ->
          Format.printf
            "[DEBUG] Account %a created\n%!"
            Signature.Public_key_hash.pp_short
            pkh)
        initial_accounts) ;
  let possible_transfers =
    let l = List.map fst initial_accounts in
    List.product l l |> List.filter (fun (a, b) -> a <> b)
  in
  ( match args.nb_commitments with
  | x when x < 0 ->
      return ([], parameters)
  | x ->
      map_s (fun _ -> Account.new_commitment ~seed:(new_seed ()) ()) (1 -- x)
      >>=? fun commitments ->
      return
        (commitments, {parameters with commitments = List.map snd commitments})
  )
  >>=? fun ( remaining_activations,
             { bootstrap_accounts = _;
               commitments;
               constants;
               security_deposit_ramp_up_cycles;
               no_reward_cycles;
               _ } ) ->
  let gen_state =
    {
      possible_transfers;
      remaining_transfers = [];
      nonce_to_reveal = [];
      remaining_activations;
    }
  in
  let bootstrap_accounts =
    List.map
      (fun (Account.{pk; pkh; _}, amount) ->
        Default_parameters.make_bootstrap_account (pkh, pk, amount))
      initial_accounts
  in
  let parameters =
    {
      Parameters_repr.bootstrap_accounts;
      bootstrap_contracts = [];
      commitments;
      constants;
      security_deposit_ramp_up_cycles;
      no_reward_cycles;
    }
  in
  Block.genesis_with_parameters parameters
  >>=? fun genesis ->
  if_debug_s (fun () ->
      iter_s
        (let open Account in
        fun (({pkh; _} as acc), _) ->
          let contract = Alpha_context.Contract.implicit_contract acc.pkh in
          Context.Contract.manager (B genesis) contract
          >>=? fun {pkh = pkh'; _} ->
          Context.Contract.balance (B genesis) contract
          >>=? fun balance ->
          return
          @@ Format.printf
               "[DEBUG] %a's manager is %a with a balance of %a\n%!"
               Signature.Public_key_hash.pp_short
               pkh
               Signature.Public_key_hash.pp_short
               pkh'
               Tez.pp
               balance)
        initial_accounts)
  >>=? fun () ->
  if_debug (fun () ->
      Format.printf
        "[DEBUG] Constants : %a\n%!"
        Data_encoding.Json.pp
        (Data_encoding.Json.construct
           Constants_repr.parametric_encoding
           parameters.Parameters_repr.constants)) ;
  let print_block block =
    let open Block in
    Format.printf
      "@[%6i %s@]\n%!"
      (Int32.to_int block.header.shell.level)
      (Block_hash.to_b58check block.hash)
  in
  Format.printf
    "@[<v 2>Starting generation with :@ @[length    = %d@]@ @[seed      = \
     %d@]@ @[nb_commi. = %d@]@ @[#accounts = %d@]@ @]@."
    args.length
    args.seed
    args.nb_commitments
    args.accounts ;
  let rec loop gen_state blk = function
    | 0 ->
        return (gen_state, blk)
    | n ->
        print_block blk ;
        step gen_state blk >>=? fun blk' -> loop gen_state blk' (n - 1)
  in
  return (loop gen_state genesis args.length)

let () =
  Lwt_main.run (read_args () ; init ())
  |> function
  | Ok _head ->
      Format.printf "Success.@." ; exit 0
  | Error err ->
      Format.eprintf "%a@." pp_print_error err ;
      exit 1
src/lib_shell/bench/bench_tool.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Protocol.

Definition default_args {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition debug : Stdlib.ref bool := Stdlib.ref false.

Definition if_debug (k : unit -> unit) : unit :=
  if Stdlib.op_exclamation debug then
    k tt
  else
    tt.

Definition if_debug_s
  (k : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Stdlib.op_exclamation debug then
    k tt
  else
    Tezos_base__TzPervasives.return_unit.

Definition args {A : Type} : A := default_args.

Definition parse_param_file {A : Type} (name : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  if negb (Stdlib.Sys.file_exists name) then
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Parameters : Inexistent JSON file" % string
          CamlinternalFormatBasics.End_of_format)
        "Parameters : Inexistent JSON file" % string)
  else
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file name)
      (fun json =>
        match
          Tezos_base__TzPervasives.Data_encoding.Json.destruct
            op_star_t_y_p_e_minus_e_r_r_o_r_star json with
        | param => Tezos_base__TzPervasives._return param
        end).

Definition read_args (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let parse_param {A : Type} (name : string) : A :=
      OCaml.Stdlib.reverse_apply
        (Tezos_base__TzPervasives.op_gt_gt_eq (parse_param_file name)
          (fun function_parameter =>
            match function_parameter with
            | inl p => Lwt._return p
            | inr errs =>
              Stdlib.Format.printf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Parameters parsing error : " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        " ==> using default parameters
" % string
                        (CamlinternalFormatBasics.Flush
                          CamlinternalFormatBasics.End_of_format))))
                  "Parameters parsing error : %a ==> using default parameters
%!"
                    % string)
                Tezos_base__TzPervasives.Error_monad.pp_print_error errs;
              Lwt._return (params default_args)
            end)) Lwt_main.run in
    let specific :=
      cons
        ("--length" % string, (Arg.Int (fun n => set_field)),
          "Length of the chain (nb of blocks)" % string)
        (cons
          ("--seed" % string, (Arg.Int (fun n => set_field)),
            "Used seed (default 0)" % string)
          (cons
            ("--random-commitments" % string, (Arg.Int (fun n => set_field)),
              "Number of randomly generated commitments. Defaults to 200. If less than 0, commitments in protocol parameter files are used."
                % string)
            (cons
              ("--accounts" % string, (Arg.Int (fun n => set_field)),
                "Number of initial randomly generated accounts. Still adds bootstrap account if present in the parameters file."
                  % string)
              (cons
                ("--parameters" % string, (Arg.String (fun s => set_field)),
                  "JSON protocol parameters file" % string)
                (cons
                  ("--debug" % string, (Arg.Set debug),
                    "Print more info" % string) []))))) in
    let usage :=
      "Usage: [--length n] [--seed n] [--accounts n] [--parameters json_file]" %
        string in
    Stdlib.Arg.parse specific
      (fun function_parameter =>
        match function_parameter with
        | _ => tt
        end) usage
  end.

Definition choose_exp_nat (n : Z) : Z :=
  let lambda := Stdlib.op_div_point 1 (Stdlib.log (Stdlib.float n)) in
  let u := Stdlib.Random.float 1 in
  OCaml.Stdlib.reverse_apply
    (Stdlib.op_div_point (Stdlib.op_tilde_minus_point (Stdlib.log u)) lambda)
    Stdlib.int_of_float.

Definition pi : float := 3.

Definition two_pi : float := Stdlib.op_star_point 2 3.

Definition round (x : float) : Z :=
  OCaml.Stdlib.reverse_apply (Stdlib.op_plus_point x 0) Stdlib.int_of_float.

Fixpoint choose_gaussian_nat
  (function_parameter :
    Tezos_base__TzPervasives.Protocol.t * Tezos_base__TzPervasives.Protocol.t)
  : Z :=
  match function_parameter with
  | (a, b) =>
    Tezos_base__TzPervasives.Protocol.op_gt_eq b a;
    let sigma := 4 in
    let mu :=
      OCaml.Stdlib.reverse_apply
        (Z.add
          (Z.div
            (Z.sub op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star) 2)
          op_star_t_y_p_e_minus_e_r_r_o_r_star) Stdlib.float in
    let gauss (function_parameter : unit) : float :=
      match function_parameter with
      | tt =>
        let u1 := Stdlib.Random.float 1 in
        let u2 := Stdlib.Random.float 1 in
        let r :=
          Stdlib.sqrt
            (Stdlib.op_tilde_minus_point
              (Stdlib.op_star_point 2 (Stdlib.log u1))) in
        let theta := Stdlib.cos (Stdlib.op_star_point two_pi u2) in
        Stdlib.op_star_point r theta
      end in
    let z := gauss tt in
    let z :=
      OCaml.Stdlib.reverse_apply
        (Stdlib.op_plus_point (Stdlib.op_star_point z sigma) mu) round in
    if
      andb
        (Tezos_base__TzPervasives.Protocol.op_gt
          op_star_t_y_p_e_minus_e_r_r_o_r_star a)
        (Tezos_base__TzPervasives.Protocol.op_lt
          op_star_t_y_p_e_minus_e_r_r_o_r_star b) then
      z
    else
      choose_gaussian_nat (a, b)
  end.

Definition list_shuffle {A B : Type} (l : list A) : list B :=
  OCaml.Stdlib.reverse_apply op_star_t_y_p_e_minus_e_r_r_o_r_star
    (Tezos_base__TzPervasives.List.map snd).

Definition get_n_endorsements {A B : Type} (ctxt : A) (n : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (list B)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt)
    (fun endorsing_rights =>
      let endorsing_rights :=
        Tezos_base__TzPervasives.List.sub endorsing_rights n in
      Tezos_base__TzPervasives.map_s
        (fun function_parameter =>
          match function_parameter with
          | _ =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt tt
          end) endorsing_rights).

Definition generate_and_add_random_endorsements {A : Type} (inc : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  let pred {B C : Type} (inc : B) : C :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star inc in
  let nb_endorsements :=
    let n := endorsers_per_block (constants (params args)) in
    Z.sub n (choose_exp_nat n) in
  if_debug
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Stdlib.Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "[DEBUG] Generating up to " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal
                  " endorsements...
" % string
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format))))
            "[DEBUG] Generating up to %d endorsements...
%!" % string)
          nb_endorsements
      end);
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (get_n_endorsements op_star_t_y_p_e_minus_e_r_r_o_r_star
      (Z.sub nb_endorsements 1))
    (fun endorsements =>
      let compare
        (op1 : Tezos_base__TzPervasives.Operation.t) (op2 :
        Tezos_base__TzPervasives.Operation.t) : Z :=
        Tezos_base__TzPervasives.Operation_hash.compare
          (Tezos_base__TzPervasives.Operation.hash op1)
          (Tezos_base__TzPervasives.Operation.hash op2) in
      let endorsements :=
        Tezos_base__TzPervasives.List.sort_uniq compare endorsements in
      let endorsements :=
        Tezos_base__TzPervasives.List.map op_star_t_y_p_e_minus_e_r_r_o_r_star
          endorsements in
      Tezos_base__TzPervasives.fold_left_s op_star_t_y_p_e_minus_e_r_r_o_r_star
        inc endorsements).

Definition regenerate_transfers : Stdlib.ref bool := Stdlib.ref false.

Definition generate_random_activation {A B C : Type} (function_parameter : A)
  : B -> C :=
  match function_parameter with
  | _ =>
    fun inc =>
      Stdlib.op_colon_eq regenerate_transfers true;
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Fixpoint generate_random_transfer {A B C : Type} (function_parameter : A)
  : B -> C :=
  match function_parameter with
  | _ =>
    fun ctxt =>
      if
        Tezos_base__TzPervasives.Protocol.op_eq
          op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star then
        Stdlib.raise No_transfer_left
      else
        tt;
      match
        Tezos_base__TzPervasives.List.hd op_star_t_y_p_e_minus_e_r_r_o_r_star
        with
      | (a1, a2) =>
        set_field;
        op_star_t_y_p_e_minus_e_r_r_o_r_star
      end
  end.

Definition generate_random_operation {A B C : Type} (function_parameter : A)
  : B -> C :=
  match function_parameter with
  | _ =>
    fun gen_state =>
      let rnd := Stdlib.Random.int 100 in
      match rnd with
      | _ =>
        generate_random_transfer gen_state op_star_t_y_p_e_minus_e_r_r_o_r_star
      end
  end.

Definition step {A B : Type} (gen_state : A) (blk : B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition init {A B : Type} (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Lwt.t (Tezos_base__TzPervasives.tzresult (A * B)))) :=
  match function_parameter with
  | tt =>
    Stdlib.Random.init (seed args);
    let parameters := params args in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun initial_amount =>
        let new_seed (function_parameter : unit) : Stdlib.Bytes.t :=
          match function_parameter with
          | tt =>
            OCaml.Stdlib.reverse_apply (Stdlib.Bytes.make 32 "000" % char)
              (Stdlib.Bytes.map
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    OCaml.Stdlib.reverse_apply (Stdlib.Random.int 256)
                      OCaml.Stdlib.char_of_int
                  end))
          end in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_base__TzPervasives.map_s
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_base__TzPervasives._return
                  ((op_star_t_y_p_e_minus_e_r_r_o_r_star (new_seed tt) tt),
                    initial_amount)
              end) (Tezos_base__TzPervasives.op_minus_minus 1 (accounts args)))
          (fun initial_accounts =>
            if_debug
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.List.iter
                    (fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        Stdlib.Format.printf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "[DEBUG] Account " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " created
" % string
                                  (CamlinternalFormatBasics.Flush
                                    CamlinternalFormatBasics.End_of_format))))
                            "[DEBUG] Account %a created
%!" % string)
                          Tezos_base__TzPervasives.Signature.Public_key_hash.pp_short
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                      end) initial_accounts
                end);
            let possible_transfers :=
              let l := Tezos_base__TzPervasives.List.map fst initial_accounts in
              OCaml.Stdlib.reverse_apply
                (Tezos_base__TzPervasives.List.product l l)
                (Tezos_base__TzPervasives.List.filter
                  (fun function_parameter =>
                    match function_parameter with
                    | (a, b) => Tezos_base__TzPervasives.Protocol.op_lt_gt a b
                    end)) in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              match nb_commitments args with
              | x =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_base__TzPervasives.map_s
                    (fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star (new_seed tt) tt
                      end) (Tezos_base__TzPervasives.op_minus_minus 1 x))
                  (fun commitments =>
                    Tezos_base__TzPervasives._return
                      (commitments, op_star_t_y_p_e_minus_e_r_r_o_r_star))
              end
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  let gen_state := op_star_t_y_p_e_minus_e_r_r_o_r_star in
                  let bootstrap_accounts :=
                    Tezos_base__TzPervasives.List.map
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star,
                              op_star_t_y_p_e_minus_e_r_r_o_r_star,
                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        end) initial_accounts in
                  let parameters := op_star_t_y_p_e_minus_e_r_r_o_r_star in
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star parameters)
                    (fun genesis =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (if_debug_s
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.iter_s
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                initial_accounts
                            end))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            if_debug
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Stdlib.Format.printf
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "[DEBUG] Constants : " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Char_literal
                                            "010" % char
                                            (CamlinternalFormatBasics.Flush
                                              CamlinternalFormatBasics.End_of_format))))
                                      "[DEBUG] Constants : %a
%!" % string)
                                    Tezos_base__TzPervasives.Data_encoding.Json.pp
                                    (Tezos_base__TzPervasives.Data_encoding.Json.construct
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (Parameters_repr.constants parameters))
                                end);
                            let print_block {C D : Type} (block : C) : D :=
                              op_star_t_y_p_e_minus_e_r_r_o_r_star in
                            Stdlib.Format.printf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<v 2>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<v 2>" % string))
                                  (CamlinternalFormatBasics.String_literal
                                    "Starting generation with :" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            CamlinternalFormatBasics.End_of_format
                                            "" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "length    = " % string
                                          (CamlinternalFormatBasics.Int
                                            CamlinternalFormatBasics.Int_d
                                            CamlinternalFormatBasics.No_padding
                                            CamlinternalFormatBasics.No_precision
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Formatting_lit
                                                (CamlinternalFormatBasics.Break
                                                  "@ " % string 1 0)
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      CamlinternalFormatBasics.End_of_format
                                                      "" % string))
                                                  (CamlinternalFormatBasics.String_literal
                                                    "seed      = " % string
                                                    (CamlinternalFormatBasics.Int
                                                      CamlinternalFormatBasics.Int_d
                                                      CamlinternalFormatBasics.No_padding
                                                      CamlinternalFormatBasics.No_precision
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_box
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          (CamlinternalFormatBasics.Break
                                                            "@ " % string 1 0)
                                                          (CamlinternalFormatBasics.Formatting_gen
                                                            (CamlinternalFormatBasics.Open_box
                                                              (CamlinternalFormatBasics.Format
                                                                CamlinternalFormatBasics.End_of_format
                                                                "" % string))
                                                            (CamlinternalFormatBasics.String_literal
                                                              "nb_commi. = " %
                                                                string
                                                              (CamlinternalFormatBasics.Int
                                                                CamlinternalFormatBasics.Int_d
                                                                CamlinternalFormatBasics.No_padding
                                                                CamlinternalFormatBasics.No_precision
                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                  CamlinternalFormatBasics.Close_box
                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                    (CamlinternalFormatBasics.Break
                                                                      "@ " %
                                                                        string 1
                                                                      0)
                                                                    (CamlinternalFormatBasics.Formatting_gen
                                                                      (CamlinternalFormatBasics.Open_box
                                                                        (CamlinternalFormatBasics.Format
                                                                          CamlinternalFormatBasics.End_of_format
                                                                          "" %
                                                                            string))
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "#accounts = "
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Int
                                                                          CamlinternalFormatBasics.Int_d
                                                                          CamlinternalFormatBasics.No_padding
                                                                          CamlinternalFormatBasics.No_precision
                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                            CamlinternalFormatBasics.Close_box
                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                              (CamlinternalFormatBasics.Break
                                                                                "@ "
                                                                                  %
                                                                                  string
                                                                                1
                                                                                0)
                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                CamlinternalFormatBasics.Close_box
                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                  CamlinternalFormatBasics.Flush_newline
                                                                                  CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))
                                "@[<v 2>Starting generation with :@ @[length    = %d@]@ @[seed      = %d@]@ @[nb_commi. = %d@]@ @[#accounts = %d@]@ @]@."
                                  % string) (length args) (seed args)
                              (nb_commitments args) (accounts args);
                            let fix loop
                              (gen_state : A) (blk : B) (function_parameter : Z)
                              : Lwt.t
                                (Tezos_base__TzPervasives.tzresult (A * B)) :=
                              match function_parameter with
                              | 0 =>
                                Tezos_base__TzPervasives._return
                                  (gen_state, blk)
                              | n =>
                                print_block blk;
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (step gen_state blk)
                                  (fun blk' => loop gen_state blk' (Z.sub n 1))
                              end in
                            Tezos_base__TzPervasives._return
                              (loop gen_state genesis (length args))
                          end))
                end)))
  end.
src/lib_shell/block_directory.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let rec read_partial_context context path depth =
  (* non tail-recursive *)
  if depth = 0 then Lwt.return Block_services.Cut
  else
    (* try to read as file *)
    Context.get context path
    >>= function
    | Some v ->
        Lwt.return (Block_services.Key v)
    | None ->
        (* try to read as directory *)
        Context.fold context path ~init:[] ~f:(fun k acc ->
            match k with
            | `Key k | `Dir k ->
                read_partial_context context k (depth - 1)
                >>= fun v ->
                let k = List.nth k (List.length k - 1) in
                Lwt.return ((k, v) :: acc))
        >>= fun l -> Lwt.return (Block_services.Dir (List.rev l))

let build_raw_header_rpc_directory (module Proto : Block_services.PROTO) =
  let dir : (State.Chain.t * Block_hash.t * Block_header.t) RPC_directory.t ref
      =
    ref RPC_directory.empty
  in
  let register0 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst0 s) (fun block p q ->
          f block p q)
  in
  let module Block_services = Block_services.Make (Proto) (Proto) in
  let module S = Block_services.S in
  register0 S.hash (fun (_, hash, _) () () -> return hash) ;
  (* block header *)
  register0 S.header (fun (chain_state, hash, header) () () ->
      let protocol_data =
        Data_encoding.Binary.of_bytes_exn
          Proto.block_header_data_encoding
          header.protocol_data
      in
      return
        {
          Block_services.hash;
          chain_id = State.Chain.id chain_state;
          shell = header.shell;
          protocol_data;
        }) ;
  register0 S.raw_header (fun (_, _, header) () () ->
      return (Data_encoding.Binary.to_bytes_exn Block_header.encoding header)) ;
  register0 S.Header.shell_header (fun (_, _, header) () () ->
      return header.shell) ;
  register0 S.Header.protocol_data (fun (_, _, header) () () ->
      return
        (Data_encoding.Binary.of_bytes_exn
           Proto.block_header_data_encoding
           header.protocol_data)) ;
  register0 S.Header.raw_protocol_data (fun (_, _, header) () () ->
      return header.protocol_data) ;
  (* helpers *)
  register0 S.Helpers.Forge.block_header (fun _block () header ->
      return (Data_encoding.Binary.to_bytes_exn Block_header.encoding header)) ;
  (* protocols *)
  register0 S.protocols (fun (chain_state, _hash, header) () () ->
      State.Chain.get_level_indexed_protocol chain_state header
      >>= fun next_protocol_hash ->
      State.Block.header_of_hash chain_state header.shell.predecessor
      >>= function
      | None ->
          return
            {
              Tezos_shell_services.Block_services.current_protocol =
                next_protocol_hash;
              next_protocol = next_protocol_hash;
            }
      | Some pred_header ->
          State.Chain.get_level_indexed_protocol chain_state pred_header
          >>= fun protocol_hash ->
          return
            {
              Tezos_shell_services.Block_services.current_protocol =
                protocol_hash;
              next_protocol = next_protocol_hash;
            }) ;
  !dir

let build_raw_rpc_directory (module Proto : Block_services.PROTO)
    (module Next_proto : Registered_protocol.T) =
  let dir : State.Block.block RPC_directory.t ref = ref RPC_directory.empty in
  let merge d = dir := RPC_directory.merge d !dir in
  let register0 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst0 s) (fun block p q ->
          f block p q)
  in
  let register1 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst1 s) (fun (block, a) p q ->
          f block a p q)
  in
  let register2 s f =
    dir :=
      RPC_directory.register
        !dir
        (RPC_service.subst2 s)
        (fun ((block, a), b) p q -> f block a b p q)
  in
  let module Block_services = Block_services.Make (Proto) (Next_proto) in
  let module S = Block_services.S in
  register0 S.live_blocks (fun block () () ->
      State.Block.max_operations_ttl block
      >>=? fun max_op_ttl ->
      Chain_traversal.live_blocks block max_op_ttl
      >>=? fun (live_blocks, _) -> return live_blocks) ;
  (* block metadata *)
  let metadata block =
    State.Block.metadata block
    >>=? fun metadata ->
    let protocol_data =
      Data_encoding.Binary.of_bytes_exn
        Proto.block_header_metadata_encoding
        metadata
    in
    State.Block.test_chain block
    >>= fun (test_chain_status, _) ->
    State.Block.max_operations_ttl block
    >>=? fun max_operations_ttl ->
    return
      {
        Block_services.protocol_data;
        test_chain_status;
        max_operations_ttl;
        max_operation_data_length = Next_proto.max_operation_data_length;
        max_block_header_length = Next_proto.max_block_length;
        operation_list_quota =
          List.map
            (fun {Tezos_protocol_environment.max_size; max_op} ->
              {Tezos_shell_services.Block_services.max_size; max_op})
            Next_proto.validation_passes;
      }
  in
  register0 S.metadata (fun block () () -> metadata block) ;
  (* operations *)
  let convert chain_id (op : Operation.t) metadata : Block_services.operation =
    let protocol_data =
      Data_encoding.Binary.of_bytes_exn Proto.operation_data_encoding op.proto
    in
    let receipt =
      Data_encoding.Binary.of_bytes_exn
        Proto.operation_receipt_encoding
        metadata
    in
    {
      Block_services.chain_id;
      hash = Operation.hash op;
      shell = op.shell;
      protocol_data;
      receipt;
    }
  in
  let operations block =
    State.Block.all_operations block
    >>= fun ops ->
    State.Block.all_operations_metadata block
    >>= fun metadata ->
    let chain_id = State.Block.chain_id block in
    return (List.map2 (List.map2 (convert chain_id)) ops metadata)
  in
  register0 S.Operations.operations (fun block () () -> operations block) ;
  register1 S.Operations.operations_in_pass (fun block i () () ->
      let chain_id = State.Block.chain_id block in
      try
        State.Block.operations block i
        >>= fun (ops, _path) ->
        State.Block.operations_metadata block i
        >>= fun metadata -> return (List.map2 (convert chain_id) ops metadata)
      with _ -> Lwt.fail Not_found) ;
  register2 S.Operations.operation (fun block i j () () ->
      let chain_id = State.Block.chain_id block in
      ( try
          State.Block.operations block i
          >>= fun (ops, _path) ->
          State.Block.operations_metadata block i
          >>= fun metadata -> Lwt.return (List.nth ops j, List.nth metadata j)
        with _ -> Lwt.fail Not_found )
      >>= fun (op, md) -> return (convert chain_id op md)) ;
  (* operation_hashes *)
  register0 S.Operation_hashes.operation_hashes (fun block () () ->
      State.Block.all_operation_hashes block >>= return) ;
  register1 S.Operation_hashes.operation_hashes_in_pass (fun block i () () ->
      State.Block.operation_hashes block i >>= fun (ops, _) -> return ops) ;
  register2 S.Operation_hashes.operation_hash (fun block i j () () ->
      ( try
          State.Block.operation_hashes block i
          >>= fun (ops, _) -> Lwt.return (List.nth ops j)
        with _ -> Lwt.fail Not_found )
      >>= fun op -> return op) ;
  (* context *)
  register1 S.Context.read (fun block path q () ->
      let depth = Option.unopt ~default:max_int q#depth in
      fail_unless
        (depth >= 0)
        (Tezos_shell_services.Block_services.Invalid_depth_arg depth)
      >>=? fun () ->
      State.Block.context_exn block
      >>= fun context ->
      Context.mem context path
      >>= fun mem ->
      Context.dir_mem context path
      >>= fun dir_mem ->
      if not (mem || dir_mem) then Lwt.fail Not_found
      else read_partial_context context path depth >>= fun dir -> return dir) ;
  (* info *)
  register0 S.info (fun block () () ->
      let chain_id = State.Block.chain_id block in
      let hash = State.Block.hash block in
      let header = State.Block.header block in
      let shell = header.shell in
      let protocol_data =
        Data_encoding.Binary.of_bytes_exn
          Proto.block_header_data_encoding
          header.protocol_data
      in
      metadata block
      >>=? fun metadata ->
      operations block
      >>=? fun operations ->
      return
        {
          Block_services.hash;
          chain_id;
          header = {shell; protocol_data};
          metadata;
          operations;
        }) ;
  (* helpers *)
  register0 S.Helpers.Preapply.block (fun block q p ->
      let timestamp =
        match q#timestamp with
        | None ->
            Time.System.to_protocol (Systime_os.now ())
        | Some time ->
            time
      in
      let protocol_data =
        Data_encoding.Binary.to_bytes_exn
          Next_proto.block_header_data_encoding
          p.protocol_data
      in
      let operations =
        List.map
          (List.map (fun op ->
               let proto =
                 Data_encoding.Binary.to_bytes_exn
                   Next_proto.operation_data_encoding
                   op.Next_proto.protocol_data
               in
               {Operation.shell = op.shell; proto}))
          p.operations
      in
      Prevalidation.preapply
        ~predecessor:block
        ~timestamp
        ~protocol_data
        operations) ;
  register0 S.Helpers.Preapply.operations (fun block () ops ->
      State.Block.context_exn block
      >>= fun ctxt ->
      let predecessor = State.Block.hash block in
      let header = State.Block.shell_header block in
      let predecessor_context = Shell_context.wrap_disk_context ctxt in
      Next_proto.begin_construction
        ~chain_id:(State.Block.chain_id block)
        ~predecessor_context
        ~predecessor_timestamp:header.timestamp
        ~predecessor_level:header.level
        ~predecessor_fitness:header.fitness
        ~predecessor
        ~timestamp:(Time.System.to_protocol (Systime_os.now ()))
        ()
      >>=? fun state ->
      fold_left_s
        (fun (state, acc) op ->
          Next_proto.apply_operation state op
          >>=? fun (state, result) ->
          return (state, (op.protocol_data, result) :: acc))
        (state, [])
        ops
      >>=? fun (state, acc) ->
      Next_proto.finalize_block state >>=? fun _ -> return (List.rev acc)) ;
  register1 S.Helpers.complete (fun block prefix () () ->
      State.Block.context_exn block
      >>= fun ctxt ->
      Base58.complete prefix
      >>= fun l1 ->
      let ctxt = Shell_context.wrap_disk_context ctxt in
      Next_proto.complete_b58prefix ctxt prefix >>= fun l2 -> return (l1 @ l2)) ;
  (* merge protocol rpcs... *)
  merge
    (RPC_directory.map
       (fun block ->
         let chain_state = State.Block.chain_state block in
         let hash = State.Block.hash block in
         let header = State.Block.header block in
         Lwt.return (chain_state, hash, header))
       (build_raw_header_rpc_directory (module Proto))) ;
  merge
    (RPC_directory.map
       (fun block ->
         State.Block.context_exn block
         >|= fun context ->
         let context = Shell_context.wrap_disk_context context in
         {
           Tezos_protocol_environment.block_hash = State.Block.hash block;
           block_header = State.Block.shell_header block;
           context;
         })
       Next_proto.rpc_services) ;
  !dir

let get_protocol hash =
  match Registered_protocol.get hash with
  | None ->
      raise Not_found
  | Some protocol ->
      protocol

let get_directory chain_state block =
  State.Block.get_rpc_directory block
  >>= function
  | Some dir ->
      Lwt.return dir
  | None -> (
      State.Block.protocol_hash_exn block
      >>= fun next_protocol_hash ->
      let next_protocol = get_protocol next_protocol_hash in
      State.Block.predecessor block
      >>= function
      | None ->
          Lwt.return
            (build_raw_rpc_directory
               (module Block_services.Fake_protocol)
               next_protocol)
      | Some pred -> (
          State.Chain.save_point chain_state
          >>= fun (save_point_level, _) ->
          ( if Compare.Int32.(State.Block.level pred < save_point_level) then
            State.Chain.get_level_indexed_protocol
              chain_state
              (State.Block.header pred)
          else State.Block.protocol_hash_exn pred )
          >>= fun protocol_hash ->
          let (module Proto) = get_protocol protocol_hash in
          State.Block.get_rpc_directory block
          >>= function
          | Some dir ->
              Lwt.return dir
          | None ->
              let dir = build_raw_rpc_directory (module Proto) next_protocol in
              State.Block.set_rpc_directory block dir
              >>= fun () -> Lwt.return dir ) )

let get_header_directory chain_state header =
  State.Block.header_of_hash chain_state header.Block_header.shell.predecessor
  >>= function
  | None ->
      (* should not happen *)
      Lwt.fail Not_found
  | Some pred -> (
      State.Chain.get_level_indexed_protocol chain_state pred
      >>= fun protocol_hash ->
      let (module Proto) = get_protocol protocol_hash in
      State.Block.get_header_rpc_directory chain_state header
      >>= function
      | Some dir ->
          Lwt.return dir
      | None ->
          let dir = build_raw_header_rpc_directory (module Proto) in
          State.Block.set_header_rpc_directory chain_state header dir
          >>= fun () -> Lwt.return dir )

let get_block chain_state = function
  | `Genesis ->
      Chain.genesis chain_state >>= fun genesis -> Lwt.return_some genesis
  | `Head n ->
      Chain.head chain_state
      >>= fun head ->
      if n < 0 then Lwt.return_none
      else if n = 0 then Lwt.return_some head
      else
        State.Block.read_predecessor
          chain_state
          ~pred:n
          ~below_save_point:true
          (State.Block.hash head)
  | (`Alias (_, n) | `Hash (_, n)) as b ->
      ( match b with
      | `Alias (`Checkpoint, _) ->
          State.Chain.checkpoint chain_state
          >>= fun checkpoint -> Lwt.return (Block_header.hash checkpoint)
      | `Alias (`Save_point, _) ->
          State.Chain.save_point chain_state
          >>= fun (_, save_point) -> Lwt.return save_point
      | `Alias (`Caboose, _) ->
          State.Chain.caboose chain_state
          >>= fun (_, caboose) -> Lwt.return caboose
      | `Hash (h, _) ->
          Lwt.return h )
      >>= fun hash ->
      if n < 0 then
        State.Block.read_opt chain_state hash
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun block ->
        Chain.head chain_state
        >>= fun head ->
        let head_level = State.Block.level head in
        let block_level = State.Block.level block in
        let target =
          Int32.(to_int (sub head_level (sub block_level (of_int n))))
        in
        if target < 0 then Lwt.return_none
        else
          State.Block.read_predecessor
            chain_state
            ~pred:target
            ~below_save_point:true
            (State.Block.hash head)
      else if n = 0 then
        Chain.genesis chain_state
        >>= fun genesis ->
        let genesis_hash = State.Block.hash genesis in
        if Block_hash.equal hash genesis_hash then Lwt.return_some genesis
        else
          State.Block.read_predecessor
            chain_state
            ~pred:0
            ~below_save_point:true
            hash
      else
        State.Block.read_predecessor
          chain_state
          ~pred:n
          ~below_save_point:true
          hash
  | `Level i ->
      Chain.head chain_state
      >>= fun head ->
      let target = Int32.(to_int (sub (State.Block.level head) i)) in
      if target < 0 then Lwt.fail Not_found
      else
        State.Block.read_predecessor
          chain_state
          ~pred:target
          ~below_save_point:true
          (State.Block.hash head)

let build_rpc_directory chain_state block =
  get_block chain_state block
  >>= function
  | None ->
      Lwt.fail Not_found
  | Some b ->
      State.Chain.save_point chain_state
      >>= fun (save_point_level, _) ->
      let block_level = State.Block.level b in
      let block_hash = State.Block.hash b in
      let genesis = State.Chain.genesis chain_state in
      if
        block_level >= save_point_level
        || Block_hash.equal block_hash genesis.block
      then
        get_directory chain_state b
        >>= fun dir ->
        Lwt.return (RPC_directory.map (fun _ -> Lwt.return b) dir)
      else
        let header = State.Block.header b in
        let hash = State.Block.hash b in
        get_header_directory chain_state header
        >>= fun dir ->
        Lwt.return
          (RPC_directory.map
             (fun _ -> Lwt.return (chain_state, hash, header))
             dir)
src/lib_shell/block_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Fixpoint read_partial_context
  (context : Tezos_storage.Context.context) (path : Tezos_storage.Context.key)
  (depth : Z) : Lwt.t Tezos_shell_services.Block_services.raw_context :=
  if equiv_decb depth 0 then
    Lwt._return Block_services.Cut
  else
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_storage.Context.get context path)
      (fun function_parameter =>
        match function_parameter with
        | Some v => Lwt._return (Block_services.Key v)
        | None =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_storage.Context.fold context path []
              (fun k =>
                fun acc =>
                  match k with
                  | Key k | Dir k =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (read_partial_context context k (Z.sub depth 1))
                      (fun v =>
                        let k :=
                          Tezos_base__TzPervasives.List.nth k
                            (Z.sub (Tezos_base__TzPervasives.List.length k) 1)
                          in
                        Lwt._return (cons (k, v) acc))
                  end))
            (fun l =>
              Lwt._return
                (Block_services.Dir (Tezos_base__TzPervasives.List.rev l)))
        end).

Definition build_raw_header_rpc_directory
  (Proto :
    {'(block_header_data, block_header_metadata, operation_data,
      operation_receipt, operation) : _ &
      Tezos_shell_services.Block_services.PROTO.signature block_header_data
        block_header_metadata operation_data operation_receipt operation})
  : Tezos_base__TzPervasives.RPC_directory.t
    (Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t) :=
  let Proto := projT2 Proto in
  let dir := Stdlib.ref Tezos_base__TzPervasives.RPC_directory.empty in
  let register0 {A B C D : Type}
    (s :
    Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
      Tezos_rpc.RPC_service.error) (f :
    (Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t) ->
      B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir)
        (Tezos_base__TzPervasives.RPC_service.subst0 s)
        (fun block => fun p => fun q => f block p q)) in
  let Block_services := unsupported_functor_application in
  let S := Block_services.S in
  register0 S.hash
    (fun function_parameter =>
      match function_parameter with
      | (_, hash, _) =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives._return hash
              end
          end
      end);
  register0 S.header
    (fun function_parameter =>
      match function_parameter with
      | (chain_state, hash, header) =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                let protocol_data :=
                  Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                    Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
                    (protocol_data header) in
                Tezos_base__TzPervasives._return
                  {|
                    Block_services.chain_id :=
                      Tezos_shell.State.Chain.id chain_state;
                    Block_services.hash := hash;
                    Block_services.shell := shell header;
                    Block_services.protocol_data := protocol_data |}
              end
          end
      end);
  register0 S.raw_header
    (fun function_parameter =>
      match function_parameter with
      | (_, _, header) =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives._return
                  (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                    Tezos_base__TzPervasives.Block_header.encoding header)
              end
          end
      end);
  register0 S.Header.shell_header
    (fun function_parameter =>
      match function_parameter with
      | (_, _, header) =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives._return (shell header)
              end
          end
      end);
  register0 S.Header.protocol_data
    (fun function_parameter =>
      match function_parameter with
      | (_, _, header) =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives._return
                  (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                    Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
                    (protocol_data header))
              end
          end
      end);
  register0 S.Header.raw_protocol_data
    (fun function_parameter =>
      match function_parameter with
      | (_, _, header) =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives._return (protocol_data header)
              end
          end
      end);
  register0 S.Helpers.Forge.block_header
    (fun _block =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun header =>
            Tezos_base__TzPervasives._return
              (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                Tezos_base__TzPervasives.Block_header.encoding header)
        end);
  register0 S.protocols
    (fun function_parameter =>
      match function_parameter with
      | (chain_state, _hash, header) =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Chain.get_level_indexed_protocol
                    chain_state header)
                  (fun next_protocol_hash =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.State.Block.header_of_hash chain_state
                        (predecessor (shell header)))
                      (fun function_parameter =>
                        match function_parameter with
                        | None =>
                          Tezos_base__TzPervasives._return
                            {|
                              Tezos_shell_services.Block_services.current_protocol :=
                                next_protocol_hash;
                              Tezos_shell_services.Block_services.next_protocol :=
                                next_protocol_hash |}
                        | Some pred_header =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_shell.State.Chain.get_level_indexed_protocol
                              chain_state pred_header)
                            (fun protocol_hash =>
                              Tezos_base__TzPervasives._return
                                {|
                                  Tezos_shell_services.Block_services.current_protocol :=
                                    protocol_hash;
                                  Tezos_shell_services.Block_services.next_protocol :=
                                    next_protocol_hash |})
                        end))
              end
          end
      end);
  Stdlib.op_exclamation dir.

Definition build_raw_rpc_directory
  (Proto :
    {'(block_header_data, block_header_metadata, operation_data,
      operation_receipt, operation) : _ &
      Tezos_shell_services.Block_services.PROTO.signature block_header_data
        block_header_metadata operation_data operation_receipt operation})
  : {'(P_block_header_data, P_block_header, P_block_header_metadata,
    P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
    &
    Tezos_protocol_updater.Registered_protocol.T.signature P_block_header_data
      P_block_header P_block_header_metadata P_operation_data
      P_operation_receipt P_operation P_validation_state} ->
    Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Block.block :=
  let Proto := projT2 Proto in
  fun Next_proto =>
    let Next_proto := projT2 Next_proto in
    let dir := Stdlib.ref Tezos_base__TzPervasives.RPC_directory.empty in
    let merge
      (d :
      Tezos_base__TzPervasives.RPC_directory.directory
        Tezos_shell.State.Block.block) : unit :=
      Stdlib.op_colon_eq dir
        (Tezos_base__TzPervasives.RPC_directory.merge d
          (Stdlib.op_exclamation dir)) in
    let register0 {A B C D : Type}
      (s :
      Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
        Tezos_rpc.RPC_service.error) (f :
      Tezos_shell.State.Block.block ->
        B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
      Stdlib.op_colon_eq dir
        (Tezos_base__TzPervasives.RPC_directory.register
          (Stdlib.op_exclamation dir)
          (Tezos_base__TzPervasives.RPC_service.subst0 s)
          (fun block => fun p => fun q => f block p q)) in
    let register1 {A B C D E : Type}
      (s :
      Tezos_base__TzPervasives.RPC_service.raw variant A (A * B) C D E
        Tezos_rpc.RPC_service.error) (f :
      Tezos_shell.State.Block.block ->
        B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E))
      : unit :=
      Stdlib.op_colon_eq dir
        (Tezos_base__TzPervasives.RPC_directory.register
          (Stdlib.op_exclamation dir)
          (Tezos_base__TzPervasives.RPC_service.subst1 s)
          (fun function_parameter =>
            match function_parameter with
            | (block, a) => fun p => fun q => f block a p q
            end)) in
    let register2 {A B C D E F : Type}
      (s :
      Tezos_base__TzPervasives.RPC_service.raw variant A ((A * B) * C) D E F
        Tezos_rpc.RPC_service.error) (f :
      Tezos_shell.State.Block.block ->
        B -> C -> D -> E -> Lwt.t (Tezos_error_monad.Error_monad.tzresult F))
      : unit :=
      Stdlib.op_colon_eq dir
        (Tezos_base__TzPervasives.RPC_directory.register
          (Stdlib.op_exclamation dir)
          (Tezos_base__TzPervasives.RPC_service.subst2 s)
          (fun function_parameter =>
            match function_parameter with
            | ((block, a), b) => fun p => fun q => f block a b p q
            end)) in
    let Block_services := unsupported_functor_application in
    let S := Block_services.S in
    register0 S.live_blocks
      (fun block =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_shell.State.Block.max_operations_ttl block)
                  (fun max_op_ttl =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell.Chain_traversal.live_blocks block max_op_ttl)
                      (fun function_parameter =>
                        match function_parameter with
                        | (live_blocks, _) =>
                          Tezos_base__TzPervasives._return live_blocks
                        end))
              end
          end);
    let metadata (block : Tezos_shell.State.Block.t)
      : Lwt.t (Tezos_base__TzPervasives.tzresult Block_services.block_metadata) :=
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.State.Block.metadata block)
        (fun metadata =>
          let protocol_data :=
            Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
              Proto.(Tezos_shell_services__Block_services.PROTO.block_header_metadata_encoding)
              metadata in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.test_chain block)
            (fun function_parameter =>
              match function_parameter with
              | (test_chain_status, _) =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_shell.State.Block.max_operations_ttl block)
                  (fun max_operations_ttl =>
                    Tezos_base__TzPervasives._return
                      {| Block_services.protocol_data := protocol_data;
                        Block_services.test_chain_status := test_chain_status;
                        Block_services.max_operations_ttl := max_operations_ttl;
                        Block_services.max_operation_data_length :=
                          Next_proto.(Tezos_protocol_updater__Registered_protocol.T.max_operation_data_length);
                        Block_services.max_block_header_length :=
                          Next_proto.(Tezos_protocol_updater__Registered_protocol.T.max_block_length);
                        Block_services.operation_list_quota :=
                          Tezos_base__TzPervasives.List.map
                            (fun function_parameter =>
                              match function_parameter with
                              | {|
                                Tezos_protocol_environment.max_size := max_size;
                                  Tezos_protocol_environment.max_op := max_op
                                  |} =>
                                {|
                                  Tezos_shell_services.Block_services.max_size :=
                                    max_size;
                                  Tezos_shell_services.Block_services.max_op :=
                                    max_op |}
                              end)
                            Next_proto.(Tezos_protocol_updater__Registered_protocol.T.validation_passes)
                        |})
              end)) in
    register0 S.metadata
      (fun block =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt => metadata block
              end
          end);
    let convert
      (chain_id : Tezos_base__TzPervasives.Chain_id.t) (op :
      Tezos_base__TzPervasives.Operation.t) (metadata : Stdlib.Bytes.t)
      : Block_services.operation :=
      let protocol_data :=
        Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
          Proto.(Tezos_shell_services__Block_services.PROTO.operation_data_encoding)
          (proto op) in
      let receipt :=
        Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
          Proto.(Tezos_shell_services__Block_services.PROTO.operation_receipt_encoding)
          metadata in
      {| Block_services.chain_id := chain_id;
        Block_services.hash := Tezos_base__TzPervasives.Operation.hash op;
        Block_services.shell := shell op;
        Block_services.protocol_data := protocol_data;
        Block_services.receipt := receipt |} in
    let operations (block : Tezos_shell.State.Block.t)
      : Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list (list Block_services.operation))) :=
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.all_operations block)
        (fun ops =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.all_operations_metadata block)
            (fun metadata =>
              let chain_id := Tezos_shell.State.Block.chain_id block in
              Tezos_base__TzPervasives._return
                (Tezos_base__TzPervasives.List.map2
                  (Tezos_base__TzPervasives.List.map2 (convert chain_id)) ops
                  metadata))) in
    register0 S.Operations.operations
      (fun block =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt => operations block
              end
          end);
    register1 S.Operations.operations_in_pass
      (fun block =>
        fun i =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  let chain_id := Tezos_shell.State.Block.chain_id block in
                  try
                end
            end);
    register2 S.Operations.operation
      (fun block =>
        fun i =>
          fun j =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    let chain_id := Tezos_shell.State.Block.chain_id block in
                    Tezos_base__TzPervasives.op_gt_gt_eq try
                      (fun function_parameter =>
                        match function_parameter with
                        | (op, md) =>
                          Tezos_base__TzPervasives._return
                            (convert chain_id op md)
                        end)
                  end
              end);
    register0 S.Operation_hashes.operation_hashes
      (fun block =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Block.all_operation_hashes block)
                  Tezos_base__TzPervasives._return
              end
          end);
    register1 S.Operation_hashes.operation_hashes_in_pass
      (fun block =>
        fun i =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.Block.operation_hashes block i)
                    (fun function_parameter =>
                      match function_parameter with
                      | (ops, _) => Tezos_base__TzPervasives._return ops
                      end)
                end
            end);
    register2 S.Operation_hashes.operation_hash
      (fun block =>
        fun i =>
          fun j =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq try
                      (fun op => Tezos_base__TzPervasives._return op)
                  end
              end);
    register1 S.Context.read
      (fun block =>
        fun path =>
          fun q =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                let depth :=
                  Tezos_base__TzPervasives.Option.unopt Stdlib.max_int send in
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_base__TzPervasives.fail_unless
                    (OCaml.Stdlib.ge depth 0)
                    (Tezos_shell_services.Block_services.Invalid_depth_arg depth))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.State.Block.context_exn block)
                        (fun context =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_storage.Context.mem context path)
                            (fun mem =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_storage.Context.dir_mem context path)
                                (fun dir_mem =>
                                  if negb (orb mem dir_mem) then
                                    Lwt.fail OCaml.Not_found
                                  else
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (read_partial_context context path depth)
                                      (fun dir =>
                                        Tezos_base__TzPervasives._return dir))))
                    end)
              end);
    register0 S.info
      (fun block =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                let chain_id := Tezos_shell.State.Block.chain_id block in
                let hash := Tezos_shell.State.Block.hash block in
                let header := Tezos_shell.State.Block.header block in
                let shell := shell header in
                let protocol_data :=
                  Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                    Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
                    (protocol_data header) in
                Tezos_base__TzPervasives.op_gt_gt_eq_question (metadata block)
                  (fun metadata =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (operations block)
                      (fun operations =>
                        Tezos_base__TzPervasives._return
                          {| Block_services.chain_id := chain_id;
                            Block_services.hash := hash;
                            Block_services.header :=
                              {| shell := shell; protocol_data := protocol_data
                                |}; Block_services.metadata := metadata;
                            Block_services.operations := operations |}))
              end
          end);
    register0 S.Helpers.Preapply.block
      (fun block =>
        fun q =>
          fun p =>
            let timestamp :=
              match send with
              | None =>
                Tezos_base__TzPervasives.Time.System.to_protocol
                  (Tezos_stdlib_unix.Systime_os.now tt)
              | Some time => time
              end in
            let protocol_data :=
              Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                Next_proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
                (protocol_data p) in
            let operations :=
              Tezos_base__TzPervasives.List.map
                (Tezos_base__TzPervasives.List.map
                  (fun op =>
                    let proto :=
                      Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                        Next_proto.(Tezos_protocol_updater__Registered_protocol.T.operation_data_encoding)
                        (Next_proto.protocol_data op) in
                    {| Operation.shell := shell op; Operation.proto := proto |}))
                (operations p) in
            Tezos_shell.Prevalidation.preapply block timestamp protocol_data
              operations);
    register0 S.Helpers.Preapply.operations
      (fun block =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun ops =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.State.Block.context_exn block)
                (fun ctxt =>
                  let predecessor := Tezos_shell.State.Block.hash block in
                  let header := Tezos_shell.State.Block.shell_header block in
                  let predecessor_context :=
                    Tezos_shell_context.Shell_context.wrap_disk_context ctxt in
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Next_proto.(Tezos_protocol_updater__Registered_protocol.T.begin_construction)
                      (Tezos_shell.State.Block.chain_id block)
                      predecessor_context (timestamp header) (level header)
                      (fitness header) predecessor
                      (Tezos_base__TzPervasives.Time.System.to_protocol
                        (Tezos_stdlib_unix.Systime_os.now tt)) None tt)
                    (fun state =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_base__TzPervasives.fold_left_s
                          (fun function_parameter =>
                            match function_parameter with
                            | (state, acc) =>
                              fun op =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Next_proto.(Tezos_protocol_updater__Registered_protocol.T.apply_operation)
                                    state op)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (state, result) =>
                                      Tezos_base__TzPervasives._return
                                        (state,
                                          (cons ((protocol_data op), result) acc))
                                    end)
                            end) (state, []) ops)
                        (fun function_parameter =>
                          match function_parameter with
                          | (state, acc) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Next_proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
                                state)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ =>
                                  Tezos_base__TzPervasives._return
                                    (Tezos_base__TzPervasives.List.rev acc)
                                end)
                          end)))
          end);
    register1 S.Helpers.complete
      (fun block =>
        fun prefix =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.Block.context_exn block)
                    (fun ctxt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_base__TzPervasives.Base58.complete None prefix)
                        (fun l1 =>
                          let ctxt :=
                            Tezos_shell_context.Shell_context.wrap_disk_context
                              ctxt in
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Next_proto.(Tezos_protocol_updater__Registered_protocol.T.complete_b58prefix)
                              ctxt prefix)
                            (fun l2 =>
                              Tezos_base__TzPervasives._return
                                (OCaml.Stdlib.app l1 l2))))
                end
            end);
    merge
      (Tezos_base__TzPervasives.RPC_directory.map
        (fun block =>
          let chain_state := Tezos_shell.State.Block.chain_state block in
          let hash := Tezos_shell.State.Block.hash block in
          let header := Tezos_shell.State.Block.header block in
          Lwt._return (chain_state, hash, header))
        (build_raw_header_rpc_directory Proto));
    merge
      (Tezos_base__TzPervasives.RPC_directory.map
        (fun block =>
          Tezos_base__TzPervasives.op_gt_pipe_eq
            (Tezos_shell.State.Block.context_exn block)
            (fun context =>
              let context :=
                Tezos_shell_context.Shell_context.wrap_disk_context context in
              {|
                Tezos_protocol_environment.block_hash :=
                  Tezos_shell.State.Block.hash block;
                Tezos_protocol_environment.block_header :=
                  Tezos_shell.State.Block.shell_header block;
                Tezos_protocol_environment.context := context |}))
        Next_proto.(Tezos_protocol_updater__Registered_protocol.T.rpc_services));
    Stdlib.op_exclamation dir.

Definition get_protocol (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  : Tezos_protocol_updater.Registered_protocol.t :=
  match Tezos_protocol_updater.Registered_protocol.get hash with
  | None => Stdlib.raise OCaml.Not_found
  | Some protocol => protocol
  end.

Definition get_directory
  (chain_state : Tezos_shell.State.Chain.chain_state)
  (block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Block.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Block.get_rpc_directory block)
    (fun function_parameter =>
      match function_parameter with
      | Some dir => Lwt._return dir
      | None =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Block.protocol_hash_exn block)
          (fun next_protocol_hash =>
            let next_protocol := get_protocol next_protocol_hash in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Block.predecessor block)
              (fun function_parameter =>
                match function_parameter with
                | None =>
                  Lwt._return
                    (build_raw_rpc_directory
                      Tezos_shell_services.Block_services.Fake_protocol
                      next_protocol)
                | Some pred =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.Chain.save_point chain_state)
                    (fun function_parameter =>
                      match function_parameter with
                      | (save_point_level, _) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (if
                            Tezos_base__TzPervasives.Compare.Int32.op_lt
                              (Tezos_shell.State.Block.level pred)
                              save_point_level then
                            Tezos_shell.State.Chain.get_level_indexed_protocol
                              chain_state (Tezos_shell.State.Block.header pred)
                          else
                            Tezos_shell.State.Block.protocol_hash_exn pred)
                          (fun protocol_hash =>
                            let Proto := get_protocol protocol_hash in
                            let Proto := projT2 Proto in
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_shell.State.Block.get_rpc_directory block)
                              (fun function_parameter =>
                                match function_parameter with
                                | Some dir => Lwt._return dir
                                | None =>
                                  let dir :=
                                    build_raw_rpc_directory Proto next_protocol
                                    in
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_shell.State.Block.set_rpc_directory
                                      block dir)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt => Lwt._return dir
                                      end)
                                end))
                      end)
                end))
      end).

Definition get_header_directory
  (chain_state : Tezos_shell__State.Chain.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t
    (Tezos_base__TzPervasives.RPC_directory.t
      (Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Block.header_of_hash chain_state
      (predecessor (Block_header.shell header)))
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.fail OCaml.Not_found
      | Some pred =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.get_level_indexed_protocol chain_state pred)
          (fun protocol_hash =>
            let Proto := get_protocol protocol_hash in
            let Proto := projT2 Proto in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Block.get_header_rpc_directory chain_state
                header)
              (fun function_parameter =>
                match function_parameter with
                | Some dir => Lwt._return dir
                | None =>
                  let dir := build_raw_header_rpc_directory Proto in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.Block.set_header_rpc_directory
                      chain_state header dir)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Lwt._return dir
                      end)
                end))
      end).

Definition get_block
  (chain_state : Tezos_shell.State.Chain.t) (function_parameter : variant)
  : Lwt.t (option Tezos_shell.State.Block.t) :=
  match function_parameter with
  | Genesis =>
    Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.genesis chain_state)
      (fun genesis => Lwt.return_some genesis)
  | Head n =>
    Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.head chain_state)
      (fun head =>
        if OCaml.Stdlib.lt n 0 then
          Lwt.return_none
        else
          if equiv_decb n 0 then
            Lwt.return_some head
          else
            Tezos_shell.State.Block.read_predecessor chain_state n (Some true)
              (Tezos_shell.State.Block.hash head))
  | (Alias (_, n) | Hash (_, n)) as b =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      match b with
      | Alias (Checkpoint, _) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.checkpoint chain_state)
          (fun checkpoint =>
            Lwt._return (Tezos_base__TzPervasives.Block_header.hash checkpoint))
      | Alias (Save_point, _) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.save_point chain_state)
          (fun function_parameter =>
            match function_parameter with
            | (_, save_point) => Lwt._return save_point
            end)
      | Alias (Caboose, _) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.caboose chain_state)
          (fun function_parameter =>
            match function_parameter with
            | (_, caboose) => Lwt._return caboose
            end)
      | Hash (h, _) => Lwt._return h
      end
      (fun hash =>
        if OCaml.Stdlib.lt n 0 then
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_base__TzPervasives.op_gt_pipe_eq
              (Tezos_shell.State.Block.read_opt chain_state hash)
              (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
            (fun block =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Chain.head chain_state)
                (fun head =>
                  let head_level := Tezos_shell.State.Block.level head in
                  let block_level := Tezos_shell.State.Block.level block in
                  let target :=
                    Stdlib.Int32.to_int
                      (Stdlib.Int32.sub head_level
                        (Stdlib.Int32.sub block_level (Stdlib.Int32.of_int n)))
                    in
                  if OCaml.Stdlib.lt target 0 then
                    Lwt.return_none
                  else
                    Tezos_shell.State.Block.read_predecessor chain_state target
                      (Some true) (Tezos_shell.State.Block.hash head)))
        else
          if equiv_decb n 0 then
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.Chain.genesis chain_state)
              (fun genesis =>
                let genesis_hash := Tezos_shell.State.Block.hash genesis in
                if Tezos_base__TzPervasives.Block_hash.equal hash genesis_hash
                  then
                  Lwt.return_some genesis
                else
                  Tezos_shell.State.Block.read_predecessor chain_state 0
                    (Some true) hash)
          else
            Tezos_shell.State.Block.read_predecessor chain_state n (Some true)
              hash)
  | Level i =>
    Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.head chain_state)
      (fun head =>
        let target :=
          Stdlib.Int32.to_int
            (Stdlib.Int32.sub (Tezos_shell.State.Block.level head) i) in
        if OCaml.Stdlib.lt target 0 then
          Lwt.fail OCaml.Not_found
        else
          Tezos_shell.State.Block.read_predecessor chain_state target
            (Some true) (Tezos_shell.State.Block.hash head))
  end.

Definition build_rpc_directory {A : Type}
  (chain_state : Tezos_shell.State.Chain.t) (block : variant)
  : Lwt.t (Tezos_base__TzPervasives.RPC_directory.directory A) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (get_block chain_state block)
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.fail OCaml.Not_found
      | Some b =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.save_point chain_state)
          (fun function_parameter =>
            match function_parameter with
            | (save_point_level, _) =>
              let block_level := Tezos_shell.State.Block.level b in
              let block_hash := Tezos_shell.State.Block.hash b in
              let genesis := Tezos_shell.State.Chain.genesis chain_state in
              if
                orb (OCaml.Stdlib.ge block_level save_point_level)
                  (Tezos_base__TzPervasives.Block_hash.equal block_hash
                    (block genesis)) then
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (get_directory chain_state b)
                  (fun dir =>
                    Lwt._return
                      (Tezos_base__TzPervasives.RPC_directory.map
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => Lwt._return b
                          end) dir))
              else
                let header := Tezos_shell.State.Block.header b in
                let hash := Tezos_shell.State.Block.hash b in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (get_header_directory chain_state header)
                  (fun dir =>
                    Lwt._return
                      (Tezos_base__TzPervasives.RPC_directory.map
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => Lwt._return (chain_state, hash, header)
                          end) dir))
            end)
      end).
src/lib_shell/block_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val get_block :
  State.Chain.t -> Block_services.block -> State.Block.t option Lwt.t

val build_raw_rpc_directory :
  (module Block_services.PROTO) ->
  (module Registered_protocol.T) ->
  State.Block.t RPC_directory.directory

val build_rpc_directory :
  State.Chain.t -> Block_services.block -> 'a RPC_directory.t Lwt.t
src/lib_shell/block_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_block :
Tezos_shell.State.Chain.t ->
  Tezos_shell_services.Block_services.block ->
    Lwt.t (option Tezos_shell.State.Block.t).

Parameter build_raw_rpc_directory :
{'(block_header_data, block_header_metadata, operation_data, operation_receipt,
  operation) : _ &
  Tezos_shell_services.Block_services.PROTO.signature block_header_data
    block_header_metadata operation_data operation_receipt operation} ->
  {'(P_block_header_data, P_block_header, P_block_header_metadata,
    P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
    &
    Tezos_protocol_updater.Registered_protocol.T.signature P_block_header_data
      P_block_header P_block_header_metadata P_operation_data
      P_operation_receipt P_operation P_validation_state} ->
    Tezos_base__TzPervasives.RPC_directory.directory Tezos_shell.State.Block.t.

Parameter build_rpc_directory : forall {a : Type},
Tezos_shell.State.Chain.t ->
  Tezos_shell_services.Block_services.block ->
    Lwt.t (Tezos_base__TzPervasives.RPC_directory.t a).
src/lib_shell/block_validator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Block_validator_worker_state
open Block_validator_errors

type limits = {
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

module Name = struct
  type t = unit

  let encoding = Data_encoding.empty

  let base = ["validator"; "block"]

  let pp _ () = ()
end

module Types = struct
  include Worker_state

  type state = {
    protocol_validator : Protocol_validator.t;
    validation_process : Block_validator_process.t;
    limits : limits;
    start_testchain : bool;
  }

  type parameters =
    limits * bool * Distributed_db.t * Block_validator_process.t

  let view _state _parameters = ()
end

module Request = struct
  include Request

  type 'a t =
    | Request_validation : {
        chain_db : Distributed_db.chain_db;
        notify_new_block : State.Block.t -> unit;
        canceler : Lwt_canceler.t option;
        peer : P2p_peer.Id.t option;
        hash : Block_hash.t;
        header : Block_header.t;
        operations : Operation.t list list;
      }
        -> State.Block.t option tzresult t

  let view : type a. a t -> view =
   fun (Request_validation {chain_db; peer; hash; _}) ->
    let chain_id = chain_db |> Distributed_db.chain_state |> State.Chain.id in
    {chain_id; block = hash; peer}
end

module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)

type t = Worker.infinite Worker.queue Worker.t

let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))

let check_chain_liveness chain_db hash (header : Block_header.t) =
  let chain_state = Distributed_db.chain_state chain_db in
  match State.Chain.expiration chain_state with
  | Some eol when Time.Protocol.(eol <= header.shell.timestamp) ->
      fail @@ invalid_block hash
      @@ Expired_chain
           {
             chain_id = State.Chain.id chain_state;
             expiration = eol;
             timestamp = header.shell.timestamp;
           }
  | None | Some _ ->
      return_unit

let on_request : type r. t -> r Request.t -> r tzresult Lwt.t =
 fun w
     (Request.Request_validation
       {chain_db; notify_new_block; canceler; peer; hash; header; operations}) ->
  let bv = Worker.state w in
  let chain_state = Distributed_db.chain_state chain_db in
  State.Block.read_opt chain_state hash
  >>= function
  | Some block ->
      debug
        w
        "previously validated block %a (after pipe)"
        Block_hash.pp_short
        hash ;
      Protocol_validator.prefetch_and_compile_protocols
        bv.protocol_validator
        ?peer
        ~timeout:bv.limits.protocol_timeout
        block ;
      return (Ok None)
  | None -> (
      State.Block.read_invalid chain_state hash
      >>= function
      | Some {errors; _} ->
          return (Error errors)
      | None -> (
          State.Chain.save_point chain_state
          >>= fun (save_point_lvl, _) ->
          (* Safety and late workers in partial mode. *)
          if Compare.Int32.(header.shell.level < save_point_lvl) then
            return (Ok None)
          else
            ( debug w "validating block %a" Block_hash.pp_short hash ;
              State.Block.read chain_state header.shell.predecessor
              >>=? fun pred ->
              Worker.protect w (fun () ->
                  protect ?canceler (fun () ->
                      Block_validator_process.apply_block
                        bv.validation_process
                        ~predecessor:pred
                        header
                        operations
                      >>= function
                      | Ok x ->
                          return x
                      | Error (Missing_test_protocol protocol :: _) ->
                          Protocol_validator.fetch_and_compile_protocol
                            bv.protocol_validator
                            ?peer
                            ~timeout:bv.limits.protocol_timeout
                            protocol
                          >>=? fun _ ->
                          Block_validator_process.apply_block
                            bv.validation_process
                            ~predecessor:pred
                            header
                            operations
                      | Error _ as x ->
                          Lwt.return x)
                  >>=? fun { validation_store;
                             block_metadata;
                             ops_metadata;
                             forking_testchain } ->
                  let validation_store =
                    ( {
                        context_hash = validation_store.context_hash;
                        message = validation_store.message;
                        max_operations_ttl =
                          validation_store.max_operations_ttl;
                        last_allowed_fork_level =
                          validation_store.last_allowed_fork_level;
                      }
                      : Block_validation.validation_store )
                  in
                  Distributed_db.commit_block
                    chain_db
                    hash
                    header
                    block_metadata
                    operations
                    ops_metadata
                    validation_store
                    ~forking_testchain
                  >>=? function
                  | None ->
                      assert false (* should not happen *)
                  | Some block ->
                      return block) )
            >>= function
            | Ok block ->
                Protocol_validator.prefetch_and_compile_protocols
                  bv.protocol_validator
                  ?peer
                  ~timeout:bv.limits.protocol_timeout
                  block ;
                notify_new_block block ;
                return (Ok (Some block))
            | Error err as error ->
                if
                  List.exists
                    (function Invalid_block _ -> true | _ -> false)
                    err
                then (
                  Worker.protect w (fun () ->
                      Distributed_db.commit_invalid_block
                        chain_db
                        hash
                        header
                        err)
                  >>=? fun commited ->
                  assert commited ;
                  return error )
                else (
                  debug
                    w
                    "Error during %a block validation: %a"
                    Block_hash.pp_short
                    hash
                    Error_monad.pp_print_error
                    err ;
                  return error ) ) )

let on_launch _ _ (limits, start_testchain, db, validation_process) =
  let protocol_validator = Protocol_validator.create db in
  return
    {Types.protocol_validator; validation_process; limits; start_testchain}

let on_error w r st errs =
  Worker.record_event w (Validation_failure (r, st, errs)) ;
  Lwt.return_error errs

let on_completion :
    type a. t -> a Request.t -> a -> Worker_types.request_status -> unit Lwt.t
    =
 fun w (Request.Request_validation _ as r) v st ->
  match v with
  | Ok (Some _) ->
      Worker.record_event w (Event.Validation_success (Request.view r, st)) ;
      Lwt.return_unit
  | Ok None ->
      Lwt.return_unit
  | Error errs ->
      Worker.record_event
        w
        (Event.Validation_failure (Request.view r, st, errs)) ;
      Lwt.return_unit

let on_close w =
  let bv = Worker.state w in
  Block_validator_process.close bv.validation_process

let table = Worker.create_table Queue

let create limits db validation_process ~start_testchain =
  let module Handlers = struct
    type self = t

    let on_launch = on_launch

    let on_request = on_request

    let on_close = on_close

    let on_error = on_error

    let on_completion = on_completion

    let on_no_request _ = return_unit
  end in
  Worker.launch
    table
    limits.worker_limits
    ()
    (limits, start_testchain, db, validation_process)
    (module Handlers)

let shutdown = Worker.shutdown

let validate w ?canceler ?peer ?(notify_new_block = fun _ -> ()) chain_db hash
    (header : Block_header.t) operations =
  let bv = Worker.state w in
  let chain_state = Distributed_db.chain_state chain_db in
  State.Block.read_opt chain_state hash
  >>= function
  | Some block ->
      debug
        w
        "previously validated block %a (before pipe)"
        Block_hash.pp_short
        hash ;
      Protocol_validator.prefetch_and_compile_protocols
        bv.protocol_validator
        ?peer
        ~timeout:bv.limits.protocol_timeout
        block ;
      return_none
  | None ->
      map_p
        (map_p (fun op ->
             let op_hash = Operation.hash op in
             return op_hash))
        operations
      >>=? fun hashes ->
      let computed_hash =
        Operation_list_list_hash.compute
          (List.map Operation_list_hash.compute hashes)
      in
      fail_when
        ( Operation_list_list_hash.compare
            computed_hash
            header.shell.operations_hash
        <> 0 )
        (Inconsistent_operations_hash
           {
             block = hash;
             expected = header.shell.operations_hash;
             found = computed_hash;
           })
      >>=? fun () ->
      check_chain_liveness chain_db hash header
      >>=? fun () ->
      Worker.Queue.push_request_and_wait
        w
        (Request_validation
           {
             chain_db;
             notify_new_block;
             canceler;
             peer;
             hash;
             header;
             operations;
           })
      >>=? fun result -> Lwt.return result

let fetch_and_compile_protocol w =
  let bv = Worker.state w in
  Protocol_validator.fetch_and_compile_protocol bv.protocol_validator

let status = Worker.status

let running_worker () =
  match Worker.list table with
  | [(_, single)] ->
      single
  | [] ->
      raise Not_found
  | _ :: _ :: _ ->
      (* NOTE: names of workers must be unique, [Name.t = unit] which has only
         one inhabitant. *)
      assert false

let pending_requests t = Worker.Queue.pending_requests t

let current_request t = Worker.current_request t

let last_events = Worker.last_events
src/lib_shell/block_validator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.Block_validator_worker_state.

Import Tezos_shell_services.Block_validator_errors.

Record limits := {
  protocol_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module Name.
  Definition t := unit.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Tezos_base__TzPervasives.Data_encoding.empty.
  
  Definition base : list string :=
    cons "validator" % string (cons "block" % string []).
  
  Definition pp {A : Type} (function_parameter : A) : unit -> unit :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | tt => tt
        end
    end.
End Name.

Module Types.
  Record state := {
    protocol_validator : Tezos_shell.Protocol_validator.t;
    validation_process : Tezos_shell.Block_validator_process.t;
    limits : limits;
    start_testchain : bool }.
  
  Definition parameters :=
    limits * bool * Tezos_shell.Distributed_db.t *
      Tezos_shell.Block_validator_process.t.
  
  Definition view {A B : Type} (_state : A) (_parameters : B) : unit := tt.
End Types.

Module Request.
  Inductive t : forall (a : Type), Type :=
  | Request_validation : Tezos_shell.Distributed_db.chain_db ->
    (Tezos_shell.State.Block.t -> unit) ->
    (option Tezos_base__TzPervasives.Lwt_canceler.t) ->
    (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Block_header.t ->
    (list (list Tezos_base__TzPervasives.Operation.t)) ->
    t (Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.t)).
  
  Definition view {a : Type} (function_parameter : t a) : view :=
    match function_parameter with
    | Request_validation {| chain_db := chain_db; peer := peer; hash := hash |}
      =>
      let chain_id :=
        OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply chain_db
            Tezos_shell.Distributed_db.chain_state) Tezos_shell.State.Chain.id
        in
      {| chain_id := chain_id; block := hash; peer := peer |}
    end.
End Request.

Definition t := Worker.t (Worker.queue Worker.infinite).

Definition debug {A B : Type} (w : Worker.t A)
  : (Stdlib.format4 B Stdlib.Format.formatter unit unit) -> B :=
  Stdlib.Format.kasprintf (fun msg => Worker.record_event w (Debug msg)).

Definition check_chain_liveness
  (chain_db : Tezos_shell.Distributed_db.chain_db)
  (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let chain_state := Tezos_shell.Distributed_db.chain_state chain_db in
  match Tezos_shell.State.Chain.expiration chain_state with
  | None | Some _ => Tezos_base__TzPervasives.return_unit
  end.

Definition on_request {r : Type} (w : t) (function_parameter : Request.t r)
  : Lwt.t (Tezos_base__TzPervasives.tzresult r) :=
  match function_parameter with
  |
    Request.Request_validation {|
      chain_db := chain_db;
        notify_new_block := notify_new_block;
        canceler := canceler;
        peer := peer;
        hash := hash;
        header := header;
        operations := operations
        |} =>
    let bv := Worker.state w in
    let chain_state := Tezos_shell.Distributed_db.chain_state chain_db in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.State.Block.read_opt chain_state hash)
      (fun function_parameter =>
        match function_parameter with
        | Some block =>
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "previously validated block " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " (after pipe)" % string
                    CamlinternalFormatBasics.End_of_format)))
              "previously validated block %a (after pipe)" % string)
            Tezos_base__TzPervasives.Block_hash.pp_short hash;
          Tezos_shell.Protocol_validator.prefetch_and_compile_protocols
            (protocol_validator bv) peer (Some (protocol_timeout (limits bv)))
            block;
          Tezos_base__TzPervasives._return (inl None)
        | None =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.read_invalid chain_state hash)
            (fun function_parameter =>
              match function_parameter with
              | Some {| errors := errors |} =>
                Tezos_base__TzPervasives._return (inr errors)
              | None =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Chain.save_point chain_state)
                  (fun function_parameter =>
                    match function_parameter with
                    | (save_point_lvl, _) =>
                      if
                        Tezos_base__TzPervasives.Compare.Int32.op_lt
                          (level (shell header)) save_point_lvl then
                        Tezos_base__TzPervasives._return (inl None)
                      else
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (debug w
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "validating block " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))
                              "validating block %a" % string)
                            Tezos_base__TzPervasives.Block_hash.pp_short hash;
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_shell.State.Block.read chain_state
                              (predecessor (shell header)))
                            (fun pred =>
                              Worker.protect w None
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_base__TzPervasives.protect None
                                        canceler
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (Tezos_shell.Block_validator_process.apply_block
                                                (validation_process bv) pred
                                                header operations)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | inl x =>
                                                  Tezos_base__TzPervasives._return
                                                    x
                                                |
                                                  inr
                                                    (cons
                                                      (Missing_test_protocol
                                                        protocol) _) =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    (Tezos_shell.Protocol_validator.fetch_and_compile_protocol
                                                      (protocol_validator bv)
                                                      peer
                                                      (Some
                                                        (protocol_timeout
                                                          (limits bv))) protocol)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | _ =>
                                                        Tezos_shell.Block_validator_process.apply_block
                                                          (validation_process bv)
                                                          pred header operations
                                                      end)
                                                | (inr _) as x => Lwt._return x
                                                end)
                                          end))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | {|
                                          validation_store := validation_store;
                                            block_metadata := block_metadata;
                                            ops_metadata := ops_metadata;
                                            forking_testchain :=
                                              forking_testchain
                                            |} =>
                                          let validation_store :=
                                            {|
                                              context_hash :=
                                                context_hash validation_store;
                                              message :=
                                                message validation_store;
                                              max_operations_ttl :=
                                                max_operations_ttl
                                                  validation_store;
                                              last_allowed_fork_level :=
                                                last_allowed_fork_level
                                                  validation_store |} in
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            (Tezos_shell.Distributed_db.commit_block
                                              chain_db hash header
                                              block_metadata operations
                                              ops_metadata validation_store
                                              forking_testchain)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | None => false
                                              | Some block =>
                                                Tezos_base__TzPervasives._return
                                                  block
                                              end)
                                        end)
                                  end)))
                          (fun function_parameter =>
                            match function_parameter with
                            | inl block =>
                              Tezos_shell.Protocol_validator.prefetch_and_compile_protocols
                                (protocol_validator bv) peer
                                (Some (protocol_timeout (limits bv))) block;
                              notify_new_block block;
                              Tezos_base__TzPervasives._return
                                (inl (Some block))
                            | (inr err) as error =>
                              if
                                Tezos_base__TzPervasives.List._exists
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Invalid_block _ => true
                                    | _ => false
                                    end) err then
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Worker.protect w None
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_shell.Distributed_db.commit_invalid_block
                                          chain_db hash header err
                                      end))
                                  (fun commited =>
                                    commited;
                                    Tezos_base__TzPervasives._return error)
                              else
                                debug w
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Error during " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          " block validation: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))))
                                    "Error during %a block validation: %a" %
                                      string)
                                  Tezos_base__TzPervasives.Block_hash.pp_short
                                  hash
                                  Tezos_base__TzPervasives.Error_monad.pp_print_error
                                  err;
                                Tezos_base__TzPervasives._return error
                            end)
                    end)
              end)
        end)
  end.

Definition on_launch {A B : Type} (function_parameter : A)
  : B ->
    (limits * bool * Tezos_shell.Distributed_db.t *
      Tezos_shell.Block_validator_process.t) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult Types.state) :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | (limits, start_testchain, db, validation_process) =>
            let protocol_validator := Tezos_shell.Protocol_validator.create db
              in
            Tezos_base__TzPervasives._return
              {| Types.protocol_validator := protocol_validator;
                Types.validation_process := validation_process;
                Types.limits := limits; Types.start_testchain := start_testchain
                |}
          end
      end
  end.

Definition on_error {A B : Type}
  (w : Worker.t A)
  (r : Tezos_shell_services__Block_validator_worker_state.Request.view)
  (st : Tezos_shell_services.Worker_types.request_status)
  (errs : list Tezos_base__TzPervasives.error)
  : Lwt.t (Result.result B (list Tezos_base__TzPervasives.error)) :=
  Worker.record_event w (Validation_failure r st errs);
  Lwt.return_error errs.

Definition on_completion {a : Type} (w : t) (function_parameter : Request.t a)
  : a -> Tezos_shell_services.Worker_types.request_status -> Lwt.t unit :=
  match function_parameter with
  | (Request.Request_validation _) as r =>
    fun v =>
      fun st =>
        match v with
        | inl (Some _) =>
          Worker.record_event w (Event.Validation_success (Request.view r) st);
          Lwt.return_unit
        | inl None => Lwt.return_unit
        | inr errs =>
          Worker.record_event w
            (Event.Validation_failure (Request.view r) st errs);
          Lwt.return_unit
        end
  end.

Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
  let bv := Worker.state w in
  Tezos_shell.Block_validator_process.close (validation_process bv).

Definition table : Worker.table (Worker.queue Worker.infinite) :=
  Worker.create_table Queue.

Definition create
  (limits : limits) (db : Tezos_shell.Distributed_db.t)
  (validation_process : Tezos_shell.Block_validator_process.t)
  (start_testchain : bool)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
  let Handlers :=
    existT _ unit
      {|
        
        |} in
  Worker.launch table None (worker_limits limits) tt
    (limits, start_testchain, db, validation_process) Handlers.

Definition shutdown {A : Type} : (Worker.t A) -> Lwt.t unit := Worker.shutdown.

Definition validate {A : Type}
  (w : Worker.t (Worker.queue A))
  (canceler : option Tezos_base__TzPervasives.Lwt_canceler.t)
  (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
  (op_star_o_p_t_star : option (Tezos_shell.State.Block.t -> unit))
  : Tezos_shell.Distributed_db.chain_db ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Tezos_base__TzPervasives.Block_header.t ->
        (list (list Tezos_base__TzPervasives.Operation.t)) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_shell.State.Block.t)) :=
  let notify_new_block :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => tt
        end
    end in
  fun chain_db =>
    fun hash =>
      fun header =>
        fun operations =>
          let bv := Worker.state w in
          let chain_state := Tezos_shell.Distributed_db.chain_state chain_db in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.read_opt chain_state hash)
            (fun function_parameter =>
              match function_parameter with
              | Some block =>
                debug w
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "previously validated block " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " (before pipe)" % string
                          CamlinternalFormatBasics.End_of_format)))
                    "previously validated block %a (before pipe)" % string)
                  Tezos_base__TzPervasives.Block_hash.pp_short hash;
                Tezos_shell.Protocol_validator.prefetch_and_compile_protocols
                  (protocol_validator bv) peer
                  (Some (protocol_timeout (limits bv))) block;
                Tezos_base__TzPervasives.return_none
              | None =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_base__TzPervasives.map_p
                    (Tezos_base__TzPervasives.map_p
                      (fun op =>
                        let op_hash :=
                          Tezos_base__TzPervasives.Operation.hash op in
                        Tezos_base__TzPervasives._return op_hash)) operations)
                  (fun hashes =>
                    let computed_hash :=
                      Tezos_base__TzPervasives.Operation_list_list_hash.compute
                        (Tezos_base__TzPervasives.List.map
                          Tezos_base__TzPervasives.Operation_list_hash.compute
                          hashes) in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_base__TzPervasives.fail_when
                        (nequiv_decb
                          (Tezos_base__TzPervasives.Operation_list_list_hash.compare
                            computed_hash (operations_hash (shell header))) 0)
                        (Inconsistent_operations_hash
                          {| block := hash;
                            expected := operations_hash (shell header);
                            found := computed_hash |}))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (check_chain_liveness chain_db hash header)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Worker.Queue.push_request_and_wait w
                                    (Request_validation
                                      {| chain_db := chain_db;
                                        notify_new_block := notify_new_block;
                                        canceler := canceler; peer := peer;
                                        hash := hash; header := header;
                                        operations := operations |}))
                                  (fun result => Lwt._return result)
                              end)
                        end))
              end).

Definition fetch_and_compile_protocol {A : Type} (w : Worker.t A)
  : (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    (option Ptime.Span.t) ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_updater.Registered_protocol.t) :=
  let bv := Worker.state w in
  Tezos_shell.Protocol_validator.fetch_and_compile_protocol
    (protocol_validator bv).

Definition status {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
  Worker.status.

Definition running_worker (function_parameter : unit)
  : Worker.t (Worker.queue Worker.infinite) :=
  match function_parameter with
  | tt =>
    match Worker.list table with
    | cons (_, single) [] => single
    | [] => Stdlib.raise OCaml.Not_found
    | cons _ (cons _ _) => false
    end
  end.

Definition pending_requests {A : Type} (t : Worker.t (Worker.queue A))
  : list (Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
  Worker.Queue.pending_requests t.

Definition current_request {A : Type} (t : Worker.t A)
  : option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
  Worker.current_request t.

Definition last_events {A : Type}
  : (Worker.t A) ->
    list (Tezos_base__TzPervasives.Internal_event.level * (list Worker.Event.t)) :=
  Worker.last_events.
src/lib_shell/block_validator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type limits = {
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

val create :
  limits ->
  Distributed_db.t ->
  Block_validator_process.t ->
  start_testchain:bool ->
  t tzresult Lwt.t

val validate :
  t ->
  ?canceler:Lwt_canceler.t ->
  ?peer:P2p_peer.Id.t ->
  ?notify_new_block:(State.Block.t -> unit) ->
  Distributed_db.chain_db ->
  Block_hash.t ->
  Block_header.t ->
  Operation.t list list ->
  State.Block.t option tzresult Lwt.t

val fetch_and_compile_protocol :
  t ->
  ?peer:P2p_peer.Id.t ->
  ?timeout:Time.System.Span.t ->
  Protocol_hash.t ->
  Registered_protocol.t tzresult Lwt.t

val shutdown : t -> unit Lwt.t

val running_worker : unit -> t

val status : t -> Worker_types.worker_status

val pending_requests :
  t -> (Time.System.t * Block_validator_worker_state.Request.view) list

val current_request :
  t ->
  (Time.System.t * Time.System.t * Block_validator_worker_state.Request.view)
  option

val last_events :
  t -> (Internal_event.level * Block_validator_worker_state.Event.t list) list
src/lib_shell/block_validator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Record limits := {
  protocol_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Parameter create :
limits ->
  Tezos_shell.Distributed_db.t ->
    Tezos_shell.Block_validator_process.t ->
      bool -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter validate :
t ->
  (option Tezos_base__TzPervasives.Lwt_canceler.t) ->
    (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
      (option (Tezos_shell.State.Block.t -> unit)) ->
        Tezos_shell.Distributed_db.chain_db ->
          Tezos_base__TzPervasives.Block_hash.t ->
            Tezos_base__TzPervasives.Block_header.t ->
              (list (list Tezos_base__TzPervasives.Operation.t)) ->
                Lwt.t
                  (Tezos_base__TzPervasives.tzresult
                    (option Tezos_shell.State.Block.t)).

Parameter fetch_and_compile_protocol :
t ->
  (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    (option Tezos_base__TzPervasives.Time.System.Span.t) ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_updater.Registered_protocol.t).

Parameter shutdown : t -> Lwt.t unit.

Parameter running_worker : unit -> t.

Parameter status : t -> Tezos_shell_services.Worker_types.worker_status.

Parameter pending_requests :
t ->
  list
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Block_validator_worker_state.Request.view).

Parameter current_request :
t ->
  option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Block_validator_worker_state.Request.view).

Parameter last_events :
t ->
  list
    (Tezos_base__TzPervasives.Internal_event.level *
      (list Tezos_shell_services.Block_validator_worker_state.Event.t)).
src/lib_shell/block_validator_process.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let get_context index hash =
  Context.checkout index hash
  >>= function
  | None ->
      fail (Block_validator_errors.Failed_to_checkout_context hash)
  | Some ctx ->
      return ctx

(** The standard block validation method *)
module Seq_validator = struct
  include Internal_event.Legacy_logging.Make (struct
    let name = "validation_process.sequential"
  end)

  type validation_context = {context_index : Context.index}

  type t = validation_context

  let init context_index =
    lwt_log_notice "Initialized" >>= fun () -> Lwt.return {context_index}

  let close _ = lwt_log_notice "Shutting down..."

  let apply_block validator_process chain_state ~max_operations_ttl
      ~(predecessor_block_header : Block_header.t) ~block_header operations =
    let chain_id = State.Chain.id chain_state in
    get_context
      validator_process.context_index
      predecessor_block_header.shell.context
    >>=? fun predecessor_context ->
    Block_validation.apply
      chain_id
      ~max_operations_ttl
      ~predecessor_block_header
      ~predecessor_context
      ~block_header
      operations
end

(* Block validation using an external processes *)
module External_validator = struct
  include Internal_event.Legacy_logging.Make_semantic (struct
    let name = "shell.validation_process.external"
  end)

  type validation_context = {
    context_root : string;
    protocol_root : string;
    process_path : string;
    mutable validator_process : Lwt_process.process_full option;
    lock : Lwt_mutex.t;
    sandbox_parameters : Data_encoding.json option;
  }

  type t = validation_context

  let init ?sandbox_parameters ~context_root ~protocol_root ~process_path =
    lwt_log_notice (fun f -> f "Initialized")
    >>= fun () ->
    Lwt.return
      {
        context_root;
        protocol_root;
        process_path;
        validator_process = None;
        lock = Lwt_mutex.create ();
        sandbox_parameters;
      }

  let check_process_status =
    let open Unix in
    let int_tag = Tag.def "int" Format.pp_print_int in
    function
    | WEXITED 0 ->
        lwt_log_notice (fun f -> f "The process terminated normally")
    | WEXITED i ->
        lwt_fatal_error
          Tag.DSL.(
            fun f ->
              f "The process terminated abnormally with value %a"
              -% a int_tag i)
    | WSIGNALED i ->
        lwt_fatal_error
          Tag.DSL.(
            fun f -> f "The process was killed by signal %a" -% a int_tag i)
    | WSTOPPED i ->
        lwt_fatal_error
          Tag.DSL.(
            fun f -> f "The process was stopped by signal %a" -% a int_tag i)

  let close vp =
    lwt_log_notice (fun f -> f "Shutting down ...")
    >>= fun () ->
    match vp.validator_process with
    | Some process ->
        External_validation.send
          process#stdin
          External_validation.request_encoding
          External_validation.Terminate
        >>= fun () ->
        process#status
        >>= (function
              | Unix.WEXITED 0 ->
                  Lwt.return_unit
              | _ ->
                  process#terminate ; Lwt.return_unit)
        >>= fun () ->
        vp.validator_process <- None ;
        Lwt.return_unit
    | None ->
        Lwt.return_unit

  let send_request vp request result_encoding =
    let start_process () =
      let process =
        Lwt_process.open_process_full (vp.process_path, [|"tezos-validator"|])
      in
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "Block validation started on pid %a"
            -% a (Tag.def "int" Format.pp_print_int) process#pid)
      >>= fun () ->
      let parameters =
        {
          External_validation.context_root = vp.context_root;
          protocol_root = vp.protocol_root;
          sandbox_parameters = vp.sandbox_parameters;
        }
      in
      vp.validator_process <- Some process ;
      External_validation.send
        process#stdin
        Data_encoding.Variable.bytes
        External_validation.magic
      >>= fun () ->
      External_validation.send
        process#stdin
        External_validation.parameters_encoding
        parameters
      >>= fun () -> Lwt.return process
    in
    ( match vp.validator_process with
    | Some process -> (
      match process#state with
      | Running ->
          Lwt.return process
      | Exited status ->
          vp.validator_process <- None ;
          check_process_status status
          >>= fun () ->
          vp.validator_process <- None ;
          lwt_log_notice (fun f -> f "restarting validation process...")
          >>= fun () -> start_process () )
    | None ->
        start_process () )
    >>= fun process ->
    Lwt.catch
      (fun () ->
        (* Make sure that the promise is not canceled between a send and recv *)
        Lwt.protected
          (Lwt_mutex.with_lock vp.lock (fun () ->
               External_validation.send
                 process#stdin
                 External_validation.request_encoding
                 request
               >>= fun () ->
               External_validation.recv_result process#stdout result_encoding))
        >>=? fun res ->
        match process#state with
        | Running ->
            return res
        | Exited status ->
            vp.validator_process <- None ;
            check_process_status status >>= fun () -> return res)
      (function
        | errors ->
            process#status
            >>= fun status ->
            check_process_status status
            >>= fun () ->
            vp.validator_process <- None ;
            Lwt.return (error_exn errors))
end

type validator_kind =
  | Internal of Context.index
  | External of {
      context_root : string;
      protocol_root : string;
      process_path : string;
      sandbox_parameters : Data_encoding.json option;
    }

type t = Sequential of Seq_validator.t | External of External_validator.t

let init = function
  | Internal index ->
      Seq_validator.init index >>= fun v -> return (Sequential v)
  | External {context_root; protocol_root; process_path; sandbox_parameters} ->
      External_validator.init
        ?sandbox_parameters
        ~context_root
        ~protocol_root
        ~process_path
      >>= fun v ->
      External_validator.send_request
        v
        External_validation.Init
        Data_encoding.empty
      >>=? fun () -> return (External v)

let close = function
  | Sequential vp ->
      Seq_validator.close vp
  | External vp ->
      External_validator.close vp

let apply_block bvp ~predecessor block_header operations =
  let chain_state = State.Block.chain_state predecessor in
  let predecessor_block_header = State.Block.header predecessor in
  State.Block.max_operations_ttl predecessor
  >>=? fun max_operations_ttl ->
  let block_hash = Block_header.hash block_header in
  Chain.data chain_state
  >>= (fun chain_data ->
        if State.Block.equal chain_data.current_head predecessor then
          return (chain_data.live_blocks, chain_data.live_operations)
        else Chain_traversal.live_blocks predecessor max_operations_ttl)
  >>=? fun (live_blocks, live_operations) ->
  Block_validation.check_liveness
    ~live_operations
    ~live_blocks
    block_hash
    operations
  >>=? fun () ->
  match bvp with
  | Sequential vp ->
      Seq_validator.apply_block
        vp
        ~max_operations_ttl
        chain_state
        ~predecessor_block_header
        ~block_header
        operations
  | External vp ->
      let chain_id = State.Chain.id chain_state in
      let request =
        External_validation.Validate
          {
            chain_id;
            block_header;
            predecessor_block_header;
            operations;
            max_operations_ttl;
          }
      in
      External_validator.send_request
        vp
        request
        Block_validation.result_encoding

let commit_genesis bvp ~genesis_hash ~chain_id ~time ~protocol =
  match bvp with
  | Sequential {context_index} ->
      Context.commit_genesis context_index ~chain_id ~time ~protocol
      >>= fun res -> return res
  | External vp ->
      let request =
        External_validation.Commit_genesis
          {genesis_hash; chain_id; time; protocol}
      in
      External_validator.send_request vp request Context_hash.encoding

let init_test_chain bvp forking_block =
  let forked_header = State.Block.header forking_block in
  match bvp with
  | Sequential _ ->
      State.Block.context forking_block
      >>=? fun context ->
      Block_validation.init_test_chain context forked_header
  | External vp ->
      let context_hash = forked_header.shell.context in
      let request =
        External_validation.Fork_test_chain {context_hash; forked_header}
      in
      External_validator.send_request vp request Block_header.encoding
src/lib_shell/block_validator_process.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition get_context
  (index : Tezos_storage.Context.index)
  (hash : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_storage.Context.checkout index hash)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_base__TzPervasives.fail
          (Block_validator_errors.Failed_to_checkout_context hash)
      | Some ctx => Tezos_base__TzPervasives._return ctx
      end).

Module Seq_validator.
  Record validation_context := {
    context_index : Tezos_storage.Context.index }.
  
  Definition t := validation_context.
  
  Definition init (context_index : Tezos_storage.Context.index)
    : Lwt.t validation_context :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Initialized" % string
            CamlinternalFormatBasics.End_of_format) "Initialized" % string))
      (fun function_parameter =>
        match function_parameter with
        | tt => Lwt._return {| context_index := context_index |}
        end).
  
  Definition close {A : Type} (function_parameter : A) : Lwt.t unit :=
    match function_parameter with
    | _ =>
      lwt_log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Shutting down..." % string
            CamlinternalFormatBasics.End_of_format) "Shutting down..." % string)
    end.
  
  Definition apply_block
    (validator_process : validation_context)
    (chain_state : Tezos_shell.State.Chain.chain_state) (max_operations_ttl : Z)
    (predecessor_block_header : Tezos_base__TzPervasives.Block_header.t)
    (block_header : Tezos_base__TzPervasives.Block_header.t)
    (operations : list (list Tezos_base__TzPervasives.Operation.t))
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_validation.Block_validation.result) :=
    let chain_id := Tezos_shell.State.Chain.id chain_state in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (get_context (context_index validator_process)
        (context (shell predecessor_block_header)))
      (fun predecessor_context =>
        Tezos_validation.Block_validation.apply chain_id max_operations_ttl
          predecessor_block_header predecessor_context block_header operations).
End Seq_validator.

Module External_validator.
  Record validation_context := {
    context_root : string;
    protocol_root : string;
    process_path : string;
    validator_process : option Lwt_process.process_full;
    lock : Lwt_mutex.t;
    sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json }.
  
  Definition t := validation_context.
  
  Definition init
    (sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json)
    (context_root : string) (protocol_root : string) (process_path : string)
    : Lwt.t validation_context :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_log_notice
        (fun f =>
          f
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Initialized" % string
                CamlinternalFormatBasics.End_of_format) "Initialized" % string)))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Lwt._return
            {| context_root := context_root; protocol_root := protocol_root;
              process_path := process_path; validator_process := None;
              lock := Lwt_mutex.create tt;
              sandbox_parameters := sandbox_parameters |}
        end).
  
  Definition check_process_status : Unix.process_status -> Lwt.t unit :=
    let int_tag := Tag.def None "int" % string Stdlib.Format.pp_print_int in
    fun function_parameter =>
      match function_parameter with
      | WEXITED 0 =>
        lwt_log_notice
          (fun f =>
            f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "The process terminated normally" % string
                  CamlinternalFormatBasics.End_of_format)
                "The process terminated normally" % string))
      | WEXITED i =>
        lwt_fatal_error
          (fun f =>
            Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The process terminated abnormally with value " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "The process terminated abnormally with value %a" % string))
              (Tag.DSL.a int_tag i))
      | WSIGNALED i =>
        lwt_fatal_error
          (fun f =>
            Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The process was killed by signal " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "The process was killed by signal %a" % string))
              (Tag.DSL.a int_tag i))
      | WSTOPPED i =>
        lwt_fatal_error
          (fun f =>
            Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The process was stopped by signal " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "The process was stopped by signal %a" % string))
              (Tag.DSL.a int_tag i))
      end.
  
  Definition close (vp : validation_context) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_log_notice
        (fun f =>
          f
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Shutting down ..." % string
                CamlinternalFormatBasics.End_of_format)
              "Shutting down ..." % string)))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          match validator_process vp with
          | Some process =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_validation.External_validation.send send
                Tezos_validation.External_validation.request_encoding
                External_validation.Terminate)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_base__TzPervasives.op_gt_gt_eq send
                      (fun function_parameter =>
                        match function_parameter with
                        | Unix.WEXITED 0 => Lwt.return_unit
                        | _ =>
                          send;
                          Lwt.return_unit
                        end))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        set_field;
                        Lwt.return_unit
                      end)
                end)
          | None => Lwt.return_unit
          end
        end).
  
  Definition send_request {A : Type}
    (vp : validation_context)
    (request : Tezos_validation.External_validation.request)
    (result_encoding : Tezos_base__TzPervasives.Data_encoding.t A)
    : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
    let start_process (function_parameter : unit)
      : Lwt.t Lwt_process.process_full :=
      match function_parameter with
      | tt =>
        let process :=
          Lwt_process.open_process_full None None
            ((process_path vp), ("tezos-validator" % string)) in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_notice
            (fun f =>
              Tag.DSL.op_minus_percent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Block validation started on pid " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))
                    "Block validation started on pid %a" % string))
                (Tag.DSL.a
                  (Tag.def None "int" % string Stdlib.Format.pp_print_int) send)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let parameters :=
                {| External_validation.context_root := context_root vp;
                  External_validation.protocol_root := protocol_root vp;
                  External_validation.sandbox_parameters :=
                    sandbox_parameters vp |} in
              set_field;
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_validation.External_validation.send send
                  Tezos_base__TzPervasives.Data_encoding.Variable.bytes
                  Tezos_validation.External_validation.magic)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_validation.External_validation.send send
                        Tezos_validation.External_validation.parameters_encoding
                        parameters)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Lwt._return process
                        end)
                  end)
            end)
      end in
    Tezos_base__TzPervasives.op_gt_gt_eq
      match validator_process vp with
      | Some process =>
        match send with
        | Running => Lwt._return process
        | Exited status =>
          set_field;
          Tezos_base__TzPervasives.op_gt_gt_eq (check_process_status status)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                set_field;
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_notice
                    (fun f =>
                      f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "restarting validation process..." % string
                            CamlinternalFormatBasics.End_of_format)
                          "restarting validation process..." % string)))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => start_process tt
                    end)
              end)
        end
      | None => start_process tt
      end
      (fun process =>
        Lwt.catch
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Lwt.protected
                  (Lwt_mutex.with_lock (lock vp)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_validation.External_validation.send send
                            Tezos_validation.External_validation.request_encoding
                            request)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_validation.External_validation.recv_result
                                send result_encoding
                            end)
                      end)))
                (fun res =>
                  match send with
                  | Running => Tezos_base__TzPervasives._return res
                  | Exited status =>
                    set_field;
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (check_process_status status)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_base__TzPervasives._return res
                        end)
                  end)
            end)
          (fun errors =>
            Tezos_base__TzPervasives.op_gt_gt_eq send
              (fun status =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (check_process_status status)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      set_field;
                      Lwt._return (Tezos_base__TzPervasives.error_exn errors)
                    end)))).
End External_validator.

Inductive validator_kind : Type :=
| Internal : Tezos_storage.Context.index -> validator_kind
| External : string -> string -> string ->
  (option Tezos_base__TzPervasives.Data_encoding.json) -> validator_kind.

Inductive t : Type :=
| Sequential : Seq_validator.t -> t
| External : External_validator.t -> t.

Definition init (function_parameter : validator_kind)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  match function_parameter with
  | Internal index =>
    Tezos_base__TzPervasives.op_gt_gt_eq (Seq_validator.init index)
      (fun v => Tezos_base__TzPervasives._return (Sequential v))
  |
    External {|
      context_root := context_root;
        protocol_root := protocol_root;
        process_path := process_path;
        sandbox_parameters := sandbox_parameters
        |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (External_validator.init sandbox_parameters context_root protocol_root
        process_path)
      (fun v =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (External_validator.send_request v External_validation.Init
            Tezos_base__TzPervasives.Data_encoding.empty)
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives._return (External v)
            end))
  end.

Definition close (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | Sequential vp => Seq_validator.close vp
  | External vp => External_validator.close vp
  end.

Definition apply_block
  (bvp : t) (predecessor : Tezos_shell.State.Block.t)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_validation.Block_validation.result) :=
  let chain_state := Tezos_shell.State.Block.chain_state predecessor in
  let predecessor_block_header := Tezos_shell.State.Block.header predecessor in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.Block.max_operations_ttl predecessor)
    (fun max_operations_ttl =>
      let block_hash := Tezos_base__TzPervasives.Block_header.hash block_header
        in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Chain.data chain_state)
          (fun chain_data =>
            if
              Tezos_shell.State.Block.equal (current_head chain_data)
                predecessor then
              Tezos_base__TzPervasives._return
                ((live_blocks chain_data), (live_operations chain_data))
            else
              Tezos_shell.Chain_traversal.live_blocks predecessor
                max_operations_ttl))
        (fun function_parameter =>
          match function_parameter with
          | (live_blocks, live_operations) =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_validation.Block_validation.check_liveness live_blocks
                live_operations block_hash operations)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  match bvp with
                  | Sequential vp =>
                    Seq_validator.apply_block vp chain_state max_operations_ttl
                      predecessor_block_header block_header operations
                  | External vp =>
                    let chain_id := Tezos_shell.State.Chain.id chain_state in
                    let request :=
                      External_validation.Validate
                        {| chain_id := chain_id; block_header := block_header;
                          predecessor_block_header := predecessor_block_header;
                          operations := operations;
                          max_operations_ttl := max_operations_ttl |} in
                    External_validator.send_request vp request
                      Tezos_validation.Block_validation.result_encoding
                  end
                end)
          end)).

Definition commit_genesis
  (bvp : t) (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
  (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (time : Tezos_base__TzPervasives.Time.Protocol.t)
  (protocol : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Context_hash.t) :=
  match bvp with
  | Sequential {| context_index := context_index |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_storage.Context.commit_genesis context_index chain_id time protocol)
      (fun res => Tezos_base__TzPervasives._return res)
  | External vp =>
    let request :=
      External_validation.Commit_genesis
        {| chain_id := chain_id; genesis_hash := genesis_hash; time := time;
          protocol := protocol |} in
    External_validator.send_request vp request
      Tezos_base__TzPervasives.Context_hash.encoding
  end.

Definition init_test_chain (bvp : t) (forking_block : Tezos_shell.State.Block.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
  let forked_header := Tezos_shell.State.Block.header forking_block in
  match bvp with
  | Sequential _ =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_shell.State.Block.context forking_block)
      (fun context =>
        Tezos_validation.Block_validation.init_test_chain context forked_header)
  | External vp =>
    let context_hash := context (shell forked_header) in
    let request :=
      External_validation.Fork_test_chain
        {| context_hash := context_hash; forked_header := forked_header |} in
    External_validator.send_request vp request
      Tezos_base__TzPervasives.Block_header.encoding
  end.
src/lib_shell/block_validator_process.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type validator_kind =
  | Internal of Context.index
  | External of {
      context_root : string;
      protocol_root : string;
      process_path : string;
      sandbox_parameters : Data_encoding.json option;
    }

type t

val init : validator_kind -> t tzresult Lwt.t

val close : t -> unit Lwt.t

val apply_block :
  t ->
  predecessor:State.Block.t ->
  Block_header.t ->
  Operation.t list list ->
  Block_validation.result tzresult Lwt.t

val commit_genesis :
  t ->
  genesis_hash:Block_hash.t ->
  chain_id:Chain_id.t ->
  time:Time.Protocol.t ->
  protocol:Protocol_hash.t ->
  Context_hash.t tzresult Lwt.t

(** [init_test_chain] must only be called on a forking block. *)
val init_test_chain : t -> State.Block.t -> Block_header.t tzresult Lwt.t
src/lib_shell/block_validator_process.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive validator_kind : Type :=
| Internal : Tezos_storage.Context.index -> validator_kind
| External : string -> string -> string ->
  (option Tezos_base__TzPervasives.Data_encoding.json) -> validator_kind.

Parameter t : Type.

Parameter init : validator_kind -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter close : t -> Lwt.t unit.

Parameter apply_block :
t ->
  Tezos_shell.State.Block.t ->
    Tezos_base__TzPervasives.Block_header.t ->
      (list (list Tezos_base__TzPervasives.Operation.t)) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_validation.Block_validation.result).

Parameter commit_genesis :
t ->
  Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Chain_id.t ->
      Tezos_base__TzPervasives.Time.Protocol.t ->
        Tezos_base__TzPervasives.Protocol_hash.t ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_base__TzPervasives.Context_hash.t).

Parameter init_test_chain :
t ->
  Tezos_shell.State.Block.t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t).
src/lib_shell/bootstrap_pipeline.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.validator.bootstrap_pipeline"
end)

let node_time_tag =
  Tag.def ~doc:"local time at this node" "node_time" Time.System.pp_hum

let block_time_tag =
  Tag.def
    ~doc:"claimed creation time of block"
    "block_time"
    (fun fmt prot_time -> Time.System.(pp_hum fmt (of_protocol_exn prot_time)))

open Validation_errors

type t = {
  canceler : Lwt_canceler.t;
  block_header_timeout : Time.System.Span.t;
  block_operations_timeout : Time.System.Span.t;
  mutable headers_fetch_worker : unit Lwt.t;
  mutable operations_fetch_worker : unit Lwt.t;
  mutable validation_worker : unit Lwt.t;
  peer_id : P2p_peer.Id.t;
  chain_db : Distributed_db.chain_db;
  locator : Block_locator.t;
  block_validator : Block_validator.t;
  notify_new_block : State.Block.t -> unit;
  fetched_headers : (Block_hash.t * Block_header.t) list Lwt_pipe.t;
  fetched_blocks :
    (Block_hash.t * Block_header.t * Operation.t list list tzresult Lwt.t)
    Lwt_pipe.t;
  (* HACK, a worker should be able to return the 'error'. *)
  mutable errors : Error_monad.error list;
}

let operations_index_tag =
  Tag.def ~doc:"Operations index" "operations_index" Format.pp_print_int

let assert_acceptable_header pipeline hash (header : Block_header.t) =
  let chain_state = Distributed_db.chain_state pipeline.chain_db in
  let time_now = Systime_os.now () in
  fail_unless
    ( Time.Protocol.compare
        (Time.Protocol.add (Time.System.to_protocol (Systime_os.now ())) 15L)
        header.shell.timestamp
    >= 0 )
    (Future_block_header
       {block = hash; time = time_now; block_time = header.shell.timestamp})
  >>=? fun () ->
  State.Chain.checkpoint chain_state
  >>= fun checkpoint ->
  fail_when
    ( Int32.equal header.shell.level checkpoint.shell.level
    && not (Block_header.equal checkpoint header) )
    (Checkpoint_error (hash, Some pipeline.peer_id))
  >>=? fun () ->
  Chain.head chain_state
  >>= fun head ->
  let checkpoint_reached =
    (State.Block.header head).shell.level >= checkpoint.shell.level
  in
  if checkpoint_reached then
    (* If reached the checkpoint, every block before the checkpoint
       must be part of the chain. *)
    if header.shell.level <= checkpoint.shell.level then
      Chain.mem chain_state hash
      >>= fun in_chain ->
      fail_unless in_chain (Checkpoint_error (hash, Some pipeline.peer_id))
    else return_unit
  else return_unit

let fetch_step pipeline (step : Block_locator.step) =
  ( if step.step > 2000 then
    lwt_log_notice
      Tag.DSL.(
        fun f ->
          f
            "fetching a large bootstrap step (%a headers) from peer %a, this \
             may take a while."
          -% t event "fetching_large_step_from_peer"
          -% a (Tag.def ~doc:"" "length" Format.pp_print_int) step.step
          -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
  else
    lwt_log_info
      Tag.DSL.(
        fun f ->
          f "fetching step %a -> %a (%a) from peer %a."
          -% t event "fetching_step_from_peer"
          -% a Block_hash.Logging.tag step.block
          -% a Block_hash.Logging.predecessor_tag step.predecessor
          -% a (Tag.def ~doc:"" "" Block_locator.pp_step) step
          -% a P2p_peer.Id.Logging.tag pipeline.peer_id) )
  >>= fun () ->
  let rec fetch_loop acc hash cpt =
    Lwt_unix.yield ()
    >>= fun () ->
    ( if step.step > 2000 && step.step <> cpt && (step.step - cpt) mod 1000 = 0
    then
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "fetched %a/%a headers from peer %a, and continuing."
            -% t event "still_fetching_large_step_from_peer"
            -% a
                 (Tag.def ~doc:"" "fetched" Format.pp_print_int)
                 (step.step - cpt)
            -% a (Tag.def ~doc:"" "length" Format.pp_print_int) step.step
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
    else Lwt.return_unit )
    >>= fun () ->
    if cpt < 0 then
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "invalid step from peer %a (too long)."
            -% t event "step_too_long"
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
      >>= fun () -> fail (Invalid_locator (pipeline.peer_id, pipeline.locator))
    else if Block_hash.equal hash step.predecessor then
      if step.strict_step && cpt <> 0 then
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "invalid step from peer %a (too short)."
              -% t event "step_too_short"
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () ->
        fail (Invalid_locator (pipeline.peer_id, pipeline.locator))
      else return acc
    else
      let chain_state = Distributed_db.chain_state pipeline.chain_db in
      Chain.mem chain_state hash
      >>= fun in_chain ->
      if in_chain then return acc
      else
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "fetching block header %a from peer %a."
              -% t event "fetching_block_header_from_peer"
              -% a Block_hash.Logging.tag hash
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () ->
        protect ~canceler:pipeline.canceler (fun () ->
            Distributed_db.Block_header.fetch
              ~timeout:pipeline.block_header_timeout
              pipeline.chain_db
              ~peer:pipeline.peer_id
              hash
              ())
        >>=? fun header ->
        assert_acceptable_header pipeline hash header
        >>=? fun () ->
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "fetched block header %a from peer %a."
              -% t event "fetched_block_header_from_peer"
              -% a Block_hash.Logging.tag hash
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () ->
        fetch_loop ((hash, header) :: acc) header.shell.predecessor (cpt - 1)
  in
  fetch_loop [] step.block step.step

let headers_fetch_worker_loop pipeline =
  (let sender_id = Distributed_db.my_peer_id pipeline.chain_db in
   (* sender and receiver are inverted here because they are from
       the point of view of the node sending the locator *)
   let seed =
     {Block_locator.sender_id = pipeline.peer_id; receiver_id = sender_id}
   in
   let chain_state = Distributed_db.chain_state pipeline.chain_db in
   let state = State.Chain.global_state chain_state in
   State.history_mode state
   >>= fun history_mode ->
   ( match history_mode with
   | History_mode.Archive ->
       Lwt.return_none
   | Full | Rolling ->
       let chain_state = Distributed_db.chain_state pipeline.chain_db in
       State.Chain.save_point chain_state >>= Lwt.return_some )
   >>= fun save_point ->
   (* In Full and Rolling mode, we do not want to receive blocks
         that are past our save point's level, otherwise we would
         start validating them again. *)
   let steps =
     match save_point with
     | None ->
         Block_locator.to_steps seed pipeline.locator
     | Some (save_point_level, save_point) ->
         let (head, _) = (pipeline.locator : Block_locator.t :> _ * _) in
         let head_level = head.shell.level in
         let truncate_limit = Int32.(sub head_level save_point_level) in
         Block_locator.to_steps_truncate
           ~limit:(Int32.to_int truncate_limit)
           ~save_point
           seed
           pipeline.locator
   in
   match steps with
   | [] ->
       fail (Too_short_locator (sender_id, pipeline.locator))
   | {Block_locator.predecessor; _} :: _ ->
       State.Block.known chain_state predecessor
       >>= fun predecessor_known ->
       (* Check that the locator is anchored in a block locally known *)
       fail_unless
         predecessor_known
         (Too_short_locator (sender_id, pipeline.locator))
       >>=? fun () ->
       let rec process_headers headers =
         let (batch, remaining_headers) = List.split_n 20 headers in
         protect ~canceler:pipeline.canceler (fun () ->
             Lwt_pipe.push pipeline.fetched_headers batch
             >>= fun () -> return_unit)
         >>=? fun () ->
         match remaining_headers with
         | [] ->
             return_unit
         | _ ->
             process_headers remaining_headers
       in
       let rec pipe ?pred = function
         | [] ->
             return_unit
         | first :: (second :: _ as rest) ->
             let fetch =
               match pred with
               | None ->
                   fetch_step pipeline first
               | Some fetch ->
                   fetch
             in
             let pred = fetch_step pipeline second in
             fetch
             >>=? fun headers ->
             process_headers headers >>=? fun () -> pipe ~pred rest
         | [last] ->
             let fetch =
               match pred with
               | None ->
                   fetch_step pipeline last
               | Some fetch ->
                   fetch
             in
             fetch >>=? process_headers
       in
       pipe steps)
  >>= function
  | Ok () ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "fetched all steps from peer %a."
            -% t event "fetched_all_steps_from_peer"
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
      >>= fun () ->
      Lwt_pipe.close pipeline.fetched_headers ;
      Lwt.return_unit
  | Error (Exn Lwt.Canceled :: _)
  | Error (Canceled :: _)
  | Error (Exn Lwt_pipe.Closed :: _) ->
      Lwt.return_unit
  | Error (Distributed_db.Block_header.Timeout bh :: _) ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "request for header %a from peer %a timed out."
            -% t event "header_request_timeout"
            -% a Block_hash.Logging.tag bh
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler
  | Error (Future_block_header {block; block_time; time} :: _) ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f
              "Block locator %a from peer %a contains future blocks. local \
               time: %a, block time: %a"
            -% t event "locator_contains_future_blocks"
            -% a Block_hash.Logging.tag block
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id
            -% a node_time_tag time
            -% a block_time_tag block_time)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler
  | Error (Too_short_locator _ :: _ as err) ->
      pipeline.errors <- pipeline.errors @ err ;
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "Too short locator received" -% t event "too_short_locator")
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler
  | Error err ->
      pipeline.errors <- pipeline.errors @ err ;
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "@[Unexpected error (headers fetch):@ %a@]"
            -% t event "unexpected_error" -% a errs_tag err)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler

let rec operations_fetch_worker_loop pipeline =
  Lwt_unix.yield ()
  >>= (fun () ->
        protect ~canceler:pipeline.canceler (fun () ->
            Lwt_pipe.pop pipeline.fetched_headers >>= return)
        >>=? fun batch ->
        map_p
          (fun (hash, header) ->
            lwt_log_info
              Tag.DSL.(
                fun f ->
                  f "fetching operations of block %a from peer %a."
                  -% t event "fetching_operations"
                  -% a Block_hash.Logging.tag hash
                  -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
            >>= fun () ->
            let operations =
              map_p
                (fun i ->
                  protect ~canceler:pipeline.canceler (fun () ->
                      Distributed_db.Operations.fetch
                        ~timeout:pipeline.block_operations_timeout
                        pipeline.chain_db
                        ~peer:pipeline.peer_id
                        (hash, i)
                        header.Block_header.shell.operations_hash
                      >>= fun res -> Lwt.return res))
                (0 -- (header.shell.validation_passes - 1))
              >>=? fun operations ->
              lwt_log_info
                Tag.DSL.(
                  fun f ->
                    f "fetched operations of block %a from peer %a."
                    -% t event "fetched_operations"
                    -% a Block_hash.Logging.tag hash
                    -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
              >>= fun () -> return operations
            in
            return (hash, header, operations))
          batch
        >>=? fun operationss ->
        iter_s
          (fun (hash, header, operations) ->
            protect ~canceler:pipeline.canceler (fun () ->
                Lwt_pipe.push pipeline.fetched_blocks (hash, header, operations)
                >>= fun () -> return_unit))
          operationss)
  >>= function
  | Ok () ->
      operations_fetch_worker_loop pipeline
  | Error (Exn Lwt.Canceled :: _)
  | Error (Canceled :: _)
  | Error (Exn Lwt_pipe.Closed :: _) ->
      Lwt_pipe.close pipeline.fetched_blocks ;
      Lwt.return_unit
  | Error (Distributed_db.Operations.Timeout (bh, n) :: _) ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "request for operations %a:%d from peer %a timed out."
            -% t event "request_operations_timeout"
            -% a Block_hash.Logging.tag bh
            -% s operations_index_tag n
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler
  | Error err ->
      pipeline.errors <- pipeline.errors @ err ;
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "@[Unexpected error (operations fetch):@ %a@]"
            -% t event "unexpected_error" -% a errs_tag err)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler

let rec validation_worker_loop pipeline =
  Lwt_unix.yield ()
  >>= (fun () ->
        protect ~canceler:pipeline.canceler (fun () ->
            Lwt_pipe.pop pipeline.fetched_blocks >>= return)
        >>=? fun (hash, header, operations) ->
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "requesting validation for block %a from peer %a."
              -% t event "requesting_validation"
              -% a Block_hash.Logging.tag hash
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () ->
        operations
        >>=? fun operations ->
        protect ~canceler:pipeline.canceler (fun () ->
            Block_validator.validate
              ~canceler:pipeline.canceler
              ~notify_new_block:pipeline.notify_new_block
              pipeline.block_validator
              pipeline.chain_db
              hash
              header
              operations)
        >>=? fun _block ->
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "validated block %a from peer %a."
              -% t event "validated_block"
              -% a Block_hash.Logging.tag hash
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () -> return_unit)
  >>= function
  | Ok () ->
      validation_worker_loop pipeline
  | Error ((Exn Lwt.Canceled | Canceled | Exn Lwt_pipe.Closed) :: _) ->
      Lwt.return_unit
  | Error
      ( ( Block_validator_errors.Invalid_block _
        | Block_validator_errors.Unavailable_protocol _
        | Block_validator_errors.System_error _
        | Timeout )
        :: _ as err ) ->
      (* Propagate the error to the peer validator. *)
      pipeline.errors <- pipeline.errors @ err ;
      Lwt_canceler.cancel pipeline.canceler
  | Error err ->
      pipeline.errors <- pipeline.errors @ err ;
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "@[Unexpected error (validator):@ %a@]"
            -% t event "unexpected_error" -% a errs_tag err)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler

let create ?(notify_new_block = fun _ -> ()) ~block_header_timeout
    ~block_operations_timeout block_validator peer_id chain_db locator =
  let canceler = Lwt_canceler.create () in
  let fetched_headers = Lwt_pipe.create ~size:(1024, fun _ -> 1) () in
  let fetched_blocks = Lwt_pipe.create ~size:(128, fun _ -> 1) () in
  let pipeline =
    {
      canceler;
      block_header_timeout;
      block_operations_timeout;
      headers_fetch_worker = Lwt.return_unit;
      operations_fetch_worker = Lwt.return_unit;
      validation_worker = Lwt.return_unit;
      notify_new_block;
      peer_id;
      chain_db;
      locator;
      block_validator;
      fetched_headers;
      fetched_blocks;
      errors = [];
    }
  in
  Lwt_canceler.on_cancel pipeline.canceler (fun () ->
      Lwt_pipe.close fetched_blocks ;
      Lwt_pipe.close fetched_headers ;
      (* TODO proper cleanup of ressources... *)
      Lwt.return_unit) ;
  let (head, _) = (pipeline.locator : Block_locator.t :> _ * _) in
  let hash = Block_header.hash head in
  pipeline.headers_fetch_worker <-
    Lwt_utils.worker
      (Format.asprintf
         "bootstrap_pipeline-headers_fetch.%a.%a"
         P2p_peer.Id.pp_short
         peer_id
         Block_hash.pp_short
         hash)
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> headers_fetch_worker_loop pipeline)
      ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
  pipeline.operations_fetch_worker <-
    Lwt_utils.worker
      (Format.asprintf
         "bootstrap_pipeline-operations_fetch.%a.%a"
         P2p_peer.Id.pp_short
         peer_id
         Block_hash.pp_short
         hash)
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> operations_fetch_worker_loop pipeline)
      ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
  pipeline.validation_worker <-
    Lwt_utils.worker
      (Format.asprintf
         "bootstrap_pipeline-validation.%a.%a"
         P2p_peer.Id.pp_short
         peer_id
         Block_hash.pp_short
         hash)
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> validation_worker_loop pipeline)
      ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
  pipeline

let wait_workers pipeline =
  pipeline.headers_fetch_worker
  >>= fun () ->
  pipeline.operations_fetch_worker >>= fun () -> pipeline.validation_worker

let wait pipeline =
  wait_workers pipeline
  >>= fun () ->
  match pipeline.errors with
  | [] ->
      return_unit
  | errors ->
      Lwt.return_error errors

let cancel pipeline =
  Lwt_canceler.cancel pipeline.canceler >>= fun () -> wait_workers pipeline

let length pipeline =
  Peer_validator_worker_state.Worker_state.
    {
      fetched_header_length = Lwt_pipe.length pipeline.fetched_headers;
      fetched_block_length = Lwt_pipe.length pipeline.fetched_blocks;
    }

let length_zero =
  Peer_validator_worker_state.Worker_state.
    {fetched_header_length = 0; fetched_block_length = 0}
src/lib_shell/bootstrap_pipeline.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition node_time_tag : Tag.def Tezos_base__TzPervasives.Time.System.t :=
  Tag.def (Some "local time at this node" % string) "node_time" % string
    Tezos_base__TzPervasives.Time.System.pp_hum.

Definition block_time_tag : Tag.def Tezos_base__Time.Protocol.t :=
  Tag.def (Some "claimed creation time of block" % string) "block_time" % string
    (fun fmt =>
      fun prot_time =>
        Tezos_base__TzPervasives.Time.System.pp_hum fmt
          (Tezos_base__TzPervasives.Time.System.of_protocol_exn prot_time)).

Import Tezos_shell_services.Validation_errors.

Record t := {
  canceler : Tezos_base__TzPervasives.Lwt_canceler.t;
  block_header_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  block_operations_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  headers_fetch_worker : Lwt.t unit;
  operations_fetch_worker : Lwt.t unit;
  validation_worker : Lwt.t unit;
  peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
  chain_db : Tezos_shell.Distributed_db.chain_db;
  locator : Tezos_base__TzPervasives.Block_locator.t;
  block_validator : Tezos_shell.Block_validator.t;
  notify_new_block : Tezos_shell.State.Block.t -> unit;
  fetched_headers :
    Tezos_base__TzPervasives.Lwt_pipe.t
      (list
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t));
  fetched_blocks :
    Tezos_base__TzPervasives.Lwt_pipe.t
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t *
        (Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list (list Tezos_base__TzPervasives.Operation.t)))));
  errors : list Tezos_base__TzPervasives.Error_monad.error }.

Definition operations_index_tag : Tag.def Z :=
  Tag.def (Some "Operations index" % string) "operations_index" % string
    Stdlib.Format.pp_print_int.

Definition assert_acceptable_header
  (pipeline : t) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let chain_state := Tezos_shell.Distributed_db.chain_state (chain_db pipeline)
    in
  let time_now := Tezos_stdlib_unix.Systime_os.now tt in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.fail_unless
      (OCaml.Stdlib.ge
        (Tezos_base__TzPervasives.Time.Protocol.compare
          (Tezos_base__TzPervasives.Time.Protocol.add
            (Tezos_base__TzPervasives.Time.System.to_protocol
              (Tezos_stdlib_unix.Systime_os.now tt)) 15)
          (timestamp (shell header))) 0)
      (Future_block_header
        {| block := hash; block_time := timestamp (shell header);
          time := time_now |}))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.checkpoint chain_state)
          (fun checkpoint =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.fail_when
                (andb
                  (Stdlib.Int32.equal (level (shell header))
                    (level (shell checkpoint)))
                  (negb
                    (Tezos_base__TzPervasives.Block_header.equal checkpoint
                      header)))
                (Checkpoint_error hash (Some (peer_id pipeline))))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.Chain.head chain_state)
                    (fun head =>
                      let checkpoint_reached :=
                        OCaml.Stdlib.ge
                          (level (shell (Tezos_shell.State.Block.header head)))
                          (level (shell checkpoint)) in
                      if checkpoint_reached then
                        if
                          OCaml.Stdlib.le (level (shell header))
                            (level (shell checkpoint)) then
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_shell.Chain.mem chain_state hash)
                            (fun in_chain =>
                              Tezos_base__TzPervasives.fail_unless in_chain
                                (Checkpoint_error hash (Some (peer_id pipeline))))
                        else
                          Tezos_base__TzPervasives.return_unit
                      else
                        Tezos_base__TzPervasives.return_unit)
                end))
      end).

Definition fetch_step
  (pipeline : t) (step : Tezos_base__TzPervasives.Block_locator.step)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (if OCaml.Stdlib.gt (step step) 2000 then
      lwt_log_notice
        (fun f =>
          Tag.DSL.op_minus_percent
            (Tag.DSL.op_minus_percent
              (Tag.DSL.op_minus_percent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "fetching a large bootstrap step (" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " headers) from peer " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              ", this may take a while." % string
                              CamlinternalFormatBasics.End_of_format)))))
                    "fetching a large bootstrap step (%a headers) from peer %a, this may take a while."
                      % string))
                (Tag.DSL.t event "fetching_large_step_from_peer" % string))
              (Tag.DSL.a
                (Tag.def (Some "" % string) "length" % string
                  Stdlib.Format.pp_print_int) (step step)))
            (Tag.DSL.a Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
              (peer_id pipeline)))
    else
      lwt_log_info
        (fun f =>
          Tag.DSL.op_minus_percent
            (Tag.DSL.op_minus_percent
              (Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "fetching step " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " -> " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " (" % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      ") from peer " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "." % char
                                          CamlinternalFormatBasics.End_of_format)))))))))
                        "fetching step %a -> %a (%a) from peer %a." % string))
                    (Tag.DSL.t event "fetching_step_from_peer" % string))
                  (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                    (block step)))
                (Tag.DSL.a
                  Tezos_base__TzPervasives.Block_hash.Logging.predecessor_tag
                  (predecessor step)))
              (Tag.DSL.a
                (Tag.def (Some "" % string) "" % string
                  Tezos_base__TzPervasives.Block_locator.pp_step) step))
            (Tag.DSL.a Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
              (peer_id pipeline))))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let fix fetch_loop
          (acc :
          list
            (Tezos_base__TzPervasives.Block_hash.t *
              Tezos_base__TzPervasives.Block_header.t)) (hash :
          Tezos_base__TzPervasives.Block_hash.t) (cpt : Z)
          : Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (list
                (Tezos_base__TzPervasives.Block_hash.t *
                  Tezos_base__TzPervasives.Block_header.t))) :=
          Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (if
                    andb (OCaml.Stdlib.gt (step step) 2000)
                      (andb (nequiv_decb (step step) cpt)
                        (equiv_decb (Z.modulo (Z.sub (step step) cpt) 1000) 0))
                    then
                    lwt_log_notice
                      (fun f =>
                        Tag.DSL.op_minus_percent
                          (Tag.DSL.op_minus_percent
                            (Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "fetched " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "/" % char
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " headers from peer " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  ", and continuing." % string
                                                  CamlinternalFormatBasics.End_of_format)))))))
                                    "fetched %a/%a headers from peer %a, and continuing."
                                      % string))
                                (Tag.DSL.t event
                                  "still_fetching_large_step_from_peer" % string))
                              (Tag.DSL.a
                                (Tag.def (Some "" % string) "fetched" % string
                                  Stdlib.Format.pp_print_int)
                                (Z.sub (step step) cpt)))
                            (Tag.DSL.a
                              (Tag.def (Some "" % string) "length" % string
                                Stdlib.Format.pp_print_int) (step step)))
                          (Tag.DSL.a
                            Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                            (peer_id pipeline)))
                  else
                    Lwt.return_unit)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      if OCaml.Stdlib.lt cpt 0 then
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (lwt_log_info
                            (fun f =>
                              Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "invalid step from peer " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            " (too long)." % string
                                            CamlinternalFormatBasics.End_of_format)))
                                      "invalid step from peer %a (too long)." %
                                        string))
                                  (Tag.DSL.t event "step_too_long" % string))
                                (Tag.DSL.a
                                  Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                  (peer_id pipeline))))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.fail
                                (Invalid_locator (peer_id pipeline)
                                  (locator pipeline))
                            end)
                      else
                        if
                          Tezos_base__TzPervasives.Block_hash.equal hash
                            (predecessor step) then
                          if andb (strict_step step) (nequiv_decb cpt 0) then
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (lwt_log_info
                                (fun f =>
                                  Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "invalid step from peer " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                " (too short)." % string
                                                CamlinternalFormatBasics.End_of_format)))
                                          "invalid step from peer %a (too short)."
                                            % string))
                                      (Tag.DSL.t event "step_too_short" % string))
                                    (Tag.DSL.a
                                      Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                      (peer_id pipeline))))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.fail
                                    (Invalid_locator (peer_id pipeline)
                                      (locator pipeline))
                                end)
                          else
                            Tezos_base__TzPervasives._return acc
                        else
                          let chain_state :=
                            Tezos_shell.Distributed_db.chain_state
                              (chain_db pipeline) in
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_shell.Chain.mem chain_state hash)
                            (fun in_chain =>
                              if in_chain then
                                Tezos_base__TzPervasives._return acc
                              else
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (lwt_log_info
                                    (fun f =>
                                      Tag.DSL.op_minus_percent
                                        (Tag.DSL.op_minus_percent
                                          (Tag.DSL.op_minus_percent
                                            (f
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "fetching block header " %
                                                    string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.String_literal
                                                      " from peer " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Char_literal
                                                          "." % char
                                                          CamlinternalFormatBasics.End_of_format)))))
                                                "fetching block header %a from peer %a."
                                                  % string))
                                            (Tag.DSL.t event
                                              "fetching_block_header_from_peer"
                                                % string))
                                          (Tag.DSL.a
                                            Tezos_base__TzPervasives.Block_hash.Logging.tag
                                            hash))
                                        (Tag.DSL.a
                                          Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                          (peer_id pipeline))))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_base__TzPervasives.protect None
                                          (Some (canceler pipeline))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_shell.Distributed_db.Block_header.fetch
                                                (chain_db pipeline)
                                                (Some (peer_id pipeline))
                                                (Some
                                                  (block_header_timeout pipeline))
                                                hash tt
                                            end))
                                        (fun header =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            (assert_acceptable_header pipeline
                                              hash header)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                  (lwt_log_info
                                                    (fun f =>
                                                      Tag.DSL.op_minus_percent
                                                        (Tag.DSL.op_minus_percent
                                                          (Tag.DSL.op_minus_percent
                                                            (f
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "fetched block header "
                                                                    % string
                                                                  (CamlinternalFormatBasics.Alpha
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      " from peer "
                                                                        % string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Char_literal
                                                                          "." %
                                                                            char
                                                                          CamlinternalFormatBasics.End_of_format)))))
                                                                "fetched block header %a from peer %a."
                                                                  % string))
                                                            (Tag.DSL.t event
                                                              "fetched_block_header_from_peer"
                                                                % string))
                                                          (Tag.DSL.a
                                                            Tezos_base__TzPervasives.Block_hash.Logging.tag
                                                            hash))
                                                        (Tag.DSL.a
                                                          Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                                          (peer_id pipeline))))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      fetch_loop
                                                        (cons (hash, header) acc)
                                                        (predecessor
                                                          (shell header))
                                                        (Z.sub cpt 1)
                                                    end)
                                              end))
                                    end))
                    end)
              end) in
        fetch_loop [] (block step) (step step)
      end).

Definition headers_fetch_worker_loop (pipeline : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (let sender_id := Tezos_shell.Distributed_db.my_peer_id (chain_db pipeline)
      in
    let seed :=
      {| Block_locator.sender_id := peer_id pipeline;
        Block_locator.receiver_id := sender_id |} in
    let chain_state :=
      Tezos_shell.Distributed_db.chain_state (chain_db pipeline) in
    let state := Tezos_shell.State.Chain.global_state chain_state in
    Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.State.history_mode state)
      (fun history_mode =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          match history_mode with
          | History_mode.Archive => Lwt.return_none
          | Full | Rolling =>
            let chain_state :=
              Tezos_shell.Distributed_db.chain_state (chain_db pipeline) in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Chain.save_point chain_state) Lwt.return_some
          end
          (fun save_point =>
            let steps :=
              match save_point with
              | None =>
                Tezos_base__TzPervasives.Block_locator.to_steps seed
                  (locator pipeline)
              | Some (save_point_level, save_point) =>
                match locator pipeline with
                | (head, _) =>
                  let head_level := level (shell head) in
                  let truncate_limit :=
                    Stdlib.Int32.sub head_level save_point_level in
                  Tezos_base__TzPervasives.Block_locator.to_steps_truncate
                    (Stdlib.Int32.to_int truncate_limit) save_point seed
                    (locator pipeline)
                end
              end in
            match steps with
            | [] =>
              Tezos_base__TzPervasives.fail
                (Too_short_locator sender_id (locator pipeline))
            | cons {| Block_locator.predecessor := predecessor |} _ =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.State.Block.known chain_state predecessor)
                (fun predecessor_known =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_base__TzPervasives.fail_unless predecessor_known
                      (Too_short_locator sender_id (locator pipeline)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        let fix process_headers
                          (headers :
                          list
                            (Tezos_base__TzPervasives.Block_hash.t *
                              Tezos_base__TzPervasives.Block_header.t))
                          : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                          match Tezos_base__TzPervasives.List.split_n 20 headers
                            with
                          | (batch, remaining_headers) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_base__TzPervasives.protect None
                                (Some (canceler pipeline))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Tezos_base__TzPervasives.Lwt_pipe.push
                                        (fetched_headers pipeline) batch)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.return_unit
                                        end)
                                  end))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  match remaining_headers with
                                  | [] => Tezos_base__TzPervasives.return_unit
                                  | _ => process_headers remaining_headers
                                  end
                                end)
                          end in
                        let fix pipe
                          (pred :
                          option
                            (Lwt.t
                              (Tezos_base__TzPervasives.tzresult
                                (list
                                  (Tezos_base__TzPervasives.Block_hash.t *
                                    Tezos_base__TzPervasives.Block_header.t)))))
                          (function_parameter :
                          list Tezos_base__TzPervasives.Block_locator.step)
                          : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                          match function_parameter with
                          | [] => Tezos_base__TzPervasives.return_unit
                          | cons first ((cons second _) as rest) =>
                            let fetch :=
                              match pred with
                              | None => fetch_step pipeline first
                              | Some fetch => fetch
                              end in
                            let pred := fetch_step pipeline second in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question fetch
                              (fun headers =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (process_headers headers)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => pipe (Some pred) rest
                                    end))
                          | cons last [] =>
                            let fetch :=
                              match pred with
                              | None => fetch_step pipeline last
                              | Some fetch => fetch
                              end in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question fetch
                              process_headers
                          end in
                        pipe None steps
                      end))
            end)))
    (fun function_parameter =>
      match function_parameter with
      | inl tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_info
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "fetched all steps from peer " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "." % char
                            CamlinternalFormatBasics.End_of_format)))
                      "fetched all steps from peer %a." % string))
                  (Tag.DSL.t event "fetched_all_steps_from_peer" % string))
                (Tag.DSL.a Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                  (peer_id pipeline))))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Lwt_pipe.close (fetched_headers pipeline);
              Lwt.return_unit
            end)
      |
        inr (cons (Exn Lwt.Canceled) _) | inr (cons Canceled _) |
          inr (cons (Exn Lwt_pipe.Closed) _) => Lwt.return_unit
      | inr (cons (Distributed_db.Block_header.Timeout bh) _) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_info
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "request for header " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " from peer " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " timed out." % string
                                  CamlinternalFormatBasics.End_of_format)))))
                        "request for header %a from peer %a timed out." % string))
                    (Tag.DSL.t event "header_request_timeout" % string))
                  (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag bh))
                (Tag.DSL.a Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                  (peer_id pipeline))))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline)
            end)
      |
        inr
          (cons
            (Future_block_header {|
              block := block; block_time := block_time; time := time |}) _)
        =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_notice
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Block locator " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " from peer " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " contains future blocks. local time: " %
                                        string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          ", block time: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))))))))
                            "Block locator %a from peer %a contains future blocks. local time: %a, block time: %a"
                              % string))
                        (Tag.DSL.t event
                          "locator_contains_future_blocks" % string))
                      (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                        block))
                    (Tag.DSL.a Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                      (peer_id pipeline))) (Tag.DSL.a node_time_tag time))
                (Tag.DSL.a block_time_tag block_time)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline)
            end)
      | inr ((cons (Too_short_locator _ _) _) as err) =>
        set_field;
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_info
            (fun f =>
              Tag.DSL.op_minus_percent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Too short locator received" % string
                      CamlinternalFormatBasics.End_of_format)
                    "Too short locator received" % string))
                (Tag.DSL.t event "too_short_locator" % string)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline)
            end)
      | inr err =>
        set_field;
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_error
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected error (headers fetch):" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Unexpected error (headers fetch):@ %a@]" % string))
                  (Tag.DSL.t event "unexpected_error" % string))
                (Tag.DSL.a Tezos_base__TzPervasives.errs_tag err)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline)
            end)
      end).

Fixpoint operations_fetch_worker_loop (pipeline : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_base__TzPervasives.protect None (Some (canceler pipeline))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_base__TzPervasives.Lwt_pipe.pop
                      (fetched_headers pipeline))
                    Tezos_base__TzPervasives._return
                end))
            (fun batch =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives.map_p
                  (fun function_parameter =>
                    match function_parameter with
                    | (hash, header) =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (lwt_log_info
                          (fun f =>
                            Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "fetching operations of block " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            " from peer " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                "." % char
                                                CamlinternalFormatBasics.End_of_format)))))
                                      "fetching operations of block %a from peer %a."
                                        % string))
                                  (Tag.DSL.t event
                                    "fetching_operations" % string))
                                (Tag.DSL.a
                                  Tezos_base__TzPervasives.Block_hash.Logging.tag
                                  hash))
                              (Tag.DSL.a
                                Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                (peer_id pipeline))))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            let operations :=
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_base__TzPervasives.map_p
                                  (fun i =>
                                    Tezos_base__TzPervasives.protect None
                                      (Some (canceler pipeline))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Tezos_shell.Distributed_db.Operations.fetch
                                              (chain_db pipeline)
                                              (Some (peer_id pipeline))
                                              (Some
                                                (block_operations_timeout
                                                  pipeline)) (hash, i)
                                              (operations_hash
                                                (Block_header.shell header)))
                                            (fun res => Lwt._return res)
                                        end))
                                  (Tezos_base__TzPervasives.op_minus_minus 0
                                    (Z.sub (validation_passes (shell header)) 1)))
                                (fun operations =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (lwt_log_info
                                      (fun f =>
                                        Tag.DSL.op_minus_percent
                                          (Tag.DSL.op_minus_percent
                                            (Tag.DSL.op_minus_percent
                                              (f
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "fetched operations of block "
                                                      % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        " from peer " % string
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.Char_literal
                                                            "." % char
                                                            CamlinternalFormatBasics.End_of_format)))))
                                                  "fetched operations of block %a from peer %a."
                                                    % string))
                                              (Tag.DSL.t event
                                                "fetched_operations" % string))
                                            (Tag.DSL.a
                                              Tezos_base__TzPervasives.Block_hash.Logging.tag
                                              hash))
                                          (Tag.DSL.a
                                            Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                            (peer_id pipeline))))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives._return
                                          operations
                                      end)) in
                            Tezos_base__TzPervasives._return
                              (hash, header, operations)
                          end)
                    end) batch)
                (fun operationss =>
                  Tezos_base__TzPervasives.iter_s
                    (fun function_parameter =>
                      match function_parameter with
                      | (hash, header, operations) =>
                        Tezos_base__TzPervasives.protect None
                          (Some (canceler pipeline))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_base__TzPervasives.Lwt_pipe.push
                                  (fetched_blocks pipeline)
                                  (hash, header, operations))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                            end)
                      end) operationss))
        end))
    (fun function_parameter =>
      match function_parameter with
      | inl tt => operations_fetch_worker_loop pipeline
      |
        inr (cons (Exn Lwt.Canceled) _) | inr (cons Canceled _) |
          inr (cons (Exn Lwt_pipe.Closed) _) =>
        Tezos_base__TzPervasives.Lwt_pipe.close (fetched_blocks pipeline);
        Lwt.return_unit
      | inr (cons (Distributed_db.Operations.Timeout (bh, n)) _) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_info
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "request for operations " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal ":" % char
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " from peer " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " timed out." % string
                                        CamlinternalFormatBasics.End_of_format)))))))
                          "request for operations %a:%d from peer %a timed out."
                            % string))
                      (Tag.DSL.t event "request_operations_timeout" % string))
                    (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                      bh)) (Tag.DSL.s operations_index_tag n))
                (Tag.DSL.a Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                  (peer_id pipeline))))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline)
            end)
      | inr err =>
        set_field;
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_error
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected error (operations fetch):" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Unexpected error (operations fetch):@ %a@]" % string))
                  (Tag.DSL.t event "unexpected_error" % string))
                (Tag.DSL.a Tezos_base__TzPervasives.errs_tag err)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline)
            end)
      end).

Fixpoint validation_worker_loop (pipeline : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.yield tt)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_base__TzPervasives.protect None (Some (canceler pipeline))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_base__TzPervasives.Lwt_pipe.pop
                      (fetched_blocks pipeline))
                    Tezos_base__TzPervasives._return
                end))
            (fun function_parameter =>
              match function_parameter with
              | (hash, header, operations) =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_info
                    (fun f =>
                      Tag.DSL.op_minus_percent
                        (Tag.DSL.op_minus_percent
                          (Tag.DSL.op_minus_percent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "requesting validation for block " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " from peer " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "." % char
                                          CamlinternalFormatBasics.End_of_format)))))
                                "requesting validation for block %a from peer %a."
                                  % string))
                            (Tag.DSL.t event "requesting_validation" % string))
                          (Tag.DSL.a
                            Tezos_base__TzPervasives.Block_hash.Logging.tag hash))
                        (Tag.DSL.a
                          Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                          (peer_id pipeline))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question operations
                        (fun operations =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_base__TzPervasives.protect None
                              (Some (canceler pipeline))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_shell.Block_validator.validate
                                    (block_validator pipeline)
                                    (Some (canceler pipeline)) None
                                    (Some (notify_new_block pipeline))
                                    (chain_db pipeline) hash header operations
                                end))
                            (fun _block =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (lwt_log_info
                                  (fun f =>
                                    Tag.DSL.op_minus_percent
                                      (Tag.DSL.op_minus_percent
                                        (Tag.DSL.op_minus_percent
                                          (f
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "validated block " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.String_literal
                                                    " from peer " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Char_literal
                                                        "." % char
                                                        CamlinternalFormatBasics.End_of_format)))))
                                              "validated block %a from peer %a."
                                                % string))
                                          (Tag.DSL.t event
                                            "validated_block" % string))
                                        (Tag.DSL.a
                                          Tezos_base__TzPervasives.Block_hash.Logging.tag
                                          hash))
                                      (Tag.DSL.a
                                        Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                        (peer_id pipeline))))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)))
                    end)
              end)
        end))
    (fun function_parameter =>
      match function_parameter with
      | inl tt => validation_worker_loop pipeline
      | inr (cons (Exn Lwt.Canceled | Canceled | Exn Lwt_pipe.Closed) _) =>
        Lwt.return_unit
      |
        inr
          ((cons
            (Block_validator_errors.Invalid_block _ |
              Block_validator_errors.Unavailable_protocol _ |
              Block_validator_errors.System_error _ | Timeout) _) as err) =>
        set_field;
        Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline)
      | inr err =>
        set_field;
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_error
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected error (validator):" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Unexpected error (validator):@ %a@]" % string))
                  (Tag.DSL.t event "unexpected_error" % string))
                (Tag.DSL.a Tezos_base__TzPervasives.errs_tag err)))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline)
            end)
      end).

Definition create
  (op_star_o_p_t_star : option (Tezos_shell.State.Block.t -> unit))
  : Tezos_base__TzPervasives.Time.System.Span.t ->
    Tezos_base__TzPervasives.Time.System.Span.t ->
      Tezos_shell.Block_validator.t ->
        Tezos_base__TzPervasives.P2p_peer.Id.t ->
          Tezos_shell.Distributed_db.chain_db ->
            Tezos_base__TzPervasives.Block_locator.t -> t :=
  let notify_new_block :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => tt
        end
    end in
  fun block_header_timeout =>
    fun block_operations_timeout =>
      fun block_validator =>
        fun peer_id =>
          fun chain_db =>
            fun locator =>
              let canceler := Tezos_base__TzPervasives.Lwt_canceler.create tt in
              let fetched_headers :=
                Tezos_base__TzPervasives.Lwt_pipe.create
                  (Some
                    (1024,
                      (fun function_parameter =>
                        match function_parameter with
                        | _ => 1
                        end))) tt in
              let fetched_blocks :=
                Tezos_base__TzPervasives.Lwt_pipe.create
                  (Some
                    (128,
                      (fun function_parameter =>
                        match function_parameter with
                        | _ => 1
                        end))) tt in
              let pipeline :=
                {| canceler := canceler;
                  block_header_timeout := block_header_timeout;
                  block_operations_timeout := block_operations_timeout;
                  headers_fetch_worker := Lwt.return_unit;
                  operations_fetch_worker := Lwt.return_unit;
                  validation_worker := Lwt.return_unit; peer_id := peer_id;
                  chain_db := chain_db; locator := locator;
                  block_validator := block_validator;
                  notify_new_block := notify_new_block;
                  fetched_headers := fetched_headers;
                  fetched_blocks := fetched_blocks; errors := [] |} in
              Tezos_base__TzPervasives.Lwt_canceler.on_cancel
                (canceler pipeline)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.Lwt_pipe.close fetched_blocks;
                    Tezos_base__TzPervasives.Lwt_pipe.close fetched_headers;
                    Lwt.return_unit
                  end);
              match locator pipeline with
              | (head, _) =>
                let hash := Tezos_base__TzPervasives.Block_header.hash head in
                set_field;
                set_field;
                set_field;
                pipeline
              end.

Definition wait_workers (pipeline : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq (headers_fetch_worker pipeline)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq (operations_fetch_worker pipeline)
          (fun function_parameter =>
            match function_parameter with
            | tt => validation_worker pipeline
            end)
      end).

Definition wait (pipeline : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (wait_workers pipeline)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        match errors pipeline with
        | [] => Tezos_base__TzPervasives.return_unit
        | errors => Lwt.return_error errors
        end
      end).

Definition cancel (pipeline : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler pipeline))
    (fun function_parameter =>
      match function_parameter with
      | tt => wait_workers pipeline
      end).

Definition length (pipeline : t)
  : Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
  {|
    fetched_header_length :=
      Tezos_base__TzPervasives.Lwt_pipe.length (fetched_headers pipeline);
    fetched_block_length :=
      Tezos_base__TzPervasives.Lwt_pipe.length (fetched_blocks pipeline) |}.

Definition length_zero
  : Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
  {| fetched_header_length := 0; fetched_block_length := 0 |}.
src/lib_shell/bootstrap_pipeline.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

val create :
  ?notify_new_block:(State.Block.t -> unit) ->
  block_header_timeout:Time.System.Span.t ->
  block_operations_timeout:Time.System.Span.t ->
  Block_validator.t ->
  P2p_peer.Id.t ->
  Distributed_db.chain_db ->
  Block_locator.t ->
  t

val wait : t -> unit tzresult Lwt.t

val cancel : t -> unit Lwt.t

val length : t -> Peer_validator_worker_state.Worker_state.pipeline_length

val length_zero : Peer_validator_worker_state.Worker_state.pipeline_length
src/lib_shell/bootstrap_pipeline.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create :
(option (Tezos_shell.State.Block.t -> unit)) ->
  Tezos_base__TzPervasives.Time.System.Span.t ->
    Tezos_base__TzPervasives.Time.System.Span.t ->
      Tezos_shell.Block_validator.t ->
        Tezos_base__TzPervasives.P2p_peer.Id.t ->
          Tezos_shell.Distributed_db.chain_db ->
            Tezos_base__TzPervasives.Block_locator.t -> t.

Parameter wait : t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter cancel : t -> Lwt.t unit.

Parameter length :
t ->
  Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length.

Parameter length_zero :
Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length.
src/lib_shell/chain.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open State_logging

let genesis chain_state =
  let genesis = State.Chain.genesis chain_state in
  State.Block.read_opt chain_state genesis.block
  >|= Option.unopt_assert ~loc:__POS__

let known_heads chain_state =
  State.read_chain_data chain_state (fun chain_store _data ->
      Store.Chain_data.Known_heads.elements chain_store)
  >>= fun hashes ->
  Lwt_list.map_p
    (fun h ->
      State.Block.read_opt chain_state h >|= Option.unopt_assert ~loc:__POS__)
    hashes

let head chain_state =
  State.read_chain_data chain_state (fun _chain_store data ->
      Lwt.return data.current_head)

let mem chain_state hash =
  State.read_chain_data chain_state (fun chain_store data ->
      if Block_hash.equal (State.Block.hash data.current_head) hash then
        Lwt.return_true
      else Store.Chain_data.In_main_branch.known (chain_store, hash))

type data = State.chain_data = {
  current_head : State.Block.t;
  current_mempool : Mempool.t;
  live_blocks : Block_hash.Set.t;
  live_operations : Operation_hash.Set.t;
  test_chain : Chain_id.t option;
  save_point : Int32.t * Block_hash.t;
  caboose : Int32.t * Block_hash.t;
}

let data chain_state =
  State.read_chain_data chain_state (fun _chain_store data -> Lwt.return data)

let locator chain_state seed =
  data chain_state
  >>= fun data -> State.compute_locator chain_state data.current_head seed

let locked_set_head chain_store data block live_blocks live_operations =
  let rec pop_blocks ancestor block =
    let hash = State.Block.hash block in
    if Block_hash.equal hash ancestor then Lwt.return_unit
    else
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "pop_block %a" -% t event "pop_block"
            -% a Block_hash.Logging.tag hash)
      >>= fun () ->
      Store.Chain_data.In_main_branch.remove (chain_store, hash)
      >>= fun () ->
      State.Block.predecessor block
      >>= function
      | Some predecessor ->
          pop_blocks ancestor predecessor
      | None ->
          assert false
    (* Cannot pop the genesis... *)
  in
  let push_block pred_hash block =
    let hash = State.Block.hash block in
    lwt_debug
      Tag.DSL.(
        fun f ->
          f "push_block %a" -% t event "push_block"
          -% a Block_hash.Logging.tag hash)
    >>= fun () ->
    Store.Chain_data.In_main_branch.store (chain_store, pred_hash) hash
    >>= fun () -> Lwt.return hash
  in
  Chain_traversal.new_blocks ~from_block:data.current_head ~to_block:block
  >>= fun (ancestor, path) ->
  let ancestor = State.Block.hash ancestor in
  pop_blocks ancestor data.current_head
  >>= fun () ->
  Lwt_list.fold_left_s push_block ancestor path
  >>= fun _ ->
  Store.Chain_data.Current_head.store chain_store (State.Block.hash block)
  >>= fun () ->
  (* TODO more optimized updated of live_{blocks/operations} when the
     new head is a direct successor of the current head...
     Make sure to do the live blocks computation in `init_head`
     when this TODO is resolved. *)
  Lwt.return
    {
      data with
      current_head = block;
      current_mempool = Mempool.empty;
      live_blocks;
      live_operations;
    }

let set_head chain_state block =
  State.Block.max_operations_ttl block
  >>=? fun max_op_ttl ->
  Chain_traversal.live_blocks block max_op_ttl
  >>=? fun (live_blocks, live_operations) ->
  State.update_chain_data chain_state (fun chain_store data ->
      locked_set_head chain_store data block live_blocks live_operations
      >>= fun new_chain_data ->
      Lwt.return (Some new_chain_data, data.current_head))
  >>= fun chain_state -> return chain_state

let test_and_set_head chain_state ~old block =
  State.Block.max_operations_ttl block
  >>=? fun max_op_ttl ->
  Chain_traversal.live_blocks block max_op_ttl
  >>=? fun (live_blocks, live_operations) ->
  State.update_chain_data chain_state (fun chain_store data ->
      if not (State.Block.equal data.current_head old) then
        Lwt.return (None, false)
      else
        locked_set_head chain_store data block live_blocks live_operations
        >>= fun new_chain_data -> Lwt.return (Some new_chain_data, true))
  >>= fun chain_state -> return chain_state

let init_head chain_state =
  head chain_state
  >>= fun block ->
  set_head chain_state block >>=? fun (_ : State.Block.t) -> return_unit
src/lib_shell/chain.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.State_logging.

Definition genesis (chain_state : Tezos_shell.State.Chain.chain_state)
  : Lwt.t Tezos_shell.State.Block.t :=
  let genesis := Tezos_shell.State.Chain.genesis chain_state in
  Tezos_base__TzPervasives.op_gt_pipe_eq
    (Tezos_shell.State.Block.read_opt chain_state (block genesis))
    (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__).

Definition known_heads (chain_state : Tezos_shell.State.Chain.t)
  : Lwt.t (list Tezos_shell.State.Block.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.read_chain_data chain_state
      (fun chain_store =>
        fun _data =>
          Tezos_shell.Store.Chain_data.Known_heads.elements chain_store))
    (fun hashes =>
      Lwt_list.map_p
        (fun h =>
          Tezos_base__TzPervasives.op_gt_pipe_eq
            (Tezos_shell.State.Block.read_opt chain_state h)
            (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
        hashes).

Definition head (chain_state : Tezos_shell.State.Chain.t)
  : Lwt.t Tezos_shell.State.Block.t :=
  Tezos_shell.State.read_chain_data chain_state
    (fun _chain_store => fun data => Lwt._return (current_head data)).

Definition mem
  (chain_state : Tezos_shell.State.Chain.t)
  (hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t bool :=
  Tezos_shell.State.read_chain_data chain_state
    (fun chain_store =>
      fun data =>
        if
          Tezos_base__TzPervasives.Block_hash.equal
            (Tezos_shell.State.Block.hash (current_head data)) hash then
          Lwt.return_true
        else
          Tezos_shell.Store.Chain_data.In_main_branch.known (chain_store, hash)).

Record data := {
  current_head : Tezos_shell.State.Block.t;
  current_mempool : Tezos_base__TzPervasives.Mempool.t;
  live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t;
  live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t;
  test_chain : option Tezos_base__TzPervasives.Chain_id.t;
  save_point : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t;
  caboose : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t }.

Definition data (chain_state : Tezos_shell.State.Chain.t)
  : Lwt.t Tezos_shell.State.chain_data :=
  Tezos_shell.State.read_chain_data chain_state
    (fun _chain_store => fun data => Lwt._return data).

Definition locator
  (chain_state : Tezos_shell.State.Chain.t)
  (seed : Tezos_base__TzPervasives.Block_locator.seed)
  : Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
  Tezos_base__TzPervasives.op_gt_gt_eq (data chain_state)
    (fun data =>
      Tezos_shell.State.compute_locator chain_state None (current_head data)
        seed).

Definition locked_set_head
  (chain_store : Tezos_shell__Store.Chain_data.store) (data : data)
  (block : Tezos_shell.State.Block.t)
  (live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
  (live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
  : Lwt.t data :=
  let fix pop_blocks
    (ancestor : Tezos_base__TzPervasives.Block_hash.t) (block :
    Tezos_shell.State.Block.t) : Lwt.t unit :=
    let hash := Tezos_shell.State.Block.hash block in
    if Tezos_base__TzPervasives.Block_hash.equal hash ancestor then
      Lwt.return_unit
    else
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell_services.State_logging.lwt_debug
          (fun f =>
            Tezos_shell_services.State_logging.Tag.DSL.op_minus_percent
              (Tezos_shell_services.State_logging.Tag.DSL.op_minus_percent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "pop_block " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))
                    "pop_block %a" % string))
                (Tezos_shell_services.State_logging.Tag.DSL.t
                  Tezos_shell_services.State_logging.event "pop_block" % string))
              (Tezos_shell_services.State_logging.Tag.DSL.a
                Tezos_base__TzPervasives.Block_hash.Logging.tag hash)))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.Store.Chain_data.In_main_branch.remove
                (chain_store, hash))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.Block.predecessor block)
                    (fun function_parameter =>
                      match function_parameter with
                      | Some predecessor => pop_blocks ancestor predecessor
                      | None => false
                      end)
                end)
          end) in
  let push_block
    (pred_hash : Tezos_base__TzPervasives.Block_hash.t) (block :
    Tezos_shell.State.Block.t) : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
    let hash := Tezos_shell.State.Block.hash block in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell_services.State_logging.lwt_debug
        (fun f =>
          Tezos_shell_services.State_logging.Tag.DSL.op_minus_percent
            (Tezos_shell_services.State_logging.Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "push_block " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "push_block %a" % string))
              (Tezos_shell_services.State_logging.Tag.DSL.t
                Tezos_shell_services.State_logging.event "push_block" % string))
            (Tezos_shell_services.State_logging.Tag.DSL.a
              Tezos_base__TzPervasives.Block_hash.Logging.tag hash)))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.Store.Chain_data.In_main_branch.store
              (chain_store, pred_hash) hash)
            (fun function_parameter =>
              match function_parameter with
              | tt => Lwt._return hash
              end)
        end) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.Chain_traversal.new_blocks (current_head data) block)
    (fun function_parameter =>
      match function_parameter with
      | (ancestor, path) =>
        let ancestor := Tezos_shell.State.Block.hash ancestor in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (pop_blocks ancestor (current_head data))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Lwt_list.fold_left_s push_block ancestor path)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.Store.Chain_data.Current_head.store
                        chain_store (Tezos_shell.State.Block.hash block))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Lwt._return record
                        end)
                  end)
            end)
      end).

Definition set_head
  (chain_state : Tezos_shell.State.Chain.t) (block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.State.Block.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.Block.max_operations_ttl block)
    (fun max_op_ttl =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.Chain_traversal.live_blocks block max_op_ttl)
        (fun function_parameter =>
          match function_parameter with
          | (live_blocks, live_operations) =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.update_chain_data chain_state
                (fun chain_store =>
                  fun data =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (locked_set_head chain_store data block live_blocks
                        live_operations)
                      (fun new_chain_data =>
                        Lwt._return ((Some new_chain_data), (current_head data)))))
              (fun chain_state => Tezos_base__TzPervasives._return chain_state)
          end)).

Definition test_and_set_head
  (chain_state : Tezos_shell.State.Chain.t) (old : Tezos_shell.State.Block.t)
  (block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.Block.max_operations_ttl block)
    (fun max_op_ttl =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.Chain_traversal.live_blocks block max_op_ttl)
        (fun function_parameter =>
          match function_parameter with
          | (live_blocks, live_operations) =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.update_chain_data chain_state
                (fun chain_store =>
                  fun data =>
                    if
                      negb
                        (Tezos_shell.State.Block.equal (current_head data) old)
                      then
                      Lwt._return (None, false)
                    else
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (locked_set_head chain_store data block live_blocks
                          live_operations)
                        (fun new_chain_data =>
                          Lwt._return ((Some new_chain_data), true))))
              (fun chain_state => Tezos_base__TzPervasives._return chain_state)
          end)).

Definition init_head (chain_state : Tezos_shell.State.Chain.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (head chain_state)
    (fun block =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question (set_head chain_state block)
        (fun function_parameter =>
          match function_parameter with
          | _ => Tezos_base__TzPervasives.return_unit
          end)).
src/lib_shell/chain.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell Module - Manging the current head. *)

(** The genesis block of the chain. On a test chain,
    the test protocol has been promoted as "main" protocol. *)
val genesis : State.Chain.t -> State.Block.t Lwt.t

(** The current head of the chain. *)
val head : State.Chain.t -> State.Block.t Lwt.t

val locator : State.Chain.t -> Block_locator.seed -> Block_locator.t Lwt.t

(** All the available chain data. *)
type data = {
  current_head : State.Block.t;
  current_mempool : Mempool.t;
  live_blocks : Block_hash.Set.t;
  live_operations : Operation_hash.Set.t;
  test_chain : Chain_id.t option;
  save_point : Int32.t * Block_hash.t;
  caboose : Int32.t * Block_hash.t;
}

(** Reading atomically all the chain data. *)
val data : State.Chain.t -> data Lwt.t

(** The current head and all the known (valid) alternate heads. *)
val known_heads : State.Chain.t -> State.Block.t list Lwt.t

(** Test whether a block belongs to the current mainchain. *)
val mem : State.Chain.t -> Block_hash.t -> bool Lwt.t

(** Record a block as the current head of the chain.
    It returns the previous head. *)
val set_head : State.Chain.t -> State.Block.t -> State.Block.t tzresult Lwt.t

(** Atomically change the current head of the chain.
    This returns [true] whenever the change succeeded, or [false]
    when the current head is not equal to the [old] argument. *)
val test_and_set_head :
  State.Chain.t -> old:State.Block.t -> State.Block.t -> bool tzresult Lwt.t

(** Restores the data about the current head at startup
    (recomputes the sets of live blocks and operations). *)
val init_head : State.Chain.t -> unit tzresult Lwt.t
src/lib_shell/chain.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter genesis :
Tezos_shell.State.Chain.t -> Lwt.t Tezos_shell.State.Block.t.

Parameter head : Tezos_shell.State.Chain.t -> Lwt.t Tezos_shell.State.Block.t.

Parameter locator :
Tezos_shell.State.Chain.t ->
  Tezos_base__TzPervasives.Block_locator.seed ->
    Lwt.t Tezos_base__TzPervasives.Block_locator.t.

Record data := {
  current_head : Tezos_shell.State.Block.t;
  current_mempool : Tezos_base__TzPervasives.Mempool.t;
  live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t;
  live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t;
  test_chain : option Tezos_base__TzPervasives.Chain_id.t;
  save_point : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t;
  caboose : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t }.

Parameter data : Tezos_shell.State.Chain.t -> Lwt.t data.

Parameter known_heads :
Tezos_shell.State.Chain.t -> Lwt.t (list Tezos_shell.State.Block.t).

Parameter mem :
Tezos_shell.State.Chain.t -> Tezos_base__TzPervasives.Block_hash.t -> Lwt.t bool.

Parameter set_head :
Tezos_shell.State.Chain.t ->
  Tezos_shell.State.Block.t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.State.Block.t).

Parameter test_and_set_head :
Tezos_shell.State.Chain.t ->
  Tezos_shell.State.Block.t ->
    Tezos_shell.State.Block.t -> Lwt.t (Tezos_base__TzPervasives.tzresult bool).

Parameter init_head :
Tezos_shell.State.Chain.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/lib_shell/chain_directory.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Chain_services

let get_chain_id state = function
  | `Main ->
      Lwt.return (State.Chain.main state)
  | `Test -> (
      State.Chain.get_exn state (State.Chain.main state)
      >>= fun main_chain ->
      State.Chain.test main_chain
      >>= function
      | None -> Lwt.fail Not_found | Some chain_id -> Lwt.return chain_id )
  | `Hash chain_id ->
      Lwt.return chain_id

let get_chain_id_opt state chain =
  Lwt.catch
    (fun () -> get_chain_id state chain >>= Lwt.return_some)
    (fun _exn -> Lwt.return_none)

let get_chain state chain =
  get_chain_id state chain
  >>= fun chain_id -> State.Chain.get_exn state chain_id

let get_checkpoint state (chain : Chain_services.chain) =
  get_chain state chain
  >>= fun chain ->
  State.Chain.checkpoint chain
  >>= fun header -> Lwt.return (Block_header.hash header)

let predecessors ignored length head =
  let rec loop acc length block =
    if length <= 0 then Lwt.return (List.rev acc)
    else
      State.Block.predecessor block
      >>= function
      | None ->
          Lwt.return (List.rev acc)
      | Some pred ->
          if Block_hash.Set.mem (State.Block.hash block) ignored then
            Lwt.return (List.rev acc)
          else loop (State.Block.hash pred :: acc) (length - 1) pred
  in
  loop [State.Block.hash head] (length - 1) head

let list_blocks chain_state ?(length = 1) ?min_date heads =
  ( match heads with
  | [] ->
      Chain.known_heads chain_state
      >>= fun heads ->
      let heads =
        match min_date with
        | None ->
            heads
        | Some min_date ->
            List.fold_left
              (fun acc block ->
                let timestamp = State.Block.timestamp block in
                if Time.Protocol.(min_date <= timestamp) then block :: acc
                else acc)
              []
              heads
      in
      let sorted_heads =
        List.sort
          (fun b1 b2 ->
            let f1 = State.Block.fitness b1 in
            let f2 = State.Block.fitness b2 in
            ~-(Fitness.compare f1 f2))
          heads
      in
      Lwt.return (List.map (fun b -> Some b) sorted_heads)
  | _ :: _ as heads ->
      Lwt_list.map_p (State.Block.read_opt chain_state) heads )
  >>= fun requested_heads ->
  Lwt_list.fold_left_s
    (fun (ignored, acc) head ->
      match head with
      | None ->
          Lwt.return (ignored, [])
      | Some block ->
          predecessors ignored length block
          >>= fun predecessors ->
          let ignored =
            List.fold_left
              (fun acc v -> Block_hash.Set.add v acc)
              ignored
              predecessors
          in
          Lwt.return (ignored, predecessors :: acc))
    (Block_hash.Set.empty, [])
    requested_heads
  >>= fun (_, blocks) -> return (List.rev blocks)

let rpc_directory =
  let dir : State.Chain.t RPC_directory.t ref = ref RPC_directory.empty in
  let register0 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst0 s) (fun chain p q ->
          f chain p q)
  in
  let register1 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst1 s) (fun (chain, a) p q ->
          f chain a p q)
  in
  let register_dynamic_directory2 ?descr s f =
    dir :=
      RPC_directory.register_dynamic_directory
        !dir
        ?descr
        (RPC_path.subst1 s)
        (fun (chain, a) -> f chain a)
  in
  register0 S.chain_id (fun chain () () -> return (State.Chain.id chain)) ;
  register0 S.checkpoint (fun chain () () ->
      State.Chain.checkpoint chain
      >>= fun checkpoint ->
      State.Chain.save_point chain
      >>= fun (save_point, _) ->
      State.Chain.caboose chain
      >>= fun (caboose, _) ->
      State.history_mode (State.Chain.global_state chain)
      >>= fun history_mode ->
      return (checkpoint, save_point, caboose, history_mode)) ;
  (* blocks *)
  register0 S.Blocks.list (fun chain q () ->
      list_blocks chain ?length:q#length ?min_date:q#min_date q#heads) ;
  register_dynamic_directory2
    Block_services.path
    Block_directory.build_rpc_directory ;
  (* invalid_blocks *)
  register0 S.Invalid_blocks.list (fun chain () () ->
      let convert (hash, level, errors) = {hash; level; errors} in
      State.Block.list_invalid chain
      >>= fun blocks -> return (List.map convert blocks)) ;
  register1 S.Invalid_blocks.get (fun chain hash () () ->
      State.Block.read_invalid chain hash
      >>= function
      | None ->
          Lwt.fail Not_found
      | Some {level; errors} ->
          return {hash; level; errors}) ;
  register1 S.Invalid_blocks.delete (fun chain hash () () ->
      State.Block.unmark_invalid chain hash) ;
  !dir

let build_rpc_directory validator =
  let distributed_db = Validator.distributed_db validator in
  let state = Distributed_db.state distributed_db in
  let dir = ref rpc_directory in
  (* Mempool *)
  let merge d = dir := RPC_directory.merge !dir d in
  merge
    (RPC_directory.map
       (fun chain ->
         match Validator.get validator (State.Chain.id chain) with
         | Error _ ->
             Lwt.fail Not_found
         | Ok chain_validator ->
             Lwt.return (Chain_validator.prevalidator chain_validator))
       Prevalidator.rpc_directory) ;
  RPC_directory.prefix Chain_services.path
  @@ RPC_directory.map (fun ((), chain) -> get_chain state chain) !dir
src/lib_shell/chain_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.Chain_services.

Definition get_chain_id
  (state : Tezos_shell__State.global_state) (function_parameter : variant)
  : Lwt.t Tezos_base__TzPervasives.Chain_id.t :=
  match function_parameter with
  | Main => Lwt._return (Tezos_shell.State.Chain.main state)
  | Test =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.State.Chain.get_exn state
        (Tezos_shell.State.Chain.main state))
      (fun main_chain =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.test main_chain)
          (fun function_parameter =>
            match function_parameter with
            | None => Lwt.fail OCaml.Not_found
            | Some chain_id => Lwt._return chain_id
            end))
  | Hash chain_id => Lwt._return chain_id
  end.

Definition get_chain_id_opt
  (state : Tezos_shell__State.global_state) (chain : variant)
  : Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq (get_chain_id state chain)
          Lwt.return_some
      end) (fun _exn => Lwt.return_none).

Definition get_chain (state : Tezos_shell__State.global_state) (chain : variant)
  : Lwt.t Tezos_shell.State.Chain.chain_state :=
  Tezos_base__TzPervasives.op_gt_gt_eq (get_chain_id state chain)
    (fun chain_id => Tezos_shell.State.Chain.get_exn state chain_id).

Definition get_checkpoint
  (state : Tezos_shell__State.global_state)
  (chain : Tezos_shell_services.Chain_services.chain)
  : Lwt.t Tezos_crypto.Block_hash.t :=
  Tezos_base__TzPervasives.op_gt_gt_eq (get_chain state chain)
    (fun chain =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Chain.checkpoint chain)
        (fun header =>
          Lwt._return (Tezos_base__TzPervasives.Block_header.hash header))).

Definition predecessors
  (ignored : Tezos_base__TzPervasives.Block_hash.Set.t) (length : Z)
  (head : Tezos_shell.State.Block.t)
  : Lwt.t (list Tezos_base__TzPervasives.Block_hash.t) :=
  let fix loop
    (acc : list Tezos_base__TzPervasives.Block_hash.t) (length : Z) (block :
    Tezos_shell.State.Block.t)
    : Lwt.t (list Tezos_base__TzPervasives.Block_hash.t) :=
    if OCaml.Stdlib.le length 0 then
      Lwt._return (Tezos_base__TzPervasives.List.rev acc)
    else
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.predecessor block)
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt._return (Tezos_base__TzPervasives.List.rev acc)
          | Some pred =>
            if
              Tezos_base__TzPervasives.Block_hash.Set.mem
                (Tezos_shell.State.Block.hash block) ignored then
              Lwt._return (Tezos_base__TzPervasives.List.rev acc)
            else
              loop (cons (Tezos_shell.State.Block.hash pred) acc)
                (Z.sub length 1) pred
          end) in
  loop (cons (Tezos_shell.State.Block.hash head) []) (Z.sub length 1) head.

Definition list_blocks
  (chain_state : Tezos_shell.State.Chain.t) (op_star_o_p_t_star : option Z)
  : (option Tezos_base__TzPervasives.Time.Protocol.t) ->
    (list Tezos_base__TzPervasives.Block_hash.t) ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list (list Tezos_base__TzPervasives.Block_hash.Set.elt))) :=
  let length :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 1
    end in
  fun min_date =>
    fun heads =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        match heads with
        | [] =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.Chain.known_heads chain_state)
            (fun heads =>
              let heads :=
                match min_date with
                | None => heads
                | Some min_date =>
                  Tezos_base__TzPervasives.List.fold_left
                    (fun acc =>
                      fun block =>
                        let timestamp := Tezos_shell.State.Block.timestamp block
                          in
                        if
                          Tezos_base__TzPervasives.Time.Protocol.op_lt_eq
                            min_date timestamp then
                          cons block acc
                        else
                          acc) [] heads
                end in
              let sorted_heads :=
                Tezos_base__TzPervasives.List.sort
                  (fun b1 =>
                    fun b2 =>
                      let f1 := Tezos_shell.State.Block.fitness b1 in
                      let f2 := Tezos_shell.State.Block.fitness b2 in
                      Z.opp (Tezos_base__TzPervasives.Fitness.compare f1 f2))
                  heads in
              Lwt._return
                (Tezos_base__TzPervasives.List.map (fun b => Some b)
                  sorted_heads))
        | (cons _ _) as heads =>
          Lwt_list.map_p (Tezos_shell.State.Block.read_opt chain_state) heads
        end
        (fun requested_heads =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Lwt_list.fold_left_s
              (fun function_parameter =>
                match function_parameter with
                | (ignored, acc) =>
                  fun head =>
                    match head with
                    | None => Lwt._return (ignored, [])
                    | Some block =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (predecessors ignored length block)
                        (fun predecessors =>
                          let ignored :=
                            Tezos_base__TzPervasives.List.fold_left
                              (fun acc =>
                                fun v =>
                                  Tezos_base__TzPervasives.Block_hash.Set.add v
                                    acc) ignored predecessors in
                          Lwt._return (ignored, (cons predecessors acc)))
                    end
                end) (Tezos_base__TzPervasives.Block_hash.Set.empty, [])
              requested_heads)
            (fun function_parameter =>
              match function_parameter with
              | (_, blocks) =>
                Tezos_base__TzPervasives._return
                  (Tezos_base__TzPervasives.List.rev blocks)
              end)).

Definition rpc_directory
  : Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Chain.t :=
  let dir := Stdlib.ref Tezos_base__TzPervasives.RPC_directory.empty in
  let register0 {A B C D : Type}
    (s :
    Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
      Tezos_rpc.RPC_service.error) (f :
    Tezos_shell.State.Chain.t ->
      B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir)
        (Tezos_base__TzPervasives.RPC_service.subst0 s)
        (fun chain => fun p => fun q => f chain p q)) in
  let register1 {A B C D E : Type}
    (s :
    Tezos_base__TzPervasives.RPC_service.raw variant A (A * B) C D E
      Tezos_rpc.RPC_service.error) (f :
    Tezos_shell.State.Chain.t ->
      B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E)) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir)
        (Tezos_base__TzPervasives.RPC_service.subst1 s)
        (fun function_parameter =>
          match function_parameter with
          | (chain, a) => fun p => fun q => f chain a p q
          end)) in
  let register_dynamic_directory2 {A B : Type}
    (descr : option string) (s :
    Tezos_base__TzPervasives.RPC_path.path A (A * B)) (f :
    Tezos_shell.State.Chain.t ->
      B ->
        Lwt.t
          (Tezos_base__TzPervasives.RPC_directory.directory
            (Tezos_shell.State.Chain.t * B))) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register_dynamic_directory descr
        (Stdlib.op_exclamation dir) (Tezos_base__TzPervasives.RPC_path.subst1 s)
        (fun function_parameter =>
          match function_parameter with
          | (chain, a) => f chain a
          end)) in
  register0 Tezos_shell_services.Chain_services.S.chain_id
    (fun chain =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives._return
                (Tezos_shell.State.Chain.id chain)
            end
        end);
  register0 Tezos_shell_services.Chain_services.S.checkpoint
    (fun chain =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.State.Chain.checkpoint chain)
                (fun checkpoint =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.Chain.save_point chain)
                    (fun function_parameter =>
                      match function_parameter with
                      | (save_point, _) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_shell.State.Chain.caboose chain)
                          (fun function_parameter =>
                            match function_parameter with
                            | (caboose, _) =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_shell.State.history_mode
                                  (Tezos_shell.State.Chain.global_state chain))
                                (fun history_mode =>
                                  Tezos_base__TzPervasives._return
                                    (checkpoint, save_point, caboose,
                                      history_mode))
                            end)
                      end))
            end
        end);
  register0 Tezos_shell_services.Chain_services.S.Blocks.list
    (fun chain =>
      fun q =>
        fun function_parameter =>
          match function_parameter with
          | tt => list_blocks chain send send send
          end);
  register_dynamic_directory2 None Tezos_shell_services.Block_services.path
    Tezos_shell.Block_directory.build_rpc_directory;
  register0 Tezos_shell_services.Chain_services.S.Invalid_blocks.list
    (fun chain =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              let convert
                (function_parameter :
                Tezos_base__TzPervasives.Block_hash.t * Stdlib.Int32.t *
                  (list Tezos_base__TzPervasives.error))
                : Tezos_shell_services.Chain_services.invalid_block :=
                match function_parameter with
                | (hash, level, errors) =>
                  {| hash := hash; level := level; errors := errors |}
                end in
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.State.Block.list_invalid chain)
                (fun blocks =>
                  Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.List.map convert blocks))
            end
        end);
  register1 Tezos_shell_services.Chain_services.S.Invalid_blocks.get
    (fun chain =>
      fun hash =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Block.read_invalid chain hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => Lwt.fail OCaml.Not_found
                    | Some {| level := level; errors := errors |} =>
                      Tezos_base__TzPervasives._return
                        {| hash := hash; level := level; errors := errors |}
                    end)
              end
          end);
  register1 Tezos_shell_services.Chain_services.S.Invalid_blocks.delete
    (fun chain =>
      fun hash =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt => Tezos_shell.State.Block.unmark_invalid chain hash
              end
          end);
  Stdlib.op_exclamation dir.

Definition build_rpc_directory (validator : Tezos_shell.Validator.t)
  : Tezos_base__TzPervasives.RPC_directory.directory unit :=
  let distributed_db := Tezos_shell.Validator.distributed_db validator in
  let state := Tezos_shell.Distributed_db.state distributed_db in
  let dir := Stdlib.ref rpc_directory in
  let merge
    (d :
    Tezos_base__TzPervasives.RPC_directory.directory Tezos_shell.State.Chain.t)
    : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.merge (Stdlib.op_exclamation dir)
        d) in
  merge
    (Tezos_base__TzPervasives.RPC_directory.map
      (fun chain =>
        match
          Tezos_shell.Validator.get validator (Tezos_shell.State.Chain.id chain)
          with
        | inr _ => Lwt.fail OCaml.Not_found
        | inl chain_validator =>
          Lwt._return (Tezos_shell.Chain_validator.prevalidator chain_validator)
        end) Tezos_shell.Prevalidator.rpc_directory);
  apply
    (Tezos_base__TzPervasives.RPC_directory.prefix
      Tezos_shell_services.Chain_services.path)
    (Tezos_base__TzPervasives.RPC_directory.map
      (fun function_parameter =>
        match function_parameter with
        | (tt, chain) => get_chain state chain
        end) (Stdlib.op_exclamation dir)).
src/lib_shell/chain_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val get_chain_id : State.t -> Chain_services.chain -> Chain_id.t Lwt.t

val get_chain_id_opt :
  State.t -> Chain_services.chain -> Chain_id.t option Lwt.t

val get_chain : State.t -> Chain_services.chain -> State.Chain.t Lwt.t

val get_checkpoint : State.t -> Chain_services.chain -> Block_hash.t Lwt.t

val rpc_directory : State.Chain.t RPC_directory.t

val build_rpc_directory : Validator.t -> unit RPC_directory.t
src/lib_shell/chain_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_chain_id :
Tezos_shell.State.t ->
  Tezos_shell_services.Chain_services.chain ->
    Lwt.t Tezos_base__TzPervasives.Chain_id.t.

Parameter get_chain_id_opt :
Tezos_shell.State.t ->
  Tezos_shell_services.Chain_services.chain ->
    Lwt.t (option Tezos_base__TzPervasives.Chain_id.t).

Parameter get_chain :
Tezos_shell.State.t ->
  Tezos_shell_services.Chain_services.chain -> Lwt.t Tezos_shell.State.Chain.t.

Parameter get_checkpoint :
Tezos_shell.State.t ->
  Tezos_shell_services.Chain_services.chain ->
    Lwt.t Tezos_base__TzPervasives.Block_hash.t.

Parameter rpc_directory :
Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Chain.t.

Parameter build_rpc_directory :
Tezos_shell.Validator.t -> Tezos_base__TzPervasives.RPC_directory.t unit.
src/lib_shell/chain_traversal.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open State

let path (b1 : Block.t) (b2 : Block.t) =
  if not (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
    invalid_arg "Chain_traversal.path" ;
  let rec loop acc current =
    if Block.equal b1 current then Lwt.return_some acc
    else
      Block.predecessor current
      >>= function
      | Some pred -> loop (current :: acc) pred | None -> Lwt.return_none
  in
  loop [] b2

let common_ancestor (b1 : Block.t) (b2 : Block.t) =
  if not (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
    invalid_arg "Chain_traversal.path" ;
  let rec loop (b1 : Block.t) (b2 : Block.t) =
    if Block.equal b1 b2 then Lwt.return b1
    else if Time.Protocol.(Block.timestamp b1 <= Block.timestamp b2) then
      Block.predecessor b2
      >>= function None -> assert false | Some b2 -> loop b1 b2
    else
      Block.predecessor b1
      >>= function None -> assert false | Some b1 -> loop b1 b2
  in
  loop b1 b2

let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
  let module Local = struct
    exception Exit
  end in
  let compare b1 b2 =
    match Fitness.compare (Block.fitness b1) (Block.fitness b2) with
    | 0 -> (
      match
        Time.Protocol.compare (Block.timestamp b1) (Block.timestamp b2)
      with
      | 0 ->
          Block.compare b1 b2
      | res ->
          res )
    | res ->
        res
  in
  let (pop, push) =
    (* Poor-man priority queue *)
    let queue : Block.t list ref = ref [] in
    let pop () =
      match !queue with
      | [] ->
          None
      | b :: bs ->
          queue := bs ;
          Some b
    in
    let push b =
      let rec loop = function
        | [] ->
            [b]
        | b' :: bs' as bs ->
            let cmp = compare b b' in
            if cmp = 0 then bs else if cmp < 0 then b' :: loop bs' else b :: bs
      in
      queue := loop !queue
    in
    (pop, push)
  in
  let check_count =
    match max with
    | None ->
        fun () -> ()
    | Some max ->
        let cpt = ref 0 in
        fun () ->
          if !cpt >= max then raise Local.Exit ;
          incr cpt
  in
  let check_fitness =
    match min_fitness with
    | None ->
        fun _ -> true
    | Some min_fitness ->
        fun b -> Fitness.compare min_fitness (Block.fitness b) <= 0
  in
  let check_date =
    match min_date with
    | None ->
        fun _ -> true
    | Some min_date ->
        fun b -> Time.Protocol.(min_date <= Block.timestamp b)
  in
  let rec loop () =
    match pop () with
    | None ->
        Lwt.return_unit
    | Some b -> (
        check_count () ;
        f b
        >>= fun () ->
        Block.predecessor b
        >>= function
        | None ->
            loop ()
        | Some p ->
            if check_fitness p && check_date p then push p ;
            loop () )
  in
  List.iter push heads ;
  try loop () with Local.Exit -> Lwt.return_unit

let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
  match heads with
  | [] ->
      Lwt.return_unit
  | b :: _ ->
      let chain_id = Block.chain_id b in
      if
        not
          (List.for_all
             (fun b -> Chain_id.equal chain_id (Block.chain_id b))
             heads)
      then invalid_arg "State.Helpers.iter_predecessors" ;
      iter_predecessors ?max ?min_fitness ?min_date heads ~f

let new_blocks ~from_block ~to_block =
  common_ancestor from_block to_block
  >>= fun ancestor ->
  path ancestor to_block
  >>= function None -> assert false | Some path -> Lwt.return (ancestor, path)

let live_blocks block n =
  let rec loop bacc oacc chain_state block_head n =
    Block.all_operation_hashes block_head
    >>= fun hashes ->
    let oacc =
      List.fold_left
        (List.fold_left (fun oacc op -> Operation_hash.Set.add op oacc))
        oacc
        hashes
    in
    let bacc = Block_hash.Set.add (Block.hash block_head) bacc in
    if n = 0 then return (bacc, oacc)
    else
      State.Block.predecessor block_head
      >>= function
      | None ->
          let genesis_hash = (State.Chain.genesis chain_state).block in
          let block_hash = Block.hash block_head in
          if Block_hash.equal genesis_hash block_hash then return (bacc, oacc)
          else fail (State.Block_not_found block_hash)
      | Some predecessor ->
          loop bacc oacc chain_state predecessor (pred n)
  in
  loop
    Block_hash.Set.empty
    Operation_hash.Set.empty
    (Block.chain_state block)
    block
    n
src/lib_shell/chain_traversal.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell.State.

Definition path
  (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
  : Lwt.t (option (list Tezos_shell.State.Block.t)) :=
  if
    negb
      (Tezos_base__TzPervasives.Chain_id.equal
        (Tezos_shell.State.Block.chain_id b1)
        (Tezos_shell.State.Block.chain_id b2)) then
    OCaml.Stdlib.invalid_arg "Chain_traversal.path" % string
  else
    tt;
  let fix loop
    (acc : list Tezos_shell.State.Block.t) (current : Tezos_shell.State.Block.t)
    : Lwt.t (option (list Tezos_shell.State.Block.t)) :=
    if Tezos_shell.State.Block.equal b1 current then
      Lwt.return_some acc
    else
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.predecessor current)
        (fun function_parameter =>
          match function_parameter with
          | Some pred => loop (cons current acc) pred
          | None => Lwt.return_none
          end) in
  loop [] b2.

Definition common_ancestor
  (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
  : Lwt.t Tezos_shell.State.Block.t :=
  if
    negb
      (Tezos_base__TzPervasives.Chain_id.equal
        (Tezos_shell.State.Block.chain_id b1)
        (Tezos_shell.State.Block.chain_id b2)) then
    OCaml.Stdlib.invalid_arg "Chain_traversal.path" % string
  else
    tt;
  let fix loop (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
    : Lwt.t Tezos_shell.State.Block.t :=
    if Tezos_shell.State.Block.equal b1 b2 then
      Lwt._return b1
    else
      if
        Tezos_base__TzPervasives.Time.Protocol.op_lt_eq
          (Tezos_shell.State.Block.timestamp b1)
          (Tezos_shell.State.Block.timestamp b2) then
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Block.predecessor b2)
          (fun function_parameter =>
            match function_parameter with
            | None => false
            | Some b2 => loop b1 b2
            end)
      else
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Block.predecessor b1)
          (fun function_parameter =>
            match function_parameter with
            | None => false
            | Some b1 => loop b1 b2
            end) in
  loop b1 b2.

Definition iter_predecessors
  (max : option Z) (min_fitness : option Tezos_base__TzPervasives.Fitness.t)
  (min_date : option Tezos_base__TzPervasives.Time.Protocol.t)
  (heads : list Tezos_shell.State.Block.t)
  (f : Tezos_shell.State.Block.t -> Lwt.t unit) : Lwt.t unit :=
  let Local :=
    existT _ _
      {|
        
        |} in
  let compare (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
    : Z :=
    match
      Tezos_base__TzPervasives.Fitness.compare
        (Tezos_shell.State.Block.fitness b1)
        (Tezos_shell.State.Block.fitness b2) with
    | 0 =>
      match
        Tezos_base__TzPervasives.Time.Protocol.compare
          (Tezos_shell.State.Block.timestamp b1)
          (Tezos_shell.State.Block.timestamp b2) with
      | 0 => Tezos_shell.State.Block.compare b1 b2
      | res => res
      end
    | res => res
    end in
  match
    let queue := Stdlib.ref [] in
    let pop (function_parameter : unit) : option Tezos_shell.State.Block.t :=
      match function_parameter with
      | tt =>
        match Stdlib.op_exclamation queue with
        | [] => None
        | cons b bs =>
          Stdlib.op_colon_eq queue bs;
          Some b
        end
      end in
    let push (b : Tezos_shell.State.Block.t) : unit :=
      let fix loop (function_parameter : list Tezos_shell.State.Block.t)
        : list Tezos_shell.State.Block.t :=
        match function_parameter with
        | [] => cons b []
        | (cons b' bs') as bs =>
          let cmp := compare b b' in
          if equiv_decb cmp 0 then
            bs
          else
            if OCaml.Stdlib.lt cmp 0 then
              cons b' (loop bs')
            else
              cons b bs
        end in
      Stdlib.op_colon_eq queue (loop (Stdlib.op_exclamation queue)) in
    (pop, push) with
  | (pop, push) =>
    let check_count :=
      match max with
      | None =>
        fun function_parameter =>
          match function_parameter with
          | tt => tt
          end
      | Some max =>
        let cpt := Stdlib.ref 0 in
        fun function_parameter =>
          match function_parameter with
          | tt =>
            if OCaml.Stdlib.ge (Stdlib.op_exclamation cpt) max then
              Stdlib.raise Local.Exit
            else
              tt;
            Stdlib.incr cpt
          end
      end in
    let check_fitness :=
      match min_fitness with
      | None =>
        fun function_parameter =>
          match function_parameter with
          | _ => true
          end
      | Some min_fitness =>
        fun b =>
          OCaml.Stdlib.le
            (Tezos_base__TzPervasives.Fitness.compare min_fitness
              (Tezos_shell.State.Block.fitness b)) 0
      end in
    let check_date :=
      match min_date with
      | None =>
        fun function_parameter =>
          match function_parameter with
          | _ => true
          end
      | Some min_date =>
        fun b =>
          Tezos_base__TzPervasives.Time.Protocol.op_lt_eq min_date
            (Tezos_shell.State.Block.timestamp b)
      end in
    let fix loop (function_parameter : unit) : Lwt.t unit :=
      match function_parameter with
      | tt =>
        match pop tt with
        | None => Lwt.return_unit
        | Some b =>
          check_count tt;
          Tezos_base__TzPervasives.op_gt_gt_eq (f b)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Block.predecessor b)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => loop tt
                    | Some p =>
                      if andb (check_fitness p) (check_date p) then
                        push p
                      else
                        tt;
                      loop tt
                    end)
              end)
        end
      end in
    Tezos_base__TzPervasives.List.iter push heads;
    try
  end.

Definition iter_predecessors
  (max : option Z) (min_fitness : option Tezos_base__TzPervasives.Fitness.t)
  (min_date : option Tezos_base__TzPervasives.Time.Protocol.t)
  (heads : list Tezos_shell.State.Block.t)
  (f : Tezos_shell.State.Block.t -> Lwt.t unit) : Lwt.t unit :=
  match heads with
  | [] => Lwt.return_unit
  | cons b _ =>
    let chain_id := Tezos_shell.State.Block.chain_id b in
    if
      negb
        (Tezos_base__TzPervasives.List.for_all
          (fun b =>
            Tezos_base__TzPervasives.Chain_id.equal chain_id
              (Tezos_shell.State.Block.chain_id b)) heads) then
      OCaml.Stdlib.invalid_arg "State.Helpers.iter_predecessors" % string
    else
      tt;
    iter_predecessors max min_fitness min_date heads f
  end.

Definition new_blocks
  (from_block : Tezos_shell.State.Block.t)
  (to_block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_shell.State.Block.t * (list Tezos_shell.State.Block.t)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (common_ancestor from_block to_block)
    (fun ancestor =>
      Tezos_base__TzPervasives.op_gt_gt_eq (path ancestor to_block)
        (fun function_parameter =>
          match function_parameter with
          | None => false
          | Some path => Lwt._return (ancestor, path)
          end)).

Definition live_blocks (block : Tezos_shell.State.Block.t) (n : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_hash.Set.t *
        Tezos_base__TzPervasives.Operation_hash.Set.t)) :=
  let fix loop
    (bacc : Tezos_base__TzPervasives.Block_hash.Set.t) (oacc :
    Tezos_base__TzPervasives.Operation_hash.Set.t) (chain_state :
    Tezos_shell.State.Chain.chain_state) (block_head :
    Tezos_shell.State.Block.t) (n : Z)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_base__TzPervasives.Block_hash.Set.t *
          Tezos_base__TzPervasives.Operation_hash.Set.t)) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.State.Block.all_operation_hashes block_head)
      (fun hashes =>
        let oacc :=
          Tezos_base__TzPervasives.List.fold_left
            (Tezos_base__TzPervasives.List.fold_left
              (fun oacc =>
                fun op =>
                  Tezos_base__TzPervasives.Operation_hash.Set.add op oacc)) oacc
            hashes in
        let bacc :=
          Tezos_base__TzPervasives.Block_hash.Set.add
            (Tezos_shell.State.Block.hash block_head) bacc in
        if equiv_decb n 0 then
          Tezos_base__TzPervasives._return (bacc, oacc)
        else
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.predecessor block_head)
            (fun function_parameter =>
              match function_parameter with
              | None =>
                let genesis_hash :=
                  block (Tezos_shell.State.Chain.genesis chain_state) in
                let block_hash := Tezos_shell.State.Block.hash block_head in
                if
                  Tezos_base__TzPervasives.Block_hash.equal genesis_hash
                    block_hash then
                  Tezos_base__TzPervasives._return (bacc, oacc)
                else
                  Tezos_base__TzPervasives.fail
                    (State.Block_not_found block_hash)
              | Some predecessor =>
                loop bacc oacc chain_state predecessor (Z.pred n)
              end)) in
  loop Tezos_base__TzPervasives.Block_hash.Set.empty
    Tezos_base__TzPervasives.Operation_hash.Set.empty
    (Tezos_shell.State.Block.chain_state block) block n.
src/lib_shell/chain_traversal.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell Module - Chain Traversal API *)

open State

(** If [h1] is an ancestor of [h2] in the current [state],
    then [path state h1 h2] returns the chain of block from
    [h1] (excluded) to [h2] (included). Returns [None] otherwise. *)
val path : Block.t -> Block.t -> Block.t list option Lwt.t

(** [common_ancestor state h1 h2] returns the first common ancestors
    in the history of blocks [h1] and [h2]. *)
val common_ancestor : Block.t -> Block.t -> Block.t Lwt.t

(** [iter_predecessors state blocks f] iter [f] on [blocks] and
    their recursive predecessors. Blocks are visited with a
    decreasing fitness (then decreasing timestamp). If the optional
    argument [max] is provided, the iteration is stopped after [max]
    visited block. If [min_fitness] id provided, blocks with a
    fitness lower than [min_fitness] are ignored. If [min_date],
    blocks with a fitness lower than [min_date] are ignored. *)
val iter_predecessors :
  ?max:int ->
  ?min_fitness:Fitness.t ->
  ?min_date:Time.Protocol.t ->
  Block.t list ->
  f:(Block.t -> unit Lwt.t) ->
  unit Lwt.t

(** [new_blocks ~from_block ~to_block] returns a pair [(ancestor,
    path)], where [ancestor] is the common ancestor of [from_block]
    and [to_block] and where [path] is the chain from [ancestor]
    (excluded) to [to_block] (included).  The function raises an
    exception when the two provided blocks do not belong to the same
    [chain].  *)
val new_blocks :
  from_block:Block.t -> to_block:Block.t -> (Block.t * Block.t list) Lwt.t

(** [live_blocks b n] return a pair [(blocks,operations)] where
    [blocks] is the set of arity [n], that contains [b] and its [n-1]
    predecessors. And where [operations] is the set of operations
    included in those blocks.
*)
val live_blocks :
  Block.t -> int -> (Block_hash.Set.t * Operation_hash.Set.t) tzresult Lwt.t
src/lib_shell/chain_traversal.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter path :
Tezos_shell.State.Block.t ->
  Tezos_shell.State.Block.t -> Lwt.t (option (list Tezos_shell.State.Block.t)).

Parameter common_ancestor :
Tezos_shell.State.Block.t ->
  Tezos_shell.State.Block.t -> Lwt.t Tezos_shell.State.Block.t.

Parameter iter_predecessors :
(option Z) ->
  (option Tezos_base__TzPervasives.Fitness.t) ->
    (option Tezos_base__TzPervasives.Time.Protocol.t) ->
      (list Tezos_shell.State.Block.t) ->
        (Tezos_shell.State.Block.t -> Lwt.t unit) -> Lwt.t unit.

Parameter new_blocks :
Tezos_shell.State.Block.t ->
  Tezos_shell.State.Block.t ->
    Lwt.t (Tezos_shell.State.Block.t * (list Tezos_shell.State.Block.t)).

Parameter live_blocks :
Tezos_shell.State.Block.t ->
  Z ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_base__TzPervasives.Block_hash.Set.t *
          Tezos_base__TzPervasives.Operation_hash.Set.t)).
src/lib_shell/chain_validator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Chain_validator_worker_state

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "node.chain_validator"
end)

module Name = struct
  type t = Chain_id.t

  let encoding = Chain_id.encoding

  let base = ["validator"; "chain"]

  let pp = Chain_id.pp_short
end

module Request = struct
  include Request

  type _ t = Validated : State.Block.t -> Event.update t

  let view (type a) (Validated block : a t) : view = State.Block.hash block
end

type limits = {bootstrap_threshold : int; worker_limits : Worker_types.limits}

module Types = struct
  include Worker_state

  type parameters = {
    parent : Name.t option;
    db : Distributed_db.t;
    chain_state : State.Chain.t;
    chain_db : Distributed_db.chain_db;
    block_validator : Block_validator.t;
    block_validator_process : Block_validator_process.t;
    global_valid_block_input : State.Block.t Lwt_watcher.input;
    global_chains_input : (Chain_id.t * bool) Lwt_watcher.input;
    prevalidator_limits : Prevalidator.limits;
    peer_validator_limits : Peer_validator.limits;
    limits : limits;
  }

  type state = {
    parameters : parameters;
    mutable bootstrapped : bool;
    bootstrapped_waiter : unit Lwt.t;
    bootstrapped_wakener : unit Lwt.u;
    valid_block_input : State.Block.t Lwt_watcher.input;
    new_head_input : State.Block.t Lwt_watcher.input;
    mutable child : (state * (unit -> unit Lwt.t (* shutdown *))) option;
    mutable prevalidator : Prevalidator.t option;
    active_peers : Peer_validator.t P2p_peer.Error_table.t;
    bootstrapped_peers : unit P2p_peer.Table.t;
  }

  let view (state : state) _ : view =
    let {bootstrapped; active_peers; bootstrapped_peers; _} = state in
    {
      bootstrapped;
      active_peers =
        P2p_peer.Error_table.fold_keys (fun id l -> id :: l) active_peers [];
      bootstrapped_peers =
        P2p_peer.Table.fold (fun id _ l -> id :: l) bootstrapped_peers [];
    }
end

module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
open Types

type t = Worker.infinite Worker.queue Worker.t

let table = Worker.create_table Queue

let shutdown w = Worker.shutdown w

let shutdown_child nv active_chains =
  Lwt_utils.may
    ~f:
      (fun ({parameters = {chain_state; global_chains_input; _}; _}, shutdown) ->
      Lwt_watcher.notify global_chains_input (State.Chain.id chain_state, false) ;
      Chain_id.Table.remove active_chains (State.Chain.id chain_state) ;
      State.update_chain_data nv.parameters.chain_state (fun _ chain_data ->
          Lwt.return (Some {chain_data with test_chain = None}, ()))
      >>= fun () ->
      shutdown ()
      >>= fun () ->
      nv.child <- None ;
      Lwt.return_unit)
    nv.child

let notify_new_block w block =
  let nv = Worker.state w in
  Option.iter nv.parameters.parent ~f:(fun id ->
      try
        let w = List.assoc id (Worker.list table) in
        let nv = Worker.state w in
        Lwt_watcher.notify nv.valid_block_input block
      with Not_found -> ()) ;
  Lwt_watcher.notify nv.valid_block_input block ;
  Lwt_watcher.notify nv.parameters.global_valid_block_input block ;
  Worker.Queue.push_request_now w (Validated block)

let may_toggle_bootstrapped_chain w =
  let nv = Worker.state w in
  if
    (not nv.bootstrapped)
    && P2p_peer.Table.length nv.bootstrapped_peers
       >= nv.parameters.limits.bootstrap_threshold
  then (
    Log.log_info "bootstrapped" ;
    nv.bootstrapped <- true ;
    Lwt.wakeup_later nv.bootstrapped_wakener () )

let with_activated_peer_validator w peer_id f =
  let nv = Worker.state w in
  P2p_peer.Error_table.find_or_make nv.active_peers peer_id (fun () ->
      Peer_validator.create
        ~notify_new_block:(notify_new_block w)
        ~notify_bootstrapped:(fun () ->
          P2p_peer.Table.add nv.bootstrapped_peers peer_id () ;
          may_toggle_bootstrapped_chain w)
        ~notify_termination:(fun _pv ->
          P2p_peer.Error_table.remove nv.active_peers peer_id ;
          P2p_peer.Table.remove nv.bootstrapped_peers peer_id)
        nv.parameters.peer_validator_limits
        nv.parameters.block_validator
        nv.parameters.chain_db
        peer_id)
  >>=? fun pv ->
  match Peer_validator.status pv with
  | Worker_types.Running _ ->
      f pv
  | Worker_types.Closing (_, _)
  | Worker_types.Closed (_, _, _)
  | Worker_types.Launching _ ->
      return_unit

let may_update_checkpoint chain_state new_head =
  State.Chain.checkpoint chain_state
  >>= fun checkpoint ->
  State.Block.last_allowed_fork_level new_head
  >>=? fun new_level ->
  if new_level <= checkpoint.shell.level then return_unit
  else
    let state = State.Chain.global_state chain_state in
    State.history_mode state
    >>= fun history_mode ->
    let head_level = State.Block.level new_head in
    State.Block.predecessor_n
      new_head
      (Int32.to_int (Int32.sub head_level new_level))
    >>= function
    | None ->
        assert false (* should not happen *)
    | Some new_checkpoint -> (
        State.Block.read_opt chain_state new_checkpoint
        >>= function
        | None ->
            assert false (* should not happen *)
        | Some new_checkpoint -> (
            Log.log_notice
              "@[Update to checkpoint %a (running in mode %a).@]"
              Block_hash.pp
              (State.Block.hash new_checkpoint)
              History_mode.pp
              history_mode ;
            let new_checkpoint = State.Block.header new_checkpoint in
            match history_mode with
            | History_mode.Archive ->
                State.Chain.set_checkpoint chain_state new_checkpoint
                >>= fun () -> return_unit
            | Full ->
                State.Chain.set_checkpoint_then_purge_full
                  chain_state
                  new_checkpoint
            | Rolling ->
                State.Chain.set_checkpoint_then_purge_rolling
                  chain_state
                  new_checkpoint ) )

let may_switch_test_chain w active_chains spawn_child block =
  let nv = Worker.state w in
  let create_child block protocol expiration forking_block =
    let block_header = State.Block.header block in
    let genesis =
      Context.compute_testchain_genesis (State.Block.hash forking_block)
    in
    let chain_id = Context.compute_testchain_chain_id genesis in
    let activated =
      match nv.child with
      | None ->
          false
      | Some (child, _) ->
          Block_hash.equal
            (State.Chain.genesis child.parameters.chain_state).block
            genesis
    in
    let expired = expiration < block_header.shell.timestamp in
    if expired && activated then
      shutdown_child nv active_chains >>= fun () -> return_unit
    else if
      activated || expired
      || not (State.Chain.allow_forked_chain nv.parameters.chain_state)
    then return_unit
    else
      State.Chain.get_opt
        (State.Chain.global_state nv.parameters.chain_state)
        chain_id
      >>= (function
            | Some chain_state ->
                State.update_testchain block ~testchain_state:chain_state
                >>= fun () -> return chain_state
            | None ->
                let try_init_test_chain cont =
                  let bvp = nv.parameters.block_validator_process in
                  Block_validator_process.init_test_chain bvp forking_block
                  >>= function
                  | Ok genesis_header ->
                      State.fork_testchain
                        block
                        chain_id
                        genesis
                        genesis_header
                        protocol
                        expiration
                      >>=? fun chain_state ->
                      Chain.head chain_state
                      >>= fun new_genesis_block ->
                      Lwt_watcher.notify
                        nv.parameters.global_valid_block_input
                        new_genesis_block ;
                      Lwt_watcher.notify nv.valid_block_input new_genesis_block ;
                      return chain_state
                  | Error
                      (Block_validator_errors.Missing_test_protocol
                         missing_protocol
                      :: _) ->
                      Block_validator.fetch_and_compile_protocol
                        nv.parameters.block_validator
                        missing_protocol
                      >>=? fun _ -> cont ()
                  | Error _ as error ->
                      Lwt.return error
                in
                try_init_test_chain
                @@ fun () ->
                try_init_test_chain
                @@ fun () -> failwith "Could not retrieve test protocol")
      >>=? fun chain_state ->
      (* [spawn_child] is a callback to [create_node]. Thus, it takes care of
         global initialization boilerplate (e.g. notifying [global_chains_input],
         adding the chain to the correct tables, ...) *)
      spawn_child
        ~parent:(State.Chain.id chain_state)
        nv.parameters.peer_validator_limits
        nv.parameters.prevalidator_limits
        nv.parameters.block_validator
        nv.parameters.global_valid_block_input
        nv.parameters.global_chains_input
        nv.parameters.db
        chain_state
        nv.parameters.limits
      (* TODO: different limits main/test ? *)
      >>=? fun child ->
      nv.child <- Some child ;
      return_unit
  in
  State.Block.test_chain block
  >>= (function
        | (Not_running, _) ->
            shutdown_child nv active_chains >>= fun () -> return_unit
        | ((Forking _ | Running _), None) ->
            return_unit (* only for snapshots *)
        | ( ( Forking {protocol; expiration; _}
            | Running {protocol; expiration; _} ),
            Some forking_block ) ->
            create_child block protocol expiration forking_block)
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error err ->
      Worker.record_event w (Could_not_switch_testchain err) ;
      Lwt.return_unit

let broadcast_head w ~previous block =
  let nv = Worker.state w in
  if not nv.bootstrapped then Lwt.return_unit
  else
    State.Block.predecessor block
    >>= (function
          | None ->
              Lwt.return_true
          | Some predecessor ->
              Lwt.return (State.Block.equal predecessor previous))
    >>= fun successor ->
    if successor then (
      Distributed_db.Advertise.current_head nv.parameters.chain_db block ;
      Lwt.return_unit )
    else Distributed_db.Advertise.current_branch nv.parameters.chain_db

let safe_get_protocol hash =
  match Registered_protocol.get hash with
  | None ->
      (* FIXME. *)
      (* This should not happen: it should be handled in the validator. *)
      failwith
        "chain_validator: missing protocol '%a' for the current block."
        Protocol_hash.pp_short
        hash
  | Some protocol ->
      return protocol

let on_request (type a) w start_testchain active_chains spawn_child
    (req : a Request.t) : a tzresult Lwt.t =
  let (Request.Validated block) = req in
  let nv = Worker.state w in
  Chain.head nv.parameters.chain_state
  >>= fun head ->
  let head_header = State.Block.header head
  and head_hash = State.Block.hash head
  and block_header = State.Block.header block
  and block_hash = State.Block.hash block in
  ( match nv.prevalidator with
  | None ->
      Lwt.return head_header.shell.fitness
  | Some pv ->
      Prevalidator.fitness pv )
  >>= fun context_fitness ->
  let head_fitness = head_header.shell.fitness in
  let new_fitness = block_header.shell.fitness in
  let accepted_head =
    if Fitness.(context_fitness = head_fitness) then
      Fitness.(new_fitness > head_fitness)
    else Fitness.(new_fitness >= context_fitness)
  in
  if not accepted_head then return Event.Ignored_head
  else
    Chain.set_head nv.parameters.chain_state block
    >>=? fun previous ->
    may_update_checkpoint nv.parameters.chain_state block
    >>=? fun () ->
    broadcast_head w ~previous block
    >>= fun () ->
    ( match nv.prevalidator with
    | Some old_prevalidator ->
        State.Block.protocol_hash block
        >>=? fun new_protocol ->
        let old_protocol = Prevalidator.protocol_hash old_prevalidator in
        if not (Protocol_hash.equal old_protocol new_protocol) then (
          safe_get_protocol new_protocol
          >>=? fun (module Proto) ->
          let (limits, chain_db) = Prevalidator.parameters old_prevalidator in
          (* TODO inject in the new prevalidator the operation
                 from the previous one. *)
          Prevalidator.create limits (module Proto) chain_db
          >>= function
          | Error errs ->
              Log.lwt_log_error
                "@[Failed to reinstantiate prevalidator:@ %a@]"
                pp_print_error
                errs
              >>= fun () ->
              nv.prevalidator <- None ;
              Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit
          | Ok prevalidator ->
              nv.prevalidator <- Some prevalidator ;
              Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit
          )
        else Prevalidator.flush old_prevalidator block_hash
    | None ->
        return_unit )
    >>=? fun () ->
    ( if start_testchain then
      may_switch_test_chain w active_chains spawn_child block
    else Lwt.return_unit )
    >>= fun () ->
    Lwt_watcher.notify nv.new_head_input block ;
    if Block_hash.equal head_hash block_header.shell.predecessor then
      return Event.Head_increment
    else return Event.Branch_switch

let on_completion (type a) w (req : a Request.t) (update : a) request_status =
  let (Request.Validated block) = req in
  let fitness = State.Block.fitness block in
  let request = State.Block.hash block in
  Worker.record_event
    w
    (Processed_block {request; request_status; update; fitness}) ;
  Lwt.return_unit

let on_close w =
  let nv = Worker.state w in
  Distributed_db.deactivate nv.parameters.chain_db
  >>= fun () ->
  let pvs =
    P2p_peer.Error_table.fold_promises
      (fun _ pv acc ->
        ( pv
        >>= function
        | Error _ -> Lwt.return_unit | Ok pv -> Peer_validator.shutdown pv )
        :: acc)
      nv.active_peers
      []
  in
  Lwt.join
    ( ( match nv.prevalidator with
      | Some prevalidator ->
          Prevalidator.shutdown prevalidator
      | None ->
          Lwt.return_unit )
    :: Lwt_utils.may ~f:(fun (_, shutdown) -> shutdown ()) nv.child
    :: pvs )

let on_launch start_prevalidator w _ parameters =
  ( if start_prevalidator then
    State.read_chain_data
      parameters.chain_state
      (fun _ {State.current_head; _} -> Lwt.return current_head)
    >>= fun head ->
    State.Block.protocol_hash head
    >>=? fun head_hash ->
    safe_get_protocol head_hash
    >>= function
    | Ok (module Proto) -> (
        Prevalidator.create
          parameters.prevalidator_limits
          (module Proto)
          parameters.chain_db
        >>= function
        | Error err ->
            Log.lwt_log_error
              "@[Failed to instantiate prevalidator:@ %a@]"
              pp_print_error
              err
            >>= fun () -> return_none
        | Ok prevalidator ->
            return_some prevalidator )
    | Error err ->
        Log.lwt_log_error
          "@[Failed to instantiate prevalidator:@ %a@]"
          pp_print_error
          err
        >>= fun () -> return_none
  else return_none )
  >>=? fun prevalidator ->
  let valid_block_input = Lwt_watcher.create_input () in
  let new_head_input = Lwt_watcher.create_input () in
  let (bootstrapped_waiter, bootstrapped_wakener) = Lwt.wait () in
  let nv =
    {
      parameters;
      valid_block_input;
      new_head_input;
      bootstrapped_wakener;
      bootstrapped_waiter;
      bootstrapped = parameters.limits.bootstrap_threshold <= 0;
      active_peers = P2p_peer.Error_table.create 50;
      (* TODO use `2 * max_connection` *)
      bootstrapped_peers = P2p_peer.Table.create 50;
      (* TODO use `2 * max_connection` *)
      child = None;
      prevalidator;
    }
  in
  if nv.bootstrapped then Lwt.wakeup_later bootstrapped_wakener () ;
  Distributed_db.set_callback
    parameters.chain_db
    {
      notify_branch =
        (fun peer_id locator ->
          Lwt.async (fun () ->
              with_activated_peer_validator w peer_id
              @@ fun pv ->
              Peer_validator.notify_branch pv locator ;
              return_unit));
      notify_head =
        (fun peer_id block ops ->
          Lwt.async (fun () ->
              with_activated_peer_validator w peer_id (fun pv ->
                  Peer_validator.notify_head pv block ;
                  return_unit)
              >>=? fun () ->
              (* TODO notify prevalidator only if head is known ??? *)
              match nv.prevalidator with
              | Some prevalidator ->
                  Prevalidator.notify_operations prevalidator peer_id ops
                  >>= fun () -> return_unit
              | None ->
                  return_unit));
      disconnection =
        (fun peer_id ->
          Lwt.async (fun () ->
              let nv = Worker.state w in
              match P2p_peer.Error_table.find_opt nv.active_peers peer_id with
              | None ->
                  return_unit
              | Some pv ->
                  pv
                  >>=? fun pv ->
                  Peer_validator.shutdown pv >>= fun () -> return_unit));
    } ;
  return nv

let rec create ~start_prevalidator ~start_testchain ~active_chains ?parent
    ~block_validator_process peer_validator_limits prevalidator_limits
    block_validator global_valid_block_input global_chains_input db chain_state
    limits =
  let spawn_child ~parent pvl pl bl gvbi gci db n l =
    create
      ~start_prevalidator
      ~start_testchain
      ~active_chains
      ~parent
      ~block_validator_process
      pvl
      pl
      bl
      gvbi
      gci
      db
      n
      l
    >>=? fun w -> return (Worker.state w, fun () -> Worker.shutdown w)
  in
  let module Handlers = struct
    type self = t

    let on_launch = on_launch start_prevalidator

    let on_request w = on_request w start_testchain active_chains spawn_child

    let on_close = on_close

    let on_error _ _ _ errs = Lwt.return_error errs

    let on_completion = on_completion

    let on_no_request _ = return_unit
  end in
  let parameters =
    {
      parent;
      peer_validator_limits;
      prevalidator_limits;
      block_validator;
      block_validator_process;
      global_valid_block_input;
      global_chains_input;
      db;
      chain_db = Distributed_db.activate db chain_state;
      chain_state;
      limits;
    }
  in
  Chain.init_head chain_state
  >>=? fun () ->
  Worker.launch
    table
    prevalidator_limits.worker_limits
    (State.Chain.id chain_state)
    parameters
    (module Handlers)
  >>=? fun w ->
  Chain_id.Table.add active_chains (State.Chain.id chain_state) w ;
  Lwt_watcher.notify global_chains_input (State.Chain.id chain_state, true) ;
  return w

(** Current block computation *)

let create ~start_prevalidator ~start_testchain ~active_chains
    ~block_validator_process peer_validator_limits prevalidator_limits
    block_validator global_valid_block_input global_chains_input global_db
    state limits =
  (* hide the optional ?parent *)
  create
    ~start_prevalidator
    ~start_testchain
    ~active_chains
    ~block_validator_process
    peer_validator_limits
    prevalidator_limits
    block_validator
    global_valid_block_input
    global_chains_input
    global_db
    state
    limits

let chain_id w =
  let {parameters = {chain_state; _}; _} = Worker.state w in
  State.Chain.id chain_state

let chain_state w =
  let {parameters = {chain_state; _}; _} = Worker.state w in
  chain_state

let prevalidator w =
  let {prevalidator; _} = Worker.state w in
  prevalidator

let chain_db w =
  let {parameters = {chain_db; _}; _} = Worker.state w in
  chain_db

let child w =
  match (Worker.state w).child with
  | None ->
      None
  | Some ({parameters = {chain_state; _}; _}, _) -> (
    try Some (List.assoc (State.Chain.id chain_state) (Worker.list table))
    with Not_found -> None )

let assert_fitness_increases ?(force = false) w distant_header =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  Chain.head chain_state
  >>= fun local_header ->
  fail_when
    ( (not force)
    && Fitness.compare
         distant_header.Block_header.shell.fitness
         (State.Block.fitness local_header)
       <= 0 )
    (failure "Fitness too low")

let assert_checkpoint w (header : Block_header.t) =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  State.Chain.acceptable_block chain_state header
  >>= fun acceptable ->
  fail_unless
    acceptable
    (Validation_errors.Checkpoint_error (Block_header.hash header, None))

let validate_block w ?force hash block operations =
  let nv = Worker.state w in
  assert (Block_hash.equal hash (Block_header.hash block)) ;
  assert_fitness_increases ?force w block
  >>=? fun () ->
  assert_checkpoint w block
  >>=? fun () ->
  Block_validator.validate
    ~canceler:(Worker.canceler w)
    ~notify_new_block:(notify_new_block w)
    nv.parameters.block_validator
    nv.parameters.chain_db
    hash
    block
    operations

let bootstrapped w =
  let {bootstrapped_waiter; _} = Worker.state w in
  Lwt.protected bootstrapped_waiter

let valid_block_watcher w =
  let {valid_block_input; _} = Worker.state w in
  Lwt_watcher.create_stream valid_block_input

let new_head_watcher w =
  let {new_head_input; _} = Worker.state w in
  Lwt_watcher.create_stream new_head_input

let status = Worker.status

let information = Worker.information

let running_workers () = Worker.list table

let pending_requests t = Worker.Queue.pending_requests t

let pending_requests_length t = Worker.Queue.pending_requests_length t

let current_request t = Worker.current_request t

let last_events = Worker.last_events

let ddb_information t =
  let state = Worker.state t in
  let ddb = state.parameters.chain_db in
  Distributed_db.information ddb
src/lib_shell/chain_validator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.Chain_validator_worker_state.

Module Name.
  Definition t := Tezos_base__TzPervasives.Chain_id.t.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Chain_id.t :=
    Tezos_base__TzPervasives.Chain_id.encoding.
  
  Definition base : list string :=
    cons "validator" % string (cons "chain" % string []).
  
  Definition pp
    : Stdlib.Format.formatter -> Tezos_base__TzPervasives.Chain_id.t -> unit :=
    Tezos_base__TzPervasives.Chain_id.pp_short.
End Name.

Module Request.
  Inductive t : forall (_ : Type), Type :=
  | Validated : Tezos_shell.State.Block.t ->
    t Tezos_shell_services.Chain_validator_worker_state.Event.update.
  
  Definition view {A : Type} (function_parameter : t A) : view :=
    match function_parameter with
    | Validated block => Tezos_shell.State.Block.hash block
    end.
End Request.

Record limits := {
  bootstrap_threshold : Z;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module Types.
  Record parameters := {
    parent : option Name.t;
    db : Tezos_shell.Distributed_db.t;
    chain_state : Tezos_shell.State.Chain.t;
    chain_db : Tezos_shell.Distributed_db.chain_db;
    block_validator : Tezos_shell.Block_validator.t;
    block_validator_process : Tezos_shell.Block_validator_process.t;
    global_valid_block_input :
      Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
    global_chains_input :
      Tezos_base__TzPervasives.Lwt_watcher.input
        (Tezos_base__TzPervasives.Chain_id.t * bool);
    prevalidator_limits : Tezos_shell.Prevalidator.limits;
    peer_validator_limits : Tezos_shell.Peer_validator.limits;
    limits : limits }.
  
  Record state := {
    parameters : parameters;
    bootstrapped : bool;
    bootstrapped_waiter : Lwt.t unit;
    bootstrapped_wakener : Lwt.u unit;
    valid_block_input :
      Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
    new_head_input :
      Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
    child : option (state * (unit -> Lwt.t unit));
    prevalidator : option Tezos_shell.Prevalidator.t;
    active_peers :
      Tezos_base__TzPervasives.P2p_peer.Error_table.t
        Tezos_shell.Peer_validator.t;
    bootstrapped_peers : Tezos_base__TzPervasives.P2p_peer.Table.t unit }.
  
  Definition view {A : Type} (state : state) (function_parameter : A) : view :=
    match function_parameter with
    | _ =>
      match state with
      | {|
        bootstrapped := bootstrapped;
          active_peers := active_peers;
          bootstrapped_peers := bootstrapped_peers
          |} =>
        {|
          active_peers :=
            Tezos_base__TzPervasives.P2p_peer.Error_table.fold_keys
              (fun id => fun l => cons id l) active_peers [];
          bootstrapped_peers :=
            Tezos_base__TzPervasives.P2p_peer.Table.fold
              (fun id =>
                fun function_parameter =>
                  match function_parameter with
                  | _ => fun l => cons id l
                  end) bootstrapped_peers []; bootstrapped := bootstrapped |}
      end
    end.
End Types.

Import Types.

Definition t := Worker.t (Worker.queue Worker.infinite).

Definition table : Worker.table (Worker.queue Worker.infinite) :=
  Worker.create_table Queue.

Definition shutdown {A : Type} (w : Worker.t A) : Lwt.t unit :=
  Worker.shutdown w.

Definition shutdown_child {A : Type}
  (nv : Types.state)
  (active_chains : Tezos_base__TzPervasives.Chain_id.Table.t A) : Lwt.t unit :=
  Tezos_base__TzPervasives.Lwt_utils.may
    (fun function_parameter =>
      match function_parameter with
      |
        ({|
          parameters := {|
            chain_state := chain_state;
              global_chains_input := global_chains_input
              |}
            |}, shutdown) =>
        Tezos_base__TzPervasives.Lwt_watcher.notify global_chains_input
          ((Tezos_shell.State.Chain.id chain_state), false);
        Tezos_base__TzPervasives.Chain_id.Table.remove active_chains
          (Tezos_shell.State.Chain.id chain_state);
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.update_chain_data (chain_state (parameters nv))
            (fun function_parameter =>
              match function_parameter with
              | _ => fun chain_data => Lwt._return ((Some record), tt)
              end))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq (shutdown tt)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    set_field;
                    Lwt.return_unit
                  end)
            end)
      end) (child nv).

Definition notify_new_block
  (w : Worker.t (Worker.queue Worker.infinite))
  (block : Tezos_shell.State.Block.t) : unit :=
  let nv := Worker.state w in
  Tezos_base__TzPervasives.Option.iter (fun id => try) (parent (parameters nv));
  Tezos_base__TzPervasives.Lwt_watcher.notify (valid_block_input nv) block;
  Tezos_base__TzPervasives.Lwt_watcher.notify
    (global_valid_block_input (parameters nv)) block;
  Worker.Queue.push_request_now w (Validated block).

Definition may_toggle_bootstrapped_chain {A : Type} (w : Worker.t A) : unit :=
  let nv := Worker.state w in
  if
    andb (negb (bootstrapped nv))
      (OCaml.Stdlib.ge
        (Tezos_base__TzPervasives.P2p_peer.Table.length (bootstrapped_peers nv))
        (bootstrap_threshold (limits (parameters nv)))) then
    Log.log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "bootstrapped" % string
          CamlinternalFormatBasics.End_of_format) "bootstrapped" % string);
    set_field;
    Lwt.wakeup_later (bootstrapped_wakener nv) tt
  else
    tt.

Definition with_activated_peer_validator
  (w : Worker.t (Worker.queue Worker.infinite))
  (peer_id : Tezos_base__TzPervasives.P2p_peer.Error_table.key)
  (f :
    Tezos_shell.Peer_validator.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let nv := Worker.state w in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.P2p_peer.Error_table.find_or_make
      (active_peers nv) peer_id
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_shell.Peer_validator.create (Some (notify_new_block w))
            (Some
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.P2p_peer.Table.add
                    (bootstrapped_peers nv) peer_id tt;
                  may_toggle_bootstrapped_chain w
                end))
            (Some
              (fun _pv =>
                Tezos_base__TzPervasives.P2p_peer.Error_table.remove
                  (active_peers nv) peer_id;
                Tezos_base__TzPervasives.P2p_peer.Table.remove
                  (bootstrapped_peers nv) peer_id))
            (peer_validator_limits (parameters nv))
            (block_validator (parameters nv)) (chain_db (parameters nv)) peer_id
        end))
    (fun pv =>
      match Tezos_shell.Peer_validator.status pv with
      | Worker_types.Running _ => f pv
      |
        Worker_types.Closing _ _ | Worker_types.Closed _ _ _ |
          Worker_types.Launching _ => Tezos_base__TzPervasives.return_unit
      end).

Definition may_update_checkpoint
  (chain_state : Tezos_shell.State.Chain.chain_state)
  (new_head : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.checkpoint chain_state)
    (fun checkpoint =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.State.Block.last_allowed_fork_level new_head)
        (fun new_level =>
          if OCaml.Stdlib.le new_level (level (shell checkpoint)) then
            Tezos_base__TzPervasives.return_unit
          else
            let state := Tezos_shell.State.Chain.global_state chain_state in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.history_mode state)
              (fun history_mode =>
                let head_level := Tezos_shell.State.Block.level new_head in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Block.predecessor_n new_head
                    (Stdlib.Int32.to_int (Stdlib.Int32.sub head_level new_level)))
                  (fun function_parameter =>
                    match function_parameter with
                    | None => false
                    | Some new_checkpoint =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.State.Block.read_opt chain_state
                          new_checkpoint)
                        (fun function_parameter =>
                          match function_parameter with
                          | None => false
                          | Some new_checkpoint =>
                            Log.log_notice
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      CamlinternalFormatBasics.End_of_format
                                      "" % string))
                                  (CamlinternalFormatBasics.String_literal
                                    "Update to checkpoint " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " (running in mode " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            ")." % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format)))))))
                                "@[Update to checkpoint %a (running in mode %a).@]"
                                  % string)
                              Tezos_base__TzPervasives.Block_hash.pp
                              (Tezos_shell.State.Block.hash new_checkpoint)
                              Tezos_shell_services.History_mode.pp history_mode;
                            let new_checkpoint :=
                              Tezos_shell.State.Block.header new_checkpoint in
                            match history_mode with
                            | History_mode.Archive =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_shell.State.Chain.set_checkpoint
                                  chain_state new_checkpoint)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                            | Full =>
                              Tezos_shell.State.Chain.set_checkpoint_then_purge_full
                                chain_state new_checkpoint
                            | Rolling =>
                              Tezos_shell.State.Chain.set_checkpoint_then_purge_rolling
                                chain_state new_checkpoint
                            end
                          end)
                    end)))).

Definition may_switch_test_chain {A B : Type}
  (w : Worker.t A) (active_chains : Tezos_base__TzPervasives.Chain_id.Table.t B)
  (spawn_child :
    Tezos_base__TzPervasives.Chain_id.t ->
      Tezos_shell.Peer_validator.limits ->
        Tezos_shell.Prevalidator.limits ->
          Tezos_shell.Block_validator.t ->
            (Tezos_base__TzPervasives.Lwt_watcher.input
              Tezos_shell.State.Block.t) ->
              (Tezos_base__TzPervasives.Lwt_watcher.input
                (Tezos_base__TzPervasives.Chain_id.t * bool)) ->
                Tezos_shell.Distributed_db.t ->
                  Tezos_shell.State.Chain.chain_state ->
                    limits ->
                      Lwt.t
                        (Tezos_base__TzPervasives.tzresult
                          (Types.state * (unit -> Lwt.t unit))))
  (block : Tezos_shell.State.Block.t) : Lwt.t unit :=
  let nv := Worker.state w in
  let create_child
    (block : Tezos_shell.State.Block.t) (protocol :
    Tezos_base__TzPervasives.Protocol_hash.t) (expiration :
    Tezos_base.Time.Protocol.t) (forking_block : Tezos_shell.State.Block.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let block_header := Tezos_shell.State.Block.header block in
    let genesis :=
      Tezos_storage.Context.compute_testchain_genesis
        (Tezos_shell.State.Block.hash forking_block) in
    let chain_id := Tezos_storage.Context.compute_testchain_chain_id genesis in
    let activated :=
      match child nv with
      | None => false
      | Some (child, _) =>
        Tezos_base__TzPervasives.Block_hash.equal
          (block
            (Tezos_shell.State.Chain.genesis (chain_state (parameters child))))
          genesis
      end in
    let expired := OCaml.Stdlib.lt expiration (timestamp (shell block_header))
      in
    if andb expired activated then
      Tezos_base__TzPervasives.op_gt_gt_eq (shutdown_child nv active_chains)
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_base__TzPervasives.return_unit
          end)
    else
      if
        orb activated
          (orb expired
            (negb
              (Tezos_shell.State.Chain.allow_forked_chain
                (chain_state (parameters nv))))) then
        Tezos_base__TzPervasives.return_unit
      else
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Chain.get_opt
              (Tezos_shell.State.Chain.global_state
                (chain_state (parameters nv))) chain_id)
            (fun function_parameter =>
              match function_parameter with
              | Some chain_state =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.update_testchain block chain_state)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives._return chain_state
                    end)
              | None =>
                let try_init_test_chain
                  (cont :
                  unit ->
                    Lwt.t
                      (Tezos_base__TzPervasives.tzresult
                        Tezos_shell.State.Chain.t))
                  : Lwt.t
                    (Tezos_base__TzPervasives.tzresult Tezos_shell.State.Chain.t) :=
                  let bvp := block_validator_process (parameters nv) in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.Block_validator_process.init_test_chain bvp
                      forking_block)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl genesis_header =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_shell.State.fork_testchain block chain_id
                            genesis genesis_header protocol expiration)
                          (fun chain_state =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_shell.Chain.head chain_state)
                              (fun new_genesis_block =>
                                Tezos_base__TzPervasives.Lwt_watcher.notify
                                  (global_valid_block_input (parameters nv))
                                  new_genesis_block;
                                Tezos_base__TzPervasives.Lwt_watcher.notify
                                  (valid_block_input nv) new_genesis_block;
                                Tezos_base__TzPervasives._return chain_state))
                      |
                        inr
                          (cons
                            (Block_validator_errors.Missing_test_protocol
                              missing_protocol) _) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_shell.Block_validator.fetch_and_compile_protocol
                            (block_validator (parameters nv)) None None
                            missing_protocol)
                          (fun function_parameter =>
                            match function_parameter with
                            | _ => cont tt
                            end)
                      | (inr _) as error => Lwt._return error
                      end) in
                apply try_init_test_chain
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      apply try_init_test_chain
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Could not retrieve test protocol" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "Could not retrieve test protocol" % string)
                          end)
                    end)
              end))
          (fun chain_state =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (spawn_child (Tezos_shell.State.Chain.id chain_state)
                (peer_validator_limits (parameters nv))
                (prevalidator_limits (parameters nv))
                (block_validator (parameters nv))
                (global_valid_block_input (parameters nv))
                (global_chains_input (parameters nv)) (db (parameters nv))
                chain_state (limits (parameters nv)))
              (fun child =>
                set_field;
                Tezos_base__TzPervasives.return_unit)) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.State.Block.test_chain block)
      (fun function_parameter =>
        match function_parameter with
        | (Not_running, _) =>
          Tezos_base__TzPervasives.op_gt_gt_eq (shutdown_child nv active_chains)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        | (Forking _ | Running _, None) => Tezos_base__TzPervasives.return_unit
        |
          (Forking {| protocol := protocol; expiration := expiration |} |
            Running {| protocol := protocol; expiration := expiration |},
            Some forking_block) =>
          create_child block protocol expiration forking_block
        end))
    (fun function_parameter =>
      match function_parameter with
      | inl tt => Lwt.return_unit
      | inr err =>
        Worker.record_event w (Could_not_switch_testchain err);
        Lwt.return_unit
      end).

Definition broadcast_head {A : Type}
  (w : Worker.t A) (previous : Tezos_shell.State.Block.t)
  (block : Tezos_shell.State.Block.t) : Lwt.t unit :=
  let nv := Worker.state w in
  if negb (bootstrapped nv) then
    Lwt.return_unit
  else
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.predecessor block)
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt.return_true
          | Some predecessor =>
            Lwt._return (Tezos_shell.State.Block.equal predecessor previous)
          end))
      (fun successor =>
        if successor then
          Tezos_shell.Distributed_db.Advertise.current_head
            (chain_db (parameters nv)) None None block;
          Lwt.return_unit
        else
          Tezos_shell.Distributed_db.Advertise.current_branch None
            (chain_db (parameters nv))).

Definition safe_get_protocol (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_updater.Registered_protocol.t) :=
  match Tezos_protocol_updater.Registered_protocol.get hash with
  | None =>
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "chain_validator: missing protocol '" % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              "' for the current block." % string
              CamlinternalFormatBasics.End_of_format)))
        "chain_validator: missing protocol '%a' for the current block." % string)
      Tezos_base__TzPervasives.Protocol_hash.pp_short hash
  | Some protocol => Tezos_base__TzPervasives._return protocol
  end.

Definition on_request {A B C : Type}
  (w : Worker.t A) (start_testchain : bool)
  (active_chains : Tezos_base__TzPervasives.Chain_id.Table.t B)
  (spawn_child :
    Tezos_base__TzPervasives.Chain_id.t ->
      Tezos_shell.Peer_validator.limits ->
        Tezos_shell.Prevalidator.limits ->
          Tezos_shell.Block_validator.t ->
            (Tezos_base__TzPervasives.Lwt_watcher.input
              Tezos_shell.State.Block.t) ->
              (Tezos_base__TzPervasives.Lwt_watcher.input
                (Tezos_base__TzPervasives.Chain_id.t * bool)) ->
                Tezos_shell.Distributed_db.t ->
                  Tezos_shell.State.Chain.chain_state ->
                    limits ->
                      Lwt.t
                        (Tezos_base__TzPervasives.tzresult
                          (Types.state * (unit -> Lwt.t unit))))
  (req : Request.t C) : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
  match req with
  | Request.Validated block =>
    let nv := Worker.state w in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Chain.head (chain_state (parameters nv)))
      (fun head =>
        let head_header : Tezos_base__TzPervasives.Block_header.t :=
          Tezos_shell.State.Block.header head
        with head_hash : Tezos_base__TzPervasives.Block_hash.t :=
          Tezos_shell.State.Block.hash head
        with block_header : Tezos_base__TzPervasives.Block_header.t :=
          Tezos_shell.State.Block.header block
        with block_hash : Tezos_base__TzPervasives.Block_hash.t :=
          Tezos_shell.State.Block.hash block in
        Tezos_base__TzPervasives.op_gt_gt_eq
          match prevalidator nv with
          | None => Lwt._return (fitness (shell head_header))
          | Some pv => Tezos_shell.Prevalidator.fitness pv
          end
          (fun context_fitness =>
            let head_fitness := fitness (shell head_header) in
            let new_fitness := fitness (shell block_header) in
            let accepted_head :=
              if
                Tezos_base__TzPervasives.Fitness.op_eq context_fitness
                  head_fitness then
                Tezos_base__TzPervasives.Fitness.op_gt new_fitness head_fitness
              else
                Tezos_base__TzPervasives.Fitness.op_gt_eq new_fitness
                  context_fitness in
            if negb accepted_head then
              Tezos_base__TzPervasives._return Event.Ignored_head
            else
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell.Chain.set_head (chain_state (parameters nv)) block)
                (fun previous =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (may_update_checkpoint (chain_state (parameters nv)) block)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (broadcast_head w previous block)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                match prevalidator nv with
                                | Some old_prevalidator =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_shell.State.Block.protocol_hash block)
                                    (fun new_protocol =>
                                      let old_protocol :=
                                        Tezos_shell.Prevalidator.protocol_hash
                                          old_prevalidator in
                                      if
                                        negb
                                          (Tezos_base__TzPervasives.Protocol_hash.equal
                                            old_protocol new_protocol) then
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (safe_get_protocol new_protocol)
                                          (fun Proto =>
                                            let Proto := projT2 Proto in
                                            match
                                              Tezos_shell.Prevalidator.parameters
                                                old_prevalidator with
                                            | (limits, chain_db) =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (Tezos_shell.Prevalidator.create
                                                  limits Proto chain_db)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | inr errs =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (Log.lwt_log_error
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.Formatting_gen
                                                            (CamlinternalFormatBasics.Open_box
                                                              (CamlinternalFormatBasics.Format
                                                                CamlinternalFormatBasics.End_of_format
                                                                "" % string))
                                                            (CamlinternalFormatBasics.String_literal
                                                              "Failed to reinstantiate prevalidator:"
                                                                % string
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                (CamlinternalFormatBasics.Break
                                                                  "@ " % string
                                                                  1 0)
                                                                (CamlinternalFormatBasics.Alpha
                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                    CamlinternalFormatBasics.Close_box
                                                                    CamlinternalFormatBasics.End_of_format)))))
                                                          "@[Failed to reinstantiate prevalidator:@ %a@]"
                                                            % string)
                                                        Tezos_base__TzPervasives.pp_print_error
                                                        errs)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          set_field;
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (Tezos_shell.Prevalidator.shutdown
                                                              old_prevalidator)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_base__TzPervasives.return_unit
                                                              end)
                                                        end)
                                                  | inl prevalidator =>
                                                    set_field;
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (Tezos_shell.Prevalidator.shutdown
                                                        old_prevalidator)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.return_unit
                                                        end)
                                                  end)
                                            end)
                                      else
                                        Tezos_shell.Prevalidator.flush
                                          old_prevalidator block_hash)
                                | None => Tezos_base__TzPervasives.return_unit
                                end
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (if start_testchain then
                                        may_switch_test_chain w active_chains
                                          spawn_child block
                                      else
                                        Lwt.return_unit)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.Lwt_watcher.notify
                                            (new_head_input nv) block;
                                          if
                                            Tezos_base__TzPervasives.Block_hash.equal
                                              head_hash
                                              (predecessor (shell block_header))
                                            then
                                            Tezos_base__TzPervasives._return
                                              Event.Head_increment
                                          else
                                            Tezos_base__TzPervasives._return
                                              Event.Branch_switch
                                        end)
                                  end)
                            end)
                      end))))
  end.

Definition on_completion {A B : Type}
  (w : Worker.t A) (req : Request.t B) (update : B)
  (request_status : Tezos_shell_services.Worker_types.request_status)
  : Lwt.t unit :=
  match req with
  | Request.Validated block =>
    let fitness := Tezos_shell.State.Block.fitness block in
    let request := Tezos_shell.State.Block.hash block in
    Worker.record_event w
      (Processed_block
        {| request := request; request_status := request_status;
          update := update; fitness := fitness |});
    Lwt.return_unit
  end.

Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
  let nv := Worker.state w in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.Distributed_db.deactivate (chain_db (parameters nv)))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let pvs :=
          Tezos_base__TzPervasives.P2p_peer.Error_table.fold_promises
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                fun pv =>
                  fun acc =>
                    cons
                      (Tezos_base__TzPervasives.op_gt_gt_eq pv
                        (fun function_parameter =>
                          match function_parameter with
                          | inr _ => Lwt.return_unit
                          | inl pv => Tezos_shell.Peer_validator.shutdown pv
                          end)) acc
              end) (active_peers nv) [] in
        Lwt.join
          (cons
            match prevalidator nv with
            | Some prevalidator =>
              Tezos_shell.Prevalidator.shutdown prevalidator
            | None => Lwt.return_unit
            end
            (cons
              (Tezos_base__TzPervasives.Lwt_utils.may
                (fun function_parameter =>
                  match function_parameter with
                  | (_, shutdown) => shutdown tt
                  end) (child nv)) pvs))
      end).

Definition on_launch {A : Type}
  (start_prevalidator : bool) (w : Worker.t (Worker.queue Worker.infinite))
  (function_parameter : A)
  : Types.parameters -> Lwt.t (Tezos_base__TzPervasives.tzresult Types.state) :=
  match function_parameter with
  | _ =>
    fun parameters =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (if start_prevalidator then
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.read_chain_data (chain_state parameters)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  fun function_parameter =>
                    match function_parameter with
                    | {| State.current_head := current_head |} =>
                      Lwt._return current_head
                    end
                end))
            (fun head =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell.State.Block.protocol_hash head)
                (fun head_hash =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (safe_get_protocol head_hash)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl Proto =>
                        let Proto := projT2 Proto in
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_shell.Prevalidator.create
                            (prevalidator_limits parameters) Proto
                            (chain_db parameters))
                          (fun function_parameter =>
                            match function_parameter with
                            | inr err =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Log.lwt_log_error
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          CamlinternalFormatBasics.End_of_format
                                          "" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "Failed to instantiate prevalidator:" %
                                          string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@ " % string 1 0)
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format)))))
                                    "@[Failed to instantiate prevalidator:@ %a@]"
                                      % string)
                                  Tezos_base__TzPervasives.pp_print_error err)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_none
                                  end)
                            | inl prevalidator =>
                              Tezos_base__TzPervasives.return_some prevalidator
                            end)
                      | inr err =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Log.lwt_log_error
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    CamlinternalFormatBasics.End_of_format
                                    "" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "Failed to instantiate prevalidator:" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format)))))
                              "@[Failed to instantiate prevalidator:@ %a@]" %
                                string) Tezos_base__TzPervasives.pp_print_error
                            err)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_none
                            end)
                      end)))
        else
          Tezos_base__TzPervasives.return_none)
        (fun prevalidator =>
          let valid_block_input :=
            Tezos_base__TzPervasives.Lwt_watcher.create_input tt in
          let new_head_input :=
            Tezos_base__TzPervasives.Lwt_watcher.create_input tt in
          match Lwt.wait tt with
          | (bootstrapped_waiter, bootstrapped_wakener) =>
            let nv :=
              {| parameters := parameters;
                bootstrapped :=
                  OCaml.Stdlib.le (bootstrap_threshold (limits parameters)) 0;
                bootstrapped_waiter := bootstrapped_waiter;
                bootstrapped_wakener := bootstrapped_wakener;
                valid_block_input := valid_block_input;
                new_head_input := new_head_input; child := None;
                prevalidator := prevalidator;
                active_peers :=
                  Tezos_base__TzPervasives.P2p_peer.Error_table.create 50;
                bootstrapped_peers :=
                  Tezos_base__TzPervasives.P2p_peer.Table.create 50 |} in
            if bootstrapped nv then
              Lwt.wakeup_later bootstrapped_wakener tt
            else
              tt;
            Tezos_shell.Distributed_db.set_callback (chain_db parameters)
              {|
                notify_branch :=
                  fun peer_id =>
                    fun locator =>
                      Lwt.async
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            apply (with_activated_peer_validator w peer_id)
                              (fun pv =>
                                Tezos_shell.Peer_validator.notify_branch pv
                                  locator;
                                Tezos_base__TzPervasives.return_unit)
                          end);
                notify_head :=
                  fun peer_id =>
                    fun block =>
                      fun ops =>
                        Lwt.async
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (with_activated_peer_validator w peer_id
                                  (fun pv =>
                                    Tezos_shell.Peer_validator.notify_head pv
                                      block;
                                    Tezos_base__TzPervasives.return_unit))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    match prevalidator nv with
                                    | Some prevalidator =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_shell.Prevalidator.notify_operations
                                          prevalidator peer_id ops)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.return_unit
                                          end)
                                    | None =>
                                      Tezos_base__TzPervasives.return_unit
                                    end
                                  end)
                            end);
                disconnection :=
                  fun peer_id =>
                    Lwt.async
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let nv := Worker.state w in
                          match
                            Tezos_base__TzPervasives.P2p_peer.Error_table.find_opt
                              (active_peers nv) peer_id with
                          | None => Tezos_base__TzPervasives.return_unit
                          | Some pv =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question pv
                              (fun pv =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Tezos_shell.Peer_validator.shutdown pv)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end))
                          end
                        end) |};
            Tezos_base__TzPervasives._return nv
          end)
  end.

Fixpoint create
  (start_prevalidator : bool) (start_testchain : bool)
  (active_chains :
    Tezos_base__TzPervasives.Chain_id.Table.t
      (Worker.t (Worker.queue Worker.infinite)))
  (parent : option Tezos_base__TzPervasives.Chain_id.t)
  (block_validator_process : Tezos_shell.Block_validator_process.t)
  (peer_validator_limits : Tezos_shell.Peer_validator.limits)
  (prevalidator_limits : Tezos_shell.Prevalidator.limits)
  (block_validator : Tezos_shell.Block_validator.t)
  (global_valid_block_input :
    Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t)
  (global_chains_input :
    Tezos_base__TzPervasives.Lwt_watcher.input
      (Tezos_base__TzPervasives.Chain_id.t * bool))
  (db : Tezos_shell.Distributed_db.t)
  (chain_state : Tezos_shell.State.Chain.chain_state) (limits : limits)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
  let spawn_child
    (parent : Tezos_base__TzPervasives.Chain_id.t) (pvl :
    Tezos_shell.Peer_validator.limits) (pl : Tezos_shell.Prevalidator.limits)
    (bl : Tezos_shell.Block_validator.t) (gvbi :
    Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t) (gci :
    Tezos_base__TzPervasives.Lwt_watcher.input
      (Tezos_base__TzPervasives.Chain_id.t * bool)) (db :
    Tezos_shell.Distributed_db.t) (n : Tezos_shell.State.Chain.chain_state) (l :
    limits)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Worker.Types.state * (unit -> Lwt.t unit))) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (create start_prevalidator start_testchain active_chains (Some parent)
        block_validator_process pvl pl bl gvbi gci db n l)
      (fun w =>
        Tezos_base__TzPervasives._return
          ((Worker.state w),
            (fun function_parameter =>
              match function_parameter with
              | tt => Worker.shutdown w
              end))) in
  let Handlers :=
    existT _ unit
      {|
        Worker.HANDLERS.on_launch := on_launch start_prevalidator
        |} in
  let parameters :=
    {| parent := parent; db := db; chain_state := chain_state;
      chain_db := Tezos_shell.Distributed_db.activate db chain_state;
      block_validator := block_validator;
      block_validator_process := block_validator_process;
      global_valid_block_input := global_valid_block_input;
      global_chains_input := global_chains_input;
      prevalidator_limits := prevalidator_limits;
      peer_validator_limits := peer_validator_limits; limits := limits |} in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.Chain.init_head chain_state)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Worker.launch table None (worker_limits prevalidator_limits)
            (Tezos_shell.State.Chain.id chain_state) parameters Handlers)
          (fun w =>
            Tezos_base__TzPervasives.Chain_id.Table.add active_chains
              (Tezos_shell.State.Chain.id chain_state) w;
            Tezos_base__TzPervasives.Lwt_watcher.notify global_chains_input
              ((Tezos_shell.State.Chain.id chain_state), true);
            Tezos_base__TzPervasives._return w)
      end).

Definition create
  (start_prevalidator : bool) (start_testchain : bool)
  (active_chains :
    Tezos_base__TzPervasives.Chain_id.Table.t
      (Worker.t (Worker.queue Worker.infinite)))
  (block_validator_process : Tezos_shell.Block_validator_process.t)
  (peer_validator_limits : Tezos_shell.Peer_validator.limits)
  (prevalidator_limits : Tezos_shell.Prevalidator.limits)
  (block_validator : Tezos_shell.Block_validator.t)
  (global_valid_block_input :
    Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t)
  (global_chains_input :
    Tezos_base__TzPervasives.Lwt_watcher.input
      (Tezos_base__TzPervasives.Chain_id.t * bool))
  (global_db : Tezos_shell.Distributed_db.t)
  (state : Tezos_shell.State.Chain.chain_state) (limits : limits)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
  create start_prevalidator start_testchain active_chains None
    block_validator_process peer_validator_limits prevalidator_limits
    block_validator global_valid_block_input global_chains_input global_db state
    limits.

Definition chain_id {A : Type} (w : Worker.t A)
  : Tezos_base__TzPervasives.Chain_id.t :=
  match Worker.state w with
  | {| parameters := {| chain_state := chain_state |} |} =>
    Tezos_shell.State.Chain.id chain_state
  end.

Definition chain_state {A : Type} (w : Worker.t A)
  : Tezos_shell.State.Chain.t :=
  match Worker.state w with
  | {| parameters := {| chain_state := chain_state |} |} => chain_state
  end.

Definition prevalidator {A : Type} (w : Worker.t A)
  : option Tezos_shell.Prevalidator.t :=
  match Worker.state w with
  | {| prevalidator := prevalidator |} => prevalidator
  end.

Definition chain_db {A : Type} (w : Worker.t A)
  : Tezos_shell.Distributed_db.chain_db :=
  match Worker.state w with
  | {| parameters := {| chain_db := chain_db |} |} => chain_db
  end.

Definition child {A : Type} (w : Worker.t A)
  : option (Worker.t (Worker.queue Worker.infinite)) :=
  match child (Worker.state w) with
  | None => None
  | Some ({| parameters := {| chain_state := chain_state |} |}, _) => try
  end.

Definition assert_fitness_increases {A : Type}
  (op_star_o_p_t_star : option bool)
  : (Worker.t A) ->
    Tezos_base__TzPervasives.Block_header.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let force :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun w =>
    fun distant_header =>
      let pv := Worker.state w in
      let chain_state :=
        Tezos_shell.Distributed_db.chain_state (chain_db (parameters pv)) in
      Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.head chain_state)
        (fun local_header =>
          Tezos_base__TzPervasives.fail_when
            (andb (negb force)
              (OCaml.Stdlib.le
                (Tezos_base__TzPervasives.Fitness.compare
                  (fitness (Block_header.shell distant_header))
                  (Tezos_shell.State.Block.fitness local_header)) 0))
            (Tezos_base__TzPervasives.failure
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Fitness too low" % string
                  CamlinternalFormatBasics.End_of_format)
                "Fitness too low" % string))).

Definition assert_checkpoint {A : Type}
  (w : Worker.t A) (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let chain_state :=
    Tezos_shell.Distributed_db.chain_state (chain_db (parameters pv)) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.acceptable_block chain_state header)
    (fun acceptable =>
      Tezos_base__TzPervasives.fail_unless acceptable
        (Validation_errors.Checkpoint_error
          (Tezos_base__TzPervasives.Block_header.hash header) None)).

Definition validate_block
  (w : Worker.t (Worker.queue Worker.infinite)) (force : option bool)
  (hash : Tezos_base__TzPervasives.Block_hash.t)
  (block : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.t)) :=
  let nv := Worker.state w in
  Tezos_base__TzPervasives.Block_hash.equal hash
    (Tezos_base__TzPervasives.Block_header.hash block);
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (assert_fitness_increases force w block)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (assert_checkpoint w block)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_shell.Block_validator.validate
                (block_validator (parameters nv)) (Some (Worker.canceler w))
                None (Some (notify_new_block w)) (chain_db (parameters nv)) hash
                block operations
            end)
      end).

Definition bootstrapped {A : Type} (w : Worker.t A) : Lwt.t unit :=
  match Worker.state w with
  | {| bootstrapped_waiter := bootstrapped_waiter |} =>
    Lwt.protected bootstrapped_waiter
  end.

Definition valid_block_watcher {A : Type} (w : Worker.t A)
  : (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  match Worker.state w with
  | {| valid_block_input := valid_block_input |} =>
    Tezos_base__TzPervasives.Lwt_watcher.create_stream valid_block_input
  end.

Definition new_head_watcher {A : Type} (w : Worker.t A)
  : (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  match Worker.state w with
  | {| new_head_input := new_head_input |} =>
    Tezos_base__TzPervasives.Lwt_watcher.create_stream new_head_input
  end.

Definition status {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
  Worker.status.

Definition information {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_information :=
  Worker.information.

Definition running_workers (function_parameter : unit)
  : list (Worker.Name.t * (Worker.t (Worker.queue Worker.infinite))) :=
  match function_parameter with
  | tt => Worker.list table
  end.

Definition pending_requests {A : Type} (t : Worker.t (Worker.queue A))
  : list (Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
  Worker.Queue.pending_requests t.

Definition pending_requests_length {A : Type} (t : Worker.t (Worker.queue A))
  : Z := Worker.Queue.pending_requests_length t.

Definition current_request {A : Type} (t : Worker.t A)
  : option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
  Worker.current_request t.

Definition last_events {A : Type}
  : (Worker.t A) ->
    list (Tezos_base__TzPervasives.Internal_event.level * (list Worker.Event.t)) :=
  Worker.last_events.

Definition ddb_information {A : Type} (t : Worker.t A)
  : Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
  let state := Worker.state t in
  let ddb := chain_db (parameters state) in
  Tezos_shell.Distributed_db.information ddb.
src/lib_shell/chain_validator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type limits = {bootstrap_threshold : int; worker_limits : Worker_types.limits}

val create :
  start_prevalidator:bool ->
  start_testchain:bool ->
  active_chains:t Chain_id.Table.t ->
  block_validator_process:Block_validator_process.t ->
  Peer_validator.limits ->
  Prevalidator.limits ->
  Block_validator.t ->
  State.Block.t Lwt_watcher.input ->
  (Chain_id.t * bool) Lwt_watcher.input ->
  Distributed_db.t ->
  State.Chain.t ->
  limits ->
  t tzresult Lwt.t

val bootstrapped : t -> unit Lwt.t

val chain_id : t -> Chain_id.t

val chain_state : t -> State.Chain.t

val prevalidator : t -> Prevalidator.t option

val chain_db : t -> Distributed_db.chain_db

val child : t -> t option

val validate_block :
  t ->
  ?force:bool ->
  Block_hash.t ->
  Block_header.t ->
  Operation.t list list ->
  State.Block.t option tzresult Lwt.t

val shutdown : t -> unit Lwt.t

val valid_block_watcher : t -> State.Block.t Lwt_stream.t * Lwt_watcher.stopper

val new_head_watcher : t -> State.Block.t Lwt_stream.t * Lwt_watcher.stopper

val running_workers : unit -> (Chain_id.t * t) list

val status : t -> Worker_types.worker_status

val information : t -> Worker_types.worker_information

val pending_requests :
  t -> (Time.System.t * Chain_validator_worker_state.Request.view) list

val pending_requests_length : t -> int

val current_request :
  t ->
  (Time.System.t * Time.System.t * Chain_validator_worker_state.Request.view)
  option

val last_events :
  t -> (Internal_event.level * Chain_validator_worker_state.Event.t list) list

val ddb_information :
  t -> Chain_validator_worker_state.Distributed_db_state.view
src/lib_shell/chain_validator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Record limits := {
  bootstrap_threshold : Z;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Parameter create :
bool ->
  bool ->
    (Tezos_base__TzPervasives.Chain_id.Table.t t) ->
      Tezos_shell.Block_validator_process.t ->
        Tezos_shell.Peer_validator.limits ->
          Tezos_shell.Prevalidator.limits ->
            Tezos_shell.Block_validator.t ->
              (Tezos_base__TzPervasives.Lwt_watcher.input
                Tezos_shell.State.Block.t) ->
                (Tezos_base__TzPervasives.Lwt_watcher.input
                  (Tezos_base__TzPervasives.Chain_id.t * bool)) ->
                  Tezos_shell.Distributed_db.t ->
                    Tezos_shell.State.Chain.t ->
                      limits -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter bootstrapped : t -> Lwt.t unit.

Parameter chain_id : t -> Tezos_base__TzPervasives.Chain_id.t.

Parameter chain_state : t -> Tezos_shell.State.Chain.t.

Parameter prevalidator : t -> option Tezos_shell.Prevalidator.t.

Parameter chain_db : t -> Tezos_shell.Distributed_db.chain_db.

Parameter child : t -> option t.

Parameter validate_block :
t ->
  (option bool) ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Tezos_base__TzPervasives.Block_header.t ->
        (list (list Tezos_base__TzPervasives.Operation.t)) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_shell.State.Block.t)).

Parameter shutdown : t -> Lwt.t unit.

Parameter valid_block_watcher :
t ->
  (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper.

Parameter new_head_watcher :
t ->
  (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper.

Parameter running_workers :
unit -> list (Tezos_base__TzPervasives.Chain_id.t * t).

Parameter status : t -> Tezos_shell_services.Worker_types.worker_status.

Parameter information :
t -> Tezos_shell_services.Worker_types.worker_information.

Parameter pending_requests :
t ->
  list
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Chain_validator_worker_state.Request.view).

Parameter pending_requests_length : t -> Z.

Parameter current_request :
t ->
  option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Chain_validator_worker_state.Request.view).

Parameter last_events :
t ->
  list
    (Tezos_base__TzPervasives.Internal_event.level *
      (list Tezos_shell_services.Chain_validator_worker_state.Event.t)).

Parameter ddb_information :
t -> Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view.
src/lib_shell/distributed_db.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Message = Distributed_db_message

module Logging = Internal_event.Legacy_logging.Make (struct
  let name = "node.distributed_db"
end)

type p2p = (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.net

type connection =
  (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.connection

type 'a request_param = {
  p2p : (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.t;
  data : 'a;
  active : unit -> P2p_peer.Set.t;
  send : P2p_peer.Id.t -> Message.t -> unit;
}

module Make_raw (Hash : sig
  type t

  val name : string

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit

  module Logging : sig
    val tag : t Tag.def
  end
end)
(Disk_table : Distributed_db_functors.DISK_TABLE with type key := Hash.t)
(Memory_table : Distributed_db_functors.MEMORY_TABLE with type key := Hash.t)
(Request_message : sig
  type param

  val max_length : int

  val initial_delay : Time.System.Span.t

  val forge : param -> Hash.t list -> Message.t
end)
(Precheck : Distributed_db_functors.PRECHECK
              with type key := Hash.t
               and type value := Disk_table.value) =
struct
  module Request = struct
    type param = Request_message.param request_param

    let active {active; _} = active ()

    let initial_delay = Request_message.initial_delay

    let rec send state gid keys =
      let (first_keys, keys) = List.split_n Request_message.max_length keys in
      let msg = Request_message.forge state.data first_keys in
      state.send gid msg ;
      let open Peer_metadata in
      let (req : requests_kind) =
        match msg with
        | Get_current_branch _ ->
            Branch
        | Get_current_head _ ->
            Head
        | Get_block_headers _ ->
            Block_header
        | Get_operations _ ->
            Operations
        | Get_protocols _ ->
            Protocols
        | Get_operation_hashes_for_blocks _ ->
            Operation_hashes_for_block
        | Get_operations_for_blocks _ ->
            Operations_for_block
        | _ ->
            Other
      in
      let meta = P2p.get_peer_metadata state.p2p gid in
      Peer_metadata.incr meta @@ Scheduled_request req ;
      if keys <> [] then send state gid keys
  end

  module Scheduler =
    Distributed_db_functors.Make_request_scheduler (Hash) (Memory_table)
      (Request)
  module Table =
    Distributed_db_functors.Make_table (Hash) (Disk_table) (Memory_table)
      (Scheduler)
      (Precheck)

  type t = {scheduler : Scheduler.t; table : Table.t}

  let state_of_t {scheduler; table} =
    let table_length = Table.memory_table_length table in
    let scheduler_length = Scheduler.memory_table_length scheduler in
    {
      Chain_validator_worker_state.Distributed_db_state.table_length;
      scheduler_length;
    }

  let create ?global_input request_param param =
    let scheduler = Scheduler.create request_param in
    let table = Table.create ?global_input scheduler param in
    {scheduler; table}

  let shutdown {scheduler; _} =
    Logging.lwt_log_notice
      "Shutting down the distributed data-base scheduler..."
    >>= fun () -> Scheduler.shutdown scheduler
end

module Fake_operation_storage = struct
  type store = State.Chain.t

  type value = Operation.t

  let known _ _ = Lwt.return_false

  let read _ _ = Lwt.return (Error_monad.error_exn Not_found)

  let read_opt _ _ = Lwt.return_none
end

module Raw_operation =
  Make_raw (Operation_hash) (Fake_operation_storage) (Operation_hash.Table)
    (struct
      type param = unit

      let max_length = 10

      let initial_delay = Time.System.Span.of_seconds_exn 0.5

      let forge () keys = Message.Get_operations keys
    end)
    (struct
      type param = unit

      type notified_value = Operation.t

      let precheck _ _ v = Some v
    end)

module Block_header_storage = struct
  type store = State.Chain.t

  type value = Block_header.t

  let known = State.Block.known_valid

  let read chain_state h =
    State.Block.read chain_state h >>=? fun b -> return (State.Block.header b)

  let read_opt chain_state h =
    State.Block.read_opt chain_state h
    >>= fun b -> Lwt.return (Option.map ~f:State.Block.header b)
end

module Raw_block_header =
  Make_raw (Block_hash) (Block_header_storage) (Block_hash.Table)
    (struct
      type param = unit

      let max_length = 10

      let initial_delay = Time.System.Span.of_seconds_exn 0.5

      let forge () keys = Message.Get_block_headers keys
    end)
    (struct
      type param = unit

      type notified_value = Block_header.t

      let precheck _ _ v = Some v
    end)

module Operation_hashes_storage = struct
  type store = State.Chain.t

  type value = Operation_hash.t list

  let known chain_state (h, _) = State.Block.known_valid chain_state h

  let read chain_state (h, i) =
    State.Block.read chain_state h
    >>=? fun b ->
    State.Block.operation_hashes b i >>= fun (ops, _) -> return ops

  let read_opt chain_state (h, i) =
    State.Block.read_opt chain_state h
    >>= function
    | None ->
        Lwt.return_none
    | Some b ->
        State.Block.operation_hashes b i
        >>= fun (ops, _) -> Lwt.return_some ops
end

module Operations_table = Hashtbl.Make (struct
  type t = Block_hash.t * int

  let hash = Hashtbl.hash

  let equal (b1, i1) (b2, i2) = Block_hash.equal b1 b2 && i1 = i2
end)

module Raw_operation_hashes = struct
  include Make_raw
            (struct
              type t = Block_hash.t * int

              let name = "operation_hashes"

              let pp ppf (h, n) = Format.fprintf ppf "%a:%d" Block_hash.pp h n

              let encoding =
                let open Data_encoding in
                obj2 (req "block" Block_hash.encoding) (req "index" uint16)

              module Logging = struct
                let tag = Tag.def ~doc:"Operation hashes" "operation_hashes" pp
              end
            end)
            (Operation_hashes_storage)
            (Operations_table)
            (struct
              type param = unit

              let max_length = 10

              let initial_delay = Time.System.Span.of_seconds_exn 1.

              let forge () keys = Message.Get_operation_hashes_for_blocks keys
            end)
            (struct
              type param = Operation_list_list_hash.t

              type notified_value =
                Operation_hash.t list * Operation_list_list_hash.path

              let precheck (_block, expected_ofs) expected_hash (ops, path) =
                let (received_hash, received_ofs) =
                  Operation_list_list_hash.check_path
                    path
                    (Operation_list_hash.compute ops)
                in
                if
                  received_ofs = expected_ofs
                  && Operation_list_list_hash.compare
                       expected_hash
                       received_hash
                     = 0
                then Some ops
                else None
            end)

  let clear_all table hash n =
    List.iter (fun i -> Table.clear_or_cancel table (hash, i)) (0 -- (n - 1))
end

module Operations_storage = struct
  type store = State.Chain.t

  type value = Operation.t list

  let known chain_state (h, _) = State.Block.known_valid chain_state h

  let read chain_state (h, i) =
    State.Block.read chain_state h
    >>=? fun b -> State.Block.operations b i >>= fun (ops, _) -> return ops

  let read_opt chain_state (h, i) =
    State.Block.read_opt chain_state h
    >>= function
    | None ->
        Lwt.return_none
    | Some b ->
        State.Block.operations b i >>= fun (ops, _) -> Lwt.return_some ops
end

module Raw_operations = struct
  include Make_raw
            (struct
              type t = Block_hash.t * int

              let name = "operations"

              let pp ppf (h, n) = Format.fprintf ppf "%a:%d" Block_hash.pp h n

              let encoding =
                let open Data_encoding in
                obj2 (req "block" Block_hash.encoding) (req "index" uint16)

              module Logging = struct
                let tag = Tag.def ~doc:"Operations" "operations" pp
              end
            end)
            (Operations_storage)
            (Operations_table)
            (struct
              type param = unit

              let max_length = 10

              let initial_delay = Time.System.Span.of_seconds_exn 1.

              let forge () keys = Message.Get_operations_for_blocks keys
            end)
            (struct
              type param = Operation_list_list_hash.t

              type notified_value =
                Operation.t list * Operation_list_list_hash.path

              let precheck (_block, expected_ofs) expected_hash (ops, path) =
                let (received_hash, received_ofs) =
                  Operation_list_list_hash.check_path
                    path
                    (Operation_list_hash.compute (List.map Operation.hash ops))
                in
                if
                  received_ofs = expected_ofs
                  && Operation_list_list_hash.compare
                       expected_hash
                       received_hash
                     = 0
                then Some ops
                else None
            end)

  let clear_all table hash n =
    List.iter (fun i -> Table.clear_or_cancel table (hash, i)) (0 -- (n - 1))
end

module Protocol_storage = struct
  type store = State.t

  type value = Protocol.t

  let known = State.Protocol.known

  let read = State.Protocol.read

  let read_opt = State.Protocol.read_opt
end

module Raw_protocol =
  Make_raw (Protocol_hash) (Protocol_storage) (Protocol_hash.Table)
    (struct
      type param = unit

      let initial_delay = Time.System.Span.of_seconds_exn 10.

      let max_length = 10

      let forge () keys = Message.Get_protocols keys
    end)
    (struct
      type param = unit

      type notified_value = Protocol.t

      let precheck _ _ v = Some v
    end)

type callback = {
  notify_branch : P2p_peer.Id.t -> Block_locator.t -> unit;
  notify_head : P2p_peer.Id.t -> Block_header.t -> Mempool.t -> unit;
  disconnection : P2p_peer.Id.t -> unit;
}

type db = {
  p2p : p2p;
  p2p_readers : p2p_reader P2p_peer.Table.t;
  disk : State.t;
  active_chains : chain_db Chain_id.Table.t;
  protocol_db : Raw_protocol.t;
  block_input : (Block_hash.t * Block_header.t) Lwt_watcher.input;
  operation_input : (Operation_hash.t * Operation.t) Lwt_watcher.input;
}

and chain_db = {
  chain_state : State.Chain.t;
  global_db : db;
  operation_db : Raw_operation.t;
  block_header_db : Raw_block_header.t;
  operation_hashes_db : Raw_operation_hashes.t;
  operations_db : Raw_operations.t;
  mutable callback : callback;
  active_peers : P2p_peer.Set.t ref;
  active_connections : p2p_reader P2p_peer.Table.t;
}

and p2p_reader = {
  gid : P2p_peer.Id.t;
  conn : connection;
  peer_active_chains : chain_db Chain_id.Table.t;
  canceler : Lwt_canceler.t;
  mutable worker : unit Lwt.t;
}

let noop_callback =
  {
    notify_branch = (fun _gid _locator -> ());
    notify_head = (fun _gid _block _ops -> ());
    disconnection = (fun _gid -> ());
  }

type t = db

let state {disk; _} = disk

let chain_state {chain_state; _} = chain_state

let db {global_db; _} = global_db

let information
    ({ global_db = {p2p_readers; active_chains; _};
       operation_db;
       operations_db;
       block_header_db;
       operation_hashes_db;
       active_connections;
       active_peers;
       _ } :
      chain_db) =
  {
    Chain_validator_worker_state.Distributed_db_state.p2p_readers_length =
      P2p_peer.Table.length p2p_readers;
    active_chains_length = Chain_id.Table.length active_chains;
    operation_db = Raw_operation.state_of_t operation_db;
    operations_db = Raw_operations.state_of_t operations_db;
    block_header_db = Raw_block_header.state_of_t block_header_db;
    operations_hashed_db = Raw_operation_hashes.state_of_t operation_hashes_db;
    active_connections_length = P2p_peer.Table.length active_connections;
    active_peers_length = P2p_peer.Set.cardinal !active_peers;
  }

let my_peer_id chain_db = P2p.peer_id chain_db.global_db.p2p

let get_peer_metadata chain_db = P2p.get_peer_metadata chain_db.global_db.p2p

let read_block_header {disk; _} h =
  State.read_block disk h
  >>= function
  | Some b ->
      Lwt.return_some (State.Block.chain_id b, State.Block.header b)
  | None ->
      Lwt.return_none

let find_pending_block_header {peer_active_chains; _} h =
  Chain_id.Table.fold
    (fun _chain_id chain_db acc ->
      match acc with
      | Some _ ->
          acc
      | None
        when Raw_block_header.Table.pending chain_db.block_header_db.table h ->
          Some chain_db
      | None ->
          None)
    peer_active_chains
    None

let find_pending_operations {peer_active_chains; _} h i =
  Chain_id.Table.fold
    (fun _chain_id chain_db acc ->
      match acc with
      | Some _ ->
          acc
      | None
        when Raw_operations.Table.pending chain_db.operations_db.table (h, i)
        ->
          Some chain_db
      | None ->
          None)
    peer_active_chains
    None

let find_pending_operation_hashes {peer_active_chains; _} h i =
  Chain_id.Table.fold
    (fun _chain_id chain_db acc ->
      match acc with
      | Some _ ->
          acc
      | None
        when Raw_operation_hashes.Table.pending
               chain_db.operation_hashes_db.table
               (h, i) ->
          Some chain_db
      | None ->
          None)
    peer_active_chains
    None

let find_pending_operation {peer_active_chains; _} h =
  Chain_id.Table.fold
    (fun _chain_id chain_db acc ->
      match acc with
      | Some _ ->
          acc
      | None when Raw_operation.Table.pending chain_db.operation_db.table h ->
          Some chain_db
      | None ->
          None)
    peer_active_chains
    None

let read_operation {active_chains; _} h =
  Chain_id.Table.fold
    (fun chain_id chain_db acc ->
      acc
      >>= function
      | Some _ ->
          acc
      | None -> (
          Raw_operation.Table.read_opt chain_db.operation_db.table h
          >>= function
          | None -> Lwt.return_none | Some bh -> Lwt.return_some (chain_id, bh)
          ))
    active_chains
    Lwt.return_none

module P2p_reader = struct
  let may_activate global_db state chain_id f =
    match Chain_id.Table.find_opt state.peer_active_chains chain_id with
    | Some chain_db ->
        f chain_db
    | None -> (
      match Chain_id.Table.find_opt global_db.active_chains chain_id with
      | Some chain_db ->
          chain_db.active_peers :=
            P2p_peer.Set.add state.gid !(chain_db.active_peers) ;
          P2p_peer.Table.add chain_db.active_connections state.gid state ;
          Chain_id.Table.add state.peer_active_chains chain_id chain_db ;
          f chain_db
      | None ->
          let meta = P2p.get_peer_metadata global_db.p2p state.gid in
          Peer_metadata.incr meta Unactivated_chain ;
          Lwt.return_unit )

  let deactivate state chain_db =
    chain_db.callback.disconnection state.gid ;
    chain_db.active_peers :=
      P2p_peer.Set.remove state.gid !(chain_db.active_peers) ;
    P2p_peer.Table.remove chain_db.active_connections state.gid

  (* check if the chain advertized by a peer is (still) active *)
  let may_handle global_db state chain_id f =
    match Chain_id.Table.find_opt state.peer_active_chains chain_id with
    | None ->
        let meta = P2p.get_peer_metadata global_db.p2p state.gid in
        Peer_metadata.incr meta Inactive_chain ;
        Lwt.return_unit
    | Some chain_db ->
        f chain_db

  let may_handle_global global_db chain_id f =
    match Chain_id.Table.find_opt global_db.active_chains chain_id with
    | None ->
        Lwt.return_unit
    | Some chain_db ->
        f chain_db

  module Handle_msg_Logging =
  Internal_event.Legacy_logging.Make_semantic (struct
    let name = "node.distributed_db.p2p_reader"
  end)

  let soon () =
    let now = Systime_os.now () in
    match Ptime.add_span now (Ptime.Span.of_int_s 15) with
    | Some s ->
        s
    | None ->
        invalid_arg "Distributed_db.handle_msg: end of time"

  let handle_msg global_db state msg =
    let open Message in
    let open Handle_msg_Logging in
    let meta = P2p.get_peer_metadata global_db.p2p state.gid in
    lwt_debug
      Tag.DSL.(
        fun f ->
          f "Read message from %a: %a"
          -% t event "read_message"
          -% a P2p_peer.Id.Logging.tag state.gid
          -% a Message.Logging.tag msg)
    >>= fun () ->
    match msg with
    | Get_current_branch chain_id ->
        Peer_metadata.incr meta @@ Received_request Branch ;
        may_handle_global global_db chain_id
        @@ fun chain_db ->
        if not (Chain_id.Table.mem state.peer_active_chains chain_id) then
          Peer_metadata.update_requests meta Branch
          @@ P2p.try_send global_db.p2p state.conn
          @@ Get_current_branch chain_id ;
        let seed =
          {
            Block_locator.receiver_id = state.gid;
            sender_id = my_peer_id chain_db;
          }
        in
        Chain.locator chain_db.chain_state seed
        >>= fun locator ->
        Peer_metadata.update_responses meta Branch
        @@ P2p.try_send global_db.p2p state.conn
        @@ Current_branch (chain_id, locator) ;
        Lwt.return_unit
    | Current_branch (chain_id, locator) ->
        may_activate global_db state chain_id
        @@ fun chain_db ->
        let (head, hist) = (locator :> Block_header.t * Block_hash.t list) in
        Lwt_list.exists_p
          (State.Block.known_invalid chain_db.chain_state)
          (Block_header.hash head :: hist)
        >>= fun known_invalid ->
        if known_invalid then (
          P2p.disconnect global_db.p2p state.conn
          >>= fun () ->
          P2p.greylist_peer global_db.p2p state.gid ;
          Lwt.return_unit )
        else if Time.System.(soon () < of_protocol_exn head.shell.timestamp)
        then (
          Peer_metadata.incr meta Future_block ;
          lwt_log_notice
            Tag.DSL.(
              fun f ->
                f "Received future block %a from peer %a."
                -% t event "received_future_block"
                -% a Block_hash.Logging.tag (Block_header.hash head)
                -% a P2p_peer.Id.Logging.tag state.gid) )
        else (
          chain_db.callback.notify_branch state.gid locator ;
          (* TODO discriminate between received advertisements
             and responses? *)
          Peer_metadata.incr meta @@ Received_advertisement Branch ;
          Lwt.return_unit )
    | Deactivate chain_id ->
        may_handle global_db state chain_id
        @@ fun chain_db ->
        deactivate state chain_db ;
        Chain_id.Table.remove state.peer_active_chains chain_id ;
        Lwt.return_unit
    | Get_current_head chain_id ->
        may_handle global_db state chain_id
        @@ fun chain_db ->
        Peer_metadata.incr meta @@ Received_request Head ;
        let {Connection_metadata.disable_mempool; _} =
          P2p.connection_remote_metadata chain_db.global_db.p2p state.conn
        in
        ( if disable_mempool then
          Chain.head chain_db.chain_state
          >>= fun head -> Lwt.return (State.Block.header head, Mempool.empty)
        else State.Current_mempool.get chain_db.chain_state )
        >>= fun (head, mempool) ->
        (* TODO bound the sent mempool size *)
        Peer_metadata.update_responses meta Head
        @@ P2p.try_send global_db.p2p state.conn
        @@ Current_head (chain_id, head, mempool) ;
        Lwt.return_unit
    | Current_head (chain_id, header, mempool) ->
        may_handle global_db state chain_id
        @@ fun chain_db ->
        let head = Block_header.hash header in
        State.Block.known_invalid chain_db.chain_state head
        >>= fun known_invalid ->
        let {Connection_metadata.disable_mempool; _} =
          P2p.connection_local_metadata chain_db.global_db.p2p state.conn
        in
        let known_invalid =
          known_invalid || (disable_mempool && mempool <> Mempool.empty)
          (* A non-empty mempool was received while mempool is desactivated,
               so the message is ignored.
               This should probably warrant a reduction of the sender's score. *)
        in
        if known_invalid then (
          P2p.disconnect global_db.p2p state.conn
          >>= fun () ->
          P2p.greylist_peer global_db.p2p state.gid ;
          Lwt.return_unit )
        else if Time.System.(soon () < of_protocol_exn header.shell.timestamp)
        then (
          Peer_metadata.incr meta Future_block ;
          lwt_log_notice
            Tag.DSL.(
              fun f ->
                f "Received future block %a from peer %a."
                -% t event "received_future_block"
                -% a Block_hash.Logging.tag head
                -% a P2p_peer.Id.Logging.tag state.gid) )
        else (
          chain_db.callback.notify_head state.gid header mempool ;
          (* TODO discriminate between received advertisements
             and responses? *)
          Peer_metadata.incr meta @@ Received_advertisement Head ;
          Lwt.return_unit )
    | Get_block_headers hashes ->
        Peer_metadata.incr meta @@ Received_request Block_header ;
        Lwt_list.iter_p
          (fun hash ->
            read_block_header global_db hash
            >>= function
            | None ->
                Peer_metadata.incr meta @@ Unadvertised Block ;
                Lwt.return_unit
            | Some (_chain_id, header) ->
                Peer_metadata.update_responses meta Block_header
                @@ P2p.try_send global_db.p2p state.conn
                @@ Block_header header ;
                Lwt.return_unit)
          hashes
    | Block_header block -> (
        let hash = Block_header.hash block in
        match find_pending_block_header state hash with
        | None ->
            Peer_metadata.incr meta Unexpected_response ;
            Lwt.return_unit
        | Some chain_db ->
            Raw_block_header.Table.notify
              chain_db.block_header_db.table
              state.gid
              hash
              block
            >>= fun () ->
            Peer_metadata.incr meta @@ Received_response Block_header ;
            Lwt.return_unit )
    | Get_operations hashes ->
        Peer_metadata.incr meta @@ Received_request Operations ;
        Lwt_list.iter_p
          (fun hash ->
            read_operation global_db hash
            >>= function
            | None ->
                Peer_metadata.incr meta @@ Unadvertised Operations ;
                Lwt.return_unit
            | Some (_chain_id, op) ->
                Peer_metadata.update_responses meta Operations
                @@ P2p.try_send global_db.p2p state.conn
                @@ Operation op ;
                Lwt.return_unit)
          hashes
    | Operation operation -> (
        let hash = Operation.hash operation in
        match find_pending_operation state hash with
        | None ->
            Peer_metadata.incr meta Unexpected_response ;
            Lwt.return_unit
        | Some chain_db ->
            Raw_operation.Table.notify
              chain_db.operation_db.table
              state.gid
              hash
              operation
            >>= fun () ->
            Peer_metadata.incr meta @@ Received_response Operations ;
            Lwt.return_unit )
    | Get_protocols hashes ->
        Peer_metadata.incr meta @@ Received_request Protocols ;
        Lwt_list.iter_p
          (fun hash ->
            State.Protocol.read_opt global_db.disk hash
            >>= function
            | None ->
                Peer_metadata.incr meta @@ Unadvertised Protocol ;
                Lwt.return_unit
            | Some p ->
                Peer_metadata.update_responses meta Protocols
                @@ P2p.try_send global_db.p2p state.conn
                @@ Protocol p ;
                Lwt.return_unit)
          hashes
    | Protocol protocol ->
        let hash = Protocol.hash protocol in
        Raw_protocol.Table.notify
          global_db.protocol_db.table
          state.gid
          hash
          protocol
        >>= fun () ->
        Peer_metadata.incr meta @@ Received_response Protocols ;
        Lwt.return_unit
    | Get_operation_hashes_for_blocks blocks ->
        Peer_metadata.incr meta @@ Received_request Operation_hashes_for_block ;
        Lwt_list.iter_p
          (fun (hash, ofs) ->
            State.read_block global_db.disk hash
            >>= function
            | None ->
                Lwt.return_unit
            | Some block ->
                State.Block.operation_hashes block ofs
                >>= fun (hashes, path) ->
                Peer_metadata.update_responses meta Operation_hashes_for_block
                @@ P2p.try_send global_db.p2p state.conn
                @@ Operation_hashes_for_block (hash, ofs, hashes, path) ;
                Lwt.return_unit)
          blocks
    | Operation_hashes_for_block (block, ofs, ops, path) -> (
      match find_pending_operation_hashes state block ofs with
      | None ->
          Peer_metadata.incr meta Unexpected_response ;
          Lwt.return_unit
      | Some chain_db ->
          Raw_operation_hashes.Table.notify
            chain_db.operation_hashes_db.table
            state.gid
            (block, ofs)
            (ops, path)
          >>= fun () ->
          Peer_metadata.incr meta
          @@ Received_response Operation_hashes_for_block ;
          Lwt.return_unit )
    | Get_operations_for_blocks blocks ->
        Peer_metadata.incr meta @@ Received_request Operations_for_block ;
        Lwt_list.iter_p
          (fun (hash, ofs) ->
            State.read_block global_db.disk hash
            >>= function
            | None ->
                Lwt.return_unit
            | Some block ->
                State.Block.operations block ofs
                >>= fun (ops, path) ->
                Peer_metadata.update_responses meta Operations_for_block
                @@ P2p.try_send global_db.p2p state.conn
                @@ Operations_for_block (hash, ofs, ops, path) ;
                Lwt.return_unit)
          blocks
    | Operations_for_block (block, ofs, ops, path) -> (
      match find_pending_operations state block ofs with
      | None ->
          Peer_metadata.incr meta Unexpected_response ;
          Lwt.return_unit
      | Some chain_db ->
          Raw_operations.Table.notify
            chain_db.operations_db.table
            state.gid
            (block, ofs)
            (ops, path)
          >>= fun () ->
          Peer_metadata.incr meta @@ Received_response Operations_for_block ;
          Lwt.return_unit )

  let rec worker_loop global_db state =
    protect ~canceler:state.canceler (fun () ->
        P2p.recv global_db.p2p state.conn)
    >>= function
    | Ok msg ->
        handle_msg global_db state msg
        >>= fun () -> worker_loop global_db state
    | Error _ ->
        Chain_id.Table.iter
          (fun _ -> deactivate state)
          state.peer_active_chains ;
        P2p_peer.Table.remove global_db.p2p_readers state.gid ;
        Lwt.return_unit

  let run db gid conn =
    let canceler = Lwt_canceler.create () in
    let state =
      {
        conn;
        gid;
        canceler;
        peer_active_chains = Chain_id.Table.create 17;
        worker = Lwt.return_unit;
      }
    in
    Chain_id.Table.iter
      (fun chain_id _chain_db ->
        Lwt.async (fun () ->
            let meta = P2p.get_peer_metadata db.p2p gid in
            Peer_metadata.incr meta (Sent_request Branch) ;
            P2p.send db.p2p conn (Get_current_branch chain_id)))
      db.active_chains ;
    state.worker <-
      Lwt_utils.worker
        (Format.asprintf "db_network_reader.%a" P2p_peer.Id.pp_short gid)
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop db state)
        ~cancel:(fun () -> Lwt_canceler.cancel canceler) ;
    P2p_peer.Table.add db.p2p_readers gid state

  let shutdown s = Lwt_canceler.cancel s.canceler >>= fun () -> s.worker
end

let active_peer_ids p2p () =
  List.fold_left
    (fun acc conn ->
      let {P2p_connection.Info.peer_id; _} = P2p.connection_info p2p conn in
      P2p_peer.Set.add peer_id acc)
    P2p_peer.Set.empty
    (P2p.connections p2p)

let raw_try_send p2p peer_id msg =
  match P2p.find_connection p2p peer_id with
  | None ->
      ()
  | Some conn ->
      ignore (P2p.try_send p2p conn msg : bool)

let create disk p2p =
  let global_request =
    {p2p; data = (); active = active_peer_ids p2p; send = raw_try_send p2p}
  in
  let protocol_db = Raw_protocol.create global_request disk in
  let active_chains = Chain_id.Table.create 17 in
  let p2p_readers = P2p_peer.Table.create 17 in
  let block_input = Lwt_watcher.create_input () in
  let operation_input = Lwt_watcher.create_input () in
  let db =
    {
      p2p;
      p2p_readers;
      disk;
      active_chains;
      protocol_db;
      block_input;
      operation_input;
    }
  in
  db

let activate ({p2p; active_chains; _} as global_db) chain_state =
  P2p.on_new_connection p2p (P2p_reader.run global_db) ;
  P2p.iter_connections p2p (P2p_reader.run global_db) ;
  P2p.activate p2p ;
  let chain_id = State.Chain.id chain_state in
  match Chain_id.Table.find_opt active_chains chain_id with
  | None ->
      let active_peers = ref P2p_peer.Set.empty in
      let p2p_request =
        {
          p2p;
          data = ();
          active = (fun () -> !active_peers);
          send = raw_try_send p2p;
        }
      in
      let operation_db =
        Raw_operation.create
          ~global_input:global_db.operation_input
          p2p_request
          chain_state
      in
      let block_header_db =
        Raw_block_header.create
          ~global_input:global_db.block_input
          p2p_request
          chain_state
      in
      let operation_hashes_db =
        Raw_operation_hashes.create p2p_request chain_state
      in
      let operations_db = Raw_operations.create p2p_request chain_state in
      let chain =
        {
          global_db;
          operation_db;
          block_header_db;
          operation_hashes_db;
          operations_db;
          chain_state;
          callback = noop_callback;
          active_peers;
          active_connections = P2p_peer.Table.create 53;
        }
      in
      P2p.iter_connections p2p (fun _peer_id conn ->
          Lwt.async (fun () -> P2p.send p2p conn (Get_current_branch chain_id))) ;
      Chain_id.Table.add active_chains chain_id chain ;
      chain
  | Some chain ->
      chain

let set_callback chain_db callback = chain_db.callback <- callback

let deactivate chain_db =
  let {active_chains; p2p; _} = chain_db.global_db in
  let chain_id = State.Chain.id chain_db.chain_state in
  Chain_id.Table.remove active_chains chain_id ;
  P2p_peer.Table.iter
    (fun _peer_id reader ->
      P2p_reader.deactivate reader chain_db ;
      Lwt.async (fun () -> P2p.send p2p reader.conn (Deactivate chain_id)))
    chain_db.active_connections ;
  Raw_operation.shutdown chain_db.operation_db
  >>= fun () -> Raw_block_header.shutdown chain_db.block_header_db

let get_chain {active_chains; _} chain_id =
  Chain_id.Table.find_opt active_chains chain_id

let greylist {global_db = {p2p; _}; _} peer_id =
  Lwt.return (P2p.greylist_peer p2p peer_id)

let disconnect {global_db = {p2p; _}; _} peer_id =
  match P2p.find_connection p2p peer_id with
  | None ->
      Lwt.return_unit
  | Some conn ->
      P2p.disconnect p2p conn

let shutdown {p2p_readers; active_chains; _} =
  P2p_peer.Table.fold
    (fun _peer_id reader acc -> P2p_reader.shutdown reader >>= fun () -> acc)
    p2p_readers
    Lwt.return_unit
  >>= fun () ->
  Chain_id.Table.fold
    (fun _ chain_db acc ->
      Raw_operation.shutdown chain_db.operation_db
      >>= fun () ->
      Raw_block_header.shutdown chain_db.block_header_db >>= fun () -> acc)
    active_chains
    Lwt.return_unit

let clear_block chain_db hash n =
  Raw_operations.clear_all chain_db.operations_db.table hash n ;
  Raw_operation_hashes.clear_all chain_db.operation_hashes_db.table hash n ;
  Raw_block_header.Table.clear_or_cancel chain_db.block_header_db.table hash

let commit_block chain_db hash header header_data operations operations_data
    result ~forking_testchain =
  assert (Block_hash.equal hash (Block_header.hash header)) ;
  assert (List.length operations = header.shell.validation_passes) ;
  State.Block.store
    chain_db.chain_state
    header
    header_data
    operations
    operations_data
    result
    ~forking_testchain
  >>=? fun res ->
  clear_block chain_db hash header.shell.validation_passes ;
  return res

let commit_invalid_block chain_db hash header errors =
  assert (Block_hash.equal hash (Block_header.hash header)) ;
  State.Block.store_invalid chain_db.chain_state header errors
  >>=? fun res ->
  clear_block chain_db hash header.shell.validation_passes ;
  return res

let inject_operation chain_db h op =
  assert (Operation_hash.equal h (Operation.hash op)) ;
  Raw_operation.Table.inject chain_db.operation_db.table h op

let commit_protocol db h p =
  State.Protocol.store db.disk p
  >>= fun res ->
  Raw_protocol.Table.clear_or_cancel db.protocol_db.table h ;
  return (res <> None)

let watch_block_header {block_input; _} = Lwt_watcher.create_stream block_input

let watch_operation {operation_input; _} =
  Lwt_watcher.create_stream operation_input

module Raw = struct
  let encoding = P2p_message.encoding Message.cfg.encoding

  let chain_name = Message.cfg.chain_name

  let distributed_db_versions = Message.cfg.distributed_db_versions
end

module Make
    (Table : Distributed_db_functors.DISTRIBUTED_DB) (Kind : sig
      type t

      val proj : t -> Table.t
    end) =
struct
  type key = Table.key

  type value = Table.value

  let known t k = Table.known (Kind.proj t) k

  type error += Missing_data = Table.Missing_data

  type error += Canceled = Table.Canceled

  type error += Timeout = Table.Timeout

  let read t k = Table.read (Kind.proj t) k

  let read_opt t k = Table.read_opt (Kind.proj t) k

  let prefetch t ?peer ?timeout k p =
    Table.prefetch (Kind.proj t) ?peer ?timeout k p

  let fetch t ?peer ?timeout k p = Table.fetch (Kind.proj t) ?peer ?timeout k p

  let clear_or_cancel t k = Table.clear_or_cancel (Kind.proj t) k

  let inject t k v = Table.inject (Kind.proj t) k v

  let pending t k = Table.pending (Kind.proj t) k

  let watch t = Table.watch (Kind.proj t)

  let resolve_pending t k v = Table.resolve_pending (Kind.proj t) k v
end

module Block_header = struct
  type t = Block_header.t

  include (
    Make
      (Raw_block_header.Table)
      (struct
        type t = chain_db

        let proj chain = chain.block_header_db.table
      end) :
        Distributed_db_functors.DISTRIBUTED_DB
          with type t := chain_db
           and type key := Block_hash.t
           and type value := Block_header.t
           and type param := unit )
end

module Operation_hashes =
  Make
    (Raw_operation_hashes.Table)
    (struct
      type t = chain_db

      let proj chain = chain.operation_hashes_db.table
    end)

module Operations =
  Make
    (Raw_operations.Table)
    (struct
      type t = chain_db

      let proj chain = chain.operations_db.table
    end)

module Operation = struct
  include Operation

  include (
    Make
      (Raw_operation.Table)
      (struct
        type t = chain_db

        let proj chain = chain.operation_db.table
      end) :
        Distributed_db_functors.DISTRIBUTED_DB
          with type t := chain_db
           and type key := Operation_hash.t
           and type value := Operation.t
           and type param := unit )
end

module Protocol = struct
  type t = Protocol.t

  include (
    Make
      (Raw_protocol.Table)
      (struct
        type t = db

        let proj db = db.protocol_db.table
      end) :
        Distributed_db_functors.DISTRIBUTED_DB
          with type t := db
           and type key := Protocol_hash.t
           and type value := Protocol.t
           and type param := unit )
end

let broadcast chain_db msg =
  P2p_peer.Table.iter
    (fun _peer_id state ->
      ignore (P2p.try_send chain_db.global_db.p2p state.conn msg))
    chain_db.active_connections

let try_send chain_db peer_id msg =
  match P2p_peer.Table.find_opt chain_db.active_connections peer_id with
  | None ->
      ()
  | Some conn ->
      ignore (P2p.try_send chain_db.global_db.p2p conn.conn msg : bool)

let send chain_db ?peer msg =
  match peer with
  | Some peer ->
      try_send chain_db peer msg
  | None ->
      broadcast chain_db msg

module Request = struct
  let current_head chain_db ?peer () =
    let chain_id = State.Chain.id chain_db.chain_state in
    ( match peer with
    | Some peer ->
        let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
        Peer_metadata.incr meta (Sent_request Head)
    | None ->
        () ) ;
    send chain_db ?peer @@ Get_current_head chain_id

  let current_branch chain_db ?peer () =
    let chain_id = State.Chain.id chain_db.chain_state in
    ( match peer with
    | Some peer ->
        let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
        Peer_metadata.incr meta (Sent_request Head)
    | None ->
        () ) ;
    send chain_db ?peer @@ Get_current_branch chain_id
end

module Advertise = struct
  let current_head chain_db ?peer ?(mempool = Mempool.empty) head =
    let chain_id = State.Chain.id chain_db.chain_state in
    assert (Chain_id.equal chain_id (State.Block.chain_id head)) ;
    ( match peer with
    | Some peer ->
        let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
        Peer_metadata.incr meta (Sent_advertisement Head)
    | None ->
        () ) ;
    let msg_mempool =
      Message.Current_head (chain_id, State.Block.header head, mempool)
    in
    if mempool = Mempool.empty then send chain_db ?peer msg_mempool
    else
      let msg_disable_mempool =
        Message.Current_head (chain_id, State.Block.header head, Mempool.empty)
      in
      let send_mempool state =
        let {Connection_metadata.disable_mempool; _} =
          P2p.connection_remote_metadata chain_db.global_db.p2p state.conn
        in
        let msg =
          if disable_mempool then msg_disable_mempool else msg_mempool
        in
        ignore @@ P2p.try_send chain_db.global_db.p2p state.conn msg
      in
      match peer with
      | Some receiver_id ->
          let state =
            P2p_peer.Table.find chain_db.active_connections receiver_id
          in
          send_mempool state
      | None ->
          List.iter
            (fun (_receiver_id, state) -> send_mempool state)
            (P2p_peer.Table.fold
               (fun k v acc -> (k, v) :: acc)
               chain_db.active_connections
               [])

  let current_branch ?peer chain_db =
    let chain_id = State.Chain.id chain_db.chain_state in
    let chain_state = chain_state chain_db in
    let sender_id = my_peer_id chain_db in
    ( match peer with
    | Some peer ->
        let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
        Peer_metadata.incr meta (Sent_advertisement Branch)
    | None ->
        () ) ;
    match peer with
    | Some receiver_id ->
        let seed = {Block_locator.receiver_id; sender_id} in
        Chain.locator chain_state seed
        >>= fun locator ->
        let msg = Message.Current_branch (chain_id, locator) in
        try_send chain_db receiver_id msg ;
        Lwt.return_unit
    | None ->
        Lwt_list.iter_p
          (fun (receiver_id, state) ->
            let seed = {Block_locator.receiver_id; sender_id} in
            Chain.locator chain_state seed
            >>= fun locator ->
            let msg = Message.Current_branch (chain_id, locator) in
            ignore (P2p.try_send chain_db.global_db.p2p state.conn msg) ;
            Lwt.return_unit)
          (P2p_peer.Table.fold
             (fun k v acc -> (k, v) :: acc)
             chain_db.active_connections
             [])
end
src/lib_shell/distributed_db.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition p2p :=
  Tezos_p2p.P2p.net Message.t Tezos_shell_services.Peer_metadata.t
    Tezos_shell_services.Connection_metadata.t.

Definition connection :=
  Tezos_p2p.P2p.connection Message.t Tezos_shell_services.Peer_metadata.t
    Tezos_shell_services.Connection_metadata.t.

Record request_param {a : Type} := {
  p2p :
    Tezos_p2p.P2p.t Message.t Tezos_shell_services.Peer_metadata.t
      Tezos_shell_services.Connection_metadata.t;
  data : a;
  active : unit -> Tezos_base__TzPervasives.P2p_peer.Set.t;
  send : Tezos_base__TzPervasives.P2p_peer.Id.t -> Message.t -> unit }.
Arguments request_param : clear implicits.

Module Fake_operation_storage.
  Definition store := Tezos_shell.State.Chain.t.
  
  Definition value := Tezos_base__TzPervasives.Operation.t.
  
  Definition known {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => Lwt.return_false
        end
    end.
  
  Definition read {A B C : Type} (function_parameter : A)
    : B -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult C) :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          Lwt._return
            (Tezos_base__TzPervasives.Error_monad.error_exn OCaml.Not_found)
        end
    end.
  
  Definition read_opt {A B C : Type} (function_parameter : A)
    : B -> Lwt.t (option C) :=
    match function_parameter with
    | _ =>
      fun function_parameter =>
        match function_parameter with
        | _ => Lwt.return_none
        end
    end.
End Fake_operation_storage.

Module Block_header_storage.
  Definition store := Tezos_shell.State.Chain.t.
  
  Definition value := Tezos_base__TzPervasives.Block_header.t.
  
  Definition known
    : Tezos_shell__State.Chain.t ->
      Tezos_base__TzPervasives.Block_hash.t -> Lwt.t bool :=
    Tezos_shell.State.Block.known_valid.
  
  Definition read
    (chain_state : Tezos_shell__State.Chain.t)
    (h : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_shell.State.Block.read chain_state h)
      (fun b =>
        Tezos_base__TzPervasives._return (Tezos_shell.State.Block.header b)).
  
  Definition read_opt
    (chain_state : Tezos_shell__State.Chain.t)
    (h : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.State.Block.read_opt chain_state h)
      (fun b =>
        Lwt._return
          (Tezos_base__TzPervasives.Option.map Tezos_shell.State.Block.header b)).
End Block_header_storage.

Module Operation_hashes_storage.
  Definition store := Tezos_shell.State.Chain.t.
  
  Definition value := list Tezos_base__TzPervasives.Operation_hash.t.
  
  Definition known {A : Type}
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * A)
    : Lwt.t bool :=
    match function_parameter with
    | (h, _) => Tezos_shell.State.Block.known_valid chain_state h
    end.
  
  Definition read
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list Tezos_base__TzPervasives.Operation_hash.t)) :=
    match function_parameter with
    | (h, i) =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.State.Block.read chain_state h)
        (fun b =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.operation_hashes b i)
            (fun function_parameter =>
              match function_parameter with
              | (ops, _) => Tezos_base__TzPervasives._return ops
              end))
    end.
  
  Definition read_opt
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
    : Lwt.t (option (list Tezos_base__TzPervasives.Operation_hash.t)) :=
    match function_parameter with
    | (h, i) =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.read_opt chain_state h)
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt.return_none
          | Some b =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Block.operation_hashes b i)
              (fun function_parameter =>
                match function_parameter with
                | (ops, _) => Lwt.return_some ops
                end)
          end)
    end.
End Operation_hashes_storage.

Module Raw_operation_hashes.
  Definition clear_all
    (table : Table.t) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
    : unit :=
    Tezos_base__TzPervasives.List.iter
      (fun i => Table.clear_or_cancel table (hash, i))
      (Tezos_base__TzPervasives.op_minus_minus 0 (Z.sub n 1)).
End Raw_operation_hashes.

Module Operations_storage.
  Definition store := Tezos_shell.State.Chain.t.
  
  Definition value := list Tezos_base__TzPervasives.Operation.t.
  
  Definition known {A : Type}
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * A)
    : Lwt.t bool :=
    match function_parameter with
    | (h, _) => Tezos_shell.State.Block.known_valid chain_state h
    end.
  
  Definition read
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list Tezos_base__TzPervasives.Operation.t)) :=
    match function_parameter with
    | (h, i) =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.State.Block.read chain_state h)
        (fun b =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.operations b i)
            (fun function_parameter =>
              match function_parameter with
              | (ops, _) => Tezos_base__TzPervasives._return ops
              end))
    end.
  
  Definition read_opt
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
    : Lwt.t (option (list Tezos_base__TzPervasives.Operation.t)) :=
    match function_parameter with
    | (h, i) =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.read_opt chain_state h)
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt.return_none
          | Some b =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Block.operations b i)
              (fun function_parameter =>
                match function_parameter with
                | (ops, _) => Lwt.return_some ops
                end)
          end)
    end.
End Operations_storage.

Module Raw_operations.
  Definition clear_all
    (table : Table.t) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
    : unit :=
    Tezos_base__TzPervasives.List.iter
      (fun i => Table.clear_or_cancel table (hash, i))
      (Tezos_base__TzPervasives.op_minus_minus 0 (Z.sub n 1)).
End Raw_operations.

Module Protocol_storage.
  Definition store := Tezos_shell.State.t.
  
  Definition value := Tezos_base__TzPervasives.Protocol.t.
  
  Definition known
    : Tezos_shell__State.global_state ->
      Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t bool :=
    Tezos_shell.State.Protocol.known.
  
  Definition read
    : Tezos_shell__State.global_state ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Protocol.t) :=
    Tezos_shell.State.Protocol.read.
  
  Definition read_opt
    : Tezos_shell__State.global_state ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t (option Tezos_base__TzPervasives.Protocol.t) :=
    Tezos_shell.State.Protocol.read_opt.
End Protocol_storage.

Record callback := {
  notify_branch :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_base__TzPervasives.Block_locator.t -> unit;
  notify_head :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_base__TzPervasives.Block_header.t ->
        Tezos_base__TzPervasives.Mempool.t -> unit;
  disconnection : Tezos_base__TzPervasives.P2p_peer.Id.t -> unit }.

.

Definition noop_callback : callback :=
  {| notify_branch := fun _gid => fun _locator => tt;
    notify_head := fun _gid => fun _block => fun _ops => tt;
    disconnection := fun _gid => tt |}.

Definition t := db.

Definition state (function_parameter : db) : Tezos_shell.State.t :=
  match function_parameter with
  | {| disk := disk |} => disk
  end.

Definition chain_state (function_parameter : chain_db)
  : Tezos_shell.State.Chain.t :=
  match function_parameter with
  | {| chain_state := chain_state |} => chain_state
  end.

Definition db (function_parameter : chain_db) : db :=
  match function_parameter with
  | {| global_db := global_db |} => global_db
  end.

Definition information (function_parameter : chain_db)
  : Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
  match function_parameter with
  | {|
    global_db := {| p2p_readers := p2p_readers; active_chains := active_chains |};
      operation_db := operation_db;
      block_header_db := block_header_db;
      operation_hashes_db := operation_hashes_db;
      operations_db := operations_db;
      active_peers := active_peers;
      active_connections := active_connections
      |} =>
    {|
      Chain_validator_worker_state.Distributed_db_state.p2p_readers_length :=
        Tezos_base__TzPervasives.P2p_peer.Table.length p2p_readers;
      Chain_validator_worker_state.Distributed_db_state.active_chains_length :=
        Tezos_base__TzPervasives.Chain_id.Table.length active_chains;
      Chain_validator_worker_state.Distributed_db_state.operation_db :=
        Raw_operation.state_of_t operation_db;
      Chain_validator_worker_state.Distributed_db_state.operations_db :=
        Raw_operations.state_of_t operations_db;
      Chain_validator_worker_state.Distributed_db_state.block_header_db :=
        Raw_block_header.state_of_t block_header_db;
      Chain_validator_worker_state.Distributed_db_state.operations_hashed_db :=
        Raw_operation_hashes.state_of_t operation_hashes_db;
      Chain_validator_worker_state.Distributed_db_state.active_connections_length :=
        Tezos_base__TzPervasives.P2p_peer.Table.length active_connections;
      Chain_validator_worker_state.Distributed_db_state.active_peers_length :=
        Tezos_base__TzPervasives.P2p_peer.Set.cardinal
          (Stdlib.op_exclamation active_peers) |}
  end.

Definition my_peer_id (chain_db : chain_db)
  : Tezos_base__TzPervasives.P2p_peer.Id.t :=
  Tezos_p2p.P2p.peer_id (p2p (global_db chain_db)).

Definition get_peer_metadata (chain_db : chain_db)
  : Tezos_base__TzPervasives.P2p_peer.Id.t ->
    Tezos_shell_services.Peer_metadata.t :=
  Tezos_p2p.P2p.get_peer_metadata (p2p (global_db chain_db)).

Definition read_block_header (function_parameter : db)
  : Tezos_base__TzPervasives.Block_hash.t ->
    Lwt.t
      (option
        (Tezos_base__TzPervasives.Chain_id.t *
          Tezos_base__TzPervasives.Block_header.t)) :=
  match function_parameter with
  | {| disk := disk |} =>
    fun h =>
      Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.State.read_block disk h)
        (fun function_parameter =>
          match function_parameter with
          | Some b =>
            Lwt.return_some
              ((Tezos_shell.State.Block.chain_id b),
                (Tezos_shell.State.Block.header b))
          | None => Lwt.return_none
          end)
  end.

Definition find_pending_block_header (function_parameter : p2p_reader)
  : Raw_block_header.Table.key -> option chain_db :=
  match function_parameter with
  | {| peer_active_chains := peer_active_chains |} =>
    fun h =>
      Tezos_base__TzPervasives.Chain_id.Table.fold
        (fun _chain_id =>
          fun chain_db =>
            fun acc =>
              match acc with
              | Some _ => acc
              | None => None
              end) peer_active_chains None
  end.

Definition find_pending_operations (function_parameter : p2p_reader)
  : Tezos_base__TzPervasives.Block_hash.t -> Z -> option chain_db :=
  match function_parameter with
  | {| peer_active_chains := peer_active_chains |} =>
    fun h =>
      fun i =>
        Tezos_base__TzPervasives.Chain_id.Table.fold
          (fun _chain_id =>
            fun chain_db =>
              fun acc =>
                match acc with
                | Some _ => acc
                | None => None
                end) peer_active_chains None
  end.

Definition find_pending_operation_hashes (function_parameter : p2p_reader)
  : Tezos_base__TzPervasives.Block_hash.t -> Z -> option chain_db :=
  match function_parameter with
  | {| peer_active_chains := peer_active_chains |} =>
    fun h =>
      fun i =>
        Tezos_base__TzPervasives.Chain_id.Table.fold
          (fun _chain_id =>
            fun chain_db =>
              fun acc =>
                match acc with
                | Some _ => acc
                | None => None
                end) peer_active_chains None
  end.

Definition find_pending_operation (function_parameter : p2p_reader)
  : Raw_operation.Table.key -> option chain_db :=
  match function_parameter with
  | {| peer_active_chains := peer_active_chains |} =>
    fun h =>
      Tezos_base__TzPervasives.Chain_id.Table.fold
        (fun _chain_id =>
          fun chain_db =>
            fun acc =>
              match acc with
              | Some _ => acc
              | None => None
              end) peer_active_chains None
  end.

Definition read_operation (function_parameter : db)
  : Raw_operation.Table.key ->
    Lwt.t
      (option
        (Tezos_base__TzPervasives.Chain_id.Table.key * Raw_operation.Table.value)) :=
  match function_parameter with
  | {| active_chains := active_chains |} =>
    fun h =>
      Tezos_base__TzPervasives.Chain_id.Table.fold
        (fun chain_id =>
          fun chain_db =>
            fun acc =>
              Tezos_base__TzPervasives.op_gt_gt_eq acc
                (fun function_parameter =>
                  match function_parameter with
                  | Some _ => acc
                  | None =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Raw_operation.Table.read_opt
                        (table (operation_db chain_db)) h)
                      (fun function_parameter =>
                        match function_parameter with
                        | None => Lwt.return_none
                        | Some bh => Lwt.return_some (chain_id, bh)
                        end)
                  end)) active_chains Lwt.return_none
  end.

Module P2p_reader.
  Definition may_activate
    (global_db : db) (state : p2p_reader)
    (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
    (f : chain_db -> Lwt.t unit) : Lwt.t unit :=
    match
      Tezos_base__TzPervasives.Chain_id.Table.find_opt
        (peer_active_chains state) chain_id with
    | Some chain_db => f chain_db
    | None =>
      match
        Tezos_base__TzPervasives.Chain_id.Table.find_opt
          (active_chains global_db) chain_id with
      | Some chain_db =>
        Stdlib.op_colon_eq (active_peers chain_db)
          (Tezos_base__TzPervasives.P2p_peer.Set.add (gid state)
            (Stdlib.op_exclamation (active_peers chain_db)));
        Tezos_base__TzPervasives.P2p_peer.Table.add
          (active_connections chain_db) (gid state) state;
        Tezos_base__TzPervasives.Chain_id.Table.add (peer_active_chains state)
          chain_id chain_db;
        f chain_db
      | None =>
        let meta := Tezos_p2p.P2p.get_peer_metadata (p2p global_db) (gid state)
          in
        Tezos_shell_services.Peer_metadata.incr meta Unactivated_chain;
        Lwt.return_unit
      end
    end.
  
  Definition deactivate (state : p2p_reader) (chain_db : chain_db) : unit :=
    (disconnection (callback chain_db)) (gid state);
    Stdlib.op_colon_eq (active_peers chain_db)
      (Tezos_base__TzPervasives.P2p_peer.Set.remove (gid state)
        (Stdlib.op_exclamation (active_peers chain_db)));
    Tezos_base__TzPervasives.P2p_peer.Table.remove (active_connections chain_db)
      (gid state).
  
  Definition may_handle
    (global_db : db) (state : p2p_reader)
    (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
    (f : chain_db -> Lwt.t unit) : Lwt.t unit :=
    match
      Tezos_base__TzPervasives.Chain_id.Table.find_opt
        (peer_active_chains state) chain_id with
    | None =>
      let meta := Tezos_p2p.P2p.get_peer_metadata (p2p global_db) (gid state) in
      Tezos_shell_services.Peer_metadata.incr meta Inactive_chain;
      Lwt.return_unit
    | Some chain_db => f chain_db
    end.
  
  Definition may_handle_global
    (global_db : db) (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
    (f : chain_db -> Lwt.t unit) : Lwt.t unit :=
    match
      Tezos_base__TzPervasives.Chain_id.Table.find_opt (active_chains global_db)
        chain_id with
    | None => Lwt.return_unit
    | Some chain_db => f chain_db
    end.
  
  Definition soon (function_parameter : unit) : Ptime.t :=
    match function_parameter with
    | tt =>
      let now := Tezos_stdlib_unix.Systime_os.now tt in
      match Ptime.add_span now (Ptime.Span.of_int_s 15) with
      | Some s => s
      | None =>
        OCaml.Stdlib.invalid_arg
          "Distributed_db.handle_msg: end of time" % string
      end
    end.
  
  Definition handle_msg
    (global_db : db) (state : p2p_reader)
    (msg : Tezos_shell__Distributed_db_message.t) : Lwt.t unit :=
    let meta := Tezos_p2p.P2p.get_peer_metadata (p2p global_db) (gid state) in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Handle_msg_Logging.lwt_debug
        (fun f =>
          Handle_msg_Logging.Tag.DSL.op_minus_percent
            (Handle_msg_Logging.Tag.DSL.op_minus_percent
              (Handle_msg_Logging.Tag.DSL.op_minus_percent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Read message from " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal ": " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))))
                    "Read message from %a: %a" % string))
                (Handle_msg_Logging.Tag.DSL.t Handle_msg_Logging.event
                  "read_message" % string))
              (Handle_msg_Logging.Tag.DSL.a
                Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag (gid state)))
            (Handle_msg_Logging.Tag.DSL.a Message.Logging.tag msg)))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          match msg with
          | Get_current_branch chain_id =>
            apply (Tezos_shell_services.Peer_metadata.incr meta)
              (Received_request Branch);
            apply (may_handle_global global_db chain_id)
              (fun chain_db =>
                if
                  negb
                    (Tezos_base__TzPervasives.Chain_id.Table.mem
                      (peer_active_chains state) chain_id) then
                  apply
                    (Tezos_shell_services.Peer_metadata.update_requests meta
                      Branch)
                    (apply (Tezos_p2p.P2p.try_send (p2p global_db) (conn state))
                      (Get_current_branch chain_id))
                else
                  tt;
                let seed :=
                  {| Block_locator.sender_id := my_peer_id chain_db;
                    Block_locator.receiver_id := gid state |} in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Chain.locator (chain_state chain_db) seed)
                  (fun locator =>
                    apply
                      (Tezos_shell_services.Peer_metadata.update_responses meta
                        Branch)
                      (apply
                        (Tezos_p2p.P2p.try_send (p2p global_db) (conn state))
                        (Current_branch chain_id locator));
                    Lwt.return_unit))
          | Current_branch chain_id locator =>
            apply (may_activate global_db state chain_id)
              (fun chain_db =>
                match locator with
                | (head, hist) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Lwt_list.exists_p
                      (Tezos_shell.State.Block.known_invalid
                        (chain_state chain_db))
                      (cons (Tezos_base__TzPervasives.Block_header.hash head)
                        hist))
                    (fun known_invalid =>
                      if known_invalid then
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_p2p.P2p.disconnect (p2p global_db) None
                            (conn state))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_p2p.P2p.greylist_peer (p2p global_db)
                                (gid state);
                              Lwt.return_unit
                            end)
                      else
                        if
                          Tezos_base__TzPervasives.Time.System.op_lt (soon tt)
                            (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                              (timestamp (shell head))) then
                          Tezos_shell_services.Peer_metadata.incr meta
                            Future_block;
                          Handle_msg_Logging.lwt_log_notice
                            (fun f =>
                              Handle_msg_Logging.Tag.DSL.op_minus_percent
                                (Handle_msg_Logging.Tag.DSL.op_minus_percent
                                  (Handle_msg_Logging.Tag.DSL.op_minus_percent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Received future block " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " from peer " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  "." % char
                                                  CamlinternalFormatBasics.End_of_format)))))
                                        "Received future block %a from peer %a."
                                          % string))
                                    (Handle_msg_Logging.Tag.DSL.t
                                      Handle_msg_Logging.event
                                      "received_future_block" % string))
                                  (Handle_msg_Logging.Tag.DSL.a
                                    Tezos_base__TzPervasives.Block_hash.Logging.tag
                                    (Tezos_base__TzPervasives.Block_header.hash
                                      head)))
                                (Handle_msg_Logging.Tag.DSL.a
                                  Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                  (gid state)))
                        else
                          (notify_branch (callback chain_db)) (gid state)
                            locator;
                          apply (Tezos_shell_services.Peer_metadata.incr meta)
                            (Received_advertisement Branch);
                          Lwt.return_unit)
                end)
          | Deactivate chain_id =>
            apply (may_handle global_db state chain_id)
              (fun chain_db =>
                deactivate state chain_db;
                Tezos_base__TzPervasives.Chain_id.Table.remove
                  (peer_active_chains state) chain_id;
                Lwt.return_unit)
          | Get_current_head chain_id =>
            apply (may_handle global_db state chain_id)
              (fun chain_db =>
                apply (Tezos_shell_services.Peer_metadata.incr meta)
                  (Received_request Head);
                match
                  Tezos_p2p.P2p.connection_remote_metadata
                    (p2p (global_db chain_db)) (conn state) with
                | {| Connection_metadata.disable_mempool := disable_mempool |}
                  =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (if disable_mempool then
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.Chain.head (chain_state chain_db))
                        (fun head =>
                          Lwt._return
                            ((Tezos_shell.State.Block.header head),
                              Tezos_base__TzPervasives.Mempool.empty))
                    else
                      Tezos_shell.State.Current_mempool.get
                        (chain_state chain_db))
                    (fun function_parameter =>
                      match function_parameter with
                      | (head, mempool) =>
                        apply
                          (Tezos_shell_services.Peer_metadata.update_responses
                            meta Head)
                          (apply
                            (Tezos_p2p.P2p.try_send (p2p global_db) (conn state))
                            (Current_head chain_id head mempool));
                        Lwt.return_unit
                      end)
                end)
          | Current_head chain_id header mempool =>
            apply (may_handle global_db state chain_id)
              (fun chain_db =>
                let head := Tezos_base__TzPervasives.Block_header.hash header in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Block.known_invalid (chain_state chain_db)
                    head)
                  (fun known_invalid =>
                    match
                      Tezos_p2p.P2p.connection_local_metadata
                        (p2p (global_db chain_db)) (conn state) with
                    | {|
                      Connection_metadata.disable_mempool := disable_mempool
                        |} =>
                      let known_invalid :=
                        orb known_invalid
                          (andb disable_mempool
                            (nequiv_decb mempool
                              Tezos_base__TzPervasives.Mempool.empty)) in
                      if known_invalid then
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_p2p.P2p.disconnect (p2p global_db) None
                            (conn state))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_p2p.P2p.greylist_peer (p2p global_db)
                                (gid state);
                              Lwt.return_unit
                            end)
                      else
                        if
                          Tezos_base__TzPervasives.Time.System.op_lt (soon tt)
                            (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                              (timestamp (shell header))) then
                          Tezos_shell_services.Peer_metadata.incr meta
                            Future_block;
                          Handle_msg_Logging.lwt_log_notice
                            (fun f =>
                              Handle_msg_Logging.Tag.DSL.op_minus_percent
                                (Handle_msg_Logging.Tag.DSL.op_minus_percent
                                  (Handle_msg_Logging.Tag.DSL.op_minus_percent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Received future block " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " from peer " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  "." % char
                                                  CamlinternalFormatBasics.End_of_format)))))
                                        "Received future block %a from peer %a."
                                          % string))
                                    (Handle_msg_Logging.Tag.DSL.t
                                      Handle_msg_Logging.event
                                      "received_future_block" % string))
                                  (Handle_msg_Logging.Tag.DSL.a
                                    Tezos_base__TzPervasives.Block_hash.Logging.tag
                                    head))
                                (Handle_msg_Logging.Tag.DSL.a
                                  Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag
                                  (gid state)))
                        else
                          (notify_head (callback chain_db)) (gid state) header
                            mempool;
                          apply (Tezos_shell_services.Peer_metadata.incr meta)
                            (Received_advertisement Head);
                          Lwt.return_unit
                    end))
          | Get_block_headers hashes =>
            apply (Tezos_shell_services.Peer_metadata.incr meta)
              (Received_request Block_header);
            Lwt_list.iter_p
              (fun hash =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (read_block_header global_db hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      apply (Tezos_shell_services.Peer_metadata.incr meta)
                        (Unadvertised Block);
                      Lwt.return_unit
                    | Some (_chain_id, header) =>
                      apply
                        (Tezos_shell_services.Peer_metadata.update_responses
                          meta Block_header)
                        (apply
                          (Tezos_p2p.P2p.try_send (p2p global_db) (conn state))
                          (Block_header header));
                      Lwt.return_unit
                    end)) hashes
          | Block_header block =>
            let hash := Tezos_base__TzPervasives.Block_header.hash block in
            match find_pending_block_header state hash with
            | None =>
              Tezos_shell_services.Peer_metadata.incr meta Unexpected_response;
              Lwt.return_unit
            | Some chain_db =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Raw_block_header.Table.notify
                  (table (block_header_db chain_db)) (gid state) hash block)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    apply (Tezos_shell_services.Peer_metadata.incr meta)
                      (Received_response Block_header);
                    Lwt.return_unit
                  end)
            end
          | Get_operations hashes =>
            apply (Tezos_shell_services.Peer_metadata.incr meta)
              (Received_request Operations);
            Lwt_list.iter_p
              (fun hash =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (read_operation global_db hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      apply (Tezos_shell_services.Peer_metadata.incr meta)
                        (Unadvertised Operations);
                      Lwt.return_unit
                    | Some (_chain_id, op) =>
                      apply
                        (Tezos_shell_services.Peer_metadata.update_responses
                          meta Operations)
                        (apply
                          (Tezos_p2p.P2p.try_send (p2p global_db) (conn state))
                          (Operation op));
                      Lwt.return_unit
                    end)) hashes
          | Operation operation =>
            let hash := Tezos_base__TzPervasives.Operation.hash operation in
            match find_pending_operation state hash with
            | None =>
              Tezos_shell_services.Peer_metadata.incr meta Unexpected_response;
              Lwt.return_unit
            | Some chain_db =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Raw_operation.Table.notify (table (operation_db chain_db))
                  (gid state) hash operation)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    apply (Tezos_shell_services.Peer_metadata.incr meta)
                      (Received_response Operations);
                    Lwt.return_unit
                  end)
            end
          | Get_protocols hashes =>
            apply (Tezos_shell_services.Peer_metadata.incr meta)
              (Received_request Protocols);
            Lwt_list.iter_p
              (fun hash =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Protocol.read_opt (disk global_db) hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      apply (Tezos_shell_services.Peer_metadata.incr meta)
                        (Unadvertised Protocol);
                      Lwt.return_unit
                    | Some p =>
                      apply
                        (Tezos_shell_services.Peer_metadata.update_responses
                          meta Protocols)
                        (apply
                          (Tezos_p2p.P2p.try_send (p2p global_db) (conn state))
                          (Protocol p));
                      Lwt.return_unit
                    end)) hashes
          | Protocol protocol =>
            let hash := Tezos_base__TzPervasives.Protocol.hash protocol in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Raw_protocol.Table.notify (table (protocol_db global_db))
                (gid state) hash protocol)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  apply (Tezos_shell_services.Peer_metadata.incr meta)
                    (Received_response Protocols);
                  Lwt.return_unit
                end)
          | Get_operation_hashes_for_blocks blocks =>
            apply (Tezos_shell_services.Peer_metadata.incr meta)
              (Received_request Operation_hashes_for_block);
            Lwt_list.iter_p
              (fun function_parameter =>
                match function_parameter with
                | (hash, ofs) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.read_block (disk global_db) hash)
                    (fun function_parameter =>
                      match function_parameter with
                      | None => Lwt.return_unit
                      | Some block =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_shell.State.Block.operation_hashes block ofs)
                          (fun function_parameter =>
                            match function_parameter with
                            | (hashes, path) =>
                              apply
                                (Tezos_shell_services.Peer_metadata.update_responses
                                  meta Operation_hashes_for_block)
                                (apply
                                  (Tezos_p2p.P2p.try_send (p2p global_db)
                                    (conn state))
                                  (Operation_hashes_for_block hash ofs hashes
                                    path));
                              Lwt.return_unit
                            end)
                      end)
                end) blocks
          | Operation_hashes_for_block block ofs ops path =>
            match find_pending_operation_hashes state block ofs with
            | None =>
              Tezos_shell_services.Peer_metadata.incr meta Unexpected_response;
              Lwt.return_unit
            | Some chain_db =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Raw_operation_hashes.Table.notify
                  (table (operation_hashes_db chain_db)) (gid state)
                  (block, ofs) (ops, path))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    apply (Tezos_shell_services.Peer_metadata.incr meta)
                      (Received_response Operation_hashes_for_block);
                    Lwt.return_unit
                  end)
            end
          | Get_operations_for_blocks blocks =>
            apply (Tezos_shell_services.Peer_metadata.incr meta)
              (Received_request Operations_for_block);
            Lwt_list.iter_p
              (fun function_parameter =>
                match function_parameter with
                | (hash, ofs) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.read_block (disk global_db) hash)
                    (fun function_parameter =>
                      match function_parameter with
                      | None => Lwt.return_unit
                      | Some block =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_shell.State.Block.operations block ofs)
                          (fun function_parameter =>
                            match function_parameter with
                            | (ops, path) =>
                              apply
                                (Tezos_shell_services.Peer_metadata.update_responses
                                  meta Operations_for_block)
                                (apply
                                  (Tezos_p2p.P2p.try_send (p2p global_db)
                                    (conn state))
                                  (Operations_for_block hash ofs ops path));
                              Lwt.return_unit
                            end)
                      end)
                end) blocks
          | Operations_for_block block ofs ops path =>
            match find_pending_operations state block ofs with
            | None =>
              Tezos_shell_services.Peer_metadata.incr meta Unexpected_response;
              Lwt.return_unit
            | Some chain_db =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Raw_operations.Table.notify (table (operations_db chain_db))
                  (gid state) (block, ofs) (ops, path))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    apply (Tezos_shell_services.Peer_metadata.incr meta)
                      (Received_response Operations_for_block);
                    Lwt.return_unit
                  end)
            end
          end
        end).
  
  Fixpoint worker_loop (global_db : db) (state : p2p_reader) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.protect None (Some (canceler state))
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_p2p.P2p.recv (p2p global_db) (conn state)
          end))
      (fun function_parameter =>
        match function_parameter with
        | inl msg =>
          Tezos_base__TzPervasives.op_gt_gt_eq (handle_msg global_db state msg)
            (fun function_parameter =>
              match function_parameter with
              | tt => worker_loop global_db state
              end)
        | inr _ =>
          Tezos_base__TzPervasives.Chain_id.Table.iter
            (fun function_parameter =>
              match function_parameter with
              | _ => deactivate state
              end) (peer_active_chains state);
          Tezos_base__TzPervasives.P2p_peer.Table.remove (p2p_readers global_db)
            (gid state);
          Lwt.return_unit
        end).
  
  Definition run
    (db : db) (gid : Tezos_base__TzPervasives.P2p_peer.Id.t) (conn : connection)
    : unit :=
    let canceler := Tezos_base__TzPervasives.Lwt_canceler.create tt in
    let state :=
      {| gid := gid; conn := conn;
        peer_active_chains := Tezos_base__TzPervasives.Chain_id.Table.create 17;
        canceler := canceler; worker := Lwt.return_unit |} in
    Tezos_base__TzPervasives.Chain_id.Table.iter
      (fun chain_id =>
        fun _chain_db =>
          Lwt.async
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let meta := Tezos_p2p.P2p.get_peer_metadata (p2p db) gid in
                Tezos_shell_services.Peer_metadata.incr meta
                  (Sent_request Branch);
                Tezos_p2p.P2p.send (p2p db) conn (Get_current_branch chain_id)
              end)) (active_chains db);
    set_field;
    Tezos_base__TzPervasives.P2p_peer.Table.add (p2p_readers db) gid state.
  
  Definition shutdown (s : p2p_reader) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler s))
      (fun function_parameter =>
        match function_parameter with
        | tt => worker s
        end).
End P2p_reader.

Definition active_peer_ids {A B C : Type}
  (p2p : Tezos_p2p.P2p.net A B C) (function_parameter : unit)
  : Tezos_base__TzPervasives.P2p_peer.Set.t :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.List.fold_left
      (fun acc =>
        fun conn =>
          match Tezos_p2p.P2p.connection_info p2p conn with
          | {| P2p_connection.Info.peer_id := peer_id |} =>
            Tezos_base__TzPervasives.P2p_peer.Set.add peer_id acc
          end) Tezos_base__TzPervasives.P2p_peer.Set.empty
      (Tezos_p2p.P2p.connections p2p)
  end.

Definition raw_try_send {A B C : Type}
  (p2p : Tezos_p2p.P2p.net A B C)
  (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) (msg : A) : unit :=
  match Tezos_p2p.P2p.find_connection p2p peer_id with
  | None => tt
  | Some conn => OCaml.Stdlib.ignore (Tezos_p2p.P2p.try_send p2p conn msg)
  end.

Definition create
  (disk : Protocol_storage.store)
  (p2p :
    Tezos_p2p.P2p.t Message.t Tezos_shell_services.Peer_metadata.t
      Tezos_shell_services.Connection_metadata.t) : db :=
  let global_request :=
    {| p2p := p2p; data := tt; active := active_peer_ids p2p;
      send := raw_try_send p2p |} in
  let protocol_db := Raw_protocol.create None global_request disk in
  let active_chains := Tezos_base__TzPervasives.Chain_id.Table.create 17 in
  let p2p_readers := Tezos_base__TzPervasives.P2p_peer.Table.create 17 in
  let block_input := Tezos_base__TzPervasives.Lwt_watcher.create_input tt in
  let operation_input := Tezos_base__TzPervasives.Lwt_watcher.create_input tt in
  let db :=
    {| p2p := p2p; p2p_readers := p2p_readers; disk := disk;
      active_chains := active_chains; protocol_db := protocol_db;
      block_input := block_input; operation_input := operation_input |} in
  db.

Definition activate (function_parameter : db)
  : Tezos_shell.State.Chain.chain_state -> chain_db :=
  match function_parameter with
  | {| p2p := p2p; active_chains := active_chains |} as global_db =>
    fun chain_state =>
      Tezos_p2p.P2p.on_new_connection p2p (P2p_reader.run global_db);
      Tezos_p2p.P2p.iter_connections p2p (P2p_reader.run global_db);
      Tezos_p2p.P2p.activate p2p;
      let chain_id := Tezos_shell.State.Chain.id chain_state in
      match
        Tezos_base__TzPervasives.Chain_id.Table.find_opt active_chains chain_id
        with
      | None =>
        let active_peers :=
          Stdlib.ref Tezos_base__TzPervasives.P2p_peer.Set.empty in
        let p2p_request :=
          {| p2p := p2p; data := tt;
            active :=
              fun function_parameter =>
                match function_parameter with
                | tt => Stdlib.op_exclamation active_peers
                end; send := raw_try_send p2p |} in
        let operation_db :=
          Raw_operation.create (Some (operation_input global_db)) p2p_request
            chain_state in
        let block_header_db :=
          Raw_block_header.create (Some (block_input global_db)) p2p_request
            chain_state in
        let operation_hashes_db :=
          Raw_operation_hashes.create None p2p_request chain_state in
        let operations_db := Raw_operations.create None p2p_request chain_state
          in
        let chain :=
          {| chain_state := chain_state; global_db := global_db;
            operation_db := operation_db; block_header_db := block_header_db;
            operation_hashes_db := operation_hashes_db;
            operations_db := operations_db; callback := noop_callback;
            active_peers := active_peers;
            active_connections :=
              Tezos_base__TzPervasives.P2p_peer.Table.create 53 |} in
        Tezos_p2p.P2p.iter_connections p2p
          (fun _peer_id =>
            fun conn =>
              Lwt.async
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_p2p.P2p.send p2p conn (Get_current_branch chain_id)
                  end));
        Tezos_base__TzPervasives.Chain_id.Table.add active_chains chain_id chain;
        chain
      | Some chain => chain
      end
  end.

Definition set_callback (chain_db : chain_db) (callback : callback) : unit :=
  set_field.

Definition deactivate (chain_db : chain_db) : Lwt.t unit :=
  match global_db chain_db with
  | {| p2p := p2p; active_chains := active_chains |} =>
    let chain_id := Tezos_shell.State.Chain.id (chain_state chain_db) in
    Tezos_base__TzPervasives.Chain_id.Table.remove active_chains chain_id;
    Tezos_base__TzPervasives.P2p_peer.Table.iter
      (fun _peer_id =>
        fun reader =>
          P2p_reader.deactivate reader chain_db;
          Lwt.async
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_p2p.P2p.send p2p (conn reader) (Deactivate chain_id)
              end)) (active_connections chain_db);
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Raw_operation.shutdown (operation_db chain_db))
      (fun function_parameter =>
        match function_parameter with
        | tt => Raw_block_header.shutdown (block_header_db chain_db)
        end)
  end.

Definition get_chain (function_parameter : db)
  : Tezos_base__TzPervasives.Chain_id.Table.key -> option chain_db :=
  match function_parameter with
  | {| active_chains := active_chains |} =>
    fun chain_id =>
      Tezos_base__TzPervasives.Chain_id.Table.find_opt active_chains chain_id
  end.

Definition greylist (function_parameter : chain_db)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit :=
  match function_parameter with
  | {| global_db := {| p2p := p2p |} |} =>
    fun peer_id => Lwt._return (Tezos_p2p.P2p.greylist_peer p2p peer_id)
  end.

Definition disconnect (function_parameter : chain_db)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit :=
  match function_parameter with
  | {| global_db := {| p2p := p2p |} |} =>
    fun peer_id =>
      match Tezos_p2p.P2p.find_connection p2p peer_id with
      | None => Lwt.return_unit
      | Some conn => Tezos_p2p.P2p.disconnect p2p None conn
      end
  end.

Definition shutdown (function_parameter : db) : Lwt.t unit :=
  match function_parameter with
  | {| p2p_readers := p2p_readers; active_chains := active_chains |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.P2p_peer.Table.fold
        (fun _peer_id =>
          fun reader =>
            fun acc =>
              Tezos_base__TzPervasives.op_gt_gt_eq (P2p_reader.shutdown reader)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => acc
                  end)) p2p_readers Lwt.return_unit)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.Chain_id.Table.fold
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                fun chain_db =>
                  fun acc =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Raw_operation.shutdown (operation_db chain_db))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Raw_block_header.shutdown
                              (block_header_db chain_db))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => acc
                              end)
                        end)
              end) active_chains Lwt.return_unit
        end)
  end.

Definition clear_block
  (chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
  : unit :=
  Raw_operations.clear_all (table (operations_db chain_db)) hash n;
  Raw_operation_hashes.clear_all (table (operation_hashes_db chain_db)) hash n;
  Raw_block_header.Table.clear_or_cancel (table (block_header_db chain_db)) hash.

Definition commit_block
  (chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  (header_data : Stdlib.Bytes.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  (operations_data : list (list Stdlib.Bytes.t))
  (result : Tezos_validation.Block_validation.validation_store)
  (forking_testchain : bool)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.block)) :=
  Tezos_base__TzPervasives.Block_hash.equal hash
    (Tezos_base__TzPervasives.Block_header.hash header);
  equiv_decb (Tezos_base__TzPervasives.List.length operations)
    (validation_passes (shell header));
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.Block.store None (chain_state chain_db) header
      header_data operations operations_data result forking_testchain)
    (fun res =>
      clear_block chain_db hash (validation_passes (shell header));
      Tezos_base__TzPervasives._return res).

Definition commit_invalid_block
  (chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  (errors : list Tezos_base__TzPervasives.error)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  Tezos_base__TzPervasives.Block_hash.equal hash
    (Tezos_base__TzPervasives.Block_header.hash header);
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.Block.store_invalid (chain_state chain_db) header errors)
    (fun res =>
      clear_block chain_db hash (validation_passes (shell header));
      Tezos_base__TzPervasives._return res).

Definition inject_operation
  (chain_db : chain_db) (h : Tezos_base__TzPervasives.Operation_hash.t)
  (op : Tezos_base__TzPervasives.Operation.t) : Lwt.t bool :=
  Tezos_base__TzPervasives.Operation_hash.equal h
    (Tezos_base__TzPervasives.Operation.hash op);
  Raw_operation.Table.inject (table (operation_db chain_db)) h op.

Definition commit_protocol
  (db : db) (h : Raw_protocol.Table.key)
  (p : Tezos_base__TzPervasives.Protocol.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Protocol.store (disk db) p)
    (fun res =>
      Raw_protocol.Table.clear_or_cancel (table (protocol_db db)) h;
      Tezos_base__TzPervasives._return (nequiv_decb res None)).

Definition watch_block_header (function_parameter : db)
  : (Lwt_stream.t
    (Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  match function_parameter with
  | {| block_input := block_input |} =>
    Tezos_base__TzPervasives.Lwt_watcher.create_stream block_input
  end.

Definition watch_operation (function_parameter : db)
  : (Lwt_stream.t
    (Tezos_base__TzPervasives.Operation_hash.t *
      Tezos_base__TzPervasives.Operation.t)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  match function_parameter with
  | {| operation_input := operation_input |} =>
    Tezos_base__TzPervasives.Lwt_watcher.create_stream operation_input
  end.

Module Raw.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.t
      (Tezos_p2p.P2p_message.t Message.t) :=
    Tezos_p2p.P2p_message.encoding (encoding Message.cfg).
  
  Definition chain_name
    : Tezos_base__TzPervasives.Distributed_db_version.name :=
    chain_name Message.cfg.
  
  Definition distributed_db_versions
    : list Tezos_base__TzPervasives.Distributed_db_version.t :=
    distributed_db_versions Message.cfg.
End Raw.

Module Block_header.
  Definition t := Tezos_base__TzPervasives.Block_header.t.
End Block_header.

Module Operation.

End Operation.

Module Protocol.
  Definition t := Tezos_base__TzPervasives.Protocol.t.
End Protocol.

Definition broadcast (chain_db : chain_db) (msg : Message.t) : unit :=
  Tezos_base__TzPervasives.P2p_peer.Table.iter
    (fun _peer_id =>
      fun state =>
        OCaml.Stdlib.ignore
          (Tezos_p2p.P2p.try_send (p2p (global_db chain_db)) (conn state) msg))
    (active_connections chain_db).

Definition try_send
  (chain_db : chain_db) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
  (msg : Message.t) : unit :=
  match
    Tezos_base__TzPervasives.P2p_peer.Table.find_opt
      (active_connections chain_db) peer_id with
  | None => tt
  | Some conn =>
    OCaml.Stdlib.ignore
      (Tezos_p2p.P2p.try_send (p2p (global_db chain_db)) (conn conn) msg)
  end.

Definition send
  (chain_db : chain_db)
  (peer : option Tezos_base__TzPervasives.P2p_peer.Table.key) (msg : Message.t)
  : unit :=
  match peer with
  | Some peer => try_send chain_db peer msg
  | None => broadcast chain_db msg
  end.

Module Request.
  Definition current_head
    (chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
    (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      let chain_id := Tezos_shell.State.Chain.id (chain_state chain_db) in
      match peer with
      | Some peer =>
        let meta :=
          Tezos_p2p.P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
        Tezos_shell_services.Peer_metadata.incr meta (Sent_request Head)
      | None => tt
      end;
      apply (send chain_db peer) (Get_current_head chain_id)
    end.
  
  Definition current_branch
    (chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
    (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      let chain_id := Tezos_shell.State.Chain.id (chain_state chain_db) in
      match peer with
      | Some peer =>
        let meta :=
          Tezos_p2p.P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
        Tezos_shell_services.Peer_metadata.incr meta (Sent_request Head)
      | None => tt
      end;
      apply (send chain_db peer) (Get_current_branch chain_id)
    end.
End Request.

Module Advertise.
  Definition current_head
    (chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
    (op_star_o_p_t_star : option Tezos_base__TzPervasives.Mempool.mempool)
    : Tezos_shell.State.Block.t -> unit :=
    let mempool :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => Tezos_base__TzPervasives.Mempool.empty
      end in
    fun head =>
      let chain_id := Tezos_shell.State.Chain.id (chain_state chain_db) in
      Tezos_base__TzPervasives.Chain_id.equal chain_id
        (Tezos_shell.State.Block.chain_id head);
      match peer with
      | Some peer =>
        let meta :=
          Tezos_p2p.P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
        Tezos_shell_services.Peer_metadata.incr meta (Sent_advertisement Head)
      | None => tt
      end;
      let msg_mempool :=
        Message.Current_head chain_id (Tezos_shell.State.Block.header head)
          mempool in
      if equiv_decb mempool Tezos_base__TzPervasives.Mempool.empty then
        send chain_db peer msg_mempool
      else
        let msg_disable_mempool :=
          Message.Current_head chain_id (Tezos_shell.State.Block.header head)
            Tezos_base__TzPervasives.Mempool.empty in
        let send_mempool (state : p2p_reader) : unit :=
          match
            Tezos_p2p.P2p.connection_remote_metadata (p2p (global_db chain_db))
              (conn state) with
          | {| Connection_metadata.disable_mempool := disable_mempool |} =>
            let msg :=
              if disable_mempool then
                msg_disable_mempool
              else
                msg_mempool in
            apply OCaml.Stdlib.ignore
              (Tezos_p2p.P2p.try_send (p2p (global_db chain_db)) (conn state)
                msg)
          end in
        match peer with
        | Some receiver_id =>
          let state :=
            Tezos_base__TzPervasives.P2p_peer.Table.find
              (active_connections chain_db) receiver_id in
          send_mempool state
        | None =>
          Tezos_base__TzPervasives.List.iter
            (fun function_parameter =>
              match function_parameter with
              | (_receiver_id, state) => send_mempool state
              end)
            (Tezos_base__TzPervasives.P2p_peer.Table.fold
              (fun k => fun v => fun acc => cons (k, v) acc)
              (active_connections chain_db) [])
        end.
  
  Definition current_branch
    (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t) (chain_db : chain_db)
    : Lwt.t unit :=
    let chain_id := Tezos_shell.State.Chain.id (chain_state chain_db) in
    let chain_state := chain_state chain_db in
    let sender_id := my_peer_id chain_db in
    match peer with
    | Some peer =>
      let meta :=
        Tezos_p2p.P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
      Tezos_shell_services.Peer_metadata.incr meta (Sent_advertisement Branch)
    | None => tt
    end;
    match peer with
    | Some receiver_id =>
      let seed :=
        {| Block_locator.sender_id := sender_id;
          Block_locator.receiver_id := receiver_id |} in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.Chain.locator chain_state seed)
        (fun locator =>
          let msg := Message.Current_branch chain_id locator in
          try_send chain_db receiver_id msg;
          Lwt.return_unit)
    | None =>
      Lwt_list.iter_p
        (fun function_parameter =>
          match function_parameter with
          | (receiver_id, state) =>
            let seed :=
              {| Block_locator.sender_id := sender_id;
                Block_locator.receiver_id := receiver_id |} in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.Chain.locator chain_state seed)
              (fun locator =>
                let msg := Message.Current_branch chain_id locator in
                OCaml.Stdlib.ignore
                  (Tezos_p2p.P2p.try_send (p2p (global_db chain_db))
                    (conn state) msg);
                Lwt.return_unit)
          end)
        (Tezos_base__TzPervasives.P2p_peer.Table.fold
          (fun k => fun v => fun acc => cons (k, v) acc)
          (active_connections chain_db) [])
    end.
End Advertise.
src/lib_shell/distributed_db.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell - High-level API for the Gossip network and local storage. *)

open Distributed_db_functors

type t

type db = t

module Message = Distributed_db_message

type p2p = (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.net

val create : State.t -> p2p -> t

val state : db -> State.t

val shutdown : t -> unit Lwt.t

(** {1 Network database} *)

(** An instance of the distributed DB for a given chain (mainchain,
    current testchain, ...) *)
type chain_db

(** Activate a given chain. The node will notify its neighbors that
    it now handles the given chain and that it expects notification
    for new head or new operations. *)
val activate : t -> State.Chain.t -> chain_db

(** Look for the database of an active chain. *)
val get_chain : t -> Chain_id.t -> chain_db option

(** Deactivate a given chain. The node will notify its neighbors
    that it does not care anymore about this chain. *)
val deactivate : chain_db -> unit Lwt.t

type callback = {
  notify_branch : P2p_peer.Id.t -> Block_locator.t -> unit;
  notify_head : P2p_peer.Id.t -> Block_header.t -> Mempool.t -> unit;
  disconnection : P2p_peer.Id.t -> unit;
}

(** Register all the possible callback from the distributed DB to the
    validator. *)
val set_callback : chain_db -> callback -> unit

(** Kick a given peer. *)
val disconnect : chain_db -> P2p_peer.Id.t -> unit Lwt.t

(** Greylist a given peer. *)
val greylist : chain_db -> P2p_peer.Id.t -> unit Lwt.t

(** Various accessors. *)
val chain_state : chain_db -> State.Chain.t

val db : chain_db -> db

val information :
  chain_db -> Chain_validator_worker_state.Distributed_db_state.view

(** Return the peer id of the node *)
val my_peer_id : chain_db -> P2p_peer.Id.t

val get_peer_metadata : chain_db -> P2p_peer.Id.t -> Peer_metadata.t

(** {1 Sending messages} *)

module Request : sig
  (** Send to a given peer, or to all known active peers for the
      chain, a friendly request "Hey, what's your current branch
      ?". The expected answer is a [Block_locator.t.]. *)
  val current_branch : chain_db -> ?peer:P2p_peer.Id.t -> unit -> unit

  (** Send to a given peer, or to all known active peers for the
      given chain, a friendly request "Hey, what's your current
      branch ?". The expected answer is a [Block_locator.t.]. *)
  val current_head : chain_db -> ?peer:P2p_peer.Id.t -> unit -> unit
end

module Advertise : sig
  (** Notify a given peer, or all known active peers for the
      chain, of a new head and possibly of new operations. *)
  val current_head :
    chain_db ->
    ?peer:P2p_peer.Id.t ->
    ?mempool:Mempool.t ->
    State.Block.t ->
    unit

  (** Notify a given peer, or all known active peers for the
      chain, of a new head and its sparse history. *)
  val current_branch : ?peer:P2p_peer.Id.t -> chain_db -> unit Lwt.t
end

(** {2 Block index} *)

(** Index of block headers. *)
module Block_header : sig
  type t = Block_header.t (* avoid shadowing. *)

  include
    DISTRIBUTED_DB
      with type t := chain_db
       and type key := Block_hash.t
       and type value := Block_header.t
       and type param := unit
end

(** Lookup for block header in any active chains *)
val read_block_header :
  db -> Block_hash.t -> (Chain_id.t * Block_header.t) option Lwt.t

(** Index of all the operations of a given block (per validation pass). *)
module Operations :
  DISTRIBUTED_DB
    with type t := chain_db
     and type key = Block_hash.t * int
     and type value = Operation.t list
     and type param := Operation_list_list_hash.t

(** Index of all the hashes of operations of a given block (per
    validation pass). *)
module Operation_hashes :
  DISTRIBUTED_DB
    with type t := chain_db
     and type key = Block_hash.t * int
     and type value = Operation_hash.t list
     and type param := Operation_list_list_hash.t

(** Store on disk all the data associated to a valid block. *)
val commit_block :
  chain_db ->
  Block_hash.t ->
  Block_header.t ->
  Bytes.t ->
  Operation.t list list ->
  Bytes.t list list ->
  Block_validation.validation_store ->
  forking_testchain:bool ->
  State.Block.t option tzresult Lwt.t

(** Store on disk all the data associated to an invalid block. *)
val commit_invalid_block :
  chain_db ->
  Block_hash.t ->
  Block_header.t ->
  Error_monad.error list ->
  bool tzresult Lwt.t

(** Monitor all the fetched block headers (for all activate chains). *)
val watch_block_header :
  t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Lwt_watcher.stopper

(** {2 Operations index} *)

(** Index of operations (for the mempool). *)
module Operation : sig
  type t = Operation.t (* avoid shadowing. *)

  include
    DISTRIBUTED_DB
      with type t := chain_db
       and type key := Operation_hash.t
       and type value := Operation.t
       and type param := unit
end

(** Inject a new operation in the local index (memory only). *)
val inject_operation :
  chain_db -> Operation_hash.t -> Operation.t -> bool Lwt.t

(** Monitor all the fetched operations (for all activate chains). *)
val watch_operation :
  t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Lwt_watcher.stopper

(** {2 Protocol index} *)

(** Index of protocol sources. *)
module Protocol : sig
  type t = Protocol.t (* avoid shadowing. *)

  include
    DISTRIBUTED_DB
      with type t := db
       and type key := Protocol_hash.t
       and type value := Protocol.t
       and type param := unit
end

(** Store on disk protocol sources. *)
val commit_protocol :
  db -> Protocol_hash.t -> Protocol.t -> bool tzresult Lwt.t

(**/**)

module Raw : sig
  val encoding : Message.t P2p_message.t Data_encoding.t

  val chain_name : Distributed_db_version.name

  val distributed_db_versions : Distributed_db_version.t list
end
src/lib_shell/distributed_db.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition db := t.

unhandled_module

Definition p2p :=
  Tezos_p2p.P2p.net Message.t Tezos_shell_services.Peer_metadata.t
    Tezos_shell_services.Connection_metadata.t.

Parameter create : Tezos_shell.State.t -> p2p -> t.

Parameter state : db -> Tezos_shell.State.t.

Parameter shutdown : t -> Lwt.t unit.

Parameter chain_db : Type.

Parameter activate : t -> Tezos_shell.State.Chain.t -> chain_db.

Parameter get_chain :
t -> Tezos_base__TzPervasives.Chain_id.t -> option chain_db.

Parameter deactivate : chain_db -> Lwt.t unit.

Record callback := {
  notify_branch :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_base__TzPervasives.Block_locator.t -> unit;
  notify_head :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_base__TzPervasives.Block_header.t ->
        Tezos_base__TzPervasives.Mempool.t -> unit;
  disconnection : Tezos_base__TzPervasives.P2p_peer.Id.t -> unit }.

Parameter set_callback : chain_db -> callback -> unit.

Parameter disconnect :
chain_db -> Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit.

Parameter greylist :
chain_db -> Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit.

Parameter chain_state : chain_db -> Tezos_shell.State.Chain.t.

Parameter db : chain_db -> db.

Parameter information :
chain_db ->
  Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view.

Parameter my_peer_id : chain_db -> Tezos_base__TzPervasives.P2p_peer.Id.t.

Parameter get_peer_metadata :
chain_db ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> Tezos_shell_services.Peer_metadata.t.

Module Request.
  Parameter current_branch : chain_db ->
    (option Tezos_base__TzPervasives.P2p_peer.Id.t) -> unit -> unit.
  
  Parameter current_head : chain_db ->
    (option Tezos_base__TzPervasives.P2p_peer.Id.t) -> unit -> unit.
End Request.

Module Advertise.
  Parameter current_head : chain_db ->
    (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
      (option Tezos_base__TzPervasives.Mempool.t) ->
        Tezos_shell.State.Block.t -> unit.
  
  Parameter current_branch : (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    chain_db -> Lwt.t unit.
End Advertise.

Module Block_header.
  Definition t := Tezos_base__TzPervasives.Block_header.t.
  
  include
End Block_header.

Parameter read_block_header :
db ->
  Tezos_base__TzPervasives.Block_hash.t ->
    Lwt.t (option (Tezos_base__TzPervasives.Chain_id.t * Block_header.t)).

unhandled_module

unhandled_module

Parameter commit_block :
chain_db ->
  Tezos_base__TzPervasives.Block_hash.t ->
    Block_header.t ->
      Stdlib.Bytes.t ->
        (list (list Tezos_base__TzPervasives.Operation.t)) ->
          (list (list Stdlib.Bytes.t)) ->
            Tezos_validation.Block_validation.validation_store ->
              bool ->
                Lwt.t
                  (Tezos_base__TzPervasives.tzresult
                    (option Tezos_shell.State.Block.t)).

Parameter commit_invalid_block :
chain_db ->
  Tezos_base__TzPervasives.Block_hash.t ->
    Block_header.t ->
      (list Tezos_base__TzPervasives.Error_monad.error) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult bool).

Parameter watch_block_header :
t ->
  (Lwt_stream.t (Tezos_base__TzPervasives.Block_hash.t * Block_header.t)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper.

Module Operation.
  Definition t := Tezos_base__TzPervasives.Operation.t.
  
  include
End Operation.

Parameter inject_operation :
chain_db ->
  Tezos_base__TzPervasives.Operation_hash.t -> Operation.t -> Lwt.t bool.

Parameter watch_operation :
t ->
  (Lwt_stream.t (Tezos_base__TzPervasives.Operation_hash.t * Operation.t)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper.

Module Protocol.
  Definition t := Tezos_base__TzPervasives.Protocol.t.
  
  include
End Protocol.

Parameter commit_protocol :
db ->
  Tezos_base__TzPervasives.Protocol_hash.t ->
    Protocol.t -> Lwt.t (Tezos_base__TzPervasives.tzresult bool).

Module Raw.
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t
    (Tezos_p2p.P2p_message.t Message.t).
  
  Parameter chain_name : Tezos_base__TzPervasives.Distributed_db_version.name.
  
  Parameter distributed_db_versions : list
    Tezos_base__TzPervasives.Distributed_db_version.t.
End Raw.
src/lib_shell/distributed_db_functors.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type DISTRIBUTED_DB = sig
  type t

  type key

  type value

  type param

  val known : t -> key -> bool Lwt.t

  type error += Missing_data of key

  type error += Canceled of key

  type error += Timeout of key

  val read : t -> key -> value tzresult Lwt.t

  val read_opt : t -> key -> value option Lwt.t

  val prefetch :
    t ->
    ?peer:P2p_peer.Id.t ->
    ?timeout:Time.System.Span.t ->
    key ->
    param ->
    unit

  val fetch :
    t ->
    ?peer:P2p_peer.Id.t ->
    ?timeout:Time.System.Span.t ->
    key ->
    param ->
    value tzresult Lwt.t

  val clear_or_cancel : t -> key -> unit

  val resolve_pending : t -> key -> value -> unit

  val inject : t -> key -> value -> bool Lwt.t

  val watch : t -> (key * value) Lwt_stream.t * Lwt_watcher.stopper

  val pending : t -> key -> bool
end

module type DISK_TABLE = sig
  type store

  type key

  type value

  val known : store -> key -> bool Lwt.t

  val read : store -> key -> value tzresult Lwt.t

  val read_opt : store -> key -> value option Lwt.t
end

module type MEMORY_TABLE = sig
  type 'a t

  type key

  val create : int -> 'a t

  val find : 'a t -> key -> 'a

  val find_opt : 'a t -> key -> 'a option

  val add : 'a t -> key -> 'a -> unit

  val replace : 'a t -> key -> 'a -> unit

  val remove : 'a t -> key -> unit

  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val length : 'a t -> int
end

module type SCHEDULER_EVENTS = sig
  type t

  type key

  val request : t -> P2p_peer.Id.t option -> key -> unit

  val notify : t -> P2p_peer.Id.t -> key -> unit

  val notify_cancellation : t -> key -> unit

  val notify_unrequested : t -> P2p_peer.Id.t -> key -> unit

  val notify_duplicate : t -> P2p_peer.Id.t -> key -> unit

  val notify_invalid : t -> P2p_peer.Id.t -> key -> unit

  val memory_table_length : t -> int
end

module type PRECHECK = sig
  type key

  type param

  type notified_value

  type value

  val precheck : key -> param -> notified_value -> value option
end

module Make_table (Hash : sig
  type t

  val name : string

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end)
(Disk_table : DISK_TABLE with type key := Hash.t)
(Memory_table : MEMORY_TABLE with type key := Hash.t)
(Scheduler : SCHEDULER_EVENTS with type key := Hash.t)
(Precheck : PRECHECK with type key := Hash.t and type value := Disk_table.value) : sig
  include
    DISTRIBUTED_DB
      with type key = Hash.t
       and type value = Disk_table.value
       and type param = Precheck.param

  val create :
    ?global_input:(key * value) Lwt_watcher.input ->
    Scheduler.t ->
    Disk_table.store ->
    t

  val notify :
    t -> P2p_peer.Id.t -> key -> Precheck.notified_value -> unit Lwt.t

  val memory_table_length : t -> int
end = struct
  type key = Hash.t

  type value = Disk_table.value

  type param = Precheck.param

  type t = {
    scheduler : Scheduler.t;
    disk : Disk_table.store;
    memory : status Memory_table.t;
    global_input : (key * value) Lwt_watcher.input option;
    input : (key * value) Lwt_watcher.input;
  }

  and status =
    | Pending of {
        waiter : value tzresult Lwt.t;
        wakener : value tzresult Lwt.u;
        mutable waiters : int;
        param : param;
      }
    | Found of value

  let known s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        Disk_table.known s.disk k
    | Some (Pending _) ->
        Lwt.return_false
    | Some (Found _) ->
        Lwt.return_true

  let read_opt s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        Disk_table.read_opt s.disk k
    | Some (Found v) ->
        Lwt.return_some v
    | Some (Pending _) ->
        Lwt.return_none

  type error += Missing_data of key

  type error += Canceled of key

  type error += Timeout of key

  let () =
    (* Missing data key *)
    register_error_kind
      `Permanent
      ~id:("distributed_db." ^ Hash.name ^ ".missing")
      ~title:("Missing " ^ Hash.name)
      ~description:("Some " ^ Hash.name ^ " is missing from the distributed db")
      ~pp:(fun ppf key ->
        Format.fprintf ppf "Missing %s %a" Hash.name Hash.pp key)
      (Data_encoding.obj1 (Data_encoding.req "key" Hash.encoding))
      (function Missing_data key -> Some key | _ -> None)
      (fun key -> Missing_data key) ;
    (* Canceled key *)
    register_error_kind
      `Permanent
      ~title:("Canceled fetch of a " ^ Hash.name)
      ~description:("The fetch of a " ^ Hash.name ^ " has been canceled")
      ~id:("distributed_db." ^ Hash.name ^ ".fetch_canceled")
      ~pp:(fun ppf key ->
        Format.fprintf ppf "Fetch of %s %a canceled" Hash.name Hash.pp key)
      Data_encoding.(obj1 (req "key" Hash.encoding))
      (function Canceled key -> Some key | _ -> None)
      (fun key -> Canceled key) ;
    (* Timeout key *)
    register_error_kind
      `Permanent
      ~title:("Timed out fetch of a " ^ Hash.name)
      ~description:("The fetch of a " ^ Hash.name ^ " has timed out")
      ~id:("distributed_db." ^ Hash.name ^ ".fetch_timeout")
      ~pp:(fun ppf key ->
        Format.fprintf ppf "Fetch of %s %a timed out" Hash.name Hash.pp key)
      Data_encoding.(obj1 (req "key" Hash.encoding))
      (function Timeout key -> Some key | _ -> None)
      (fun key -> Timeout key)

  let read s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        trace (Missing_data k) @@ Disk_table.read s.disk k
    | Some (Found v) ->
        return v
    | Some (Pending _) ->
        fail (Missing_data k)

  let wrap s k ?timeout t =
    let t = Lwt.protected t in
    Lwt.on_cancel t (fun () ->
        match Memory_table.find_opt s.memory k with
        | None ->
            ()
        | Some (Found _) ->
            ()
        | Some (Pending data) ->
            data.waiters <- data.waiters - 1 ;
            if data.waiters = 0 then (
              Memory_table.remove s.memory k ;
              Scheduler.notify_cancellation s.scheduler k )) ;
    match timeout with
    | None ->
        t
    | Some delay ->
        let timeout = Systime_os.sleep delay >>= fun () -> fail (Timeout k) in
        Lwt.pick [t; timeout]

  let fetch s ?peer ?timeout k param =
    match Memory_table.find_opt s.memory k with
    | None -> (
        Disk_table.read_opt s.disk k
        >>= function
        | Some v ->
            return v
        | None -> (
          match Memory_table.find_opt s.memory k with
          | None ->
              let (waiter, wakener) = Lwt.wait () in
              Memory_table.add
                s.memory
                k
                (Pending {waiter; wakener; waiters = 1; param}) ;
              Scheduler.request s.scheduler peer k ;
              wrap s k ?timeout waiter
          | Some (Pending data) ->
              Scheduler.request s.scheduler peer k ;
              data.waiters <- data.waiters + 1 ;
              wrap s k ?timeout data.waiter
          | Some (Found v) ->
              return v ) )
    | Some (Pending data) ->
        Scheduler.request s.scheduler peer k ;
        data.waiters <- data.waiters + 1 ;
        wrap s k ?timeout data.waiter
    | Some (Found v) ->
        return v

  let prefetch s ?peer ?timeout k param =
    try ignore (fetch s ?peer ?timeout k param) with _ -> ()

  let notify s p k v =
    match Memory_table.find_opt s.memory k with
    | None -> (
        Disk_table.known s.disk k
        >>= function
        | true ->
            Scheduler.notify_duplicate s.scheduler p k ;
            Lwt.return_unit
        | false ->
            Scheduler.notify_unrequested s.scheduler p k ;
            Lwt.return_unit )
    | Some (Pending {wakener = w; param; _}) -> (
      match Precheck.precheck k param v with
      | None ->
          Scheduler.notify_invalid s.scheduler p k ;
          Lwt.return_unit
      | Some v ->
          Scheduler.notify s.scheduler p k ;
          Memory_table.replace s.memory k (Found v) ;
          Lwt.wakeup_later w (Ok v) ;
          Option.iter s.global_input ~f:(fun input ->
              Lwt_watcher.notify input (k, v)) ;
          Lwt_watcher.notify s.input (k, v) ;
          Lwt.return_unit )
    | Some (Found _) ->
        Scheduler.notify_duplicate s.scheduler p k ;
        Lwt.return_unit

  let inject s k v =
    match Memory_table.find_opt s.memory k with
    | None -> (
        Disk_table.known s.disk k
        >>= function
        | true ->
            Lwt.return_false
        | false ->
            Memory_table.add s.memory k (Found v) ;
            Lwt.return_true )
    | Some (Pending _) | Some (Found _) ->
        Lwt.return_false

  let resolve_pending s k v =
    match Memory_table.find_opt s.memory k with
    | Some (Pending {wakener; _}) ->
        Scheduler.notify_cancellation s.scheduler k ;
        Memory_table.replace s.memory k (Found v) ;
        Lwt.wakeup_later wakener (Ok v) ;
        Option.iter s.global_input ~f:(fun input ->
            Lwt_watcher.notify input (k, v)) ;
        Lwt_watcher.notify s.input (k, v)
    | _ ->
        ()

  let clear_or_cancel s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        ()
    | Some (Pending {wakener = w; _}) ->
        Scheduler.notify_cancellation s.scheduler k ;
        Memory_table.remove s.memory k ;
        Lwt.wakeup_later w (error (Canceled k))
    | Some (Found _) ->
        Memory_table.remove s.memory k

  let watch s = Lwt_watcher.create_stream s.input

  let create ?global_input scheduler disk =
    let memory = Memory_table.create 17 in
    let input = Lwt_watcher.create_input () in
    {scheduler; disk; memory; input; global_input}

  let pending s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        false
    | Some (Found _) ->
        false
    | Some (Pending _) ->
        true

  let memory_table_length s = Memory_table.length s.memory
end

module type REQUEST = sig
  type key

  type param

  val initial_delay : Time.System.Span.t

  val active : param -> P2p_peer.Set.t

  val send : param -> P2p_peer.Id.t -> key list -> unit
end

module Make_request_scheduler (Hash : sig
  type t

  val name : string

  module Logging : sig
    val tag : t Tag.def
  end
end)
(Table : MEMORY_TABLE with type key := Hash.t)
(Request : REQUEST with type key := Hash.t) : sig
  type t

  val create : Request.param -> t

  val shutdown : t -> unit Lwt.t

  include SCHEDULER_EVENTS with type t := t and type key := Hash.t

  val memory_table_length : t -> int
end = struct
  include Internal_event.Legacy_logging.Make_semantic (struct
    let name = "node.distributed_db.scheduler." ^ Hash.name
  end)

  type key = Hash.t

  type t = {
    param : Request.param;
    pending : status Table.t;
    queue : event Lwt_pipe.t;
    mutable events : event list Lwt.t;
    canceler : Lwt_canceler.t;
    mutable worker : unit Lwt.t;
  }

  and status = {
    peers : P2p_peer.Set.t;
    next_request : Time.System.t;
    delay : Time.System.Span.t;
  }

  and event =
    | Request of P2p_peer.Id.t option * key
    | Notify of P2p_peer.Id.t * key
    | Notify_cancellation of key
    | Notify_invalid of P2p_peer.Id.t * key
    | Notify_duplicate of P2p_peer.Id.t * key
    | Notify_unrequested of P2p_peer.Id.t * key

  let request t p k = assert (Lwt_pipe.push_now t.queue (Request (p, k)))

  let notify t p k =
    debug
      Tag.DSL.(
        fun f ->
          f "push received %a from %a"
          -% t event "push_received" -% a Hash.Logging.tag k
          -% a P2p_peer.Id.Logging.tag p) ;
    assert (Lwt_pipe.push_now t.queue (Notify (p, k)))

  let notify_cancellation t k =
    debug
      Tag.DSL.(
        fun f ->
          f "push cancellation %a"
          -% t event "push_cancellation"
          -% a Hash.Logging.tag k) ;
    assert (Lwt_pipe.push_now t.queue (Notify_cancellation k))

  let notify_invalid t p k =
    debug
      Tag.DSL.(
        fun f ->
          f "push received invalid %a from %a"
          -% t event "push_received_invalid"
          -% a Hash.Logging.tag k
          -% a P2p_peer.Id.Logging.tag p) ;
    assert (Lwt_pipe.push_now t.queue (Notify_invalid (p, k)))

  let notify_duplicate t p k =
    debug
      Tag.DSL.(
        fun f ->
          f "push received duplicate %a from %a"
          -% t event "push_received_duplicate"
          -% a Hash.Logging.tag k
          -% a P2p_peer.Id.Logging.tag p) ;
    assert (Lwt_pipe.push_now t.queue (Notify_duplicate (p, k)))

  let notify_unrequested t p k =
    debug
      Tag.DSL.(
        fun f ->
          f "push received unrequested %a from %a"
          -% t event "push_received_unrequested"
          -% a Hash.Logging.tag k
          -% a P2p_peer.Id.Logging.tag p) ;
    assert (Lwt_pipe.push_now t.queue (Notify_unrequested (p, k)))

  let compute_timeout state =
    let next =
      Table.fold
        (fun _ {next_request; _} acc ->
          match acc with
          | None ->
              Some next_request
          | Some x ->
              Some (Time.System.min x next_request))
        state.pending
        None
    in
    match next with
    | None ->
        fst @@ Lwt.task ()
    | Some next ->
        let now = Systime_os.now () in
        let delay = Ptime.diff next now in
        if Ptime.Span.compare delay Ptime.Span.zero <= 0 then Lwt.return_unit
        else Systime_os.sleep delay

  let process_event state now = function
    | Request (peer, key) -> (
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "registering request %a from %a"
              -% t event "registering_request"
              -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag_opt peer)
        >>= fun () ->
        try
          let data = Table.find state.pending key in
          let peers =
            match peer with
            | None ->
                data.peers
            | Some peer ->
                P2p_peer.Set.add peer data.peers
          in
          let next_request = now in
          Table.replace
            state.pending
            key
            {delay = Request.initial_delay; next_request; peers} ;
          lwt_debug
            Tag.DSL.(
              fun f ->
                f "registering request %a from %a -> replaced"
                -% t event "registering_request_replaced"
                -% a Hash.Logging.tag key
                -% a P2p_peer.Id.Logging.tag_opt peer)
        with Not_found ->
          let peers =
            match peer with
            | None ->
                P2p_peer.Set.empty
            | Some peer ->
                P2p_peer.Set.singleton peer
          in
          Table.add
            state.pending
            key
            {peers; next_request = now; delay = Request.initial_delay} ;
          lwt_debug
            Tag.DSL.(
              fun f ->
                f "registering request %a from %a -> added"
                -% t event "registering_request_added"
                -% a Hash.Logging.tag key
                -% a P2p_peer.Id.Logging.tag_opt peer) )
    | Notify (peer, key) ->
        Table.remove state.pending key ;
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "received %a from %a" -% t event "received"
              -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag peer)
    | Notify_cancellation key ->
        Table.remove state.pending key ;
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "canceled %a" -% t event "canceled" -% a Hash.Logging.tag key)
    | Notify_invalid (peer, key) ->
        (* TODO *)
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "received invalid %a from %a"
              -% t event "received_invalid" -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag peer)
    | Notify_unrequested (peer, key) ->
        (* TODO *)
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "received unrequested %a from %a"
              -% t event "received_unrequested"
              -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag peer)
    | Notify_duplicate (peer, key) ->
        (* TODO *)
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "received duplicate %a from %a"
              -% t event "received_duplicate"
              -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag peer)

  let worker_loop state =
    let shutdown = Lwt_canceler.cancellation state.canceler in
    let rec loop state =
      let timeout = compute_timeout state in
      Lwt.choose [(state.events >|= fun _ -> ()); timeout; shutdown]
      >>= fun () ->
      if Lwt.state shutdown <> Lwt.Sleep then
        lwt_debug Tag.DSL.(fun f -> f "terminating" -% t event "terminating")
      else if Lwt.state state.events <> Lwt.Sleep then (
        let now = Systime_os.now () in
        state.events
        >>= fun events ->
        state.events <- Lwt_pipe.pop_all state.queue ;
        Lwt_list.iter_s (process_event state now) events
        >>= fun () -> loop state )
      else
        lwt_debug Tag.DSL.(fun f -> f "timeout" -% t event "timeout")
        >>= fun () ->
        let now = Systime_os.now () in
        let active_peers = Request.active state.param in
        let requests =
          Table.fold
            (fun key {peers; next_request; delay} acc ->
              if Ptime.is_later next_request ~than:now then acc
              else
                let remaining_peers = P2p_peer.Set.inter peers active_peers in
                if
                  P2p_peer.Set.is_empty remaining_peers
                  && not (P2p_peer.Set.is_empty peers)
                then (
                  Table.remove state.pending key ;
                  acc )
                else
                  let requested_peer =
                    P2p_peer.Id.Set.random_elt
                      ( if P2p_peer.Set.is_empty remaining_peers then
                        active_peers
                      else remaining_peers )
                  in
                  let next_request =
                    Option.unopt ~default:Ptime.max (Ptime.add_span now delay)
                  in
                  let next =
                    {
                      peers = remaining_peers;
                      next_request;
                      delay = Time.System.Span.multiply_exn 1.5 delay;
                    }
                  in
                  Table.replace state.pending key next ;
                  let requests =
                    try key :: P2p_peer.Map.find requested_peer acc
                    with Not_found -> [key]
                  in
                  P2p_peer.Map.add requested_peer requests acc)
            state.pending
            P2p_peer.Map.empty
        in
        P2p_peer.Map.iter (Request.send state.param) requests ;
        P2p_peer.Map.fold
          (fun peer request acc ->
            acc
            >>= fun () ->
            Lwt_list.iter_s
              (fun key ->
                lwt_debug
                  Tag.DSL.(
                    fun f ->
                      f "requested %a from %a" -% t event "requested"
                      -% a Hash.Logging.tag key
                      -% a P2p_peer.Id.Logging.tag peer))
              request)
          requests
          Lwt.return_unit
        >>= fun () -> loop state
    in
    loop state

  let create param =
    let state =
      {
        param;
        queue = Lwt_pipe.create ();
        pending = Table.create 17;
        events = Lwt.return_nil;
        canceler = Lwt_canceler.create ();
        worker = Lwt.return_unit;
      }
    in
    state.worker <-
      Lwt_utils.worker
        "db_request_scheduler"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop state)
        ~cancel:(fun () -> Lwt_canceler.cancel state.canceler) ;
    state

  let shutdown s = Lwt_canceler.cancel s.canceler >>= fun () -> s.worker

  let memory_table_length s = Table.length s.pending
end
src/lib_shell/distributed_db_functors.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module DISTRIBUTED_DB.
  Record signature {t key value param : Type} := {
    t := t;
    key := key;
    value := value;
    param := param;
    known : t -> key -> Lwt.t bool;
    extensible_type;
    extensible_type;
    extensible_type;
    read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : t -> key -> Lwt.t (option value);
    prefetch : t ->
      (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
        (option Tezos_base__TzPervasives.Time.System.Span.t) ->
          key -> param -> unit;
    fetch : t ->
      (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
        (option Tezos_base__TzPervasives.Time.System.Span.t) ->
          key -> param -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    clear_or_cancel : t -> key -> unit;
    resolve_pending : t -> key -> value -> unit;
    inject : t -> key -> value -> Lwt.t bool;
    watch : t ->
      (Lwt_stream.t (key * value)) *
        Tezos_base__TzPervasives.Lwt_watcher.stopper;
    pending : t -> key -> bool;
  }.
  Arguments signature : clear implicits.
End DISTRIBUTED_DB.

Module DISK_TABLE.
  Record signature {store key value : Type} := {
    store := store;
    key := key;
    value := value;
    known : store -> key -> Lwt.t bool;
    read : store -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : store -> key -> Lwt.t (option value);
  }.
  Arguments signature : clear implicits.
End DISK_TABLE.

Module MEMORY_TABLE.
  Record signature {t key : Type} := {
    polymorphic_abstract_type;
    key := key;
    create : forall {a : Type}, Z -> t a;
    find : forall {a : Type}, (t a) -> key -> a;
    find_opt : forall {a : Type}, (t a) -> key -> option a;
    add : forall {a : Type}, (t a) -> key -> a -> unit;
    replace : forall {a : Type}, (t a) -> key -> a -> unit;
    remove : forall {a : Type}, (t a) -> key -> unit;
    fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
    length : forall {a : Type}, (t a) -> Z;
  }.
  Arguments signature : clear implicits.
End MEMORY_TABLE.

Module SCHEDULER_EVENTS.
  Record signature {t key : Type} := {
    t := t;
    key := key;
    request : t ->
      (option Tezos_base__TzPervasives.P2p_peer.Id.t) -> key -> unit;
    notify : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
    notify_cancellation : t -> key -> unit;
    notify_unrequested : t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
    notify_duplicate : t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
    notify_invalid : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
    memory_table_length : t -> Z;
  }.
  Arguments signature : clear implicits.
End SCHEDULER_EVENTS.

Module PRECHECK.
  Record signature {key param notified_value value : Type} := {
    key := key;
    param := param;
    notified_value := notified_value;
    value := value;
    precheck : key -> param -> notified_value -> option value;
  }.
  Arguments signature : clear implicits.
End PRECHECK.

Module REQUEST.
  Record signature {key param : Type} := {
    key := key;
    param := param;
    initial_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    active : param -> Tezos_base__TzPervasives.P2p_peer.Set.t;
    send : param -> Tezos_base__TzPervasives.P2p_peer.Id.t -> (list key) -> unit;
  }.
  Arguments signature : clear implicits.
End REQUEST.
src/lib_shell/distributed_db_functors.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell - High-level API for the Gossip network and local
                  storage (helpers). *)

(** {1 Indexes} *)

(** Generic interface for a "distributed" index.

    By "distributed", it means that this interface abstract the P2P
    gossip layer and it is able to fetch missing data from known
    peers in a "synchronous" interface.

*)
module type DISTRIBUTED_DB = sig
  type t

  (** The index key *)
  type key

  (** The indexed data *)
  type value

  (** An extra parameter for the network lookup, usually
      used for prevalidating data. *)
  type param

  (** Is the value known locally? *)
  val known : t -> key -> bool Lwt.t

  type error += Missing_data of key

  type error += Canceled of key

  type error += Timeout of key

  (** Return the value if it is known locally, otherwise fail with
      the error [Missing_data]. *)
  val read : t -> key -> value tzresult Lwt.t

  (** Return the value if it is known locally, otherwise fail with
      the value [None]. *)
  val read_opt : t -> key -> value option Lwt.t

  (** Same as `fetch` but the call is non-blocking: the data will be
      stored in the local index when received. *)
  val prefetch :
    t ->
    ?peer:P2p_peer.Id.t ->
    ?timeout:Time.System.Span.t ->
    key ->
    param ->
    unit

  (** Return the value if it is known locally, or block until the data
      is received from the network. By default, the data will be
      requested to all the active peers in the network; if the [peer]
      argument is provided, the data will only be requested to the
      provided peer. By default, the resulting promise will block
      forever if the data is never received. If [timeout] is provided
      the promise will be resolved with the error [Timeout] after the
      provided amount of seconds.

      A internal scheduler is able to re-send the request with an
      exponential back-off until the data is received. If the function
      is called multiple time with the same key but with distinct
      peers, the internal scheduler randomly chooses the requested
      peer (at each retry). *)
  val fetch :
    t ->
    ?peer:P2p_peer.Id.t ->
    ?timeout:Time.System.Span.t ->
    key ->
    param ->
    value tzresult Lwt.t

  (** Remove the data from the local index or cancel all pending
      request. Any pending [fetch] promises are resolved with the
      error [Canceled]. *)
  val clear_or_cancel : t -> key -> unit

  (** [resolve_pending t pids k v] resolves pending request (if any) in the
      local index for key k with [Found v]. It notifies the scheduler using
      'notify_cancellation' for this key and wakes up the waiter on this
      request. *)
  val resolve_pending : t -> key -> value -> unit

  val inject : t -> key -> value -> bool Lwt.t

  (** Monitor all the fetched data. A given data will appear only
      once. *)
  val watch : t -> (key * value) Lwt_stream.t * Lwt_watcher.stopper

  val pending : t -> key -> bool
end

module type DISK_TABLE = sig
  type store

  type key

  type value

  val known : store -> key -> bool Lwt.t

  val read : store -> key -> value tzresult Lwt.t

  val read_opt : store -> key -> value option Lwt.t
end

module type MEMORY_TABLE = sig
  (* A subtype of Hashtbl.S *)
  type 'a t

  type key

  val create : int -> 'a t

  val find : 'a t -> key -> 'a

  val find_opt : 'a t -> key -> 'a option

  val add : 'a t -> key -> 'a -> unit

  val replace : 'a t -> key -> 'a -> unit

  val remove : 'a t -> key -> unit

  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val length : 'a t -> int
end

module type SCHEDULER_EVENTS = sig
  type t

  type key

  val request : t -> P2p_peer.Id.t option -> key -> unit

  val notify : t -> P2p_peer.Id.t -> key -> unit

  val notify_cancellation : t -> key -> unit

  val notify_unrequested : t -> P2p_peer.Id.t -> key -> unit

  val notify_duplicate : t -> P2p_peer.Id.t -> key -> unit

  val notify_invalid : t -> P2p_peer.Id.t -> key -> unit

  val memory_table_length : t -> int
end

module type PRECHECK = sig
  type key

  type param

  type notified_value

  type value

  val precheck : key -> param -> notified_value -> value option
end

module Make_table (Hash : sig
  type t

  val name : string

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end)
(Disk_table : DISK_TABLE with type key := Hash.t)
(Memory_table : MEMORY_TABLE with type key := Hash.t)
(Scheduler : SCHEDULER_EVENTS with type key := Hash.t)
(Precheck : PRECHECK with type key := Hash.t and type value := Disk_table.value) : sig
  include
    DISTRIBUTED_DB
      with type key = Hash.t
       and type value = Disk_table.value
       and type param = Precheck.param

  val create :
    ?global_input:(key * value) Lwt_watcher.input ->
    Scheduler.t ->
    Disk_table.store ->
    t

  val notify :
    t -> P2p_peer.Id.t -> key -> Precheck.notified_value -> unit Lwt.t

  val memory_table_length : t -> int
end

module type REQUEST = sig
  type key

  type param

  val initial_delay : Time.System.Span.t

  val active : param -> P2p_peer.Set.t

  val send : param -> P2p_peer.Id.t -> key list -> unit
end

module Make_request_scheduler (Hash : sig
  type t

  val name : string

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit

  module Logging : sig
    val tag : t Tag.def
  end
end)
(Table : MEMORY_TABLE with type key := Hash.t)
(Request : REQUEST with type key := Hash.t) : sig
  type t

  val create : Request.param -> t

  val shutdown : t -> unit Lwt.t

  include SCHEDULER_EVENTS with type t := t and type key := Hash.t
end
src/lib_shell/distributed_db_functors.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

module_type

module_type

module_type

unhandled_module

module_type

unhandled_module
src/lib_shell/distributed_db_message.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Bounded_encoding = struct
  open Data_encoding

  let block_header_max_size = ref (Some (8 * 1024 * 1024))

  (* FIXME: arbitrary *)

  let block_header_cache =
    ref (Block_header.bounded_encoding ?max_size:!block_header_max_size ())

  let block_locator_cache =
    ref
      (Block_locator.bounded_encoding
         ?max_header_size:!block_header_max_size
         ())

  let update_block_header_encoding () =
    block_header_cache :=
      Block_header.bounded_encoding ?max_size:!block_header_max_size () ;
    block_locator_cache :=
      Block_locator.bounded_encoding ?max_header_size:!block_header_max_size ()

  let set_block_header_max_size max =
    block_header_max_size := max ;
    update_block_header_encoding ()

  let block_header = delayed (fun () -> !block_header_cache)

  let block_locator = delayed (fun () -> !block_locator_cache)

  (* FIXME: all constants below are arbitrary high bounds until we
     have the mechanism to update them properly *)
  let operation_max_size = ref (Some (128 * 1024)) (* FIXME: arbitrary *)

  let operation_list_max_size = ref (Some (1024 * 1024)) (* FIXME: arbitrary *)

  let operation_list_max_length = ref None (* FIXME: arbitrary *)

  let operation_max_pass = ref (Some 8) (* FIXME: arbitrary *)

  let operation_cache =
    ref (Operation.bounded_encoding ?max_size:!operation_max_size ())

  let operation_list_cache =
    ref
      (Operation.bounded_list_encoding
         ?max_length:!operation_list_max_length
         ?max_size:!operation_list_max_size
         ?max_operation_size:!operation_max_size
         ?max_pass:!operation_max_pass
         ())

  let operation_hash_list_cache =
    ref
      (Operation.bounded_hash_list_encoding
         ?max_length:!operation_list_max_length
         ?max_pass:!operation_max_pass
         ())

  let update_operation_list_encoding () =
    operation_list_cache :=
      Operation.bounded_list_encoding
        ?max_length:!operation_list_max_length
        ?max_size:!operation_list_max_size
        ?max_operation_size:!operation_max_size
        ?max_pass:!operation_max_pass
        ()

  let update_operation_hash_list_encoding () =
    operation_list_cache :=
      Operation.bounded_list_encoding
        ?max_length:!operation_list_max_length
        ?max_pass:!operation_max_pass
        ()

  let update_operation_encoding () =
    operation_cache :=
      Operation.bounded_encoding ?max_size:!operation_max_size ()

  let set_operation_max_size max =
    operation_max_size := max ;
    update_operation_encoding () ;
    update_operation_list_encoding ()

  let set_operation_list_max_size max =
    operation_list_max_size := max ;
    update_operation_list_encoding ()

  let set_operation_list_max_length max =
    operation_list_max_length := max ;
    update_operation_list_encoding () ;
    update_operation_hash_list_encoding ()

  let set_operation_max_pass max =
    operation_max_pass := max ;
    update_operation_list_encoding () ;
    update_operation_hash_list_encoding ()

  let operation = delayed (fun () -> !operation_cache)

  let operation_list = delayed (fun () -> !operation_list_cache)

  let operation_hash_list = delayed (fun () -> !operation_hash_list_cache)

  let protocol_max_size = ref (Some (2 * 1024 * 1024)) (* FIXME: arbitrary *)

  let protocol_cache =
    ref (Protocol.bounded_encoding ?max_size:!protocol_max_size ())

  let set_protocol_max_size max = protocol_max_size := max

  let protocol = delayed (fun () -> !protocol_cache)

  let mempool_max_operations = ref None

  let mempool_cache =
    ref (Mempool.bounded_encoding ?max_operations:!mempool_max_operations ())

  let set_mempool_max_operations max = mempool_max_operations := max

  let mempool = delayed (fun () -> !mempool_cache)
end

type t =
  | Get_current_branch of Chain_id.t
  | Current_branch of Chain_id.t * Block_locator.t
  | Deactivate of Chain_id.t
  | Get_current_head of Chain_id.t
  | Current_head of Chain_id.t * Block_header.t * Mempool.t
  | Get_block_headers of Block_hash.t list
  | Block_header of Block_header.t
  | Get_operations of Operation_hash.t list
  | Operation of Operation.t
  | Get_protocols of Protocol_hash.t list
  | Protocol of Protocol.t
  | Get_operation_hashes_for_blocks of (Block_hash.t * int) list
  | Operation_hashes_for_block of
      Block_hash.t
      * int
      * Operation_hash.t list
      * Operation_list_list_hash.path
  | Get_operations_for_blocks of (Block_hash.t * int) list
  | Operations_for_block of
      Block_hash.t * int * Operation.t list * Operation_list_list_hash.path

let encoding =
  let open Data_encoding in
  let case ?max_length ~tag ~title encoding unwrap wrap =
    P2p_message.Encoding {tag; title; encoding; wrap; unwrap; max_length}
  in
  [ case
      ~tag:0x10
      ~title:"Get_current_branch"
      (obj1 (req "get_current_branch" Chain_id.encoding))
      (function Get_current_branch chain_id -> Some chain_id | _ -> None)
      (fun chain_id -> Get_current_branch chain_id);
    case
      ~tag:0x11
      ~title:"Current_branch"
      (obj2
         (req "chain_id" Chain_id.encoding)
         (req "current_branch" Bounded_encoding.block_locator))
      (function
        | Current_branch (chain_id, locator) ->
            Some (chain_id, locator)
        | _ ->
            None)
      (fun (chain_id, locator) -> Current_branch (chain_id, locator));
    case
      ~tag:0x12
      ~title:"Deactivate"
      (obj1 (req "deactivate" Chain_id.encoding))
      (function Deactivate chain_id -> Some chain_id | _ -> None)
      (fun chain_id -> Deactivate chain_id);
    case
      ~tag:0x13
      ~title:"Get_current_head"
      (obj1 (req "get_current_head" Chain_id.encoding))
      (function Get_current_head chain_id -> Some chain_id | _ -> None)
      (fun chain_id -> Get_current_head chain_id);
    case
      ~tag:0x14
      ~title:"Current_head"
      (obj3
         (req "chain_id" Chain_id.encoding)
         (req
            "current_block_header"
            (dynamic_size Bounded_encoding.block_header))
         (req "current_mempool" Bounded_encoding.mempool))
      (function
        | Current_head (chain_id, bh, mempool) ->
            Some (chain_id, bh, mempool)
        | _ ->
            None)
      (fun (chain_id, bh, mempool) -> Current_head (chain_id, bh, mempool));
    case
      ~tag:0x20
      ~title:"Get_block_headers"
      (obj1 (req "get_block_headers" (list ~max_length:10 Block_hash.encoding)))
      (function Get_block_headers bhs -> Some bhs | _ -> None)
      (fun bhs -> Get_block_headers bhs);
    case
      ~tag:0x21
      ~title:"Block_header"
      (obj1 (req "block_header" Bounded_encoding.block_header))
      (function Block_header bh -> Some bh | _ -> None)
      (fun bh -> Block_header bh);
    case
      ~tag:0x30
      ~title:"Get_operations"
      (obj1
         (req "get_operations" (list ~max_length:10 Operation_hash.encoding)))
      (function Get_operations bhs -> Some bhs | _ -> None)
      (fun bhs -> Get_operations bhs);
    case
      ~tag:0x31
      ~title:"Operation"
      (obj1 (req "operation" Bounded_encoding.operation))
      (function Operation o -> Some o | _ -> None)
      (fun o -> Operation o);
    case
      ~tag:0x40
      ~title:"Get_protocols"
      (obj1 (req "get_protocols" (list ~max_length:10 Protocol_hash.encoding)))
      (function Get_protocols protos -> Some protos | _ -> None)
      (fun protos -> Get_protocols protos);
    case
      ~tag:0x41
      ~title:"Protocol"
      (obj1 (req "protocol" Bounded_encoding.protocol))
      (function Protocol proto -> Some proto | _ -> None)
      (fun proto -> Protocol proto);
    case
      ~tag:0x50
      ~title:"Get_operation_hashes_for_blocks"
      (obj1
         (req
            "get_operation_hashes_for_blocks"
            (list ~max_length:10 (tup2 Block_hash.encoding int8))))
      (function
        | Get_operation_hashes_for_blocks keys -> Some keys | _ -> None)
      (fun keys -> Get_operation_hashes_for_blocks keys);
    case
      ~tag:0x51
      ~title:"Operation_hashes_for_blocks"
      (merge_objs
         (obj1
            (req
               "operation_hashes_for_block"
               (obj2
                  (req "hash" Block_hash.encoding)
                  (req "validation_pass" int8))))
         Bounded_encoding.operation_hash_list)
      (function
        | Operation_hashes_for_block (block, ofs, ops, path) ->
            Some ((block, ofs), (path, ops))
        | _ ->
            None)
      (fun ((block, ofs), (path, ops)) ->
        Operation_hashes_for_block (block, ofs, ops, path));
    case
      ~tag:0x60
      ~title:"Get_operations_for_blocks"
      (obj1
         (req
            "get_operations_for_blocks"
            (list
               ~max_length:10
               (obj2
                  (req "hash" Block_hash.encoding)
                  (req "validation_pass" int8)))))
      (function Get_operations_for_blocks keys -> Some keys | _ -> None)
      (fun keys -> Get_operations_for_blocks keys);
    case
      ~tag:0x61
      ~title:"Operations_for_blocks"
      (merge_objs
         (obj1
            (req
               "operations_for_block"
               (obj2
                  (req "hash" Block_hash.encoding)
                  (req "validation_pass" int8))))
         Bounded_encoding.operation_list)
      (function
        | Operations_for_block (block, ofs, ops, path) ->
            Some ((block, ofs), (path, ops))
        | _ ->
            None)
      (fun ((block, ofs), (path, ops)) ->
        Operations_for_block (block, ofs, ops, path)) ]

let cfg : _ P2p.message_config =
  {
    encoding;
    chain_name = Distributed_db_version.chain_name;
    distributed_db_versions = [Distributed_db_version.zero];
  }

let raw_encoding = P2p_message.encoding encoding

let pp_json ppf msg =
  Data_encoding.Json.pp
    ppf
    (Data_encoding.Json.construct raw_encoding (Message msg))

module Logging = struct
  let tag = Tag.def ~doc:"Message" "message" pp_json
end
src/lib_shell/distributed_db_message.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Bounded_encoding.
  Import Tezos_base__TzPervasives.Data_encoding.
  
  Definition block_header_max_size : Stdlib.ref (option Z) :=
    Stdlib.ref (Some (Z.mul (Z.mul 8 1024) 1024)).
  
  Definition block_header_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        Tezos_base__TzPervasives.Block_header.t) :=
    Stdlib.ref
      (Tezos_base__TzPervasives.Block_header.bounded_encoding
        (Stdlib.op_exclamation block_header_max_size) tt).
  
  Definition block_locator_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        Tezos_base__TzPervasives.Block_locator.t) :=
    Stdlib.ref
      (Tezos_base__TzPervasives.Block_locator.bounded_encoding
        (Stdlib.op_exclamation block_header_max_size) None tt).
  
  Definition update_block_header_encoding (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Stdlib.op_colon_eq block_header_cache
        (Tezos_base__TzPervasives.Block_header.bounded_encoding
          (Stdlib.op_exclamation block_header_max_size) tt);
      Stdlib.op_colon_eq block_locator_cache
        (Tezos_base__TzPervasives.Block_locator.bounded_encoding
          (Stdlib.op_exclamation block_header_max_size) None tt)
    end.
  
  Definition set_block_header_max_size (max : option Z) : unit :=
    Stdlib.op_colon_eq block_header_max_size max;
    update_block_header_encoding tt.
  
  Definition block_header
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Block_header.t :=
    Tezos_base__TzPervasives.Data_encoding.delayed
      (fun function_parameter =>
        match function_parameter with
        | tt => Stdlib.op_exclamation block_header_cache
        end).
  
  Definition block_locator
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Block_locator.t :=
    Tezos_base__TzPervasives.Data_encoding.delayed
      (fun function_parameter =>
        match function_parameter with
        | tt => Stdlib.op_exclamation block_locator_cache
        end).
  
  Definition operation_max_size : Stdlib.ref (option Z) :=
    Stdlib.ref (Some (Z.mul 128 1024)).
  
  Definition operation_list_max_size : Stdlib.ref (option Z) :=
    Stdlib.ref (Some (Z.mul 1024 1024)).
  
  Definition operation_list_max_length : Stdlib.ref (option Z) :=
    Stdlib.ref None.
  
  Definition operation_max_pass : Stdlib.ref (option Z) := Stdlib.ref (Some 8).
  
  Definition operation_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Operation.t) :=
    Stdlib.ref
      (Tezos_base__TzPervasives.Operation.bounded_encoding
        (Stdlib.op_exclamation operation_max_size) tt).
  
  Definition operation_list_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        (Tezos_crypto.Operation_list_list_hash.path *
          (list Tezos_base__TzPervasives.Operation.t))) :=
    Stdlib.ref
      (Tezos_base__TzPervasives.Operation.bounded_list_encoding
        (Stdlib.op_exclamation operation_list_max_length)
        (Stdlib.op_exclamation operation_list_max_size)
        (Stdlib.op_exclamation operation_max_size)
        (Stdlib.op_exclamation operation_max_pass) tt).
  
  Definition operation_hash_list_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        (Tezos_crypto.Operation_list_list_hash.path *
          (list Tezos_crypto.Operation_hash.t))) :=
    Stdlib.ref
      (Tezos_base__TzPervasives.Operation.bounded_hash_list_encoding
        (Stdlib.op_exclamation operation_list_max_length)
        (Stdlib.op_exclamation operation_max_pass) tt).
  
  Definition update_operation_list_encoding (function_parameter : unit)
    : unit :=
    match function_parameter with
    | tt =>
      Stdlib.op_colon_eq operation_list_cache
        (Tezos_base__TzPervasives.Operation.bounded_list_encoding
          (Stdlib.op_exclamation operation_list_max_length)
          (Stdlib.op_exclamation operation_list_max_size)
          (Stdlib.op_exclamation operation_max_size)
          (Stdlib.op_exclamation operation_max_pass) tt)
    end.
  
  Definition update_operation_hash_list_encoding (function_parameter : unit)
    : unit :=
    match function_parameter with
    | tt =>
      Stdlib.op_colon_eq operation_list_cache
        (Tezos_base__TzPervasives.Operation.bounded_list_encoding
          (Stdlib.op_exclamation operation_list_max_length) None None
          (Stdlib.op_exclamation operation_max_pass) tt)
    end.
  
  Definition update_operation_encoding (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Stdlib.op_colon_eq operation_cache
        (Tezos_base__TzPervasives.Operation.bounded_encoding
          (Stdlib.op_exclamation operation_max_size) tt)
    end.
  
  Definition set_operation_max_size (max : option Z) : unit :=
    Stdlib.op_colon_eq operation_max_size max;
    update_operation_encoding tt;
    update_operation_list_encoding tt.
  
  Definition set_operation_list_max_size (max : option Z) : unit :=
    Stdlib.op_colon_eq operation_list_max_size max;
    update_operation_list_encoding tt.
  
  Definition set_operation_list_max_length (max : option Z) : unit :=
    Stdlib.op_colon_eq operation_list_max_length max;
    update_operation_list_encoding tt;
    update_operation_hash_list_encoding tt.
  
  Definition set_operation_max_pass (max : option Z) : unit :=
    Stdlib.op_colon_eq operation_max_pass max;
    update_operation_list_encoding tt;
    update_operation_hash_list_encoding tt.
  
  Definition operation
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Operation.t :=
    Tezos_base__TzPervasives.Data_encoding.delayed
      (fun function_parameter =>
        match function_parameter with
        | tt => Stdlib.op_exclamation operation_cache
        end).
  
  Definition operation_list
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (Tezos_crypto.Operation_list_list_hash.path *
        (list Tezos_base__TzPervasives.Operation.t)) :=
    Tezos_base__TzPervasives.Data_encoding.delayed
      (fun function_parameter =>
        match function_parameter with
        | tt => Stdlib.op_exclamation operation_list_cache
        end).
  
  Definition operation_hash_list
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (Tezos_crypto.Operation_list_list_hash.path *
        (list Tezos_crypto.Operation_hash.t)) :=
    Tezos_base__TzPervasives.Data_encoding.delayed
      (fun function_parameter =>
        match function_parameter with
        | tt => Stdlib.op_exclamation operation_hash_list_cache
        end).
  
  Definition protocol_max_size : Stdlib.ref (option Z) :=
    Stdlib.ref (Some (Z.mul (Z.mul 2 1024) 1024)).
  
  Definition protocol_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Protocol.t) :=
    Stdlib.ref
      (Tezos_base__TzPervasives.Protocol.bounded_encoding
        (Stdlib.op_exclamation protocol_max_size) tt).
  
  Definition set_protocol_max_size (max : option Z) : unit :=
    Stdlib.op_colon_eq protocol_max_size max.
  
  Definition protocol
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Protocol.t :=
    Tezos_base__TzPervasives.Data_encoding.delayed
      (fun function_parameter =>
        match function_parameter with
        | tt => Stdlib.op_exclamation protocol_cache
        end).
  
  Definition mempool_max_operations : Stdlib.ref (option Z) := Stdlib.ref None.
  
  Definition mempool_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        Tezos_base__TzPervasives.Mempool.mempool) :=
    Stdlib.ref
      (Tezos_base__TzPervasives.Mempool.bounded_encoding
        (Stdlib.op_exclamation mempool_max_operations) tt).
  
  Definition set_mempool_max_operations (max : option Z) : unit :=
    Stdlib.op_colon_eq mempool_max_operations max.
  
  Definition mempool
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Mempool.mempool :=
    Tezos_base__TzPervasives.Data_encoding.delayed
      (fun function_parameter =>
        match function_parameter with
        | tt => Stdlib.op_exclamation mempool_cache
        end).
End Bounded_encoding.

Inductive t : Type :=
| Get_current_branch : Tezos_base__TzPervasives.Chain_id.t -> t
| Current_branch : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_locator.t -> t
| Deactivate : Tezos_base__TzPervasives.Chain_id.t -> t
| Get_current_head : Tezos_base__TzPervasives.Chain_id.t -> t
| Current_head : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_header.t -> Tezos_base__TzPervasives.Mempool.t
  -> t
| Get_block_headers : (list Tezos_base__TzPervasives.Block_hash.t) -> t
| Block_header : Tezos_base__TzPervasives.Block_header.t -> t
| Get_operations : (list Tezos_base__TzPervasives.Operation_hash.t) -> t
| Operation : Tezos_base__TzPervasives.Operation.t -> t
| Get_protocols : (list Tezos_base__TzPervasives.Protocol_hash.t) -> t
| Protocol : Tezos_base__TzPervasives.Protocol.t -> t
| Get_operation_hashes_for_blocks :
  (list (Tezos_base__TzPervasives.Block_hash.t * Z)) -> t
| Operation_hashes_for_block : Tezos_base__TzPervasives.Block_hash.t -> Z ->
  (list Tezos_base__TzPervasives.Operation_hash.t) ->
  Tezos_base__TzPervasives.Operation_list_list_hash.path -> t
| Get_operations_for_blocks : (list (Tezos_base__TzPervasives.Block_hash.t * Z))
  -> t
| Operations_for_block : Tezos_base__TzPervasives.Block_hash.t -> Z ->
  (list Tezos_base__TzPervasives.Operation.t) ->
  Tezos_base__TzPervasives.Operation_list_list_hash.path -> t.

Definition encoding : list (Tezos_p2p.P2p_message.encoding t) :=
  let case {A B : Type}
    (max_length : option Z) (tag : Z) (title : string) (encoding :
    Tezos_base__TzPervasives.Data_encoding.t A) (unwrap : B -> option A) (wrap :
    A -> B) : Tezos_p2p.P2p_message.encoding B :=
    P2p_message.Encoding
      {| tag := tag; title := title; encoding := encoding; wrap := wrap;
        unwrap := unwrap; max_length := max_length |} in
  cons
    (case None 16 "Get_current_branch" % string
      (Tezos_base__TzPervasives.Data_encoding.obj1
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "get_current_branch" % string
          Tezos_base__TzPervasives.Chain_id.encoding))
      (fun function_parameter =>
        match function_parameter with
        | Get_current_branch chain_id => Some chain_id
        | _ => None
        end) (fun chain_id => Get_current_branch chain_id))
    (cons
      (case None 17 "Current_branch" % string
        (Tezos_base__TzPervasives.Data_encoding.obj2
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "current_branch" % string Bounded_encoding.block_locator))
        (fun function_parameter =>
          match function_parameter with
          | Current_branch chain_id locator => Some (chain_id, locator)
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | (chain_id, locator) => Current_branch chain_id locator
          end))
      (cons
        (case None 18 "Deactivate" % string
          (Tezos_base__TzPervasives.Data_encoding.obj1
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "deactivate" % string Tezos_base__TzPervasives.Chain_id.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Deactivate chain_id => Some chain_id
            | _ => None
            end) (fun chain_id => Deactivate chain_id))
        (cons
          (case None 19 "Get_current_head" % string
            (Tezos_base__TzPervasives.Data_encoding.obj1
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "get_current_head" % string
                Tezos_base__TzPervasives.Chain_id.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Get_current_head chain_id => Some chain_id
              | _ => None
              end) (fun chain_id => Get_current_head chain_id))
          (cons
            (case None 20 "Current_head" % string
              (Tezos_base__TzPervasives.Data_encoding.obj3
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "current_block_header" % string
                  (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                    Bounded_encoding.block_header))
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "current_mempool" % string Bounded_encoding.mempool))
              (fun function_parameter =>
                match function_parameter with
                | Current_head chain_id bh mempool =>
                  Some (chain_id, bh, mempool)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (chain_id, bh, mempool) => Current_head chain_id bh mempool
                end))
            (cons
              (case None 32 "Get_block_headers" % string
                (Tezos_base__TzPervasives.Data_encoding.obj1
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "get_block_headers" % string
                    (Tezos_base__TzPervasives.Data_encoding.list (Some 10)
                      Tezos_base__TzPervasives.Block_hash.encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | Get_block_headers bhs => Some bhs
                  | _ => None
                  end) (fun bhs => Get_block_headers bhs))
              (cons
                (case None 33 "Block_header" % string
                  (Tezos_base__TzPervasives.Data_encoding.obj1
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "block_header" % string Bounded_encoding.block_header))
                  (fun function_parameter =>
                    match function_parameter with
                    | Block_header bh => Some bh
                    | _ => None
                    end) (fun bh => Block_header bh))
                (cons
                  (case None 48 "Get_operations" % string
                    (Tezos_base__TzPervasives.Data_encoding.obj1
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "get_operations" % string
                        (Tezos_base__TzPervasives.Data_encoding.list (Some 10)
                          Tezos_base__TzPervasives.Operation_hash.encoding)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Get_operations bhs => Some bhs
                      | _ => None
                      end) (fun bhs => Get_operations bhs))
                  (cons
                    (case None 49 "Operation" % string
                      (Tezos_base__TzPervasives.Data_encoding.obj1
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "operation" % string Bounded_encoding.operation))
                      (fun function_parameter =>
                        match function_parameter with
                        | Operation o => Some o
                        | _ => None
                        end) (fun o => Operation o))
                    (cons
                      (case None 64 "Get_protocols" % string
                        (Tezos_base__TzPervasives.Data_encoding.obj1
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "get_protocols" % string
                            (Tezos_base__TzPervasives.Data_encoding.list
                              (Some 10)
                              Tezos_base__TzPervasives.Protocol_hash.encoding)))
                        (fun function_parameter =>
                          match function_parameter with
                          | Get_protocols protos => Some protos
                          | _ => None
                          end) (fun protos => Get_protocols protos))
                      (cons
                        (case None 65 "Protocol" % string
                          (Tezos_base__TzPervasives.Data_encoding.obj1
                            (Tezos_base__TzPervasives.Data_encoding.req None
                              None "protocol" % string Bounded_encoding.protocol))
                          (fun function_parameter =>
                            match function_parameter with
                            | Protocol proto => Some proto
                            | _ => None
                            end) (fun proto => Protocol proto))
                        (cons
                          (case None 80
                            "Get_operation_hashes_for_blocks" % string
                            (Tezos_base__TzPervasives.Data_encoding.obj1
                              (Tezos_base__TzPervasives.Data_encoding.req None
                                None "get_operation_hashes_for_blocks" % string
                                (Tezos_base__TzPervasives.Data_encoding.list
                                  (Some 10)
                                  (Tezos_base__TzPervasives.Data_encoding.tup2
                                    Tezos_base__TzPervasives.Block_hash.encoding
                                    Tezos_base__TzPervasives.Data_encoding.int8))))
                            (fun function_parameter =>
                              match function_parameter with
                              | Get_operation_hashes_for_blocks keys =>
                                Some keys
                              | _ => None
                              end)
                            (fun keys => Get_operation_hashes_for_blocks keys))
                          (cons
                            (case None 81 "Operation_hashes_for_blocks" % string
                              (Tezos_base__TzPervasives.Data_encoding.merge_objs
                                (Tezos_base__TzPervasives.Data_encoding.obj1
                                  (Tezos_base__TzPervasives.Data_encoding.req
                                    None None
                                    "operation_hashes_for_block" % string
                                    (Tezos_base__TzPervasives.Data_encoding.obj2
                                      (Tezos_base__TzPervasives.Data_encoding.req
                                        None None "hash" % string
                                        Tezos_base__TzPervasives.Block_hash.encoding)
                                      (Tezos_base__TzPervasives.Data_encoding.req
                                        None None "validation_pass" % string
                                        Tezos_base__TzPervasives.Data_encoding.int8))))
                                Bounded_encoding.operation_hash_list)
                              (fun function_parameter =>
                                match function_parameter with
                                | Operation_hashes_for_block block ofs ops path
                                  => Some ((block, ofs), (path, ops))
                                | _ => None
                                end)
                              (fun function_parameter =>
                                match function_parameter with
                                | ((block, ofs), (path, ops)) =>
                                  Operation_hashes_for_block block ofs ops path
                                end))
                            (cons
                              (case None 96 "Get_operations_for_blocks" % string
                                (Tezos_base__TzPervasives.Data_encoding.obj1
                                  (Tezos_base__TzPervasives.Data_encoding.req
                                    None None
                                    "get_operations_for_blocks" % string
                                    (Tezos_base__TzPervasives.Data_encoding.list
                                      (Some 10)
                                      (Tezos_base__TzPervasives.Data_encoding.obj2
                                        (Tezos_base__TzPervasives.Data_encoding.req
                                          None None "hash" % string
                                          Tezos_base__TzPervasives.Block_hash.encoding)
                                        (Tezos_base__TzPervasives.Data_encoding.req
                                          None None "validation_pass" % string
                                          Tezos_base__TzPervasives.Data_encoding.int8)))))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Get_operations_for_blocks keys => Some keys
                                  | _ => None
                                  end)
                                (fun keys => Get_operations_for_blocks keys))
                              (cons
                                (case None 97 "Operations_for_blocks" % string
                                  (Tezos_base__TzPervasives.Data_encoding.merge_objs
                                    (Tezos_base__TzPervasives.Data_encoding.obj1
                                      (Tezos_base__TzPervasives.Data_encoding.req
                                        None None
                                        "operations_for_block" % string
                                        (Tezos_base__TzPervasives.Data_encoding.obj2
                                          (Tezos_base__TzPervasives.Data_encoding.req
                                            None None "hash" % string
                                            Tezos_base__TzPervasives.Block_hash.encoding)
                                          (Tezos_base__TzPervasives.Data_encoding.req
                                            None None "validation_pass" % string
                                            Tezos_base__TzPervasives.Data_encoding.int8))))
                                    Bounded_encoding.operation_list)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Operations_for_block block ofs ops path =>
                                      Some ((block, ofs), (path, ops))
                                    | _ => None
                                    end)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | ((block, ofs), (path, ops)) =>
                                      Operations_for_block block ofs ops path
                                    end)) [])))))))))))))).

Definition cfg : Tezos_p2p.P2p.message_config t :=
  {| encoding := encoding;
    chain_name := Tezos_base__TzPervasives.Distributed_db_version.chain_name;
    distributed_db_versions :=
      cons Tezos_base__TzPervasives.Distributed_db_version.zero [] |}.

Definition raw_encoding
  : Tezos_base__TzPervasives.Data_encoding.t (Tezos_p2p.P2p_message.t t) :=
  Tezos_p2p.P2p_message.encoding encoding.

Definition pp_json (ppf : Stdlib.Format.formatter) (msg : t) : unit :=
  Tezos_base__TzPervasives.Data_encoding.Json.pp ppf
    (Tezos_base__TzPervasives.Data_encoding.Json.construct raw_encoding
      (Message msg)).

Module Logging.
  Definition tag : Tezos_base__TzPervasives.Tag.def t :=
    Tezos_base__TzPervasives.Tag.def (Some "Message" % string)
      "message" % string pp_json.
End Logging.
src/lib_shell/distributed_db_message.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell - Network message for the gossip P2P protocol. *)

type t =
  | Get_current_branch of Chain_id.t
  | Current_branch of Chain_id.t * Block_locator.t
  | Deactivate of Chain_id.t
  | Get_current_head of Chain_id.t
  | Current_head of Chain_id.t * Block_header.t * Mempool.t
  | Get_block_headers of Block_hash.t list
  | Block_header of Block_header.t
  | Get_operations of Operation_hash.t list
  | Operation of Operation.t
  | Get_protocols of Protocol_hash.t list
  | Protocol of Protocol.t
  | Get_operation_hashes_for_blocks of (Block_hash.t * int) list
  | Operation_hashes_for_block of
      Block_hash.t
      * int
      * Operation_hash.t list
      * Operation_list_list_hash.path
  | Get_operations_for_blocks of (Block_hash.t * int) list
  | Operations_for_block of
      Block_hash.t * int * Operation.t list * Operation_list_list_hash.path

val cfg : t P2p.message_config

val pp_json : Format.formatter -> t -> unit

module Bounded_encoding : sig
  val set_block_header_max_size : int option -> unit

  val set_operation_max_size : int option -> unit

  val set_operation_list_max_size : int option -> unit

  val set_operation_list_max_length : int option -> unit

  val set_operation_max_pass : int option -> unit

  val set_protocol_max_size : int option -> unit

  val set_mempool_max_operations : int option -> unit
end

module Logging : sig
  val tag : t Tag.def
end
src/lib_shell/distributed_db_message.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Get_current_branch : Tezos_base__TzPervasives.Chain_id.t -> t
| Current_branch : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_locator.t -> t
| Deactivate : Tezos_base__TzPervasives.Chain_id.t -> t
| Get_current_head : Tezos_base__TzPervasives.Chain_id.t -> t
| Current_head : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_header.t -> Tezos_base__TzPervasives.Mempool.t
  -> t
| Get_block_headers : (list Tezos_base__TzPervasives.Block_hash.t) -> t
| Block_header : Tezos_base__TzPervasives.Block_header.t -> t
| Get_operations : (list Tezos_base__TzPervasives.Operation_hash.t) -> t
| Operation : Tezos_base__TzPervasives.Operation.t -> t
| Get_protocols : (list Tezos_base__TzPervasives.Protocol_hash.t) -> t
| Protocol : Tezos_base__TzPervasives.Protocol.t -> t
| Get_operation_hashes_for_blocks :
  (list (Tezos_base__TzPervasives.Block_hash.t * Z)) -> t
| Operation_hashes_for_block : Tezos_base__TzPervasives.Block_hash.t -> Z ->
  (list Tezos_base__TzPervasives.Operation_hash.t) ->
  Tezos_base__TzPervasives.Operation_list_list_hash.path -> t
| Get_operations_for_blocks : (list (Tezos_base__TzPervasives.Block_hash.t * Z))
  -> t
| Operations_for_block : Tezos_base__TzPervasives.Block_hash.t -> Z ->
  (list Tezos_base__TzPervasives.Operation.t) ->
  Tezos_base__TzPervasives.Operation_list_list_hash.path -> t.

Parameter cfg : Tezos_p2p.P2p.message_config t.

Parameter pp_json : Stdlib.Format.formatter -> t -> unit.

Module Bounded_encoding.
  Parameter set_block_header_max_size : (option Z) -> unit.
  
  Parameter set_operation_max_size : (option Z) -> unit.
  
  Parameter set_operation_list_max_size : (option Z) -> unit.
  
  Parameter set_operation_list_max_length : (option Z) -> unit.
  
  Parameter set_operation_max_pass : (option Z) -> unit.
  
  Parameter set_protocol_max_size : (option Z) -> unit.
  
  Parameter set_mempool_max_operations : (option Z) -> unit.
End Bounded_encoding.

Module Logging.
  Parameter tag : Tezos_base__TzPervasives.Tag.def t.
End Logging.
src/lib_shell/injection_directory.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let read_chain_id validator chain =
  let distributed_db = Validator.distributed_db validator in
  let state = Distributed_db.state distributed_db in
  match chain with
  | None ->
      Lwt.return_none
  | Some chain ->
      Chain_directory.get_chain_id state chain >>= Lwt.return_some

let inject_block validator ?force ?chain bytes operations =
  read_chain_id validator chain
  >>= fun chain_id ->
  Validator.validate_block validator ?force ?chain_id bytes operations
  >>=? fun (hash, block) -> return (hash, block >>=? fun _ -> return_unit)

let inject_operation validator ?chain bytes =
  read_chain_id validator chain
  >>= fun chain_id ->
  let t =
    match Data_encoding.Binary.of_bytes Operation.encoding bytes with
    | None ->
        failwith "Can't parse the operation"
    | Some op ->
        Validator.inject_operation validator ?chain_id op
  in
  let hash = Operation_hash.hash_bytes [bytes] in
  Lwt.return (hash, t)

let inject_protocol state proto =
  let proto_bytes =
    Data_encoding.Binary.to_bytes_exn Protocol.encoding proto
  in
  let hash = Protocol_hash.hash_bytes [proto_bytes] in
  let validation =
    Updater.compile hash proto
    >>= function
    | false ->
        failwith "Compilation failed (%a)" Protocol_hash.pp_short hash
    | true -> (
        State.Protocol.store state proto
        >>= function
        | None ->
            failwith
              "Previously registered protocol (%a)"
              Protocol_hash.pp_short
              hash
        | Some _ ->
            return_unit )
  in
  Lwt.return (hash, validation)

let build_rpc_directory validator =
  let distributed_db = Validator.distributed_db validator in
  let state = Distributed_db.state distributed_db in
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let register0 s f =
    dir := RPC_directory.register !dir s (fun () p q -> f p q)
  in
  register0 Injection_services.S.block (fun q (raw, operations) ->
      inject_block validator ?chain:q#chain ~force:q#force raw operations
      >>=? fun (hash, wait) ->
      (if q#async then return_unit else wait) >>=? fun () -> return hash) ;
  register0 Injection_services.S.operation (fun q contents ->
      inject_operation validator ?chain:q#chain contents
      >>= fun (hash, wait) ->
      (if q#async then return_unit else wait) >>=? fun () -> return hash) ;
  register0 Injection_services.S.protocol (fun q protocol ->
      inject_protocol state protocol
      >>= fun (hash, wait) ->
      (if q#async then return_unit else wait) >>=? fun () -> return hash) ;
  !dir
src/lib_shell/injection_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition read_chain_id
  (validator : Tezos_shell.Validator.t)
  (chain : option Tezos_shell_services.Chain_services.chain)
  : Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
  let distributed_db := Tezos_shell.Validator.distributed_db validator in
  let state := Tezos_shell.Distributed_db.state distributed_db in
  match chain with
  | None => Lwt.return_none
  | Some chain =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Chain_directory.get_chain_id state chain) Lwt.return_some
  end.

Definition inject_block
  (validator : Tezos_shell.Validator.t) (force : option bool)
  (chain : option Tezos_shell_services.Chain_services.chain)
  (bytes : Stdlib.Bytes.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_hash.t *
        (Lwt.t (Tezos_base__TzPervasives.tzresult unit)))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (read_chain_id validator chain)
    (fun chain_id =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.Validator.validate_block validator force chain_id string
          operations)
        (fun function_parameter =>
          match function_parameter with
          | (hash, block) =>
            Tezos_base__TzPervasives._return
              (hash,
                (Tezos_base__TzPervasives.op_gt_gt_eq_question block
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => Tezos_base__TzPervasives.return_unit
                    end)))
          end)).

Definition inject_operation
  (validator : Tezos_shell.Validator.t)
  (chain : option Tezos_shell_services.Chain_services.chain)
  (bytes : Stdlib.Bytes.t)
  : Lwt.t
    (Tezos_base__TzPervasives.Operation_hash.t *
      (Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (read_chain_id validator chain)
    (fun chain_id =>
      let t :=
        match
          Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
            Tezos_base__TzPervasives.Operation.encoding string with
        | None =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Can't parse the operation" % string
                CamlinternalFormatBasics.End_of_format)
              "Can't parse the operation" % string)
        | Some op =>
          Tezos_shell.Validator.inject_operation validator chain_id op
        end in
      let hash :=
        Tezos_base__TzPervasives.Operation_hash.hash_bytes None (cons string [])
        in
      Lwt._return (hash, t)).

Definition inject_protocol
  (state : Tezos_shell__State.global_state)
  (proto : Tezos_base__TzPervasives.Protocol.t)
  : Lwt.t
    (Tezos_base__TzPervasives.Protocol_hash.t *
      (Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  let proto_bytes :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
      Tezos_base__TzPervasives.Protocol.encoding proto in
  let hash :=
    Tezos_base__TzPervasives.Protocol_hash.hash_bytes None (cons proto_bytes [])
    in
  let validation :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_protocol_updater.Updater.compile hash proto)
      (fun function_parameter =>
        match function_parameter with
        | false =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Compilation failed (" % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))
              "Compilation failed (%a)" % string)
            Tezos_base__TzPervasives.Protocol_hash.pp_short hash
        | true =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Protocol.store state proto)
            (fun function_parameter =>
              match function_parameter with
              | None =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Previously registered protocol (" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))
                    "Previously registered protocol (%a)" % string)
                  Tezos_base__TzPervasives.Protocol_hash.pp_short hash
              | Some _ => Tezos_base__TzPervasives.return_unit
              end)
        end) in
  Lwt._return (hash, validation).

Definition build_rpc_directory (validator : Tezos_shell.Validator.t)
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  let distributed_db := Tezos_shell.Validator.distributed_db validator in
  let state := Tezos_shell.Distributed_db.state distributed_db in
  let dir := Stdlib.ref Tezos_base__TzPervasives.RPC_directory.empty in
  let register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | tt => fun p => fun q => f p q
          end)) in
  register0 Tezos_shell_services.Injection_services.S.block
    (fun q =>
      fun function_parameter =>
        match function_parameter with
        | (raw, operations) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (inject_block validator (Some send) send raw operations)
            (fun function_parameter =>
              match function_parameter with
              | (hash, wait) =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (if send then
                    Tezos_base__TzPervasives.return_unit
                  else
                    wait)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives._return hash
                    end)
              end)
        end);
  register0 Tezos_shell_services.Injection_services.S.operation
    (fun q =>
      fun contents =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (inject_operation validator send contents)
          (fun function_parameter =>
            match function_parameter with
            | (hash, wait) =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (if send then
                  Tezos_base__TzPervasives.return_unit
                else
                  wait)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives._return hash
                  end)
            end));
  register0 Tezos_shell_services.Injection_services.S.protocol
    (fun q =>
      fun protocol =>
        Tezos_base__TzPervasives.op_gt_gt_eq (inject_protocol state protocol)
          (fun function_parameter =>
            match function_parameter with
            | (hash, wait) =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (if send then
                  Tezos_base__TzPervasives.return_unit
                else
                  wait)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives._return hash
                  end)
            end));
  Stdlib.op_exclamation dir.
src/lib_shell/injection_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val build_rpc_directory : Validator.t -> unit RPC_directory.t
src/lib_shell/injection_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter build_rpc_directory :
Tezos_shell.Validator.t -> Tezos_base__TzPervasives.RPC_directory.t unit.
src/lib_shell/mempool_peer_worker.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Validating batches of operations with some peer-based
 * compartimentatilsation. *)

type limits = {
  max_promises_per_request : int;
  worker_limits : Worker_types.limits;
}

module type T = sig
  module Mempool_worker : Mempool_worker.T

  type t

  type input = Operation_hash.t list

  val create : limits -> P2p_peer.Id.t -> Mempool_worker.t -> t tzresult Lwt.t

  val shutdown : t -> input Lwt.t

  val validate : t -> input -> unit tzresult Lwt.t
end

module type STATIC = sig
  val max_pending_requests : int
end

module Make (Static : STATIC) (Mempool_worker : Mempool_worker.T) :
  T with module Mempool_worker = Mempool_worker = struct
  (* 0. Prelude: set up base modules and types *)
  (* See interface file for info if needed. *)

  module Proto = Mempool_worker.Proto
  module Mempool_worker = Mempool_worker

  type input = Operation_hash.t list

  type result =
    | Cannot_download of error list
    | Cannot_parse of error list
    | Cannot_validate of error list
    | Mempool_result of Mempool_worker.result

  type output = result Operation_hash.Map.t

  let pp_input ppf input =
    Format.fprintf
      ppf
      "@[<v 0>%a@]"
      (Format.pp_print_list Operation_hash.pp)
      input

  let result_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Cannot download"
          (obj1 (req "download_errors" (list Error_monad.error_encoding)))
          (function Cannot_download errs -> Some errs | _ -> None)
          (fun errs -> Cannot_download errs);
        case
          (Tag 1)
          ~title:"Cannot parse"
          (obj1 (req "parse_errors" (list Error_monad.error_encoding)))
          (function Cannot_parse errs -> Some errs | _ -> None)
          (fun errs -> Cannot_parse errs);
        case
          (Tag 2)
          ~title:"Cannot validate"
          (obj1 (req "validation_errors" (list Error_monad.error_encoding)))
          (function Cannot_validate errs -> Some errs | _ -> None)
          (fun errs -> Cannot_validate errs);
        case
          (Tag 3)
          ~title:"Validation result"
          (obj1 (req "validation_result" Mempool_worker.result_encoding))
          (function Mempool_result result -> Some result | _ -> None)
          (fun result -> Mempool_result result) ]

  module Log = Internal_event.Legacy_logging.Make (struct
    let name = "node.mempool.peer_worker"
  end)

  (* 1. Core: the carefully scheduled work performed by the worker *)

  module Work : sig
    val process_batch : Mempool_worker.t -> int -> input -> output Lwt.t
  end = struct
    type t = {
      pool : unit Lwt_pool.t;
      received : Operation_hash.t Queue.t;
      downloading : (Operation_hash.t * Operation.t tzresult Lwt.t) Queue.t;
      applying :
        (Mempool_worker.operation * Mempool_worker.result tzresult Lwt.t)
        Queue.t;
      mutable results : result Operation_hash.Map.t;
    }

    (* Primitives *)

    let is_empty t =
      Queue.is_empty t.received
      && Queue.is_empty t.downloading
      && Queue.is_empty t.applying

    let has_resolved t =
      match Lwt.state t with
      | Lwt.Return _ | Lwt.Fail _ ->
          true
      | Lwt.Sleep ->
          false

    let head_is_resolved q =
      (not (Queue.is_empty q)) && has_resolved (snd (Queue.peek q))

    let select t =
      (* A `select`-like function to wait on any of the pipeline's buffers'
       * heads to resolve *)
      assert (not (Queue.is_empty t.downloading && Queue.is_empty t.applying)) ;
      let first_task_or_never q =
        if Queue.is_empty q then Lwt_utils.never_ending ()
        else snd (Queue.peek q) >>= fun _ -> Lwt.return_unit
      in
      Lwt.choose
        [first_task_or_never t.downloading; first_task_or_never t.applying]

    let record_result pipeline op_hash result =
      pipeline.results <-
        Operation_hash.Map.add op_hash result pipeline.results

    let q_of_list l =
      let q = Queue.create () in
      List.iter (fun x -> Queue.add x q) l ;
      q

    let create pool_size op_hashes =
      {
        pool = Lwt_pool.create pool_size Lwt.return;
        received = q_of_list op_hashes;
        downloading = Queue.create ();
        applying = Queue.create ();
        results = Operation_hash.Map.empty;
      }

    let cancel pipeline =
      let cancel_snd (_, p) = Lwt.cancel p in
      Queue.iter cancel_snd pipeline.downloading ;
      Queue.iter cancel_snd pipeline.applying

    (* Exported interactions *)

    let step mempool_worker pipeline =
      (* Going through each buffer one by one. *)
      (* op_hash: Opertation_hash.t
       * op: Operation.t
       * mop: Mempool_worker.operation *)
      if head_is_resolved pipeline.applying then (
        let (op, p) = Queue.pop pipeline.applying in
        p
        >>= function
        | Error errs ->
            record_result pipeline op.hash (Cannot_validate errs) ;
            Lwt.return_unit
        | Ok mempool_result ->
            record_result pipeline op.hash (Mempool_result mempool_result) ;
            Lwt.return_unit )
      else if head_is_resolved pipeline.downloading then
        let (op_hash, p) = Queue.pop pipeline.downloading in
        p
        >>= function
        | Error errs ->
            record_result pipeline op_hash (Cannot_download errs) ;
            Lwt.return_unit
        | Ok op -> (
          match Mempool_worker.parse op with
          | Error errs ->
              record_result pipeline op_hash (Cannot_parse errs) ;
              Lwt.return_unit
          | Ok mop ->
              let p =
                Lwt_pool.use pipeline.pool (fun () ->
                    Mempool_worker.validate mempool_worker mop)
              in
              Queue.push (mop, p) pipeline.applying ;
              Lwt.return_unit )
      else if not (Queue.is_empty pipeline.received) then (
        let op_hash = Queue.pop pipeline.received in
        (* TODO[?] should we specify the current peer for fetching? *)
        let chain_db = Mempool_worker.chain_db mempool_worker in
        let p =
          Lwt_pool.use pipeline.pool (fun () ->
              Distributed_db.Operation.fetch chain_db op_hash ())
        in
        Queue.push (op_hash, p) pipeline.downloading ;
        Lwt.return_unit )
      else
        (* There are some pending operations, we need to wait on them *)
        select pipeline

    let process_batch mempool_worker pool_size input =
      let pipeline = create pool_size input in
      let rec loop () =
        if is_empty pipeline then Lwt.return pipeline.results
        else step mempool_worker pipeline >>= fun () -> loop ()
      in
      let work = loop () in
      Lwt.on_cancel work (fun () -> cancel pipeline) ;
      work
  end

  (* 2. Boilerplate: the set up for the worker architecture *)

  module Name = struct
    type t = P2p_peer.Id.t

    let encoding = P2p_peer.Id.encoding

    let base =
      let proto_hash =
        let (_ : string) = Format.flush_str_formatter () in
        Format.fprintf Format.str_formatter "%a" Protocol_hash.pp Proto.hash ;
        Format.flush_str_formatter ()
      in
      ["node"; "mempool"; "peer_worker"; proto_hash]

    let pp = P2p_peer.Id.pp
  end

  module Request = struct
    type 'a t = Batch : input -> output t

    type view = input

    let view : type a. a t -> view = fun (Batch os) -> os

    let encoding =
      let open Data_encoding in
      list Operation_hash.encoding

    let pp ppf = function
      | [] ->
          Format.fprintf ppf "@[<v 2>Request:@, Empty List of Operations@]"
      | os ->
          Format.fprintf
            ppf
            "@[<v 2>Request:@,%a@]"
            (Format.pp_print_list Operation_hash.pp)
            os
  end

  module Event = struct
    type t =
      | Start of input
      | End_ok of (Request.view * Worker_types.request_status * output)
      | End_error of (Request.view * Worker_types.request_status * error list)

    let level req =
      let open Internal_event in
      match req with
      | Start _ ->
          Info
      | End_ok _ ->
          Info
      | End_error _ ->
          Error

    let encoding =
      let open Data_encoding in
      union
        [ case
            (Tag 0)
            ~title:"Start"
            (obj1 (req "input" (list Operation_hash.encoding)))
            (function Start input -> Some input | _ -> None)
            (fun input -> Start input);
          case
            (Tag 1)
            ~title:"End_ok"
            (obj3
               (req "request" Request.encoding)
               (req "status" Worker_types.request_status_encoding)
               (req "output" (Operation_hash.Map.encoding result_encoding)))
            (function
              | End_ok (view, status, result) ->
                  Some (view, status, result)
              | _ ->
                  None)
            (fun (view, status, result) -> End_ok (view, status, result));
          case
            (Tag 2)
            ~title:"End_error"
            (obj3
               (req "failed_request" Request.encoding)
               (req "status" Worker_types.request_status_encoding)
               (req "error" RPC_error.encoding))
            (function
              | End_error (view, status, errs) ->
                  Some (view, status, errs)
              | _ ->
                  None)
            (fun (view, status, errs) -> End_error (view, status, errs)) ]

    let pp ppf = function
      | Start input ->
          Format.fprintf ppf "@[<v 0>Starting: %a@]" pp_input input
      | End_ok (view, _, _) ->
          Format.fprintf ppf "@[<v 0>Finished: %a@]" Request.pp view
      | End_error (view, _, errs) ->
          Format.fprintf
            ppf
            "@[<v 0>Errors: %a, Operations: %a@]"
            (Format.pp_print_list Error_monad.pp)
            errs
            Request.pp
            view
  end

  module Types = struct
    type parameters = Mempool_worker.t * int

    type state = {mempool_worker : Mempool_worker.t; pool_size : int}

    type view = unit

    let view _ _ = ()

    let encoding = Data_encoding.unit

    let pp _ _ = ()
  end

  module Logger = Worker_logger.Make (Event) (Request)
  module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)

  type t = Worker.bounded Worker.queue Worker.t

  let table =
    let open Worker in
    create_table (Bounded {size = Static.max_pending_requests})

  (* 3. Workers' work: setting workers' callbacks to perform core work *)

  module Handlers = struct
    type self = t

    let on_launch _ _ (mempool_worker, pool_size) =
      return Types.{mempool_worker; pool_size}

    let on_request : type a. self -> a Request.t -> a tzresult Lwt.t =
     fun t (Request.Batch os) ->
      let st = Worker.state t in
      Worker.record_event t (Event.Start os) ;
      Work.process_batch st.mempool_worker st.pool_size os
      >>= fun r -> return r

    let on_no_request _ = return_unit

    let on_close _ = Lwt.return_unit

    let on_error t view st errs =
      Worker.record_event t (Event.End_error (view, st, errs)) ;
      Lwt.return_error errs

    let on_completion :
        type a.
        self -> a Request.t -> a -> Worker_types.request_status -> unit Lwt.t =
     fun t req output st ->
      match req with
      | Request.Batch _ ->
          Worker.record_event t (Event.End_ok (Request.view req, st, output)) ;
          Lwt.return_unit
  end

  (* 4. Public interface: exporting a thin wrapper around workers and work. *)
  (* See interface file for documentation *)

  let validate t os =
    Worker.Queue.push_request_and_wait t (Request.Batch os)
    >>=? fun (_ : output) -> return_unit

  let create limits peer_id mempool_worker =
    Worker.launch
      table
      limits.worker_limits
      peer_id
      (mempool_worker, limits.max_promises_per_request)
      (module Handlers)

  let shutdown w =
    let recycled = Operation_hash.Set.empty in
    let recycled =
      List.fold_left
        (fun recycled (_, input) ->
          List.fold_left
            (fun recycled op_h -> Operation_hash.Set.add op_h recycled)
            recycled
            input)
        recycled
        (Worker.Queue.pending_requests w)
    in
    let recycled =
      match Worker.current_request w with
      | Some (_, _, input) ->
          List.fold_left
            (fun recycled op_h -> Operation_hash.Set.add op_h recycled)
            recycled
            input
      | None ->
          recycled
    in
    let input = Operation_hash.Set.elements recycled in
    Worker.shutdown w >>= fun () -> Lwt.return input
end
src/lib_shell/mempool_peer_worker.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  max_promises_per_request : Z;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module T.
  Record signature {Mempool_worker_Proto_P_block_header_data
    Mempool_worker_Proto_P_block_header
    Mempool_worker_Proto_P_block_header_metadata
    Mempool_worker_Proto_P_operation_data
    Mempool_worker_Proto_P_operation_receipt Mempool_worker_Proto_P_operation
    Mempool_worker_Proto_P_validation_state Mempool_worker_t
    Mempool_worker_operation Mempool_worker_result t : Type} := {
    Mempool_worker : Mempool_worker.T.signature Mempool_worker_Proto_P_block_header_data Mempool_worker_Proto_P_block_header Mempool_worker_Proto_P_block_header_metadata Mempool_worker_Proto_P_operation_data Mempool_worker_Proto_P_operation_receipt Mempool_worker_Proto_P_operation Mempool_worker_Proto_P_validation_state Mempool_worker_t Mempool_worker_operation Mempool_worker_result;
    t := t;
    input := list Tezos_base__TzPervasives.Operation_hash.t;
    create : limits ->
      Tezos_base__TzPervasives.P2p_peer.Id.t ->
        Mempool_worker.(Tezos_shell__Mempool_worker.T.t) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult t);
    shutdown : t -> Lwt.t input;
    validate : t -> input -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
  }.
  Arguments signature : clear implicits.
End T.

Module STATIC.
  Record signature := {
    max_pending_requests : Z;
  }.
End STATIC.
src/lib_shell/mempool_peer_worker.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Distributing validation work between different workers, one for each peer. *)

type limits = {
  max_promises_per_request : int;
  worker_limits : Worker_types.limits;
}

module type T = sig
  module Mempool_worker : Mempool_worker.T

  (** The type of a peer worker. Each peer worker should be used for treating
      all the operations from a given peer. *)
  type t

  (** Types for calls into this module *)

  (** [input] are the batches of operations that are given to a peer worker to
      validate. These hashes are gossiped on the network, and the mempool checks
      their validity before gossiping them further. *)
  type input = Operation_hash.t list

  (** [create limits peer_id mempool_worker] creates a peer worker meant
      to be used for validating batches of operations sent by the peer
      [peer_id]. The validation of each operations is delegated to the
      associated [mempool_worker]. *)
  val create : limits -> P2p_peer.Id.t -> Mempool_worker.t -> t tzresult Lwt.t

  (** [shutdown t] closes the peer worker [t]. It returns a list of operation
      hashes that can be recycled when a new worker is created for the same peer.
  *)
  val shutdown : t -> input Lwt.t

  (** [validate worker input] validates the batch of operations [input]. The
      work is performed by [worker] and the underlying validation of each
      operation is performed by the [mempool_worker] that was used to [create]
      [worker]. *)
  val validate : t -> input -> unit tzresult Lwt.t
end

module type STATIC = sig
  val max_pending_requests : int
end

module Make (Static : STATIC) (Mempool_worker : Mempool_worker.T) :
  T with module Mempool_worker = Mempool_worker
src/lib_shell/mempool_peer_worker.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  max_promises_per_request : Z;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

module_type

module_type

unhandled_module
src/lib_shell/mempool_worker.ml 
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type limits = {worker_limits : Worker_types.limits}

module type T = sig
  module Proto : Registered_protocol.T

  type t

  type operation = private {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  type result =
    | Applied of Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Not_in_branch

  val result_encoding : result Data_encoding.t

  (** Creates/tear-down a new mempool validator context. *)
  val create : limits -> Distributed_db.chain_db -> t tzresult Lwt.t

  val shutdown : t -> unit Lwt.t

  (** parse a new operation and add it to the mempool context *)
  val parse : Operation.t -> operation tzresult

  (** validate a new operation and add it to the mempool context *)
  val validate : t -> operation -> result tzresult Lwt.t

  val chain_db : t -> Distributed_db.chain_db

  val rpc_directory : t RPC_directory.t
end

module type STATIC = sig
  val max_size_parsed_cache : int
end

module Make (Static : STATIC) (Proto : Registered_protocol.T) :
  T with module Proto = Proto = struct
  module Proto = Proto

  (* used for rpc *)
  module Proto_services = Block_services.Make (Proto) (Proto)

  type operation = {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  type result =
    | Applied of Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Not_in_branch

  let result_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Applied"
          (obj1 (req "receipt" Proto.operation_receipt_encoding))
          (function Applied receipt -> Some receipt | _ -> None)
          (fun receipt -> Applied receipt);
        case
          (Tag 1)
          ~title:"Branch Delayed"
          (obj1 (req "error" (list Error_monad.error_encoding)))
          (function Branch_delayed error -> Some error | _ -> None)
          (fun error -> Branch_delayed error);
        case
          (Tag 2)
          ~title:"Branch Refused"
          (obj1 (req "error" (list Error_monad.error_encoding)))
          (function Branch_refused error -> Some error | _ -> None)
          (fun error -> Branch_refused error);
        case
          (Tag 3)
          ~title:"Refused"
          (obj1 (req "error" (list Error_monad.error_encoding)))
          (function Refused error -> Some error | _ -> None)
          (fun error -> Refused error);
        case
          (Tag 4)
          ~title:"Duplicate"
          empty
          (function Duplicate -> Some () | _ -> None)
          (fun () -> Duplicate);
        case
          (Tag 5)
          ~title:"Not_in_branch"
          empty
          (function Not_in_branch -> Some () | _ -> None)
          (fun () -> Not_in_branch) ]

  let pp_result ppf = function
    | Applied _ ->
        Format.pp_print_string ppf "applied"
    | Branch_delayed _ ->
        Format.pp_print_string ppf "branch delayed"
    | Branch_refused _ ->
        Format.pp_print_string ppf "branch refused"
    | Refused _ ->
        Format.pp_print_string ppf "refused"
    | Duplicate ->
        Format.pp_print_string ppf "duplicate"
    | Not_in_branch ->
        Format.pp_print_string ppf "not in branch"

  let operation_encoding =
    let open Data_encoding in
    conv
      (fun {hash; raw; protocol_data} -> (hash, raw, protocol_data))
      (fun (hash, raw, protocol_data) -> {hash; raw; protocol_data})
      (obj3
         (req "hash" Operation_hash.encoding)
         (req "raw" Operation.encoding)
         (req "protocol_data" Proto.operation_data_encoding))

  module Log = Internal_event.Legacy_logging.Make (struct
    let name = "node.mempool_validator"
  end)

  module Name = struct
    type t = Chain_id.t

    let encoding = Chain_id.encoding

    let base =
      let proto_hash =
        let (_ : string) = Format.flush_str_formatter () in
        Format.fprintf Format.str_formatter "%a" Protocol_hash.pp Proto.hash ;
        Format.flush_str_formatter ()
      in
      ["node"; "mempool"; "worker"; proto_hash]

    let pp = Chain_id.pp_short
  end

  module Request = struct
    type 'a t = Validate : operation -> result t [@@ocaml.unboxed]

    type view = View : _ t -> view

    let view req = View req

    let encoding =
      let open Data_encoding in
      conv
        (fun (View (Validate op)) -> op)
        (fun op -> View (Validate op))
        operation_encoding

    let pp ppf (View (Validate {hash; _})) =
      Format.fprintf ppf "Validating new operation %a" Operation_hash.pp hash
  end

  module Event = struct
    type t =
      | Request of
          (Request.view * Worker_types.request_status * error list option)
      | Debug of string

    let level req =
      match req with
      | Debug _ ->
          Internal_event.Debug
      | Request _ ->
          Internal_event.Info

    let encoding =
      let open Data_encoding in
      union
        [ case
            (Tag 0)
            ~title:"Debug"
            (obj1 (req "message" string))
            (function Debug msg -> Some msg | _ -> None)
            (fun msg -> Debug msg);
          case
            (Tag 1)
            ~title:"Request"
            (obj2
               (req "request" Request.encoding)
               (req "status" Worker_types.request_status_encoding))
            (function Request (req, t, None) -> Some (req, t) | _ -> None)
            (fun (req, t) -> Request (req, t, None));
          case
            (Tag 2)
            ~title:"Failed request"
            (obj3
               (req "error" RPC_error.encoding)
               (req "failed_request" Request.encoding)
               (req "status" Worker_types.request_status_encoding))
            (function
              | Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
            (fun (errs, req, t) -> Request (req, t, Some errs)) ]

    let pp ppf = function
      | Debug msg ->
          Format.fprintf ppf "%s" msg
      | Request (view, {pushed; treated; completed}, None) ->
          Format.fprintf
            ppf
            "@[<v 0>%a@, %a@]"
            Request.pp
            view
            Worker_types.pp_status
            {pushed; treated; completed}
      | Request (view, {pushed; treated; completed}, Some errors) ->
          Format.fprintf
            ppf
            "@[<v 0>%a@, %a, %a@]"
            Request.pp
            view
            Worker_types.pp_status
            {pushed; treated; completed}
            (Format.pp_print_list Error_monad.pp)
            errors
  end

  (* parsed operations' cache. used for memoization *)
  module ParsedCache = struct
    type t = {
      table : operation tzresult Operation_hash.Table.t;
      ring : Operation_hash.t Ring.t;
    }

    let create () : t =
      {
        table = Operation_hash.Table.create Static.max_size_parsed_cache;
        ring = Ring.create Static.max_size_parsed_cache;
      }

    let add t raw_op parsed_op =
      let hash = Operation.hash raw_op in
      Option.iter
        ~f:(Operation_hash.Table.remove t.table)
        (Ring.add_and_return_erased t.ring hash) ;
      Operation_hash.Table.replace t.table hash parsed_op

    let find_opt t raw_op =
      let hash = Operation.hash raw_op in
      Operation_hash.Table.find_opt t.table hash

    let rem t hash =
      (* NOTE: hashes are not removed from the ring. As a result, the cache size
       * bound can be lowered. This is a non-issue because it's only a cache. *)
      Operation_hash.Table.remove t.table hash
  end

  (* validated operations' cache. used for memoization *)
  module ValidatedCache = struct
    type t = (result * Operation.t) Operation_hash.Table.t

    let encoding =
      let open Data_encoding in
      Operation_hash.Table.encoding (tup2 result_encoding Operation.encoding)

    let pp break ppf table =
      let open Format in
      Operation_hash.Table.iter
        (fun h (r, _) ->
          fprintf ppf "Operation %a: %a" Operation_hash.pp_short h pp_result r ;
          break ppf)
        table

    let create () = Operation_hash.Table.create 1000

    let add t parsed_op result =
      Operation_hash.Table.replace t parsed_op.hash result

    let find_opt t parsed_op = Operation_hash.Table.find_opt t parsed_op.hash

    let iter f t = Operation_hash.Table.iter f t

    let to_mempool t =
      let empty =
        {
          Proto_services.Mempool.applied = [];
          refused = Operation_hash.Map.empty;
          branch_refused = Operation_hash.Map.empty;
          branch_delayed = Operation_hash.Map.empty;
          unprocessed = Operation_hash.Map.empty;
        }
      in
      let map_op op =
        let protocol_data =
          Data_encoding.Binary.of_bytes_exn
            Proto.operation_data_encoding
            op.Operation.proto
        in
        {Proto.shell = op.shell; protocol_data}
      in
      Operation_hash.Table.fold
        (fun hash (result, raw_op) acc ->
          let proto_op = map_op raw_op in
          match result with
          | Applied _ ->
              {
                acc with
                Proto_services.Mempool.applied =
                  (hash, proto_op) :: acc.Proto_services.Mempool.applied;
              }
          | Branch_refused err ->
              {
                acc with
                Proto_services.Mempool.branch_refused =
                  Operation_hash.Map.add
                    hash
                    (proto_op, err)
                    acc.Proto_services.Mempool.branch_refused;
              }
          | Branch_delayed err ->
              {
                acc with
                Proto_services.Mempool.branch_delayed =
                  Operation_hash.Map.add
                    hash
                    (proto_op, err)
                    acc.Proto_services.Mempool.branch_delayed;
              }
          | Refused err ->
              {
                acc with
                Proto_services.Mempool.refused =
                  Operation_hash.Map.add
                    hash
                    (proto_op, err)
                    acc.Proto_services.Mempool.refused;
              }
          | _ ->
              acc)
        t
        empty

    let clear t = Operation_hash.Table.clear t
  end

  module Types = struct
    type parameters = {
      limits : limits;
      chain_db : Distributed_db.chain_db;
      validation_state : Proto.validation_state;
    }

    (* internal worker state *)
    type state = {
      (* state of the validator. this is updated at each apply_operation *)
      mutable validation_state : Proto.validation_state;
      cache : ValidatedCache.t;
      (* live blocks and operations, initialized at worker launch *)
      live_blocks : Block_hash.Set.t;
      live_operations : Operation_hash.Set.t;
      operation_stream :
        (result * Operation.shell_header * Proto.operation_data)
        Lwt_watcher.input;
      parameters : parameters;
    }

    type view = {cache : ValidatedCache.t}

    let view (state : state) _ : view = {cache = state.cache}

    let encoding =
      let open Data_encoding in
      conv
        (fun {cache} -> cache)
        (fun cache -> {cache})
        ValidatedCache.encoding

    let pp ppf {cache} =
      ValidatedCache.pp
        (fun ppf ->
          Format.pp_print_string ppf ";" ;
          Format.pp_print_space ppf ())
        ppf
        cache
  end

  module Logger = Worker_logger.Make (Event) (Request)
  module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
  open Types

  type t = Worker.infinite Worker.queue Worker.t

  let parsed_cache = ParsedCache.create ()

  let shutdown w = Worker.shutdown w

  (*** prevalidation ****)
  open Validation_errors

  let create ?protocol_data ~predecessor ~timestamp () =
    let { Block_header.shell =
            { fitness = predecessor_fitness;
              timestamp = predecessor_timestamp;
              level = predecessor_level;
              _ };
          _ } =
      State.Block.header predecessor
    in
    State.Block.context predecessor
    >>=? fun predecessor_context ->
    let predecessor_hash = State.Block.hash predecessor in
    ( match protocol_data with
    | None ->
        return_none
    | Some protocol_data -> (
      match
        Data_encoding.Binary.of_bytes
          Proto.block_header_data_encoding
          protocol_data
      with
      | None ->
          failwith "Invalid block header"
      | Some protocol_data ->
          return_some protocol_data ) )
    >>=? fun protocol_data ->
    let predecessor_context =
      Shell_context.wrap_disk_context predecessor_context
    in
    Proto.begin_construction
      ~chain_id:(State.Block.chain_id predecessor)
      ~predecessor_context
      ~predecessor_timestamp
      ~predecessor_fitness
      ~predecessor_level
      ~predecessor:predecessor_hash
      ~timestamp
      ?protocol_data
      ()

  let apply_operation state op =
    if Operation_hash.Set.mem op.hash state.live_operations then
      Lwt.return (None, Duplicate)
    else if
      not (Block_hash.Set.mem op.raw.Operation.shell.branch state.live_blocks)
    then Lwt.return (None, Not_in_branch)
    else
      Proto.apply_operation
        state.validation_state
        {shell = op.raw.shell; protocol_data = op.protocol_data}
      >|= function
      | Ok (validation_state, receipt) ->
          (Some validation_state, Applied receipt)
      | Error errors -> (
          ( None,
            match classify_errors errors with
            | `Branch ->
                Branch_refused errors
            | `Permanent ->
                Refused errors
            | `Temporary ->
                Branch_delayed errors ) )

  (*** end prevalidation ***)

  let parse_helper raw_op =
    let hash = Operation.hash raw_op in
    let size = Data_encoding.Binary.length Operation.encoding raw_op in
    if size > Proto.max_operation_data_length then
      error (Oversized_operation {size; max = Proto.max_operation_data_length})
    else
      match
        Data_encoding.Binary.of_bytes
          Proto.operation_data_encoding
          raw_op.Operation.proto
      with
      | None ->
          error Parse_error
      | Some protocol_data ->
          ok {hash; raw = raw_op; protocol_data}

  (* this function update the internal state of the worker *)
  let validate_helper w parsed_op =
    let state = Worker.state w in
    apply_operation state parsed_op
    >>= fun (validation_state, result) ->
    ( match validation_state with
    | Some validation_state ->
        state.validation_state <- validation_state
    | None ->
        () ) ;
    Lwt.return result

  let notify_helper w result {Operation.shell; proto} =
    let state = Worker.state w in
    (* this function is called by on_validate where we take care of the error *)
    let protocol_data =
      Data_encoding.Binary.of_bytes_exn Proto.operation_data_encoding proto
    in
    Lwt_watcher.notify state.operation_stream (result, shell, protocol_data)

  (* memoization is done only at on_* level *)
  let on_validate w parsed_op =
    let state = Worker.state w in
    match ValidatedCache.find_opt state.cache parsed_op with
    | None | Some (Branch_delayed _, _) ->
        validate_helper w parsed_op
        >>= fun result ->
        ValidatedCache.add state.cache parsed_op (result, parsed_op.raw) ;
        (* operations are notified only the first time *)
        notify_helper w result parsed_op.raw ;
        Lwt.return result
    | Some (result, _) ->
        Lwt.return result

  (* worker's handlers *)
  let on_request : type r. t -> r Request.t -> r tzresult Lwt.t =
   fun w request ->
    match request with
    | Request.Validate parsed_op ->
        on_validate w parsed_op >>= return

  let on_launch (_ : t) (_ : Name.t)
      ({chain_db; validation_state; _} as parameters) =
    let chain_state = Distributed_db.chain_state chain_db in
    Chain.data chain_state
    >>= fun {current_mempool = _mempool; live_blocks; live_operations; _} ->
    (* remove all operations that are already included *)
    Operation_hash.Set.iter
      (fun hash -> ParsedCache.rem parsed_cache hash)
      live_operations ;
    return
      {
        validation_state;
        cache = ValidatedCache.create ();
        live_blocks;
        live_operations;
        operation_stream = Lwt_watcher.create_input ();
        parameters;
      }

  let on_close w =
    let state = Worker.state w in
    Lwt_watcher.shutdown_input state.operation_stream ;
    ValidatedCache.iter
      (fun hash _ ->
        Distributed_db.Operation.clear_or_cancel state.parameters.chain_db hash)
      state.cache ;
    ValidatedCache.clear state.cache ;
    Lwt.return_unit

  let on_error w r st errs =
    Worker.record_event w (Event.Request (r, st, Some errs)) ;
    Lwt.return_error errs

  let on_completion w r _ st =
    Worker.record_event w (Event.Request (Request.view r, st, None)) ;
    Lwt.return_unit

  let table = Worker.create_table Queue

  let create limits chain_db =
    let chain_state = Distributed_db.chain_state chain_db in
    let chain_id = State.Chain.id chain_state in
    let module Handlers = struct
      type self = t

      let on_launch = on_launch

      let on_close = on_close

      let on_error = on_error

      let on_completion = on_completion

      let on_no_request _ = return_unit

      let on_request = on_request
    end in
    Chain.data chain_state
    >>= fun {current_head = predecessor; _} ->
    let timestamp = Time.System.to_protocol (Systime_os.now ()) in
    create ~predecessor ~timestamp ()
    >>=? fun validation_state ->
    Worker.launch
      table
      limits.worker_limits
      chain_id
      {limits; chain_db; validation_state}
      (module Handlers)

  (* Exporting functions *)

  let validate t parsed_op =
    Worker.Queue.push_request_and_wait t (Request.Validate parsed_op)

  (* atomic parse + memoization *)
  let parse raw_op =
    match ParsedCache.find_opt parsed_cache raw_op with
    | None ->
        let parsed_op = parse_helper raw_op in
        ParsedCache.add parsed_cache raw_op parsed_op ;
        parsed_op
    | Some parsed_op ->
        parsed_op

  let chain_db t =
    let state = Worker.state t in
    state.parameters.chain_db

  let pending_rpc_directory : t RPC_directory.t =
    RPC_directory.gen_register
      RPC_directory.empty
      (Proto_services.S.Mempool.pending_operations RPC_path.open_root)
      (fun w () () ->
        let state = Worker.state w in
        RPC_answer.return (ValidatedCache.to_mempool state.cache))

  let monitor_rpc_directory : t RPC_directory.t =
    RPC_directory.gen_register
      RPC_directory.empty
      (Proto_services.S.Mempool.monitor_operations RPC_path.open_root)
      (fun w params () ->
        let state = Worker.state w in
        let filter_result = function
          | Applied _ ->
              params#applied
          | Refused _ ->
              params#refused
          | Branch_refused _ ->
              params#branch_refused
          | Branch_delayed _ ->
              params#branch_delayed
          | _ ->
              false
        in
        let (op_stream, stopper) =
          Lwt_watcher.create_stream state.operation_stream
        in
        let shutdown () = Lwt_watcher.shutdown stopper in
        let next () =
          Lwt_stream.get op_stream
          >>= function
          | Some (kind, shell, protocol_data) when filter_result kind ->
              Lwt.return_some [{Proto.shell; protocol_data}]
          | _ ->
              Lwt.return_none
        in
        RPC_answer.return_stream {next; shutdown})

  (* /mempool/<chain_id>/pending
     /mempool/<chain_id>/monitor *)
  let rpc_directory =
    RPC_directory.merge pending_rpc_directory monitor_rpc_directory
end
src/lib_shell/mempool_worker.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module T.
  Record signature {Proto_P_block_header_data Proto_P_block_header
    Proto_P_block_header_metadata Proto_P_operation_data
    Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state t
    operation result : Type} := {
    Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
    t := t;
    operation := operation;
    result := result;
    result_encoding : Tezos_base__TzPervasives.Data_encoding.t result;
    create : limits ->
      Tezos_shell.Distributed_db.chain_db ->
        Lwt.t (Tezos_base__TzPervasives.tzresult t);
    shutdown : t -> Lwt.t unit;
    parse : Tezos_base__TzPervasives.Operation.t ->
      Tezos_base__TzPervasives.tzresult operation;
    validate : t ->
      operation -> Lwt.t (Tezos_base__TzPervasives.tzresult result);
    chain_db : t -> Tezos_shell.Distributed_db.chain_db;
    rpc_directory : Tezos_base__TzPervasives.RPC_directory.t t;
  }.
  Arguments signature : clear implicits.
End T.

Module STATIC.
  Record signature := {
    max_size_parsed_cache : Z;
  }.
End STATIC.
src/lib_shell/mempool_worker.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type limits = {worker_limits : Worker_types.limits}

module type T = sig
  module Proto : Registered_protocol.T

  type t

  type operation = private {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  type result =
    | Applied of Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Not_in_branch

  val result_encoding : result Data_encoding.t

  (** Creates/tear-down a new mempool validator context. *)
  val create : limits -> Distributed_db.chain_db -> t tzresult Lwt.t

  val shutdown : t -> unit Lwt.t

  (** parse a new operation *)
  val parse : Operation.t -> operation tzresult

  (** validate a new operation and add it to the mempool context *)
  val validate : t -> operation -> result tzresult Lwt.t

  val chain_db : t -> Distributed_db.chain_db

  val rpc_directory : t RPC_directory.t
end

module type STATIC = sig
  val max_size_parsed_cache : int
end

module Make (Static : STATIC) (Proto : Registered_protocol.T) :
  T with module Proto = Proto
src/lib_shell/mempool_worker.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  worker_limits : Tezos_shell_services.Worker_types.limits }.

module_type

module_type

unhandled_module
src/lib_shell/monitor_directory.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let build_rpc_directory validator mainchain_validator =
  let distributed_db = Validator.distributed_db validator in
  let state = Distributed_db.state distributed_db in
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let gen_register0 s f =
    dir := RPC_directory.gen_register !dir s (fun () p q -> f p q)
  in
  let gen_register1 s f =
    dir := RPC_directory.gen_register !dir s (fun ((), a) p q -> f a p q)
  in
  gen_register0 Monitor_services.S.bootstrapped (fun () () ->
      let (block_stream, stopper) =
        Chain_validator.new_head_watcher mainchain_validator
      in
      let first_run = ref true in
      let next () =
        if !first_run then (
          first_run := false ;
          let chain_state = Chain_validator.chain_state mainchain_validator in
          Chain.head chain_state
          >>= fun head ->
          let head_hash = State.Block.hash head in
          let head_header = State.Block.header head in
          Lwt.return_some (head_hash, head_header.shell.timestamp) )
        else
          Lwt.pick
            [ Lwt_stream.get block_stream
              >|= Option.map ~f:(fun b ->
                      ( State.Block.hash b,
                        (State.Block.header b).shell.timestamp ));
              ( Chain_validator.bootstrapped mainchain_validator
              >|= fun () -> None ) ]
      in
      let shutdown () = Lwt_watcher.shutdown stopper in
      RPC_answer.return_stream {next; shutdown}) ;
  gen_register0 Monitor_services.S.valid_blocks (fun q () ->
      let (block_stream, stopper) = State.watcher state in
      let shutdown () = Lwt_watcher.shutdown stopper in
      let in_chains block =
        match q#chains with
        | [] ->
            Lwt.return_true
        | chains ->
            let chain_id = State.Block.chain_id block in
            Lwt_list.filter_map_p
              (Chain_directory.get_chain_id_opt state)
              chains
            >>= fun chains ->
            Lwt.return (List.exists (Chain_id.equal chain_id) chains)
      in
      let in_protocols block =
        match q#protocols with
        | [] ->
            Lwt.return_true
        | protocols -> (
            State.Block.predecessor block
            >>= function
            | None ->
                Lwt.return_false (* won't happen *)
            | Some pred ->
                State.Block.context_exn pred
                >>= fun context ->
                Context.get_protocol context
                >>= fun protocol ->
                Lwt.return
                  (List.exists (Protocol_hash.equal protocol) protocols) )
      in
      let in_next_protocols block =
        match q#next_protocols with
        | [] ->
            Lwt.return_true
        | protocols ->
            State.Block.context_exn block
            >>= fun context ->
            Context.get_protocol context
            >>= fun next_protocol ->
            Lwt.return
              (List.exists (Protocol_hash.equal next_protocol) protocols)
      in
      let stream =
        Lwt_stream.filter_map_s
          (fun block ->
            in_chains block
            >>= fun in_chains ->
            in_next_protocols block
            >>= fun in_next_protocols ->
            in_protocols block
            >>= fun in_protocols ->
            if in_chains && in_protocols && in_next_protocols then
              Lwt.return_some
                ( (State.Block.chain_id block, State.Block.hash block),
                  State.Block.header block )
            else Lwt.return_none)
          block_stream
      in
      let next () = Lwt_stream.get stream in
      RPC_answer.return_stream {next; shutdown}) ;
  gen_register1 Monitor_services.S.heads (fun chain q () ->
      (* TODO: when `chain = `Test`, should we reset then stream when
       the `testnet` change, or dias we currently do ?? *)
      Chain_directory.get_chain state chain
      >>= fun chain ->
      match Validator.get validator (State.Chain.id chain) with
      | Error _ ->
          Lwt.fail Not_found
      | Ok chain_validator ->
          let (block_stream, stopper) =
            Chain_validator.new_head_watcher chain_validator
          in
          Chain.head chain
          >>= fun head ->
          let shutdown () = Lwt_watcher.shutdown stopper in
          let in_next_protocols block =
            match q#next_protocols with
            | [] ->
                Lwt.return_true
            | protocols ->
                State.Block.context_exn block
                >>= fun context ->
                Context.get_protocol context
                >>= fun next_protocol ->
                Lwt.return
                  (List.exists (Protocol_hash.equal next_protocol) protocols)
          in
          let stream =
            Lwt_stream.filter_map_s
              (fun block ->
                in_next_protocols block
                >>= fun in_next_protocols ->
                if in_next_protocols then
                  Lwt.return_some
                    (State.Block.hash block, State.Block.header block)
                else Lwt.return_none)
              block_stream
          in
          in_next_protocols head
          >>= fun first_block_is_among_next_protocols ->
          let first_call =
            (* Skip the first block if this is false *)
            ref first_block_is_among_next_protocols
          in
          let next () =
            if !first_call then (
              first_call := false ;
              Lwt.return_some (State.Block.hash head, State.Block.header head)
              )
            else Lwt_stream.get stream
          in
          RPC_answer.return_stream {next; shutdown}) ;
  gen_register0 Monitor_services.S.protocols (fun () () ->
      let (stream, stopper) = State.Protocol.watcher state in
      let shutdown () = Lwt_watcher.shutdown stopper in
      let next () = Lwt_stream.get stream in
      RPC_answer.return_stream {next; shutdown}) ;
  gen_register0 Monitor_services.S.commit_hash (fun () () ->
      RPC_answer.return Tezos_version.Current_git_info.commit_hash) ;
  gen_register0 Monitor_services.S.active_chains (fun () () ->
      let (stream, stopper) = Validator.chains_watcher validator in
      let shutdown () = Lwt_watcher.shutdown stopper in
      let first_call =
        (* Only notify the newly created chains if this is false *)
        ref true
      in
      let next () =
        let convert (chain_id, b) =
          if not b then Lwt.return (Monitor_services.Stopping chain_id)
          else if Chain_id.equal (State.Chain.main state) chain_id then
            Lwt.return (Monitor_services.Active_main chain_id)
          else
            State.Chain.get_exn state chain_id
            >>= fun chain_state ->
            let {State.Chain.protocol; _} = State.Chain.genesis chain_state in
            let expiration_date =
              Option.unopt_exn
                (Invalid_argument
                   (Format.asprintf
                      "Monitor.active_chains: no expiration date for the \
                       chain %a"
                      Chain_id.pp
                      chain_id))
                (State.Chain.expiration chain_state)
            in
            Lwt.return
              (Monitor_services.Active_test
                 {chain = chain_id; protocol; expiration_date})
        in
        if !first_call then (
          first_call := false ;
          Lwt_list.map_p
            (fun c -> convert (c, true))
            (Validator.get_active_chains validator)
          >>= fun l -> Lwt.return_some l )
        else
          Lwt_stream.get stream
          >>= function
          | None ->
              Lwt.return_none
          | Some c ->
              convert c >>= fun status -> Lwt.return_some [status]
      in
      RPC_answer.return_stream {next; shutdown}) ;
  !dir
src/lib_shell/monitor_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition build_rpc_directory
  (validator : Tezos_shell.Validator.t)
  (mainchain_validator : Tezos_shell.Chain_validator.t)
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  let distributed_db := Tezos_shell.Validator.distributed_db validator in
  let state := Tezos_shell.Distributed_db.state distributed_db in
  let dir := Stdlib.ref Tezos_base__TzPervasives.RPC_directory.empty in
  let gen_register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t variant) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.gen_register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | tt => fun p => fun q => f p q
          end)) in
  let gen_register1 {A B C D : Type}
    (s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
    A -> B -> C -> Lwt.t variant) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.gen_register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | (tt, a) => fun p => fun q => f a p q
          end)) in
  gen_register0 Tezos_shell_services.Monitor_services.S.bootstrapped
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            match
              Tezos_shell.Chain_validator.new_head_watcher mainchain_validator
              with
            | (block_stream, stopper) =>
              let first_run := Stdlib.ref true in
              let next (function_parameter : unit)
                : Lwt.t
                  (option
                    (Tezos_base__TzPervasives.Block_hash.t *
                      Tezos_base.Time.Protocol.t)) :=
                match function_parameter with
                | tt =>
                  if Stdlib.op_exclamation first_run then
                    Stdlib.op_colon_eq first_run false;
                    let chain_state :=
                      Tezos_shell.Chain_validator.chain_state
                        mainchain_validator in
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.Chain.head chain_state)
                      (fun head =>
                        let head_hash := Tezos_shell.State.Block.hash head in
                        let head_header := Tezos_shell.State.Block.header head
                          in
                        Lwt.return_some
                          (head_hash, (timestamp (shell head_header))))
                  else
                    Lwt.pick
                      (cons
                        (Tezos_base__TzPervasives.op_gt_pipe_eq
                          (Lwt_stream.get block_stream)
                          (Tezos_base__TzPervasives.Option.map
                            (fun b =>
                              ((Tezos_shell.State.Block.hash b),
                                (timestamp
                                  (shell (Tezos_shell.State.Block.header b)))))))
                        (cons
                          (Tezos_base__TzPervasives.op_gt_pipe_eq
                            (Tezos_shell.Chain_validator.bootstrapped
                              mainchain_validator)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => None
                              end)) []))
                end in
              let shutdown (function_parameter : unit) : unit :=
                match function_parameter with
                | tt => Tezos_base__TzPervasives.Lwt_watcher.shutdown stopper
                end in
              Tezos_base__TzPervasives.RPC_answer.return_stream
                {| next := next; shutdown := shutdown |}
            end
          end
      end);
  gen_register0 Tezos_shell_services.Monitor_services.S.valid_blocks
    (fun q =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          match Tezos_shell.State.watcher state with
          | (block_stream, stopper) =>
            let shutdown (function_parameter : unit) : unit :=
              match function_parameter with
              | tt => Tezos_base__TzPervasives.Lwt_watcher.shutdown stopper
              end in
            let in_chains (block : Tezos_shell.State.Block.t) : Lwt.t bool :=
              match send with
              | [] => Lwt.return_true
              | chains =>
                let chain_id := Tezos_shell.State.Block.chain_id block in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Lwt_list.filter_map_p
                    (Tezos_shell.Chain_directory.get_chain_id_opt state) chains)
                  (fun chains =>
                    Lwt._return
                      (Tezos_base__TzPervasives.List._exists
                        (Tezos_base__TzPervasives.Chain_id.equal chain_id)
                        chains))
              end in
            let in_protocols (block : Tezos_shell.State.Block.t) : Lwt.t bool :=
              match send with
              | [] => Lwt.return_true
              | protocols =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Block.predecessor block)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => Lwt.return_false
                    | Some pred =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.State.Block.context_exn pred)
                        (fun context =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_storage.Context.get_protocol context)
                            (fun protocol =>
                              Lwt._return
                                (Tezos_base__TzPervasives.List._exists
                                  (Tezos_base__TzPervasives.Protocol_hash.equal
                                    protocol) protocols)))
                    end)
              end in
            let in_next_protocols (block : Tezos_shell.State.Block.t)
              : Lwt.t bool :=
              match send with
              | [] => Lwt.return_true
              | protocols =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Block.context_exn block)
                  (fun context =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_storage.Context.get_protocol context)
                      (fun next_protocol =>
                        Lwt._return
                          (Tezos_base__TzPervasives.List._exists
                            (Tezos_base__TzPervasives.Protocol_hash.equal
                              next_protocol) protocols)))
              end in
            let stream :=
              Lwt_stream.filter_map_s
                (fun block =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (in_chains block)
                    (fun in_chains =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (in_next_protocols block)
                        (fun in_next_protocols =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (in_protocols block)
                            (fun in_protocols =>
                              if
                                andb in_chains
                                  (andb in_protocols in_next_protocols) then
                                Lwt.return_some
                                  (((Tezos_shell.State.Block.chain_id block),
                                    (Tezos_shell.State.Block.hash block)),
                                    (Tezos_shell.State.Block.header block))
                              else
                                Lwt.return_none)))) block_stream in
            let next (function_parameter : unit)
              : Lwt.t
                (option
                  ((Tezos_base__TzPervasives.Chain_id.t *
                    Tezos_base__TzPervasives.Block_hash.t) *
                    Tezos_base__TzPervasives.Block_header.t)) :=
              match function_parameter with
              | tt => Lwt_stream.get stream
              end in
            Tezos_base__TzPervasives.RPC_answer.return_stream
              {| next := next; shutdown := shutdown |}
          end
        end);
  gen_register1 Tezos_shell_services.Monitor_services.S.heads
    (fun chain =>
      fun q =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.Chain_directory.get_chain state chain)
              (fun chain =>
                match
                  Tezos_shell.Validator.get validator
                    (Tezos_shell.State.Chain.id chain) with
                | inr _ => Lwt.fail OCaml.Not_found
                | inl chain_validator =>
                  match
                    Tezos_shell.Chain_validator.new_head_watcher chain_validator
                    with
                  | (block_stream, stopper) =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.Chain.head chain)
                      (fun head =>
                        let shutdown (function_parameter : unit) : unit :=
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.Lwt_watcher.shutdown
                              stopper
                          end in
                        let in_next_protocols
                          (block : Tezos_shell.State.Block.t) : Lwt.t bool :=
                          match send with
                          | [] => Lwt.return_true
                          | protocols =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_shell.State.Block.context_exn block)
                              (fun context =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Tezos_storage.Context.get_protocol context)
                                  (fun next_protocol =>
                                    Lwt._return
                                      (Tezos_base__TzPervasives.List._exists
                                        (Tezos_base__TzPervasives.Protocol_hash.equal
                                          next_protocol) protocols)))
                          end in
                        let stream :=
                          Lwt_stream.filter_map_s
                            (fun block =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (in_next_protocols block)
                                (fun in_next_protocols =>
                                  if in_next_protocols then
                                    Lwt.return_some
                                      ((Tezos_shell.State.Block.hash block),
                                        (Tezos_shell.State.Block.header block))
                                  else
                                    Lwt.return_none)) block_stream in
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (in_next_protocols head)
                          (fun first_block_is_among_next_protocols =>
                            let first_call :=
                              Stdlib.ref first_block_is_among_next_protocols in
                            let next (function_parameter : unit)
                              : Lwt.t
                                (option
                                  (Tezos_base__TzPervasives.Block_hash.t *
                                    Tezos_base__TzPervasives.Block_header.t)) :=
                              match function_parameter with
                              | tt =>
                                if Stdlib.op_exclamation first_call then
                                  Stdlib.op_colon_eq first_call false;
                                  Lwt.return_some
                                    ((Tezos_shell.State.Block.hash head),
                                      (Tezos_shell.State.Block.header head))
                                else
                                  Lwt_stream.get stream
                              end in
                            Tezos_base__TzPervasives.RPC_answer.return_stream
                              {| next := next; shutdown := shutdown |}))
                  end
                end)
          end);
  gen_register0 Tezos_shell_services.Monitor_services.S.protocols
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            match Tezos_shell.State.Protocol.watcher state with
            | (stream, stopper) =>
              let shutdown (function_parameter : unit) : unit :=
                match function_parameter with
                | tt => Tezos_base__TzPervasives.Lwt_watcher.shutdown stopper
                end in
              let next (function_parameter : unit)
                : Lwt.t (option Tezos_base__TzPervasives.Protocol_hash.t) :=
                match function_parameter with
                | tt => Lwt_stream.get stream
                end in
              Tezos_base__TzPervasives.RPC_answer.return_stream
                {| next := next; shutdown := shutdown |}
            end
          end
      end);
  gen_register0 Tezos_shell_services.Monitor_services.S.commit_hash
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.RPC_answer._return
              Tezos_version.Current_git_info.commit_hash
          end
      end);
  gen_register0 Tezos_shell_services.Monitor_services.S.active_chains
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            match Tezos_shell.Validator.chains_watcher validator with
            | (stream, stopper) =>
              let shutdown (function_parameter : unit) : unit :=
                match function_parameter with
                | tt => Tezos_base__TzPervasives.Lwt_watcher.shutdown stopper
                end in
              let first_call := Stdlib.ref true in
              let next (function_parameter : unit)
                : Lwt.t
                  (option
                    (list Tezos_shell_services.Monitor_services.chain_status)) :=
                match function_parameter with
                | tt =>
                  let convert
                    (function_parameter :
                    Tezos_base__TzPervasives.Chain_id.t * bool)
                    : Lwt.t Tezos_shell_services.Monitor_services.chain_status :=
                    match function_parameter with
                    | (chain_id, b) =>
                      if negb b then
                        Lwt._return (Monitor_services.Stopping chain_id)
                      else
                        if
                          Tezos_base__TzPervasives.Chain_id.equal
                            (Tezos_shell.State.Chain.main state) chain_id then
                          Lwt._return (Monitor_services.Active_main chain_id)
                        else
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_shell.State.Chain.get_exn state chain_id)
                            (fun chain_state =>
                              match Tezos_shell.State.Chain.genesis chain_state
                                with
                              | {| State.Chain.protocol := protocol |} =>
                                let expiration_date :=
                                  Tezos_base__TzPervasives.Option.unopt_exn
                                    (OCaml.Invalid_argument
                                      (Stdlib.Format.asprintf
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Monitor.active_chains: no expiration date for the chain "
                                              % string
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format))
                                          "Monitor.active_chains: no expiration date for the chain %a"
                                            % string)
                                        Tezos_base__TzPervasives.Chain_id.pp
                                        chain_id))
                                    (Tezos_shell.State.Chain.expiration
                                      chain_state) in
                                Lwt._return
                                  (Monitor_services.Active_test
                                    {| chain := chain_id; protocol := protocol;
                                      expiration_date := expiration_date |})
                              end)
                    end in
                  if Stdlib.op_exclamation first_call then
                    Stdlib.op_colon_eq first_call false;
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Lwt_list.map_p (fun c => convert (c, true))
                        (Tezos_shell.Validator.get_active_chains validator))
                      (fun l => Lwt.return_some l)
                  else
                    Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_stream.get stream)
                      (fun function_parameter =>
                        match function_parameter with
                        | None => Lwt.return_none
                        | Some c =>
                          Tezos_base__TzPervasives.op_gt_gt_eq (convert c)
                            (fun status => Lwt.return_some (cons status []))
                        end)
                end in
              Tezos_base__TzPervasives.RPC_answer.return_stream
                {| next := next; shutdown := shutdown |}
            end
          end
      end);
  Stdlib.op_exclamation dir.
src/lib_shell/monitor_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val build_rpc_directory :
  Validator.t -> Chain_validator.t -> unit RPC_directory.t
src/lib_shell/monitor_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter build_rpc_directory :
Tezos_shell.Validator.t ->
  Tezos_shell.Chain_validator.t -> Tezos_base__TzPervasives.RPC_directory.t unit.
src/lib_shell/node.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018-2019 Nomadic Labs, <contact@nomadic-labs.com>          *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

open Lwt.Infix
open Tezos_base

module Initialization_event = struct
  type t = {
    time_stamp : float;
    status : [`P2p_layer_disabled | `Bootstrapping | `P2p_maintain_started];
  }

  let status_names =
    [ ("p2p_layer_disabled", `P2p_layer_disabled);
      ("bootstrapping", `Bootstrapping);
      ("p2p_maintain_started", `P2p_maintain_started) ]

  module Definition = struct
    let name = "shell-node"

    type nonrec t = t

    let encoding =
      let open Data_encoding in
      let v0_encoding =
        conv
          (function {time_stamp; status} -> (time_stamp, status))
          (fun (time_stamp, status) -> {time_stamp; status})
          (obj2
             (req "time-stamp" float)
             (req "status" (string_enum status_names)))
      in
      With_version.(encoding ~name (first_version v0_encoding))

    let pp ppf {status; _} =
      Format.fprintf
        ppf
        "%s initialization: %s"
        name
        (List.find (fun (_, s) -> s = status) status_names |> fst)

    let doc = "Status of the initialization of the P2P layer."

    let level _ = Internal_event.Notice
  end

  module Event = Internal_event.Make (Definition)

  let lwt_emit status =
    let time_stamp = Unix.gettimeofday () in
    Event.emit (fun () -> {time_stamp; status})
    >>= function
    | Ok () ->
        Lwt.return_unit
    | Error el ->
        Format.kasprintf
          Lwt.fail_with
          "Initialization_event.emit: %a"
          pp_print_error
          el
end

type t = {
  state : State.t;
  distributed_db : Distributed_db.t;
  validator : Validator.t;
  mainchain_validator : Chain_validator.t;
  p2p : Distributed_db.p2p;
  (* For P2P RPCs *)
  shutdown : unit -> unit Lwt.t;
}

let peer_metadata_cfg : _ P2p.peer_meta_config =
  {
    peer_meta_encoding = Peer_metadata.encoding;
    peer_meta_initial = Peer_metadata.empty;
    score = Peer_metadata.score;
  }

let connection_metadata_cfg cfg : _ P2p.conn_meta_config =
  {
    conn_meta_encoding = Connection_metadata.encoding;
    private_node = (fun {private_node; _} -> private_node);
    conn_meta_value = (fun _ -> cfg);
  }

let init_connection_metadata opt =
  let open Connection_metadata in
  match opt with
  | None ->
      {disable_mempool = false; private_node = false}
  | Some c ->
      {
        disable_mempool = c.P2p.disable_mempool;
        private_node = c.P2p.private_mode;
      }

let init_p2p ?(sandboxed = false) p2p_params =
  match p2p_params with
  | None ->
      let c_meta = init_connection_metadata None in
      Initialization_event.lwt_emit `P2p_layer_disabled
      >>= fun () ->
      return
        (P2p.faked_network Distributed_db_message.cfg peer_metadata_cfg c_meta)
  | Some (config, limits) ->
      let c_meta = init_connection_metadata (Some config) in
      let conn_metadata_cfg = connection_metadata_cfg c_meta in
      Initialization_event.lwt_emit `Bootstrapping
      >>= fun () ->
      let message_cfg =
        if sandboxed then
          {
            Distributed_db_message.cfg with
            chain_name = Distributed_db_version.sandboxed_chain_name;
          }
        else Distributed_db_message.cfg
      in
      P2p.create
        ~config
        ~limits
        peer_metadata_cfg
        conn_metadata_cfg
        message_cfg
      >>=? fun p2p ->
      Initialization_event.lwt_emit `P2p_maintain_started
      >>= fun () -> return p2p

type config = {
  genesis : State.Chain.genesis;
  store_root : string;
  context_root : string;
  protocol_root : string;
  patch_context : (Context.t -> Context.t Lwt.t) option;
  p2p : (P2p.config * P2p.limits) option;
  checkpoint : Block_header.t option;
}

and peer_validator_limits = Peer_validator.limits = {
  new_head_request_timeout : Time.System.Span.t;
  block_header_timeout : Time.System.Span.t;
  block_operations_timeout : Time.System.Span.t;
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

and prevalidator_limits = Prevalidator.limits = {
  max_refused_operations : int;
  operation_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
  operations_batch_size : int;
}

and block_validator_limits = Block_validator.limits = {
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

and chain_validator_limits = Chain_validator.limits = {
  bootstrap_threshold : int;
  worker_limits : Worker_types.limits;
}

let default_block_validator_limits =
  {
    protocol_timeout = Time.System.Span.of_seconds_exn 120.;
    worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Debug};
  }

let default_prevalidator_limits =
  {
    operation_timeout = Time.System.Span.of_seconds_exn 10.;
    max_refused_operations = 1000;
    worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
    operations_batch_size = 50;
  }

let default_peer_validator_limits =
  {
    block_header_timeout = Time.System.Span.of_seconds_exn 300.;
    block_operations_timeout = Time.System.Span.of_seconds_exn 300.;
    protocol_timeout = Time.System.Span.of_seconds_exn 600.;
    new_head_request_timeout = Time.System.Span.of_seconds_exn 90.;
    worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
  }

let default_chain_validator_limits =
  {
    bootstrap_threshold = 4;
    worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
  }

let may_update_checkpoint chain_state checkpoint history_mode =
  match checkpoint with
  | None ->
      return_unit
  | Some checkpoint -> (
      State.best_known_head_for_checkpoint chain_state checkpoint
      >>= fun new_head ->
      Chain.set_head chain_state new_head
      >>= fun _old_head ->
      match history_mode with
      | History_mode.Archive ->
          State.Chain.set_checkpoint chain_state checkpoint
          >>= fun () -> return_unit
      | Full ->
          State.Chain.set_checkpoint_then_purge_full chain_state checkpoint
      | Rolling ->
          State.Chain.set_checkpoint_then_purge_rolling chain_state checkpoint
      )

module Local_logging = Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.worker"
end)

let store_known_protocols state =
  let open Local_logging in
  let embedded_protocols = Registered_protocol.list_embedded () in
  Lwt_list.iter_s
    (fun protocol_hash ->
      State.Protocol.known state protocol_hash
      >>= function
      | true ->
          lwt_log_info
            Tag.DSL.(
              fun f ->
                f "protocol %a is already in store: nothing to do"
                -% a Protocol_hash.Logging.tag protocol_hash
                -% t event "embedded_protocol_already_stored")
      | false -> (
        match Registered_protocol.get_embedded_sources protocol_hash with
        | None ->
            lwt_log_info
              Tag.DSL.(
                fun f ->
                  f "protocol %a won't be stored: missing source files"
                  -% a Protocol_hash.Logging.tag protocol_hash
                  -% t event "embedded_protocol_missing_sources")
        | Some protocol -> (
            let hash = Protocol.hash protocol in
            if not (Protocol_hash.equal hash protocol_hash) then
              lwt_log_info
                Tag.DSL.(
                  fun f ->
                    f "protocol %a won't be stored: wrong hash"
                    -% a Protocol_hash.Logging.tag protocol_hash
                    -% t event "embedded_protocol_inconsistent_hash")
            else
              State.Protocol.store state protocol
              >>= function
              | Some hash' ->
                  assert (hash = hash') ;
                  lwt_log_info
                    Tag.DSL.(
                      fun f ->
                        f "protocol %a successfully stored"
                        -% a Protocol_hash.Logging.tag protocol_hash
                        -% t event "embedded_protocol_stored")
              | None ->
                  lwt_log_info
                    Tag.DSL.(
                      fun f ->
                        f "protocol %a is already in store: nothing to do"
                        -% a Protocol_hash.Logging.tag protocol_hash
                        -% t event "embedded_protocol_already_stored") ) ))
    embedded_protocols

let create ?(sandboxed = false) ?sandbox_parameters ~singleprocess
    { genesis;
      store_root;
      context_root;
      protocol_root;
      patch_context;
      p2p = p2p_params;
      checkpoint } peer_validator_limits block_validator_limits
    prevalidator_limits chain_validator_limits history_mode =
  let (start_prevalidator, start_testchain) =
    match p2p_params with
    | Some (config, _limits) ->
        (not config.P2p.disable_mempool, not config.P2p.disable_testchain)
    | None ->
        (true, true)
  in
  init_p2p ~sandboxed p2p_params
  >>=? fun p2p ->
  (let open Block_validator_process in
  if singleprocess then
    State.init ~store_root ~context_root ?history_mode ?patch_context genesis
    >>=? fun (state, mainchain_state, context_index, history_mode) ->
    init (Internal context_index)
    >>=? fun validator_process ->
    return (validator_process, state, mainchain_state, history_mode)
  else
    init
      (External
         {
           context_root;
           protocol_root;
           process_path = Sys.executable_name;
           sandbox_parameters;
         })
    >>=? fun validator_process ->
    let commit_genesis =
      Block_validator_process.commit_genesis
        validator_process
        ~genesis_hash:genesis.block
    in
    State.init
      ~store_root
      ~context_root
      ?history_mode
      ?patch_context
      ~commit_genesis
      genesis
    >>=? fun (state, mainchain_state, _context_index, history_mode) ->
    return (validator_process, state, mainchain_state, history_mode))
  >>=? fun (validator_process, state, mainchain_state, history_mode) ->
  may_update_checkpoint mainchain_state checkpoint history_mode
  >>=? fun () ->
  let distributed_db = Distributed_db.create state p2p in
  store_known_protocols state
  >>= fun () ->
  Validator.create
    state
    distributed_db
    peer_validator_limits
    block_validator_limits
    validator_process
    prevalidator_limits
    chain_validator_limits
    ~start_testchain
  >>=? fun validator ->
  (* TODO : Check that the testchain is correctly activated after a node restart *)
  Validator.activate
    validator
    ~start_prevalidator
    ~validator_process
    mainchain_state
  >>=? fun mainchain_validator ->
  let shutdown () =
    let open Local_logging in
    lwt_log_info
      Tag.DSL.(
        fun f -> f "Shutting down the p2p layer..." -% t event "shutdown")
    >>= fun () ->
    P2p.shutdown p2p
    >>= fun () ->
    lwt_log_info
      Tag.DSL.(
        fun f ->
          f "Shutting down the distributed database..." -% t event "shutdown")
    >>= fun () ->
    Distributed_db.shutdown distributed_db
    >>= fun () ->
    lwt_log_info
      Tag.DSL.(
        fun f -> f "Shutting down the validator..." -% t event "shutdown")
    >>= fun () ->
    Validator.shutdown validator
    >>= fun () ->
    lwt_log_info
      Tag.DSL.(fun f -> f "Closing down the state..." -% t event "shutdown")
    >>= fun () -> State.close state
  in
  return {state; distributed_db; validator; mainchain_validator; p2p; shutdown}

let shutdown node = node.shutdown ()

let build_rpc_directory node =
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let merge d = dir := RPC_directory.merge !dir d in
  let register0 s f =
    dir := RPC_directory.register !dir s (fun () p q -> f p q)
  in
  merge
    (Protocol_directory.build_rpc_directory
       (Block_validator.running_worker ())
       node.state) ;
  merge
    (Monitor_directory.build_rpc_directory
       node.validator
       node.mainchain_validator) ;
  merge (Injection_directory.build_rpc_directory node.validator) ;
  merge (Chain_directory.build_rpc_directory node.validator) ;
  merge (P2p_directory.build_rpc_directory node.p2p) ;
  merge (Worker_directory.build_rpc_directory node.state) ;
  merge (Stat_directory.rpc_directory ()) ;
  register0 RPC_service.error_service (fun () () ->
      return (Data_encoding.Json.schema Error_monad.error_encoding)) ;
  RPC_directory.register_describe_directory_service
    !dir
    RPC_service.description_service
src/lib_shell/node.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Import Tezos_base.

Module Initialization_event.
  Record t := {
    time_stamp : float;
    status : variant }.
  
  Definition status_names : list (string * variant) :=
    cons ("p2p_layer_disabled" % string, variant)
      (cons ("bootstrapping" % string, variant)
        (cons ("p2p_maintain_started" % string, variant) [])).
  
  Module Definition.
    Definition name : string := "shell-node" % string.
    
    Definition t := t.
    
    Definition encoding : Tezos_data_encoding__Data_encoding.encoding t :=
      let v0_encoding :=
        Tezos_base__TzPervasives.Data_encoding.conv
          (fun function_parameter =>
            match function_parameter with
            | {| time_stamp := time_stamp; status := status |} =>
              (time_stamp, status)
            end)
          (fun function_parameter =>
            match function_parameter with
            | (time_stamp, status) =>
              {| time_stamp := time_stamp; status := status |}
            end) None
          (Tezos_base__TzPervasives.Data_encoding.obj2
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "time-stamp" % string Tezos_base__TzPervasives.Data_encoding.float)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "status" % string
              (Tezos_base__TzPervasives.Data_encoding.string_enum status_names)))
        in
      Tezos_base__TzPervasives.Data_encoding.With_version.encoding name
        (Tezos_base__TzPervasives.Data_encoding.With_version.first_version
          v0_encoding).
    
    Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
      : unit :=
      match function_parameter with
      | {| status := status |} =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " initialization: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)))
            "%s initialization: %s" % string) name
          (OCaml.Stdlib.reverse_apply
            (Tezos_base__TzPervasives.List.find
              (fun function_parameter =>
                match function_parameter with
                | (_, s) => equiv_decb s status
                end) status_names) fst)
      end.
    
    Definition doc : string :=
      "Status of the initialization of the P2P layer." % string.
    
    Definition level {A : Type} (function_parameter : A)
      : Tezos_base__TzPervasives.Internal_event.level :=
      match function_parameter with
      | _ => Internal_event.Notice
      end.
  End Definition.
  
  Definition lwt_emit (status : variant) : Lwt.t unit :=
    let time_stamp := Unix.gettimeofday tt in
    Lwt.Infix.op_gt_gt_eq
      (Event.emit None
        (fun function_parameter =>
          match function_parameter with
          | tt => {| time_stamp := time_stamp; status := status |}
          end))
      (fun function_parameter =>
        match function_parameter with
        | inl tt => Lwt.return_unit
        | inr el =>
          Stdlib.Format.kasprintf Lwt.fail_with
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Initialization_event.emit: " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "Initialization_event.emit: %a" % string)
            Tezos_base__TzPervasives.pp_print_error el
        end).
End Initialization_event.

Record t := {
  state : Tezos_shell.State.t;
  distributed_db : Tezos_shell.Distributed_db.t;
  validator : Tezos_shell.Validator.t;
  mainchain_validator : Tezos_shell.Chain_validator.t;
  p2p : Tezos_shell.Distributed_db.p2p;
  shutdown : unit -> Lwt.t unit }.

Definition peer_metadata_cfg
  : Tezos_p2p.P2p.peer_meta_config Tezos_shell_services.Peer_metadata.t :=
  {| peer_meta_encoding := Tezos_shell_services.Peer_metadata.encoding;
    peer_meta_initial := Tezos_shell_services.Peer_metadata.empty;
    score := Tezos_shell_services.Peer_metadata.score |}.

Definition connection_metadata_cfg
  (cfg : Tezos_shell_services.Connection_metadata.t)
  : Tezos_p2p.P2p.conn_meta_config Tezos_shell_services.Connection_metadata.t :=
  {| conn_meta_encoding := Tezos_shell_services.Connection_metadata.encoding;
    conn_meta_value :=
      fun function_parameter =>
        match function_parameter with
        | _ => cfg
        end;
    private_node :=
      fun function_parameter =>
        match function_parameter with
        | {| private_node := private_node |} => private_node
        end |}.

Definition init_connection_metadata (opt : option Tezos_p2p.P2p.config)
  : Tezos_shell_services.Connection_metadata.t :=
  match opt with
  | None => {| disable_mempool := false; private_node := false |}
  | Some c =>
    {| disable_mempool := P2p.disable_mempool c;
      private_node := P2p.private_mode c |}
  end.

Definition init_p2p (op_star_o_p_t_star : option bool)
  : (option (Tezos_p2p.P2p.config * Tezos_p2p.P2p.limits)) ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_p2p.P2p.net Tezos_shell.Distributed_db_message.t
          Tezos_shell_services.Peer_metadata.t
          Tezos_shell_services.Connection_metadata.t)) :=
  let sandboxed :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun p2p_params =>
    match p2p_params with
    | None =>
      let c_meta := init_connection_metadata None in
      Lwt.Infix.op_gt_gt_eq (Initialization_event.lwt_emit variant)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives._return
              (Tezos_p2p.P2p.faked_network
                Tezos_shell.Distributed_db_message.cfg peer_metadata_cfg c_meta)
          end)
    | Some (config, limits) =>
      let c_meta := init_connection_metadata (Some config) in
      let conn_metadata_cfg := connection_metadata_cfg c_meta in
      Lwt.Infix.op_gt_gt_eq (Initialization_event.lwt_emit variant)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let message_cfg :=
              if sandboxed then
                record
              else
                Tezos_shell.Distributed_db_message.cfg in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_p2p.P2p.create config limits peer_metadata_cfg
                conn_metadata_cfg message_cfg)
              (fun p2p =>
                Lwt.Infix.op_gt_gt_eq (Initialization_event.lwt_emit variant)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives._return p2p
                    end))
          end)
    end.

.

Definition default_block_validator_limits : block_validator_limits :=
  {| protocol_timeout := Tezos_base.Time.System.Span.of_seconds_exn 120;
    worker_limits :=
      {| backlog_size := 1000; backlog_level := Internal_event.Debug |} |}.

Definition default_prevalidator_limits : prevalidator_limits :=
  {| max_refused_operations := 1000;
    operation_timeout := Tezos_base.Time.System.Span.of_seconds_exn 10;
    worker_limits :=
      {| backlog_size := 1000; backlog_level := Internal_event.Info |};
    operations_batch_size := 50 |}.

Definition default_peer_validator_limits : peer_validator_limits :=
  {| new_head_request_timeout := Tezos_base.Time.System.Span.of_seconds_exn 90;
    block_header_timeout := Tezos_base.Time.System.Span.of_seconds_exn 300;
    block_operations_timeout := Tezos_base.Time.System.Span.of_seconds_exn 300;
    protocol_timeout := Tezos_base.Time.System.Span.of_seconds_exn 600;
    worker_limits :=
      {| backlog_size := 1000; backlog_level := Internal_event.Info |} |}.

Definition default_chain_validator_limits : chain_validator_limits :=
  {| bootstrap_threshold := 4;
    worker_limits :=
      {| backlog_size := 1000; backlog_level := Internal_event.Info |} |}.

Definition may_update_checkpoint
  (chain_state : Tezos_shell.State.Chain.t)
  (checkpoint : option Tezos_base__TzPervasives.Block_header.t)
  (history_mode : Tezos_shell_services.History_mode.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match checkpoint with
  | None => Tezos_base__TzPervasives.return_unit
  | Some checkpoint =>
    Lwt.Infix.op_gt_gt_eq
      (Tezos_shell.State.best_known_head_for_checkpoint chain_state checkpoint)
      (fun new_head =>
        Lwt.Infix.op_gt_gt_eq (Tezos_shell.Chain.set_head chain_state new_head)
          (fun _old_head =>
            match history_mode with
            | History_mode.Archive =>
              Lwt.Infix.op_gt_gt_eq
                (Tezos_shell.State.Chain.set_checkpoint chain_state checkpoint)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            | Full =>
              Tezos_shell.State.Chain.set_checkpoint_then_purge_full chain_state
                checkpoint
            | Rolling =>
              Tezos_shell.State.Chain.set_checkpoint_then_purge_rolling
                chain_state checkpoint
            end))
  end.

Definition store_known_protocols (state : Tezos_shell__State.global_state)
  : Lwt.t unit :=
  let embedded_protocols :=
    Tezos_protocol_updater.Registered_protocol.list_embedded tt in
  Lwt_list.iter_s
    (fun protocol_hash =>
      Lwt.Infix.op_gt_gt_eq
        (Tezos_shell.State.Protocol.known state protocol_hash)
        (fun function_parameter =>
          match function_parameter with
          | true =>
            Local_logging.lwt_log_info
              (fun f =>
                Local_logging.Tag.DSL.op_minus_percent
                  (Local_logging.Tag.DSL.op_minus_percent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "protocol " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " is already in store: nothing to do" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "protocol %a is already in store: nothing to do" %
                          string))
                    (Local_logging.Tag.DSL.a
                      Tezos_base__TzPervasives.Protocol_hash.Logging.tag
                      protocol_hash))
                  (Local_logging.Tag.DSL.t Local_logging.event
                    "embedded_protocol_already_stored" % string))
          | false =>
            match
              Tezos_protocol_updater.Registered_protocol.get_embedded_sources
                protocol_hash with
            | None =>
              Local_logging.lwt_log_info
                (fun f =>
                  Local_logging.Tag.DSL.op_minus_percent
                    (Local_logging.Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "protocol " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " won't be stored: missing source files" %
                                  string CamlinternalFormatBasics.End_of_format)))
                          "protocol %a won't be stored: missing source files" %
                            string))
                      (Local_logging.Tag.DSL.a
                        Tezos_base__TzPervasives.Protocol_hash.Logging.tag
                        protocol_hash))
                    (Local_logging.Tag.DSL.t Local_logging.event
                      "embedded_protocol_missing_sources" % string))
            | Some protocol =>
              let hash := Tezos_base.Protocol.hash protocol in
              if
                negb
                  (Tezos_base__TzPervasives.Protocol_hash.equal hash
                    protocol_hash) then
                Local_logging.lwt_log_info
                  (fun f =>
                    Local_logging.Tag.DSL.op_minus_percent
                      (Local_logging.Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "protocol " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " won't be stored: wrong hash" % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "protocol %a won't be stored: wrong hash" % string))
                        (Local_logging.Tag.DSL.a
                          Tezos_base__TzPervasives.Protocol_hash.Logging.tag
                          protocol_hash))
                      (Local_logging.Tag.DSL.t Local_logging.event
                        "embedded_protocol_inconsistent_hash" % string))
              else
                Lwt.Infix.op_gt_gt_eq
                  (Tezos_shell.State.Protocol.store state protocol)
                  (fun function_parameter =>
                    match function_parameter with
                    | Some hash' =>
                      equiv_decb hash hash';
                      Local_logging.lwt_log_info
                        (fun f =>
                          Local_logging.Tag.DSL.op_minus_percent
                            (Local_logging.Tag.DSL.op_minus_percent
                              (f
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "protocol " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " successfully stored" % string
                                        CamlinternalFormatBasics.End_of_format)))
                                  "protocol %a successfully stored" % string))
                              (Local_logging.Tag.DSL.a
                                Tezos_base__TzPervasives.Protocol_hash.Logging.tag
                                protocol_hash))
                            (Local_logging.Tag.DSL.t Local_logging.event
                              "embedded_protocol_stored" % string))
                    | None =>
                      Local_logging.lwt_log_info
                        (fun f =>
                          Local_logging.Tag.DSL.op_minus_percent
                            (Local_logging.Tag.DSL.op_minus_percent
                              (f
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "protocol " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " is already in store: nothing to do" %
                                          string
                                        CamlinternalFormatBasics.End_of_format)))
                                  "protocol %a is already in store: nothing to do"
                                    % string))
                              (Local_logging.Tag.DSL.a
                                Tezos_base__TzPervasives.Protocol_hash.Logging.tag
                                protocol_hash))
                            (Local_logging.Tag.DSL.t Local_logging.event
                              "embedded_protocol_already_stored" % string))
                    end)
            end
          end)) embedded_protocols.

Definition create (op_star_o_p_t_star : option bool)
  : (option Tezos_base__TzPervasives.Data_encoding.json) ->
    bool ->
      config ->
        Tezos_shell.Peer_validator.limits ->
          Tezos_shell.Block_validator.limits ->
            Tezos_shell.Prevalidator.limits ->
              Tezos_shell.Chain_validator.limits ->
                (option Tezos_shell_services.History_mode.t) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let sandboxed :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun sandbox_parameters =>
    fun singleprocess =>
      fun function_parameter =>
        match function_parameter with
        | {|
          genesis := genesis;
            store_root := store_root;
            context_root := context_root;
            protocol_root := protocol_root;
            patch_context := patch_context;
            p2p := p2p_params;
            checkpoint := checkpoint
            |} =>
          fun peer_validator_limits =>
            fun block_validator_limits =>
              fun prevalidator_limits =>
                fun chain_validator_limits =>
                  fun history_mode =>
                    match
                      match p2p_params with
                      | Some (config, _limits) =>
                        ((negb (P2p.disable_mempool config)),
                          (negb (P2p.disable_testchain config)))
                      | None => (true, true)
                      end with
                    | (start_prevalidator, start_testchain) =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (init_p2p (Some sandboxed) p2p_params)
                        (fun p2p =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (if singleprocess then
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_shell.State.init patch_context None None
                                  None store_root context_root history_mode
                                  genesis)
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    (state, mainchain_state, context_index,
                                      history_mode) =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_shell.Block_validator_process.init
                                        (Internal context_index))
                                      (fun validator_process =>
                                        Tezos_base__TzPervasives._return
                                          (validator_process, state,
                                            mainchain_state, history_mode))
                                  end)
                            else
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_shell.Block_validator_process.init
                                  (External
                                    {| context_root := context_root;
                                      protocol_root := protocol_root;
                                      process_path := Stdlib.Sys.executable_name;
                                      sandbox_parameters := sandbox_parameters
                                      |}))
                                (fun validator_process =>
                                  let commit_genesis :=
                                    Tezos_shell.Block_validator_process.commit_genesis
                                      validator_process (block genesis) in
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_shell.State.init patch_context
                                      (Some commit_genesis) None None store_root
                                      context_root history_mode genesis)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      |
                                        (state, mainchain_state, _context_index,
                                          history_mode) =>
                                        Tezos_base__TzPervasives._return
                                          (validator_process, state,
                                            mainchain_state, history_mode)
                                      end)))
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                (validator_process, state, mainchain_state,
                                  history_mode) =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (may_update_checkpoint mainchain_state
                                    checkpoint history_mode)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      let distributed_db :=
                                        Tezos_shell.Distributed_db.create state
                                          p2p in
                                      Lwt.Infix.op_gt_gt_eq
                                        (store_known_protocols state)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                              (Tezos_shell.Validator.create
                                                state distributed_db
                                                peer_validator_limits
                                                block_validator_limits
                                                validator_process
                                                prevalidator_limits
                                                chain_validator_limits
                                                start_testchain)
                                              (fun validator =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_shell.Validator.activate
                                                    validator start_prevalidator
                                                    validator_process
                                                    mainchain_state)
                                                  (fun mainchain_validator =>
                                                    let shutdown
                                                      (function_parameter :
                                                      unit) : Lwt.t unit :=
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Lwt.Infix.op_gt_gt_eq
                                                          (Local_logging.lwt_log_info
                                                            (fun f =>
                                                              Local_logging.Tag.DSL.op_minus_percent
                                                                (f
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "Shutting down the p2p layer..."
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "Shutting down the p2p layer..."
                                                                      % string))
                                                                (Local_logging.Tag.DSL.t
                                                                  Local_logging.event
                                                                  "shutdown" %
                                                                    string)))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Lwt.Infix.op_gt_gt_eq
                                                                (Tezos_p2p.P2p.shutdown
                                                                  p2p)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Lwt.Infix.op_gt_gt_eq
                                                                      (Local_logging.lwt_log_info
                                                                        (fun f
                                                                          =>
                                                                          Local_logging.Tag.DSL.op_minus_percent
                                                                            (f
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "Shutting down the distributed database..."
                                                                                    %
                                                                                    string
                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                "Shutting down the distributed database..."
                                                                                  %
                                                                                  string))
                                                                            (Local_logging.Tag.DSL.t
                                                                              Local_logging.event
                                                                              "shutdown"
                                                                                %
                                                                                string)))
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          Lwt.Infix.op_gt_gt_eq
                                                                            (Tezos_shell.Distributed_db.shutdown
                                                                              distributed_db)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                Lwt.Infix.op_gt_gt_eq
                                                                                  (Local_logging.lwt_log_info
                                                                                    (fun
                                                                                      f
                                                                                      =>
                                                                                      Local_logging.Tag.DSL.op_minus_percent
                                                                                        (f
                                                                                          (CamlinternalFormatBasics.Format
                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                              "Shutting down the validator..."
                                                                                                %
                                                                                                string
                                                                                              CamlinternalFormatBasics.End_of_format)
                                                                                            "Shutting down the validator..."
                                                                                              %
                                                                                              string))
                                                                                        (Local_logging.Tag.DSL.t
                                                                                          Local_logging.event
                                                                                          "shutdown"
                                                                                            %
                                                                                            string)))
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      Lwt.Infix.op_gt_gt_eq
                                                                                        (Tezos_shell.Validator.shutdown
                                                                                          validator)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            tt
                                                                                            =>
                                                                                            Lwt.Infix.op_gt_gt_eq
                                                                                              (Local_logging.lwt_log_info
                                                                                                (fun
                                                                                                  f
                                                                                                  =>
                                                                                                  Local_logging.Tag.DSL.op_minus_percent
                                                                                                    (f
                                                                                                      (CamlinternalFormatBasics.Format
                                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                                          "Closing down the state..."
                                                                                                            %
                                                                                                            string
                                                                                                          CamlinternalFormatBasics.End_of_format)
                                                                                                        "Closing down the state..."
                                                                                                          %
                                                                                                          string))
                                                                                                    (Local_logging.Tag.DSL.t
                                                                                                      Local_logging.event
                                                                                                      "shutdown"
                                                                                                        %
                                                                                                        string)))
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  tt
                                                                                                  =>
                                                                                                  Tezos_shell.State.close
                                                                                                    state
                                                                                                end)
                                                                                          end)
                                                                                    end)
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end in
                                                    Tezos_base__TzPervasives._return
                                                      {| state := state;
                                                        distributed_db :=
                                                          distributed_db;
                                                        validator := validator;
                                                        mainchain_validator :=
                                                          mainchain_validator;
                                                        p2p := p2p;
                                                        shutdown := shutdown |}))
                                          end)
                                    end)
                              end))
                    end
        end.

Definition shutdown (node : t) : Lwt.t unit := (shutdown node) tt.

Definition build_rpc_directory (node : t)
  : Tezos_base__TzPervasives.RPC_directory.directory unit :=
  let dir := Stdlib.ref Tezos_base__TzPervasives.RPC_directory.empty in
  let merge (d : Tezos_base__TzPervasives.RPC_directory.directory unit)
    : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.merge (Stdlib.op_exclamation dir)
        d) in
  let register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | tt => fun p => fun q => f p q
          end)) in
  merge
    (Tezos_shell.Protocol_directory.build_rpc_directory
      (Tezos_shell.Block_validator.running_worker tt) (state node));
  merge
    (Tezos_shell.Monitor_directory.build_rpc_directory (validator node)
      (mainchain_validator node));
  merge (Tezos_shell.Injection_directory.build_rpc_directory (validator node));
  merge (Tezos_shell.Chain_directory.build_rpc_directory (validator node));
  merge (Tezos_shell.P2p_directory.build_rpc_directory (p2p node));
  merge (Tezos_shell.Worker_directory.build_rpc_directory (state node));
  merge (Tezos_shell.Stat_directory.rpc_directory tt);
  register0 Tezos_base__TzPervasives.RPC_service.error_service
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives._return
              (Tezos_base__TzPervasives.Data_encoding.Json.schema None
                Tezos_base__TzPervasives.Error_monad.error_encoding)
          end
      end);
  Tezos_base__TzPervasives.RPC_directory.register_describe_directory_service
    (Stdlib.op_exclamation dir)
    Tezos_base__TzPervasives.RPC_service.description_service.
src/lib_shell/node.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

type t

type config = {
  genesis : State.Chain.genesis;
  store_root : string;
  context_root : string;
  protocol_root : string;
  patch_context : (Context.t -> Context.t Lwt.t) option;
  p2p : (P2p.config * P2p.limits) option;
  checkpoint : Block_header.t option;
}

and peer_validator_limits = {
  new_head_request_timeout : Time.System.Span.t;
  block_header_timeout : Time.System.Span.t;
  block_operations_timeout : Time.System.Span.t;
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

and prevalidator_limits = {
  max_refused_operations : int;
  operation_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
  operations_batch_size : int;
}

and block_validator_limits = {
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

and chain_validator_limits = {
  bootstrap_threshold : int;
  worker_limits : Worker_types.limits;
}

val default_peer_validator_limits : peer_validator_limits

val default_prevalidator_limits : prevalidator_limits

val default_block_validator_limits : block_validator_limits

val default_chain_validator_limits : chain_validator_limits

val create :
  ?sandboxed:bool ->
  ?sandbox_parameters:Data_encoding.json ->
  singleprocess:bool ->
  config ->
  peer_validator_limits ->
  block_validator_limits ->
  prevalidator_limits ->
  chain_validator_limits ->
  History_mode.t option ->
  t tzresult Lwt.t

val shutdown : t -> unit Lwt.t

val build_rpc_directory : t -> unit RPC_directory.t
src/lib_shell/node.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

attribute

Parameter t : Type.

.

Parameter default_peer_validator_limits : peer_validator_limits.

Parameter default_prevalidator_limits : prevalidator_limits.

Parameter default_block_validator_limits : block_validator_limits.

Parameter default_chain_validator_limits : chain_validator_limits.

Parameter create :
(option bool) ->
  (option Tezos_base__TzPervasives.Data_encoding.json) ->
    bool ->
      config ->
        peer_validator_limits ->
          block_validator_limits ->
            prevalidator_limits ->
              chain_validator_limits ->
                (option Tezos_shell_services.History_mode.t) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter shutdown : t -> Lwt.t unit.

Parameter build_rpc_directory :
t -> Tezos_base__TzPervasives.RPC_directory.t unit.
src/lib_shell/p2p_directory.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let info_of_point_info i =
  let open P2p_point.Info in
  let open P2p_point.State in
  let state =
    match P2p_point_state.get i with
    | Requested _ ->
        Requested
    | Accepted {current_peer_id; _} ->
        Accepted current_peer_id
    | Running {current_peer_id; _} ->
        Running current_peer_id
    | Disconnected ->
        Disconnected
  in
  P2p_point_state.Info.
    {
      trusted = trusted i;
      state;
      greylisted_until = greylisted_until i;
      last_failed_connection = last_failed_connection i;
      last_rejected_connection = last_rejected_connection i;
      last_established_connection = last_established_connection i;
      last_disconnection = last_disconnection i;
      last_seen = last_seen i;
      last_miss = last_miss i;
    }

let info_of_peer_info pool i =
  let open P2p_peer.Info in
  let open P2p_peer.State in
  let (state, id_point) =
    match P2p_peer_state.get i with
    | Accepted {current_point; _} ->
        (Accepted, Some current_point)
    | Running {current_point; _} ->
        (Running, Some current_point)
    | Disconnected ->
        (Disconnected, None)
  in
  let peer_id = P2p_peer_state.Info.peer_id i in
  let score = P2p_pool.Peers.get_score pool peer_id in
  let conn_opt = P2p_pool.Connection.find_by_peer_id pool peer_id in
  let stat =
    match conn_opt with
    | None ->
        P2p_stat.empty
    | Some conn ->
        P2p_pool.Connection.stat conn
  in
  let meta_opt =
    match conn_opt with
    | None ->
        None
    | Some conn ->
        Some (P2p_pool.Connection.remote_metadata conn)
  in
  P2p_peer_state.Info.
    {
      score;
      trusted = trusted i;
      conn_metadata = meta_opt;
      peer_metadata = peer_metadata i;
      state;
      id_point;
      stat;
      last_failed_connection = last_failed_connection i;
      last_rejected_connection = last_rejected_connection i;
      last_established_connection = last_established_connection i;
      last_disconnection = last_disconnection i;
      last_seen = last_seen i;
      last_miss = last_miss i;
    }

let build_rpc_directory net =
  let dir = RPC_directory.empty in
  (* Network : Global *)
  let dir =
    RPC_directory.register0 dir P2p_services.S.version (fun () () ->
        return (P2p.announced_version net))
  in
  let dir =
    (* DEPRECATED: use [version] instead. *)
    RPC_directory.register0 dir P2p_services.S.versions (fun () () ->
        return [P2p.announced_version net])
  in
  let dir =
    RPC_directory.register0 dir P2p_services.S.self (fun () () ->
        match P2p.pool net with
        | None ->
            failwith "The P2P layer is disabled."
        | Some pool ->
            return (P2p_pool.config pool).identity.peer_id)
  in
  let dir =
    RPC_directory.register0 dir P2p_services.S.stat (fun () () ->
        match P2p.pool net with
        | None ->
            return P2p_stat.empty
        | Some pool ->
            return (P2p_pool.pool_stat pool))
  in
  let dir =
    RPC_directory.gen_register0 dir P2p_services.S.events (fun () () ->
        let (stream, stopper) =
          match P2p.pool net with
          | None ->
              Lwt_watcher.create_fake_stream ()
          | Some pool ->
              P2p_pool.watch pool
        in
        let shutdown () = Lwt_watcher.shutdown stopper in
        let next () = Lwt_stream.get stream in
        RPC_answer.return_stream {next; shutdown})
  in
  let dir =
    RPC_directory.register1 dir P2p_services.S.connect (fun point q () ->
        match P2p.pool net with
        | None ->
            failwith "The P2P layer is disabled."
        | Some pool ->
            P2p_pool.connect ~timeout:q#timeout pool point
            >>=? fun _conn -> return_unit)
  in
  (* Network : Connection *)
  let dir =
    RPC_directory.opt_register1
      dir
      P2p_services.Connections.S.info
      (fun peer_id () () ->
        return
        @@ Option.apply (P2p.pool net) ~f:(fun pool ->
               Option.map
                 ~f:P2p_pool.Connection.info
                 (P2p_pool.Connection.find_by_peer_id pool peer_id)))
  in
  let dir =
    RPC_directory.lwt_register1
      dir
      P2p_services.Connections.S.kick
      (fun peer_id q () ->
        match P2p.pool net with
        | None ->
            Lwt.return_unit
        | Some pool -> (
          match P2p_pool.Connection.find_by_peer_id pool peer_id with
          | None ->
              Lwt.return_unit
          | Some conn ->
              P2p_pool.disconnect ~wait:q#wait conn ))
  in
  let dir =
    RPC_directory.register0 dir P2p_services.Connections.S.list (fun () () ->
        match P2p.pool net with
        | None ->
            return_nil
        | Some pool ->
            return
            @@ P2p_pool.Connection.fold pool ~init:[] ~f:(fun _peer_id c acc ->
                   P2p_pool.Connection.info c :: acc))
  in
  (* Network : Peer_id *)
  let dir =
    RPC_directory.register0 dir P2p_services.Peers.S.list (fun q () ->
        match P2p.pool net with
        | None ->
            return_nil
        | Some pool ->
            return
            @@ P2p_pool.Peers.fold_known pool ~init:[] ~f:(fun peer_id i a ->
                   let info = info_of_peer_info pool i in
                   match q#filters with
                   | [] ->
                       (peer_id, info) :: a
                   | filters when P2p_peer.State.filter filters info.state ->
                       (peer_id, info) :: a
                   | _ ->
                       a))
  in
  let dir =
    RPC_directory.opt_register1
      dir
      P2p_services.Peers.S.info
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            return_none
        | Some pool ->
            return
            @@ Option.map
                 ~f:(info_of_peer_info pool)
                 (P2p_pool.Peers.info pool peer_id))
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.events
      (fun peer_id q () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool -> (
          match P2p_pool.Peers.info pool peer_id with
          | None ->
              RPC_answer.return []
          | Some gi ->
              let rev = false and max = max_int in
              let evts =
                P2p_peer_state.Info.fold gi ~init:[] ~f:(fun a e -> e :: a)
              in
              let evts = (if rev then List.rev_sub else List.sub) evts max in
              if not q#monitor then RPC_answer.return evts
              else
                let (stream, stopper) = P2p_peer_state.Info.watch gi in
                let shutdown () = Lwt_watcher.shutdown stopper in
                let first_request = ref true in
                let next () =
                  if not !first_request then
                    Lwt_stream.get stream >|= Option.map ~f:(fun i -> [i])
                  else (
                    first_request := false ;
                    Lwt.return_some evts )
                in
                RPC_answer.return_stream {next; shutdown} ))
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.ban
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Peers.untrust pool peer_id ;
            P2p_pool.Peers.ban pool peer_id ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.unban
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Peers.unban pool peer_id ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.trust
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Peers.trust pool peer_id ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.untrust
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Peers.untrust pool peer_id ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.register1
      dir
      P2p_services.Peers.S.banned
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            return_false
        | Some pool when P2p_pool.Peers.get_trusted pool peer_id ->
            return_false
        | Some pool ->
            return (P2p_pool.Peers.banned pool peer_id))
  in
  (* Network : Point *)
  let dir =
    RPC_directory.register0 dir P2p_services.Points.S.list (fun q () ->
        match P2p.pool net with
        | None ->
            return_nil
        | Some pool ->
            return
            @@ P2p_pool.Points.fold_known pool ~init:[] ~f:(fun point i a ->
                   let info = info_of_point_info i in
                   match q#filters with
                   | [] ->
                       (point, info) :: a
                   | filters when P2p_point.State.filter filters info.state ->
                       (point, info) :: a
                   | _ ->
                       a))
  in
  let dir =
    RPC_directory.opt_register1
      dir
      P2p_services.Points.S.info
      (fun point () () ->
        match P2p.pool net with
        | None ->
            return_none
        | Some pool ->
            return
            @@ Option.map
                 (P2p_pool.Points.info pool point)
                 ~f:info_of_point_info)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.events
      (fun point_id q () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool -> (
          match P2p_pool.Points.info pool point_id with
          | None ->
              RPC_answer.return []
          | Some gi ->
              let rev = false and max = max_int in
              let evts =
                P2p_point_state.Info.fold gi ~init:[] ~f:(fun a e -> e :: a)
              in
              let evts = (if rev then List.rev_sub else List.sub) evts max in
              if not q#monitor then RPC_answer.return evts
              else
                let (stream, stopper) = P2p_point_state.Info.watch gi in
                let shutdown () = Lwt_watcher.shutdown stopper in
                let first_request = ref true in
                let next () =
                  if not !first_request then
                    Lwt_stream.get stream >|= Option.map ~f:(fun i -> [i])
                  else (
                    first_request := false ;
                    Lwt.return_some evts )
                in
                RPC_answer.return_stream {next; shutdown} ))
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.ban
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Points.untrust pool point ;
            P2p_pool.Points.ban pool point ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.unban
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Points.unban pool point ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.trust
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Points.trust pool point ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.untrust
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Points.untrust pool point ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.banned
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool when P2p_pool.Points.get_trusted pool point ->
            RPC_answer.return false
        | Some pool ->
            RPC_answer.return (P2p_pool.Points.banned pool point))
  in
  (* Network : Greylist *)
  let dir =
    RPC_directory.register dir P2p_services.ACL.S.clear (fun () () () ->
        match P2p.pool net with
        | None ->
            return_unit
        | Some pool ->
            P2p_pool.acl_clear pool ; return_unit)
  in
  dir
src/lib_shell/p2p_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition info_of_point_info {A : Type}
  (i : Tezos_p2p.P2p_point_state.Info.t A)
  : Tezos_base__TzPervasives.P2p_point.Info.t :=
  let state :=
    match Tezos_p2p.P2p_point_state.get i with
    | Requested _ => Requested
    | Accepted {| current_peer_id := current_peer_id |} =>
      Accepted current_peer_id
    | Running {| current_peer_id := current_peer_id |} =>
      Running current_peer_id
    | Disconnected => Disconnected
    end in
  {| trusted := Tezos_p2p.P2p_point_state.Info.trusted i;
    greylisted_until := Tezos_p2p.P2p_point_state.Info.greylisted_until i;
    state := state;
    last_failed_connection :=
      Tezos_p2p.P2p_point_state.Info.last_failed_connection i;
    last_rejected_connection :=
      Tezos_p2p.P2p_point_state.Info.last_rejected_connection i;
    last_established_connection :=
      Tezos_p2p.P2p_point_state.Info.last_established_connection i;
    last_disconnection := Tezos_p2p.P2p_point_state.Info.last_disconnection i;
    last_seen := Tezos_p2p.P2p_point_state.Info.last_seen i;
    last_miss := Tezos_p2p.P2p_point_state.Info.last_miss i |}.

Definition info_of_peer_info {A B C D E F : Type}
  (pool : Tezos_p2p__P2p_pool.pool A B C)
  (i : Tezos_p2p.P2p_peer_state.Info.t D E F)
  : Tezos_base__TzPervasives.P2p_peer.Info.t E C :=
  match
    match Tezos_p2p.P2p_peer_state.get i with
    | Accepted {| current_point := current_point |} =>
      (Accepted, (Some current_point))
    | Running {| current_point := current_point |} =>
      (Running, (Some current_point))
    | Disconnected => (Disconnected, None)
    end with
  | (state, id_point) =>
    let peer_id := Tezos_p2p.P2p_peer_state.Info.peer_id i in
    let score := Tezos_p2p.P2p_pool.Peers.get_score pool peer_id in
    let conn_opt := Tezos_p2p.P2p_pool.Connection.find_by_peer_id pool peer_id
      in
    let stat :=
      match conn_opt with
      | None => Tezos_base__TzPervasives.P2p_stat.empty
      | Some conn => Tezos_p2p.P2p_pool.Connection.stat conn
      end in
    let meta_opt :=
      match conn_opt with
      | None => None
      | Some conn => Some (Tezos_p2p.P2p_pool.Connection.remote_metadata conn)
      end in
    {| score := score; trusted := Tezos_p2p.P2p_peer_state.Info.trusted i;
      conn_metadata := meta_opt;
      peer_metadata := Tezos_p2p.P2p_peer_state.Info.peer_metadata i;
      state := state; id_point := id_point; stat := stat;
      last_failed_connection :=
        Tezos_p2p.P2p_peer_state.Info.last_failed_connection i;
      last_rejected_connection :=
        Tezos_p2p.P2p_peer_state.Info.last_rejected_connection i;
      last_established_connection :=
        Tezos_p2p.P2p_peer_state.Info.last_established_connection i;
      last_disconnection := Tezos_p2p.P2p_peer_state.Info.last_disconnection i;
      last_seen := Tezos_p2p.P2p_peer_state.Info.last_seen i;
      last_miss := Tezos_p2p.P2p_peer_state.Info.last_miss i |}
  end.

Definition build_rpc_directory {A : Type}
  (net :
    Tezos_p2p.P2p.net A Tezos_shell_services.Peer_metadata.t
      Tezos_shell_services.Connection_metadata.t)
  : Tezos_base__TzPervasives.RPC_directory.directory unit :=
  let dir := Tezos_base__TzPervasives.RPC_directory.empty in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register0 dir
      Tezos_shell_services.P2p_services.S.version
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives._return
                (Tezos_p2p.P2p.announced_version net)
            end
        end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register0 dir
      Tezos_shell_services.P2p_services.S.versions
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives._return
                (cons (Tezos_p2p.P2p.announced_version net) [])
            end
        end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register0 dir
      Tezos_shell_services.P2p_services.S.self
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match Tezos_p2p.P2p.pool net with
              | None =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "The P2P layer is disabled." % string
                      CamlinternalFormatBasics.End_of_format)
                    "The P2P layer is disabled." % string)
              | Some pool =>
                Tezos_base__TzPervasives._return
                  (peer_id (identity (Tezos_p2p.P2p_pool.config pool)))
              end
            end
        end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register0 dir
      Tezos_shell_services.P2p_services.S.stat
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match Tezos_p2p.P2p.pool net with
              | None =>
                Tezos_base__TzPervasives._return
                  Tezos_base__TzPervasives.P2p_stat.empty
              | Some pool =>
                Tezos_base__TzPervasives._return
                  (Tezos_p2p.P2p_pool.pool_stat pool)
              end
            end
        end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register0 dir
      Tezos_shell_services.P2p_services.S.events
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match
                match Tezos_p2p.P2p.pool net with
                | None =>
                  Tezos_base__TzPervasives.Lwt_watcher.create_fake_stream tt
                | Some pool => Tezos_p2p.P2p_pool.watch pool
                end with
              | (stream, stopper) =>
                let shutdown (function_parameter : unit) : unit :=
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.Lwt_watcher.shutdown stopper
                  end in
                let next (function_parameter : unit)
                  : Lwt.t
                    (option Tezos_base__TzPervasives.P2p_connection.Pool_event.t) :=
                  match function_parameter with
                  | tt => Lwt_stream.get stream
                  end in
                Tezos_base__TzPervasives.RPC_answer.return_stream
                  {| next := next; shutdown := shutdown |}
              end
            end
        end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register1 dir
      Tezos_shell_services.P2p_services.S.connect
      (fun point =>
        fun q =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match Tezos_p2p.P2p.pool net with
              | None =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "The P2P layer is disabled." % string
                      CamlinternalFormatBasics.End_of_format)
                    "The P2P layer is disabled." % string)
              | Some pool =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_p2p.P2p_pool.connect (Some send) pool point)
                  (fun _conn => Tezos_base__TzPervasives.return_unit)
              end
            end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.opt_register1 dir
      Tezos_shell_services.P2p_services.Connections.S.info
      (fun peer_id =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                apply Tezos_base__TzPervasives._return
                  (Tezos_base__TzPervasives.Option.apply
                    (fun pool =>
                      Tezos_base__TzPervasives.Option.map
                        Tezos_p2p.P2p_pool.Connection.info
                        (Tezos_p2p.P2p_pool.Connection.find_by_peer_id pool
                          peer_id)) (Tezos_p2p.P2p.pool net))
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.lwt_register1 dir
      Tezos_shell_services.P2p_services.Connections.S.kick
      (fun peer_id =>
        fun q =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match Tezos_p2p.P2p.pool net with
              | None => Lwt.return_unit
              | Some pool =>
                match Tezos_p2p.P2p_pool.Connection.find_by_peer_id pool peer_id
                  with
                | None => Lwt.return_unit
                | Some conn => Tezos_p2p.P2p_pool.disconnect (Some send) conn
                end
              end
            end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register0 dir
      Tezos_shell_services.P2p_services.Connections.S.list
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match Tezos_p2p.P2p.pool net with
              | None => Tezos_base__TzPervasives.return_nil
              | Some pool =>
                apply Tezos_base__TzPervasives._return
                  (Tezos_p2p.P2p_pool.Connection.fold pool []
                    (fun _peer_id =>
                      fun c =>
                        fun acc =>
                          cons (Tezos_p2p.P2p_pool.Connection.info c) acc))
              end
            end
        end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register0 dir
      Tezos_shell_services.P2p_services.Peers.S.list
      (fun q =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            match Tezos_p2p.P2p.pool net with
            | None => Tezos_base__TzPervasives.return_nil
            | Some pool =>
              apply Tezos_base__TzPervasives._return
                (Tezos_p2p.P2p_pool.Peers.fold_known pool []
                  (fun peer_id =>
                    fun i =>
                      fun a =>
                        let info := info_of_peer_info pool i in
                        match send with
                        | [] => cons (peer_id, info) a
                        | _ => a
                        end))
            end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.opt_register1 dir
      Tezos_shell_services.P2p_services.Peers.S.info
      (fun peer_id =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.return_none
                | Some pool =>
                  apply Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.Option.map
                      (info_of_peer_info pool)
                      (Tezos_p2p.P2p_pool.Peers.info pool peer_id))
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Peers.S.events
      (fun peer_id =>
        fun q =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match Tezos_p2p.P2p.pool net with
              | None => Tezos_base__TzPervasives.RPC_answer.not_found
              | Some pool =>
                match Tezos_p2p.P2p_pool.Peers.info pool peer_id with
                | None => Tezos_base__TzPervasives.RPC_answer._return []
                | Some gi =>
                  let rev : bool :=
                    false
                  with max : Z :=
                    Stdlib.max_int in
                  let evts :=
                    Tezos_p2p.P2p_peer_state.Info.fold gi []
                      (fun a => fun e => cons e a) in
                  let evts :=
                    (if rev then
                      Tezos_base__TzPervasives.List.rev_sub
                    else
                      Tezos_base__TzPervasives.List.sub) evts max in
                  if negb send then
                    Tezos_base__TzPervasives.RPC_answer._return evts
                  else
                    match Tezos_p2p.P2p_peer_state.Info.watch gi with
                    | (stream, stopper) =>
                      let shutdown (function_parameter : unit) : unit :=
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.Lwt_watcher.shutdown stopper
                        end in
                      let first_request := Stdlib.ref true in
                      let next (function_parameter : unit)
                        : Lwt.t
                          (option
                            (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t)) :=
                        match function_parameter with
                        | tt =>
                          if negb (Stdlib.op_exclamation first_request) then
                            Tezos_base__TzPervasives.op_gt_pipe_eq
                              (Lwt_stream.get stream)
                              (Tezos_base__TzPervasives.Option.map
                                (fun i => cons i []))
                          else
                            Stdlib.op_colon_eq first_request false;
                            Lwt.return_some evts
                        end in
                      Tezos_base__TzPervasives.RPC_answer.return_stream
                        {| next := next; shutdown := shutdown |}
                    end
                end
              end
            end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Peers.S.ban
      (fun peer_id =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_p2p.P2p_pool.Peers.untrust pool peer_id;
                  Tezos_p2p.P2p_pool.Peers.ban pool peer_id;
                  Tezos_base__TzPervasives.RPC_answer.return_unit
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Peers.S.unban
      (fun peer_id =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_p2p.P2p_pool.Peers.unban pool peer_id;
                  Tezos_base__TzPervasives.RPC_answer.return_unit
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Peers.S.trust
      (fun peer_id =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_p2p.P2p_pool.Peers.trust pool peer_id;
                  Tezos_base__TzPervasives.RPC_answer.return_unit
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Peers.S.untrust
      (fun peer_id =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_p2p.P2p_pool.Peers.untrust pool peer_id;
                  Tezos_base__TzPervasives.RPC_answer.return_unit
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register1 dir
      Tezos_shell_services.P2p_services.Peers.S.banned
      (fun peer_id =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.return_false
                | Some pool =>
                  Tezos_base__TzPervasives._return
                    (Tezos_p2p.P2p_pool.Peers.banned pool peer_id)
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register0 dir
      Tezos_shell_services.P2p_services.Points.S.list
      (fun q =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            match Tezos_p2p.P2p.pool net with
            | None => Tezos_base__TzPervasives.return_nil
            | Some pool =>
              apply Tezos_base__TzPervasives._return
                (Tezos_p2p.P2p_pool.Points.fold_known pool []
                  (fun point =>
                    fun i =>
                      fun a =>
                        let info := info_of_point_info i in
                        match send with
                        | [] => cons (point, info) a
                        | _ => a
                        end))
            end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.opt_register1 dir
      Tezos_shell_services.P2p_services.Points.S.info
      (fun point =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.return_none
                | Some pool =>
                  apply Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.Option.map info_of_point_info
                      (Tezos_p2p.P2p_pool.Points.info pool point))
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Points.S.events
      (fun point_id =>
        fun q =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match Tezos_p2p.P2p.pool net with
              | None => Tezos_base__TzPervasives.RPC_answer.not_found
              | Some pool =>
                match Tezos_p2p.P2p_pool.Points.info pool point_id with
                | None => Tezos_base__TzPervasives.RPC_answer._return []
                | Some gi =>
                  let rev : bool :=
                    false
                  with max : Z :=
                    Stdlib.max_int in
                  let evts :=
                    Tezos_p2p.P2p_point_state.Info.fold gi []
                      (fun a => fun e => cons e a) in
                  let evts :=
                    (if rev then
                      Tezos_base__TzPervasives.List.rev_sub
                    else
                      Tezos_base__TzPervasives.List.sub) evts max in
                  if negb send then
                    Tezos_base__TzPervasives.RPC_answer._return evts
                  else
                    match Tezos_p2p.P2p_point_state.Info.watch gi with
                    | (stream, stopper) =>
                      let shutdown (function_parameter : unit) : unit :=
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.Lwt_watcher.shutdown stopper
                        end in
                      let first_request := Stdlib.ref true in
                      let next (function_parameter : unit)
                        : Lwt.t
                          (option
                            (list
                              Tezos_base__TzPervasives.P2p_point.Pool_event.t)) :=
                        match function_parameter with
                        | tt =>
                          if negb (Stdlib.op_exclamation first_request) then
                            Tezos_base__TzPervasives.op_gt_pipe_eq
                              (Lwt_stream.get stream)
                              (Tezos_base__TzPervasives.Option.map
                                (fun i => cons i []))
                          else
                            Stdlib.op_colon_eq first_request false;
                            Lwt.return_some evts
                        end in
                      Tezos_base__TzPervasives.RPC_answer.return_stream
                        {| next := next; shutdown := shutdown |}
                    end
                end
              end
            end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Points.S.ban
      (fun point =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_p2p.P2p_pool.Points.untrust pool point;
                  Tezos_p2p.P2p_pool.Points.ban pool point;
                  Tezos_base__TzPervasives.RPC_answer.return_unit
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Points.S.unban
      (fun point =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_p2p.P2p_pool.Points.unban pool point;
                  Tezos_base__TzPervasives.RPC_answer.return_unit
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Points.S.trust
      (fun point =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_p2p.P2p_pool.Points.trust pool point;
                  Tezos_base__TzPervasives.RPC_answer.return_unit
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Points.S.untrust
      (fun point =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_p2p.P2p_pool.Points.untrust pool point;
                  Tezos_base__TzPervasives.RPC_answer.return_unit
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.gen_register1 dir
      Tezos_shell_services.P2p_services.Points.S.banned
      (fun point =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                match Tezos_p2p.P2p.pool net with
                | None => Tezos_base__TzPervasives.RPC_answer.not_found
                | Some pool =>
                  Tezos_base__TzPervasives.RPC_answer._return
                    (Tezos_p2p.P2p_pool.Points.banned pool point)
                end
              end
          end) in
  let dir :=
    Tezos_base__TzPervasives.RPC_directory.register dir
      Tezos_shell_services.P2p_services.ACL.S.clear
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  match Tezos_p2p.P2p.pool net with
                  | None => Tezos_base__TzPervasives.return_unit
                  | Some pool =>
                    Tezos_p2p.P2p_pool.acl_clear pool;
                    Tezos_base__TzPervasives.return_unit
                  end
                end
            end
        end) in
  dir.
src/lib_shell/p2p_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val build_rpc_directory :
  (_, Peer_metadata.t, Connection_metadata.t) P2p.t -> unit RPC_directory.t
src/lib_shell/p2p_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter build_rpc_directory : forall {_ : Type},
(Tezos_p2p.P2p.t _ Tezos_shell_services.Peer_metadata.t
  Tezos_shell_services.Connection_metadata.t) ->
  Tezos_base__TzPervasives.RPC_directory.t unit.
src/lib_shell/peer_validator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* FIXME ignore/postpone fetching/validating of block in the future... *)

open Peer_validator_worker_state

module Name = struct
  type t = Chain_id.t * P2p_peer.Id.t

  let encoding = Data_encoding.tup2 Chain_id.encoding P2p_peer.Id.encoding

  let base = ["validator"; "peer"]

  let pp ppf (chain, peer) =
    Format.fprintf
      ppf
      "%a:%a"
      Chain_id.pp_short
      chain
      P2p_peer.Id.pp_short
      peer
end

module Request = struct
  include Request

  type _ t =
    | New_head : Block_hash.t * Block_header.t -> unit t
    | New_branch :
        Block_hash.t * Block_locator.t * Block_locator.seed
        -> unit t

  let view (type a) (req : a t) : view =
    match req with
    | New_head (hash, _) ->
        New_head hash
    | New_branch (hash, locator, seed) ->
        (* the seed is associated to each locator
           w.r.t. the peer_id of the sender *)
        New_branch (hash, Block_locator.estimated_length seed locator)
end

type limits = {
  new_head_request_timeout : Time.System.Span.t;
  block_header_timeout : Time.System.Span.t;
  block_operations_timeout : Time.System.Span.t;
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

module Types = struct
  include Worker_state

  type parameters = {
    chain_db : Distributed_db.chain_db;
    block_validator : Block_validator.t;
    (* callback to chain_validator *)
    notify_new_block : State.Block.t -> unit;
    notify_bootstrapped : unit -> unit;
    notify_termination : unit -> unit;
    limits : limits;
  }

  type state = {
    peer_id : P2p_peer.Id.t;
    parameters : parameters;
    mutable bootstrapped : bool;
    mutable pipeline : Bootstrap_pipeline.t option;
    mutable last_validated_head : Block_header.t;
    mutable last_advertised_head : Block_header.t;
  }

  let pipeline_length = function
    | None ->
        Bootstrap_pipeline.length_zero
    | Some p ->
        Bootstrap_pipeline.length p

  let view (state : state) _ : view =
    let {bootstrapped; pipeline; last_validated_head; last_advertised_head; _}
        =
      state
    in
    {
      bootstrapped;
      pipeline_length = pipeline_length pipeline;
      last_validated_head = Block_header.hash last_validated_head;
      last_advertised_head = Block_header.hash last_advertised_head;
    }
end

module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
open Types

type t = Worker.dropbox Worker.t

let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))

let set_bootstrapped pv =
  if not pv.bootstrapped then (
    pv.bootstrapped <- true ;
    pv.parameters.notify_bootstrapped () )

let bootstrap_new_branch w _head unknown_prefix =
  let pv = Worker.state w in
  let sender_id = Distributed_db.my_peer_id pv.parameters.chain_db in
  (* sender and receiver are inverted here because they are from
     the point of view of the node sending the locator *)
  let seed = {Block_locator.sender_id = pv.peer_id; receiver_id = sender_id} in
  let len = Block_locator.estimated_length seed unknown_prefix in
  debug
    w
    "validating new branch from peer %a (approx. %d blocks)"
    P2p_peer.Id.pp_short
    pv.peer_id
    len ;
  let pipeline =
    Bootstrap_pipeline.create
      ~notify_new_block:pv.parameters.notify_new_block
      ~block_header_timeout:pv.parameters.limits.block_header_timeout
      ~block_operations_timeout:pv.parameters.limits.block_operations_timeout
      pv.parameters.block_validator
      pv.peer_id
      pv.parameters.chain_db
      unknown_prefix
  in
  pv.pipeline <- Some pipeline ;
  Worker.protect
    w
    ~on_error:(fun error ->
      (* if the peer_validator is killed, let's cancel the pipeline *)
      pv.pipeline <- None ;
      Bootstrap_pipeline.cancel pipeline >>= fun () -> Lwt.return_error error)
    (fun () -> Bootstrap_pipeline.wait pipeline)
  >>=? fun () ->
  pv.pipeline <- None ;
  set_bootstrapped pv ;
  debug
    w
    "done validating new branch from peer %a."
    P2p_peer.Id.pp_short
    pv.peer_id ;
  return_unit

let validate_new_head w hash (header : Block_header.t) =
  let pv = Worker.state w in
  debug
    w
    "fetching operations for new head %a from peer %a"
    Block_hash.pp_short
    hash
    P2p_peer.Id.pp_short
    pv.peer_id ;
  map_p
    (fun i ->
      Worker.protect w (fun () ->
          Distributed_db.Operations.fetch
            ~timeout:pv.parameters.limits.block_operations_timeout
            pv.parameters.chain_db
            ~peer:pv.peer_id
            (hash, i)
            header.shell.operations_hash))
    (0 -- (header.shell.validation_passes - 1))
  >>=? fun operations ->
  debug
    w
    "requesting validation for new head %a from peer %a"
    Block_hash.pp_short
    hash
    P2p_peer.Id.pp_short
    pv.peer_id ;
  Block_validator.validate
    ~notify_new_block:pv.parameters.notify_new_block
    pv.parameters.block_validator
    pv.parameters.chain_db
    hash
    header
    operations
  >>=? fun _block ->
  debug
    w
    "end of validation for new head %a from peer %a"
    Block_hash.pp_short
    hash
    P2p_peer.Id.pp_short
    pv.peer_id ;
  set_bootstrapped pv ;
  let meta =
    Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id
  in
  Peer_metadata.incr meta Valid_blocks ;
  return_unit

let only_if_fitness_increases w distant_header cont =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  Chain.head chain_state
  >>= fun local_header ->
  if
    Fitness.compare
      distant_header.Block_header.shell.fitness
      (State.Block.fitness local_header)
    <= 0
  then (
    set_bootstrapped pv ;
    debug
      w
      "ignoring head %a with non increasing fitness from peer: %a."
      Block_hash.pp_short
      (Block_header.hash distant_header)
      P2p_peer.Id.pp_short
      pv.peer_id ;
    (* Don't download a branch that cannot beat the current head. *)
    let meta =
      Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id
    in
    Peer_metadata.incr meta Old_heads ;
    return_unit )
  else cont ()

let assert_acceptable_head w hash (header : Block_header.t) =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  State.Chain.acceptable_block chain_state header
  >>= fun acceptable ->
  fail_unless
    acceptable
    (Validation_errors.Checkpoint_error (hash, Some pv.peer_id))

let may_validate_new_head w hash (header : Block_header.t) =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  State.Block.known_valid chain_state hash
  >>= fun valid_block ->
  State.Block.known_invalid chain_state hash
  >>= fun invalid_block ->
  State.Block.known_valid chain_state header.shell.predecessor
  >>= fun valid_predecessor ->
  State.Block.known_invalid chain_state header.shell.predecessor
  >>= fun invalid_predecessor ->
  if valid_block then (
    debug
      w
      "ignoring previously validated block %a from peer %a"
      Block_hash.pp_short
      hash
      P2p_peer.Id.pp_short
      pv.peer_id ;
    set_bootstrapped pv ;
    pv.last_validated_head <- header ;
    return_unit )
  else if invalid_block then (
    debug
      w
      "ignoring known invalid block %a from peer %a"
      Block_hash.pp_short
      hash
      P2p_peer.Id.pp_short
      pv.peer_id ;
    fail Validation_errors.Known_invalid )
  else if invalid_predecessor then (
    debug
      w
      "ignoring known invalid block %a from peer %a"
      Block_hash.pp_short
      hash
      P2p_peer.Id.pp_short
      pv.peer_id ;
    Distributed_db.commit_invalid_block
      pv.parameters.chain_db
      hash
      header
      [Validation_errors.Known_invalid]
    >>=? fun _ -> fail Validation_errors.Known_invalid )
  else if not valid_predecessor then (
    debug
      w
      "missing predecessor for new head %a from peer %a"
      Block_hash.pp_short
      hash
      P2p_peer.Id.pp_short
      pv.peer_id ;
    Distributed_db.Request.current_branch
      pv.parameters.chain_db
      ~peer:pv.peer_id
      () ;
    return_unit )
  else
    only_if_fitness_increases w header
    @@ fun () ->
    assert_acceptable_head w hash header
    >>=? fun () -> validate_new_head w hash header

let may_validate_new_branch w distant_hash locator =
  let pv = Worker.state w in
  let (distant_header, _) =
    (locator : Block_locator.t :> Block_header.t * _)
  in
  only_if_fitness_increases w distant_header
  @@ fun () ->
  assert_acceptable_head w (Block_header.hash distant_header) distant_header
  >>=? fun () ->
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  State.Block.known_ancestor chain_state locator
  >>= function
  | None ->
      debug
        w
        "ignoring branch %a without common ancestor from peer: %a."
        Block_hash.pp_short
        distant_hash
        P2p_peer.Id.pp_short
        pv.peer_id ;
      fail Validation_errors.Unknown_ancestor
  | Some unknown_prefix ->
      let (_, history) = Block_locator.raw unknown_prefix in
      if history <> [] then
        bootstrap_new_branch w distant_header unknown_prefix
      else return_unit

let on_no_request w =
  let pv = Worker.state w in
  debug
    w
    "no new head from peer %a for %g seconds."
    P2p_peer.Id.pp_short
    pv.peer_id
    (Ptime.Span.to_float_s pv.parameters.limits.new_head_request_timeout) ;
  Distributed_db.Request.current_head
    pv.parameters.chain_db
    ~peer:pv.peer_id
    () ;
  return_unit

let on_request (type a) w (req : a Request.t) : a tzresult Lwt.t =
  let pv = Worker.state w in
  match req with
  | Request.New_head (hash, header) ->
      debug
        w
        "processing new head %a from peer %a."
        Block_hash.pp_short
        hash
        P2p_peer.Id.pp_short
        pv.peer_id ;
      may_validate_new_head w hash header
  | Request.New_branch (hash, locator, _seed) ->
      (* TODO penalize empty locator... ?? *)
      debug
        w
        "processing new branch %a from peer %a."
        Block_hash.pp_short
        hash
        P2p_peer.Id.pp_short
        pv.peer_id ;
      may_validate_new_branch w hash locator

let on_completion w r _ st =
  Worker.record_event w (Event.Request (Request.view r, st, None)) ;
  Lwt.return_unit

let on_error w r st err =
  let pv = Worker.state w in
  match err with
  | ( Validation_errors.Unknown_ancestor
    | Validation_errors.Invalid_locator _
    | Block_validator_errors.Invalid_block _ )
    :: _ as errors ->
      Distributed_db.greylist pv.parameters.chain_db pv.peer_id
      >>= fun () ->
      debug
        w
        "Terminating the validation worker for peer %a (kickban)."
        P2p_peer.Id.pp_short
        pv.peer_id ;
      debug w "%a" Error_monad.pp_print_error errors ;
      Worker.trigger_shutdown w ;
      Worker.record_event w (Event.Request (r, st, Some err)) ;
      Lwt.return_error err
  | Block_validator_errors.System_error _ :: _ ->
      Worker.record_event w (Event.Request (r, st, Some err)) ;
      return_unit
  | Block_validator_errors.Unavailable_protocol {protocol; _} :: _ -> (
      Block_validator.fetch_and_compile_protocol
        pv.parameters.block_validator
        ~peer:pv.peer_id
        ~timeout:pv.parameters.limits.protocol_timeout
        protocol
      >>= function
      | Ok _ ->
          Distributed_db.Request.current_head
            pv.parameters.chain_db
            ~peer:pv.peer_id
            () ;
          return_unit
      | Error _ ->
          (* TODO: punish *)
          debug
            w
            "Terminating the validation worker for peer %a (missing protocol \
             %a)."
            P2p_peer.Id.pp_short
            pv.peer_id
            Protocol_hash.pp_short
            protocol ;
          Worker.record_event w (Event.Request (r, st, Some err)) ;
          Lwt.return_error err )
  | Validation_errors.Too_short_locator _ :: _ ->
      debug
        w
        "Terminating the validation worker for peer %a (kick)."
        P2p_peer.Id.pp_short
        pv.peer_id ;
      Worker.trigger_shutdown w ;
      Worker.record_event w (Event.Request (r, st, Some err)) ;
      return_unit
  | _ ->
      Worker.record_event w (Event.Request (r, st, Some err)) ;
      Lwt.return_error err

let on_close w =
  let pv = Worker.state w in
  Distributed_db.disconnect pv.parameters.chain_db pv.peer_id
  >>= fun () ->
  pv.parameters.notify_termination () ;
  Lwt.return_unit

let on_launch _ name parameters =
  let chain_state = Distributed_db.chain_state parameters.chain_db in
  State.Block.read_opt chain_state (State.Chain.genesis chain_state).block
  >|= Option.unopt_assert ~loc:__POS__
  >>= fun genesis ->
  let rec pv =
    {
      peer_id = snd name;
      parameters = {parameters with notify_new_block};
      bootstrapped = false;
      pipeline = None;
      last_validated_head = State.Block.header genesis;
      last_advertised_head = State.Block.header genesis;
    }
  and notify_new_block block =
    pv.last_validated_head <- State.Block.header block ;
    parameters.notify_new_block block
  in
  return pv

let table =
  let merge w (Worker.Any_request neu) old =
    let pv = Worker.state w in
    match neu with
    | Request.New_branch (_, locator, _) ->
        let (header, _) = (locator : Block_locator.t :> _ * _) in
        pv.last_advertised_head <- header ;
        Some (Worker.Any_request neu)
    | Request.New_head (_, header) -> (
        pv.last_advertised_head <- header ;
        (* TODO penalize decreasing fitness *)
        match old with
        | Some (Worker.Any_request (Request.New_branch _) as old) ->
            Some old (* ignore *)
        | Some (Worker.Any_request (Request.New_head _)) ->
            Some (Any_request neu)
        | None ->
            Some (Any_request neu) )
  in
  Worker.create_table (Dropbox {merge})

let create ?(notify_new_block = fun _ -> ())
    ?(notify_bootstrapped = fun () -> ()) ?(notify_termination = fun _ -> ())
    limits block_validator chain_db peer_id =
  let name = (State.Chain.id (Distributed_db.chain_state chain_db), peer_id) in
  let parameters =
    {
      chain_db;
      notify_termination;
      block_validator;
      notify_new_block;
      notify_bootstrapped;
      limits;
    }
  in
  let module Handlers = struct
    type self = t

    let on_launch = on_launch

    let on_request = on_request

    let on_close = on_close

    let on_error = on_error

    let on_completion = on_completion

    let on_no_request = on_no_request
  end in
  Worker.launch
    table
    ~timeout:limits.new_head_request_timeout
    limits.worker_limits
    name
    parameters
    (module Handlers)

let notify_branch w locator =
  let (header, _) = (locator : Block_locator.t :> _ * _) in
  let hash = Block_header.hash header in
  let pv = Worker.state w in
  let sender_id = Distributed_db.my_peer_id pv.parameters.chain_db in
  (* sender and receiver are inverted here because they are from
     the point of view of the node sending the locator *)
  let seed = {Block_locator.sender_id = pv.peer_id; receiver_id = sender_id} in
  Worker.Dropbox.put_request w (New_branch (hash, locator, seed))

let notify_head w header =
  let hash = Block_header.hash header in
  Worker.Dropbox.put_request w (New_head (hash, header))

let shutdown w = Worker.shutdown w

let peer_id w =
  let pv = Worker.state w in
  pv.peer_id

let bootstrapped w =
  let pv = Worker.state w in
  pv.bootstrapped

let current_head w =
  let pv = Worker.state w in
  pv.last_validated_head

let status = Worker.status

let information = Worker.information

let running_workers () = Worker.list table

let current_request t = Worker.current_request t

let last_events = Worker.last_events

let pipeline_length w =
  let state = Worker.state w in
  Types.pipeline_length state.pipeline
src/lib_shell/peer_validator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.Peer_validator_worker_state.

Module Name.
  Definition t :=
    Tezos_base__TzPervasives.Chain_id.t * Tezos_base__TzPervasives.P2p_peer.Id.t.
  
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (Tezos_base__TzPervasives.Chain_id.t *
        Tezos_base__TzPervasives.P2p_peer.Id.t) :=
    Tezos_base__TzPervasives.Data_encoding.tup2
      Tezos_base__TzPervasives.Chain_id.encoding
      Tezos_base__TzPervasives.P2p_peer.Id.encoding.
  
  Definition base : list string :=
    cons "validator" % string (cons "peer" % string []).
  
  Definition pp
    (ppf : Stdlib.Format.formatter)
    (function_parameter :
      Tezos_base__TzPervasives.Chain_id.t *
        Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
    match function_parameter with
    | (chain, peer) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal ":" % char
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))) "%a:%a" % string)
        Tezos_base__TzPervasives.Chain_id.pp_short chain
        Tezos_base__TzPervasives.P2p_peer.Id.pp_short peer
    end.
End Name.

Module Request.
  Inductive t : forall (_ : Type), Type :=
  | New_head : Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Block_header.t -> t unit
  | New_branch : Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Block_locator.t ->
    Tezos_base__TzPervasives.Block_locator.seed -> t unit.
  
  Definition view {A : Type} (req : t A) : view :=
    match req with
    | New_head hash _ => New_head hash
    | New_branch hash locator seed =>
      New_branch hash
        (Tezos_base__TzPervasives.Block_locator.estimated_length seed locator)
    end.
End Request.

Record limits := {
  new_head_request_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  block_header_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  block_operations_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  protocol_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module Types.
  Record parameters := {
    chain_db : Tezos_shell.Distributed_db.chain_db;
    block_validator : Tezos_shell.Block_validator.t;
    notify_new_block : Tezos_shell.State.Block.t -> unit;
    notify_bootstrapped : unit -> unit;
    notify_termination : unit -> unit;
    limits : limits }.
  
  Record state := {
    peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
    parameters : parameters;
    bootstrapped : bool;
    pipeline : option Tezos_shell.Bootstrap_pipeline.t;
    last_validated_head : Tezos_base__TzPervasives.Block_header.t;
    last_advertised_head : Tezos_base__TzPervasives.Block_header.t }.
  
  Definition pipeline_length
    (function_parameter : option Tezos_shell.Bootstrap_pipeline.t)
    : Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
    match function_parameter with
    | None => Tezos_shell.Bootstrap_pipeline.length_zero
    | Some p => Tezos_shell.Bootstrap_pipeline.length p
    end.
  
  Definition view {A : Type} (state : state) (function_parameter : A) : view :=
    match function_parameter with
    | _ =>
      match state with
      | {|
        bootstrapped := bootstrapped;
          pipeline := pipeline;
          last_validated_head := last_validated_head;
          last_advertised_head := last_advertised_head
          |} =>
        {| bootstrapped := bootstrapped;
          pipeline_length := pipeline_length pipeline;
          last_validated_head :=
            Tezos_base__TzPervasives.Block_header.hash last_validated_head;
          last_advertised_head :=
            Tezos_base__TzPervasives.Block_header.hash last_advertised_head |}
      end
    end.
End Types.

Import Types.

Definition t := Worker.t Worker.dropbox.

Definition debug {A B : Type} (w : Worker.t A)
  : (Stdlib.format4 B Stdlib.Format.formatter unit unit) -> B :=
  Stdlib.Format.kasprintf (fun msg => Worker.record_event w (Debug msg)).

Definition set_bootstrapped (pv : Types.state) : unit :=
  if negb (bootstrapped pv) then
    set_field;
    (notify_bootstrapped (parameters pv)) tt
  else
    tt.

Definition bootstrap_new_branch {A B : Type}
  (w : Worker.t A) (_head : B)
  (unknown_prefix : Tezos_base__TzPervasives.Block_locator.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let sender_id :=
    Tezos_shell.Distributed_db.my_peer_id (chain_db (parameters pv)) in
  let seed :=
    {| Block_locator.sender_id := peer_id pv;
      Block_locator.receiver_id := sender_id |} in
  let len :=
    Tezos_base__TzPervasives.Block_locator.estimated_length seed unknown_prefix
    in
  debug w
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal
        "validating new branch from peer " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal " (approx. " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " blocks)" % string
                CamlinternalFormatBasics.End_of_format)))))
      "validating new branch from peer %a (approx. %d blocks)" % string)
    Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv) len;
  let pipeline :=
    Tezos_shell.Bootstrap_pipeline.create
      (Some (notify_new_block (parameters pv)))
      (block_header_timeout (limits (parameters pv)))
      (block_operations_timeout (limits (parameters pv)))
      (block_validator (parameters pv)) (peer_id pv) (chain_db (parameters pv))
      unknown_prefix in
  set_field;
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Worker.protect w
      (Some
        (fun error =>
          set_field;
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.Bootstrap_pipeline.cancel pipeline)
            (fun function_parameter =>
              match function_parameter with
              | tt => Lwt.return_error error
              end)))
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_shell.Bootstrap_pipeline.wait pipeline
        end))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        set_field;
        set_bootstrapped pv;
        debug w
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "done validating new branch from peer " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  CamlinternalFormatBasics.End_of_format)))
            "done validating new branch from peer %a." % string)
          Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv);
        Tezos_base__TzPervasives.return_unit
      end).

Definition validate_new_head {A : Type}
  (w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  debug w
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal
        "fetching operations for new head " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal " from peer " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))))
      "fetching operations for new head %a from peer %a" % string)
    Tezos_base__TzPervasives.Block_hash.pp_short hash
    Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv);
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.map_p
      (fun i =>
        Worker.protect w None
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_shell.Distributed_db.Operations.fetch
                (chain_db (parameters pv)) (Some (peer_id pv))
                (Some (block_operations_timeout (limits (parameters pv))))
                (hash, i) (operations_hash (shell header))
            end))
      (Tezos_base__TzPervasives.op_minus_minus 0
        (Z.sub (validation_passes (shell header)) 1)))
    (fun operations =>
      debug w
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "requesting validation for new head " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " from peer " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))))
          "requesting validation for new head %a from peer %a" % string)
        Tezos_base__TzPervasives.Block_hash.pp_short hash
        Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv);
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.Block_validator.validate (block_validator (parameters pv))
          None None (Some (notify_new_block (parameters pv)))
          (chain_db (parameters pv)) hash header operations)
        (fun _block =>
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "end of validation for new head " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " from peer " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))
              "end of validation for new head %a from peer %a" % string)
            Tezos_base__TzPervasives.Block_hash.pp_short hash
            Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv);
          set_bootstrapped pv;
          let meta :=
            Tezos_shell.Distributed_db.get_peer_metadata
              (chain_db (parameters pv)) (peer_id pv) in
          Tezos_shell_services.Peer_metadata.incr meta Valid_blocks;
          Tezos_base__TzPervasives.return_unit)).

Definition only_if_fitness_increases {A : Type}
  (w : Worker.t A) (distant_header : Tezos_base__TzPervasives.Block_header.t)
  (cont : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let chain_state :=
    Tezos_shell.Distributed_db.chain_state (chain_db (parameters pv)) in
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.head chain_state)
    (fun local_header =>
      if
        OCaml.Stdlib.le
          (Tezos_base__TzPervasives.Fitness.compare
            (fitness (Block_header.shell distant_header))
            (Tezos_shell.State.Block.fitness local_header)) 0 then
        set_bootstrapped pv;
        debug w
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "ignoring head " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  " with non increasing fitness from peer: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal "." % char
                      CamlinternalFormatBasics.End_of_format)))))
            "ignoring head %a with non increasing fitness from peer: %a." %
              string) Tezos_base__TzPervasives.Block_hash.pp_short
          (Tezos_base__TzPervasives.Block_header.hash distant_header)
          Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv);
        let meta :=
          Tezos_shell.Distributed_db.get_peer_metadata
            (chain_db (parameters pv)) (peer_id pv) in
        Tezos_shell_services.Peer_metadata.incr meta Old_heads;
        Tezos_base__TzPervasives.return_unit
      else
        cont tt).

Definition assert_acceptable_head {A : Type}
  (w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let chain_state :=
    Tezos_shell.Distributed_db.chain_state (chain_db (parameters pv)) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.acceptable_block chain_state header)
    (fun acceptable =>
      Tezos_base__TzPervasives.fail_unless acceptable
        (Validation_errors.Checkpoint_error hash (Some (peer_id pv)))).

Definition may_validate_new_head {A : Type}
  (w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let chain_state :=
    Tezos_shell.Distributed_db.chain_state (chain_db (parameters pv)) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Block.known_valid chain_state hash)
    (fun valid_block =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.known_invalid chain_state hash)
        (fun invalid_block =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.known_valid chain_state
              (predecessor (shell header)))
            (fun valid_predecessor =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.State.Block.known_invalid chain_state
                  (predecessor (shell header)))
                (fun invalid_predecessor =>
                  if valid_block then
                    debug w
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "ignoring previously validated block " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " from peer " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))))
                        "ignoring previously validated block %a from peer %a" %
                          string) Tezos_base__TzPervasives.Block_hash.pp_short
                      hash Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                      (peer_id pv);
                    set_bootstrapped pv;
                    set_field;
                    Tezos_base__TzPervasives.return_unit
                  else
                    if invalid_block then
                      debug w
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "ignoring known invalid block " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " from peer " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))))
                          "ignoring known invalid block %a from peer %a" %
                            string) Tezos_base__TzPervasives.Block_hash.pp_short
                        hash Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                        (peer_id pv);
                      Tezos_base__TzPervasives.fail
                        Validation_errors.Known_invalid
                    else
                      if invalid_predecessor then
                        debug w
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "ignoring known invalid block " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " from peer " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))))
                            "ignoring known invalid block %a from peer %a" %
                              string)
                          Tezos_base__TzPervasives.Block_hash.pp_short hash
                          Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                          (peer_id pv);
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_shell.Distributed_db.commit_invalid_block
                            (chain_db (parameters pv)) hash header
                            (cons Validation_errors.Known_invalid []))
                          (fun function_parameter =>
                            match function_parameter with
                            | _ =>
                              Tezos_base__TzPervasives.fail
                                Validation_errors.Known_invalid
                            end)
                      else
                        if negb valid_predecessor then
                          debug w
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "missing predecessor for new head " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " from peer " % string
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format))))
                              "missing predecessor for new head %a from peer %a"
                                % string)
                            Tezos_base__TzPervasives.Block_hash.pp_short hash
                            Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                            (peer_id pv);
                          Tezos_shell.Distributed_db.Request.current_branch
                            (chain_db (parameters pv)) (Some (peer_id pv)) tt;
                          Tezos_base__TzPervasives.return_unit
                        else
                          apply (only_if_fitness_increases w header)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (assert_acceptable_head w hash header)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => validate_new_head w hash header
                                    end)
                              end))))).

Definition may_validate_new_branch {A : Type}
  (w : Worker.t A) (distant_hash : Tezos_base__TzPervasives.Block_hash.t)
  (locator : Tezos_base__TzPervasives.Block_locator.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  match locator with
  | (distant_header, _) =>
    apply (only_if_fitness_increases w distant_header)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (assert_acceptable_head w
              (Tezos_base__TzPervasives.Block_header.hash distant_header)
              distant_header)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let chain_state :=
                  Tezos_shell.Distributed_db.chain_state
                    (chain_db (parameters pv)) in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Block.known_ancestor chain_state locator)
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      debug w
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "ignoring branch " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " without common ancestor from peer: " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    "." % char
                                    CamlinternalFormatBasics.End_of_format)))))
                          "ignoring branch %a without common ancestor from peer: %a."
                            % string)
                        Tezos_base__TzPervasives.Block_hash.pp_short
                        distant_hash
                        Tezos_base__TzPervasives.P2p_peer.Id.pp_short
                        (peer_id pv);
                      Tezos_base__TzPervasives.fail
                        Validation_errors.Unknown_ancestor
                    | Some unknown_prefix =>
                      match
                        Tezos_base__TzPervasives.Block_locator.raw
                          unknown_prefix with
                      | (_, history) =>
                        if nequiv_decb history [] then
                          bootstrap_new_branch w distant_header unknown_prefix
                        else
                          Tezos_base__TzPervasives.return_unit
                      end
                    end)
              end)
        end)
  end.

Definition on_no_request {A : Type} (w : Worker.t A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  debug w
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "no new head from peer " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal " for " % string
            (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_g
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " seconds." % string
                CamlinternalFormatBasics.End_of_format)))))
      "no new head from peer %a for %g seconds." % string)
    Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv)
    (Ptime.Span.to_float_s (new_head_request_timeout (limits (parameters pv))));
  Tezos_shell.Distributed_db.Request.current_head (chain_db (parameters pv))
    (Some (peer_id pv)) tt;
  Tezos_base__TzPervasives.return_unit.

Definition on_request {A B : Type} (w : Worker.t A) (req : Request.t B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  let pv := Worker.state w in
  match req with
  | Request.New_head hash header =>
    debug w
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "processing new head " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " from peer " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  CamlinternalFormatBasics.End_of_format)))))
        "processing new head %a from peer %a." % string)
      Tezos_base__TzPervasives.Block_hash.pp_short hash
      Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv);
    may_validate_new_head w hash header
  | Request.New_branch hash locator _seed =>
    debug w
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "processing new branch " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " from peer " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  CamlinternalFormatBasics.End_of_format)))))
        "processing new branch %a from peer %a." % string)
      Tezos_base__TzPervasives.Block_hash.pp_short hash
      Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv);
    may_validate_new_branch w hash locator
  end.

Definition on_completion {A B C : Type}
  (w : Worker.t A) (r : Request.t B) (function_parameter : C)
  : Tezos_shell_services.Worker_types.request_status -> Lwt.t unit :=
  match function_parameter with
  | _ =>
    fun st =>
      Worker.record_event w (Event.Request ((Request.view r), st, None));
      Lwt.return_unit
  end.

Definition on_error {A : Type}
  (w : Worker.t A)
  (r : Tezos_shell_services__Peer_validator_worker_state.Request.view)
  (st : Tezos_shell_services.Worker_types.request_status)
  (err : list Tezos_base__TzPervasives.error)
  : Lwt.t (Result.result unit (list Tezos_base__TzPervasives.error)) :=
  let pv := Worker.state w in
  match err with
  |
    (cons
      (Validation_errors.Unknown_ancestor |
        Validation_errors.Invalid_locator _ _ |
        Block_validator_errors.Invalid_block _) _) as errors =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Distributed_db.greylist (chain_db (parameters pv))
        (peer_id pv))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Terminating the validation worker for peer " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " (kickban)." % string
                    CamlinternalFormatBasics.End_of_format)))
              "Terminating the validation worker for peer %a (kickban)." %
                string) Tezos_base__TzPervasives.P2p_peer.Id.pp_short
            (peer_id pv);
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Tezos_base__TzPervasives.Error_monad.pp_print_error errors;
          Worker.trigger_shutdown w;
          Worker.record_event w (Event.Request (r, st, (Some err)));
          Lwt.return_error err
        end)
  | cons (Block_validator_errors.System_error _) _ =>
    Worker.record_event w (Event.Request (r, st, (Some err)));
    Tezos_base__TzPervasives.return_unit
  |
    cons
      (Block_validator_errors.Unavailable_protocol {| protocol := protocol |}) _
    =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Block_validator.fetch_and_compile_protocol
        (block_validator (parameters pv)) (Some (peer_id pv))
        (Some (protocol_timeout (limits (parameters pv)))) protocol)
      (fun function_parameter =>
        match function_parameter with
        | inl _ =>
          Tezos_shell.Distributed_db.Request.current_head
            (chain_db (parameters pv)) (Some (peer_id pv)) tt;
          Tezos_base__TzPervasives.return_unit
        | inr _ =>
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Terminating the validation worker for peer " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " (missing protocol " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal ")." % string
                        CamlinternalFormatBasics.End_of_format)))))
              "Terminating the validation worker for peer %a (missing protocol %a)."
                % string) Tezos_base__TzPervasives.P2p_peer.Id.pp_short
            (peer_id pv) Tezos_base__TzPervasives.Protocol_hash.pp_short
            protocol;
          Worker.record_event w (Event.Request (r, st, (Some err)));
          Lwt.return_error err
        end)
  | cons (Validation_errors.Too_short_locator _ _) _ =>
    debug w
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Terminating the validation worker for peer " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " (kick)." % string
              CamlinternalFormatBasics.End_of_format)))
        "Terminating the validation worker for peer %a (kick)." % string)
      Tezos_base__TzPervasives.P2p_peer.Id.pp_short (peer_id pv);
    Worker.trigger_shutdown w;
    Worker.record_event w (Event.Request (r, st, (Some err)));
    Tezos_base__TzPervasives.return_unit
  | _ =>
    Worker.record_event w (Event.Request (r, st, (Some err)));
    Lwt.return_error err
  end.

Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
  let pv := Worker.state w in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.Distributed_db.disconnect (chain_db (parameters pv))
      (peer_id pv))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        (notify_termination (parameters pv)) tt;
        Lwt.return_unit
      end).

Definition on_launch {A B : Type} (function_parameter : A)
  : (B * Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    Types.parameters -> Lwt.t (Tezos_base__TzPervasives.tzresult Types.state) :=
  match function_parameter with
  | _ =>
    fun name =>
      fun parameters =>
        let chain_state :=
          Tezos_shell.Distributed_db.chain_state (chain_db parameters) in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_base__TzPervasives.op_gt_pipe_eq
            (Tezos_shell.State.Block.read_opt chain_state
              (block (Tezos_shell.State.Chain.genesis chain_state)))
            (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
          (fun genesis =>
            let fix pv : Types.state :=
              {| peer_id := snd name; parameters := record;
                bootstrapped := false; pipeline := None;
                last_validated_head := Tezos_shell.State.Block.header genesis;
                last_advertised_head := Tezos_shell.State.Block.header genesis
                |}
            with notify_new_block (block : Tezos_shell.State.Block.t) : unit :=
              set_field;
              (notify_new_block parameters) block in
            Tezos_base__TzPervasives._return pv)
  end.

Definition table : Worker.table Worker.dropbox :=
  let merge {A : Type}
    (w : Worker.t A) (function_parameter : Worker.any_request)
    : (option Worker.any_request) -> option Worker.any_request :=
    match function_parameter with
    | Worker.Any_request neu =>
      fun old =>
        let pv := Worker.state w in
        match neu with
        | Request.New_branch _ locator _ =>
          match locator with
          | (header, _) =>
            set_field;
            Some (Worker.Any_request neu)
          end
        | Request.New_head _ header =>
          set_field;
          match old with
          | Some ((Worker.Any_request (Request.New_branch _ _ _)) as old) =>
            Some old
          | Some (Worker.Any_request (Request.New_head _ _)) =>
            Some (Any_request neu)
          | None => Some (Any_request neu)
          end
        end
    end in
  Worker.create_table (Dropbox {| merge := merge |}).

Definition create
  (op_star_o_p_t_star : option (Tezos_shell.State.Block.t -> unit))
  : (option (unit -> unit)) ->
    (option (unit -> unit)) ->
      limits ->
        Tezos_shell.Block_validator.t ->
          Tezos_shell.Distributed_db.chain_db ->
            Tezos_base__TzPervasives.P2p_peer.Id.t ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult (Worker.t Worker.dropbox)) :=
  let notify_new_block :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => tt
        end
    end in
  fun op_star_o_p_t_star =>
    let notify_bootstrapped :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None =>
        fun function_parameter =>
          match function_parameter with
          | tt => tt
          end
      end in
    fun op_star_o_p_t_star =>
      let notify_termination :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None =>
          fun function_parameter =>
            match function_parameter with
            | _ => tt
            end
        end in
      fun limits =>
        fun block_validator =>
          fun chain_db =>
            fun peer_id =>
              let name :=
                ((Tezos_shell.State.Chain.id
                  (Tezos_shell.Distributed_db.chain_state chain_db)), peer_id)
                in
              let parameters :=
                {| chain_db := chain_db; block_validator := block_validator;
                  notify_new_block := notify_new_block;
                  notify_bootstrapped := notify_bootstrapped;
                  notify_termination := notify_termination; limits := limits |}
                in
              let Handlers :=
                existT _ unit
                  {|
                    
                    |} in
              Worker.launch table (Some (new_head_request_timeout limits))
                (worker_limits limits) name parameters Handlers.

Definition notify_branch
  (w : Worker.t Worker.dropbox)
  (locator : Tezos_base__TzPervasives.Block_locator.t) : unit :=
  match locator with
  | (header, _) =>
    let hash := Tezos_base__TzPervasives.Block_header.hash header in
    let pv := Worker.state w in
    let sender_id :=
      Tezos_shell.Distributed_db.my_peer_id (chain_db (parameters pv)) in
    let seed :=
      {| Block_locator.sender_id := peer_id pv;
        Block_locator.receiver_id := sender_id |} in
    Worker.Dropbox.put_request w (New_branch hash locator seed)
  end.

Definition notify_head
  (w : Worker.t Worker.dropbox)
  (header : Tezos_base__TzPervasives.Block_header.t) : unit :=
  let hash := Tezos_base__TzPervasives.Block_header.hash header in
  Worker.Dropbox.put_request w (New_head hash header).

Definition shutdown {A : Type} (w : Worker.t A) : Lwt.t unit :=
  Worker.shutdown w.

Definition peer_id {A : Type} (w : Worker.t A)
  : Tezos_base__TzPervasives.P2p_peer.Id.t :=
  let pv := Worker.state w in
  peer_id pv.

Definition bootstrapped {A : Type} (w : Worker.t A) : bool :=
  let pv := Worker.state w in
  bootstrapped pv.

Definition current_head {A : Type} (w : Worker.t A)
  : Tezos_base__TzPervasives.Block_header.t :=
  let pv := Worker.state w in
  last_validated_head pv.

Definition status {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
  Worker.status.

Definition information {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_information :=
  Worker.information.

Definition running_workers (function_parameter : unit)
  : list (Worker.Name.t * (Worker.t Worker.dropbox)) :=
  match function_parameter with
  | tt => Worker.list table
  end.

Definition current_request {A : Type} (t : Worker.t A)
  : option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
  Worker.current_request t.

Definition last_events {A : Type}
  : (Worker.t A) ->
    list (Tezos_base__TzPervasives.Internal_event.level * (list Worker.Event.t)) :=
  Worker.last_events.

Definition pipeline_length {A : Type} (w : Worker.t A)
  : Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
  let state := Worker.state w in
  Types.pipeline_length (pipeline state).
src/lib_shell/peer_validator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type limits = {
  new_head_request_timeout : Time.System.Span.t;
  block_header_timeout : Time.System.Span.t;
  block_operations_timeout : Time.System.Span.t;
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

val peer_id : t -> P2p_peer.Id.t

val bootstrapped : t -> bool

val current_head : t -> Block_header.t

val create :
  ?notify_new_block:(State.Block.t -> unit) ->
  ?notify_bootstrapped:(unit -> unit) ->
  ?notify_termination:(unit -> unit) ->
  limits ->
  Block_validator.t ->
  Distributed_db.chain_db ->
  P2p_peer.Id.t ->
  t tzresult Lwt.t

val shutdown : t -> unit Lwt.t

val notify_branch : t -> Block_locator.t -> unit

val notify_head : t -> Block_header.t -> unit

val running_workers : unit -> ((Chain_id.t * P2p_peer.Id.t) * t) list

val status : t -> Worker_types.worker_status

val information : t -> Worker_types.worker_information

val current_request :
  t ->
  (Time.System.t * Time.System.t * Peer_validator_worker_state.Request.view)
  option

val last_events :
  t -> (Internal_event.level * Peer_validator_worker_state.Event.t list) list

val pipeline_length :
  t -> Peer_validator_worker_state.Worker_state.pipeline_length
src/lib_shell/peer_validator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Record limits := {
  new_head_request_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  block_header_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  block_operations_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  protocol_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Parameter peer_id : t -> Tezos_base__TzPervasives.P2p_peer.Id.t.

Parameter bootstrapped : t -> bool.

Parameter current_head : t -> Tezos_base__TzPervasives.Block_header.t.

Parameter create :
(option (Tezos_shell.State.Block.t -> unit)) ->
  (option (unit -> unit)) ->
    (option (unit -> unit)) ->
      limits ->
        Tezos_shell.Block_validator.t ->
          Tezos_shell.Distributed_db.chain_db ->
            Tezos_base__TzPervasives.P2p_peer.Id.t ->
              Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter shutdown : t -> Lwt.t unit.

Parameter notify_branch : t -> Tezos_base__TzPervasives.Block_locator.t -> unit.

Parameter notify_head : t -> Tezos_base__TzPervasives.Block_header.t -> unit.

Parameter running_workers :
unit ->
  list
    ((Tezos_base__TzPervasives.Chain_id.t *
      Tezos_base__TzPervasives.P2p_peer.Id.t) * t).

Parameter status : t -> Tezos_shell_services.Worker_types.worker_status.

Parameter information :
t -> Tezos_shell_services.Worker_types.worker_information.

Parameter current_request :
t ->
  option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Peer_validator_worker_state.Request.view).

Parameter last_events :
t ->
  list
    (Tezos_base__TzPervasives.Internal_event.level *
      (list Tezos_shell_services.Peer_validator_worker_state.Event.t)).

Parameter pipeline_length :
t ->
  Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length.
src/lib_shell/prevalidation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Validation_errors

module type T = sig
  module Proto : Registered_protocol.T

  type t

  type operation = private {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  val compare : operation -> operation -> int

  val parse : Operation.t -> operation tzresult

  (** Creates a new prevalidation context w.r.t. the protocol associate to the
      predecessor block . When ?protocol_data is passed to this function, it will
      be used to create the new block *)
  val create :
    ?protocol_data:Bytes.t ->
    predecessor:State.Block.t ->
    timestamp:Time.Protocol.t ->
    unit ->
    t tzresult Lwt.t

  type result =
    | Applied of t * Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Outdated

  val apply_operation : t -> operation -> result Lwt.t

  type status = {
    applied_operations : (operation * Proto.operation_receipt) list;
    block_result : Tezos_protocol_environment.validation_result;
    block_metadata : Proto.block_header_metadata;
  }

  val status : t -> status tzresult Lwt.t

  val pp_result : Format.formatter -> result -> unit
end

module Make (Proto : Registered_protocol.T) : T with module Proto = Proto =
struct
  module Proto = Proto

  type operation = {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  type t = {
    state : Proto.validation_state;
    applied : (operation * Proto.operation_receipt) list;
    live_blocks : Block_hash.Set.t;
    live_operations : Operation_hash.Set.t;
  }

  type result =
    | Applied of t * Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Outdated

  let parse (raw : Operation.t) =
    let hash = Operation.hash raw in
    let size = Data_encoding.Binary.length Operation.encoding raw in
    if size > Proto.max_operation_data_length then
      error (Oversized_operation {size; max = Proto.max_operation_data_length})
    else
      match
        Data_encoding.Binary.of_bytes
          Proto.operation_data_encoding
          raw.Operation.proto
      with
      | None ->
          error Parse_error
      | Some protocol_data ->
          ok {hash; raw; protocol_data}

  let compare op1 op2 =
    Proto.compare_operations
      {shell = op1.raw.shell; protocol_data = op1.protocol_data}
      {shell = op2.raw.shell; protocol_data = op2.protocol_data}

  let create ?protocol_data ~predecessor ~timestamp () =
    (* The prevalidation module receives input from the system byt handles
       protocol values. It translates timestamps here. *)
    let { Block_header.shell =
            { fitness = predecessor_fitness;
              timestamp = predecessor_timestamp;
              level = predecessor_level;
              _ };
          _ } =
      State.Block.header predecessor
    in
    State.Block.context predecessor
    >>=? fun predecessor_context ->
    let predecessor_header = State.Block.header predecessor in
    let predecessor_hash = State.Block.hash predecessor in
    State.Block.max_operations_ttl predecessor
    >>=? fun max_op_ttl ->
    Chain_traversal.live_blocks predecessor max_op_ttl
    >>=? fun (live_blocks, live_operations) ->
    Block_validation.update_testchain_status
      predecessor_context
      predecessor_header
      timestamp
    >>=? fun predecessor_context ->
    ( match protocol_data with
    | None ->
        return_none
    | Some protocol_data -> (
      match
        Data_encoding.Binary.of_bytes
          Proto.block_header_data_encoding
          protocol_data
      with
      | None ->
          failwith "Invalid block header"
      | Some protocol_data ->
          return_some protocol_data ) )
    >>=? fun protocol_data ->
    let predecessor_context =
      Shell_context.wrap_disk_context predecessor_context
    in
    Proto.begin_construction
      ~chain_id:(State.Block.chain_id predecessor)
      ~predecessor_context
      ~predecessor_timestamp
      ~predecessor_fitness
      ~predecessor_level
      ~predecessor:predecessor_hash
      ~timestamp
      ?protocol_data
      ()
    >>=? fun state ->
    (* FIXME arbitrary value, to be customisable *)
    return {state; applied = []; live_blocks; live_operations}

  let apply_operation pv op =
    if Operation_hash.Set.mem op.hash pv.live_operations then
      Lwt.return Outdated
    else
      Proto.apply_operation
        pv.state
        {shell = op.raw.shell; protocol_data = op.protocol_data}
      >|= function
      | Ok (state, receipt) ->
          let pv =
            {
              state;
              applied = (op, receipt) :: pv.applied;
              live_blocks = pv.live_blocks;
              live_operations =
                Operation_hash.Set.add op.hash pv.live_operations;
            }
          in
          Applied (pv, receipt)
      | Error errors -> (
        match classify_errors errors with
        | `Branch ->
            Branch_refused errors
        | `Permanent ->
            Refused errors
        | `Temporary ->
            Branch_delayed errors )

  type status = {
    applied_operations : (operation * Proto.operation_receipt) list;
    block_result : Tezos_protocol_environment.validation_result;
    block_metadata : Proto.block_header_metadata;
  }

  let status pv =
    Proto.finalize_block pv.state
    >>=? fun (block_result, block_metadata) ->
    return {block_metadata; block_result; applied_operations = pv.applied}

  let pp_result ppf =
    let open Format in
    function
    | Applied _ ->
        pp_print_string ppf "applied"
    | Branch_delayed err ->
        fprintf ppf "branch delayed (%a)" pp_print_error err
    | Branch_refused err ->
        fprintf ppf "branch refused (%a)" pp_print_error err
    | Refused err ->
        fprintf ppf "refused (%a)" pp_print_error err
    | Duplicate ->
        pp_print_string ppf "duplicate"
    | Outdated ->
        pp_print_string ppf "outdated"
end

let preapply ~predecessor ~timestamp ~protocol_data operations =
  State.Block.context predecessor
  >>=? fun predecessor_context ->
  Context.get_protocol predecessor_context
  >>= fun protocol ->
  ( match Registered_protocol.get protocol with
  | None ->
      (* FIXME. *)
      (* This should not happen: it should be handled in the validator. *)
      failwith
        "Prevalidation: missing protocol '%a' for the current block."
        Protocol_hash.pp_short
        protocol
  | Some protocol ->
      return protocol )
  >>=? fun (module Proto) ->
  let module Prevalidation = Make (Proto) in
  let apply_operation_with_preapply_result preapp t op =
    let open Preapply_result in
    Prevalidation.apply_operation t op
    >>= function
    | Applied (t, _) ->
        let applied = (op.hash, op.raw) :: preapp.applied in
        Lwt.return ({preapp with applied}, t)
    | Branch_delayed errors ->
        let branch_delayed =
          Operation_hash.Map.add op.hash (op.raw, errors) preapp.branch_delayed
        in
        Lwt.return ({preapp with branch_delayed}, t)
    | Branch_refused errors ->
        let branch_refused =
          Operation_hash.Map.add op.hash (op.raw, errors) preapp.branch_refused
        in
        Lwt.return ({preapp with branch_refused}, t)
    | Refused errors ->
        let refused =
          Operation_hash.Map.add op.hash (op.raw, errors) preapp.refused
        in
        Lwt.return ({preapp with refused}, t)
    | Duplicate | Outdated ->
        Lwt.return (preapp, t)
  in
  Prevalidation.create ~protocol_data ~predecessor ~timestamp ()
  >>=? fun validation_state ->
  Lwt_list.fold_left_s
    (fun (acc_validation_result, acc_validation_state) operations ->
      Lwt_list.fold_left_s
        (fun (acc_validation_result, acc_validation_state) op ->
          match Prevalidation.parse op with
          | Error _ ->
              (* FIXME *)
              Lwt.return (acc_validation_result, acc_validation_state)
          | Ok op ->
              apply_operation_with_preapply_result
                acc_validation_result
                acc_validation_state
                op)
        (Preapply_result.empty, acc_validation_state)
        operations
      >>= fun (new_validation_result, new_validation_state) ->
      (* Applied operations are reverted ; revert to the initial ordering *)
      let new_validation_result =
        {
          new_validation_result with
          applied = List.rev new_validation_result.applied;
        }
      in
      Lwt.return
        (acc_validation_result @ [new_validation_result], new_validation_state))
    ([], validation_state)
    operations
  >>= fun (validation_result_list, validation_state) ->
  let operations_hash =
    Operation_list_list_hash.compute
      (List.map
         (fun r ->
           Operation_list_hash.compute (List.map fst r.Preapply_result.applied))
         validation_result_list)
  in
  Prevalidation.status validation_state
  >>=? fun {block_result; _} ->
  let pred_shell_header = State.Block.shell_header predecessor in
  let level = Int32.succ pred_shell_header.level in
  Block_validation.may_patch_protocol ~level block_result
  >>= fun {fitness; context; message; _} ->
  State.Block.protocol_hash predecessor
  >>=? fun pred_protocol ->
  let context = Shell_context.unwrap_disk_context context in
  Context.get_protocol context
  >>= fun protocol ->
  let proto_level =
    if Protocol_hash.equal protocol pred_protocol then
      pred_shell_header.proto_level
    else (pred_shell_header.proto_level + 1) mod 256
  in
  let shell_header : Block_header.shell_header =
    {
      level;
      proto_level;
      predecessor = State.Block.hash predecessor;
      timestamp;
      validation_passes = List.length validation_result_list;
      operations_hash;
      fitness;
      context = Context_hash.zero (* place holder *);
    }
  in
  ( if Protocol_hash.equal protocol pred_protocol then return (context, message)
  else
    match Registered_protocol.get protocol with
    | None ->
        fail
          (Block_validator_errors.Unavailable_protocol
             {block = State.Block.hash predecessor; protocol})
    | Some (module NewProto) ->
        let context = Shell_context.wrap_disk_context context in
        NewProto.init context shell_header
        >>=? fun {context; message; _} ->
        let context = Shell_context.unwrap_disk_context context in
        return (context, message) )
  >>=? fun (context, message) ->
  let context = Context.hash ?message ~time:timestamp context in
  return ({shell_header with context}, validation_result_list)
src/lib_shell/prevalidation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.Validation_errors.

Module T.
  Record signature {Proto_P_block_header_data Proto_P_block_header
    Proto_P_block_header_metadata Proto_P_operation_data
    Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state t
    operation result status : Type} := {
    Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
    t := t;
    operation := operation;
    compare : operation -> operation -> Z;
    parse : Tezos_base__TzPervasives.Operation.t ->
      Tezos_base__TzPervasives.tzresult operation;
    create : (option Stdlib.Bytes.t) ->
      Tezos_shell.State.Block.t ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          unit -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
    result := result;
    apply_operation : t -> operation -> Lwt.t result;
    status := status;
    status : t -> Lwt.t (Tezos_base__TzPervasives.tzresult status);
    pp_result : Stdlib.Format.formatter -> result -> unit;
  }.
  Arguments signature : clear implicits.
End T.

Definition preapply
  (predecessor : Tezos_shell.State.Block.t)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  (protocol_data : Stdlib.Bytes.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_header.shell_header *
        (list
          (Tezos_base__TzPervasives.Preapply_result.t
            Tezos_base__TzPervasives.error)))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.Block.context predecessor)
    (fun predecessor_context =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_storage.Context.get_protocol predecessor_context)
        (fun protocol =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            match Tezos_protocol_updater.Registered_protocol.get protocol with
            | None =>
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Prevalidation: missing protocol '" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        "' for the current block." % string
                        CamlinternalFormatBasics.End_of_format)))
                  "Prevalidation: missing protocol '%a' for the current block."
                    % string) Tezos_base__TzPervasives.Protocol_hash.pp_short
                protocol
            | Some protocol => Tezos_base__TzPervasives._return protocol
            end
            (fun Proto =>
              let Proto := projT2 Proto in
              let Prevalidation := unsupported_functor_application in
              let apply_operation_with_preapply_result
                (preapp :
                Tezos_base__TzPervasives.Preapply_result.t
                  Tezos_base__TzPervasives.error) (t : Prevalidation.t) (op :
                Prevalidation.operation)
                : Lwt.t
                  ((Tezos_base__TzPervasives.Preapply_result.t
                    Tezos_base__TzPervasives.error) * Prevalidation.t) :=
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Prevalidation.apply_operation t op)
                  (fun function_parameter =>
                    match function_parameter with
                    | Applied t _ =>
                      let applied := cons ((hash op), (raw op)) (applied preapp)
                        in
                      Lwt._return (record, t)
                    | Branch_delayed errors =>
                      let branch_delayed :=
                        Tezos_base__TzPervasives.Operation_hash.Map.add
                          (hash op) ((raw op), errors) (branch_delayed preapp)
                        in
                      Lwt._return (record, t)
                    | Branch_refused errors =>
                      let branch_refused :=
                        Tezos_base__TzPervasives.Operation_hash.Map.add
                          (hash op) ((raw op), errors) (branch_refused preapp)
                        in
                      Lwt._return (record, t)
                    | Refused errors =>
                      let refused :=
                        Tezos_base__TzPervasives.Operation_hash.Map.add
                          (hash op) ((raw op), errors) (refused preapp) in
                      Lwt._return (record, t)
                    | Duplicate | Outdated => Lwt._return (preapp, t)
                    end) in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Prevalidation.create (Some protocol_data) predecessor timestamp
                  tt)
                (fun validation_state =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Lwt_list.fold_left_s
                      (fun function_parameter =>
                        match function_parameter with
                        | (acc_validation_result, acc_validation_state) =>
                          fun operations =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Lwt_list.fold_left_s
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    (acc_validation_result, acc_validation_state)
                                    =>
                                    fun op =>
                                      match Prevalidation.parse op with
                                      | inr _ =>
                                        Lwt._return
                                          (acc_validation_result,
                                            acc_validation_state)
                                      | inl op =>
                                        apply_operation_with_preapply_result
                                          acc_validation_result
                                          acc_validation_state op
                                      end
                                  end)
                                (Tezos_base__TzPervasives.Preapply_result.empty,
                                  acc_validation_state) operations)
                              (fun function_parameter =>
                                match function_parameter with
                                | (new_validation_result, new_validation_state)
                                  =>
                                  let new_validation_result := record in
                                  Lwt._return
                                    ((OCaml.Stdlib.app acc_validation_result
                                      (cons new_validation_result [])),
                                      new_validation_state)
                                end)
                        end) ([], validation_state) operations)
                    (fun function_parameter =>
                      match function_parameter with
                      | (validation_result_list, validation_state) =>
                        let operations_hash :=
                          Tezos_base__TzPervasives.Operation_list_list_hash.compute
                            (Tezos_base__TzPervasives.List.map
                              (fun r =>
                                Tezos_base__TzPervasives.Operation_list_hash.compute
                                  (Tezos_base__TzPervasives.List.map fst
                                    (Preapply_result.applied r)))
                              validation_result_list) in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Prevalidation.status validation_state)
                          (fun function_parameter =>
                            match function_parameter with
                            | {| block_result := block_result |} =>
                              let pred_shell_header :=
                                Tezos_shell.State.Block.shell_header predecessor
                                in
                              let level :=
                                Stdlib.Int32.succ (level pred_shell_header) in
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_validation.Block_validation.may_patch_protocol
                                  level block_result)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | {|
                                    context := context;
                                      fitness := fitness;
                                      message := message
                                      |} =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_shell.State.Block.protocol_hash
                                        predecessor)
                                      (fun pred_protocol =>
                                        let context :=
                                          Tezos_shell_context.Shell_context.unwrap_disk_context
                                            context in
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (Tezos_storage.Context.get_protocol
                                            context)
                                          (fun protocol =>
                                            let proto_level :=
                                              if
                                                Tezos_base__TzPervasives.Protocol_hash.equal
                                                  protocol pred_protocol then
                                                proto_level pred_shell_header
                                              else
                                                Z.modulo
                                                  (Z.add
                                                    (proto_level
                                                      pred_shell_header) 1) 256
                                              in
                                            let shell_header :=
                                              {| level := level;
                                                proto_level := proto_level;
                                                predecessor :=
                                                  Tezos_shell.State.Block.hash
                                                    predecessor;
                                                timestamp := timestamp;
                                                validation_passes :=
                                                  Tezos_base__TzPervasives.List.length
                                                    validation_result_list;
                                                operations_hash :=
                                                  operations_hash;
                                                fitness := fitness;
                                                context :=
                                                  Tezos_base__TzPervasives.Context_hash.zero
                                                |} in
                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                              (if
                                                Tezos_base__TzPervasives.Protocol_hash.equal
                                                  protocol pred_protocol then
                                                Tezos_base__TzPervasives._return
                                                  (context, message)
                                              else
                                                match
                                                  Tezos_protocol_updater.Registered_protocol.get
                                                    protocol with
                                                | None =>
                                                  Tezos_base__TzPervasives.fail
                                                    (Block_validator_errors.Unavailable_protocol
                                                      {|
                                                        block :=
                                                          Tezos_shell.State.Block.hash
                                                            predecessor;
                                                        protocol := protocol |})
                                                | Some NewProto =>
                                                  let NewProto :=
                                                    projT2 NewProto in
                                                  let context :=
                                                    Tezos_shell_context.Shell_context.wrap_disk_context
                                                      context in
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    (NewProto.(Tezos_protocol_updater__Registered_protocol.T.init)
                                                      context shell_header)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | {|
                                                        context := context;
                                                          message := message
                                                          |} =>
                                                        let context :=
                                                          Tezos_shell_context.Shell_context.unwrap_disk_context
                                                            context in
                                                        Tezos_base__TzPervasives._return
                                                          (context, message)
                                                      end)
                                                end)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (context, message) =>
                                                  let context :=
                                                    Tezos_storage.Context.hash
                                                      timestamp message context
                                                    in
                                                  Tezos_base__TzPervasives._return
                                                    (record,
                                                      validation_result_list)
                                                end)))
                                  end)
                            end)
                      end))))).
src/lib_shell/prevalidation.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A newly received block is validated by replaying locally the block
    creation, applying each operation and its finalization to ensure their
    consistency. This module is stateless and creates and manipulates the
    prevalidation_state. *)

module type T = sig
  module Proto : Registered_protocol.T

  type t

  type operation = private {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  val compare : operation -> operation -> int

  val parse : Operation.t -> operation tzresult

  (** Creates a new prevalidation context w.r.t. the protocol associate to the
      predecessor block . When ?protocol_data is passed to this function, it will
      be used to create the new block *)
  val create :
    ?protocol_data:Bytes.t ->
    predecessor:State.Block.t ->
    timestamp:Time.Protocol.t ->
    unit ->
    t tzresult Lwt.t

  type result =
    | Applied of t * Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Outdated

  val apply_operation : t -> operation -> result Lwt.t

  type status = {
    applied_operations : (operation * Proto.operation_receipt) list;
    block_result : Tezos_protocol_environment.validation_result;
    block_metadata : Proto.block_header_metadata;
  }

  val status : t -> status tzresult Lwt.t

  val pp_result : Format.formatter -> result -> unit
end

module Make (Proto : Registered_protocol.T) : T with module Proto = Proto

(** Pre-apply creates a new block and returns it. *)
val preapply :
  predecessor:State.Block.t ->
  timestamp:Time.Protocol.t ->
  protocol_data:Bytes.t ->
  Operation.t list list ->
  (Block_header.shell_header * error Preapply_result.t list) tzresult Lwt.t
src/lib_shell/prevalidation.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

unhandled_module

Parameter preapply :
Tezos_shell.State.Block.t ->
  Tezos_base__TzPervasives.Time.Protocol.t ->
    Stdlib.Bytes.t ->
      (list (list Tezos_base__TzPervasives.Operation.t)) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Block_header.shell_header *
              (list
                (Tezos_base__TzPervasives.Preapply_result.t
                  Tezos_base__TzPervasives.error)))).
src/lib_shell/prevalidator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Prevalidator_worker_state

type limits = {
  max_refused_operations : int;
  operation_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
  operations_batch_size : int;
}

type name_t = Chain_id.t * Protocol_hash.t

module type T = sig
  module Proto : Registered_protocol.T

  val name : name_t

  val parameters : limits * Distributed_db.chain_db

  module Prevalidation : Prevalidation.T with module Proto = Proto

  type types_state = {
    chain_db : Distributed_db.chain_db;
    limits : limits;
    mutable predecessor : State.Block.t;
    mutable timestamp : Time.System.t;
    mutable live_blocks : Block_hash.Set.t;
    mutable live_operations : Operation_hash.Set.t;
    refused : Operation_hash.t Ring.t;
    mutable refusals : (Operation.t * error list) Operation_hash.Map.t;
    branch_refused : Operation_hash.t Ring.t;
    mutable branch_refusals : (Operation.t * error list) Operation_hash.Map.t;
    branch_delayed : Operation_hash.t Ring.t;
    mutable branch_delays : (Operation.t * error list) Operation_hash.Map.t;
    mutable fetching : Operation_hash.Set.t;
    mutable pending : Operation.t Operation_hash.Map.t;
    mutable mempool : Mempool.t;
    mutable in_mempool : Operation_hash.Set.t;
    mutable applied : (Operation_hash.t * Operation.t) list;
    mutable applied_count : int;
    mutable validation_state : Prevalidation.t tzresult;
    mutable operation_stream :
      ( [`Applied | `Refused | `Branch_refused | `Branch_delayed]
      * Operation.shell_header
      * Proto.operation_data )
      Lwt_watcher.input;
    mutable advertisement : [`Pending of Mempool.t | `None];
    mutable rpc_directory : types_state RPC_directory.t lazy_t;
  }

  module Name : Worker.NAME with type t = name_t

  module Types : Worker.TYPES with type state = types_state

  module Worker :
    Worker.T
      with type Event.t = Event.t
       and type 'a Request.t = 'a Request.t
       and type Request.view = Request.view
       and type Types.state = types_state

  type worker = Worker.infinite Worker.queue Worker.t

  val list_pendings :
    Distributed_db.chain_db ->
    from_block:State.Block.t ->
    to_block:State.Block.t ->
    live_blocks:Block_hash.Set.t ->
    Operation.t Operation_hash.Map.t ->
    Operation.t Operation_hash.Map.t Lwt.t

  val validation_result : types_state -> error Preapply_result.t

  val fitness : unit -> Fitness.t Lwt.t

  val initialization_errors : unit tzresult Lwt.t

  val worker : worker Lazy.t
end

module type ARG = sig
  val limits : limits

  val chain_db : Distributed_db.chain_db

  val chain_id : Chain_id.t
end

type t = (module T)

module Make (Proto : Registered_protocol.T) (Arg : ARG) : T = struct
  module Proto = Proto

  let name = (Arg.chain_id, Proto.hash)

  let parameters = (Arg.limits, Arg.chain_db)

  module Prevalidation = Prevalidation.Make (Proto)

  type types_state = {
    chain_db : Distributed_db.chain_db;
    limits : limits;
    mutable predecessor : State.Block.t;
    mutable timestamp : Time.System.t;
    mutable live_blocks : Block_hash.Set.t;
    (* just a cache *)
    mutable live_operations : Operation_hash.Set.t;
    (* just a cache *)
    refused : Operation_hash.t Ring.t;
    mutable refusals : (Operation.t * error list) Operation_hash.Map.t;
    branch_refused : Operation_hash.t Ring.t;
    mutable branch_refusals : (Operation.t * error list) Operation_hash.Map.t;
    branch_delayed : Operation_hash.t Ring.t;
    mutable branch_delays : (Operation.t * error list) Operation_hash.Map.t;
    mutable fetching : Operation_hash.Set.t;
    mutable pending : Operation.t Operation_hash.Map.t;
    mutable mempool : Mempool.t;
    mutable in_mempool : Operation_hash.Set.t;
    mutable applied : (Operation_hash.t * Operation.t) list;
    mutable applied_count : int;
    mutable validation_state : Prevalidation.t tzresult;
    mutable operation_stream :
      ( [`Applied | `Refused | `Branch_refused | `Branch_delayed]
      * Operation.shell_header
      * Proto.operation_data )
      Lwt_watcher.input;
    mutable advertisement : [`Pending of Mempool.t | `None];
    mutable rpc_directory : types_state RPC_directory.t lazy_t;
  }

  module Name = struct
    type t = name_t

    let encoding = Data_encoding.tup2 Chain_id.encoding Protocol_hash.encoding

    let chain_id_string =
      let (_ : string) = Format.flush_str_formatter () in
      Chain_id.pp_short Format.str_formatter Arg.chain_id ;
      Format.flush_str_formatter ()

    let proto_hash_string =
      let (_ : string) = Format.flush_str_formatter () in
      Protocol_hash.pp_short Format.str_formatter Proto.hash ;
      Format.flush_str_formatter ()

    let base = ["prevalidator"; chain_id_string; proto_hash_string]

    let pp fmt (chain_id, proto_hash) =
      Chain_id.pp_short fmt chain_id ;
      Format.pp_print_string fmt "." ;
      Protocol_hash.pp_short fmt proto_hash
  end

  module Types = struct
    (* Invariants:
       - an operation is in only one of these sets (map domains):
         pv.refusals pv.pending pv.fetching pv.live_operations pv.in_mempool
       - pv.in_mempool is the domain of all fields of pv.prevalidation_result
       - pv.prevalidation_result.refused = Ø, refused ops are in pv.refused
       - the 'applied' operations in pv.validation_result are in reverse order. *)
    type state = types_state

    type parameters = limits * Distributed_db.chain_db

    include Worker_state

    let view (state : state) _ : view =
      let domain map =
        Operation_hash.Map.fold
          (fun elt _ acc -> Operation_hash.Set.add elt acc)
          map
          Operation_hash.Set.empty
      in
      {
        head = State.Block.hash state.predecessor;
        timestamp = state.timestamp;
        fetching = state.fetching;
        pending = domain state.pending;
        applied = List.rev (List.map (fun (h, _) -> h) state.applied);
        delayed =
          Operation_hash.Set.union
            (domain state.branch_delays)
            (domain state.branch_refusals);
      }
  end

  module Logger = Worker_logger.Make (Event) (Request)

  module Worker :
    Worker.T
      with type Name.t = Name.t
       and type Event.t = Event.t
       and type 'a Request.t = 'a Request.t
       and type Request.view = Request.view
       and type Types.state = Types.state
       and type Types.parameters = Types.parameters =
    Worker.Make (Name) (Prevalidator_worker_state.Event)
      (Prevalidator_worker_state.Request)
      (Types)
      (Logger)

  (** Centralised operation stream for the RPCs *)
  let notify_operation {operation_stream; _} result {Operation.shell; proto} =
    let protocol_data =
      Data_encoding.Binary.of_bytes Proto.operation_data_encoding proto
    in
    match protocol_data with
    | Some protocol_data ->
        Lwt_watcher.notify operation_stream (result, shell, protocol_data)
    | None ->
        ()

  open Types

  type worker = Worker.infinite Worker.queue Worker.t

  let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))

  let list_pendings chain_db ~from_block ~to_block ~live_blocks old_mempool =
    let rec pop_blocks ancestor block mempool =
      let hash = State.Block.hash block in
      if Block_hash.equal hash ancestor then Lwt.return mempool
      else
        State.Block.all_operations block
        >>= fun operations ->
        Lwt_list.fold_left_s
          (Lwt_list.fold_left_s (fun mempool op ->
               let h = Operation.hash op in
               Distributed_db.inject_operation chain_db h op
               >>= fun (_ : bool) ->
               Lwt.return (Operation_hash.Map.add h op mempool)))
          mempool
          operations
        >>= fun mempool ->
        State.Block.predecessor block
        >>= function
        | None ->
            assert false
        | Some predecessor ->
            pop_blocks ancestor predecessor mempool
    in
    let push_block mempool block =
      State.Block.all_operation_hashes block
      >|= fun operations ->
      List.iter
        (List.iter (Distributed_db.Operation.clear_or_cancel chain_db))
        operations ;
      List.fold_left
        (List.fold_left (fun mempool h -> Operation_hash.Map.remove h mempool))
        mempool
        operations
    in
    Chain_traversal.new_blocks ~from_block ~to_block
    >>= fun (ancestor, path) ->
    pop_blocks (State.Block.hash ancestor) from_block old_mempool
    >>= fun mempool ->
    Lwt_list.fold_left_s push_block mempool path
    >>= fun new_mempool ->
    let (new_mempool, outdated) =
      Operation_hash.Map.partition
        (fun _oph op ->
          Block_hash.Set.mem op.Operation.shell.branch live_blocks)
        new_mempool
    in
    Operation_hash.Map.iter
      (fun oph _op -> Distributed_db.Operation.clear_or_cancel chain_db oph)
      outdated ;
    Lwt.return new_mempool

  let already_handled pv oph =
    Operation_hash.Map.mem oph pv.refusals
    || Operation_hash.Map.mem oph pv.pending
    || Operation_hash.Set.mem oph pv.fetching
    || Operation_hash.Set.mem oph pv.live_operations
    || Operation_hash.Set.mem oph pv.in_mempool

  let validation_result (state : types_state) =
    {
      Preapply_result.applied = List.rev state.applied;
      branch_delayed = state.branch_delays;
      branch_refused = state.branch_refusals;
      refused = Operation_hash.Map.empty;
    }

  let advertise (w : worker) pv mempool =
    match pv.advertisement with
    | `Pending {Mempool.known_valid; pending} ->
        pv.advertisement <-
          `Pending
            {
              known_valid = known_valid @ mempool.Mempool.known_valid;
              pending = Operation_hash.Set.union pending mempool.pending;
            }
    | `None ->
        pv.advertisement <- `Pending mempool ;
        Lwt.async (fun () ->
            Lwt_unix.sleep 0.01
            >>= fun () ->
            Worker.Queue.push_request_now w Advertise ;
            Lwt.return_unit)

  let is_endorsement (op : Prevalidation.operation) =
    Proto.acceptable_passes
      {shell = op.raw.shell; protocol_data = op.protocol_data}
    = [0]

  let is_endorsement_raw op =
    match Prevalidation.parse op with
    | Ok op ->
        is_endorsement op
    | Error _ ->
        false

  let handle_unprocessed w pv =
    ( match pv.validation_state with
    | Error err ->
        Operation_hash.Map.iter
          (fun h op ->
            Option.iter
              (Ring.add_and_return_erased pv.branch_delayed h)
              ~f:(fun e ->
                pv.branch_delays <-
                  Operation_hash.Map.remove e pv.branch_delays ;
                pv.in_mempool <- Operation_hash.Set.remove e pv.in_mempool) ;
            pv.in_mempool <- Operation_hash.Set.add h pv.in_mempool ;
            pv.branch_delays <-
              Operation_hash.Map.add h (op, err) pv.branch_delays)
          pv.pending ;
        pv.pending <- Operation_hash.Map.empty ;
        Lwt.return_unit
    | Ok state -> (
      match Operation_hash.Map.cardinal pv.pending with
      | 0 ->
          Lwt.return_unit
      | n ->
          debug w "processing %d operations" n ;
          let operations =
            List.map snd (Operation_hash.Map.bindings pv.pending)
          in
          Lwt_utils.fold_left_s_n
            ~n:pv.limits.operations_batch_size
            (fun (acc_validation_state, acc_mempool) op ->
              let refused hash raw errors =
                notify_operation pv `Refused raw ;
                let new_mempool =
                  Mempool.
                    {
                      acc_mempool with
                      pending = Operation_hash.Set.add hash acc_mempool.pending;
                    }
                in
                Option.iter
                  (Ring.add_and_return_erased pv.refused hash)
                  ~f:(fun e ->
                    pv.refusals <- Operation_hash.Map.remove e pv.refusals) ;
                pv.refusals <-
                  Operation_hash.Map.add hash (raw, errors) pv.refusals ;
                Distributed_db.Operation.clear_or_cancel pv.chain_db hash ;
                Lwt.return (acc_validation_state, new_mempool)
              in
              match Prevalidation.parse op with
              | Error errors ->
                  refused (Operation.hash op) op errors
              | Ok op -> (
                  Prevalidation.apply_operation state op
                  >>= function
                  | Applied (new_acc_validation_state, _) ->
                      if
                        pv.applied_count <= 2000
                        (* this test is a quick fix while we wait for the new mempool *)
                        || is_endorsement op
                      then (
                        notify_operation pv `Applied op.raw ;
                        let new_mempool =
                          Mempool.
                            {
                              acc_mempool with
                              known_valid = op.hash :: acc_mempool.known_valid;
                            }
                        in
                        pv.applied <- (op.hash, op.raw) :: pv.applied ;
                        pv.in_mempool <-
                          Operation_hash.Set.add op.hash pv.in_mempool ;
                        Lwt.return (new_acc_validation_state, new_mempool) )
                      else Lwt.return (acc_validation_state, acc_mempool)
                  | Branch_delayed errors ->
                      notify_operation pv `Branch_delayed op.raw ;
                      let new_mempool =
                        if is_endorsement op then
                          Mempool.
                            {
                              acc_mempool with
                              pending =
                                Operation_hash.Set.add
                                  op.hash
                                  acc_mempool.pending;
                            }
                        else acc_mempool
                      in
                      Option.iter
                        (Ring.add_and_return_erased pv.branch_delayed op.hash)
                        ~f:(fun e ->
                          pv.branch_delays <-
                            Operation_hash.Map.remove e pv.branch_delays ;
                          pv.in_mempool <-
                            Operation_hash.Set.remove e pv.in_mempool) ;
                      pv.in_mempool <-
                        Operation_hash.Set.add op.hash pv.in_mempool ;
                      pv.branch_delays <-
                        Operation_hash.Map.add
                          op.hash
                          (op.raw, errors)
                          pv.branch_delays ;
                      Lwt.return (acc_validation_state, new_mempool)
                  | Branch_refused errors ->
                      notify_operation pv `Branch_refused op.raw ;
                      let new_mempool =
                        if is_endorsement op then
                          Mempool.
                            {
                              acc_mempool with
                              pending =
                                Operation_hash.Set.add
                                  op.hash
                                  acc_mempool.pending;
                            }
                        else acc_mempool
                      in
                      Option.iter
                        (Ring.add_and_return_erased pv.branch_refused op.hash)
                        ~f:(fun e ->
                          pv.branch_refusals <-
                            Operation_hash.Map.remove e pv.branch_refusals ;
                          pv.in_mempool <-
                            Operation_hash.Set.remove e pv.in_mempool) ;
                      pv.in_mempool <-
                        Operation_hash.Set.add op.hash pv.in_mempool ;
                      pv.branch_refusals <-
                        Operation_hash.Map.add
                          op.hash
                          (op.raw, errors)
                          pv.branch_refusals ;
                      Lwt.return (acc_validation_state, new_mempool)
                  | Refused errors ->
                      refused op.hash op.raw errors
                  | Duplicate | Outdated ->
                      Lwt.return (acc_validation_state, acc_mempool) ))
            (state, Mempool.empty)
            operations
          >>= fun ((state, advertised_mempool), remaining_op) ->
          ( if remaining_op != [] then
            Worker.Queue.push_request w Request.Leftover
          else Lwt.return_unit )
          >>= fun () ->
          pv.validation_state <- Ok state ;
          pv.pending <- Operation_hash.Map.empty ;
          advertise
            w
            pv
            {
              advertised_mempool with
              known_valid = List.rev advertised_mempool.known_valid;
            } ;
          Lwt.return_unit ) )
    >>= fun () ->
    pv.mempool <-
      {
        Mempool.known_valid = List.rev_map fst pv.applied;
        pending =
          Operation_hash.Map.fold
            (fun k (op, _) s ->
              if is_endorsement_raw op then Operation_hash.Set.add k s else s)
            pv.branch_delays
          @@ Operation_hash.Map.fold
               (fun k (op, _) s ->
                 if is_endorsement_raw op then Operation_hash.Set.add k s
                 else s)
               pv.branch_refusals
          @@ Operation_hash.Set.empty;
      } ;
    State.Current_mempool.set
      (Distributed_db.chain_state pv.chain_db)
      ~head:(State.Block.hash pv.predecessor)
      pv.mempool
    >>= fun () -> Lwt_main.yield ()

  let fetch_operation w pv ?peer oph =
    debug w "fetching operation %a" Operation_hash.pp_short oph ;
    Distributed_db.Operation.fetch
      ~timeout:pv.limits.operation_timeout
      pv.chain_db
      ?peer
      oph
      ()
    >>= function
    | Ok op ->
        Worker.Queue.push_request_now w (Arrived (oph, op)) ;
        Lwt.return_unit
    | Error (Distributed_db.Operation.Canceled _ :: _) ->
        debug
          w
          "operation %a included before being prevalidated"
          Operation_hash.pp_short
          oph ;
        Lwt.return_unit
    | Error _ ->
        (* should not happen *)
        Lwt.return_unit

  let rpc_directory =
    lazy
      (let dir : state RPC_directory.t ref = ref RPC_directory.empty in
       let module Proto_services = Block_services.Make (Proto) (Proto) in
       (* TODO
       refused => Operation_hash.Set.t ;
       kick le peer
    *)
       dir :=
         RPC_directory.register
           !dir
           (Proto_services.S.Mempool.pending_operations RPC_path.open_root)
           (fun pv () () ->
             let map_op op =
               let protocol_data_opt =
                 Data_encoding.Binary.of_bytes
                   Proto.operation_data_encoding
                   op.Operation.proto
               in
               match protocol_data_opt with
               | Some protocol_data ->
                   Some {Proto.shell = op.shell; protocol_data}
               | None ->
                   None
             in
             let map_op_error oph (op, error) acc =
               match map_op op with
               | None ->
                   acc
               | Some res ->
                   Operation_hash.Map.add oph (res, error) acc
             in
             let applied =
               List.filter_map
                 (fun (hash, op) ->
                   match map_op op with
                   | Some op ->
                       Some (hash, op)
                   | None ->
                       None)
                 (List.rev pv.applied)
             in
             let filter f map =
               Operation_hash.Map.fold f map Operation_hash.Map.empty
             in
             let refused = filter map_op_error pv.refusals in
             let branch_refused = filter map_op_error pv.branch_refusals in
             let branch_delayed = filter map_op_error pv.branch_delays in
             let unprocessed =
               Operation_hash.Map.fold
                 (fun oph op acc ->
                   match map_op op with
                   | Some op ->
                       Operation_hash.Map.add oph op acc
                   | None ->
                       acc)
                 pv.pending
                 Operation_hash.Map.empty
             in
             return
               {
                 Proto_services.Mempool.applied;
                 refused;
                 branch_refused;
                 branch_delayed;
                 unprocessed;
               }) ;
       dir :=
         RPC_directory.register
           !dir
           (Proto_services.S.Mempool.request_operations RPC_path.open_root)
           (fun pv () () ->
             Distributed_db.Request.current_head pv.chain_db () ;
             return_unit) ;
       dir :=
         RPC_directory.gen_register
           !dir
           (Proto_services.S.Mempool.monitor_operations RPC_path.open_root)
           (fun { applied;
                  refusals = refused;
                  branch_refusals = branch_refused;
                  branch_delays = branch_delayed;
                  operation_stream;
                  _ }
                params
                ()
                ->
             let (op_stream, stopper) =
               Lwt_watcher.create_stream operation_stream
             in
             (* Convert ops *)
             let map_op op =
               let protocol_data =
                 Data_encoding.Binary.of_bytes_exn
                   Proto.operation_data_encoding
                   op.Operation.proto
               in
               Proto.{shell = op.shell; protocol_data}
             in
             let fold_op _k (op, _error) acc = map_op op :: acc in
             (* First call : retrieve the current set of op from the mempool *)
             let applied =
               if params#applied then List.map map_op (List.map snd applied)
               else []
             in
             let refused =
               if params#refused then
                 Operation_hash.Map.fold fold_op refused []
               else []
             in
             let branch_refused =
               if params#branch_refused then
                 Operation_hash.Map.fold fold_op branch_refused []
               else []
             in
             let branch_delayed =
               if params#branch_delayed then
                 Operation_hash.Map.fold fold_op branch_delayed []
               else []
             in
             let current_mempool =
               List.concat [applied; refused; branch_refused; branch_delayed]
             in
             let current_mempool = ref (Some current_mempool) in
             let filter_result = function
               | `Applied ->
                   params#applied
               | `Refused ->
                   params#refused
               | `Branch_refused ->
                   params#branch_refused
               | `Branch_delayed ->
                   params#branch_delayed
             in
             let rec next () =
               match !current_mempool with
               | Some mempool ->
                   current_mempool := None ;
                   Lwt.return_some mempool
               | None -> (
                   Lwt_stream.get op_stream
                   >>= function
                   | Some (kind, shell, protocol_data) when filter_result kind
                     ->
                       (* NOTE: Should the protocol change, a new Prevalidation
                        * context would be created. Thus, we use the same Proto. *)
                       let bytes =
                         Data_encoding.Binary.to_bytes_exn
                           Proto.operation_data_encoding
                           protocol_data
                       in
                       let protocol_data =
                         Data_encoding.Binary.of_bytes_exn
                           Proto.operation_data_encoding
                           bytes
                       in
                       Lwt.return_some [{Proto.shell; protocol_data}]
                   | Some _ ->
                       next ()
                   | None ->
                       Lwt.return_none )
             in
             let shutdown () = Lwt_watcher.shutdown stopper in
             RPC_answer.return_stream {next; shutdown}) ;
       !dir)

  module Handlers = struct
    type self = worker

    let on_operation_arrived (pv : state) oph op =
      pv.fetching <- Operation_hash.Set.remove oph pv.fetching ;
      if not (Block_hash.Set.mem op.Operation.shell.branch pv.live_blocks) then
        Distributed_db.Operation.clear_or_cancel pv.chain_db oph
        (* TODO: put in a specific delayed map ? *)
      else if
        not (already_handled pv oph) (* prevent double inclusion on flush *)
      then pv.pending <- Operation_hash.Map.add oph op pv.pending

    let on_inject pv op =
      let oph = Operation.hash op in
      if already_handled pv oph then return_unit
        (* FIXME : is this an error ? *)
      else
        Lwt.return pv.validation_state
        >>=? fun validation_state ->
        Lwt.return (Prevalidation.parse op)
        >>=? fun parsed_op ->
        Prevalidation.apply_operation validation_state parsed_op
        >>= function
        | Applied (_, _result) ->
            Distributed_db.inject_operation pv.chain_db oph op
            >>= fun (_ : bool) ->
            pv.pending <- Operation_hash.Map.add parsed_op.hash op pv.pending ;
            return_unit
        | res ->
            failwith
              "Error while applying operation %a:@ %a"
              Operation_hash.pp
              oph
              Prevalidation.pp_result
              res

    let on_notify w pv peer mempool =
      let all_ophs =
        List.fold_left
          (fun s oph -> Operation_hash.Set.add oph s)
          mempool.Mempool.pending
          mempool.known_valid
      in
      let to_fetch =
        Operation_hash.Set.filter
          (fun oph -> not (already_handled pv oph))
          all_ophs
      in
      pv.fetching <- Operation_hash.Set.union to_fetch pv.fetching ;
      Operation_hash.Set.iter
        (fun oph -> Lwt.ignore_result (fetch_operation w pv ~peer oph))
        to_fetch

    let on_flush w pv predecessor =
      Lwt_watcher.shutdown_input pv.operation_stream ;
      State.Block.max_operations_ttl predecessor
      >>=? fun max_op_ttl ->
      Chain_traversal.live_blocks predecessor max_op_ttl
      >>=? fun (new_live_blocks, new_live_operations) ->
      list_pendings
        pv.chain_db
        ~from_block:pv.predecessor
        ~to_block:predecessor
        ~live_blocks:new_live_blocks
        (Preapply_result.operations (validation_result pv))
      >>= fun pending ->
      let timestamp_system = Tezos_stdlib_unix.Systime_os.now () in
      let timestamp = Time.System.to_protocol timestamp_system in
      Prevalidation.create ~predecessor ~timestamp ()
      >>= fun validation_state ->
      debug
        w
        "%d operations were not washed by the flush"
        (Operation_hash.Map.cardinal pending) ;
      pv.predecessor <- predecessor ;
      pv.live_blocks <- new_live_blocks ;
      pv.live_operations <- new_live_operations ;
      pv.timestamp <- timestamp_system ;
      pv.mempool <- {known_valid = []; pending = Operation_hash.Set.empty} ;
      pv.pending <- pending ;
      pv.in_mempool <- Operation_hash.Set.empty ;
      Ring.clear pv.branch_delayed ;
      pv.branch_delays <- Operation_hash.Map.empty ;
      Ring.clear pv.branch_refused ;
      pv.branch_refusals <- Operation_hash.Map.empty ;
      pv.applied <- [] ;
      pv.applied_count <- 0 ;
      pv.validation_state <- validation_state ;
      pv.operation_stream <- Lwt_watcher.create_input () ;
      return_unit

    let on_advertise pv =
      match pv.advertisement with
      | `None ->
          () (* should not happen *)
      | `Pending mempool ->
          pv.advertisement <- `None ;
          Distributed_db.Advertise.current_head
            pv.chain_db
            ~mempool
            pv.predecessor

    let on_request : type r. worker -> r Request.t -> r tzresult Lwt.t =
     fun w request ->
      let pv = Worker.state w in
      ( match request with
      | Request.Flush hash ->
          on_advertise pv ;
          (* TODO: rebase the advertisement instead *)
          let chain_state = Distributed_db.chain_state pv.chain_db in
          State.Block.read chain_state hash
          >>=? fun block -> on_flush w pv block >>=? fun () -> return (() : r)
      | Request.Notify (peer, mempool) ->
          on_notify w pv peer mempool ;
          return_unit
      | Request.Leftover ->
          (* unprocessed ops are handled just below *)
          return_unit
      | Request.Inject op ->
          on_inject pv op
      | Request.Arrived (oph, op) ->
          on_operation_arrived pv oph op ;
          return_unit
      | Request.Advertise ->
          on_advertise pv ; return_unit )
      >>=? fun r -> handle_unprocessed w pv >>= fun () -> return r

    let on_close w =
      let pv = Worker.state w in
      Operation_hash.Set.iter
        (Distributed_db.Operation.clear_or_cancel pv.chain_db)
        pv.fetching ;
      Lwt.return_unit

    let on_launch w _ (limits, chain_db) =
      let chain_state = Distributed_db.chain_state chain_db in
      Chain.data chain_state
      >>= fun { current_head = predecessor;
                current_mempool = mempool;
                live_blocks;
                live_operations;
                _ } ->
      let timestamp_system = Tezos_stdlib_unix.Systime_os.now () in
      let timestamp = Time.System.to_protocol timestamp_system in
      Prevalidation.create ~predecessor ~timestamp ()
      >>= fun validation_state ->
      let fetching =
        List.fold_left
          (fun s h -> Operation_hash.Set.add h s)
          Operation_hash.Set.empty
          mempool.known_valid
      in
      let pv =
        {
          limits;
          chain_db;
          predecessor;
          timestamp = timestamp_system;
          live_blocks;
          live_operations;
          mempool = {known_valid = []; pending = Operation_hash.Set.empty};
          refused = Ring.create limits.max_refused_operations;
          refusals = Operation_hash.Map.empty;
          fetching;
          pending = Operation_hash.Map.empty;
          in_mempool = Operation_hash.Set.empty;
          applied = [];
          applied_count = 0;
          branch_refused = Ring.create limits.max_refused_operations;
          branch_refusals = Operation_hash.Map.empty;
          branch_delayed = Ring.create limits.max_refused_operations;
          branch_delays = Operation_hash.Map.empty;
          validation_state;
          operation_stream = Lwt_watcher.create_input ();
          advertisement = `None;
          rpc_directory;
        }
      in
      List.iter
        (fun oph -> Lwt.ignore_result (fetch_operation w pv oph))
        mempool.known_valid ;
      return pv

    let on_error w r st errs =
      Worker.record_event w (Event.Request (r, st, Some errs)) ;
      match r with
      | Request.(View (Inject _)) ->
          return_unit
      | _ ->
          Lwt.return_error errs

    let on_completion w r _ st =
      Worker.record_event w (Event.Request (Request.view r, st, None)) ;
      Lwt.return_unit

    let on_no_request _ = return_unit
  end

  let table = Worker.create_table Queue

  (* NOTE: we register a single worker for each instantiation of this Make
   * functor (and thus a single worker for the single instantiaion of Worker).
   * Whislt this is somewhat abusing the intended purpose of worker, it is part
   * of a transition plan to a one-worker-per-peer architecture. *)
  let worker_promise =
    Worker.launch
      table
      Arg.limits.worker_limits
      name
      (Arg.limits, Arg.chain_db)
      (module Handlers)

  let initialization_errors = worker_promise >>=? fun _ -> return_unit

  let worker =
    lazy
      ( match Lwt.state worker_promise with
      | Lwt.Return (Ok worker) ->
          worker
      | Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep ->
          assert false )

  let fitness () =
    let w = Lazy.force worker in
    let pv = Worker.state w in
    Lwt.return pv.validation_state
    >>=? (fun state ->
           Prevalidation.status state
           >>=? fun status -> return status.block_result.fitness)
    >>= function
    | Ok fitness ->
        Lwt.return fitness
    | Error _ ->
        Lwt.return (State.Block.fitness pv.predecessor)
end

module ChainProto_registry = Registry.Make (struct
  type v = t

  type t = Chain_id.t * Protocol_hash.t

  let compare (c1, p1) (c2, p2) =
    let pc = Protocol_hash.compare p1 p2 in
    if pc = 0 then Chain_id.compare c1 c2 else pc
end)

let create limits (module Proto : Registered_protocol.T) chain_db =
  let chain_state = Distributed_db.chain_state chain_db in
  let chain_id = State.Chain.id chain_state in
  match ChainProto_registry.query (chain_id, Proto.hash) with
  | None ->
      let module Prevalidator =
        Make
          (Proto)
          (struct
            let limits = limits

            let chain_db = chain_db

            let chain_id = chain_id
          end)
      in
      (* Checking initialization errors before giving a reference to dnagerous
       * `worker` value to caller. *)
      Prevalidator.initialization_errors
      >>=? fun () ->
      ChainProto_registry.register Prevalidator.name (module Prevalidator : T) ;
      return (module Prevalidator : T)
  | Some p ->
      return p

let shutdown (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  ChainProto_registry.remove Prevalidator.name ;
  Prevalidator.Worker.shutdown w

let flush (t : t) head =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.push_request_and_wait w (Request.Flush head)

let notify_operations (t : t) peer mempool =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.push_request w (Request.Notify (peer, mempool))

let operations (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  let pv = Prevalidator.Worker.state w in
  ( {(Prevalidator.validation_result pv) with applied = List.rev pv.applied},
    pv.pending )

let pending (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  let pv = Prevalidator.Worker.state w in
  let ops = Preapply_result.operations (Prevalidator.validation_result pv) in
  Lwt.return ops

let timestamp (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  let pv = Prevalidator.Worker.state w in
  pv.timestamp

let fitness (t : t) =
  let module Prevalidator : T = (val t) in
  Prevalidator.fitness ()

let inject_operation (t : t) op =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.push_request_and_wait w (Inject op)

let status (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.status w

let running_workers () =
  ChainProto_registry.fold (fun (id, proto) t acc -> (id, proto, t) :: acc) []

let pending_requests (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.pending_requests w

let current_request (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.current_request w

let last_events (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.last_events w

let protocol_hash (t : t) =
  let module Prevalidator : T = (val t) in
  Prevalidator.Proto.hash

let parameters (t : t) =
  let module Prevalidator : T = (val t) in
  Prevalidator.parameters

let information (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.information w

let pipeline_length (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.pending_requests_length w

let empty_rpc_directory : unit RPC_directory.t =
  RPC_directory.register
    RPC_directory.empty
    (Block_services.Empty.S.Mempool.pending_operations RPC_path.open_root)
    (fun _pv () () ->
      return
        {
          Block_services.Empty.Mempool.applied = [];
          refused = Operation_hash.Map.empty;
          branch_refused = Operation_hash.Map.empty;
          branch_delayed = Operation_hash.Map.empty;
          unprocessed = Operation_hash.Map.empty;
        })

let rpc_directory : t option RPC_directory.t =
  RPC_directory.register_dynamic_directory
    RPC_directory.empty
    (Block_services.mempool_path RPC_path.open_root)
    (function
      | None ->
          Lwt.return
            (RPC_directory.map (fun _ -> Lwt.return_unit) empty_rpc_directory)
      | Some t -> (
          let module Prevalidator : T = (val t : T) in
          Prevalidator.initialization_errors
          >>= function
          | Error _ ->
              Lwt.return
                (RPC_directory.map
                   (fun _ -> Lwt.return_unit)
                   empty_rpc_directory)
          | Ok () ->
              let w = Lazy.force Prevalidator.worker in
              let pv = Prevalidator.Worker.state w in
              let pv_rpc_dir = Lazy.force pv.rpc_directory in
              Lwt.return
                (RPC_directory.map (fun _ -> Lwt.return pv) pv_rpc_dir) ))
src/lib_shell/prevalidator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.Prevalidator_worker_state.

Record limits := {
  max_refused_operations : Z;
  operation_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits;
  operations_batch_size : Z }.

Definition name_t :=
  Tezos_base__TzPervasives.Chain_id.t * Tezos_base__TzPervasives.Protocol_hash.t.

Module T.
  Record signature {Proto_P_block_header_data Proto_P_block_header
    Proto_P_block_header_metadata Proto_P_operation_data
    Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state
    Prevalidation_t Prevalidation_operation Prevalidation_result
    Prevalidation_status types_state Types_parameters Types_view Worker_Name_t
    Worker_Types_parameters Worker_Types_view Worker_t Worker_table Worker_queue
    Worker_bounded Worker_infinite Worker_dropbox Worker_buffer_kind
    Worker_any_request : Type} := {
    Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
    name : name_t;
    parameters : limits * Tezos_shell.Distributed_db.chain_db;
    Prevalidation : Prevalidation.T.signature Prevalidation_Proto_P_block_header_data Prevalidation_Proto_P_block_header Prevalidation_Proto_P_block_header_metadata Prevalidation_Proto_P_operation_data Prevalidation_Proto_P_operation_receipt Prevalidation_Proto_P_operation Prevalidation_Proto_P_validation_state Prevalidation_t Prevalidation_operation Prevalidation_result Prevalidation_status;
    types_state := types_state;
    Name : Worker.NAME.signature name_t;
    Types : Worker.TYPES.signature types_state Types_parameters Types_view;
    Worker : Worker.T.signature (Tezos_shell_services.Prevalidator_worker_state.Request.t
      a) (Tezos_shell_services.Prevalidator_worker_state.Request.t a) (Tezos_shell_services.Prevalidator_worker_state.Request.t
      a) Tezos_shell_services.Prevalidator_worker_state.Request.view types_state Worker_Types_parameters Tezos_shell_services.Prevalidator_worker_state.Request.view Worker_t Worker_table Worker_queue Worker_bounded Worker_infinite Worker_dropbox Worker_buffer_kind Worker_any_request;
    worker := Worker.t (Worker.queue Worker.infinite);
    list_pendings : Tezos_shell.Distributed_db.chain_db ->
      Tezos_shell.State.Block.t ->
        Tezos_shell.State.Block.t ->
          Tezos_base__TzPervasives.Block_hash.Set.t ->
            (Tezos_base__TzPervasives.Operation_hash.Map.t
              Tezos_base__TzPervasives.Operation.t) ->
              Lwt.t
                (Tezos_base__TzPervasives.Operation_hash.Map.t
                  Tezos_base__TzPervasives.Operation.t);
    validation_result : types_state ->
      Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error;
    fitness : unit -> Lwt.t Tezos_base__TzPervasives.Fitness.t;
    initialization_errors : Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    worker : Stdlib.Lazy.t worker;
  }.
  Arguments signature : clear implicits.
End T.

Module ARG.
  Record signature := {
    limits : limits;
    chain_db : Tezos_shell.Distributed_db.chain_db;
    chain_id : Tezos_base__TzPervasives.Chain_id.t;
  }.
End ARG.

Definition t :=
  {'(Proto_P_block_header_data, Proto_P_block_header,
    Proto_P_block_header_metadata, Proto_P_operation_data,
    Proto_P_operation_receipt, Proto_P_operation, Proto_P_validation_state,
    Prevalidation_t, Prevalidation_operation, Prevalidation_result,
    Prevalidation_status, types_state, Types_parameters, Types_view,
    Worker_Name_t, Worker_Types_parameters, Worker_Types_view, Worker_t,
    Worker_table, Worker_queue, Worker_bounded, Worker_infinite, Worker_dropbox,
    Worker_buffer_kind, Worker_any_request) : _ &
    T.signature Proto_P_block_header_data Proto_P_block_header
      Proto_P_block_header_metadata Proto_P_operation_data
      Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state
      Prevalidation_t Prevalidation_operation Prevalidation_result
      Prevalidation_status types_state Types_parameters Types_view Worker_Name_t
      Worker_Types_parameters Worker_Types_view Worker_t Worker_table
      Worker_queue Worker_bounded Worker_infinite Worker_dropbox
      Worker_buffer_kind Worker_any_request}.

Definition create
  (limits : limits)
  (Proto :
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      Tezos_protocol_updater.Registered_protocol.T.signature P_block_header_data
        P_block_header P_block_header_metadata P_operation_data
        P_operation_receipt P_operation P_validation_state})
  : Tezos_shell.Distributed_db.chain_db ->
    Lwt.t (Tezos_base__TzPervasives.tzresult ChainProto_registry.v) :=
  let Proto := projT2 Proto in
  fun chain_db =>
    let chain_state := Tezos_shell.Distributed_db.chain_state chain_db in
    let chain_id := Tezos_shell.State.Chain.id chain_state in
    match
      ChainProto_registry.query
        (chain_id, Proto.(Tezos_protocol_updater__Registered_protocol.T.hash))
      with
    | None =>
      let Prevalidator := unsupported_functor_application in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        Prevalidator.(T.initialization_errors)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            ChainProto_registry.register Prevalidator.(T.name) Prevalidator;
            Tezos_base__TzPervasives._return Prevalidator
          end)
    | Some p => Tezos_base__TzPervasives._return p
    end.

Definition shutdown (t : t) : Lwt.t unit :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  ChainProto_registry.remove Prevalidator.(T.name);
  Prevalidator.Worker.shutdown w.

Definition flush (t : t) (head : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.push_request_and_wait w (Request.Flush head).

Definition notify_operations
  (t : t) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t)
  (mempool : Tezos_base__TzPervasives.Mempool.t) : Lwt.t unit :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.push_request w (Request.Notify peer mempool).

Definition operations (t : t)
  : (Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
    *
    (Tezos_base__TzPervasives.Operation_hash.Map.t
      Tezos_base__TzPervasives.Operation.t) :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  let pv := Prevalidator.Worker.state w in
  (record, (pending pv)).

Definition pending (t : t)
  : Lwt.t (Tezos_crypto.Operation_hash.Map.t Tezos_base.Operation.t) :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  let pv := Prevalidator.Worker.state w in
  let ops :=
    Tezos_base__TzPervasives.Preapply_result.operations
      (Prevalidator.(T.validation_result) pv) in
  Lwt._return ops.

Definition timestamp (t : t) : Tezos_base__TzPervasives.Time.System.t :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  let pv := Prevalidator.Worker.state w in
  timestamp pv.

Definition fitness (t : t) : Lwt.t Tezos_base__TzPervasives.Fitness.t :=
  let Prevalidator := projT2 t in
  Prevalidator.(T.fitness) tt.

Definition inject_operation (t : t) (op : Tezos_base__TzPervasives.Operation.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.push_request_and_wait w (Inject op).

Definition status (t : t) : Tezos_shell_services.Worker_types.worker_status :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.status w.

Definition running_workers (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Chain_id.t *
      Tezos_base__TzPervasives.Protocol_hash.t * ChainProto_registry.v) :=
  match function_parameter with
  | tt =>
    ChainProto_registry.fold
      (fun function_parameter =>
        match function_parameter with
        | (id, proto) => fun t => fun acc => cons (id, proto, t) acc
        end) []
  end.

Definition pending_requests (t : t)
  : list
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Prevalidator_worker_state.Request.view) :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.pending_requests w.

Definition current_request (t : t)
  : option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Prevalidator_worker_state.Request.view) :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.current_request w.

Definition last_events (t : t)
  : list
    (Tezos_base__TzPervasives.Internal_event.level *
      (list Tezos_shell_services.Prevalidator_worker_state.Event.t)) :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.last_events w.

Definition protocol_hash (t : t) : Tezos_base__TzPervasives.Protocol_hash.t :=
  let Prevalidator := projT2 t in
  Prevalidator.(T.Proto).(Tezos_protocol_updater__Registered_protocol.T.hash).

Definition parameters (t : t) : limits * Tezos_shell.Distributed_db.chain_db :=
  let Prevalidator := projT2 t in
  Prevalidator.(T.parameters).

Definition information (t : t)
  : Tezos_shell_services.Worker_types.worker_information :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.information w.

Definition pipeline_length (t : t) : Z :=
  let Prevalidator := projT2 t in
  let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.pending_requests_length w.

Definition empty_rpc_directory
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  Tezos_base__TzPervasives.RPC_directory.register
    Tezos_base__TzPervasives.RPC_directory.empty
    (Tezos_shell_services.Block_services.Empty.S.Mempool.pending_operations
      Tezos_base__TzPervasives.RPC_path.open_root)
    (fun _pv =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives._return
                {| Block_services.Empty.Mempool.applied := [];
                  Block_services.Empty.Mempool.refused :=
                    Tezos_base__TzPervasives.Operation_hash.Map.empty;
                  Block_services.Empty.Mempool.branch_refused :=
                    Tezos_base__TzPervasives.Operation_hash.Map.empty;
                  Block_services.Empty.Mempool.branch_delayed :=
                    Tezos_base__TzPervasives.Operation_hash.Map.empty;
                  Block_services.Empty.Mempool.unprocessed :=
                    Tezos_base__TzPervasives.Operation_hash.Map.empty |}
            end
        end).

Definition rpc_directory
  : Tezos_base__TzPervasives.RPC_directory.t (option t) :=
  Tezos_base__TzPervasives.RPC_directory.register_dynamic_directory None
    Tezos_base__TzPervasives.RPC_directory.empty
    (Tezos_shell_services.Block_services.mempool_path
      Tezos_base__TzPervasives.RPC_path.open_root)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Lwt._return
          (Tezos_base__TzPervasives.RPC_directory.map
            (fun function_parameter =>
              match function_parameter with
              | _ => Lwt.return_unit
              end) empty_rpc_directory)
      | Some t =>
        let Prevalidator := projT2 t in
        Tezos_base__TzPervasives.op_gt_gt_eq
          Prevalidator.(T.initialization_errors)
          (fun function_parameter =>
            match function_parameter with
            | inr _ =>
              Lwt._return
                (Tezos_base__TzPervasives.RPC_directory.map
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => Lwt.return_unit
                    end) empty_rpc_directory)
            | inl tt =>
              let w := Stdlib.Lazy.force Prevalidator.(T.worker) in
              let pv := Prevalidator.Worker.state w in
              let pv_rpc_dir := Stdlib.Lazy.force (rpc_directory pv) in
              Lwt._return
                (Tezos_base__TzPervasives.RPC_directory.map
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => Lwt._return pv
                    end) pv_rpc_dir)
            end)
      end).
src/lib_shell/prevalidator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell - Prevalidation of pending operations (a.k.a Mempool) *)

(** The prevalidator is in charge of the "mempool" (a.k.a. the
    set of known not-invalid-for-sure operations that are not yet
    included in the blockchain).

    The prevalidator also maintains a sorted subset of the mempool that
    might correspond to a valid block on top of the current head. The
    "in-progress" context produced by the application of those
    operations is called the (pre)validation context.

    Before including an operation into the mempool, the prevalidation
    worker tries to append the operation the prevalidation context. If
    the operation is (strongly) refused, it will not be added into the
    mempool and then it will be ignored by the node and never
    broadcast. If the operation is only "branch_refused" or
    "branch_delayed", the operation won't be appended in the
    prevalidation context, but still broadcast.

*)

(** An (abstract) prevalidator context. Separate prevalidator contexts should be
 * used for separate chains (e.g., mainchain vs testchain). *)
type t

type limits = {
  max_refused_operations : int;
  operation_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
  operations_batch_size : int;
}

(** Creates/tear-down a new prevalidator context. *)
val create :
  limits ->
  (module Registered_protocol.T) ->
  Distributed_db.chain_db ->
  t tzresult Lwt.t

val shutdown : t -> unit Lwt.t

(** Notify the prevalidator that the identified peer has sent a bunch of
 * operations relevant to the specified context. *)
val notify_operations : t -> P2p_peer.Id.t -> Mempool.t -> unit Lwt.t

(** Notify the prevalidator worker of a new injected operation. *)
val inject_operation : t -> Operation.t -> unit tzresult Lwt.t

(** Notify the prevalidator that a new head has been selected. *)
val flush : t -> Block_hash.t -> unit tzresult Lwt.t

(** Returns the timestamp of the prevalidator worker, that is the timestamp of the last
    reset of the prevalidation context *)
val timestamp : t -> Time.System.t

(** Returns the fitness of the current prevalidation context *)
val fitness : t -> Fitness.t Lwt.t

(** Returns the list of valid operations known to this prevalidation worker *)
val operations :
  t -> error Preapply_result.t * Operation.t Operation_hash.Map.t

(** Returns the list of pending operations known to this prevalidation worker *)
val pending : t -> Operation.t Operation_hash.Map.t Lwt.t

(** Returns the list of prevalidation contexts running and their associated chain *)
val running_workers : unit -> (Chain_id.t * Protocol_hash.t * t) list

(** Two functions that are useful for managing the prevalidator's transition
 * from one protocol to the next. *)

(** Returns the hash of the protocol the prevalidator was instantiated with *)
val protocol_hash : t -> Protocol_hash.t

(** Returns the parameters the prevalidator was created with. *)
val parameters : t -> limits * Distributed_db.chain_db

(** Worker status and events *)

(* None indicates the there are no workers for the current protocol. *)
val status : t -> Worker_types.worker_status

val pending_requests :
  t -> (Time.System.t * Prevalidator_worker_state.Request.view) list

val current_request :
  t ->
  (Time.System.t * Time.System.t * Prevalidator_worker_state.Request.view)
  option

val last_events :
  t -> (Internal_event.level * Prevalidator_worker_state.Event.t list) list

val information : t -> Worker_types.worker_information

val pipeline_length : t -> int

val rpc_directory : t option RPC_directory.t
src/lib_shell/prevalidator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Record limits := {
  max_refused_operations : Z;
  operation_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits;
  operations_batch_size : Z }.

Parameter create :
limits ->
  {'(P_block_header_data, P_block_header, P_block_header_metadata,
    P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
    &
    Tezos_protocol_updater.Registered_protocol.T.signature P_block_header_data
      P_block_header P_block_header_metadata P_operation_data
      P_operation_receipt P_operation P_validation_state} ->
    Tezos_shell.Distributed_db.chain_db ->
      Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter shutdown : t -> Lwt.t unit.

Parameter notify_operations :
t ->
  Tezos_base__TzPervasives.P2p_peer.Id.t ->
    Tezos_base__TzPervasives.Mempool.t -> Lwt.t unit.

Parameter inject_operation :
t ->
  Tezos_base__TzPervasives.Operation.t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter flush :
t ->
  Tezos_base__TzPervasives.Block_hash.t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter timestamp : t -> Tezos_base__TzPervasives.Time.System.t.

Parameter fitness : t -> Lwt.t Tezos_base__TzPervasives.Fitness.t.

Parameter operations :
t ->
  (Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error) *
    (Tezos_base__TzPervasives.Operation_hash.Map.t
      Tezos_base__TzPervasives.Operation.t).

Parameter pending :
t ->
  Lwt.t
    (Tezos_base__TzPervasives.Operation_hash.Map.t
      Tezos_base__TzPervasives.Operation.t).

Parameter running_workers :
unit ->
  list
    (Tezos_base__TzPervasives.Chain_id.t *
      Tezos_base__TzPervasives.Protocol_hash.t * t).

Parameter protocol_hash : t -> Tezos_base__TzPervasives.Protocol_hash.t.

Parameter parameters : t -> limits * Tezos_shell.Distributed_db.chain_db.

Parameter status : t -> Tezos_shell_services.Worker_types.worker_status.

Parameter pending_requests :
t ->
  list
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Prevalidator_worker_state.Request.view).

Parameter current_request :
t ->
  option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Prevalidator_worker_state.Request.view).

Parameter last_events :
t ->
  list
    (Tezos_base__TzPervasives.Internal_event.level *
      (list Tezos_shell_services.Prevalidator_worker_state.Event.t)).

Parameter information :
t -> Tezos_shell_services.Worker_types.worker_information.

Parameter pipeline_length : t -> Z.

Parameter rpc_directory : Tezos_base__TzPervasives.RPC_directory.t (option t).
src/lib_shell/protocol_directory.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let build_rpc_directory block_validator state =
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let gen_register0 s f =
    dir := RPC_directory.gen_register !dir s (fun () p q -> f p q)
  in
  let register1 s f =
    dir := RPC_directory.register !dir s (fun ((), a) p q -> f a p q)
  in
  gen_register0 Protocol_services.S.list (fun () () ->
      State.Protocol.list state
      >>= fun set ->
      let protocols =
        List.fold_left
          (fun acc x -> Protocol_hash.Set.add x acc)
          set
          (Registered_protocol.list_embedded ())
      in
      RPC_answer.return (Protocol_hash.Set.elements protocols)) ;
  register1 Protocol_services.S.contents (fun hash () () ->
      match Registered_protocol.get_embedded_sources hash with
      | Some p ->
          return p
      | None ->
          State.Protocol.read state hash) ;
  register1 Protocol_services.S.fetch (fun hash () () ->
      Block_validator.fetch_and_compile_protocol block_validator hash
      >>=? fun _proto -> return_unit) ;
  !dir
src/lib_shell/protocol_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition build_rpc_directory
  (block_validator : Tezos_shell.Block_validator.t)
  (state : Tezos_shell__State.global_state)
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  let dir := Stdlib.ref Tezos_base__TzPervasives.RPC_directory.empty in
  let gen_register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t variant) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.gen_register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | tt => fun p => fun q => f p q
          end)) in
  let register1 {A B C D : Type}
    (s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
    A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | (tt, a) => fun p => fun q => f a p q
          end)) in
  gen_register0 Tezos_shell_services.Protocol_services.S.list
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Protocol.list state)
              (fun set =>
                let protocols :=
                  Tezos_base__TzPervasives.List.fold_left
                    (fun acc =>
                      fun x =>
                        Tezos_base__TzPervasives.Protocol_hash.Set.add x acc)
                    set
                    (Tezos_protocol_updater.Registered_protocol.list_embedded tt)
                  in
                Tezos_base__TzPervasives.RPC_answer._return
                  (Tezos_base__TzPervasives.Protocol_hash.Set.elements protocols))
          end
      end);
  register1 Tezos_shell_services.Protocol_services.S.contents
    (fun hash =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              match
                Tezos_protocol_updater.Registered_protocol.get_embedded_sources
                  hash with
              | Some p => Tezos_base__TzPervasives._return p
              | None => Tezos_shell.State.Protocol.read state hash
              end
            end
        end);
  register1 Tezos_shell_services.Protocol_services.S.fetch
    (fun hash =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell.Block_validator.fetch_and_compile_protocol
                  block_validator None None hash)
                (fun _proto => Tezos_base__TzPervasives.return_unit)
            end
        end);
  Stdlib.op_exclamation dir.
src/lib_shell/protocol_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val build_rpc_directory : Block_validator.t -> State.t -> unit RPC_directory.t
src/lib_shell/protocol_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter build_rpc_directory :
Tezos_shell.Block_validator.t ->
  Tezos_shell.State.t -> Tezos_base__TzPervasives.RPC_directory.t unit.
src/lib_shell/protocol_validator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Validation_errors

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.validator.block"
end)

type t = {
  db : Distributed_db.t;
  mutable worker : unit Lwt.t;
  request : unit Lwt_condition.t;
  mutable pending :
    ( Protocol.t
    * Registered_protocol.t tzresult Lwt.t
    * Registered_protocol.t tzresult Lwt.u )
    Protocol_hash.Map.t;
  canceler : Lwt_canceler.t;
}

(** Block validation *)

let rec worker_loop bv =
  ( if Protocol_hash.Map.cardinal bv.pending = 0 then
    Lwt_condition.wait bv.request >>= return
  else
    let (hash, (protocol, _, wakener)) = Protocol_hash.Map.choose bv.pending in
    bv.pending <- Protocol_hash.Map.remove hash bv.pending ;
    Updater.compile hash protocol
    >>= fun valid ->
    ( if valid then Distributed_db.commit_protocol bv.db hash protocol
    else
      (* no need to tag 'invalid' protocol on disk,
             the economic protocol prevents us from
             being spammed with protocol validation. *)
      return_true )
    >>=? fun _ ->
    if valid then
      match Registered_protocol.get hash with
      | Some protocol ->
          Lwt.wakeup_later wakener (Ok protocol)
      | None ->
          Lwt.wakeup_later
            wakener
            (error (Invalid_protocol {hash; error = Dynlinking_failed}))
    else
      Lwt.wakeup_later
        wakener
        (error (Invalid_protocol {hash; error = Compilation_failed})) ;
    return_unit )
  >>= function
  | Ok () ->
      worker_loop bv
  | Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
      lwt_log_notice
        Tag.DSL.(fun f -> f "terminating" -% t event "terminating")
  | Error err ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "@[Unexpected error (worker):@ %a@]"
            -% t event "unexpected_error" -% a errs_tag err)
      >>= fun () -> Lwt_canceler.cancel bv.canceler

let create db =
  let canceler = Lwt_canceler.create () in
  let pending = Protocol_hash.Map.empty in
  let request = Lwt_condition.create () in
  let bv = {canceler; pending; request; db; worker = Lwt.return_unit} in
  Lwt_canceler.on_cancel bv.canceler (fun () ->
      Protocol_hash.Map.iter (fun _ (_, r, _) -> Lwt.cancel r) bv.pending ;
      Lwt.return_unit) ;
  bv.worker <-
    Lwt_utils.worker
      "block_validator"
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> worker_loop bv)
      ~cancel:(fun () -> Lwt_canceler.cancel bv.canceler) ;
  bv

let shutdown {canceler; worker; _} =
  Lwt_canceler.cancel canceler >>= fun () -> worker

let validate state hash protocol =
  match Registered_protocol.get hash with
  | Some protocol ->
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "previously validated protocol %a (before pipe)"
            -% t event "previously_validated_protocol"
            -% a Protocol_hash.Logging.tag hash)
      >>= fun () -> return protocol
  | None -> (
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "pushing validation request for protocol %a"
            -% t event "pushing_validation_request"
            -% a Protocol_hash.Logging.tag hash)
      >>= fun () ->
      match Protocol_hash.Map.find_opt hash state.pending with
      | None ->
          let (res, wakener) = Lwt.task () in
          let broadcast = Protocol_hash.Map.cardinal state.pending = 0 in
          state.pending <-
            Protocol_hash.Map.add hash (protocol, res, wakener) state.pending ;
          if broadcast then Lwt_condition.broadcast state.request () ;
          res
      | Some (_, res, _) ->
          res )

let fetch_and_compile_protocol pv ?peer ?timeout hash =
  match Registered_protocol.get hash with
  | Some proto ->
      return proto
  | None ->
      Distributed_db.Protocol.read_opt pv.db hash
      >>= (function
            | Some protocol ->
                return protocol
            | None ->
                lwt_log_notice
                  Tag.DSL.(
                    fun f ->
                      f "Fetching protocol %a%a"
                      -% t event "fetching_protocol"
                      -% a Protocol_hash.Logging.tag hash
                      -% a P2p_peer.Id.Logging.tag_source peer)
                >>= fun () ->
                Distributed_db.Protocol.fetch pv.db ?peer ?timeout hash ())
      >>=? fun protocol ->
      validate pv hash protocol >>=? fun proto -> return proto

let fetch_and_compile_protocols pv ?peer ?timeout (block : State.Block.t) =
  let protocol_level = State.Block.protocol_level block in
  let chain_state = State.Block.chain_state block in
  State.Block.context block
  >>=? fun context ->
  let protocol =
    Context.get_protocol context
    >>= fun protocol_hash ->
    fetch_and_compile_protocol pv ?peer ?timeout protocol_hash
    >>=? fun _p ->
    let chain_id = State.Chain.id chain_state in
    State.Chain.update_level_indexed_protocol_store
      chain_state
      chain_id
      protocol_level
      protocol_hash
      (State.Block.header block)
    >>= fun () -> return_unit
  and test_protocol =
    Context.get_test_chain context
    >>= function
    | Not_running ->
        return_unit
    | Forking {protocol; _} | Running {protocol; _} ->
        fetch_and_compile_protocol pv ?peer ?timeout protocol
        >>=? fun _ ->
        State.Chain.test chain_state
        >>= (function
              | None ->
                  Lwt.return_unit
              | Some chain_id ->
                  State.Chain.update_level_indexed_protocol_store
                    chain_state
                    chain_id
                    protocol_level
                    protocol
                    (State.Block.header block))
        >>= fun () -> return_unit
  in
  protocol >>=? fun () -> test_protocol

let prefetch_and_compile_protocols pv ?peer ?timeout block =
  try ignore (fetch_and_compile_protocols pv ?peer ?timeout block)
  with _ -> ()
src/lib_shell/protocol_validator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.Validation_errors.

Record t := {
  db : Tezos_shell.Distributed_db.t;
  worker : Lwt.t unit;
  request : Lwt_condition.t unit;
  pending :
    Tezos_base__TzPervasives.Protocol_hash.Map.t
      (Tezos_base__TzPervasives.Protocol.t *
        (Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_updater.Registered_protocol.t)) *
        (Lwt.u
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_updater.Registered_protocol.t)));
  canceler : Tezos_base__TzPervasives.Lwt_canceler.t }.

Fixpoint worker_loop (bv : t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (if
      equiv_decb
        (Tezos_base__TzPervasives.Protocol_hash.Map.cardinal (pending bv)) 0
      then
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt_condition.wait None (request bv)) Tezos_base__TzPervasives._return
    else
      match Tezos_base__TzPervasives.Protocol_hash.Map.choose (pending bv) with
      | (hash, (protocol, _, wakener)) =>
        set_field;
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_protocol_updater.Updater.compile hash protocol)
          (fun valid =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (if valid then
                Tezos_shell.Distributed_db.commit_protocol (db bv) hash protocol
              else
                Tezos_base__TzPervasives.return_true)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  if valid then
                    match Tezos_protocol_updater.Registered_protocol.get hash
                      with
                    | Some protocol => Lwt.wakeup_later wakener (inl protocol)
                    | None =>
                      Lwt.wakeup_later wakener
                        (Tezos_base__TzPervasives.error
                          (Invalid_protocol
                            {| hash := hash; error := Dynlinking_failed |}))
                    end
                  else
                    Lwt.wakeup_later wakener
                      (Tezos_base__TzPervasives.error
                        (Invalid_protocol
                          {| hash := hash; error := Compilation_failed |}));
                  Tezos_base__TzPervasives.return_unit
                end))
      end)
    (fun function_parameter =>
      match function_parameter with
      | inl tt => worker_loop bv
      | inr (cons Canceled _) | inr (cons (Exn Lwt_pipe.Closed) _) =>
        lwt_log_notice
          (fun f =>
            Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "terminating" % string
                    CamlinternalFormatBasics.End_of_format)
                  "terminating" % string))
              (Tag.DSL.t event "terminating" % string))
      | inr err =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_error
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected error (worker):" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Unexpected error (worker):@ %a@]" % string))
                  (Tag.DSL.t event "unexpected_error" % string))
                (Tag.DSL.a Tezos_base__TzPervasives.errs_tag err)))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.Lwt_canceler.cancel (canceler bv)
            end)
      end).

Definition create (db : Tezos_shell.Distributed_db.t) : t :=
  let canceler := Tezos_base__TzPervasives.Lwt_canceler.create tt in
  let pending := Tezos_base__TzPervasives.Protocol_hash.Map.empty in
  let request := Lwt_condition.create tt in
  let bv :=
    {| db := db; worker := Lwt.return_unit; request := request;
      pending := pending; canceler := canceler |} in
  Tezos_base__TzPervasives.Lwt_canceler.on_cancel (canceler bv)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.Protocol_hash.Map.iter
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              fun function_parameter =>
                match function_parameter with
                | (_, r, _) => Lwt.cancel r
                end
            end) (pending bv);
        Lwt.return_unit
      end);
  set_field;
  bv.

Definition shutdown (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | {| worker := worker; canceler := canceler |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.Lwt_canceler.cancel canceler)
      (fun function_parameter =>
        match function_parameter with
        | tt => worker
        end)
  end.

Definition validate
  (state : t) (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  (protocol : Tezos_base__TzPervasives.Protocol.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_updater.Registered_protocol.t) :=
  match Tezos_protocol_updater.Registered_protocol.get hash with
  | Some protocol =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_debug
        (fun f =>
          Tag.DSL.op_minus_percent
            (Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "previously validated protocol " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        " (before pipe)" % string
                        CamlinternalFormatBasics.End_of_format)))
                  "previously validated protocol %a (before pipe)" % string))
              (Tag.DSL.t event "previously_validated_protocol" % string))
            (Tag.DSL.a Tezos_base__TzPervasives.Protocol_hash.Logging.tag hash)))
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives._return protocol
        end)
  | None =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_debug
        (fun f =>
          Tag.DSL.op_minus_percent
            (Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "pushing validation request for protocol " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "pushing validation request for protocol %a" % string))
              (Tag.DSL.t event "pushing_validation_request" % string))
            (Tag.DSL.a Tezos_base__TzPervasives.Protocol_hash.Logging.tag hash)))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          match
            Tezos_base__TzPervasives.Protocol_hash.Map.find_opt hash
              (pending state) with
          | None =>
            match Lwt.task tt with
            | (res, wakener) =>
              let broadcast :=
                equiv_decb
                  (Tezos_base__TzPervasives.Protocol_hash.Map.cardinal
                    (pending state)) 0 in
              set_field;
              if broadcast then
                Lwt_condition.broadcast (request state) tt
              else
                tt;
              res
            end
          | Some (_, res, _) => res
          end
        end)
  end.

Definition fetch_and_compile_protocol
  (pv : t) (peer : option Tezos_base__P2p_peer_id.t)
  (timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
  (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_updater.Registered_protocol.t) :=
  match Tezos_protocol_updater.Registered_protocol.get hash with
  | Some proto => Tezos_base__TzPervasives._return proto
  | None =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.Distributed_db.Protocol.read_opt (db pv) hash)
        (fun function_parameter =>
          match function_parameter with
          | Some protocol => Tezos_base__TzPervasives._return protocol
          | None =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_log_notice
                (fun f =>
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Fetching protocol " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)))
                            "Fetching protocol %a%a" % string))
                        (Tag.DSL.t event "fetching_protocol" % string))
                      (Tag.DSL.a
                        Tezos_base__TzPervasives.Protocol_hash.Logging.tag hash))
                    (Tag.DSL.a
                      Tezos_base__TzPervasives.P2p_peer.Id.Logging.tag_source
                      peer)))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_shell.Distributed_db.Protocol.fetch (db pv) peer timeout
                    hash tt
                end)
          end))
      (fun protocol =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (validate pv hash protocol)
          (fun proto => Tezos_base__TzPervasives._return proto))
  end.

Definition fetch_and_compile_protocols
  (pv : t) (peer : option Tezos_base__P2p_peer_id.t)
  (timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
  (block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let protocol_level := Tezos_shell.State.Block.protocol_level block in
  let chain_state := Tezos_shell.State.Block.chain_state block in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.Block.context block)
    (fun context =>
      let protocol : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_storage.Context.get_protocol context)
          (fun protocol_hash =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (fetch_and_compile_protocol pv peer timeout protocol_hash)
              (fun _p =>
                let chain_id := Tezos_shell.State.Chain.id chain_state in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.State.Chain.update_level_indexed_protocol_store
                    chain_state chain_id protocol_level protocol_hash
                    (Tezos_shell.State.Block.header block))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives.return_unit
                    end)))
      with test_protocol : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_storage.Context.get_test_chain context)
          (fun function_parameter =>
            match function_parameter with
            | Not_running => Tezos_base__TzPervasives.return_unit
            |
              Forking {| protocol := protocol |} |
                Running {| protocol := protocol |} =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (fetch_and_compile_protocol pv peer timeout protocol)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.State.Chain.test chain_state)
                        (fun function_parameter =>
                          match function_parameter with
                          | None => Lwt.return_unit
                          | Some chain_id =>
                            Tezos_shell.State.Chain.update_level_indexed_protocol_store
                              chain_state chain_id protocol_level protocol
                              (Tezos_shell.State.Block.header block)
                          end))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_base__TzPervasives.return_unit
                        end)
                  end)
            end) in
      Tezos_base__TzPervasives.op_gt_gt_eq_question protocol
        (fun function_parameter =>
          match function_parameter with
          | tt => test_protocol
          end)).

Definition prefetch_and_compile_protocols
  (pv : t) (peer : option Tezos_base__P2p_peer_id.t)
  (timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
  (block : Tezos_shell.State.Block.t) : unit := try.
src/lib_shell/protocol_validator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

val create : Distributed_db.t -> t

val validate :
  t -> Protocol_hash.t -> Protocol.t -> Registered_protocol.t tzresult Lwt.t

val shutdown : t -> unit Lwt.t

val fetch_and_compile_protocol :
  t ->
  ?peer:P2p_peer.Id.t ->
  ?timeout:Ptime.Span.t ->
  Protocol_hash.t ->
  Registered_protocol.t tzresult Lwt.t

val fetch_and_compile_protocols :
  t ->
  ?peer:P2p_peer.Id.t ->
  ?timeout:Ptime.Span.t ->
  State.Block.t ->
  unit tzresult Lwt.t

val prefetch_and_compile_protocols :
  t -> ?peer:P2p_peer.Id.t -> ?timeout:Ptime.Span.t -> State.Block.t -> unit
src/lib_shell/protocol_validator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create : Tezos_shell.Distributed_db.t -> t.

Parameter validate :
t ->
  Tezos_base__TzPervasives.Protocol_hash.t ->
    Tezos_base__TzPervasives.Protocol.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_updater.Registered_protocol.t).

Parameter shutdown : t -> Lwt.t unit.

Parameter fetch_and_compile_protocol :
t ->
  (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    (option Ptime.Span.t) ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_updater.Registered_protocol.t).

Parameter fetch_and_compile_protocols :
t ->
  (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    (option Ptime.Span.t) ->
      Tezos_shell.State.Block.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter prefetch_and_compile_protocols :
t ->
  (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    (option Ptime.Span.t) -> Tezos_shell.State.Block.t -> unit.
src/lib_shell/snapshots.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type status =
  | Export_unspecified_hash of Block_hash.t
  | Export_info of History_mode.t * Block_hash.t * Int32.t
  | Export_success of string
  | Set_history_mode of History_mode.t
  | Import_info of string
  | Import_unspecified_hash
  | Import_loading
  | Set_head of Block_hash.t
  | Import_success of string

let status_pp ppf = function
  | Export_unspecified_hash h ->
      Format.fprintf
        ppf
        "There is no block hash specified with the `--block` option. Using %a \
         (last checkpoint)"
        Block_hash.pp
        h
  | Export_info (hm, h, l) ->
      Format.fprintf
        ppf
        "Exporting a snapshot in %a mode, targeting block hash %a at level %a"
        History_mode.pp
        hm
        Block_hash.pp
        h
        Format.pp_print_int
        (Int32.to_int l)
  | Export_success filename ->
      Format.fprintf ppf "@[Successful export: %s@]" filename
  | Set_history_mode hm ->
      Format.fprintf ppf "Setting history-mode to %a" History_mode.pp hm
  | Import_info filename ->
      Format.fprintf ppf "Importing data from snapshot file %s" filename
  | Import_unspecified_hash ->
      Format.fprintf
        ppf
        "You may consider using the --block <block_hash> argument to verify \
         that the block imported is the one you expect"
  | Import_loading ->
      Format.fprintf
        ppf
        "Retrieving and validating data. This can take a while, please bear \
         with us"
  | Set_head h ->
      Format.fprintf ppf "Setting current head to block %a" Block_hash.pp h
  | Import_success filename ->
      Format.fprintf ppf "@[Successful import from file %s@]" filename

type t = status Time.System.stamped

module Definition = struct
  let name = "snapshot"

  type nonrec t = t

  let encoding =
    let open Data_encoding in
    Time.System.stamped_encoding
    @@ union
         [ case
             (Tag 0)
             ~title:"Export_unspecified_hash"
             Block_hash.encoding
             (function Export_unspecified_hash h -> Some h | _ -> None)
             (fun h -> Export_unspecified_hash h);
           case
             (Tag 1)
             ~title:"Export_info"
             (obj3
                (req "history_mode" History_mode.encoding)
                (req "block_hash" Block_hash.encoding)
                (req "level" int32))
             (function Export_info (hm, h, l) -> Some (hm, h, l) | _ -> None)
             (fun (hm, h, l) -> Export_info (hm, h, l));
           case
             (Tag 2)
             ~title:"Export_success"
             string
             (function Export_success s -> Some s | _ -> None)
             (fun s -> Export_success s);
           case
             (Tag 3)
             ~title:"Set_history_mode"
             History_mode.encoding
             (function Set_history_mode hm -> Some hm | _ -> None)
             (fun hm -> Set_history_mode hm);
           case
             (Tag 4)
             ~title:"Import_info"
             string
             (function Import_info s -> Some s | _ -> None)
             (fun s -> Import_info s);
           case
             (Tag 5)
             ~title:"Import_unspecified_hash"
             empty
             (function Import_unspecified_hash -> Some () | _ -> None)
             (fun () -> Import_unspecified_hash);
           case
             (Tag 6)
             ~title:"Import_loading"
             empty
             (function Import_loading -> Some () | _ -> None)
             (fun () -> Import_loading);
           case
             (Tag 7)
             ~title:"Set_head"
             Block_hash.encoding
             (function Set_head h -> Some h | _ -> None)
             (fun h -> Set_head h);
           case
             (Tag 8)
             ~title:"Import_success"
             string
             (function Import_success s -> Some s | _ -> None)
             (fun s -> Import_success s) ]

  let pp ppf (status : t) = Format.fprintf ppf "%a" status_pp status.data

  let doc = "Snapshots status."

  let level (status : t) =
    match status.data with
    | Export_unspecified_hash _
    | Export_info _
    | Export_success _
    | Set_history_mode _
    | Import_info _
    | Import_unspecified_hash
    | Import_loading
    | Set_head _
    | Import_success _ ->
        Internal_event.Notice
end

module Event_snapshot = Internal_event.Make (Definition)

let lwt_emit (status : status) =
  let time = Systime_os.now () in
  Event_snapshot.emit
    ~section:(Internal_event.Section.make_sanitized [Definition.name])
    (fun () -> Time.System.stamp ~time status)
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error el ->
      Format.kasprintf
        Lwt.fail_with
        "Snapshot_event.emit: %a"
        pp_print_error
        el

type error += Wrong_snapshot_export of History_mode.t * History_mode.t

type error +=
  | Wrong_block_export of
      Block_hash.t * [`Pruned | `Too_few_predecessors | `Cannot_be_found]

type error += Inconsistent_imported_block of Block_hash.t * Block_hash.t

type error += Snapshot_import_failure of string

type error += Wrong_protocol_hash of Protocol_hash.t

type error +=
  | Inconsistent_operation_hashes of
      (Operation_list_list_hash.t * Operation_list_list_hash.t)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"WrongSnapshotExport"
    ~title:"Wrong snapshot export"
    ~description:
      "Snapshot exports is not compatible with the current configuration."
    ~pp:(fun ppf (src, dst) ->
      Format.fprintf
        ppf
        "Cannot export a %a snapshot from a %a node."
        History_mode.pp
        dst
        History_mode.pp
        src)
    (obj2 (req "src" History_mode.encoding) (req "dst" History_mode.encoding))
    (function
      | Wrong_snapshot_export (src, dst) -> Some (src, dst) | _ -> None)
    (fun (src, dst) -> Wrong_snapshot_export (src, dst)) ;
  let pp_wrong_block_export_error ppf kind =
    let str =
      match kind with
      | `Pruned ->
          "is pruned"
      | `Too_few_predecessors ->
          "has not enough predecessors"
      | `Cannot_be_found ->
          "cannot be found"
    in
    Format.fprintf ppf "%s" str
  in
  let error_kind_encoding =
    string_enum
      [ ("pruned", `Pruned);
        ("too_few_predecessors", `Too_few_predecessors);
        ("cannot_be_found", `Cannot_be_found) ]
  in
  register_error_kind
    `Permanent
    ~id:"WrongBlockExport"
    ~title:"Wrong block export"
    ~description:"The block to export in the snapshot is not valid."
    ~pp:(fun ppf (bh, kind) ->
      Format.fprintf
        ppf
        "Fails to export snapshot as the block with block hash %a %a."
        Block_hash.pp
        bh
        pp_wrong_block_export_error
        kind)
    (obj2
       (req "block_hash" Block_hash.encoding)
       (req "kind" error_kind_encoding))
    (function Wrong_block_export (bh, kind) -> Some (bh, kind) | _ -> None)
    (fun (bh, kind) -> Wrong_block_export (bh, kind)) ;
  register_error_kind
    `Permanent
    ~id:"InconsistentImportedBlock"
    ~title:"Inconsistent imported block"
    ~description:"The imported block is not the expected one."
    ~pp:(fun ppf (got, exp) ->
      Format.fprintf
        ppf
        "The block contained in the file is %a instead of %a."
        Block_hash.pp
        got
        Block_hash.pp
        exp)
    (obj2
       (req "block_hash" Block_hash.encoding)
       (req "block_hash_expected" Block_hash.encoding))
    (function
      | Inconsistent_imported_block (got, exp) -> Some (got, exp) | _ -> None)
    (fun (got, exp) -> Inconsistent_imported_block (got, exp)) ;
  register_error_kind
    `Permanent
    ~id:"SnapshotImportFailure"
    ~title:"Snapshot import failure"
    ~description:"The imported snapshot is malformed."
    ~pp:(fun ppf msg ->
      Format.fprintf
        ppf
        "The data contained in the snapshot is not valid. The import \
         mechanism failed to validate the file: %s."
        msg)
    (obj1 (req "message" string))
    (function Snapshot_import_failure str -> Some str | _ -> None)
    (fun str -> Snapshot_import_failure str) ;
  register_error_kind
    `Permanent
    ~id:"WrongProtocolHash"
    ~title:"Wrong protocol hash"
    ~description:"Wrong protocol hash"
    ~pp:(fun ppf p ->
      Format.fprintf
        ppf
        "Wrong protocol hash (%a) found in snapshot. Snapshot is corrupted."
        Protocol_hash.pp
        p)
    (obj1 (req "protocol_hash" Protocol_hash.encoding))
    (function Wrong_protocol_hash p -> Some p | _ -> None)
    (fun p -> Wrong_protocol_hash p) ;
  register_error_kind
    `Permanent
    ~id:"InconsistentOperationHashes"
    ~title:"Inconsistent operation hashes"
    ~description:"The operations given do not match their hashes."
    ~pp:(fun ppf (oph, oph') ->
      Format.fprintf
        ppf
        "Inconsistent operation hashes. Expected: %a, got: %a."
        Operation_list_list_hash.pp
        oph
        Operation_list_list_hash.pp
        oph')
    (obj2
       (req "expected_operation_hashes" Operation_list_list_hash.encoding)
       (req "received_operation_hashes" Operation_list_list_hash.encoding))
    (function
      | Inconsistent_operation_hashes (oph, oph') ->
          Some (oph, oph')
      | _ ->
          None)
    (fun (oph, oph') -> Inconsistent_operation_hashes (oph, oph'))

let ( // ) = Filename.concat

let context_dir data_dir = data_dir // "context"

let store_dir data_dir = data_dir // "store"

let compute_export_limit block_store chain_data_store block_header
    export_rolling =
  let block_hash = Block_header.hash block_header in
  Store.Block.Contents.read_opt (block_store, block_hash)
  >>= (function
        | Some contents ->
            return contents
        | None ->
            fail (Wrong_block_export (block_hash, `Pruned)))
  >>=? fun {max_operations_ttl; _} ->
  if not export_rolling then
    Store.Chain_data.Caboose.read chain_data_store
    >>=? fun (caboose_level, _) -> return (max 1l caboose_level)
  else
    let limit =
      Int32.(
        sub block_header.Block_header.shell.level (of_int max_operations_ttl))
    in
    (* fails when the limit exceeds the genesis or the genesis is
       included in the export limit *)
    fail_when
      (limit <= 0l)
      (Wrong_block_export (block_hash, `Too_few_predecessors))
    >>=? fun () -> return limit

(** When called with a block, returns its predecessor if it exists and
    its protocol_data if the block is a transition block (i.e. protocol
    level changing block) or when there is no more predecessor. *)
let pruned_block_iterator index block_store limit header =
  if header.Block_header.shell.level <= limit then
    Context.get_protocol_data_from_header index header
    >>= fun protocol_data -> return (None, Some protocol_data)
  else
    let pred_hash = header.Block_header.shell.predecessor in
    State.Block.Header.read (block_store, pred_hash)
    >>=? fun pred_header ->
    Store.Block.Operations.bindings (block_store, pred_hash)
    >>= fun pred_operations ->
    Store.Block.Operation_hashes.bindings (block_store, pred_hash)
    >>= fun pred_operation_hashes ->
    let pruned_block =
      {
        Context.Pruned_block.block_header = pred_header;
        operations = pred_operations;
        operation_hashes = pred_operation_hashes;
      }
    in
    let header_proto_level = header.Block_header.shell.proto_level in
    let pred_header_proto_level = pred_header.Block_header.shell.proto_level in
    if header_proto_level <> pred_header_proto_level then
      Context.get_protocol_data_from_header index header
      >>= fun proto_data -> return (Some pruned_block, Some proto_data)
    else return (Some pruned_block, None)

let export ?(export_rolling = false) ~context_index ~store ~genesis filename
    block =
  let chain_id = Chain_id.of_block_hash genesis in
  let chain_store = Store.Chain.get store chain_id in
  let chain_data_store = Store.Chain_data.get chain_store in
  let block_store = Store.Block.get chain_store in
  Store.Configuration.History_mode.read_opt store
  >>= (function
        | Some (Archive | Full) | None ->
            return_unit
        | Some (Rolling as history_mode) ->
            if export_rolling then return_unit
            else fail (Wrong_snapshot_export (history_mode, History_mode.Full)))
  >>=? fun () ->
  ( match block with
  | Some block_hash ->
      Lwt.return (Block_hash.of_b58check block_hash)
  | None ->
      Store.Chain_data.Checkpoint.read_opt chain_data_store
      >|= Option.unopt_assert ~loc:__POS__
      >>= fun last_checkpoint ->
      if last_checkpoint.shell.level = 0l then
        fail (Wrong_block_export (genesis, `Too_few_predecessors))
      else
        let last_checkpoint_hash = Block_header.hash last_checkpoint in
        lwt_emit (Export_unspecified_hash last_checkpoint_hash)
        >>= fun () -> return last_checkpoint_hash )
  >>=? fun checkpoint_block_hash ->
  State.Block.Header.read_opt (block_store, checkpoint_block_hash)
  >>= (function
        | None ->
            fail (Wrong_block_export (checkpoint_block_hash, `Cannot_be_found))
        | Some block_header ->
            let export_mode =
              if export_rolling then History_mode.Rolling else Full
            in
            lwt_emit
              (Export_info
                 (export_mode, checkpoint_block_hash, block_header.shell.level))
            >>= fun () ->
            (* Get block precessor's block header *)
            Store.Block.Predecessors.read
              (block_store, checkpoint_block_hash)
              0
            >>=? fun pred_block_hash ->
            State.Block.Header.read (block_store, pred_block_hash)
            >>=? fun pred_block_header ->
            (* Get operation list *)
            let validations_passes = block_header.shell.validation_passes in
            map_s
              (fun i ->
                Store.Block.Operations.read
                  (block_store, checkpoint_block_hash)
                  i)
              (0 -- (validations_passes - 1))
            >>=? fun operations ->
            compute_export_limit
              block_store
              chain_data_store
              block_header
              export_rolling
            >>=? fun export_limit ->
            let iterator =
              pruned_block_iterator context_index block_store export_limit
            in
            let block_data = {Context.Block_data.block_header; operations} in
            return (pred_block_header, block_data, export_mode, iterator))
  >>=? fun data_to_dump ->
  Context.dump_contexts context_index data_to_dump ~filename
  >>=? fun () -> lwt_emit (Export_success filename) >>= fun () -> return_unit

let check_operations_consistency block_header operations operation_hashes =
  (* Compute operations hashes and compare *)
  List.iter2
    (fun (_, op) (_, oph) ->
      let expected_op_hash = List.map Operation.hash op in
      List.iter2
        (fun expected found ->
          assert (Operation_hash.equal expected found) (* paul:here *))
        expected_op_hash
        oph)
    operations
    operation_hashes ;
  (* Check header hashes based on merkel tree *)
  let hashes =
    List.map
      (fun (_, opl) -> List.map Operation.hash opl)
      (List.rev operations)
  in
  let computed_hash =
    Operation_list_list_hash.compute
      (List.map Operation_list_hash.compute hashes)
  in
  let are_oph_equal =
    Operation_list_list_hash.equal
      computed_hash
      block_header.Block_header.shell.operations_hash
  in
  fail_unless
    are_oph_equal
    (Inconsistent_operation_hashes
       (computed_hash, block_header.Block_header.shell.operations_hash))

let compute_predecessors ~genesis_hash oldest_level block_hashes i =
  let rec step s d acc =
    if oldest_level = 1l && i - d = -1 then List.rev ((s, genesis_hash) :: acc)
    else if i - d < 0 then List.rev acc
    else step (s + 1) (d * 2) ((s, block_hashes.(i - d)) :: acc)
  in
  step 0 1 []

let check_context_hash_consistency block_validation_result block_header =
  fail_unless
    (Context_hash.equal
       block_validation_result.Tezos_validation.Block_validation.context_hash
       block_header.Block_header.shell.context)
    (Snapshot_import_failure "resulting context hash does not match")

let set_history_mode store history_mode =
  match history_mode with
  | History_mode.Full | History_mode.Rolling ->
      lwt_emit (Set_history_mode history_mode)
      >>= fun () ->
      Store.Configuration.History_mode.store store history_mode
      >>= fun () -> return_unit
  | History_mode.Archive ->
      fail (Snapshot_import_failure "cannot import an archive context")

let store_new_head chain_state chain_data ~genesis block_header operations
    block_validation_result =
  let ({validation_store; block_metadata; ops_metadata; forking_testchain}
        : Tezos_validation.Block_validation.result) =
    block_validation_result
  in
  State.Block.store
    chain_state
    block_header
    block_metadata
    operations
    ops_metadata
    ~forking_testchain
    validation_store
  >>=? fun new_head ->
  match new_head with
  | None ->
      (* Should not happen as the data-dir must be empty *)
      fail
        (Snapshot_import_failure "a chain head is already present in the store")
  | Some new_head ->
      (* New head is set*)
      Store.Chain_data.Known_heads.remove chain_data genesis
      >>= fun () ->
      Store.Chain_data.Known_heads.store chain_data (State.Block.hash new_head)
      >>= fun () ->
      Store.Chain_data.Current_head.store
        chain_data
        (State.Block.hash new_head)
      >>= fun () -> return_unit

let update_checkpoint chain_state checkpoint_header =
  let block_hash = Block_header.hash checkpoint_header in
  (* Imported block is set as the current checkpoint/save_point … *)
  let new_checkpoint =
    (checkpoint_header.Block_header.shell.level, block_hash)
  in
  State.Chain.set_checkpoint chain_state checkpoint_header
  >>= fun () -> Lwt.return new_checkpoint

let update_savepoint chain_state new_savepoint =
  State.update_chain_data chain_state (fun store data ->
      let new_data = {data with save_point = new_savepoint} in
      Store.Chain_data.Save_point.store store new_savepoint
      >>= fun () -> Lwt.return (Some new_data, ()))

let update_caboose chain_data ~genesis block_header oldest_header max_op_ttl =
  let oldest_level = oldest_header.Block_header.shell.level in
  let caboose_level = if oldest_level = 1l then 0l else oldest_level in
  let caboose_hash =
    if oldest_level = 1l then genesis else Block_header.hash oldest_header
  in
  let minimal_caboose_level =
    Int32.(sub block_header.Block_header.shell.level (of_int max_op_ttl))
  in
  fail_unless
    Compare.Int32.(caboose_level <= minimal_caboose_level)
    (Snapshot_import_failure
       (Format.sprintf "caboose level (%ld) is not valid" caboose_level))
  >>=? fun () ->
  Store.Chain_data.Caboose.store chain_data (caboose_level, caboose_hash)
  >>= fun () -> return_unit

let import_protocol_data index store block_hash_arr level_oldest_block
    (level, protocol_data) =
  (* Retrieve the original context hash of the block. *)
  let delta = Int32.(to_int (sub level level_oldest_block)) in
  let pruned_block_hash = block_hash_arr.(delta) in
  let block_store = Store.Block.get store in
  State.Block.Header.read_opt (block_store, pruned_block_hash)
  >>= (function
        | None -> assert false | Some block_header -> Lwt.return block_header)
  >>= fun block_header ->
  let expected_context_hash = block_header.Block_header.shell.context in
  (* Retrieve the input info. *)
  let info = protocol_data.Context.Protocol_data.info in
  let test_chain = protocol_data.test_chain_status in
  let data_hash = protocol_data.data_key in
  let parents = protocol_data.parents in
  let protocol_hash = protocol_data.protocol_hash in
  (* Validate the context hash consistency, and so the protocol data. *)
  Context.validate_context_hash_consistency_and_commit
    ~author:info.author
    ~timestamp:info.timestamp
    ~message:info.message
    ~data_hash
    ~parents
    ~expected_context_hash
    ~test_chain
    ~protocol_hash
    ~index
  >>= function
  | true ->
      let protocol_level = block_header.shell.proto_level in
      let block_level = block_header.shell.level in
      Store.Chain.Protocol_info.store
        store
        protocol_level
        (protocol_hash, block_level)
      >>= fun () -> return_unit
  | false ->
      fail (Wrong_protocol_hash protocol_hash)

let import_protocol_data_list index store block_hash_arr level_oldest_block
    protocol_data =
  let rec aux = function
    | [] ->
        return_unit
    | (level, protocol_data) :: xs ->
        import_protocol_data
          index
          store
          block_hash_arr
          level_oldest_block
          (level, protocol_data)
        >>=? fun () -> aux xs
  in
  aux protocol_data

let verify_predecessors header_opt pred_hash =
  match header_opt with
  | None ->
      return_unit
  | Some header ->
      fail_unless
        ( header.Block_header.shell.level >= 2l
        && Block_hash.equal header.shell.predecessor pred_hash )
        (Snapshot_import_failure "inconsistent predecessors")

let verify_oldest_header oldest_header genesis_hash =
  let oldest_level = oldest_header.Block_header.shell.level in
  fail_unless
    ( oldest_level >= 1l
    || Compare.Int32.(oldest_level = 1l)
       && Block_hash.equal
            oldest_header.Block_header.shell.predecessor
            genesis_hash )
    (Snapshot_import_failure "inconsistent oldest level")

let block_validation succ_header_opt header_hash
    {Context.Pruned_block.block_header; operations; operation_hashes} =
  verify_predecessors succ_header_opt header_hash
  >>=? fun () ->
  check_operations_consistency block_header operations operation_hashes
  >>=? fun () -> return_unit

let import ~data_dir ~dir_cleaner ~patch_context ~genesis filename block =
  lwt_emit (Import_info filename)
  >>= fun () ->
  ( match block with
  | None ->
      lwt_emit Import_unspecified_hash
  | Some _ ->
      Lwt.return_unit )
  >>= fun () ->
  lwt_emit Import_loading
  >>= fun () ->
  let context_root = context_dir data_dir in
  let store_root = store_dir data_dir in
  let chain_id = Chain_id.of_block_hash genesis.State.Chain.block in
  (* FIXME: use config value ? *)
  State.init
    ~context_root
    ~store_root
    genesis
    ~patch_context:(patch_context None)
  >>=? fun (state, chain_state, context_index, _history_mode) ->
  Store.init store_root
  >>=? fun store ->
  let chain_store = Store.Chain.get store chain_id in
  let chain_data = Store.Chain_data.get chain_store in
  let block_store = Store.Block.get chain_store in
  let open Context in
  Lwt.try_bind
    (fun () ->
      let k_store_pruned_blocks data =
        Store.with_atomic_rw store (fun () ->
            Error_monad.iter_s
              (fun (pruned_header_hash, pruned_block) ->
                Store.Block.Pruned_contents.store
                  (block_store, pruned_header_hash)
                  {header = pruned_block.Context.Pruned_block.block_header}
                >>= fun () ->
                Lwt_list.iter_s
                  (fun (i, v) ->
                    Store.Block.Operations.store
                      (block_store, pruned_header_hash)
                      i
                      v)
                  pruned_block.operations
                >>= fun () ->
                Lwt_list.iter_s
                  (fun (i, v) ->
                    Store.Block.Operation_hashes.store
                      (block_store, pruned_header_hash)
                      i
                      v)
                  pruned_block.operation_hashes
                >>= fun () -> return_unit)
              data)
      in
      (* Restore context and fetch data *)
      restore_contexts
        context_index
        ~filename
        k_store_pruned_blocks
        block_validation
      >>=? fun ( predecessor_block_header,
                 meta,
                 history_mode,
                 oldest_header_opt,
                 rev_block_hashes,
                 protocol_data ) ->
      let oldest_header = Option.unopt_assert ~loc:__POS__ oldest_header_opt in
      let block_hashes_arr = Array.of_list rev_block_hashes in
      let write_predecessors_table to_write =
        Store.with_atomic_rw store (fun () ->
            Lwt_list.iter_s
              (fun (current_hash, predecessors_list) ->
                Lwt_list.iter_s
                  (fun (l, h) ->
                    Store.Block.Predecessors.store
                      (block_store, current_hash)
                      l
                      h)
                  predecessors_list
                >>= fun () ->
                match predecessors_list with
                | (0, pred_hash) :: _ ->
                    Store.Chain_data.In_main_branch.store
                      (chain_data, pred_hash)
                      current_hash
                | [] ->
                    Lwt.return_unit
                | _ :: _ ->
                    assert false)
              to_write)
      in
      Lwt_list.fold_left_s
        (fun (cpt, to_write) current_hash ->
          Tezos_stdlib_unix.Utils.display_progress
            ~refresh_rate:(cpt, 1_000)
            "Computing predecessors table %dK elements%!"
            (cpt / 1_000) ;
          ( if (cpt + 1) mod 5_000 = 0 then
            write_predecessors_table to_write >>= fun () -> Lwt.return_nil
          else Lwt.return to_write )
          >>= fun to_write ->
          let predecessors_list =
            compute_predecessors
              ~genesis_hash:genesis.block
              oldest_header.shell.level
              block_hashes_arr
              cpt
          in
          Lwt.return (cpt + 1, (current_hash, predecessors_list) :: to_write))
        (0, [])
        rev_block_hashes
      >>= fun (_, to_write) ->
      write_predecessors_table to_write
      >>= fun () ->
      Tezos_stdlib_unix.Utils.display_progress_end () ;
      (* Process data imported from snapshot *)
      let {Block_data.block_header; operations} = meta in
      let block_hash = Block_header.hash block_header in
      (* Checks that the block hash imported by the snapshot is the expected one *)
      ( match block with
      | Some str ->
          let bh = Block_hash.of_b58check_exn str in
          fail_unless
            (Block_hash.equal bh block_hash)
            (Inconsistent_imported_block (bh, block_hash))
      | None ->
          return_unit )
      >>=? fun () ->
      lwt_emit (Set_head (Block_header.hash block_header))
      >>= fun () ->
      let pred_context_hash = predecessor_block_header.shell.context in
      checkout_exn context_index pred_context_hash
      >>= fun predecessor_context ->
      (* ... we can now call apply ... *)
      Tezos_validation.Block_validation.apply
        chain_id
        ~max_operations_ttl:(Int32.to_int predecessor_block_header.shell.level)
        ~predecessor_block_header
        ~predecessor_context
        ~block_header
        operations
      >>=? fun block_validation_result ->
      check_context_hash_consistency
        block_validation_result.validation_store
        block_header
      >>=? fun () ->
      verify_oldest_header oldest_header genesis.block
      >>=? fun () ->
      (* ... we set the history mode regarding the snapshot version hint ... *)
      set_history_mode store history_mode
      >>=? fun () ->
      (* ... and we import protocol data...*)
      import_protocol_data_list
        context_index
        chain_store
        block_hashes_arr
        oldest_header.Block_header.shell.level
        protocol_data
      >>=? fun () ->
      (* Everything is ok. We can store the new head *)
      store_new_head
        chain_state
        chain_data
        ~genesis:genesis.block
        block_header
        operations
        block_validation_result
      >>=? fun () ->
      (* Update history mode flags *)
      update_checkpoint chain_state block_header
      >>= fun new_checkpoint ->
      update_savepoint chain_state new_checkpoint
      >>= fun () ->
      update_caboose
        chain_data
        ~genesis:genesis.block
        block_header
        oldest_header
        block_validation_result.validation_store.max_operations_ttl
      >>=? fun () ->
      Store.close store ;
      State.close state >>= fun () -> return_unit)
    (function
      | Ok () ->
          lwt_emit (Import_success filename) >>= fun () -> return_unit
      | Error errors ->
          dir_cleaner data_dir >>= fun () -> Lwt.return (Error errors))
    (fun exn -> dir_cleaner data_dir >>= fun () -> Lwt.fail exn)
src/lib_shell/snapshots.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive status : Type :=
| Export_unspecified_hash : Tezos_base__TzPervasives.Block_hash.t -> status
| Export_info : Tezos_shell_services.History_mode.t ->
  Tezos_base__TzPervasives.Block_hash.t -> Stdlib.Int32.t -> status
| Export_success : string -> status
| Set_history_mode : Tezos_shell_services.History_mode.t -> status
| Import_info : string -> status
| Import_unspecified_hash : status
| Import_loading : status
| Set_head : Tezos_base__TzPervasives.Block_hash.t -> status
| Import_success : string -> status.

Definition status_pp
  (ppf : Stdlib.Format.formatter) (function_parameter : status) : unit :=
  match function_parameter with
  | Export_unspecified_hash h =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "There is no block hash specified with the `--block` option. Using " %
            string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " (last checkpoint)" % string
              CamlinternalFormatBasics.End_of_format)))
        "There is no block hash specified with the `--block` option. Using %a (last checkpoint)"
          % string) Tezos_base__TzPervasives.Block_hash.pp h
  | Export_info hm h l =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Exporting a snapshot in " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " mode, targeting block hash " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " at level " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))))))
        "Exporting a snapshot in %a mode, targeting block hash %a at level %a" %
          string) Tezos_shell_services.History_mode.pp hm
      Tezos_base__TzPervasives.Block_hash.pp h Stdlib.Format.pp_print_int
      (Stdlib.Int32.to_int l)
  | Export_success filename =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.String_literal
            "Successful export: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format))))
        "@[Successful export: %s@]" % string) filename
  | Set_history_mode hm =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Setting history-mode to " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Setting history-mode to %a" % string)
      Tezos_shell_services.History_mode.pp hm
  | Import_info filename =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Importing data from snapshot file " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format))
        "Importing data from snapshot file %s" % string) filename
  | Import_unspecified_hash =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "You may consider using the --block <block_hash> argument to verify that the block imported is the one you expect"
            % string CamlinternalFormatBasics.End_of_format)
        "You may consider using the --block <block_hash> argument to verify that the block imported is the one you expect"
          % string)
  | Import_loading =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Retrieving and validating data. This can take a while, please bear with us"
            % string CamlinternalFormatBasics.End_of_format)
        "Retrieving and validating data. This can take a while, please bear with us"
          % string)
  | Set_head h =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Setting current head to block " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Setting current head to block %a" % string)
      Tezos_base__TzPervasives.Block_hash.pp h
  | Import_success filename =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.String_literal
            "Successful import from file " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format))))
        "@[Successful import from file %s@]" % string) filename
  end.

Definition t := Tezos_base__TzPervasives.Time.System.stamped status.

Module Definition.
  Definition name : string := "snapshot" % string.
  
  Definition t := t.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.t
      (Tezos_base__TzPervasives.Time.System.stamped status) :=
    apply Tezos_base__TzPervasives.Time.System.stamped_encoding
      (Tezos_base__TzPervasives.Data_encoding.union None
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case
            "Export_unspecified_hash" % string None (Tag 0)
            Tezos_base__TzPervasives.Block_hash.encoding
            (fun function_parameter =>
              match function_parameter with
              | Export_unspecified_hash h => Some h
              | _ => None
              end) (fun h => Export_unspecified_hash h))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case "Export_info" % string
              None (Tag 1)
              (Tezos_base__TzPervasives.Data_encoding.obj3
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "history_mode" % string
                  Tezos_shell_services.History_mode.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "block_hash" % string
                  Tezos_base__TzPervasives.Block_hash.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "level" % string Tezos_base__TzPervasives.Data_encoding.int32))
              (fun function_parameter =>
                match function_parameter with
                | Export_info hm h l => Some (hm, h, l)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (hm, h, l) => Export_info hm h l
                end))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case
                "Export_success" % string None (Tag 2)
                Tezos_base__TzPervasives.Data_encoding.string
                (fun function_parameter =>
                  match function_parameter with
                  | Export_success s => Some s
                  | _ => None
                  end) (fun s => Export_success s))
              (cons
                (Tezos_base__TzPervasives.Data_encoding.case
                  "Set_history_mode" % string None (Tag 3)
                  Tezos_shell_services.History_mode.encoding
                  (fun function_parameter =>
                    match function_parameter with
                    | Set_history_mode hm => Some hm
                    | _ => None
                    end) (fun hm => Set_history_mode hm))
                (cons
                  (Tezos_base__TzPervasives.Data_encoding.case
                    "Import_info" % string None (Tag 4)
                    Tezos_base__TzPervasives.Data_encoding.string
                    (fun function_parameter =>
                      match function_parameter with
                      | Import_info s => Some s
                      | _ => None
                      end) (fun s => Import_info s))
                  (cons
                    (Tezos_base__TzPervasives.Data_encoding.case
                      "Import_unspecified_hash" % string None (Tag 5)
                      Tezos_base__TzPervasives.Data_encoding.empty
                      (fun function_parameter =>
                        match function_parameter with
                        | Import_unspecified_hash => Some tt
                        | _ => None
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Import_unspecified_hash
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Data_encoding.case
                        "Import_loading" % string None (Tag 6)
                        Tezos_base__TzPervasives.Data_encoding.empty
                        (fun function_parameter =>
                          match function_parameter with
                          | Import_loading => Some tt
                          | _ => None
                          end)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Import_loading
                          end))
                      (cons
                        (Tezos_base__TzPervasives.Data_encoding.case
                          "Set_head" % string None (Tag 7)
                          Tezos_base__TzPervasives.Block_hash.encoding
                          (fun function_parameter =>
                            match function_parameter with
                            | Set_head h => Some h
                            | _ => None
                            end) (fun h => Set_head h))
                        (cons
                          (Tezos_base__TzPervasives.Data_encoding.case
                            "Import_success" % string None (Tag 8)
                            Tezos_base__TzPervasives.Data_encoding.string
                            (fun function_parameter =>
                              match function_parameter with
                              | Import_success s => Some s
                              | _ => None
                              end) (fun s => Import_success s)) [])))))))))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (status : t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) status_pp (data status).
  
  Definition doc : string := "Snapshots status." % string.
  
  Definition level (status : t)
    : Tezos_base__TzPervasives.Internal_event.level :=
    match data status with
    |
      Export_unspecified_hash _ | Export_info _ _ _ | Export_success _ |
        Set_history_mode _ | Import_info _ | Import_unspecified_hash |
        Import_loading | Set_head _ | Import_success _ => Internal_event.Notice
    end.
End Definition.

Definition lwt_emit (status : status) : Lwt.t unit :=
  let time := Tezos_stdlib_unix.Systime_os.now tt in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Event_snapshot.emit
      (Some
        (Tezos_base__TzPervasives.Internal_event.Section.make_sanitized
          (cons
            Definition.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
            [])))
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives.Time.System.stamp time status
        end))
    (fun function_parameter =>
      match function_parameter with
      | inl tt => Lwt.return_unit
      | inr el =>
        Stdlib.Format.kasprintf Lwt.fail_with
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Snapshot_event.emit: " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Snapshot_event.emit: %a" % string)
          Tezos_base__TzPervasives.pp_print_error el
      end).

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition context_dir (data_dir : string) : string :=
  op_div_div data_dir "context" % string.

Definition store_dir (data_dir : string) : string :=
  op_div_div data_dir "store" % string.

Definition compute_export_limit
  (block_store : Tezos_shell__Store.Block.store)
  (chain_data_store : Tezos_shell__Store.Chain_data.store)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (export_rolling : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Int32.t) :=
  let block_hash := Tezos_base__TzPervasives.Block_header.hash block_header in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Store.Block.Contents.read_opt (block_store, block_hash))
      (fun function_parameter =>
        match function_parameter with
        | Some contents => Tezos_base__TzPervasives._return contents
        | None =>
          Tezos_base__TzPervasives.fail (Wrong_block_export block_hash variant)
        end))
    (fun function_parameter =>
      match function_parameter with
      | {| max_operations_ttl := max_operations_ttl |} =>
        if negb export_rolling then
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_shell.Store.Chain_data.Caboose.read chain_data_store)
            (fun function_parameter =>
              match function_parameter with
              | (caboose_level, _) =>
                Tezos_base__TzPervasives._return
                  (OCaml.Stdlib.max 1 caboose_level)
              end)
        else
          let limit :=
            Stdlib.Int32.sub (level (Block_header.shell block_header))
              (Stdlib.Int32.of_int max_operations_ttl) in
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_base__TzPervasives.fail_when (OCaml.Stdlib.le limit 0)
              (Wrong_block_export block_hash variant))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives._return limit
              end)
      end).

Definition pruned_block_iterator
  (index : Tezos_storage.Context.index)
  (block_store : Tezos_shell.Store.Block.store) (limit : Stdlib.Int32.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((option Tezos_storage.Context.Pruned_block.t) *
        (option Tezos_storage.Context.Protocol_data.t))) :=
  if OCaml.Stdlib.le (level (Block_header.shell header)) limit then
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_storage.Context.get_protocol_data_from_header index header)
      (fun protocol_data =>
        Tezos_base__TzPervasives._return (None, (Some protocol_data)))
  else
    let pred_hash := predecessor (Block_header.shell header) in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_shell.State.Block.Header.read (block_store, pred_hash))
      (fun pred_header =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Block.Operations.bindings (block_store, pred_hash))
          (fun pred_operations =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.Store.Block.Operation_hashes.bindings
                (block_store, pred_hash))
              (fun pred_operation_hashes =>
                let pruned_block :=
                  {| Context.Pruned_block.block_header := pred_header;
                    Context.Pruned_block.operations := pred_operations;
                    Context.Pruned_block.operation_hashes :=
                      pred_operation_hashes |} in
                let header_proto_level :=
                  proto_level (Block_header.shell header) in
                let pred_header_proto_level :=
                  proto_level (Block_header.shell pred_header) in
                if nequiv_decb header_proto_level pred_header_proto_level then
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_storage.Context.get_protocol_data_from_header index
                      header)
                    (fun proto_data =>
                      Tezos_base__TzPervasives._return
                        ((Some pruned_block), (Some proto_data)))
                else
                  Tezos_base__TzPervasives._return ((Some pruned_block), None)))).

Definition export (op_star_o_p_t_star : option bool)
  : Tezos_storage.Context.index ->
    Tezos_shell__Store.global_store ->
      Tezos_crypto.Block_hash.t ->
        string ->
          (option string) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let export_rolling :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun context_index =>
    fun store =>
      fun genesis =>
        fun filename =>
          fun block =>
            let chain_id :=
              Tezos_base__TzPervasives.Chain_id.of_block_hash genesis in
            let chain_store := Tezos_shell.Store.Chain.get store chain_id in
            let chain_data_store := Tezos_shell.Store.Chain_data.get chain_store
              in
            let block_store := Tezos_shell.Store.Block.get chain_store in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Store.Configuration.History_mode.read_opt store)
                (fun function_parameter =>
                  match function_parameter with
                  | Some (Archive | Full) | None =>
                    Tezos_base__TzPervasives.return_unit
                  | Some (Rolling as history_mode) =>
                    if export_rolling then
                      Tezos_base__TzPervasives.return_unit
                    else
                      Tezos_base__TzPervasives.fail
                        (Wrong_snapshot_export history_mode History_mode.Full)
                  end))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    match block with
                    | Some block_hash =>
                      Lwt._return
                        (Tezos_base__TzPervasives.Block_hash.of_b58check
                          block_hash)
                    | None =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_base__TzPervasives.op_gt_pipe_eq
                          (Tezos_shell.Store.Chain_data.Checkpoint.read_opt
                            chain_data_store)
                          (Tezos_base__TzPervasives.Option.unopt_assert
                            Stdlib.__POS__))
                        (fun last_checkpoint =>
                          if equiv_decb (level (shell last_checkpoint)) 0 then
                            Tezos_base__TzPervasives.fail
                              (Wrong_block_export genesis variant)
                          else
                            let last_checkpoint_hash :=
                              Tezos_base__TzPervasives.Block_header.hash
                                last_checkpoint in
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (lwt_emit
                                (Export_unspecified_hash last_checkpoint_hash))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives._return
                                    last_checkpoint_hash
                                end))
                    end
                    (fun checkpoint_block_hash =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_shell.State.Block.Header.read_opt
                            (block_store, checkpoint_block_hash))
                          (fun function_parameter =>
                            match function_parameter with
                            | None =>
                              Tezos_base__TzPervasives.fail
                                (Wrong_block_export checkpoint_block_hash
                                  variant)
                            | Some block_header =>
                              let export_mode :=
                                if export_rolling then
                                  History_mode.Rolling
                                else
                                  Full in
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (lwt_emit
                                  (Export_info export_mode checkpoint_block_hash
                                    (level (shell block_header))))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_shell.Store.Block.Predecessors.read
                                        (block_store, checkpoint_block_hash) 0)
                                      (fun pred_block_hash =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_shell.State.Block.Header.read
                                            (block_store, pred_block_hash))
                                          (fun pred_block_header =>
                                            let validations_passes :=
                                              validation_passes
                                                (shell block_header) in
                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                              (Tezos_base__TzPervasives.map_s
                                                (fun i =>
                                                  Tezos_shell.Store.Block.Operations.read
                                                    (block_store,
                                                      checkpoint_block_hash) i)
                                                (Tezos_base__TzPervasives.op_minus_minus
                                                  0 (Z.sub validations_passes 1)))
                                              (fun operations =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (compute_export_limit
                                                    block_store chain_data_store
                                                    block_header export_rolling)
                                                  (fun export_limit =>
                                                    let iterator :=
                                                      pruned_block_iterator
                                                        context_index
                                                        block_store export_limit
                                                      in
                                                    let block_data :=
                                                      {|
                                                        Context.Block_data.block_header :=
                                                          block_header;
                                                        Context.Block_data.operations :=
                                                          operations |} in
                                                    Tezos_base__TzPervasives._return
                                                      (pred_block_header,
                                                        block_data, export_mode,
                                                        iterator)))))
                                  end)
                            end))
                        (fun data_to_dump =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_storage.Context.dump_contexts context_index
                              data_to_dump filename)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (lwt_emit (Export_success filename))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end)
                              end)))
                end).

Definition check_operations_consistency {A B : Type}
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (A * (list Tezos_base__TzPervasives.Operation.t)))
  (operation_hashes :
    list (B * (list Tezos_base__TzPervasives.Operation_hash.t)))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.List.iter2
    (fun function_parameter =>
      match function_parameter with
      | (_, op) =>
        fun function_parameter =>
          match function_parameter with
          | (_, oph) =>
            let expected_op_hash :=
              Tezos_base__TzPervasives.List.map
                Tezos_base__TzPervasives.Operation.hash op in
            Tezos_base__TzPervasives.List.iter2
              (fun expected =>
                fun found =>
                  Tezos_base__TzPervasives.Operation_hash.equal expected found)
              expected_op_hash oph
          end
      end) operations operation_hashes;
  let hashes :=
    Tezos_base__TzPervasives.List.map
      (fun function_parameter =>
        match function_parameter with
        | (_, opl) =>
          Tezos_base__TzPervasives.List.map
            Tezos_base__TzPervasives.Operation.hash opl
        end) (Tezos_base__TzPervasives.List.rev operations) in
  let computed_hash :=
    Tezos_base__TzPervasives.Operation_list_list_hash.compute
      (Tezos_base__TzPervasives.List.map
        Tezos_base__TzPervasives.Operation_list_hash.compute hashes) in
  let are_oph_equal :=
    Tezos_base__TzPervasives.Operation_list_list_hash.equal computed_hash
      (operations_hash (Block_header.shell block_header)) in
  Tezos_base__TzPervasives.fail_unless are_oph_equal
    (Inconsistent_operation_hashes
      (computed_hash, (operations_hash (Block_header.shell block_header)))).

Definition compute_predecessors {A : Type}
  (genesis_hash : A) (oldest_level : int32) (block_hashes : array A) (i : Z)
  : list (Z * A) :=
  let fix step (s : Z) (d : Z) (acc : list (Z * A)) : list (Z * A) :=
    if andb (equiv_decb oldest_level 1) (equiv_decb (Z.sub i d) (-1)) then
      Tezos_base__TzPervasives.List.rev (cons (s, genesis_hash) acc)
    else
      if OCaml.Stdlib.lt (Z.sub i d) 0 then
        Tezos_base__TzPervasives.List.rev acc
      else
        step (Z.add s 1) (Z.mul d 2)
          (cons (s, (Stdlib.Array.get block_hashes (Z.sub i d))) acc) in
  step 0 1 [].

Definition check_context_hash_consistency
  (block_validation_result : Tezos_validation.Block_validation.validation_store)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.fail_unless
    (Tezos_base__TzPervasives.Context_hash.equal
      (Tezos_validation.Block_validation.context_hash block_validation_result)
      (context (Block_header.shell block_header)))
    (Snapshot_import_failure "resulting context hash does not match" % string).

Definition set_history_mode
  (store : Tezos_shell__Store.global_store)
  (history_mode : Tezos_shell_services.History_mode.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match history_mode with
  | History_mode.Full | History_mode.Rolling =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_emit (Set_history_mode history_mode))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.Store.Configuration.History_mode.store store
              history_mode)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        end)
  | History_mode.Archive =>
    Tezos_base__TzPervasives.fail
      (Snapshot_import_failure "cannot import an archive context" % string)
  end.

Definition store_new_head
  (chain_state : Tezos_shell__State.Chain.t)
  (chain_data : Tezos_shell__Store.Chain_data.store)
  (genesis : Tezos_base__TzPervasives.Block_hash.t)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  (block_validation_result : Tezos_validation.Block_validation.result)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match block_validation_result with
  | {|
    validation_store := validation_store;
      block_metadata := block_metadata;
      ops_metadata := ops_metadata;
      forking_testchain := forking_testchain
      |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_shell.State.Block.store None chain_state block_header
        block_metadata operations ops_metadata validation_store
        forking_testchain)
      (fun new_head =>
        match new_head with
        | None =>
          Tezos_base__TzPervasives.fail
            (Snapshot_import_failure
              "a chain head is already present in the store" % string)
        | Some new_head =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.Store.Chain_data.Known_heads.remove chain_data genesis)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Store.Chain_data.Known_heads.store chain_data
                    (Tezos_shell.State.Block.hash new_head))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.Store.Chain_data.Current_head.store
                          chain_data (Tezos_shell.State.Block.hash new_head))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives.return_unit
                          end)
                    end)
              end)
        end)
  end.

Definition update_checkpoint
  (chain_state : Tezos_shell.State.Chain.chain_state)
  (checkpoint_header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Stdlib.Int32.t * Tezos_crypto.Block_hash.t) :=
  let block_hash := Tezos_base__TzPervasives.Block_header.hash checkpoint_header
    in
  let new_checkpoint :=
    ((level (Block_header.shell checkpoint_header)), block_hash) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint chain_state checkpoint_header)
    (fun function_parameter =>
      match function_parameter with
      | tt => Lwt._return new_checkpoint
      end).

Definition update_savepoint
  (chain_state : Tezos_shell.State.Chain.t)
  (new_savepoint : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t unit :=
  Tezos_shell.State.update_chain_data chain_state
    (fun store =>
      fun data =>
        let new_data := record in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Chain_data.Save_point.store store new_savepoint)
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt._return ((Some new_data), tt)
            end)).

Definition update_caboose
  (chain_data : Tezos_shell__Store.Chain_data.store)
  (genesis : Tezos_crypto.Block_hash.t)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (oldest_header : Tezos_base__TzPervasives.Block_header.t) (max_op_ttl : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let oldest_level := level (Block_header.shell oldest_header) in
  let caboose_level :=
    if equiv_decb oldest_level 1 then
      0
    else
      oldest_level in
  let caboose_hash :=
    if equiv_decb oldest_level 1 then
      genesis
    else
      Tezos_base__TzPervasives.Block_header.hash oldest_header in
  let minimal_caboose_level :=
    Stdlib.Int32.sub (level (Block_header.shell block_header))
      (Stdlib.Int32.of_int max_op_ttl) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.fail_unless
      (Tezos_base__TzPervasives.Compare.Int32.op_lt_eq caboose_level
        minimal_caboose_level)
      (Snapshot_import_failure
        (Stdlib.Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "caboose level (" % string
              (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal
                  ") is not valid" % string
                  CamlinternalFormatBasics.End_of_format)))
            "caboose level (%ld) is not valid" % string) caboose_level)))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Chain_data.Caboose.store chain_data
            (caboose_level, caboose_hash))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition import_protocol_data
  (index : Tezos_storage.Context.index) (store : Tezos_shell__Store.Chain.store)
  (block_hash_arr : array Tezos_base__TzPervasives.Block_hash.t)
  (level_oldest_block : int32)
  (function_parameter : int32 * Tezos_storage.Context.Protocol_data.data)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | (level, protocol_data) =>
    let delta := Stdlib.Int32.to_int (Stdlib.Int32.sub level level_oldest_block)
      in
    let pruned_block_hash := Stdlib.Array.get block_hash_arr delta in
    let block_store := Tezos_shell.Store.Block.get store in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.Header.read_opt
          (block_store, pruned_block_hash))
        (fun function_parameter =>
          match function_parameter with
          | None => false
          | Some block_header => Lwt._return block_header
          end))
      (fun block_header =>
        let expected_context_hash := context (Block_header.shell block_header)
          in
        let info := Context.Protocol_data.info protocol_data in
        let test_chain := test_chain_status protocol_data in
        let data_hash := data_key protocol_data in
        let parents := parents protocol_data in
        let protocol_hash := protocol_hash protocol_data in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_storage.Context.validate_context_hash_consistency_and_commit
            data_hash expected_context_hash (timestamp info) test_chain
            protocol_hash (message info) (author info) parents index)
          (fun function_parameter =>
            match function_parameter with
            | true =>
              let protocol_level := proto_level (shell block_header) in
              let block_level := level (shell block_header) in
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Store.Chain.Protocol_info.store store
                  protocol_level (protocol_hash, block_level))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            | false =>
              Tezos_base__TzPervasives.fail (Wrong_protocol_hash protocol_hash)
            end))
  end.

Definition import_protocol_data_list
  (index : Tezos_storage.Context.index) (store : Tezos_shell__Store.Chain.store)
  (block_hash_arr : array Tezos_base__TzPervasives.Block_hash.t)
  (level_oldest_block : int32)
  (protocol_data : list (int32 * Tezos_storage.Context.Protocol_data.data))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let fix aux
    (function_parameter :
    list (int32 * Tezos_storage.Context.Protocol_data.data))
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    match function_parameter with
    | [] => Tezos_base__TzPervasives.return_unit
    | cons (level, protocol_data) xs =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (import_protocol_data index store block_hash_arr level_oldest_block
          (level, protocol_data))
        (fun function_parameter =>
          match function_parameter with
          | tt => aux xs
          end)
    end in
  aux protocol_data.

Definition verify_predecessors
  (header_opt : option Tezos_base__TzPervasives.Block_header.t)
  (pred_hash : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match header_opt with
  | None => Tezos_base__TzPervasives.return_unit
  | Some header =>
    Tezos_base__TzPervasives.fail_unless
      (andb (OCaml.Stdlib.ge (level (Block_header.shell header)) 2)
        (Tezos_base__TzPervasives.Block_hash.equal (predecessor (shell header))
          pred_hash))
      (Snapshot_import_failure "inconsistent predecessors" % string)
  end.

Definition verify_oldest_header
  (oldest_header : Tezos_base__TzPervasives.Block_header.t)
  (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let oldest_level := level (Block_header.shell oldest_header) in
  Tezos_base__TzPervasives.fail_unless
    (orb (OCaml.Stdlib.ge oldest_level 1)
      (andb (Tezos_base__TzPervasives.Compare.Int32.op_eq oldest_level 1)
        (Tezos_base__TzPervasives.Block_hash.equal
          (predecessor (Block_header.shell oldest_header)) genesis_hash)))
    (Snapshot_import_failure "inconsistent oldest level" % string).

Definition block_validation
  (succ_header_opt : option Tezos_base__TzPervasives.Block_header.t)
  (header_hash : Tezos_base__TzPervasives.Block_hash.t)
  (function_parameter : Tezos_storage.Context.Pruned_block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {|
    Context.Pruned_block.block_header := block_header;
      Context.Pruned_block.operations := operations;
      Context.Pruned_block.operation_hashes := operation_hashes
      |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (verify_predecessors succ_header_opt header_hash)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (check_operations_consistency block_header operations
              operation_hashes)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        end)
  end.

Definition import {A : Type}
  (data_dir : string) (dir_cleaner : string -> Lwt.t unit)
  (patch_context :
    (option A) -> Tezos_storage.Context.t -> Lwt.t Tezos_storage.Context.t)
  (genesis : Tezos_shell.State.Chain.genesis) (filename : string)
  (block : option string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (lwt_emit (Import_info filename))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          match block with
          | None => lwt_emit Import_unspecified_hash
          | Some _ => Lwt.return_unit
          end
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq (lwt_emit Import_loading)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    let context_root := context_dir data_dir in
                    let store_root := store_dir data_dir in
                    let chain_id :=
                      Tezos_base__TzPervasives.Chain_id.of_block_hash
                        (State.Chain.block genesis) in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell.State.init (Some (patch_context None)) None
                        None None store_root context_root None genesis)
                      (fun function_parameter =>
                        match function_parameter with
                        | (state, chain_state, context_index, _history_mode) =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_shell.Store.init None None store_root)
                            (fun store =>
                              let chain_store :=
                                Tezos_shell.Store.Chain.get store chain_id in
                              let chain_data :=
                                Tezos_shell.Store.Chain_data.get chain_store in
                              let block_store :=
                                Tezos_shell.Store.Block.get chain_store in
                              Lwt.try_bind
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    let k_store_pruned_blocks
                                      (data :
                                      list
                                        (Tezos_base__TzPervasives.Block_hash.t *
                                          Tezos_storage.Context.Pruned_block.t))
                                      : Lwt.t
                                        (Tezos_base__TzPervasives.Error_monad.tzresult
                                          unit) :=
                                      Tezos_shell.Store.with_atomic_rw store
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.Error_monad.iter_s
                                              (fun function_parameter =>
                                                match function_parameter with
                                                |
                                                  (pruned_header_hash,
                                                    pruned_block) =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                    (Tezos_shell.Store.Block.Pruned_contents.store
                                                      (block_store,
                                                        pruned_header_hash)
                                                      {|
                                                        header :=
                                                          Context.Pruned_block.block_header
                                                            pruned_block |})
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (Lwt_list.iter_s
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | (i, v) =>
                                                                Tezos_shell.Store.Block.Operations.store
                                                                  (block_store,
                                                                    pruned_header_hash)
                                                                  i v
                                                              end)
                                                            (operations
                                                              pruned_block))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (Lwt_list.iter_s
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | (i, v) =>
                                                                      Tezos_shell.Store.Block.Operation_hashes.store
                                                                        (block_store,
                                                                          pruned_header_hash)
                                                                        i v
                                                                    end)
                                                                  (operation_hashes
                                                                    pruned_block))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_base__TzPervasives.return_unit
                                                                  end)
                                                            end)
                                                      end)
                                                end) data
                                          end) in
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_storage.Context.restore_contexts
                                        context_index filename
                                        k_store_pruned_blocks block_validation)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        |
                                          (predecessor_block_header, meta,
                                            history_mode, oldest_header_opt,
                                            rev_block_hashes, protocol_data) =>
                                          let oldest_header :=
                                            Tezos_base__TzPervasives.Option.unopt_assert
                                              Stdlib.__POS__ oldest_header_opt
                                            in
                                          let block_hashes_arr :=
                                            Stdlib.Array.of_list
                                              rev_block_hashes in
                                          let write_predecessors_table
                                            (to_write :
                                            list
                                              (Tezos_base__TzPervasives.Block_hash.t
                                                *
                                                (list
                                                  (Tezos_shell.Store.Block.Predecessors.key
                                                    *
                                                    Tezos_shell.Store.Block.Predecessors.value))))
                                            : Lwt.t unit :=
                                            Tezos_shell.Store.with_atomic_rw
                                              store
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Lwt_list.iter_s
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      |
                                                        (current_hash,
                                                          predecessors_list) =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (Lwt_list.iter_s
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | (l, h) =>
                                                                Tezos_shell.Store.Block.Predecessors.store
                                                                  (block_store,
                                                                    current_hash)
                                                                  l h
                                                              end)
                                                            predecessors_list)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              match
                                                                predecessors_list
                                                                with
                                                              |
                                                                cons
                                                                  (0, pred_hash)
                                                                  _ =>
                                                                Tezos_shell.Store.Chain_data.In_main_branch.store
                                                                  (chain_data,
                                                                    pred_hash)
                                                                  current_hash
                                                              | [] =>
                                                                Lwt.return_unit
                                                              | cons _ _ =>
                                                                false
                                                              end
                                                            end)
                                                      end) to_write
                                                end) in
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Lwt_list.fold_left_s
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (cpt, to_write) =>
                                                  fun current_hash =>
                                                    Tezos_stdlib_unix.Utils.display_progress
                                                      (Some (cpt, 1000))
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Computing predecessors table "
                                                            % string
                                                          (CamlinternalFormatBasics.Int
                                                            CamlinternalFormatBasics.Int_d
                                                            CamlinternalFormatBasics.No_padding
                                                            CamlinternalFormatBasics.No_precision
                                                            (CamlinternalFormatBasics.String_literal
                                                              "K elements" %
                                                                string
                                                              (CamlinternalFormatBasics.Flush
                                                                CamlinternalFormatBasics.End_of_format))))
                                                        "Computing predecessors table %dK elements%!"
                                                          % string)
                                                      (Z.div cpt 1000);
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (if
                                                        equiv_decb
                                                          (Z.modulo
                                                            (Z.add cpt 1) 5000)
                                                          0 then
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (write_predecessors_table
                                                            to_write)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Lwt.return_nil
                                                            end)
                                                      else
                                                        Lwt._return to_write)
                                                      (fun to_write =>
                                                        let predecessors_list :=
                                                          compute_predecessors
                                                            (block genesis)
                                                            (level
                                                              (shell
                                                                oldest_header))
                                                            block_hashes_arr cpt
                                                          in
                                                        Lwt._return
                                                          ((Z.add cpt 1),
                                                            (cons
                                                              (current_hash,
                                                                predecessors_list)
                                                              to_write)))
                                                end) (0, []) rev_block_hashes)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | (_, to_write) =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                  (write_predecessors_table
                                                    to_write)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_stdlib_unix.Utils.display_progress_end
                                                        tt;
                                                      match meta with
                                                      | {|
                                                        Block_data.block_header := block_header;
                                                          Block_data.operations
                                                            :=
                                                            operations
                                                          |} =>
                                                        let block_hash :=
                                                          Tezos_base__TzPervasives.Block_header.hash
                                                            block_header in
                                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                          match block with
                                                          | Some str =>
                                                            let bh :=
                                                              Tezos_base__TzPervasives.Block_hash.of_b58check_exn
                                                                str in
                                                            Tezos_base__TzPervasives.fail_unless
                                                              (Tezos_base__TzPervasives.Block_hash.equal
                                                                bh block_hash)
                                                              (Inconsistent_imported_block
                                                                bh block_hash)
                                                          | None =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (lwt_emit
                                                                  (Set_head
                                                                    (Tezos_base__TzPervasives.Block_header.hash
                                                                      block_header)))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    let
                                                                      pred_context_hash :=
                                                                      context
                                                                        (shell
                                                                          predecessor_block_header)
                                                                      in
                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                      (Tezos_storage.Context.checkout_exn
                                                                        context_index
                                                                        pred_context_hash)
                                                                      (fun
                                                                        predecessor_context
                                                                        =>
                                                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                          (Tezos_validation.Block_validation.apply
                                                                            chain_id
                                                                            (Stdlib.Int32.to_int
                                                                              (level
                                                                                (shell
                                                                                  predecessor_block_header)))
                                                                            predecessor_block_header
                                                                            predecessor_context
                                                                            block_header
                                                                            operations)
                                                                          (fun
                                                                            block_validation_result
                                                                            =>
                                                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                              (check_context_hash_consistency
                                                                                (validation_store
                                                                                  block_validation_result)
                                                                                block_header)
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  tt
                                                                                  =>
                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                    (verify_oldest_header
                                                                                      oldest_header
                                                                                      (block
                                                                                        genesis))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        tt
                                                                                        =>
                                                                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                          (set_history_mode
                                                                                            store
                                                                                            history_mode)
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            match
                                                                                              function_parameter
                                                                                              with
                                                                                            |
                                                                                              tt
                                                                                              =>
                                                                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                                (import_protocol_data_list
                                                                                                  context_index
                                                                                                  chain_store
                                                                                                  block_hashes_arr
                                                                                                  (level
                                                                                                    (Block_header.shell
                                                                                                      oldest_header))
                                                                                                  protocol_data)
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  match
                                                                                                    function_parameter
                                                                                                    with
                                                                                                  |
                                                                                                    tt
                                                                                                    =>
                                                                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                                      (store_new_head
                                                                                                        chain_state
                                                                                                        chain_data
                                                                                                        (block
                                                                                                          genesis)
                                                                                                        block_header
                                                                                                        operations
                                                                                                        block_validation_result)
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        match
                                                                                                          function_parameter
                                                                                                          with
                                                                                                        |
                                                                                                          tt
                                                                                                          =>
                                                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                            (update_checkpoint
                                                                                                              chain_state
                                                                                                              block_header)
                                                                                                            (fun
                                                                                                              new_checkpoint
                                                                                                              =>
                                                                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                (update_savepoint
                                                                                                                  chain_state
                                                                                                                  new_checkpoint)
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  match
                                                                                                                    function_parameter
                                                                                                                    with
                                                                                                                  |
                                                                                                                    tt
                                                                                                                    =>
                                                                                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                                                      (update_caboose
                                                                                                                        chain_data
                                                                                                                        (block
                                                                                                                          genesis)
                                                                                                                        block_header
                                                                                                                        oldest_header
                                                                                                                        (max_operations_ttl
                                                                                                                          (validation_store
                                                                                                                            block_validation_result)))
                                                                                                                      (fun
                                                                                                                        function_parameter
                                                                                                                        =>
                                                                                                                        match
                                                                                                                          function_parameter
                                                                                                                          with
                                                                                                                        |
                                                                                                                          tt
                                                                                                                          =>
                                                                                                                          Tezos_shell.Store.close
                                                                                                                            store;
                                                                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                            (Tezos_shell.State.close
                                                                                                                              state)
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              match
                                                                                                                                function_parameter
                                                                                                                                with
                                                                                                                              |
                                                                                                                                tt
                                                                                                                                =>
                                                                                                                                Tezos_base__TzPervasives.return_unit
                                                                                                                              end)
                                                                                                                        end)
                                                                                                                  end))
                                                                                                        end)
                                                                                                  end)
                                                                                            end)
                                                                                      end)
                                                                                end)))
                                                                  end)
                                                            end)
                                                      end
                                                    end)
                                              end)
                                        end)
                                  end)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | inl tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (lwt_emit (Import_success filename))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.return_unit
                                        end)
                                  | inr errors =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (dir_cleaner data_dir)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt => Lwt._return (inr errors)
                                        end)
                                  end)
                                (fun exn =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (dir_cleaner data_dir)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt => Lwt.fail exn
                                      end)))
                        end)
                  end)
            end)
      end).
src/lib_shell/snapshots.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val export :
  ?export_rolling:bool ->
  context_index:Context.index ->
  store:Store.t ->
  genesis:Block_hash.t ->
  string ->
  string option ->
  unit tzresult Lwt.t

val import :
  data_dir:string ->
  dir_cleaner:(string -> unit Lwt.t) ->
  patch_context:('a option -> Context.t -> Context.t Lwt.t) ->
  genesis:State.Chain.genesis ->
  string ->
  string option ->
  unit tzresult Lwt.t
src/lib_shell/snapshots.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter export :
(option bool) ->
  Tezos_storage.Context.index ->
    Tezos_shell.Store.t ->
      Tezos_base__TzPervasives.Block_hash.t ->
        string ->
          (option string) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter import : forall {a : Type},
string ->
  (string -> Lwt.t unit) ->
    ((option a) -> Tezos_storage.Context.t -> Lwt.t Tezos_storage.Context.t) ->
      Tezos_shell.State.Chain.genesis ->
        string ->
          (option string) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/lib_shell/stat_directory.ml 
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let rpc_directory () =
  let dir = RPC_directory.empty in
  RPC_directory.gen_register dir Stat_services.S.gc (fun () () () ->
      RPC_answer.return @@ Gc.stat ())
  |> fun dir ->
  RPC_directory.gen_register dir Stat_services.S.memory (fun () () () ->
      Sys_info.memory_stats ()
      >>= function
      | Ok stats -> RPC_answer.return stats | Error err -> RPC_answer.fail [err])
src/lib_shell/stat_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition rpc_directory (function_parameter : unit)
  : Tezos_base__TzPervasives.RPC_directory.directory unit :=
  match function_parameter with
  | tt =>
    let dir := Tezos_base__TzPervasives.RPC_directory.empty in
    OCaml.Stdlib.reverse_apply
      (Tezos_base__TzPervasives.RPC_directory.gen_register dir
        Tezos_shell_services.Stat_services.S.gc
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    apply Tezos_base__TzPervasives.RPC_answer._return
                      (Stdlib.Gc.stat tt)
                  end
              end
          end))
      (fun dir =>
        Tezos_base__TzPervasives.RPC_directory.gen_register dir
          Tezos_shell_services.Stat_services.S.memory
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_stdlib_unix.Sys_info.memory_stats tt)
                        (fun function_parameter =>
                          match function_parameter with
                          | inl stats =>
                            Tezos_base__TzPervasives.RPC_answer._return stats
                          | inr err =>
                            Tezos_base__TzPervasives.RPC_answer.fail
                              (cons err [])
                          end)
                    end
                end
            end))
  end.
src/lib_shell/state.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

open State_logging
open Validation_errors

module Shared = struct
  type 'a t = {data : 'a; lock : Lwt_mutex.t}

  let create data = {data; lock = Lwt_mutex.create ()}

  let use {data; lock} f = Lwt_mutex.with_lock lock (fun () -> f data)
end

type genesis = {
  time : Time.Protocol.t;
  block : Block_hash.t;
  protocol : Protocol_hash.t;
}

type global_state = {
  global_data : global_data Shared.t;
  protocol_store : Store.Protocol.store Shared.t;
  main_chain : Chain_id.t;
  protocol_watcher : Protocol_hash.t Lwt_watcher.input;
  block_watcher : block Lwt_watcher.input;
}

and global_data = {
  chains : chain_state Chain_id.Table.t;
  global_store : Store.t;
  context_index : Context.index;
}

and chain_state = {
  (* never take the lock on 'block_store' when holding
     the lock on 'chain_data'. *)
  global_state : global_state;
  chain_id : Chain_id.t;
  genesis : genesis;
  faked_genesis_hash : Block_hash.t;
  expiration : Time.Protocol.t option;
  allow_forked_chain : bool;
  block_store : Store.Block.store Shared.t;
  context_index : Context.index Shared.t;
  block_watcher : block Lwt_watcher.input;
  chain_data : chain_data_state Shared.t;
  block_rpc_directories :
    block RPC_directory.t Protocol_hash.Map.t Protocol_hash.Table.t;
  header_rpc_directories :
    (chain_state * Block_hash.t * Block_header.t) RPC_directory.t
    Protocol_hash.Map.t
    Protocol_hash.Table.t;
}

and chain_data_state = {
  mutable data : chain_data;
  mutable checkpoint : Block_header.t;
  chain_data_store : Store.Chain_data.store;
}

and chain_data = {
  current_head : block;
  current_mempool : Mempool.t;
  live_blocks : Block_hash.Set.t;
  live_operations : Operation_hash.Set.t;
  test_chain : Chain_id.t option;
  save_point : Int32.t * Block_hash.t;
  caboose : Int32.t * Block_hash.t;
}

and block = {
  chain_state : chain_state;
  hash : Block_hash.t;
  header : Block_header.t;
}

(* Errors *)

type error += Block_not_found of Block_hash.t

type error += Block_contents_not_found of Block_hash.t

let () =
  register_error_kind
    `Permanent
    ~id:"state.block.not_found"
    ~title:"Block_not_found"
    ~description:"Block not found"
    ~pp:(fun ppf block_hash ->
      Format.fprintf ppf "@[Cannot find block %a]" Block_hash.pp block_hash)
    Data_encoding.(obj1 (req "block_not_found" @@ Block_hash.encoding))
    (function Block_not_found block_hash -> Some block_hash | _ -> None)
    (fun block_hash -> Block_not_found block_hash) ;
  register_error_kind
    `Permanent
    ~id:"state.block.contents_not_found"
    ~title:"Block_contents_not_found"
    ~description:"Block not found"
    ~pp:(fun ppf block_hash ->
      Format.fprintf
        ppf
        "@[Cannot find block contents %a]"
        Block_hash.pp
        block_hash)
    Data_encoding.(
      obj1 (req "block_contents_not_found" @@ Block_hash.encoding))
    (function
      | Block_contents_not_found block_hash -> Some block_hash | _ -> None)
    (fun block_hash -> Block_contents_not_found block_hash)

(* Abstract view over block header storage.
   This module aims to abstract over block header's [read], [read_opt] and [known]
   functions by calling the adequate function depending on the block being pruned or not.
*)

module Header = struct
  let read (store, hash) =
    Store.Block.Contents.read (store, hash)
    >>= function
    | Ok {header; _} ->
        return header
    | Error _ ->
        Store.Block.Pruned_contents.read (store, hash)
        >>=? fun {header} -> return header

  let read_opt (store, hash) =
    read (store, hash)
    >>= function
    | Ok header -> Lwt.return_some header | Error _ -> Lwt.return_none

  let known (store, hash) =
    Store.Block.Pruned_contents.known (store, hash)
    >>= function
    | true ->
        Lwt.return_true
    | false ->
        Store.Block.Contents.known (store, hash)
end

let read_chain_data {chain_data; _} f =
  Shared.use chain_data (fun state -> f state.chain_data_store state.data)

let update_chain_data {chain_data; _} f =
  Shared.use chain_data (fun state ->
      f state.chain_data_store state.data
      >>= fun (data, res) ->
      Lwt_utils.may data ~f:(fun data ->
          state.data <- data ;
          Lwt.return_unit)
      >>= fun () -> Lwt.return res)

(** The number of predecessors stored per block.
    This value chosen to compute efficiently block locators that
    can cover a chain of 2 months, at 1 block/min, which is ~86K
    blocks at the cost in space of ~72MB.
    |locator| = log2(|chain|/10) -1
*)
let stored_predecessors_size = 12

(**
   Takes a block and populates its predecessors store, under the
   assumption that all its predecessors have their store already
   populated. The precedecessors are distributed along the chain, up
   to the genesis, at a distance from [b] that grows exponentially.
   The store tabulates a function [p] from distances to block_ids such
   that if [p(b,d)=b'] then [b'] is at distance 2^d from [b].
   Example of how previous predecessors are used:
   p(n,0) = n-1
   p(n,1) = n-2  = p(n-1,0)
   p(n,2) = n-4  = p(n-2,1)
   p(n,3) = n-8  = p(n-4,2)
   p(n,4) = n-16 = p(n-8,3)
*)
let store_predecessors (store : Store.Block.store) (b : Block_hash.t) :
    unit Lwt.t =
  let rec loop pred dist =
    if dist = stored_predecessors_size then Lwt.return_unit
    else
      Store.Block.Predecessors.read_opt (store, pred) (dist - 1)
      >>= function
      | None ->
          Lwt.return_unit (* we reached the last known block *)
      | Some p ->
          Store.Block.Predecessors.store (store, b) dist p
          >>= fun () -> loop p (dist + 1)
  in
  (* the first predecessor is fetched from the header *)
  Header.read_opt (store, b)
  >|= Option.unopt_assert ~loc:__POS__
  >>= fun header ->
  let pred = header.shell.predecessor in
  if Block_hash.equal b pred then Lwt.return_unit (* genesis *)
  else
    Store.Block.Predecessors.store (store, b) 0 pred >>= fun () -> loop pred 1

(**
   [predecessor_n_raw s b d] returns the hash of the block at distance [d] from [b].
   Returns [None] if [d] is greater than the distance of [b] from genesis or
   if [b] is genesis.
   Works in O(log|chain|) if the chain is shorter than 2^[stored_predecessors_size]
   and in O(|chain|) after that.
   @raise Invalid_argument "State.predecessors: negative distance"
*)
let predecessor_n_raw store block_hash distance =
  (* helper functions *)
  (* computes power of 2 w/o floats *)
  let power_of_2 n =
    if n < 0 then invalid_arg "negative argument"
    else
      let rec loop cnt res =
        if cnt < 1 then res else loop (cnt - 1) (res * 2)
      in
      loop n 1
  in
  (* computes the closest power of two smaller than a given
     a number and the rest w/o floats *)
  let closest_power_two_and_rest n =
    if n < 0 then invalid_arg "negative argument"
    else
      let rec loop cnt n rest =
        if n <= 1 then (cnt, rest)
        else loop (cnt + 1) (n / 2) (rest + (power_of_2 cnt * (n mod 2)))
      in
      loop 0 n 0
  in
  (* actual predecessor function *)
  if distance < 0 then
    invalid_arg ("State.predecessor: distance < 0 " ^ string_of_int distance)
  else if distance = 0 then Lwt.return_some block_hash
  else
    let rec loop block_hash distance =
      if distance = 1 then
        Store.Block.Predecessors.read_opt (store, block_hash) 0
      else
        let (power, rest) = closest_power_two_and_rest distance in
        let (power, rest) =
          if power < stored_predecessors_size then (power, rest)
          else
            let power = stored_predecessors_size - 1 in
            let rest = distance - power_of_2 power in
            (power, rest)
        in
        Store.Block.Predecessors.read_opt (store, block_hash) power
        >>= function
        | None ->
            Lwt.return_none (* reached genesis *)
        | Some pred ->
            if rest = 0 then Lwt.return_some pred
              (* landed on the requested predecessor *)
            else loop pred rest
      (* need to jump further back *)
    in
    loop block_hash distance

let predecessor_n ?(below_save_point = false) block_store block_hash distance =
  predecessor_n_raw block_store block_hash distance
  >>= function
  | None ->
      Lwt.return_none
  | Some predecessor -> (
      ( if below_save_point then Header.known (block_store, predecessor)
      else Store.Block.Contents.known (block_store, predecessor) )
      >>= function
      | false -> Lwt.return_none | true -> Lwt.return_some predecessor )

let compute_locator_from_hash chain_state ?(size = 200) head_hash seed =
  Shared.use chain_state.chain_data (fun state ->
      Lwt.return state.data.caboose)
  >>= fun (_lvl, caboose) ->
  Shared.use chain_state.block_store (fun block_store ->
      Header.read_opt (block_store, head_hash)
      >|= Option.unopt_assert ~loc:__POS__
      >>= fun header ->
      Block_locator.compute
        ~get_predecessor:(predecessor_n ~below_save_point:true block_store)
        ~caboose
        ~size
        head_hash
        header
        seed)

let compute_locator chain ?size head seed =
  compute_locator_from_hash chain ?size head.hash seed

type t = global_state

module Locked_block = struct
  let store_genesis store genesis context =
    let shell : Block_header.shell_header =
      {
        level = 0l;
        proto_level = 0;
        predecessor = genesis.block;
        (* genesis' predecessor is genesis *)
        timestamp = genesis.time;
        fitness = [];
        validation_passes = 0;
        operations_hash = Operation_list_list_hash.empty;
        context;
      }
    in
    let header : Block_header.t = {shell; protocol_data = Bytes.create 0} in
    Store.Block.Contents.store
      (store, genesis.block)
      {
        header;
        Store.Block.message = Some "Genesis";
        max_operations_ttl = 0;
        context;
        metadata = Bytes.create 0;
        last_allowed_fork_level = 0l;
      }
    >>= fun () -> Lwt.return header

  (* Will that block is compatible with the current checkpoint. *)
  let acceptable chain_data (header : Block_header.t) =
    let checkpoint_level = chain_data.checkpoint.shell.level in
    if checkpoint_level < header.shell.level then
      (* the predecessor is assumed compatible. *)
      Lwt.return_true
    else if checkpoint_level = header.shell.level then
      Lwt.return (Block_header.equal header chain_data.checkpoint)
    else
      (* header.shell.level < level *)
      (* valid only if the current head is lower than the checkpoint. *)
      let head_level = chain_data.data.current_head.header.shell.level in
      Lwt.return (head_level < checkpoint_level)

  (* Is a block still valid for a given checkpoint ? *)
  let is_valid_for_checkpoint block_store hash (header : Block_header.t)
      (checkpoint : Block_header.t) =
    if Compare.Int32.(header.shell.level < checkpoint.shell.level) then
      Lwt.return_true
    else
      predecessor_n
        block_store
        hash
        (Int32.to_int @@ Int32.sub header.shell.level checkpoint.shell.level)
      >|= Option.unopt_assert ~loc:__POS__
      >>= fun predecessor ->
      if Block_hash.equal predecessor (Block_header.hash checkpoint) then
        Lwt.return_true
      else Lwt.return_false
end

(* Find the branches that are still valid with a given checkpoint, i.e.
   heads with lower level, or branches that goes through the checkpoint. *)
let locked_valid_heads_for_checkpoint block_store data checkpoint =
  Store.Chain_data.Known_heads.read_all data.chain_data_store
  >>= fun heads ->
  Block_hash.Set.fold
    (fun head acc ->
      let valid_header =
        Header.read_opt (block_store, head)
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun header ->
        Locked_block.is_valid_for_checkpoint block_store head header checkpoint
        >>= fun valid -> Lwt.return (valid, header)
      in
      acc
      >>= fun (valid_heads, invalid_heads) ->
      valid_header
      >>= fun (valid, header) ->
      if valid then Lwt.return ((head, header) :: valid_heads, invalid_heads)
      else Lwt.return (valid_heads, (head, header) :: invalid_heads))
    heads
    (Lwt.return ([], []))

(* Tag as invalid all blocks in `heads` and their predecessors whose
   level strictly higher to 'level'. *)
let tag_invalid_heads block_store chain_store heads level =
  let rec tag_invalid_head (hash, header) =
    if header.Block_header.shell.level <= level then
      Store.Chain_data.Known_heads.store chain_store hash
      >>= fun () -> Lwt.return_some (hash, header)
    else
      let errors = [Validation_errors.Checkpoint_error (hash, None)] in
      Store.Block.Invalid_block.store
        block_store
        hash
        {level = header.shell.level; errors}
      >>= fun () ->
      Store.Block.Contents.remove (block_store, hash)
      >>= fun () ->
      Store.Block.Operation_hashes.remove_all (block_store, hash)
      >>= fun () ->
      Store.Block.Operations_metadata.remove_all (block_store, hash)
      >>= fun () ->
      Store.Block.Operations.remove_all (block_store, hash)
      >>= fun () ->
      Store.Block.Predecessors.remove_all (block_store, hash)
      >>= fun () ->
      Header.read_opt (block_store, header.shell.predecessor)
      >>= function
      | None ->
          Lwt.return_none
      | Some header ->
          tag_invalid_head (Block_header.hash header, header)
  in
  Lwt_list.iter_p
    (fun (hash, _header) ->
      Store.Chain_data.Known_heads.remove chain_store hash)
    heads
  >>= fun () -> Lwt_list.filter_map_s tag_invalid_head heads

let prune_block store block_hash =
  let st = (store, block_hash) in
  Store.Block.Contents.remove st
  >>= fun () ->
  Store.Block.Invalid_block.remove store block_hash
  >>= fun () -> Store.Block.Operations_metadata.remove_all st

let store_header_and_prune_block store block_hash =
  let st = (store, block_hash) in
  Store.Block.Contents.read_opt st
  >>= (function
        | Some {header; _} ->
            Store.Block.Pruned_contents.store st {header}
        | None -> (
            Store.Block.Pruned_contents.known st
            >>= function
            | true ->
                Lwt.return_unit
            | false ->
                State_logging.lwt_log_error
                  Tag.DSL.(
                    fun f ->
                      f "@[cannot find pruned contents of block %a@]"
                      -% t event "missing_pruned_contents"
                      -% a Block_hash.Logging.tag block_hash) ))
  >>= fun () -> prune_block store block_hash

let delete_block store block_hash =
  prune_block store block_hash
  >>= fun () ->
  let st = (store, block_hash) in
  Store.Block.Pruned_contents.remove st
  >>= fun () ->
  Store.Block.Operations.remove_all st
  >>= fun () ->
  Store.Block.Operation_hashes.remove_all st
  >>= fun () -> Store.Block.Predecessors.remove_all st

(* Remove all blocks that are not in the chain. *)
let cut_alternate_heads block_store chain_store heads =
  let rec cut_alternate_head hash header =
    Store.Chain_data.In_main_branch.known (chain_store, hash)
    >>= fun in_chain ->
    if in_chain then Lwt.return_unit
    else
      Header.read_opt (block_store, header.Block_header.shell.predecessor)
      >>= function
      | None ->
          delete_block block_store hash >>= fun () -> Lwt.return_unit
      | Some header ->
          delete_block block_store hash
          >>= fun () -> cut_alternate_head (Block_header.hash header) header
  in
  Lwt_list.iter_p
    (fun (hash, header) ->
      Store.Chain_data.Known_heads.remove chain_store hash
      >>= fun () -> cut_alternate_head hash header)
    heads

module Chain = struct
  type nonrec genesis = genesis = {
    time : Time.Protocol.t;
    block : Block_hash.t;
    protocol : Protocol_hash.t;
  }

  let genesis_encoding =
    let open Data_encoding in
    conv
      (fun {time; block; protocol} -> (time, block, protocol))
      (fun (time, block, protocol) -> {time; block; protocol})
      (obj3
         (req "timestamp" Time.Protocol.encoding)
         (req "block" Block_hash.encoding)
         (req "protocol" Protocol_hash.encoding))

  type t = chain_state

  type chain_state = t

  let main {main_chain; _} = main_chain

  let test chain_state =
    read_chain_data chain_state (fun _ chain_data ->
        Lwt.return chain_data.test_chain)

  let get_level_indexed_protocol chain_state header =
    let chain_id = chain_state.chain_id in
    let protocol_level = header.Block_header.shell.proto_level in
    let global_state = chain_state.global_state in
    Shared.use global_state.global_data (fun global_data ->
        let global_store = global_data.global_store in
        let chain_store = Store.Chain.get global_store chain_id in
        Store.Chain.Protocol_info.read_opt chain_store protocol_level
        >>= function
        | None ->
            Pervasives.failwith "State.Chain.get_level_index_protocol"
        | Some (p, _) ->
            Lwt.return p)

  let update_level_indexed_protocol_store chain_state chain_id protocol_level
      protocol_hash block_header =
    let global_state = chain_state.global_state in
    Shared.use chain_state.block_store (fun block_store ->
        Header.read_opt
          (block_store, block_header.Block_header.shell.predecessor)
        >>= function
        | None ->
            Lwt.return_none (* should not happen *)
        | Some header ->
            Lwt.return_some header)
    >>= function
    | None ->
        Lwt.return_unit
    | Some pred_header ->
        if pred_header.shell.proto_level <> block_header.shell.proto_level then
          Shared.use global_state.global_data (fun global_data ->
              let global_store = global_data.global_store in
              let chain_store = Store.Chain.get global_store chain_id in
              Store.Chain.Protocol_info.store
                chain_store
                protocol_level
                (protocol_hash, block_header.shell.level))
        else Lwt.return_unit

  let allocate ~genesis ~faked_genesis_hash ~save_point ~caboose ~expiration
      ~allow_forked_chain ~current_head ~checkpoint ~chain_id global_state
      context_index chain_data_store block_store =
    Header.read_opt (block_store, current_head)
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun current_block_head ->
    let rec chain_data =
      {
        data =
          {
            save_point;
            caboose;
            current_head =
              {chain_state; hash = current_head; header = current_block_head};
            current_mempool = Mempool.empty;
            live_blocks = Block_hash.Set.singleton genesis.block;
            live_operations = Operation_hash.Set.empty;
            test_chain = None;
          };
        checkpoint;
        chain_data_store;
      }
    and chain_state =
      {
        global_state;
        chain_id;
        chain_data = {Shared.data = chain_data; lock = Lwt_mutex.create ()};
        genesis;
        faked_genesis_hash;
        expiration;
        allow_forked_chain;
        block_store = Shared.create block_store;
        context_index = Shared.create context_index;
        block_watcher = Lwt_watcher.create_input ();
        block_rpc_directories = Protocol_hash.Table.create 7;
        header_rpc_directories = Protocol_hash.Table.create 7;
      }
    in
    Lwt.return chain_state

  let locked_create global_state data ?expiration ?(allow_forked_chain = false)
      chain_id genesis (genesis_header : Block_header.t) =
    let chain_store = Store.Chain.get data.global_store chain_id in
    let block_store = Store.Block.get chain_store
    and chain_data_store = Store.Chain_data.get chain_store in
    let save_point = (genesis_header.shell.level, genesis.block) in
    let caboose = (genesis_header.shell.level, genesis.block) in
    let proto_level = genesis_header.shell.proto_level in
    Store.Chain.Genesis_hash.store chain_store genesis.block
    >>= fun () ->
    Store.Chain.Genesis_time.store chain_store genesis.time
    >>= fun () ->
    Store.Chain.Genesis_protocol.store chain_store genesis.protocol
    >>= fun () ->
    Store.Chain_data.Current_head.store chain_data_store genesis.block
    >>= fun () ->
    Store.Chain_data.Known_heads.store chain_data_store genesis.block
    >>= fun () ->
    Store.Chain_data.Checkpoint.store chain_data_store genesis_header
    >>= fun () ->
    Store.Chain_data.Save_point.store chain_data_store save_point
    >>= fun () ->
    Store.Chain_data.Caboose.store chain_data_store caboose
    >>= fun () ->
    Store.Chain.Protocol_info.store
      chain_store
      proto_level
      (genesis.protocol, genesis_header.shell.level)
    >>= fun () ->
    ( match expiration with
    | None ->
        Lwt.return_unit
    | Some time ->
        Store.Chain.Expiration.store chain_store time )
    >>= fun () ->
    ( if allow_forked_chain then
      Store.Chain.Allow_forked_chain.store data.global_store chain_id
    else Lwt.return_unit )
    >>= fun () ->
    allocate
      ~genesis
      ~faked_genesis_hash:(Block_header.hash genesis_header)
      ~current_head:genesis.block
      ~expiration
      ~allow_forked_chain
      ~checkpoint:genesis_header
      ~chain_id
      ~save_point
      ~caboose
      global_state
      data.context_index
      chain_data_store
      block_store
    >>= fun chain ->
    Chain_id.Table.add data.chains chain_id chain ;
    Lwt.return chain

  let create state ?allow_forked_chain ~commit_genesis genesis chain_id =
    Shared.use state.global_data (fun data ->
        let chain_store = Store.Chain.get data.global_store chain_id in
        let block_store = Store.Block.get chain_store in
        if Chain_id.Table.mem data.chains chain_id then
          Pervasives.failwith "State.Chain.create"
        else
          commit_genesis
            ~chain_id
            ~time:genesis.time
            ~protocol:genesis.protocol
          >>=? fun commit ->
          Locked_block.store_genesis block_store genesis commit
          >>= fun genesis_header ->
          locked_create
            state
            data
            ?allow_forked_chain
            chain_id
            genesis
            genesis_header
          >>= fun chain ->
          (* in case this is a forked chain creation,
           delete its header from the temporary table*)
          Store.Forking_block_hash.remove
            data.global_store
            (Context.compute_testchain_chain_id genesis.block)
          >>= fun () -> return chain)

  let locked_read global_state data chain_id =
    let chain_store = Store.Chain.get data.global_store chain_id in
    let block_store = Store.Block.get chain_store
    and chain_data_store = Store.Chain_data.get chain_store in
    Store.Chain.Genesis_hash.read chain_store
    >>=? fun genesis_hash ->
    Store.Chain.Genesis_time.read chain_store
    >>=? fun time ->
    Store.Chain.Genesis_protocol.read chain_store
    >>=? fun protocol ->
    Store.Chain.Expiration.read_opt chain_store
    >>= fun expiration ->
    Store.Chain.Allow_forked_chain.known data.global_store chain_id
    >>= fun allow_forked_chain ->
    Header.read (block_store, genesis_hash)
    >>=? fun genesis_header ->
    let genesis = {time; protocol; block = genesis_hash} in
    Store.Chain_data.Current_head.read chain_data_store
    >>=? fun current_head ->
    Store.Chain_data.Checkpoint.read chain_data_store
    >>=? fun checkpoint ->
    Store.Chain_data.Save_point.read chain_data_store
    >>=? fun save_point ->
    Store.Chain_data.Caboose.read chain_data_store
    >>=? fun caboose ->
    try
      allocate
        ~genesis
        ~faked_genesis_hash:(Block_header.hash genesis_header)
        ~current_head
        ~expiration
        ~allow_forked_chain
        ~checkpoint
        ~chain_id
        ~save_point
        ~caboose
        global_state
        data.context_index
        chain_data_store
        block_store
      >>= return
    with Not_found -> fail Bad_data_dir

  let locked_read_all global_state data =
    Store.Chain.list data.global_store
    >>= fun ids ->
    iter_p
      (fun id ->
        locked_read global_state data id
        >>=? fun chain ->
        Chain_id.Table.add data.chains id chain ;
        return_unit)
      ids

  let read_all state =
    Shared.use state.global_data (fun data -> locked_read_all state data)

  let get_exn state id =
    Shared.use state.global_data (fun data ->
        Lwt.return (Chain_id.Table.find data.chains id))

  let get_opt state id =
    Lwt.catch
      (fun () -> get_exn state id >>= Lwt.return_some)
      (function _ -> Lwt.return_none)

  let get state id =
    Lwt.catch
      (fun () -> get_exn state id >>= return)
      (function Not_found -> fail (Unknown_chain id) | exn -> Lwt.fail exn)

  let all state =
    Shared.use state.global_data (fun {chains; _} ->
        Lwt.return
        @@ Chain_id.Table.fold (fun _ chain acc -> chain :: acc) chains [])

  let id {chain_id; _} = chain_id

  let genesis {genesis; _} = genesis

  let faked_genesis_hash {faked_genesis_hash; _} = faked_genesis_hash

  let expiration {expiration; _} = expiration

  let allow_forked_chain {allow_forked_chain; _} = allow_forked_chain

  let global_state {global_state; _} = global_state

  let checkpoint chain_state =
    Shared.use chain_state.chain_data (fun {checkpoint; _} ->
        Lwt.return checkpoint)

  let save_point chain_state =
    Shared.use chain_state.chain_data (fun state ->
        Lwt.return state.data.save_point)

  let caboose chain_state =
    Shared.use chain_state.chain_data (fun state ->
        Lwt.return state.data.caboose)

  let purge_loop_full ?(chunk_size = 4000) global_store store ~genesis_hash
      block_hash caboose_level =
    let do_prune blocks =
      Store.with_atomic_rw global_store
      @@ fun () -> Lwt_list.iter_s (store_header_and_prune_block store) blocks
    in
    let rec loop block_hash (n_blocks, blocks) =
      ( if n_blocks >= chunk_size then
        do_prune blocks >>= fun () -> Lwt.return (0, [])
      else Lwt.return (n_blocks, blocks) )
      >>= fun (n_blocks, blocks) ->
      Header.read_opt (store, block_hash)
      >|= Option.unopt_assert ~loc:__POS__
      >>= fun header ->
      if Block_hash.equal block_hash genesis_hash then do_prune blocks
      else if header.shell.level = caboose_level then
        do_prune (block_hash :: blocks)
      else loop header.shell.predecessor (n_blocks + 1, block_hash :: blocks)
    in
    Header.read_opt (store, block_hash)
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun header -> loop header.shell.predecessor (0, [])

  let purge_full chain_state (lvl, hash) =
    Shared.use chain_state.global_state.global_data (fun global_data ->
        Shared.use chain_state.block_store (fun store ->
            update_chain_data chain_state (fun _ data ->
                purge_loop_full
                  global_data.global_store
                  store
                  ~genesis_hash:chain_state.genesis.block
                  hash
                  (fst data.save_point)
                >>= fun () ->
                let new_data = {data with save_point = (lvl, hash)} in
                Lwt.return (Some new_data, ()))
            >>= fun () ->
            Shared.use chain_state.chain_data (fun data ->
                Store.Chain_data.Save_point.store
                  data.chain_data_store
                  (lvl, hash)
                >>= fun () -> return_unit)))

  let purge_loop_rolling global_store store ~genesis_hash block_hash limit =
    let do_delete blocks =
      Store.with_atomic_rw global_store
      @@ fun () -> Lwt_list.iter_s (delete_block store) blocks
    in
    let rec prune_loop block_hash limit =
      if Block_hash.equal genesis_hash block_hash then Lwt.return block_hash
      else if limit = 1 then
        Header.read_opt (store, block_hash)
        >>= function
        | None ->
            assert false (* Should not happen. *)
        | Some header ->
            store_header_and_prune_block store block_hash
            >>= fun () ->
            delete_loop header.shell.predecessor (0, [])
            >>= fun () -> Lwt.return block_hash
      else
        Header.read_opt (store, block_hash)
        >>= function
        | None ->
            assert false (* Should not happen. *)
        | Some header ->
            store_header_and_prune_block store block_hash
            >>= fun () -> prune_loop header.shell.predecessor (limit - 1)
    and delete_loop block_hash (n_blocks, blocks) =
      ( if n_blocks >= 4000 then
        do_delete blocks >>= fun () -> Lwt.return (0, [])
      else Lwt.return (n_blocks, blocks) )
      >>= fun (n_blocks, blocks) ->
      Header.read_opt (store, block_hash)
      >>= function
      | None ->
          do_delete blocks
      | Some header ->
          if Block_hash.equal genesis_hash block_hash then do_delete blocks
          else
            delete_loop
              header.shell.predecessor
              (n_blocks + 1, block_hash :: blocks)
    in
    Header.read_opt (store, block_hash)
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun header ->
    if limit = 0 then
      delete_loop header.shell.predecessor (0, [])
      >>= fun () -> Lwt.return block_hash
    else prune_loop header.shell.predecessor limit

  let purge_rolling chain_state ((lvl, hash) as checkpoint) =
    Shared.use chain_state.global_state.global_data (fun global_data ->
        Shared.use chain_state.block_store (fun store ->
            Store.Block.Contents.read_opt (store, hash)
            >>= (function
                  | None ->
                      fail (Block_contents_not_found hash)
                  | Some contents ->
                      return contents)
            >>=? fun contents ->
            let max_op_ttl = contents.max_operations_ttl in
            let limit = max_op_ttl in
            purge_loop_rolling
              ~genesis_hash:chain_state.genesis.block
              global_data.global_store
              store
              hash
              limit
            >>= fun caboose_hash ->
            let caboose_level = Int32.sub lvl (Int32.of_int max_op_ttl) in
            let caboose = (caboose_level, caboose_hash) in
            update_chain_data chain_state (fun _ data ->
                let new_data = {data with save_point = checkpoint; caboose} in
                Lwt.return (Some new_data, ()))
            >>= fun () ->
            Shared.use chain_state.chain_data (fun data ->
                Store.Chain_data.Save_point.store
                  data.chain_data_store
                  checkpoint
                >>= fun () ->
                Store.Chain_data.Caboose.store data.chain_data_store caboose
                >>= fun () -> return_unit)))

  let set_checkpoint chain_state checkpoint =
    Shared.use chain_state.block_store (fun store ->
        Shared.use chain_state.chain_data (fun data ->
            let head_header = data.data.current_head.header in
            let head_hash = data.data.current_head.hash in
            Locked_block.is_valid_for_checkpoint
              store
              head_hash
              head_header
              checkpoint
            >>= fun valid ->
            assert valid ;
            (* Remove outdated invalid blocks. *)
            Store.Block.Invalid_block.iter store ~f:(fun hash iblock ->
                if iblock.level <= checkpoint.shell.level then
                  Store.Block.Invalid_block.remove store hash
                else Lwt.return_unit)
            >>= fun () ->
            (* Remove outdated heads and tag invalid branches. *)
            locked_valid_heads_for_checkpoint store data checkpoint
            >>= (fun (valid_heads, invalid_heads) ->
                  tag_invalid_heads
                    store
                    data.chain_data_store
                    invalid_heads
                    checkpoint.shell.level
                  >>= fun outdated_invalid_heads ->
                  if head_header.shell.level < checkpoint.shell.level then
                    Lwt.return_unit
                  else
                    let outdated_valid_heads =
                      List.filter
                        (fun (hash, {Block_header.shell; _}) ->
                          shell.level <= checkpoint.shell.level
                          && not (Block_hash.equal hash head_hash))
                        valid_heads
                    in
                    cut_alternate_heads
                      store
                      data.chain_data_store
                      outdated_valid_heads
                    >>= fun () ->
                    cut_alternate_heads
                      store
                      data.chain_data_store
                      outdated_invalid_heads)
            >>= fun () ->
            (* Store the new checkpoint. *)
            Store.Chain_data.Checkpoint.store data.chain_data_store checkpoint
            >>= fun () ->
            data.checkpoint <- checkpoint ;
            (* TODO 'git fsck' in the context. *)
            Lwt.return_unit))

  let set_checkpoint_then_purge_full chain_state checkpoint =
    set_checkpoint chain_state checkpoint
    >>= fun () ->
    let lvl = checkpoint.shell.level in
    let hash = Block_header.hash checkpoint in
    purge_full chain_state (lvl, hash)

  let set_checkpoint_then_purge_rolling chain_state checkpoint =
    set_checkpoint chain_state checkpoint
    >>= fun () ->
    let lvl = checkpoint.shell.level in
    let hash = Block_header.hash checkpoint in
    purge_rolling chain_state (lvl, hash)

  let acceptable_block chain_state (header : Block_header.t) =
    Shared.use chain_state.chain_data (fun chain_data ->
        Locked_block.acceptable chain_data header)

  let destroy state chain =
    lwt_debug
      Tag.DSL.(
        fun f -> f "destroy %a" -% t event "destroy" -% a chain_id (id chain))
    >>= fun () ->
    Shared.use state.global_data (fun {global_store; chains; _} ->
        Chain_id.Table.remove chains (id chain) ;
        Store.Chain.destroy global_store (id chain))

  let store chain_state =
    Shared.use chain_state.global_state.global_data (fun global_data ->
        Lwt.return global_data.global_store)
end

module Block = struct
  type t = block = {
    chain_state : Chain.t;
    hash : Block_hash.t;
    header : Block_header.t;
  }

  type block = t

  module Header = Header

  let compare b1 b2 = Block_hash.compare b1.hash b2.hash

  let equal b1 b2 = Block_hash.equal b1.hash b2.hash

  let hash {hash; _} = hash

  let header {header; _} = header

  let read_contents block =
    Shared.use block.chain_state.block_store (fun store ->
        Store.Block.Contents.read_opt (store, block.hash)
        >>= function
        | None ->
            fail (Block_contents_not_found block.hash)
        | Some contents ->
            return contents)

  let header_of_hash chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Header.read_opt (store, hash))

  let metadata b = read_contents b >>=? fun {metadata; _} -> return metadata

  let chain_state {chain_state; _} = chain_state

  let chain_id {chain_state = {chain_id; _}; _} = chain_id

  let shell_header {header = {shell; _}; _} = shell

  let timestamp b = (shell_header b).timestamp

  let fitness b = (shell_header b).fitness

  let level b = (shell_header b).level

  let validation_passes b = (shell_header b).validation_passes

  let message b = read_contents b >>=? fun {message; _} -> return message

  let max_operations_ttl b =
    read_contents b
    >>=? fun {max_operations_ttl; _} -> return max_operations_ttl

  let last_allowed_fork_level b =
    read_contents b
    >>=? fun {last_allowed_fork_level; _} -> return last_allowed_fork_level

  let is_genesis b = Block_hash.equal b.hash b.chain_state.genesis.block

  let known_valid chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Header.known (store, hash))

  let known_invalid chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.known store hash)

  let read_invalid chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.read_opt store hash)

  let list_invalid chain_state =
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.fold
          store
          ~init:[]
          ~f:(fun hash {level; errors} acc ->
            Lwt.return ((hash, level, errors) :: acc)))

  let unmark_invalid chain_state block =
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.known store block
        >>= fun mem ->
        if mem then Store.Block.Invalid_block.remove store block >>= return
        else fail (Block_not_invalid block))

  let is_valid_for_checkpoint block checkpoint =
    let chain_state = block.chain_state in
    Shared.use chain_state.block_store (fun store ->
        Locked_block.is_valid_for_checkpoint
          store
          block.hash
          block.header
          checkpoint)

  let read_predecessor chain_state ~pred ?(below_save_point = false) hash =
    Shared.use chain_state.block_store (fun store ->
        predecessor_n ~below_save_point store hash pred
        >>= fun hash_opt ->
        let new_hash_opt =
          match hash_opt with
          | Some _ as hash_opt ->
              hash_opt
          | None ->
              if Block_hash.equal hash chain_state.genesis.block then
                Some chain_state.genesis.block
              else None
        in
        match new_hash_opt with
        | None ->
            Lwt.fail Not_found
        | Some hash -> (
            Header.read_opt (store, hash)
            >>= fun header ->
            match header with
            | Some header ->
                Lwt.return_some {chain_state; hash; header}
            | None ->
                Lwt.return_none ))

  let read chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Header.read (store, hash)
        >>=? fun header -> return {chain_state; hash; header})

  let read_opt chain_state hash =
    read chain_state hash
    >>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v

  let predecessor {chain_state; header; hash; _} =
    if Block_hash.equal hash header.shell.predecessor then Lwt.return_none
      (* we are at genesis *)
    else read_opt chain_state header.shell.predecessor

  let predecessor_n b n =
    Shared.use b.chain_state.block_store (fun block_store ->
        predecessor_n block_store b.hash n)

  let store ?(dont_enforce_context_hash = false) chain_state block_header
      block_header_metadata operations operations_metadata
      ({context_hash; message; max_operations_ttl; last_allowed_fork_level} :
        Block_validation.validation_store) ~forking_testchain =
    let bytes = Block_header.to_bytes block_header in
    let hash = Block_header.hash_raw bytes in
    fail_unless
      (block_header.shell.validation_passes = List.length operations)
      (failure "State.Block.store: invalid operations length")
    >>=? fun () ->
    fail_unless
      (block_header.shell.validation_passes = List.length operations_metadata)
      (failure "State.Block.store: invalid operations_data length")
    >>=? fun () ->
    fail_unless
      (List.for_all2
         (fun l1 l2 -> List.length l1 = List.length l2)
         operations
         operations_metadata)
      (failure "State.Block.store: inconsistent operations and operations_data")
    >>=? fun () ->
    (* let's the validator check the consistency... of fitness, level, ... *)
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.known store hash
        >>= fun known_invalid ->
        fail_when known_invalid (failure "Known invalid")
        >>=? fun () ->
        Store.Block.Contents.known (store, hash)
        >>= fun known ->
        if known then return_none
        else
          (* safety check: never ever commit a block that is not compatible
           with the current checkpoint.  *)
          (let predecessor = block_header.shell.predecessor in
           Header.known (store, predecessor)
           >>= fun valid_predecessor ->
           if not valid_predecessor then Lwt.return_false
           else
             Shared.use chain_state.chain_data (fun chain_data ->
                 Locked_block.acceptable chain_data block_header))
          >>= fun acceptable_block ->
          fail_unless acceptable_block (Checkpoint_error (hash, None))
          >>=? fun () ->
          let commit = context_hash in
          Context.exists chain_state.context_index.data commit
          >>= fun exists ->
          fail_unless
            exists
            (failure "State.Block.store: context hash not found in context")
          >>=? fun _ ->
          fail_unless
            ( dont_enforce_context_hash
            || Context_hash.equal block_header.shell.context commit )
            (Inconsistent_hash (commit, block_header.shell.context))
          >>=? fun () ->
          let header =
            if dont_enforce_context_hash then
              {
                block_header with
                shell = {block_header.shell with context = commit};
              }
            else block_header
          in
          let contents =
            {
              header;
              Store.Block.message;
              max_operations_ttl;
              last_allowed_fork_level;
              context = commit;
              metadata = block_header_metadata;
            }
          in
          Store.Block.Contents.store (store, hash) contents
          >>= fun () ->
          Lwt_list.iteri_p
            (fun i ops ->
              Store.Block.Operation_hashes.store
                (store, hash)
                i
                (List.map Operation.hash ops))
            operations
          >>= fun () ->
          Lwt_list.iteri_p
            (fun i ops -> Store.Block.Operations.store (store, hash) i ops)
            operations
          >>= fun () ->
          Lwt_list.iteri_p
            (fun i ops ->
              Store.Block.Operations_metadata.store (store, hash) i ops)
            operations_metadata
          >>= fun () ->
          (* Store predecessors *)
          store_predecessors store hash
          >>= fun () ->
          (* Update the chain state. *)
          Shared.use chain_state.chain_data (fun chain_data ->
              let store = chain_data.chain_data_store in
              let predecessor = block_header.shell.predecessor in
              Store.Chain_data.Known_heads.remove store predecessor
              >>= fun () -> Store.Chain_data.Known_heads.store store hash)
          >>= fun () ->
          ( if forking_testchain then
            Shared.use chain_state.global_state.global_data (fun global_data ->
                let genesis = Context.compute_testchain_genesis hash in
                Store.Forking_block_hash.store
                  global_data.global_store
                  (Context.compute_testchain_chain_id genesis)
                  hash)
          else Lwt.return_unit )
          >>= fun () ->
          let block = {chain_state; hash; header} in
          Lwt_watcher.notify chain_state.block_watcher block ;
          Lwt_watcher.notify chain_state.global_state.block_watcher block ;
          return_some block)

  let store_invalid chain_state block_header errors =
    let bytes = Block_header.to_bytes block_header in
    let hash = Block_header.hash_raw bytes in
    Shared.use chain_state.block_store (fun store ->
        Header.known (store, hash)
        >>= fun known_valid ->
        fail_when known_valid (failure "Known valid")
        >>=? fun () ->
        Store.Block.Invalid_block.known store hash
        >>= fun known_invalid ->
        if known_invalid then return_false
        else
          Store.Block.Invalid_block.store
            store
            hash
            {level = block_header.shell.level; errors}
          >>= fun () -> return_true)

  let watcher (state : chain_state) =
    Lwt_watcher.create_stream state.block_watcher

  let compute_operation_path hashes =
    let list_hashes = List.map Operation_list_hash.compute hashes in
    Operation_list_list_hash.compute_path list_hashes

  let operation_hashes {chain_state; hash; header} i =
    if i < 0 || header.shell.validation_passes <= i then
      invalid_arg "State.Block.operations" ;
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun n ->
            Store.Block.Operation_hashes.read_opt (store, hash) n
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1))
        >>= fun hashes ->
        let path = compute_operation_path hashes in
        Lwt.return (List.nth hashes i, path i))

  let all_operation_hashes {chain_state; hash; header; _} =
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun i ->
            Store.Block.Operation_hashes.read_opt (store, hash) i
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1)))

  let operations {chain_state; hash; header; _} i =
    if i < 0 || header.shell.validation_passes <= i then
      invalid_arg "State.Block.operations" ;
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun n ->
            Store.Block.Operation_hashes.read_opt (store, hash) n
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1))
        >>= fun hashes ->
        let path = compute_operation_path hashes in
        Store.Block.Operations.read_opt (store, hash) i
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun ops -> Lwt.return (ops, path i))

  let operations_metadata {chain_state; hash; header; _} i =
    if i < 0 || header.shell.validation_passes <= i then
      invalid_arg "State.Block.operations_metadata" ;
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Operations_metadata.read_opt (store, hash) i
        >|= Option.unopt_assert ~loc:__POS__)

  let all_operations {chain_state; hash; header; _} =
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun i ->
            Store.Block.Operations.read_opt (store, hash) i
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1)))

  let all_operations_metadata {chain_state; hash; header; _} =
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun i ->
            Store.Block.Operations_metadata.read_opt (store, hash) i
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1)))

  let context_exn {chain_state; hash; _} =
    Shared.use chain_state.block_store (fun block_store ->
        Store.Block.Contents.read_opt (block_store, hash))
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun {context = commit; _} ->
    Shared.use chain_state.context_index (fun context_index ->
        Context.checkout_exn context_index commit)

  let context_opt {chain_state; hash; _} =
    Shared.use chain_state.block_store (fun block_store ->
        Store.Block.Contents.read_opt (block_store, hash))
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun {context = commit; _} ->
    Shared.use chain_state.context_index (fun context_index ->
        Context.checkout context_index commit)

  let context block =
    context_opt block
    >>= function
    | Some context ->
        return context
    | None ->
        failwith "State.Block.context failed to checkout context"

  let protocol_hash block =
    context block >>=? fun context -> Context.get_protocol context >>= return

  let protocol_hash_exn block =
    context_exn block >>= fun context -> Context.get_protocol context

  let protocol_level block = block.header.shell.proto_level

  let test_chain block =
    context_exn block
    >>= fun context ->
    Context.get_test_chain context
    >>= fun status ->
    let lookup_testchain genesis =
      let chain_id = Context.compute_testchain_chain_id genesis in
      (* otherwise, look in the temporary table *)
      Shared.use block.chain_state.global_state.global_data (fun global_data ->
          Store.Forking_block_hash.read_opt global_data.global_store chain_id)
      >>= function
      | Some forking_block_hash ->
          read_opt block.chain_state forking_block_hash
          >>= fun forking_block -> Lwt.return (status, forking_block)
      | None ->
          Lwt.return (status, None)
    in
    match status with
    | Running {genesis; _} ->
        lookup_testchain genesis
    | Forking _ ->
        Lwt.return (status, Some block)
    | Not_running ->
        Lwt.return (status, None)

  let known chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Header.known (store, hash)
        >>= fun known ->
        if known then Lwt.return_true
        else Store.Block.Invalid_block.known store hash)

  let block_validity chain_state block : Block_locator.validity Lwt.t =
    known chain_state block
    >>= function
    | false ->
        if Block_hash.equal block (Chain.faked_genesis_hash chain_state) then
          Lwt.return Block_locator.Known_valid
        else Lwt.return Block_locator.Unknown
    | true -> (
        known_invalid chain_state block
        >>= function
        | true ->
            Lwt.return Block_locator.Known_invalid
        | false ->
            Lwt.return Block_locator.Known_valid )

  let known_ancestor chain_state locator =
    Shared.use chain_state.global_state.global_data (fun {global_store; _} ->
        Store.Configuration.History_mode.read_opt global_store
        >|= Option.unopt_assert ~loc:__POS__)
    >>= fun history_mode ->
    Block_locator.unknown_prefix ~is_known:(block_validity chain_state) locator
    >>= function
    | (Known_valid, prefix_locator) ->
        Lwt.return_some prefix_locator
    | (Known_invalid, _) ->
        Lwt.return_none
    | (Unknown, _) -> (
      match history_mode with
      | Archive ->
          Lwt.return_none
      | Rolling | Full ->
          Lwt.return_some locator )

  (* Hypothesis : genesis' predecessor is itself. *)
  let get_rpc_directory ({chain_state; _} as block) =
    read_opt chain_state block.header.shell.predecessor
    >>= function
    | None ->
        Lwt.return_none (* assert false *)
    | Some pred when equal pred block ->
        Lwt.return_none (* genesis *)
    | Some pred -> (
        Chain.save_point chain_state
        >>= fun (save_point_level, _) ->
        ( if Compare.Int32.(level pred < save_point_level) then
          Chain.get_level_indexed_protocol chain_state pred.header
        else protocol_hash_exn pred )
        >>= fun protocol ->
        match
          Protocol_hash.Table.find_opt
            chain_state.block_rpc_directories
            protocol
        with
        | None ->
            Lwt.return_none
        | Some map ->
            protocol_hash_exn block
            >>= fun next_protocol ->
            Lwt.return (Protocol_hash.Map.find_opt next_protocol map) )

  let set_rpc_directory ({chain_state; _} as block) dir =
    read_opt chain_state block.header.shell.predecessor
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun pred ->
    protocol_hash_exn block
    >>= fun next_protocol ->
    Chain.save_point chain_state
    >>= fun (save_point_level, _) ->
    ( if Compare.Int32.(level pred < save_point_level) then
      Chain.get_level_indexed_protocol chain_state (header pred)
    else protocol_hash_exn pred )
    >>= fun protocol ->
    let map =
      Option.unopt
        ~default:Protocol_hash.Map.empty
        (Protocol_hash.Table.find_opt
           chain_state.block_rpc_directories
           protocol)
    in
    Protocol_hash.Table.replace
      chain_state.block_rpc_directories
      protocol
      (Protocol_hash.Map.add next_protocol dir map) ;
    Lwt.return_unit

  let get_header_rpc_directory chain_state header =
    Shared.use chain_state.block_store (fun block_store ->
        Header.read_opt (block_store, header.Block_header.shell.predecessor)
        >>= function
        | None ->
            Lwt.return_none (* caboose *)
        | Some pred when Block_header.equal pred header ->
            Lwt.return_none (* genesis *)
        | Some pred -> (
            Chain.get_level_indexed_protocol chain_state header
            >>= fun protocol ->
            match
              Protocol_hash.Table.find_opt
                chain_state.header_rpc_directories
                protocol
            with
            | None ->
                Lwt.return_none
            | Some map ->
                Chain.get_level_indexed_protocol chain_state pred
                >>= fun next_protocol ->
                Lwt.return (Protocol_hash.Map.find_opt next_protocol map) ))

  let set_header_rpc_directory chain_state header dir =
    Shared.use chain_state.block_store (fun block_store ->
        Header.read_opt (block_store, header.Block_header.shell.predecessor)
        >>= function
        | None ->
            assert false
        | Some pred ->
            Chain.get_level_indexed_protocol chain_state header
            >>= fun next_protocol ->
            Chain.get_level_indexed_protocol chain_state pred
            >>= fun protocol ->
            let map =
              Option.unopt
                ~default:Protocol_hash.Map.empty
                (Protocol_hash.Table.find_opt
                   chain_state.header_rpc_directories
                   protocol)
            in
            Protocol_hash.Table.replace
              chain_state.header_rpc_directories
              protocol
              (Protocol_hash.Map.add next_protocol dir map) ;
            Lwt.return_unit)
end

let watcher (state : global_state) =
  Lwt_watcher.create_stream state.block_watcher

let read_block {global_data; _} hash =
  Shared.use global_data (fun {chains; _} ->
      Chain_id.Table.fold
        (fun _chain_id chain_state acc ->
          acc
          >>= function
          | Some _ ->
              acc
          | None -> (
              Block.read_opt chain_state hash
              >>= function None -> acc | Some block -> Lwt.return_some block ))
        chains
        Lwt.return_none)

let read_block_exn t hash =
  read_block t hash
  >>= function None -> Lwt.fail Not_found | Some b -> Lwt.return b

let update_testchain block ~testchain_state =
  update_chain_data block.chain_state (fun _ chain_data ->
      Lwt.return
        (Some {chain_data with test_chain = Some testchain_state.chain_id}, ()))

let fork_testchain block chain_id genesis_hash genesis_header protocol
    expiration =
  Shared.use block.chain_state.global_state.global_data (fun data ->
      let chain_store = Store.Chain.get data.global_store chain_id in
      let block_store = Store.Block.get chain_store in
      Store.Block.Contents.store
        (block_store, genesis_hash)
        {
          header = genesis_header;
          Store.Block.message = Some "Genesis";
          max_operations_ttl = 0;
          context = genesis_header.shell.context;
          metadata = Bytes.create 0;
          last_allowed_fork_level = 0l;
        }
      >>= fun () ->
      let genesis =
        {block = genesis_hash; time = genesis_header.shell.timestamp; protocol}
      in
      Chain.locked_create
        block.chain_state.global_state
        data
        chain_id
        ~expiration
        genesis
        genesis_header
      >>= fun testchain_state ->
      Store.Chain.Protocol_info.store
        chain_store
        genesis_header.shell.proto_level
        (protocol, genesis_header.shell.level)
      >>= fun () ->
      update_testchain block ~testchain_state
      >>= fun () -> return testchain_state)

let best_known_head_for_checkpoint chain_state checkpoint =
  Shared.use chain_state.block_store (fun store ->
      Shared.use chain_state.chain_data (fun data ->
          let head_hash = data.data.current_head.hash in
          let head_header = data.data.current_head.header in
          Locked_block.is_valid_for_checkpoint
            store
            head_hash
            head_header
            checkpoint
          >>= fun valid ->
          if valid then Lwt.return data.data.current_head
          else
            let find_valid_predecessor hash =
              Header.read_opt (store, hash)
              >|= Option.unopt_assert ~loc:__POS__
              >>= fun header ->
              if Compare.Int32.(header.shell.level < checkpoint.shell.level)
              then Lwt.return {hash; chain_state; header}
              else
                predecessor_n
                  store
                  hash
                  ( 1
                  + ( Int32.to_int
                    @@ Int32.sub header.shell.level checkpoint.shell.level ) )
                >|= Option.unopt_assert ~loc:__POS__
                >>= fun pred ->
                Header.read_opt (store, pred)
                >|= Option.unopt_assert ~loc:__POS__
                >>= fun pred_header ->
                Lwt.return {hash = pred; chain_state; header = pred_header}
            in
            Store.Chain_data.Known_heads.read_all data.chain_data_store
            >>= fun heads ->
            Header.read_opt (store, chain_state.genesis.block)
            >|= Option.unopt_assert ~loc:__POS__
            >>= fun genesis_header ->
            let genesis =
              {
                hash = chain_state.genesis.block;
                chain_state;
                header = genesis_header;
              }
            in
            Block_hash.Set.fold
              (fun head best ->
                let valid_predecessor = find_valid_predecessor head in
                best
                >>= fun best ->
                valid_predecessor
                >>= fun pred ->
                if
                  Fitness.(
                    pred.header.shell.fitness > best.header.shell.fitness)
                then Lwt.return pred
                else Lwt.return best)
              heads
              (Lwt.return genesis)))

module Protocol = struct
  include Protocol

  let known global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.known store hash)

  let read global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.read store hash)

  let read_opt global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.read_opt store hash)

  let read_raw global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.RawContents.read (store, hash))

  let read_raw_opt global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.RawContents.read_opt (store, hash))

  let store global_state p =
    let bytes = Protocol.to_bytes p in
    let hash = Protocol.hash_raw bytes in
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.known store hash
        >>= fun known ->
        if known then Lwt.return_none
        else
          Store.Protocol.RawContents.store (store, hash) bytes
          >>= fun () ->
          Lwt_watcher.notify global_state.protocol_watcher hash ;
          Lwt.return_some hash)

  let remove global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.known store hash
        >>= fun known ->
        if known then Lwt.return_false
        else
          Store.Protocol.Contents.remove store hash
          >>= fun () -> Lwt.return_true)

  let list global_state =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.fold_keys
          store
          ~init:Protocol_hash.Set.empty
          ~f:(fun x acc -> Lwt.return (Protocol_hash.Set.add x acc)))

  let watcher (state : global_state) =
    Lwt_watcher.create_stream state.protocol_watcher
end

module Current_mempool = struct
  let set chain_state ~head mempool =
    update_chain_data chain_state (fun _chain_data_store data ->
        if Block_hash.equal head (Block.hash data.current_head) then
          Lwt.return (Some {data with current_mempool = mempool}, ())
        else Lwt.return (None, ()))

  let get chain_state =
    read_chain_data chain_state (fun _chain_data_store data ->
        Lwt.return (Block.header data.current_head, data.current_mempool))
end

let may_create_chain ~commit_genesis state chain_id genesis =
  Chain.get state chain_id
  >>= function
  | Ok chain ->
      return chain
  | Error _ ->
      Chain.create
        ~commit_genesis
        ~allow_forked_chain:true
        state
        genesis
        chain_id

let read global_store context_index main_chain =
  let global_data =
    {chains = Chain_id.Table.create 17; global_store; context_index}
  in
  let state =
    {
      global_data = Shared.create global_data;
      protocol_store = Shared.create @@ Store.Protocol.get global_store;
      main_chain;
      protocol_watcher = Lwt_watcher.create_input ();
      block_watcher = Lwt_watcher.create_input ();
    }
  in
  Chain.read_all state >>=? fun () -> return state

type error +=
  | Incorrect_history_mode_switch of {
      previous_mode : History_mode.t;
      next_mode : History_mode.t;
    }

let () =
  register_error_kind
    `Permanent
    ~id:"node_config_file.incorrect_history_mode_switch"
    ~title:"Incorrect history mode switch"
    ~description:"Incorrect history mode switch."
    ~pp:(fun ppf (prev, next) ->
      Format.fprintf
        ppf
        "@[cannot switch from history mode %a mode to %a mode@]"
        History_mode.pp
        prev
        History_mode.pp
        next)
    (Data_encoding.obj2
       (Data_encoding.req "previous_mode" History_mode.encoding)
       (Data_encoding.req "next_mode" History_mode.encoding))
    (function
      | Incorrect_history_mode_switch x ->
          Some (x.previous_mode, x.next_mode)
      | _ ->
          None)
    (fun (previous_mode, next_mode) ->
      Incorrect_history_mode_switch {previous_mode; next_mode})

let init ?patch_context ?commit_genesis ?(store_mapsize = 40_960_000_000L)
    ?(context_mapsize = 409_600_000_000L) ~store_root ~context_root
    ?history_mode genesis =
  Store.init ~mapsize:store_mapsize store_root
  >>=? fun global_store ->
  ( match commit_genesis with
  | Some commit_genesis ->
      Context.init
        ~readonly:true
        ~mapsize:context_mapsize
        ?patch_context
        context_root
      >>= fun context_index -> Lwt.return (context_index, commit_genesis)
  | None ->
      Context.init
        ~readonly:false
        ~mapsize:context_mapsize
        ?patch_context
        context_root
      >>= fun context_index ->
      let commit_genesis ~chain_id ~time ~protocol =
        Context.commit_genesis context_index ~chain_id ~time ~protocol
        >>= fun res -> return res
      in
      Lwt.return (context_index, commit_genesis) )
  >>= fun (context_index, commit_genesis) ->
  let chain_id = Chain_id.of_block_hash genesis.Chain.block in
  read global_store context_index chain_id
  >>=? fun state ->
  may_create_chain ~commit_genesis state chain_id genesis
  >>=? fun main_chain_state ->
  Store.Configuration.History_mode.read_opt global_store
  >>= (function
        | None ->
            let mode = Option.unopt ~default:History_mode.Full history_mode in
            Store.Configuration.History_mode.store global_store mode
            >>= fun () -> return mode
        | Some previous_history_mode -> (
          match history_mode with
          | None ->
              return previous_history_mode
          | Some history_mode ->
              if history_mode <> previous_history_mode then
                fail
                  (Incorrect_history_mode_switch
                     {
                       previous_mode = previous_history_mode;
                       next_mode = history_mode;
                     })
              else return history_mode ))
  >>=? fun history_mode ->
  return (state, main_chain_state, context_index, history_mode)

let history_mode {global_data; _} =
  Shared.use global_data (fun {global_store; _} ->
      Store.Configuration.History_mode.read_opt global_store
      >|= Option.unopt_assert ~loc:__POS__)

let close {global_data; _} =
  Shared.use global_data (fun {global_store; _} ->
      Store.close global_store ; Lwt.return_unit)
src/lib_shell/state.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.State_logging.

Import Tezos_shell_services.Validation_errors.

Module Shared.
  Record t {a : Type} := {
    data : a;
    lock : Lwt_mutex.t }.
  Arguments t : clear implicits.
  
  Definition create {A : Type} (data : A) : t A :=
    {| data := data; lock := Lwt_mutex.create tt |}.
  
  Definition use {A B : Type} (function_parameter : t A)
    : (A -> Lwt.t B) -> Lwt.t B :=
    match function_parameter with
    | {| data := data; lock := lock |} =>
      fun f =>
        Lwt_mutex.with_lock lock
          (fun function_parameter =>
            match function_parameter with
            | tt => f data
            end)
    end.
End Shared.

Record genesis := {
  time : Tezos_base__TzPervasives.Time.Protocol.t;
  block : Tezos_base__TzPervasives.Block_hash.t;
  protocol : Tezos_base__TzPervasives.Protocol_hash.t }.

.

Module Header.
  Definition read
    (function_parameter :
      Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
    match function_parameter with
    | (store, hash) =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.Store.Block.Contents.read (store, hash))
        (fun function_parameter =>
          match function_parameter with
          | inl {| header := header |} =>
            Tezos_base__TzPervasives._return header
          | inr _ =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_shell.Store.Block.Pruned_contents.read (store, hash))
              (fun function_parameter =>
                match function_parameter with
                | {| header := header |} =>
                  Tezos_base__TzPervasives._return header
                end)
          end)
    end.
  
  Definition read_opt
    (function_parameter :
      Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
    match function_parameter with
    | (store, hash) =>
      Tezos_base__TzPervasives.op_gt_gt_eq (read (store, hash))
        (fun function_parameter =>
          match function_parameter with
          | inl header => Lwt.return_some header
          | inr _ => Lwt.return_none
          end)
    end.
  
  Definition known
    (function_parameter :
      Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t bool :=
    match function_parameter with
    | (store, hash) =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.Store.Block.Pruned_contents.known (store, hash))
        (fun function_parameter =>
          match function_parameter with
          | true => Lwt.return_true
          | false => Tezos_shell.Store.Block.Contents.known (store, hash)
          end)
    end.
End Header.

Definition read_chain_data {A : Type} (function_parameter : chain_state)
  : (Tezos_shell.Store.Chain_data.store -> chain_data -> Lwt.t A) -> Lwt.t A :=
  match function_parameter with
  | {| chain_data := chain_data |} =>
    fun f =>
      Shared.use chain_data
        (fun state => f (chain_data_store state) (data state))
  end.

Definition update_chain_data {A : Type} (function_parameter : chain_state)
  : (Tezos_shell.Store.Chain_data.store ->
    chain_data -> Lwt.t ((option chain_data) * A)) -> Lwt.t A :=
  match function_parameter with
  | {| chain_data := chain_data |} =>
    fun f =>
      Shared.use chain_data
        (fun state =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (f (chain_data_store state) (data state))
            (fun function_parameter =>
              match function_parameter with
              | (data, res) =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_base__TzPervasives.Lwt_utils.may
                    (fun data =>
                      set_field;
                      Lwt.return_unit) data)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Lwt._return res
                    end)
              end))
  end.

Definition stored_predecessors_size : Z := 12.

Definition store_predecessors
  (store : Tezos_shell.Store.Block.store)
  (b : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  let fix loop (pred : Tezos_base__TzPervasives.Block_hash.t) (dist : Z)
    : Lwt.t unit :=
    if equiv_decb dist stored_predecessors_size then
      Lwt.return_unit
    else
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.Store.Block.Predecessors.read_opt (store, pred)
          (Z.sub dist 1))
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt.return_unit
          | Some p =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.Store.Block.Predecessors.store (store, b) dist p)
              (fun function_parameter =>
                match function_parameter with
                | tt => loop p (Z.add dist 1)
                end)
          end) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_pipe_eq (Header.read_opt (store, b))
      (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
    (fun header =>
      let pred := predecessor (shell header) in
      if Tezos_base__TzPervasives.Block_hash.equal b pred then
        Lwt.return_unit
      else
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Block.Predecessors.store (store, b) 0 pred)
          (fun function_parameter =>
            match function_parameter with
            | tt => loop pred 1
            end)).

Definition predecessor_n_raw
  (store : Tezos_shell__Store.Block.store)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
  : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
  let power_of_2 (n : Z) : Z :=
    if OCaml.Stdlib.lt n 0 then
      OCaml.Stdlib.invalid_arg "negative argument" % string
    else
      let fix loop (cnt : Z) (res : Z) : Z :=
        if OCaml.Stdlib.lt cnt 1 then
          res
        else
          loop (Z.sub cnt 1) (Z.mul res 2) in
      loop n 1 in
  let closest_power_two_and_rest (n : Z) : Z * Z :=
    if OCaml.Stdlib.lt n 0 then
      OCaml.Stdlib.invalid_arg "negative argument" % string
    else
      let fix loop (cnt : Z) (n : Z) (rest : Z) : Z * Z :=
        if OCaml.Stdlib.le n 1 then
          (cnt, rest)
        else
          loop (Z.add cnt 1) (Z.div n 2)
            (Z.add rest (Z.mul (power_of_2 cnt) (Z.modulo n 2))) in
      loop 0 n 0 in
  if OCaml.Stdlib.lt distance 0 then
    OCaml.Stdlib.invalid_arg
      (String.append "State.predecessor: distance < 0 " % string
        (OCaml.Stdlib.string_of_int distance))
  else
    if equiv_decb distance 0 then
      Lwt.return_some block_hash
    else
      let fix loop
        (block_hash : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
        : Lwt.t (option Tezos_shell.Store.Block.Predecessors.value) :=
        if equiv_decb distance 1 then
          Tezos_shell.Store.Block.Predecessors.read_opt (store, block_hash) 0
        else
          match closest_power_two_and_rest distance with
          | (power, rest) =>
            match
              if OCaml.Stdlib.lt power stored_predecessors_size then
                (power, rest)
              else
                let power := Z.sub stored_predecessors_size 1 in
                let rest := Z.sub distance (power_of_2 power) in
                (power, rest) with
            | (power, rest) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Store.Block.Predecessors.read_opt
                  (store, block_hash) power)
                (fun function_parameter =>
                  match function_parameter with
                  | None => Lwt.return_none
                  | Some pred =>
                    if equiv_decb rest 0 then
                      Lwt.return_some pred
                    else
                      loop pred rest
                  end)
            end
          end in
      loop block_hash distance.

Definition predecessor_n (op_star_o_p_t_star : option bool)
  : Tezos_shell__Store.Block.store ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Z -> Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
  let below_save_point :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun block_store =>
    fun block_hash =>
      fun distance =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (predecessor_n_raw block_store block_hash distance)
          (fun function_parameter =>
            match function_parameter with
            | None => Lwt.return_none
            | Some predecessor =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (if below_save_point then
                  Header.known (block_store, predecessor)
                else
                  Tezos_shell.Store.Block.Contents.known
                    (block_store, predecessor))
                (fun function_parameter =>
                  match function_parameter with
                  | false => Lwt.return_none
                  | true => Lwt.return_some predecessor
                  end)
            end).

Definition compute_locator_from_hash
  (chain_state : chain_state) (op_star_o_p_t_star : option Z)
  : Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Block_locator.seed ->
      Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
  let size :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 200
    end in
  fun head_hash =>
    fun seed =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Shared.use (chain_data chain_state)
          (fun state => Lwt._return (caboose (data state))))
        (fun function_parameter =>
          match function_parameter with
          | (_lvl, caboose) =>
            Shared.use (block_store chain_state)
              (fun block_store =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_base__TzPervasives.op_gt_pipe_eq
                    (Header.read_opt (block_store, head_hash))
                    (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
                  (fun header =>
                    Tezos_base__TzPervasives.Block_locator.compute
                      (predecessor_n (Some true) block_store) caboose size
                      head_hash header seed))
          end).

Definition compute_locator
  (chain : chain_state) (size : option Z) (head : block)
  (seed : Tezos_base__TzPervasives.Block_locator.seed)
  : Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
  compute_locator_from_hash chain size (hash head) seed.

Definition t := global_state.

Module Locked_block.
  Definition store_genesis
    (store : Tezos_shell__Store.Block.store) (genesis : genesis)
    (context : Tezos_crypto.Context_hash.t)
    : Lwt.t Tezos_base__TzPervasives.Block_header.t :=
    let shell :=
      {| level := 0; proto_level := 0; predecessor := block genesis;
        timestamp := time genesis; validation_passes := 0;
        operations_hash :=
          Tezos_base__TzPervasives.Operation_list_list_hash.empty;
        fitness := []; context := context |} in
    let header := {| shell := shell; protocol_data := Stdlib.Bytes.create 0 |}
      in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Store.Block.Contents.store (store, (block genesis))
        {| Store.Block.header := header;
          Store.Block.message := Some "Genesis" % string;
          Store.Block.max_operations_ttl := 0;
          Store.Block.last_allowed_fork_level := 0;
          Store.Block.context := context;
          Store.Block.metadata := Stdlib.Bytes.create 0 |})
      (fun function_parameter =>
        match function_parameter with
        | tt => Lwt._return header
        end).
  
  Definition acceptable
    (chain_data : chain_data_state)
    (header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
    let checkpoint_level := level (shell (checkpoint chain_data)) in
    if OCaml.Stdlib.lt checkpoint_level (level (shell header)) then
      Lwt.return_true
    else
      if equiv_decb checkpoint_level (level (shell header)) then
        Lwt._return
          (Tezos_base__TzPervasives.Block_header.equal header
            (checkpoint chain_data))
      else
        let head_level :=
          level (shell (header (current_head (data chain_data)))) in
        Lwt._return (OCaml.Stdlib.lt head_level checkpoint_level).
  
  Definition is_valid_for_checkpoint
    (block_store : Tezos_shell__Store.Block.store)
    (hash : Tezos_base__TzPervasives.Block_hash.t)
    (header : Tezos_base__TzPervasives.Block_header.t)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
    if
      Tezos_base__TzPervasives.Compare.Int32.op_lt (level (shell header))
        (level (shell checkpoint)) then
      Lwt.return_true
    else
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_base__TzPervasives.op_gt_pipe_eq
          (predecessor_n None block_store hash
            (apply Stdlib.Int32.to_int
              (Stdlib.Int32.sub (level (shell header))
                (level (shell checkpoint)))))
          (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
        (fun predecessor =>
          if
            Tezos_base__TzPervasives.Block_hash.equal predecessor
              (Tezos_base__TzPervasives.Block_header.hash checkpoint) then
            Lwt.return_true
          else
            Lwt.return_false).
End Locked_block.

Definition locked_valid_heads_for_checkpoint
  (block_store : Tezos_shell__Store.Block.store) (data : chain_data_state)
  (checkpoint : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t
    ((list
      (Tezos_base__TzPervasives.Block_hash.Set.elt *
        Tezos_base__TzPervasives.Block_header.t)) *
      (list
        (Tezos_base__TzPervasives.Block_hash.Set.elt *
          Tezos_base__TzPervasives.Block_header.t))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.Store.Chain_data.Known_heads.read_all (chain_data_store data))
    (fun heads =>
      Tezos_base__TzPervasives.Block_hash.Set.fold
        (fun head =>
          fun acc =>
            let valid_header :=
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_base__TzPervasives.op_gt_pipe_eq
                  (Header.read_opt (block_store, head))
                  (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
                (fun header =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Locked_block.is_valid_for_checkpoint block_store head
                      header checkpoint)
                    (fun valid => Lwt._return (valid, header))) in
            Tezos_base__TzPervasives.op_gt_gt_eq acc
              (fun function_parameter =>
                match function_parameter with
                | (valid_heads, invalid_heads) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq valid_header
                    (fun function_parameter =>
                      match function_parameter with
                      | (valid, header) =>
                        if valid then
                          Lwt._return
                            ((cons (head, header) valid_heads), invalid_heads)
                        else
                          Lwt._return
                            (valid_heads, (cons (head, header) invalid_heads))
                      end)
                end)) heads (Lwt._return ([], []))).

Definition tag_invalid_heads
  (block_store : Tezos_shell.Store.Block.Invalid_block.t)
  (chain_store : Tezos_shell__Store.Chain_data.store)
  (heads :
    list
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t)) (level : Stdlib.Int32.t)
  : Lwt.t
    (list
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t)) :=
  let fix tag_invalid_head
    (function_parameter :
    Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t
      (option
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t)) :=
    match function_parameter with
    | (hash, header) =>
      if OCaml.Stdlib.le (level (Block_header.shell header)) level then
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Chain_data.Known_heads.store chain_store hash)
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt.return_some (hash, header)
            end)
      else
        let errors := cons (Validation_errors.Checkpoint_error hash None) [] in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Block.Invalid_block.store block_store hash
            {| level := level (shell header); errors := errors |})
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Store.Block.Contents.remove (block_store, hash))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.Store.Block.Operation_hashes.remove_all
                        (block_store, hash))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_shell.Store.Block.Operations_metadata.remove_all
                              (block_store, hash))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Tezos_shell.Store.Block.Operations.remove_all
                                    (block_store, hash))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_shell.Store.Block.Predecessors.remove_all
                                          (block_store, hash))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (Header.read_opt
                                                (block_store,
                                                  (predecessor (shell header))))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | None => Lwt.return_none
                                                | Some header =>
                                                  tag_invalid_head
                                                    ((Tezos_base__TzPervasives.Block_header.hash
                                                      header), header)
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
    end in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Lwt_list.iter_p
      (fun function_parameter =>
        match function_parameter with
        | (hash, _header) =>
          Tezos_shell.Store.Chain_data.Known_heads.remove chain_store hash
        end) heads)
    (fun function_parameter =>
      match function_parameter with
      | tt => Lwt_list.filter_map_s tag_invalid_head heads
      end).

Definition prune_block
  (store : Tezos_shell__Store.Block.store)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  let st := (store, block_hash) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.Store.Block.Contents.remove st)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Block.Invalid_block.remove store block_hash)
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_shell.Store.Block.Operations_metadata.remove_all st
            end)
      end).

Definition store_header_and_prune_block
  (store : Tezos_shell__Store.Block.store)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  let st := (store, block_hash) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Store.Block.Contents.read_opt st)
      (fun function_parameter =>
        match function_parameter with
        | Some {| header := header |} =>
          Tezos_shell.Store.Block.Pruned_contents.store st
            {| header := header |}
        | None =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.Store.Block.Pruned_contents.known st)
            (fun function_parameter =>
              match function_parameter with
              | true => Lwt.return_unit
              | false =>
                Tezos_shell_services.State_logging.lwt_log_error
                  (fun f =>
                    Tezos_shell_services.State_logging.Tag.DSL.op_minus_percent
                      (Tezos_shell_services.State_logging.Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  CamlinternalFormatBasics.End_of_format
                                  "" % string))
                              (CamlinternalFormatBasics.String_literal
                                "cannot find pruned contents of block " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))
                            "@[cannot find pruned contents of block %a@]" %
                              string))
                        (Tezos_shell_services.State_logging.Tag.DSL.t
                          Tezos_shell_services.State_logging.event
                          "missing_pruned_contents" % string))
                      (Tezos_shell_services.State_logging.Tag.DSL.a
                        Tezos_base__TzPervasives.Block_hash.Logging.tag
                        block_hash))
              end)
        end))
    (fun function_parameter =>
      match function_parameter with
      | tt => prune_block store block_hash
      end).

Definition delete_block
  (store : Tezos_shell__Store.Block.store)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq (prune_block store block_hash)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let st := (store, block_hash) in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Block.Pruned_contents.remove st)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Store.Block.Operations.remove_all st)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.Store.Block.Operation_hashes.remove_all st)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_shell.Store.Block.Predecessors.remove_all st
                        end)
                  end)
            end)
      end).

Definition cut_alternate_heads
  (block_store : Tezos_shell__Store.Block.store)
  (chain_store : Tezos_shell__Store.Chain_data.store)
  (heads :
    list
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t)) : Lwt.t unit :=
  let fix cut_alternate_head
    (hash : Tezos_base__TzPervasives.Block_hash.t) (header :
    Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Store.Chain_data.In_main_branch.known (chain_store, hash))
      (fun in_chain =>
        if in_chain then
          Lwt.return_unit
        else
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Header.read_opt
              (block_store, (predecessor (Block_header.shell header))))
            (fun function_parameter =>
              match function_parameter with
              | None =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (delete_block block_store hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Lwt.return_unit
                    end)
              | Some header =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (delete_block block_store hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      cut_alternate_head
                        (Tezos_base__TzPervasives.Block_header.hash header)
                        header
                    end)
              end)) in
  Lwt_list.iter_p
    (fun function_parameter =>
      match function_parameter with
      | (hash, header) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Chain_data.Known_heads.remove chain_store hash)
          (fun function_parameter =>
            match function_parameter with
            | tt => cut_alternate_head hash header
            end)
      end) heads.

Module Chain.
  Record genesis := {
    time : Tezos_base__TzPervasives.Time.Protocol.t;
    block : Tezos_base__TzPervasives.Block_hash.t;
    protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
  
  Definition genesis_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding genesis :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| time := time; block := block; protocol := protocol |} =>
          (time, block, protocol)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (time, block, protocol) =>
          {| time := time; block := block; protocol := protocol |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj3
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "timestamp" % string Tezos_base__TzPervasives.Time.Protocol.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "block" % string
          Tezos_base__TzPervasives.Block_hash.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "protocol" % string Tezos_base__TzPervasives.Protocol_hash.encoding)).
  
  Definition t := chain_state.
  
  Definition chain_state := t.
  
  Definition main (function_parameter : global_state)
    : Tezos_base__TzPervasives.Chain_id.t :=
    match function_parameter with
    | {| main_chain := main_chain |} => main_chain
    end.
  
  Definition test (chain_state : chain_state)
    : Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
    read_chain_data chain_state
      (fun function_parameter =>
        match function_parameter with
        | _ => fun chain_data => Lwt._return (test_chain chain_data)
        end).
  
  Definition get_level_indexed_protocol
    (chain_state : chain_state)
    (header : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
    let chain_id := chain_id chain_state in
    let protocol_level := proto_level (Block_header.shell header) in
    let global_state := global_state chain_state in
    Shared.use (global_data global_state)
      (fun global_data =>
        let global_store := global_store global_data in
        let chain_store := Tezos_shell.Store.Chain.get global_store chain_id in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Chain.Protocol_info.read_opt chain_store
            protocol_level)
          (fun function_parameter =>
            match function_parameter with
            | None =>
              Stdlib.Pervasives.failwith
                "State.Chain.get_level_index_protocol" % string
            | Some (p, _) => Lwt._return p
            end)).
  
  Definition update_level_indexed_protocol_store
    (chain_state : chain_state) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    (protocol_level : Tezos_shell.Store.Chain.Protocol_info.key)
    (protocol_hash : Tezos_base__TzPervasives.Protocol_hash.t)
    (block_header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
    let global_state := global_state chain_state in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Shared.use (block_store chain_state)
        (fun block_store =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Header.read_opt
              (block_store, (predecessor (Block_header.shell block_header))))
            (fun function_parameter =>
              match function_parameter with
              | None => Lwt.return_none
              | Some header => Lwt.return_some header
              end)))
      (fun function_parameter =>
        match function_parameter with
        | None => Lwt.return_unit
        | Some pred_header =>
          if
            nequiv_decb (proto_level (shell pred_header))
              (proto_level (shell block_header)) then
            Shared.use (global_data global_state)
              (fun global_data =>
                let global_store := global_store global_data in
                let chain_store :=
                  Tezos_shell.Store.Chain.get global_store chain_id in
                Tezos_shell.Store.Chain.Protocol_info.store chain_store
                  protocol_level (protocol_hash, (level (shell block_header))))
          else
            Lwt.return_unit
        end).
  
  Definition allocate
    (genesis : genesis)
    (faked_genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
    (save_point : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
    (caboose : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
    (expiration : option Tezos_base__TzPervasives.Time.Protocol.t)
    (allow_forked_chain : bool)
    (current_head : Tezos_base__TzPervasives.Block_hash.t)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t)
    (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    (global_state : global_state) (context_index : Tezos_storage.Context.index)
    (chain_data_store : Tezos_shell.Store.Chain_data.store)
    (block_store : Tezos_shell.Store.Block.store) : Lwt.t chain_state :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.op_gt_pipe_eq
        (Header.read_opt (block_store, current_head))
        (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
      (fun current_block_head =>
        let fix chain_data : chain_data_state :=
          {|
            data :=
              {|
                current_head :=
                  {| chain_state := chain_state; hash := current_head;
                    header := current_block_head |};
                current_mempool := Tezos_base__TzPervasives.Mempool.empty;
                live_blocks :=
                  Tezos_base__TzPervasives.Block_hash.Set.singleton
                    (block genesis);
                live_operations :=
                  Tezos_base__TzPervasives.Operation_hash.Set.empty;
                test_chain := None; save_point := save_point; caboose := caboose
                |}; checkpoint := checkpoint;
            chain_data_store := chain_data_store |}
        with chain_state : chain_state :=
          {| global_state := global_state; chain_id := chain_id;
            genesis := genesis; faked_genesis_hash := faked_genesis_hash;
            expiration := expiration; allow_forked_chain := allow_forked_chain;
            block_store := Shared.create block_store;
            context_index := Shared.create context_index;
            block_watcher :=
              Tezos_base__TzPervasives.Lwt_watcher.create_input tt;
            chain_data :=
              {| Shared.data := chain_data; Shared.lock := Lwt_mutex.create tt
                |};
            block_rpc_directories :=
              Tezos_base__TzPervasives.Protocol_hash.Table.create 7;
            header_rpc_directories :=
              Tezos_base__TzPervasives.Protocol_hash.Table.create 7 |} in
        Lwt._return chain_state).
  
  Definition locked_create
    (global_state : global_state) (data : global_data)
    (expiration : option Tezos_base__TzPervasives.Time.Protocol.t)
    (op_star_o_p_t_star : option bool)
    : Tezos_base__TzPervasives.Chain_id.t ->
      genesis -> Tezos_base__TzPervasives.Block_header.t -> Lwt.t chain_state :=
    let allow_forked_chain :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun chain_id =>
      fun genesis =>
        fun genesis_header =>
          let chain_store :=
            Tezos_shell.Store.Chain.get (global_store data) chain_id in
          let block_store : Tezos_shell.Store.Block.store :=
            Tezos_shell.Store.Block.get chain_store
          with chain_data_store : Tezos_shell.Store.Chain_data.store :=
            Tezos_shell.Store.Chain_data.get chain_store in
          let save_point := ((level (shell genesis_header)), (block genesis)) in
          let caboose := ((level (shell genesis_header)), (block genesis)) in
          let proto_level := proto_level (shell genesis_header) in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.Store.Chain.Genesis_hash.store chain_store
              (block genesis))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Store.Chain.Genesis_time.store chain_store
                    (time genesis))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.Store.Chain.Genesis_protocol.store
                          chain_store (protocol genesis))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_shell.Store.Chain_data.Current_head.store
                                chain_data_store (block genesis))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_shell.Store.Chain_data.Known_heads.store
                                      chain_data_store (block genesis))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (Tezos_shell.Store.Chain_data.Checkpoint.store
                                            chain_data_store genesis_header)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (Tezos_shell.Store.Chain_data.Save_point.store
                                                  chain_data_store save_point)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (Tezos_shell.Store.Chain_data.Caboose.store
                                                        chain_data_store caboose)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (Tezos_shell.Store.Chain.Protocol_info.store
                                                              chain_store
                                                              proto_level
                                                              ((protocol genesis),
                                                                (level
                                                                  (shell
                                                                    genesis_header))))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                  match
                                                                    expiration
                                                                    with
                                                                  | None =>
                                                                    Lwt.return_unit
                                                                  | Some time =>
                                                                    Tezos_shell.Store.Chain.Expiration.store
                                                                      chain_store
                                                                      time
                                                                  end
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | tt =>
                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                        (if
                                                                          allow_forked_chain
                                                                          then
                                                                          Tezos_shell.Store.Chain.Allow_forked_chain.store
                                                                            (global_store
                                                                              data)
                                                                            chain_id
                                                                        else
                                                                          Lwt.return_unit)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | tt
                                                                            =>
                                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                                              (allocate
                                                                                genesis
                                                                                (Tezos_base__TzPervasives.Block_header.hash
                                                                                  genesis_header)
                                                                                save_point
                                                                                caboose
                                                                                expiration
                                                                                allow_forked_chain
                                                                                (block
                                                                                  genesis)
                                                                                genesis_header
                                                                                chain_id
                                                                                global_state
                                                                                (context_index
                                                                                  data)
                                                                                chain_data_store
                                                                                block_store)
                                                                              (fun
                                                                                chain
                                                                                =>
                                                                                Tezos_base__TzPervasives.Chain_id.Table.add
                                                                                  (chains
                                                                                    data)
                                                                                  chain_id
                                                                                  chain;
                                                                                Lwt._return
                                                                                  chain)
                                                                          end)
                                                                    end)
                                                              end)
                                                        end)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end).
  
  Definition create
    (state : global_state) (allow_forked_chain : option bool)
    (commit_genesis :
      Tezos_base__TzPervasives.Chain_id.t ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Protocol_hash.t ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t))
    (genesis : genesis) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
    Shared.use (global_data state)
      (fun data =>
        let chain_store :=
          Tezos_shell.Store.Chain.get (global_store data) chain_id in
        let block_store := Tezos_shell.Store.Block.get chain_store in
        if Tezos_base__TzPervasives.Chain_id.Table.mem (chains data) chain_id
          then
          Stdlib.Pervasives.failwith "State.Chain.create" % string
        else
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (commit_genesis chain_id (time genesis) (protocol genesis))
            (fun commit =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Locked_block.store_genesis block_store genesis commit)
                (fun genesis_header =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (locked_create state data None allow_forked_chain chain_id
                      genesis genesis_header)
                    (fun chain =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.Store.Forking_block_hash.remove
                          (global_store data)
                          (Tezos_storage.Context.compute_testchain_chain_id
                            (block genesis)))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives._return chain
                          end))))).
  
  Definition locked_read
    (global_state : global_state) (data : global_data)
    (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
    let chain_store := Tezos_shell.Store.Chain.get (global_store data) chain_id
      in
    let block_store : Tezos_shell.Store.Block.store :=
      Tezos_shell.Store.Block.get chain_store
    with chain_data_store : Tezos_shell.Store.Chain_data.store :=
      Tezos_shell.Store.Chain_data.get chain_store in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_shell.Store.Chain.Genesis_hash.read chain_store)
      (fun genesis_hash =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_shell.Store.Chain.Genesis_time.read chain_store)
          (fun time =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_shell.Store.Chain.Genesis_protocol.read chain_store)
              (fun protocol =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Store.Chain.Expiration.read_opt chain_store)
                  (fun expiration =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.Store.Chain.Allow_forked_chain.known
                        (global_store data) chain_id)
                      (fun allow_forked_chain =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Header.read (block_store, genesis_hash))
                          (fun genesis_header =>
                            let genesis :=
                              {| time := time; block := genesis_hash;
                                protocol := protocol |} in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_shell.Store.Chain_data.Current_head.read
                                chain_data_store)
                              (fun current_head =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_shell.Store.Chain_data.Checkpoint.read
                                    chain_data_store)
                                  (fun checkpoint =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_shell.Store.Chain_data.Save_point.read
                                        chain_data_store)
                                      (fun save_point =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_shell.Store.Chain_data.Caboose.read
                                            chain_data_store)
                                          (fun caboose => try)))))))))).
  
  Definition locked_read_all (global_state : global_state) (data : global_data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Store.Chain.list (global_store data))
      (fun ids =>
        Tezos_base__TzPervasives.iter_p
          (fun id =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (locked_read global_state data id)
              (fun chain =>
                Tezos_base__TzPervasives.Chain_id.Table.add (chains data) id
                  chain;
                Tezos_base__TzPervasives.return_unit)) ids).
  
  Definition read_all (state : global_state)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Shared.use (global_data state) (fun data => locked_read_all state data).
  
  Definition get_exn
    (state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
    : Lwt.t chain_state :=
    Shared.use (global_data state)
      (fun data =>
        Lwt._return
          (Tezos_base__TzPervasives.Chain_id.Table.find (chains data) id)).
  
  Definition get_opt
    (state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
    : Lwt.t (option chain_state) :=
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq (get_exn state id)
            Lwt.return_some
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ => Lwt.return_none
        end).
  
  Definition get
    (state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
    : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq (get_exn state id)
            Tezos_base__TzPervasives._return
        end)
      (fun function_parameter =>
        match function_parameter with
        | OCaml.Not_found => Tezos_base__TzPervasives.fail (Unknown_chain id)
        | exn => Lwt.fail exn
        end).
  
  Definition all (state : global_state) : Lwt.t (list chain_state) :=
    Shared.use (global_data state)
      (fun function_parameter =>
        match function_parameter with
        | {| chains := chains |} =>
          apply Lwt._return
            (Tezos_base__TzPervasives.Chain_id.Table.fold
              (fun function_parameter =>
                match function_parameter with
                | _ => fun chain => fun acc => cons chain acc
                end) chains [])
        end).
  
  Definition id (function_parameter : chain_state)
    : Tezos_base__TzPervasives.Chain_id.t :=
    match function_parameter with
    | {| chain_id := chain_id |} => chain_id
    end.
  
  Definition genesis (function_parameter : chain_state) : genesis :=
    match function_parameter with
    | {| genesis := genesis |} => genesis
    end.
  
  Definition faked_genesis_hash (function_parameter : chain_state)
    : Tezos_base__TzPervasives.Block_hash.t :=
    match function_parameter with
    | {| faked_genesis_hash := faked_genesis_hash |} => faked_genesis_hash
    end.
  
  Definition expiration (function_parameter : chain_state)
    : option Tezos_base__TzPervasives.Time.Protocol.t :=
    match function_parameter with
    | {| expiration := expiration |} => expiration
    end.
  
  Definition allow_forked_chain (function_parameter : chain_state) : bool :=
    match function_parameter with
    | {| allow_forked_chain := allow_forked_chain |} => allow_forked_chain
    end.
  
  Definition global_state (function_parameter : chain_state) : global_state :=
    match function_parameter with
    | {| global_state := global_state |} => global_state
    end.
  
  Definition checkpoint (chain_state : chain_state)
    : Lwt.t Tezos_base__TzPervasives.Block_header.t :=
    Shared.use (chain_data chain_state)
      (fun function_parameter =>
        match function_parameter with
        | {| checkpoint := checkpoint |} => Lwt._return checkpoint
        end).
  
  Definition save_point (chain_state : chain_state)
    : Lwt.t (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t) :=
    Shared.use (chain_data chain_state)
      (fun state => Lwt._return (save_point (data state))).
  
  Definition caboose (chain_state : chain_state)
    : Lwt.t (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t) :=
    Shared.use (chain_data chain_state)
      (fun state => Lwt._return (caboose (data state))).
  
  Definition purge_loop_full (op_star_o_p_t_star : option Z)
    : Tezos_shell.Store.t ->
      Tezos_shell__Store.Block.store ->
        Tezos_base__TzPervasives.Block_hash.t ->
          Tezos_base__TzPervasives.Block_hash.t -> Stdlib.Int32.t -> Lwt.t unit :=
    let chunk_size :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => 4000
      end in
    fun global_store =>
      fun store =>
        fun genesis_hash =>
          fun block_hash =>
            fun caboose_level =>
              let do_prune (blocks : list Tezos_base__TzPervasives.Block_hash.t)
                : Lwt.t unit :=
                apply (Tezos_shell.Store.with_atomic_rw global_store)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Lwt_list.iter_s (store_header_and_prune_block store)
                        blocks
                    end) in
              let fix loop
                (block_hash : Tezos_base__TzPervasives.Block_hash.t)
                (function_parameter :
                Z * (list Tezos_base__TzPervasives.Block_hash.t))
                : Lwt.t unit :=
                match function_parameter with
                | (n_blocks, blocks) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (if OCaml.Stdlib.ge n_blocks chunk_size then
                      Tezos_base__TzPervasives.op_gt_gt_eq (do_prune blocks)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Lwt._return (0, [])
                          end)
                    else
                      Lwt._return (n_blocks, blocks))
                    (fun function_parameter =>
                      match function_parameter with
                      | (n_blocks, blocks) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_base__TzPervasives.op_gt_pipe_eq
                            (Header.read_opt (store, block_hash))
                            (Tezos_base__TzPervasives.Option.unopt_assert
                              Stdlib.__POS__))
                          (fun header =>
                            if
                              Tezos_base__TzPervasives.Block_hash.equal
                                block_hash genesis_hash then
                              do_prune blocks
                            else
                              if equiv_decb (level (shell header)) caboose_level
                                then
                                do_prune (cons block_hash blocks)
                              else
                                loop (predecessor (shell header))
                                  ((Z.add n_blocks 1), (cons block_hash blocks)))
                      end)
                end in
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_base__TzPervasives.op_gt_pipe_eq
                  (Header.read_opt (store, block_hash))
                  (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
                (fun header => loop (predecessor (shell header)) (0, [])).
  
  Definition purge_full
    (chain_state : chain_state)
    (function_parameter : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    match function_parameter with
    | (lvl, hash) =>
      Shared.use (global_data (global_state chain_state))
        (fun global_data =>
          Shared.use (block_store chain_state)
            (fun store =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (update_chain_data chain_state
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      fun data =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (purge_loop_full None (global_store global_data) store
                            (block (genesis chain_state)) hash
                            (fst (save_point data)))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              let new_data := record in
                              Lwt._return ((Some new_data), tt)
                            end)
                    end))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Shared.use (chain_data chain_state)
                      (fun data =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_shell.Store.Chain_data.Save_point.store
                            (chain_data_store data) (lvl, hash))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_unit
                            end))
                  end)))
    end.
  
  Definition purge_loop_rolling
    (global_store : Tezos_shell.Store.t)
    (store : Tezos_shell__Store.Block.store)
    (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
    (block_hash : Tezos_base__TzPervasives.Block_hash.t) (limit : Z)
    : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
    let do_delete (blocks : list Tezos_base__TzPervasives.Block_hash.t)
      : Lwt.t unit :=
      apply (Tezos_shell.Store.with_atomic_rw global_store)
        (fun function_parameter =>
          match function_parameter with
          | tt => Lwt_list.iter_s (delete_block store) blocks
          end) in
    let fix prune_loop
      (block_hash : Tezos_base__TzPervasives.Block_hash.t) (limit : Z)
      : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
      if Tezos_base__TzPervasives.Block_hash.equal genesis_hash block_hash then
        Lwt._return block_hash
      else
        if equiv_decb limit 1 then
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Header.read_opt (store, block_hash))
            (fun function_parameter =>
              match function_parameter with
              | None => false
              | Some header =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (store_header_and_prune_block store block_hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (delete_loop (predecessor (shell header)) (0, []))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Lwt._return block_hash
                          end)
                    end)
              end)
        else
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Header.read_opt (store, block_hash))
            (fun function_parameter =>
              match function_parameter with
              | None => false
              | Some header =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (store_header_and_prune_block store block_hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      prune_loop (predecessor (shell header)) (Z.sub limit 1)
                    end)
              end)
    with delete_loop
      (block_hash : Tezos_crypto.Block_hash.t) (function_parameter :
      Z * (list Tezos_base__TzPervasives.Block_hash.t)) : Lwt.t unit :=
      match function_parameter with
      | (n_blocks, blocks) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (if OCaml.Stdlib.ge n_blocks 4000 then
            Tezos_base__TzPervasives.op_gt_gt_eq (do_delete blocks)
              (fun function_parameter =>
                match function_parameter with
                | tt => Lwt._return (0, [])
                end)
          else
            Lwt._return (n_blocks, blocks))
          (fun function_parameter =>
            match function_parameter with
            | (n_blocks, blocks) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Header.read_opt (store, block_hash))
                (fun function_parameter =>
                  match function_parameter with
                  | None => do_delete blocks
                  | Some header =>
                    if
                      Tezos_base__TzPervasives.Block_hash.equal genesis_hash
                        block_hash then
                      do_delete blocks
                    else
                      delete_loop (predecessor (shell header))
                        ((Z.add n_blocks 1), (cons block_hash blocks))
                  end)
            end)
      end in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_base__TzPervasives.op_gt_pipe_eq
        (Header.read_opt (store, block_hash))
        (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
      (fun header =>
        if equiv_decb limit 0 then
          Tezos_base__TzPervasives.op_gt_gt_eq
            (delete_loop (predecessor (shell header)) (0, []))
            (fun function_parameter =>
              match function_parameter with
              | tt => Lwt._return block_hash
              end)
        else
          prune_loop (predecessor (shell header)) limit).
  
  Definition purge_rolling
    (chain_state : chain_state)
    (function_parameter : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    match function_parameter with
    | (lvl, hash) as checkpoint =>
      Shared.use (global_data (global_state chain_state))
        (fun global_data =>
          Shared.use (block_store chain_state)
            (fun store =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Store.Block.Contents.read_opt (store, hash))
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      Tezos_base__TzPervasives.fail
                        (Block_contents_not_found hash)
                    | Some contents => Tezos_base__TzPervasives._return contents
                    end))
                (fun contents =>
                  let max_op_ttl := max_operations_ttl contents in
                  let limit := max_op_ttl in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (purge_loop_rolling (global_store global_data) store
                      (block (genesis chain_state)) hash limit)
                    (fun caboose_hash =>
                      let caboose_level :=
                        Stdlib.Int32.sub lvl (Stdlib.Int32.of_int max_op_ttl) in
                      let caboose := (caboose_level, caboose_hash) in
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (update_chain_data chain_state
                          (fun function_parameter =>
                            match function_parameter with
                            | _ =>
                              fun data =>
                                let new_data := record in
                                Lwt._return ((Some new_data), tt)
                            end))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Shared.use (chain_data chain_state)
                              (fun data =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Tezos_shell.Store.Chain_data.Save_point.store
                                    (chain_data_store data) checkpoint)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_shell.Store.Chain_data.Caboose.store
                                          (chain_data_store data) caboose)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.return_unit
                                          end)
                                    end))
                          end)))))
    end.
  
  Definition set_checkpoint
    (chain_state : chain_state)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
    Shared.use (block_store chain_state)
      (fun store =>
        Shared.use (chain_data chain_state)
          (fun data =>
            let head_header := header (current_head (data data)) in
            let head_hash := hash (current_head (data data)) in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Locked_block.is_valid_for_checkpoint store head_hash head_header
                checkpoint)
              (fun valid =>
                valid;
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Store.Block.Invalid_block.iter store
                    (fun hash =>
                      fun iblock =>
                        if
                          OCaml.Stdlib.le (level iblock)
                            (level (shell checkpoint)) then
                          Tezos_shell.Store.Block.Invalid_block.remove store
                            hash
                        else
                          Lwt.return_unit))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_base__TzPervasives.op_gt_gt_eq
                          (locked_valid_heads_for_checkpoint store data
                            checkpoint)
                          (fun function_parameter =>
                            match function_parameter with
                            | (valid_heads, invalid_heads) =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (tag_invalid_heads store (chain_data_store data)
                                  invalid_heads (level (shell checkpoint)))
                                (fun outdated_invalid_heads =>
                                  if
                                    OCaml.Stdlib.lt (level (shell head_header))
                                      (level (shell checkpoint)) then
                                    Lwt.return_unit
                                  else
                                    let outdated_valid_heads :=
                                      Tezos_base__TzPervasives.List.filter
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            (hash, {|
                                              Block_header.shell := shell |})
                                            =>
                                            andb
                                              (OCaml.Stdlib.le (level shell)
                                                (level (shell checkpoint)))
                                              (negb
                                                (Tezos_base__TzPervasives.Block_hash.equal
                                                  hash head_hash))
                                          end) valid_heads in
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (cut_alternate_heads store
                                        (chain_data_store data)
                                        outdated_valid_heads)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          cut_alternate_heads store
                                            (chain_data_store data)
                                            outdated_invalid_heads
                                        end))
                            end))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_shell.Store.Chain_data.Checkpoint.store
                                (chain_data_store data) checkpoint)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  set_field;
                                  Lwt.return_unit
                                end)
                          end)
                    end)))).
  
  Definition set_checkpoint_then_purge_full
    (chain_state : chain_state)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq (set_checkpoint chain_state checkpoint)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let lvl := level (shell checkpoint) in
          let hash := Tezos_base__TzPervasives.Block_header.hash checkpoint in
          purge_full chain_state (lvl, hash)
        end).
  
  Definition set_checkpoint_then_purge_rolling
    (chain_state : chain_state)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq (set_checkpoint chain_state checkpoint)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let lvl := level (shell checkpoint) in
          let hash := Tezos_base__TzPervasives.Block_header.hash checkpoint in
          purge_rolling chain_state (lvl, hash)
        end).
  
  Definition acceptable_block
    (chain_state : chain_state)
    (header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
    Shared.use (chain_data chain_state)
      (fun chain_data => Locked_block.acceptable chain_data header).
  
  Definition destroy (state : global_state) (chain : chain_state)
    : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell_services.State_logging.lwt_debug
        (fun f =>
          Tezos_shell_services.State_logging.Tag.DSL.op_minus_percent
            (Tezos_shell_services.State_logging.Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "destroy " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "destroy %a" % string))
              (Tezos_shell_services.State_logging.Tag.DSL.t
                Tezos_shell_services.State_logging.event "destroy" % string))
            (Tezos_shell_services.State_logging.Tag.DSL.a
              Tezos_shell_services.State_logging.chain_id (id chain))))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Shared.use (global_data state)
            (fun function_parameter =>
              match function_parameter with
              | {| chains := chains; global_store := global_store |} =>
                Tezos_base__TzPervasives.Chain_id.Table.remove chains (id chain);
                Tezos_shell.Store.Chain.destroy global_store (id chain)
              end)
        end).
  
  Definition store (chain_state : chain_state) : Lwt.t Tezos_shell.Store.t :=
    Shared.use (global_data (global_state chain_state))
      (fun global_data => Lwt._return (global_store global_data)).
End Chain.

Module Block.
  Record t := {
    chain_state : Chain.t;
    hash : Tezos_base__TzPervasives.Block_hash.t;
    header : Tezos_base__TzPervasives.Block_header.t }.
  
  Definition block := t.
  
  Definition compare (b1 : t) (b2 : t) : Z :=
    Tezos_base__TzPervasives.Block_hash.compare (hash b1) (hash b2).
  
  Definition equal (b1 : t) (b2 : t) : bool :=
    Tezos_base__TzPervasives.Block_hash.equal (hash b1) (hash b2).
  
  Definition hash (function_parameter : t)
    : Tezos_base__TzPervasives.Block_hash.t :=
    match function_parameter with
    | {| hash := hash |} => hash
    end.
  
  Definition header (function_parameter : t)
    : Tezos_base__TzPervasives.Block_header.t :=
    match function_parameter with
    | {| header := header |} => header
    end.
  
  Definition read_contents (block : t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_shell__Store.Block.contents) :=
    Shared.use (block_store (chain_state block))
      (fun store =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Block.Contents.read_opt (store, (hash block)))
          (fun function_parameter =>
            match function_parameter with
            | None =>
              Tezos_base__TzPervasives.fail
                (Block_contents_not_found (hash block))
            | Some contents => Tezos_base__TzPervasives._return contents
            end)).
  
  Definition header_of_hash
    (chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
    Shared.use (block_store chain_state)
      (fun store => Header.read_opt (store, hash)).
  
  Definition metadata (b : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (read_contents b)
      (fun function_parameter =>
        match function_parameter with
        | {| metadata := metadata |} =>
          Tezos_base__TzPervasives._return metadata
        end).
  
  Definition chain_state (function_parameter : t) : Chain.t :=
    match function_parameter with
    | {| chain_state := chain_state |} => chain_state
    end.
  
  Definition chain_id (function_parameter : t)
    : Tezos_base__TzPervasives.Chain_id.t :=
    match function_parameter with
    | {| chain_state := {| chain_id := chain_id |} |} => chain_id
    end.
  
  Definition shell_header (function_parameter : t)
    : Tezos_base__TzPervasives.Block_header.shell_header :=
    match function_parameter with
    | {| header := {| shell := shell |} |} => shell
    end.
  
  Definition timestamp (b : t) : Tezos_base.Time.Protocol.t :=
    timestamp (shell_header b).
  
  Definition fitness (b : t) : Tezos_base.Fitness.t := fitness (shell_header b).
  
  Definition level (b : t) : Stdlib.Int32.t := level (shell_header b).
  
  Definition validation_passes (b : t) : Z := validation_passes (shell_header b).
  
  Definition message (b : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (option string)) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (read_contents b)
      (fun function_parameter =>
        match function_parameter with
        | {| message := message |} => Tezos_base__TzPervasives._return message
        end).
  
  Definition max_operations_ttl (b : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (read_contents b)
      (fun function_parameter =>
        match function_parameter with
        | {| max_operations_ttl := max_operations_ttl |} =>
          Tezos_base__TzPervasives._return max_operations_ttl
        end).
  
  Definition last_allowed_fork_level (b : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Int32.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (read_contents b)
      (fun function_parameter =>
        match function_parameter with
        | {| last_allowed_fork_level := last_allowed_fork_level |} =>
          Tezos_base__TzPervasives._return last_allowed_fork_level
        end).
  
  Definition is_genesis (b : t) : bool :=
    Tezos_base__TzPervasives.Block_hash.equal (hash b)
      (block (genesis (chain_state b))).
  
  Definition known_valid
    (chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t bool :=
    Shared.use (block_store chain_state)
      (fun store => Header.known (store, hash)).
  
  Definition known_invalid
    (chain_state : chain_state)
    (hash : Tezos_shell.Store.Block.Invalid_block.key) : Lwt.t bool :=
    Shared.use (block_store chain_state)
      (fun store => Tezos_shell.Store.Block.Invalid_block.known store hash).
  
  Definition read_invalid
    (chain_state : chain_state)
    (hash : Tezos_shell.Store.Block.Invalid_block.key)
    : Lwt.t (option Tezos_shell.Store.Block.Invalid_block.value) :=
    Shared.use (block_store chain_state)
      (fun store => Tezos_shell.Store.Block.Invalid_block.read_opt store hash).
  
  Definition list_invalid (chain_state : chain_state)
    : Lwt.t
      (list
        (Tezos_shell.Store.Block.Invalid_block.key * int32 *
          (list Tezos_base__TzPervasives.Error_monad.error))) :=
    Shared.use (block_store chain_state)
      (fun store =>
        Tezos_shell.Store.Block.Invalid_block.fold store []
          (fun hash =>
            fun function_parameter =>
              match function_parameter with
              | {| level := level; errors := errors |} =>
                fun acc => Lwt._return (cons (hash, level, errors) acc)
              end)).
  
  Definition unmark_invalid
    (chain_state : chain_state)
    (block : Tezos_shell.Store.Block.Invalid_block.key)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Shared.use (block_store chain_state)
      (fun store =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Block.Invalid_block.known store block)
          (fun mem =>
            if mem then
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Store.Block.Invalid_block.remove store block)
                Tezos_base__TzPervasives._return
            else
              Tezos_base__TzPervasives.fail (Block_not_invalid block))).
  
  Definition is_valid_for_checkpoint
    (block : t) (checkpoint : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t bool :=
    let chain_state := chain_state block in
    Shared.use (block_store chain_state)
      (fun store =>
        Locked_block.is_valid_for_checkpoint store (hash block) (header block)
          checkpoint).
  
  Definition read_predecessor
    (chain_state : chain_state) (pred : Z) (op_star_o_p_t_star : option bool)
    : Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option t) :=
    let below_save_point :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun hash =>
      Shared.use (block_store chain_state)
        (fun store =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (predecessor_n (Some below_save_point) store hash pred)
            (fun hash_opt =>
              let new_hash_opt :=
                match hash_opt with
                | (Some _) as hash_opt => hash_opt
                | None =>
                  if
                    Tezos_base__TzPervasives.Block_hash.equal hash
                      (block (genesis chain_state)) then
                    Some (block (genesis chain_state))
                  else
                    None
                end in
              match new_hash_opt with
              | None => Lwt.fail OCaml.Not_found
              | Some hash =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Header.read_opt (store, hash))
                  (fun header =>
                    match header with
                    | Some header =>
                      Lwt.return_some
                        {| chain_state := chain_state; hash := hash;
                          header := header |}
                    | None => Lwt.return_none
                    end)
              end)).
  
  Definition read
    (chain_state : Chain.t) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    Shared.use (block_store chain_state)
      (fun store =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Header.read (store, hash))
          (fun header =>
            Tezos_base__TzPervasives._return
              {| chain_state := chain_state; hash := hash; header := header |})).
  
  Definition read_opt
    (chain_state : Chain.t) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (option t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq (read chain_state hash)
      (fun function_parameter =>
        match function_parameter with
        | inr _ => Lwt.return_none
        | inl v => Lwt.return_some v
        end).
  
  Definition predecessor (function_parameter : t) : Lwt.t (option t) :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash; header := header |} =>
      if
        Tezos_base__TzPervasives.Block_hash.equal hash
          (predecessor (shell header)) then
        Lwt.return_none
      else
        read_opt chain_state (predecessor (shell header))
    end.
  
  Definition predecessor_n (b : t) (n : Z)
    : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
    Shared.use (block_store (chain_state b))
      (fun block_store => predecessor_n None block_store (hash b) n).
  
  Definition store (op_star_o_p_t_star : option bool)
    : chain_state ->
      Tezos_base__TzPervasives.Block_header.t ->
        Stdlib.Bytes.t ->
          (list (list Tezos_base__TzPervasives.Operation.t)) ->
            (list (list Stdlib.Bytes.t)) ->
              Tezos_validation.Block_validation.validation_store ->
                bool -> Lwt.t (Tezos_base__TzPervasives.tzresult (option t)) :=
    let dont_enforce_context_hash :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun chain_state =>
      fun block_header =>
        fun block_header_metadata =>
          fun operations =>
            fun operations_metadata =>
              fun function_parameter =>
                match function_parameter with
                | {|
                  context_hash := context_hash;
                    message := message;
                    max_operations_ttl := max_operations_ttl;
                    last_allowed_fork_level := last_allowed_fork_level
                    |} =>
                  fun forking_testchain =>
                    let bytes :=
                      Tezos_base__TzPervasives.Block_header.to_bytes
                        block_header in
                    let hash :=
                      Tezos_base__TzPervasives.Block_header.hash_raw string in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_base__TzPervasives.fail_unless
                        (equiv_decb (validation_passes (shell block_header))
                          (Tezos_base__TzPervasives.List.length operations))
                        (Tezos_base__TzPervasives.failure
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "State.Block.store: invalid operations length" %
                                string CamlinternalFormatBasics.End_of_format)
                            "State.Block.store: invalid operations length" %
                              string)))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_base__TzPervasives.fail_unless
                              (equiv_decb
                                (validation_passes (shell block_header))
                                (Tezos_base__TzPervasives.List.length
                                  operations_metadata))
                              (Tezos_base__TzPervasives.failure
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "State.Block.store: invalid operations_data length"
                                      % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "State.Block.store: invalid operations_data length"
                                    % string)))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_base__TzPervasives.fail_unless
                                    (Tezos_base__TzPervasives.List.for_all2
                                      (fun l1 =>
                                        fun l2 =>
                                          equiv_decb
                                            (Tezos_base__TzPervasives.List.length
                                              l1)
                                            (Tezos_base__TzPervasives.List.length
                                              l2)) operations
                                      operations_metadata)
                                    (Tezos_base__TzPervasives.failure
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "State.Block.store: inconsistent operations and operations_data"
                                            % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "State.Block.store: inconsistent operations and operations_data"
                                          % string)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Shared.use (block_store chain_state)
                                        (fun store =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Tezos_shell.Store.Block.Invalid_block.known
                                              store hash)
                                            (fun known_invalid =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_base__TzPervasives.fail_when
                                                  known_invalid
                                                  (Tezos_base__TzPervasives.failure
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "Known invalid" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "Known invalid" % string)))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (Tezos_shell.Store.Block.Contents.known
                                                        (store, hash))
                                                      (fun known =>
                                                        if known then
                                                          Tezos_base__TzPervasives.return_none
                                                        else
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (let predecessor :=
                                                              predecessor
                                                                (shell
                                                                  block_header)
                                                              in
                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                              (Header.known
                                                                (store,
                                                                  predecessor))
                                                              (fun
                                                                valid_predecessor
                                                                =>
                                                                if
                                                                  negb
                                                                    valid_predecessor
                                                                  then
                                                                  Lwt.return_false
                                                                else
                                                                  Shared.use
                                                                    (chain_data
                                                                      chain_state)
                                                                    (fun
                                                                      chain_data
                                                                      =>
                                                                      Locked_block.acceptable
                                                                        chain_data
                                                                        block_header)))
                                                            (fun
                                                              acceptable_block
                                                              =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                (Tezos_base__TzPervasives.fail_unless
                                                                  acceptable_block
                                                                  (Checkpoint_error
                                                                    hash None))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    let
                                                                      commit :=
                                                                      context_hash
                                                                      in
                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                      (Tezos_storage.Context._exists
                                                                        (data
                                                                          (context_index
                                                                            chain_state))
                                                                        commit)
                                                                      (fun
                                                                        _exists
                                                                        =>
                                                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                          (Tezos_base__TzPervasives.fail_unless
                                                                            _exists
                                                                            (Tezos_base__TzPervasives.failure
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "State.Block.store: context hash not found in context"
                                                                                    %
                                                                                    string
                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                "State.Block.store: context hash not found in context"
                                                                                  %
                                                                                  string)))
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            | _
                                                                              =>
                                                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                (Tezos_base__TzPervasives.fail_unless
                                                                                  (orb
                                                                                    dont_enforce_context_hash
                                                                                    (Tezos_base__TzPervasives.Context_hash.equal
                                                                                      (context
                                                                                        (shell
                                                                                          block_header))
                                                                                      commit))
                                                                                  (Inconsistent_hash
                                                                                    commit
                                                                                    (context
                                                                                      (shell
                                                                                        block_header))))
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    tt
                                                                                    =>
                                                                                    let
                                                                                      header :=
                                                                                      if
                                                                                        dont_enforce_context_hash
                                                                                        then
                                                                                        record
                                                                                      else
                                                                                        block_header
                                                                                      in
                                                                                    let
                                                                                      contents :=
                                                                                      {|
                                                                                        Store.Block.header :=
                                                                                          header;
                                                                                        Store.Block.message :=
                                                                                          message;
                                                                                        Store.Block.max_operations_ttl :=
                                                                                          max_operations_ttl;
                                                                                        Store.Block.last_allowed_fork_level :=
                                                                                          last_allowed_fork_level;
                                                                                        Store.Block.context :=
                                                                                          commit;
                                                                                        Store.Block.metadata :=
                                                                                          block_header_metadata
                                                                                        |}
                                                                                      in
                                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                      (Tezos_shell.Store.Block.Contents.store
                                                                                        (store,
                                                                                          hash)
                                                                                        contents)
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          tt
                                                                                          =>
                                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                            (Lwt_list.iteri_p
                                                                                              (fun
                                                                                                i
                                                                                                =>
                                                                                                fun
                                                                                                  ops
                                                                                                  =>
                                                                                                  Tezos_shell.Store.Block.Operation_hashes.store
                                                                                                    (store,
                                                                                                      hash)
                                                                                                    i
                                                                                                    (Tezos_base__TzPervasives.List.map
                                                                                                      Tezos_base__TzPervasives.Operation.hash
                                                                                                      ops))
                                                                                              operations)
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                tt
                                                                                                =>
                                                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                  (Lwt_list.iteri_p
                                                                                                    (fun
                                                                                                      i
                                                                                                      =>
                                                                                                      fun
                                                                                                        ops
                                                                                                        =>
                                                                                                        Tezos_shell.Store.Block.Operations.store
                                                                                                          (store,
                                                                                                            hash)
                                                                                                          i
                                                                                                          ops)
                                                                                                    operations)
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    match
                                                                                                      function_parameter
                                                                                                      with
                                                                                                    |
                                                                                                      tt
                                                                                                      =>
                                                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                        (Lwt_list.iteri_p
                                                                                                          (fun
                                                                                                            i
                                                                                                            =>
                                                                                                            fun
                                                                                                              ops
                                                                                                              =>
                                                                                                              Tezos_shell.Store.Block.Operations_metadata.store
                                                                                                                (store,
                                                                                                                  hash)
                                                                                                                i
                                                                                                                ops)
                                                                                                          operations_metadata)
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          match
                                                                                                            function_parameter
                                                                                                            with
                                                                                                          |
                                                                                                            tt
                                                                                                            =>
                                                                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                              (store_predecessors
                                                                                                                store
                                                                                                                hash)
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                match
                                                                                                                  function_parameter
                                                                                                                  with
                                                                                                                |
                                                                                                                  tt
                                                                                                                  =>
                                                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                    (Shared.use
                                                                                                                      (chain_data
                                                                                                                        chain_state)
                                                                                                                      (fun
                                                                                                                        chain_data
                                                                                                                        =>
                                                                                                                        let
                                                                                                                          store :=
                                                                                                                          chain_data_store
                                                                                                                            chain_data
                                                                                                                          in
                                                                                                                        let
                                                                                                                          predecessor :=
                                                                                                                          predecessor
                                                                                                                            (shell
                                                                                                                              block_header)
                                                                                                                          in
                                                                                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                          (Tezos_shell.Store.Chain_data.Known_heads.remove
                                                                                                                            store
                                                                                                                            predecessor)
                                                                                                                          (fun
                                                                                                                            function_parameter
                                                                                                                            =>
                                                                                                                            match
                                                                                                                              function_parameter
                                                                                                                              with
                                                                                                                            |
                                                                                                                              tt
                                                                                                                              =>
                                                                                                                              Tezos_shell.Store.Chain_data.Known_heads.store
                                                                                                                                store
                                                                                                                                hash
                                                                                                                            end)))
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      match
                                                                                                                        function_parameter
                                                                                                                        with
                                                                                                                      |
                                                                                                                        tt
                                                                                                                        =>
                                                                                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                          (if
                                                                                                                            forking_testchain
                                                                                                                            then
                                                                                                                            Shared.use
                                                                                                                              (global_data
                                                                                                                                (global_state
                                                                                                                                  chain_state))
                                                                                                                              (fun
                                                                                                                                global_data
                                                                                                                                =>
                                                                                                                                let
                                                                                                                                  genesis :=
                                                                                                                                  Tezos_storage.Context.compute_testchain_genesis
                                                                                                                                    hash
                                                                                                                                  in
                                                                                                                                Tezos_shell.Store.Forking_block_hash.store
                                                                                                                                  (global_store
                                                                                                                                    global_data)
                                                                                                                                  (Tezos_storage.Context.compute_testchain_chain_id
                                                                                                                                    genesis)
                                                                                                                                  hash)
                                                                                                                          else
                                                                                                                            Lwt.return_unit)
                                                                                                                          (fun
                                                                                                                            function_parameter
                                                                                                                            =>
                                                                                                                            match
                                                                                                                              function_parameter
                                                                                                                              with
                                                                                                                            |
                                                                                                                              tt
                                                                                                                              =>
                                                                                                                              let
                                                                                                                                block :=
                                                                                                                                {|
                                                                                                                                  chain_state :=
                                                                                                                                    chain_state;
                                                                                                                                  hash :=
                                                                                                                                    hash;
                                                                                                                                  header :=
                                                                                                                                    header
                                                                                                                                  |}
                                                                                                                                in
                                                                                                                              Tezos_base__TzPervasives.Lwt_watcher.notify
                                                                                                                                (block_watcher
                                                                                                                                  chain_state)
                                                                                                                                block;
                                                                                                                              Tezos_base__TzPervasives.Lwt_watcher.notify
                                                                                                                                (block_watcher
                                                                                                                                  (global_state
                                                                                                                                    chain_state))
                                                                                                                                block;
                                                                                                                              Tezos_base__TzPervasives.return_some
                                                                                                                                block
                                                                                                                            end)
                                                                                                                      end)
                                                                                                                end)
                                                                                                          end)
                                                                                                    end)
                                                                                              end)
                                                                                        end)
                                                                                  end)
                                                                            end))
                                                                  end)))
                                                  end)))
                                    end)
                              end)
                        end)
                end.
  
  Definition store_invalid
    (chain_state : chain_state)
    (block_header : Tezos_base__TzPervasives.Block_header.t)
    (errors : list Tezos_base__TzPervasives.Error_monad.error)
    : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
    let bytes := Tezos_base__TzPervasives.Block_header.to_bytes block_header in
    let hash := Tezos_base__TzPervasives.Block_header.hash_raw string in
    Shared.use (block_store chain_state)
      (fun store =>
        Tezos_base__TzPervasives.op_gt_gt_eq (Header.known (store, hash))
          (fun known_valid =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.fail_when known_valid
                (Tezos_base__TzPervasives.failure
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Known valid" % string
                      CamlinternalFormatBasics.End_of_format)
                    "Known valid" % string)))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.Store.Block.Invalid_block.known store hash)
                    (fun known_invalid =>
                      if known_invalid then
                        Tezos_base__TzPervasives.return_false
                      else
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_shell.Store.Block.Invalid_block.store store
                            hash
                            {| level := level (shell block_header);
                              errors := errors |})
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_true
                            end))
                end))).
  
  Definition watcher (state : chain_state)
    : (Lwt_stream.t block) * Tezos_base__TzPervasives.Lwt_watcher.stopper :=
    Tezos_base__TzPervasives.Lwt_watcher.create_stream (block_watcher state).
  
  Definition compute_operation_path
    (hashes : list (list Tezos_base__TzPervasives.Operation_list_hash.elt))
    : Z -> Tezos_base__TzPervasives.Operation_list_list_hash.path :=
    let list_hashes :=
      Tezos_base__TzPervasives.List.map
        Tezos_base__TzPervasives.Operation_list_hash.compute hashes in
    Tezos_base__TzPervasives.Operation_list_list_hash.compute_path list_hashes.
  
  Definition operation_hashes (function_parameter : t)
    : Z ->
      Lwt.t
        (Tezos_shell.Store.Block.Operation_hashes.value *
          Tezos_base__TzPervasives.Operation_list_list_hash.path) :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash; header := header |} =>
      fun i =>
        if
          orb (OCaml.Stdlib.lt i 0)
            (OCaml.Stdlib.le (validation_passes (shell header)) i) then
          OCaml.Stdlib.invalid_arg "State.Block.operations" % string
        else
          tt;
        Shared.use (block_store chain_state)
          (fun store =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Lwt_list.map_p
                (fun n =>
                  Tezos_base__TzPervasives.op_gt_pipe_eq
                    (Tezos_shell.Store.Block.Operation_hashes.read_opt
                      (store, hash) n)
                    (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
                (Tezos_base__TzPervasives.op_minus_minus 0
                  (Z.sub (validation_passes (shell header)) 1)))
              (fun hashes =>
                let path := compute_operation_path hashes in
                Lwt._return
                  ((Tezos_base__TzPervasives.List.nth hashes i), (path i))))
    end.
  
  Definition all_operation_hashes (function_parameter : t)
    : Lwt.t (list Tezos_shell.Store.Block.Operation_hashes.value) :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash; header := header |} =>
      Shared.use (block_store chain_state)
        (fun store =>
          Lwt_list.map_p
            (fun i =>
              Tezos_base__TzPervasives.op_gt_pipe_eq
                (Tezos_shell.Store.Block.Operation_hashes.read_opt (store, hash)
                  i)
                (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
            (Tezos_base__TzPervasives.op_minus_minus 0
              (Z.sub (validation_passes (shell header)) 1)))
    end.
  
  Definition operations (function_parameter : t)
    : Tezos_shell.Store.Block.Operations.key ->
      Lwt.t
        (Tezos_shell.Store.Block.Operations.value *
          Tezos_base__TzPervasives.Operation_list_list_hash.path) :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash; header := header |} =>
      fun i =>
        if
          orb (OCaml.Stdlib.lt i 0)
            (OCaml.Stdlib.le (validation_passes (shell header)) i) then
          OCaml.Stdlib.invalid_arg "State.Block.operations" % string
        else
          tt;
        Shared.use (block_store chain_state)
          (fun store =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Lwt_list.map_p
                (fun n =>
                  Tezos_base__TzPervasives.op_gt_pipe_eq
                    (Tezos_shell.Store.Block.Operation_hashes.read_opt
                      (store, hash) n)
                    (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
                (Tezos_base__TzPervasives.op_minus_minus 0
                  (Z.sub (validation_passes (shell header)) 1)))
              (fun hashes =>
                let path := compute_operation_path hashes in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_base__TzPervasives.op_gt_pipe_eq
                    (Tezos_shell.Store.Block.Operations.read_opt (store, hash) i)
                    (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
                  (fun ops => Lwt._return (ops, (path i)))))
    end.
  
  Definition operations_metadata (function_parameter : t)
    : Tezos_shell.Store.Block.Operations_metadata.key ->
      Lwt.t Tezos_shell.Store.Block.Operations_metadata.value :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash; header := header |} =>
      fun i =>
        if
          orb (OCaml.Stdlib.lt i 0)
            (OCaml.Stdlib.le (validation_passes (shell header)) i) then
          OCaml.Stdlib.invalid_arg "State.Block.operations_metadata" % string
        else
          tt;
        Shared.use (block_store chain_state)
          (fun store =>
            Tezos_base__TzPervasives.op_gt_pipe_eq
              (Tezos_shell.Store.Block.Operations_metadata.read_opt
                (store, hash) i)
              (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
    end.
  
  Definition all_operations (function_parameter : t)
    : Lwt.t (list Tezos_shell.Store.Block.Operations.value) :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash; header := header |} =>
      Shared.use (block_store chain_state)
        (fun store =>
          Lwt_list.map_p
            (fun i =>
              Tezos_base__TzPervasives.op_gt_pipe_eq
                (Tezos_shell.Store.Block.Operations.read_opt (store, hash) i)
                (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
            (Tezos_base__TzPervasives.op_minus_minus 0
              (Z.sub (validation_passes (shell header)) 1)))
    end.
  
  Definition all_operations_metadata (function_parameter : t)
    : Lwt.t (list Tezos_shell.Store.Block.Operations_metadata.value) :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash; header := header |} =>
      Shared.use (block_store chain_state)
        (fun store =>
          Lwt_list.map_p
            (fun i =>
              Tezos_base__TzPervasives.op_gt_pipe_eq
                (Tezos_shell.Store.Block.Operations_metadata.read_opt
                  (store, hash) i)
                (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
            (Tezos_base__TzPervasives.op_minus_minus 0
              (Z.sub (validation_passes (shell header)) 1)))
    end.
  
  Definition context_exn (function_parameter : t)
    : Lwt.t Tezos_storage.Context.context :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash |} =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_base__TzPervasives.op_gt_pipe_eq
          (Shared.use (block_store chain_state)
            (fun block_store =>
              Tezos_shell.Store.Block.Contents.read_opt (block_store, hash)))
          (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
        (fun function_parameter =>
          match function_parameter with
          | {| context := commit |} =>
            Shared.use (context_index chain_state)
              (fun context_index =>
                Tezos_storage.Context.checkout_exn context_index commit)
          end)
    end.
  
  Definition context_opt (function_parameter : t)
    : Lwt.t (option Tezos_storage.Context.context) :=
    match function_parameter with
    | {| chain_state := chain_state; hash := hash |} =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_base__TzPervasives.op_gt_pipe_eq
          (Shared.use (block_store chain_state)
            (fun block_store =>
              Tezos_shell.Store.Block.Contents.read_opt (block_store, hash)))
          (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
        (fun function_parameter =>
          match function_parameter with
          | {| context := commit |} =>
            Shared.use (context_index chain_state)
              (fun context_index =>
                Tezos_storage.Context.checkout context_index commit)
          end)
    end.
  
  Definition context (block : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
    Tezos_base__TzPervasives.op_gt_gt_eq (context_opt block)
      (fun function_parameter =>
        match function_parameter with
        | Some context => Tezos_base__TzPervasives._return context
        | None =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "State.Block.context failed to checkout context" % string
                CamlinternalFormatBasics.End_of_format)
              "State.Block.context failed to checkout context" % string)
        end).
  
  Definition protocol_hash (block : t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_base__TzPervasives.Protocol_hash.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (context block)
      (fun context =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_storage.Context.get_protocol context)
          Tezos_base__TzPervasives._return).
  
  Definition protocol_hash_exn (block : t)
    : Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
    Tezos_base__TzPervasives.op_gt_gt_eq (context_exn block)
      (fun context => Tezos_storage.Context.get_protocol context).
  
  Definition protocol_level (block : t) : Z :=
    proto_level (shell (header block)).
  
  Definition test_chain (block : t)
    : Lwt.t (Tezos_base__TzPervasives.Test_chain_status.t * (option t)) :=
    Tezos_base__TzPervasives.op_gt_gt_eq (context_exn block)
      (fun context =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_storage.Context.get_test_chain context)
          (fun status =>
            let lookup_testchain
              (genesis : Tezos_base__TzPervasives.Block_hash.t)
              : Lwt.t
                (Tezos_base__TzPervasives.Test_chain_status.t * (option t)) :=
              let chain_id :=
                Tezos_storage.Context.compute_testchain_chain_id genesis in
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Shared.use (global_data (global_state (chain_state block)))
                  (fun global_data =>
                    Tezos_shell.Store.Forking_block_hash.read_opt
                      (global_store global_data) chain_id))
                (fun function_parameter =>
                  match function_parameter with
                  | Some forking_block_hash =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (read_opt (chain_state block) forking_block_hash)
                      (fun forking_block => Lwt._return (status, forking_block))
                  | None => Lwt._return (status, None)
                  end) in
            match status with
            | Running {| genesis := genesis |} => lookup_testchain genesis
            | Forking _ => Lwt._return (status, (Some block))
            | Not_running => Lwt._return (status, None)
            end)).
  
  Definition known
    (chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t bool :=
    Shared.use (block_store chain_state)
      (fun store =>
        Tezos_base__TzPervasives.op_gt_gt_eq (Header.known (store, hash))
          (fun known =>
            if known then
              Lwt.return_true
            else
              Tezos_shell.Store.Block.Invalid_block.known store hash)).
  
  Definition block_validity
    (chain_state : chain_state) (block : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t Tezos_base__TzPervasives.Block_locator.validity :=
    Tezos_base__TzPervasives.op_gt_gt_eq (known chain_state block)
      (fun function_parameter =>
        match function_parameter with
        | false =>
          if
            Tezos_base__TzPervasives.Block_hash.equal block
              (Chain.faked_genesis_hash chain_state) then
            Lwt._return Block_locator.Known_valid
          else
            Lwt._return Block_locator.Unknown
        | true =>
          Tezos_base__TzPervasives.op_gt_gt_eq (known_invalid chain_state block)
            (fun function_parameter =>
              match function_parameter with
              | true => Lwt._return Block_locator.Known_invalid
              | false => Lwt._return Block_locator.Known_valid
              end)
        end).
  
  Definition known_ancestor
    (chain_state : chain_state)
    (locator : Tezos_base__TzPervasives.Block_locator.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_locator.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Shared.use (global_data (global_state chain_state))
        (fun function_parameter =>
          match function_parameter with
          | {| global_store := global_store |} =>
            Tezos_base__TzPervasives.op_gt_pipe_eq
              (Tezos_shell.Store.Configuration.History_mode.read_opt
                global_store)
              (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__)
          end))
      (fun history_mode =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_base__TzPervasives.Block_locator.unknown_prefix
            (block_validity chain_state) locator)
          (fun function_parameter =>
            match function_parameter with
            | (Known_valid, prefix_locator) => Lwt.return_some prefix_locator
            | (Known_invalid, _) => Lwt.return_none
            | (Unknown, _) =>
              match history_mode with
              | Archive => Lwt.return_none
              | Rolling | Full => Lwt.return_some locator
              end
            end)).
  
  Definition get_rpc_directory (function_parameter : t)
    : Lwt.t (option (Tezos_base__TzPervasives.RPC_directory.t block)) :=
    match function_parameter with
    | {| chain_state := chain_state |} as block =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (read_opt chain_state (predecessor (shell (header block))))
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt.return_none
          | Some pred => Lwt.return_none
          | Some pred =>
            Tezos_base__TzPervasives.op_gt_gt_eq (Chain.save_point chain_state)
              (fun function_parameter =>
                match function_parameter with
                | (save_point_level, _) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (if
                      Tezos_base__TzPervasives.Compare.Int32.op_lt (level pred)
                        save_point_level then
                      Chain.get_level_indexed_protocol chain_state (header pred)
                    else
                      protocol_hash_exn pred)
                    (fun protocol =>
                      match
                        Tezos_base__TzPervasives.Protocol_hash.Table.find_opt
                          (block_rpc_directories chain_state) protocol with
                      | None => Lwt.return_none
                      | Some map =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (protocol_hash_exn block)
                          (fun next_protocol =>
                            Lwt._return
                              (Tezos_base__TzPervasives.Protocol_hash.Map.find_opt
                                next_protocol map))
                      end)
                end)
          end)
    end.
  
  Definition set_rpc_directory (function_parameter : t)
    : (Tezos_base__TzPervasives.RPC_directory.t block) -> Lwt.t unit :=
    match function_parameter with
    | {| chain_state := chain_state |} as block =>
      fun dir =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_base__TzPervasives.op_gt_pipe_eq
            (read_opt chain_state (predecessor (shell (header block))))
            (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
          (fun pred =>
            Tezos_base__TzPervasives.op_gt_gt_eq (protocol_hash_exn block)
              (fun next_protocol =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Chain.save_point chain_state)
                  (fun function_parameter =>
                    match function_parameter with
                    | (save_point_level, _) =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (if
                          Tezos_base__TzPervasives.Compare.Int32.op_lt
                            (level pred) save_point_level then
                          Chain.get_level_indexed_protocol chain_state
                            (header pred)
                        else
                          protocol_hash_exn pred)
                        (fun protocol =>
                          let map :=
                            Tezos_base__TzPervasives.Option.unopt
                              Tezos_base__TzPervasives.Protocol_hash.Map.empty
                              (Tezos_base__TzPervasives.Protocol_hash.Table.find_opt
                                (block_rpc_directories chain_state) protocol) in
                          Tezos_base__TzPervasives.Protocol_hash.Table.replace
                            (block_rpc_directories chain_state) protocol
                            (Tezos_base__TzPervasives.Protocol_hash.Map.add
                              next_protocol dir map);
                          Lwt.return_unit)
                    end)))
    end.
  
  Definition get_header_rpc_directory
    (chain_state : chain_state)
    (header : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t
      (option
        (Tezos_base__TzPervasives.RPC_directory.t
          (chain_state * Tezos_base__TzPervasives.Block_hash.t *
            Tezos_base__TzPervasives.Block_header.t))) :=
    Shared.use (block_store chain_state)
      (fun block_store =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Header.read_opt
            (block_store, (predecessor (Block_header.shell header))))
          (fun function_parameter =>
            match function_parameter with
            | None => Lwt.return_none
            | Some pred => Lwt.return_none
            | Some pred =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Chain.get_level_indexed_protocol chain_state header)
                (fun protocol =>
                  match
                    Tezos_base__TzPervasives.Protocol_hash.Table.find_opt
                      (header_rpc_directories chain_state) protocol with
                  | None => Lwt.return_none
                  | Some map =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Chain.get_level_indexed_protocol chain_state pred)
                      (fun next_protocol =>
                        Lwt._return
                          (Tezos_base__TzPervasives.Protocol_hash.Map.find_opt
                            next_protocol map))
                  end)
            end)).
  
  Definition set_header_rpc_directory
    (chain_state : chain_state)
    (header : Tezos_base__TzPervasives.Block_header.t)
    (dir :
      Tezos_base__TzPervasives.RPC_directory.t
        (chain_state * Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t)) : Lwt.t unit :=
    Shared.use (block_store chain_state)
      (fun block_store =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Header.read_opt
            (block_store, (predecessor (Block_header.shell header))))
          (fun function_parameter =>
            match function_parameter with
            | None => false
            | Some pred =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Chain.get_level_indexed_protocol chain_state header)
                (fun next_protocol =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Chain.get_level_indexed_protocol chain_state pred)
                    (fun protocol =>
                      let map :=
                        Tezos_base__TzPervasives.Option.unopt
                          Tezos_base__TzPervasives.Protocol_hash.Map.empty
                          (Tezos_base__TzPervasives.Protocol_hash.Table.find_opt
                            (header_rpc_directories chain_state) protocol) in
                      Tezos_base__TzPervasives.Protocol_hash.Table.replace
                        (header_rpc_directories chain_state) protocol
                        (Tezos_base__TzPervasives.Protocol_hash.Map.add
                          next_protocol dir map);
                      Lwt.return_unit))
            end)).
End Block.

Definition watcher (state : global_state)
  : (Lwt_stream.t block) * Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  Tezos_base__TzPervasives.Lwt_watcher.create_stream (block_watcher state).

Definition read_block (function_parameter : global_state)
  : Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option Block.t) :=
  match function_parameter with
  | {| global_data := global_data |} =>
    fun hash =>
      Shared.use global_data
        (fun function_parameter =>
          match function_parameter with
          | {| chains := chains |} =>
            Tezos_base__TzPervasives.Chain_id.Table.fold
              (fun _chain_id =>
                fun chain_state =>
                  fun acc =>
                    Tezos_base__TzPervasives.op_gt_gt_eq acc
                      (fun function_parameter =>
                        match function_parameter with
                        | Some _ => acc
                        | None =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Block.read_opt chain_state hash)
                            (fun function_parameter =>
                              match function_parameter with
                              | None => acc
                              | Some block => Lwt.return_some block
                              end)
                        end)) chains Lwt.return_none
          end)
  end.

Definition read_block_exn
  (t : global_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t Block.t :=
  Tezos_base__TzPervasives.op_gt_gt_eq (read_block t hash)
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.fail OCaml.Not_found
      | Some b => Lwt._return b
      end).

Definition update_testchain (block : block) (testchain_state : chain_state)
  : Lwt.t unit :=
  update_chain_data (chain_state block)
    (fun function_parameter =>
      match function_parameter with
      | _ => fun chain_data => Lwt._return ((Some record), tt)
      end).

Definition fork_testchain
  (block : block) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
  (genesis_header : Tezos_base__TzPervasives.Block_header.t)
  (protocol : Tezos_base__TzPervasives.Protocol_hash.t)
  (expiration : Tezos_base__TzPervasives.Time.Protocol.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
  Shared.use (global_data (global_state (chain_state block)))
    (fun data =>
      let chain_store :=
        Tezos_shell.Store.Chain.get (global_store data) chain_id in
      let block_store := Tezos_shell.Store.Block.get chain_store in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.Store.Block.Contents.store (block_store, genesis_hash)
          {| Store.Block.header := genesis_header;
            Store.Block.message := Some "Genesis" % string;
            Store.Block.max_operations_ttl := 0;
            Store.Block.last_allowed_fork_level := 0;
            Store.Block.context := context (shell genesis_header);
            Store.Block.metadata := Stdlib.Bytes.create 0 |})
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let genesis :=
              {| time := timestamp (shell genesis_header);
                block := genesis_hash; protocol := protocol |} in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Chain.locked_create (global_state (chain_state block)) data
                (Some expiration) None chain_id genesis genesis_header)
              (fun testchain_state =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Store.Chain.Protocol_info.store chain_store
                    (proto_level (shell genesis_header))
                    (protocol, (level (shell genesis_header))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (update_testchain block testchain_state)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives._return testchain_state
                          end)
                    end))
          end)).

Definition best_known_head_for_checkpoint
  (chain_state : chain_state)
  (checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t block :=
  Shared.use (block_store chain_state)
    (fun store =>
      Shared.use (chain_data chain_state)
        (fun data =>
          let head_hash := hash (current_head (data data)) in
          let head_header := header (current_head (data data)) in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Locked_block.is_valid_for_checkpoint store head_hash head_header
              checkpoint)
            (fun valid =>
              if valid then
                Lwt._return (current_head (data data))
              else
                let find_valid_predecessor
                  (hash : Tezos_base__TzPervasives.Block_hash.t)
                  : Lwt.t block :=
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_base__TzPervasives.op_gt_pipe_eq
                      (Header.read_opt (store, hash))
                      (Tezos_base__TzPervasives.Option.unopt_assert
                        Stdlib.__POS__))
                    (fun header =>
                      if
                        Tezos_base__TzPervasives.Compare.Int32.op_lt
                          (level (shell header)) (level (shell checkpoint)) then
                        Lwt._return
                          {| chain_state := chain_state; hash := hash;
                            header := header |}
                      else
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_base__TzPervasives.op_gt_pipe_eq
                            (predecessor_n None store hash
                              (Z.add 1
                                (apply Stdlib.Int32.to_int
                                  (Stdlib.Int32.sub (level (shell header))
                                    (level (shell checkpoint))))))
                            (Tezos_base__TzPervasives.Option.unopt_assert
                              Stdlib.__POS__))
                          (fun pred =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (Tezos_base__TzPervasives.op_gt_pipe_eq
                                (Header.read_opt (store, pred))
                                (Tezos_base__TzPervasives.Option.unopt_assert
                                  Stdlib.__POS__))
                              (fun pred_header =>
                                Lwt._return
                                  {| chain_state := chain_state; hash := pred;
                                    header := pred_header |}))) in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Store.Chain_data.Known_heads.read_all
                    (chain_data_store data))
                  (fun heads =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_base__TzPervasives.op_gt_pipe_eq
                        (Header.read_opt (store, (block (genesis chain_state))))
                        (Tezos_base__TzPervasives.Option.unopt_assert
                          Stdlib.__POS__))
                      (fun genesis_header =>
                        let genesis :=
                          {| chain_state := chain_state;
                            hash := block (genesis chain_state);
                            header := genesis_header |} in
                        Tezos_base__TzPervasives.Block_hash.Set.fold
                          (fun head =>
                            fun best =>
                              let valid_predecessor :=
                                find_valid_predecessor head in
                              Tezos_base__TzPervasives.op_gt_gt_eq best
                                (fun best =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    valid_predecessor
                                    (fun pred =>
                                      if
                                        Tezos_base__TzPervasives.Fitness.op_gt
                                          (fitness (shell (header pred)))
                                          (fitness (shell (header best))) then
                                        Lwt._return pred
                                      else
                                        Lwt._return best))) heads
                          (Lwt._return genesis)))))).

Module Protocol.
  Definition known
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t bool :=
    Shared.use (protocol_store global_state)
      (fun store => Tezos_shell.Store.Protocol.Contents.known store hash).
  
  Definition read
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Protocol.t) :=
    Shared.use (protocol_store global_state)
      (fun store => Tezos_shell.Store.Protocol.Contents.read store hash).
  
  Definition read_opt
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t)
    : Lwt.t (option Tezos_base__TzPervasives.Protocol.t) :=
    Shared.use (protocol_store global_state)
      (fun store => Tezos_shell.Store.Protocol.Contents.read_opt store hash).
  
  Definition read_raw
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
    Shared.use (protocol_store global_state)
      (fun store => Tezos_shell.Store.Protocol.RawContents.read (store, hash)).
  
  Definition read_raw_opt
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t)
    : Lwt.t (option Stdlib.Bytes.t) :=
    Shared.use (protocol_store global_state)
      (fun store =>
        Tezos_shell.Store.Protocol.RawContents.read_opt (store, hash)).
  
  Definition store
    (global_state : global_state) (p : Tezos_base__TzPervasives.Protocol.t)
    : Lwt.t (option Tezos_crypto.Protocol_hash.t) :=
    let bytes := Tezos_base__TzPervasives.Protocol.to_bytes p in
    let hash := Tezos_base__TzPervasives.Protocol.hash_raw string in
    Shared.use (protocol_store global_state)
      (fun store =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Protocol.Contents.known store hash)
          (fun known =>
            if known then
              Lwt.return_none
            else
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Store.Protocol.RawContents.store (store, hash)
                  string)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.Lwt_watcher.notify
                      (protocol_watcher global_state) hash;
                    Lwt.return_some hash
                  end))).
  
  Definition remove
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t bool :=
    Shared.use (protocol_store global_state)
      (fun store =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Store.Protocol.Contents.known store hash)
          (fun known =>
            if known then
              Lwt.return_false
            else
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Store.Protocol.Contents.remove store hash)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Lwt.return_true
                  end))).
  
  Definition list (global_state : global_state)
    : Lwt.t Tezos_base__TzPervasives.Protocol_hash.Set.t :=
    Shared.use (protocol_store global_state)
      (fun store =>
        Tezos_shell.Store.Protocol.Contents.fold_keys store
          Tezos_base__TzPervasives.Protocol_hash.Set.empty
          (fun x =>
            fun acc =>
              Lwt._return (Tezos_base__TzPervasives.Protocol_hash.Set.add x acc))).
  
  Definition watcher (state : global_state)
    : (Lwt_stream.t Tezos_base__TzPervasives.Protocol_hash.t) *
      Tezos_base__TzPervasives.Lwt_watcher.stopper :=
    Tezos_base__TzPervasives.Lwt_watcher.create_stream (protocol_watcher state).
End Protocol.

Module Current_mempool.
  Definition set
    (chain_state : chain_state) (head : Tezos_base__TzPervasives.Block_hash.t)
    (mempool : Tezos_base__TzPervasives.Mempool.t) : Lwt.t unit :=
    update_chain_data chain_state
      (fun _chain_data_store =>
        fun data =>
          if
            Tezos_base__TzPervasives.Block_hash.equal head
              (Block.hash (current_head data)) then
            Lwt._return ((Some record), tt)
          else
            Lwt._return (None, tt)).
  
  Definition get (chain_state : chain_state)
    : Lwt.t
      (Tezos_base__TzPervasives.Block_header.t *
        Tezos_base__TzPervasives.Mempool.t) :=
    read_chain_data chain_state
      (fun _chain_data_store =>
        fun data =>
          Lwt._return
            ((Block.header (current_head data)), (current_mempool data))).
End Current_mempool.

Definition may_create_chain
  (commit_genesis :
    Tezos_base__TzPervasives.Chain_id.t ->
      Tezos_base__TzPervasives.Time.Protocol.t ->
        Tezos_base__TzPervasives.Protocol_hash.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t))
  (state : global_state)
  (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
  (genesis : Chain.genesis)
  : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Chain.get state chain_id)
    (fun function_parameter =>
      match function_parameter with
      | inl chain => Tezos_base__TzPervasives._return chain
      | inr _ => Chain.create state (Some true) commit_genesis genesis chain_id
      end).

Definition read
  (global_store : Tezos_shell.Store.t)
  (context_index : Tezos_storage.Context.index)
  (main_chain : Tezos_base__TzPervasives.Chain_id.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult global_state) :=
  let global_data :=
    {| chains := Tezos_base__TzPervasives.Chain_id.Table.create 17;
      global_store := global_store; context_index := context_index |} in
  let state :=
    {| global_data := Shared.create global_data;
      protocol_store :=
        apply Shared.create (Tezos_shell.Store.Protocol.get global_store);
      main_chain := main_chain;
      protocol_watcher := Tezos_base__TzPervasives.Lwt_watcher.create_input tt;
      block_watcher := Tezos_base__TzPervasives.Lwt_watcher.create_input tt |}
    in
  Tezos_base__TzPervasives.op_gt_gt_eq_question (Chain.read_all state)
    (fun function_parameter =>
      match function_parameter with
      | tt => Tezos_base__TzPervasives._return state
      end).

Definition init
  (patch_context :
    option
      (Tezos_storage.Context.context -> Lwt.t Tezos_storage.Context.context))
  (commit_genesis :
    option
      (Tezos_base__TzPervasives.Chain_id.t ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Protocol_hash.t ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t)))
  (op_star_o_p_t_star : option int64)
  : (option int64) ->
    string ->
      string ->
        (option Tezos_shell_services.History_mode.t) ->
          Chain.genesis ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                (global_state * chain_state * Tezos_storage.Context.index *
                  Tezos_shell_services.History_mode.t)) :=
  let store_mapsize :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 40960000000
    end in
  fun op_star_o_p_t_star =>
    let context_mapsize :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => 409600000000
      end in
    fun store_root =>
      fun context_root =>
        fun history_mode =>
          fun genesis =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_shell.Store.init None (Some store_mapsize) store_root)
              (fun global_store =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  match commit_genesis with
                  | Some commit_genesis =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_storage.Context.init patch_context
                        (Some context_mapsize) (Some true) context_root)
                      (fun context_index =>
                        Lwt._return (context_index, commit_genesis))
                  | None =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_storage.Context.init patch_context
                        (Some context_mapsize) (Some false) context_root)
                      (fun context_index =>
                        let commit_genesis
                          (chain_id : Tezos_base__TzPervasives.Chain_id.t) (time
                          : Tezos_base__TzPervasives.Time.Protocol.t) (protocol
                          : Tezos_base__TzPervasives.Protocol_hash.t)
                          : Lwt.t
                            (Tezos_base__TzPervasives.tzresult
                              Tezos_base__TzPervasives.Context_hash.t) :=
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_storage.Context.commit_genesis context_index
                              chain_id time protocol)
                            (fun res => Tezos_base__TzPervasives._return res) in
                        Lwt._return (context_index, commit_genesis))
                  end
                  (fun function_parameter =>
                    match function_parameter with
                    | (context_index, commit_genesis) =>
                      let chain_id :=
                        Tezos_base__TzPervasives.Chain_id.of_block_hash
                          (Chain.block genesis) in
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (read global_store context_index chain_id)
                        (fun state =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (may_create_chain commit_genesis state chain_id
                              genesis)
                            (fun main_chain_state =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Tezos_shell.Store.Configuration.History_mode.read_opt
                                    global_store)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | None =>
                                      let mode :=
                                        Tezos_base__TzPervasives.Option.unopt
                                          History_mode.Full history_mode in
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_shell.Store.Configuration.History_mode.store
                                          global_store mode)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives._return
                                              mode
                                          end)
                                    | Some previous_history_mode =>
                                      match history_mode with
                                      | None =>
                                        Tezos_base__TzPervasives._return
                                          previous_history_mode
                                      | Some history_mode =>
                                        if
                                          nequiv_decb history_mode
                                            previous_history_mode then
                                          Tezos_base__TzPervasives.fail
                                            (Incorrect_history_mode_switch
                                              {|
                                                previous_mode :=
                                                  previous_history_mode;
                                                next_mode := history_mode |})
                                        else
                                          Tezos_base__TzPervasives._return
                                            history_mode
                                      end
                                    end))
                                (fun history_mode =>
                                  Tezos_base__TzPervasives._return
                                    (state, main_chain_state, context_index,
                                      history_mode))))
                    end)).

Definition history_mode (function_parameter : global_state)
  : Lwt.t Tezos_shell_services.History_mode.t :=
  match function_parameter with
  | {| global_data := global_data |} =>
    Shared.use global_data
      (fun function_parameter =>
        match function_parameter with
        | {| global_store := global_store |} =>
          Tezos_base__TzPervasives.op_gt_pipe_eq
            (Tezos_shell.Store.Configuration.History_mode.read_opt global_store)
            (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__)
        end)
  end.

Definition close (function_parameter : global_state) : Lwt.t unit :=
  match function_parameter with
  | {| global_data := global_data |} =>
    Shared.use global_data
      (fun function_parameter =>
        match function_parameter with
        | {| global_store := global_store |} =>
          Tezos_shell.Store.close global_store;
          Lwt.return_unit
        end)
  end.
src/lib_shell/state.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell - Abstraction over all the disk storage.

    It encapsulates access to:

    - the index of validation contexts; and
    - the persistent state of the node:
    - the blockchain and its alternate heads ;
    - the pool of pending operations of a chain. *)

type t

type global_state = t

(** {2 Network} *)

(** Data specific to a given chain (e.g. the main chain or the current
    test chain).  *)
module Chain : sig
  type t

  type chain_state = t

  (** The chain starts from a genesis block associated to a seed protocol *)
  type genesis = {
    time : Time.Protocol.t;
    block : Block_hash.t;
    protocol : Protocol_hash.t;
  }

  val genesis_encoding : genesis Data_encoding.t

  (** Initialize a chain for a given [genesis]. By default,
      the chain does accept forking test chain. When
      [~allow_forked_chain:true] is provided, test chain are allowed. *)
  val create :
    global_state ->
    ?allow_forked_chain:bool ->
    commit_genesis:(chain_id:Chain_id.t ->
                   time:Time.Protocol.t ->
                   protocol:Protocol_hash.t ->
                   Context_hash.t tzresult Lwt.t) ->
    genesis ->
    Chain_id.t ->
    chain_state tzresult Lwt.t

  (** Look up for a chain by the hash of its genesis block. *)
  val get : global_state -> Chain_id.t -> chain_state tzresult Lwt.t

  val get_opt : global_state -> Chain_id.t -> chain_state option Lwt.t

  val get_exn : global_state -> Chain_id.t -> chain_state Lwt.t

  val main : global_state -> Chain_id.t

  val test : chain_state -> Chain_id.t option Lwt.t

  (** Returns all the known chains. *)
  val all : global_state -> chain_state list Lwt.t

  (** Destroy a chain: this completely removes from the local storage all
      the data associated to the chain (this includes blocks and
      operations). *)
  val destroy : global_state -> chain_state -> unit Lwt.t

  (** Various accessors. *)
  val id : chain_state -> Chain_id.t

  val genesis : chain_state -> genesis

  val global_state : chain_state -> global_state

  (** Hash of the faked block header of the genesis block. *)
  val faked_genesis_hash : chain_state -> Block_hash.t

  (** Return the expiration timestamp of a test chain. *)
  val expiration : chain_state -> Time.Protocol.t option

  val allow_forked_chain : chain_state -> bool

  val checkpoint : chain_state -> Block_header.t Lwt.t

  val save_point : chain_state -> (Int32.t * Block_hash.t) Lwt.t

  val caboose : chain_state -> (Int32.t * Block_hash.t) Lwt.t

  val store : chain_state -> Store.t Lwt.t

  (** Update the current checkpoint. The current head should be
      consistent (i.e. it should either have a lower level or pass
      through the checkpoint). In the process all the blocks from
      invalid alternate heads are removed from the disk, either
      completely (when `level <= checkpoint`) or still tagged as
      invalid (when `level > checkpoint`). *)
  val set_checkpoint : chain_state -> Block_header.t -> unit Lwt.t

  (** Apply [set_checkpoint] then [purge_full] (see {!History_mode.t}). *)
  val set_checkpoint_then_purge_full :
    chain_state -> Block_header.t -> unit tzresult Lwt.t

  (** Apply [set_checkpoint] then [purge_rolling] (see {!History_mode.t}). *)
  val set_checkpoint_then_purge_rolling :
    chain_state -> Block_header.t -> unit tzresult Lwt.t

  (** Check that a block is compatible with the current checkpoint.
      This function assumes that the predecessor is known valid. *)
  val acceptable_block : chain_state -> Block_header.t -> bool Lwt.t

  (** Get the level indexed chain protocol store for the given header. *)
  val get_level_indexed_protocol :
    chain_state -> Block_header.t -> Protocol_hash.t Lwt.t

  (** Update the level indexed chain protocol store so that the block can easily access
      its corresponding protocol hash from the protocol level in its header.
      Also stores the transition block level.
  *)
  val update_level_indexed_protocol_store :
    chain_state ->
    Chain_id.t ->
    int ->
    Protocol_hash.t ->
    Block_header.t ->
    unit Lwt.t
end

(** {2 Block database} *)

type error += Block_not_found of Block_hash.t

type error += Block_contents_not_found of Block_hash.t

module Block : sig
  type t

  type block = t

  (** Abstract view over block header storage.
      This module aims to abstract over block header's [read], [read_opt] and [known]
      functions by calling the adequate function depending on the block being pruned or not. *)
  module Header : sig
    val read :
      Store.Block.store * Block_hash.t -> Block_header.t tzresult Lwt.t

    val read_opt :
      Store.Block.store * Block_hash.t -> Block_header.t option Lwt.t

    val known : Store.Block.store * Block_hash.t -> bool Lwt.t
  end

  val known : Chain.t -> Block_hash.t -> bool Lwt.t

  val known_valid : Chain.t -> Block_hash.t -> bool Lwt.t

  val known_invalid : Chain.t -> Block_hash.t -> bool Lwt.t

  val read_invalid :
    Chain.t -> Block_hash.t -> Store.Block.invalid_block option Lwt.t

  val list_invalid : Chain.t -> (Block_hash.t * int32 * error list) list Lwt.t

  val unmark_invalid : Chain.t -> Block_hash.t -> unit tzresult Lwt.t

  val read : Chain.t -> Block_hash.t -> t tzresult Lwt.t

  val read_opt : Chain.t -> Block_hash.t -> t option Lwt.t

  (** Will return the full block if the block has never been cleaned
      (all blocks for nodes whose history-mode is set to archive), only
      the header for nodes below the save point (nodes in full or
      rolling history-mode) or even `Pruned` for blocks below the rock
      bottom, only for nodes in rolling history-mode. Will fail with
      `Not_found` if the given hash is unknown. *)
  val read_predecessor :
    Chain.t ->
    pred:int ->
    ?below_save_point:bool ->
    Block_hash.t ->
    t option Lwt.t

  val store :
    ?dont_enforce_context_hash:bool ->
    Chain.t ->
    Block_header.t ->
    Bytes.t ->
    Operation.t list list ->
    Bytes.t list list ->
    Block_validation.validation_store ->
    forking_testchain:bool ->
    block option tzresult Lwt.t

  val store_invalid :
    Chain.t -> Block_header.t -> error list -> bool tzresult Lwt.t

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val hash : t -> Block_hash.t

  val header : t -> Block_header.t

  val header_of_hash : Chain.t -> Block_hash.t -> Block_header.t option Lwt.t

  val shell_header : t -> Block_header.shell_header

  val timestamp : t -> Time.Protocol.t

  val fitness : t -> Fitness.t

  val validation_passes : t -> int

  val chain_id : t -> Chain_id.t

  val chain_state : t -> Chain.t

  val level : t -> Int32.t

  val message : t -> string option tzresult Lwt.t

  val max_operations_ttl : t -> int tzresult Lwt.t

  val metadata : t -> Bytes.t tzresult Lwt.t

  val last_allowed_fork_level : t -> Int32.t tzresult Lwt.t

  val is_genesis : t -> bool

  val predecessor : t -> t option Lwt.t

  val predecessor_n : t -> int -> Block_hash.t option Lwt.t

  val is_valid_for_checkpoint : t -> Block_header.t -> bool Lwt.t

  val context : t -> Context.t tzresult Lwt.t

  val context_opt : t -> Context.t option Lwt.t

  val context_exn : t -> Context.t Lwt.t

  val protocol_hash : t -> Protocol_hash.t tzresult Lwt.t

  val protocol_hash_exn : t -> Protocol_hash.t Lwt.t

  val test_chain : t -> (Test_chain_status.t * t option) Lwt.t

  val protocol_level : t -> int

  val operation_hashes :
    t -> int -> (Operation_hash.t list * Operation_list_list_hash.path) Lwt.t

  val all_operation_hashes : t -> Operation_hash.t list list Lwt.t

  val operations :
    t -> int -> (Operation.t list * Operation_list_list_hash.path) Lwt.t

  val all_operations : t -> Operation.t list list Lwt.t

  val operations_metadata : t -> int -> Bytes.t list Lwt.t

  val all_operations_metadata : t -> Bytes.t list list Lwt.t

  val watcher : Chain.t -> block Lwt_stream.t * Lwt_watcher.stopper

  (** [known_ancestor chain_state locator] computes the unknown prefix in
      the [locator] according to [chain_state].
      It either returns:
      - [Some (h, hist)] when we find a valid block, where [hist]
        is the unknown prefix, ending with the first valid block found.
      - [Some (h, hist)] when we don't find any block known valid nor invalid
        and the node runs in full or rolling mode. In this case
        [(h, hist)] is the given [locator].
      - [None] when the node runs in archive history mode and
        we find an invalid block or no valid block in the [locator].
      - [None] when the node runs in full or rolling mode and we find
        an invalid block in the [locator]. *)
  val known_ancestor :
    Chain.t -> Block_locator.t -> Block_locator.t option Lwt.t

  val get_rpc_directory : t -> t RPC_directory.t option Lwt.t

  val set_rpc_directory : t -> t RPC_directory.t -> unit Lwt.t

  val get_header_rpc_directory :
    Chain.t ->
    Block_header.t ->
    (Chain.t * Block_hash.t * Block_header.t) RPC_directory.t option Lwt.t

  val set_header_rpc_directory :
    Chain.t ->
    Block_header.t ->
    (Chain.t * Block_hash.t * Block_header.t) RPC_directory.t ->
    unit Lwt.t
end

val read_block : global_state -> Block_hash.t -> Block.t option Lwt.t

val read_block_exn : global_state -> Block_hash.t -> Block.t Lwt.t

val watcher : t -> Block.t Lwt_stream.t * Lwt_watcher.stopper

(** Computes the block with the best fitness amongst the known blocks
    which are compatible with the given checkpoint. *)
val best_known_head_for_checkpoint : Chain.t -> Block_header.t -> Block.t Lwt.t

val compute_locator :
  Chain.t ->
  ?size:int ->
  Block.t ->
  Block_locator.seed ->
  Block_locator.t Lwt.t

val update_testchain : Block.t -> testchain_state:Chain.t -> unit Lwt.t

val fork_testchain :
  Block.t ->
  Chain_id.t ->
  Block_hash.t ->
  Block_header.t ->
  Protocol_hash.t ->
  Time.Protocol.t ->
  Chain.t tzresult Lwt.t

type chain_data = {
  current_head : Block.t;
  current_mempool : Mempool.t;
  live_blocks : Block_hash.Set.t;
  live_operations : Operation_hash.Set.t;
  test_chain : Chain_id.t option;
  save_point : Int32.t * Block_hash.t;
  caboose : Int32.t * Block_hash.t;
}

val read_chain_data :
  Chain.t -> (Store.Chain_data.store -> chain_data -> 'a Lwt.t) -> 'a Lwt.t

val update_chain_data :
  Chain.t ->
  (Store.Chain_data.store -> chain_data -> (chain_data option * 'a) Lwt.t) ->
  'a Lwt.t

(** {2 Protocol database} *)

module Protocol : sig
  include module type of struct
    include Protocol
  end

  (** Is a value stored in the local database ? *)
  val known : global_state -> Protocol_hash.t -> bool Lwt.t

  (** Read a value in the local database. *)
  val read : global_state -> Protocol_hash.t -> Protocol.t tzresult Lwt.t

  val read_opt : global_state -> Protocol_hash.t -> Protocol.t option Lwt.t

  (** Read a value in the local database (without parsing). *)
  val read_raw : global_state -> Protocol_hash.t -> Bytes.t tzresult Lwt.t

  val read_raw_opt : global_state -> Protocol_hash.t -> Bytes.t option Lwt.t

  val store : global_state -> Protocol.t -> Protocol_hash.t option Lwt.t

  (** Remove a value from the local database. *)
  val remove : global_state -> Protocol_hash.t -> bool Lwt.t

  val list : global_state -> Protocol_hash.Set.t Lwt.t

  val watcher :
    global_state -> Protocol_hash.t Lwt_stream.t * Lwt_watcher.stopper
end

module Current_mempool : sig
  (** The current mempool. *)
  val get : Chain.t -> (Block_header.t * Mempool.t) Lwt.t

  (** Set the current mempool. It is ignored if the current head is
      not the provided one. *)
  val set : Chain.t -> head:Block_hash.t -> Mempool.t -> unit Lwt.t
end

type error +=
  | Incorrect_history_mode_switch of {
      previous_mode : History_mode.t;
      next_mode : History_mode.t;
    }

val history_mode : global_state -> History_mode.t Lwt.t

(** Read the internal state of the node and initialize
    the databases. *)
val init :
  ?patch_context:(Context.t -> Context.t Lwt.t) ->
  ?commit_genesis:(chain_id:Chain_id.t ->
                  time:Time.Protocol.t ->
                  protocol:Protocol_hash.t ->
                  Context_hash.t tzresult Lwt.t) ->
  ?store_mapsize:int64 ->
  ?context_mapsize:int64 ->
  store_root:string ->
  context_root:string ->
  ?history_mode:History_mode.t ->
  Chain.genesis ->
  (global_state * Chain.t * Context.index * History_mode.t) tzresult Lwt.t

val close : global_state -> unit Lwt.t
src/lib_shell/state.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition global_state := t.

Module Chain.
  Parameter t : Type.
  
  Definition chain_state := t.
  
  Record genesis := {
    time : Tezos_base__TzPervasives.Time.Protocol.t;
    block : Tezos_base__TzPervasives.Block_hash.t;
    protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
  
  Parameter genesis_encoding : Tezos_base__TzPervasives.Data_encoding.t genesis.
  
  Parameter create : global_state ->
    (option bool) ->
      (Tezos_base__TzPervasives.Chain_id.t ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Protocol_hash.t ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_base__TzPervasives.Context_hash.t)) ->
        genesis ->
          Tezos_base__TzPervasives.Chain_id.t ->
            Lwt.t (Tezos_base__TzPervasives.tzresult chain_state).
  
  Parameter get : global_state ->
    Tezos_base__TzPervasives.Chain_id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult chain_state).
  
  Parameter get_opt : global_state ->
    Tezos_base__TzPervasives.Chain_id.t -> Lwt.t (option chain_state).
  
  Parameter get_exn : global_state ->
    Tezos_base__TzPervasives.Chain_id.t -> Lwt.t chain_state.
  
  Parameter main : global_state -> Tezos_base__TzPervasives.Chain_id.t.
  
  Parameter test : chain_state ->
    Lwt.t (option Tezos_base__TzPervasives.Chain_id.t).
  
  Parameter all : global_state -> Lwt.t (list chain_state).
  
  Parameter destroy : global_state -> chain_state -> Lwt.t unit.
  
  Parameter id : chain_state -> Tezos_base__TzPervasives.Chain_id.t.
  
  Parameter genesis : chain_state -> genesis.
  
  Parameter global_state : chain_state -> global_state.
  
  Parameter faked_genesis_hash : chain_state ->
    Tezos_base__TzPervasives.Block_hash.t.
  
  Parameter expiration : chain_state ->
    option Tezos_base__TzPervasives.Time.Protocol.t.
  
  Parameter allow_forked_chain : chain_state -> bool.
  
  Parameter checkpoint : chain_state ->
    Lwt.t Tezos_base__TzPervasives.Block_header.t.
  
  Parameter save_point : chain_state ->
    Lwt.t (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t).
  
  Parameter caboose : chain_state ->
    Lwt.t (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t).
  
  Parameter store : chain_state -> Lwt.t Tezos_shell.Store.t.
  
  Parameter set_checkpoint : chain_state ->
    Tezos_base__TzPervasives.Block_header.t -> Lwt.t unit.
  
  Parameter set_checkpoint_then_purge_full : chain_state ->
    Tezos_base__TzPervasives.Block_header.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter set_checkpoint_then_purge_rolling : chain_state ->
    Tezos_base__TzPervasives.Block_header.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter acceptable_block : chain_state ->
    Tezos_base__TzPervasives.Block_header.t -> Lwt.t bool.
  
  Parameter get_level_indexed_protocol : chain_state ->
    Tezos_base__TzPervasives.Block_header.t ->
      Lwt.t Tezos_base__TzPervasives.Protocol_hash.t.
  
  Parameter update_level_indexed_protocol_store : chain_state ->
    Tezos_base__TzPervasives.Chain_id.t ->
      Z ->
        Tezos_base__TzPervasives.Protocol_hash.t ->
          Tezos_base__TzPervasives.Block_header.t -> Lwt.t unit.
End Chain.

extensible_type

extensible_type

Module Block.
  Parameter t : Type.
  
  Definition block := t.
  
  Module Header.
    Parameter read : (Tezos_shell.Store.Block.store *
      Tezos_base__TzPervasives.Block_hash.t) ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Block_header.t).
    
    Parameter read_opt : (Tezos_shell.Store.Block.store *
      Tezos_base__TzPervasives.Block_hash.t) ->
      Lwt.t (option Tezos_base__TzPervasives.Block_header.t).
    
    Parameter known : (Tezos_shell.Store.Block.store *
      Tezos_base__TzPervasives.Block_hash.t) -> Lwt.t bool.
  End Header.
  
  Parameter known : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t -> Lwt.t bool.
  
  Parameter known_valid : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t -> Lwt.t bool.
  
  Parameter known_invalid : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t -> Lwt.t bool.
  
  Parameter read_invalid : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Lwt.t (option Tezos_shell.Store.Block.invalid_block).
  
  Parameter list_invalid : Chain.t ->
    Lwt.t
      (list
        (Tezos_base__TzPervasives.Block_hash.t * int32 *
          (list Tezos_base__TzPervasives.error))).
  
  Parameter unmark_invalid : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter read : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult t).
  
  Parameter read_opt : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option t).
  
  Parameter read_predecessor : Chain.t ->
    Z ->
      (option bool) -> Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option t).
  
  Parameter store : (option bool) ->
    Chain.t ->
      Tezos_base__TzPervasives.Block_header.t ->
        Stdlib.Bytes.t ->
          (list (list Tezos_base__TzPervasives.Operation.t)) ->
            (list (list Stdlib.Bytes.t)) ->
              Tezos_validation.Block_validation.validation_store ->
                bool -> Lwt.t (Tezos_base__TzPervasives.tzresult (option block)).
  
  Parameter store_invalid : Chain.t ->
    Tezos_base__TzPervasives.Block_header.t ->
      (list Tezos_base__TzPervasives.error) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult bool).
  
  Parameter compare : t -> t -> Z.
  
  Parameter equal : t -> t -> bool.
  
  Parameter hash : t -> Tezos_base__TzPervasives.Block_hash.t.
  
  Parameter header : t -> Tezos_base__TzPervasives.Block_header.t.
  
  Parameter header_of_hash : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Lwt.t (option Tezos_base__TzPervasives.Block_header.t).
  
  Parameter shell_header : t ->
    Tezos_base__TzPervasives.Block_header.shell_header.
  
  Parameter timestamp : t -> Tezos_base__TzPervasives.Time.Protocol.t.
  
  Parameter fitness : t -> Tezos_base__TzPervasives.Fitness.t.
  
  Parameter validation_passes : t -> Z.
  
  Parameter chain_id : t -> Tezos_base__TzPervasives.Chain_id.t.
  
  Parameter chain_state : t -> Chain.t.
  
  Parameter level : t -> Stdlib.Int32.t.
  
  Parameter message : t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult (option string)).
  
  Parameter max_operations_ttl : t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult Z).
  
  Parameter metadata : t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t).
  
  Parameter last_allowed_fork_level : t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Int32.t).
  
  Parameter is_genesis : t -> bool.
  
  Parameter predecessor : t -> Lwt.t (option t).
  
  Parameter predecessor_n : t ->
    Z -> Lwt.t (option Tezos_base__TzPervasives.Block_hash.t).
  
  Parameter is_valid_for_checkpoint : t ->
    Tezos_base__TzPervasives.Block_header.t -> Lwt.t bool.
  
  Parameter context : t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.t).
  
  Parameter context_opt : t -> Lwt.t (option Tezos_storage.Context.t).
  
  Parameter context_exn : t -> Lwt.t Tezos_storage.Context.t.
  
  Parameter protocol_hash : t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_base__TzPervasives.Protocol_hash.t).
  
  Parameter protocol_hash_exn : t ->
    Lwt.t Tezos_base__TzPervasives.Protocol_hash.t.
  
  Parameter test_chain : t ->
    Lwt.t (Tezos_base__TzPervasives.Test_chain_status.t * (option t)).
  
  Parameter protocol_level : t -> Z.
  
  Parameter operation_hashes : t ->
    Z ->
      Lwt.t
        ((list Tezos_base__TzPervasives.Operation_hash.t) *
          Tezos_base__TzPervasives.Operation_list_list_hash.path).
  
  Parameter all_operation_hashes : t ->
    Lwt.t (list (list Tezos_base__TzPervasives.Operation_hash.t)).
  
  Parameter operations : t ->
    Z ->
      Lwt.t
        ((list Tezos_base__TzPervasives.Operation.t) *
          Tezos_base__TzPervasives.Operation_list_list_hash.path).
  
  Parameter all_operations : t ->
    Lwt.t (list (list Tezos_base__TzPervasives.Operation.t)).
  
  Parameter operations_metadata : t -> Z -> Lwt.t (list Stdlib.Bytes.t).
  
  Parameter all_operations_metadata : t -> Lwt.t (list (list Stdlib.Bytes.t)).
  
  Parameter watcher : Chain.t ->
    (Lwt_stream.t block) * Tezos_base__TzPervasives.Lwt_watcher.stopper.
  
  Parameter known_ancestor : Chain.t ->
    Tezos_base__TzPervasives.Block_locator.t ->
      Lwt.t (option Tezos_base__TzPervasives.Block_locator.t).
  
  Parameter get_rpc_directory : t ->
    Lwt.t (option (Tezos_base__TzPervasives.RPC_directory.t t)).
  
  Parameter set_rpc_directory : t ->
    (Tezos_base__TzPervasives.RPC_directory.t t) -> Lwt.t unit.
  
  Parameter get_header_rpc_directory : Chain.t ->
    Tezos_base__TzPervasives.Block_header.t ->
      Lwt.t
        (option
          (Tezos_base__TzPervasives.RPC_directory.t
            (Chain.t * Tezos_base__TzPervasives.Block_hash.t *
              Tezos_base__TzPervasives.Block_header.t))).
  
  Parameter set_header_rpc_directory : Chain.t ->
    Tezos_base__TzPervasives.Block_header.t ->
      (Tezos_base__TzPervasives.RPC_directory.t
        (Chain.t * Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t)) -> Lwt.t unit.
End Block.

Parameter read_block :
global_state -> Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option Block.t).

Parameter read_block_exn :
global_state -> Tezos_base__TzPervasives.Block_hash.t -> Lwt.t Block.t.

Parameter watcher :
t -> (Lwt_stream.t Block.t) * Tezos_base__TzPervasives.Lwt_watcher.stopper.

Parameter best_known_head_for_checkpoint :
Chain.t -> Tezos_base__TzPervasives.Block_header.t -> Lwt.t Block.t.

Parameter compute_locator :
Chain.t ->
  (option Z) ->
    Block.t ->
      Tezos_base__TzPervasives.Block_locator.seed ->
        Lwt.t Tezos_base__TzPervasives.Block_locator.t.

Parameter update_testchain : Block.t -> Chain.t -> Lwt.t unit.

Parameter fork_testchain :
Block.t ->
  Tezos_base__TzPervasives.Chain_id.t ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Tezos_base__TzPervasives.Block_header.t ->
        Tezos_base__TzPervasives.Protocol_hash.t ->
          Tezos_base__TzPervasives.Time.Protocol.t ->
            Lwt.t (Tezos_base__TzPervasives.tzresult Chain.t).

Record chain_data := {
  current_head : Block.t;
  current_mempool : Tezos_base__TzPervasives.Mempool.t;
  live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t;
  live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t;
  test_chain : option Tezos_base__TzPervasives.Chain_id.t;
  save_point : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t;
  caboose : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t }.

Parameter read_chain_data : forall {a : Type},
Chain.t ->
  (Tezos_shell.Store.Chain_data.store -> chain_data -> Lwt.t a) -> Lwt.t a.

Parameter update_chain_data : forall {a : Type},
Chain.t ->
  (Tezos_shell.Store.Chain_data.store ->
    chain_data -> Lwt.t ((option chain_data) * a)) -> Lwt.t a.

Module Protocol.
  include
  
  Parameter known : global_state ->
    Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t bool.
  
  Parameter read : global_state ->
    Tezos_base__TzPervasives.Protocol_hash.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Protocol.t).
  
  Parameter read_opt : global_state ->
    Tezos_base__TzPervasives.Protocol_hash.t ->
      Lwt.t (option Tezos_base__TzPervasives.Protocol.t).
  
  Parameter read_raw : global_state ->
    Tezos_base__TzPervasives.Protocol_hash.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t).
  
  Parameter read_raw_opt : global_state ->
    Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t (option Stdlib.Bytes.t).
  
  Parameter store : global_state ->
    Tezos_base__TzPervasives.Protocol.t ->
      Lwt.t (option Tezos_base__TzPervasives.Protocol_hash.t).
  
  Parameter remove : global_state ->
    Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t bool.
  
  Parameter list : global_state ->
    Lwt.t Tezos_base__TzPervasives.Protocol_hash.Set.t.
  
  Parameter watcher : global_state ->
    (Lwt_stream.t Tezos_base__TzPervasives.Protocol_hash.t) *
      Tezos_base__TzPervasives.Lwt_watcher.stopper.
End Protocol.

Module Current_mempool.
  Parameter get : Chain.t ->
    Lwt.t
      (Tezos_base__TzPervasives.Block_header.t *
        Tezos_base__TzPervasives.Mempool.t).
  
  Parameter set : Chain.t ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Tezos_base__TzPervasives.Mempool.t -> Lwt.t unit.
End Current_mempool.

extensible_type

Parameter history_mode :
global_state -> Lwt.t Tezos_shell_services.History_mode.t.

Parameter init :
(option (Tezos_storage.Context.t -> Lwt.t Tezos_storage.Context.t)) ->
  (option
    (Tezos_base__TzPervasives.Chain_id.t ->
      Tezos_base__TzPervasives.Time.Protocol.t ->
        Tezos_base__TzPervasives.Protocol_hash.t ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_base__TzPervasives.Context_hash.t))) ->
    (option int64) ->
      (option int64) ->
        string ->
          string ->
            (option Tezos_shell_services.History_mode.t) ->
              Chain.genesis ->
                Lwt.t
                  (Tezos_base__TzPervasives.tzresult
                    (global_state * Chain.t * Tezos_storage.Context.index *
                      Tezos_shell_services.History_mode.t)).

Parameter close : global_state -> Lwt.t unit.
src/lib_shell/store.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Raw_store.t

type global_store = t

(**************************************************************************
 * Configuration setup we need to save in order to avoid wrong changes.
 **************************************************************************)

module Configuration = struct
  module History_mode =
    Store_helpers.Make_single_store
      (Raw_store)
      (struct
        let name = ["history_mode"]
      end)
      (Store_helpers.Make_value (History_mode))
end

(**************************************************************************
 * Net store under "chain/"
 **************************************************************************)

module Chain = struct
  type store = global_store * Chain_id.t

  let get s id = (s, id)

  module Indexed_store =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Raw_store)
         (struct
           let name = ["chain"]
         end))
         (Chain_id)

  let destroy = Indexed_store.remove_all

  let list t =
    Indexed_store.fold_indexes t ~init:[] ~f:(fun h acc ->
        Lwt.return (h :: acc))

  module Genesis_hash =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["genesis"; "hash"]
      end)
      (Store_helpers.Make_value (Block_hash))

  module Genesis_time =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["genesis"; "time"]
      end)
      (Store_helpers.Make_value (Time.Protocol))

  module Genesis_protocol =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["genesis"; "protocol"]
      end)
      (Store_helpers.Make_value (Protocol_hash))

  module Genesis_test_protocol =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["genesis"; "test_protocol"]
      end)
      (Store_helpers.Make_value (Protocol_hash))

  module Expiration =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["expiration"]
      end)
      (Store_helpers.Make_value (Time.Protocol))

  module Allow_forked_chain = Indexed_store.Make_set (struct
    let name = ["allow_forked_chain"]
  end)

  module Protocol_index =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Indexed_store.Store)
         (struct
           let name = ["protocol"]
         end))
         (Store_helpers.Integer_index)

  module Protocol_info =
    Protocol_index.Make_map
      (struct
        let name = ["info"]
      end)
      (Store_helpers.Make_value (struct
        type t = Protocol_hash.t * Int32.t

        let encoding =
          let open Data_encoding in
          tup2 Protocol_hash.encoding int32
      end))
end

(**************************************************************************
 * Temporary test chain forking block store under "forking_block_hash/"
 **************************************************************************)

module Forking_block_hash =
  Store_helpers.Make_map
    (Store_helpers.Make_substore
       (Raw_store)
       (struct
         let name = ["forking_block_hash"]
       end))
       (Chain_id)
    (Store_helpers.Make_value (Block_hash))

(**************************************************************************
 * Block_header store under "chain/<id>/blocks/"
 **************************************************************************)

module Block = struct
  type store = Chain.store

  let get x = x

  module Indexed_store =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Chain.Indexed_store.Store)
         (struct
           let name = ["blocks"]
         end))
         (Block_hash)

  type contents = {
    header : Block_header.t;
    message : string option;
    max_operations_ttl : int;
    last_allowed_fork_level : Int32.t;
    context : Context_hash.t;
    metadata : Bytes.t;
  }

  module Contents =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["contents"]
      end)
      (Store_helpers.Make_value (struct
        type t = contents

        let encoding =
          let open Data_encoding in
          conv
            (fun { header;
                   message;
                   max_operations_ttl;
                   last_allowed_fork_level;
                   context;
                   metadata } ->
              ( message,
                max_operations_ttl,
                last_allowed_fork_level,
                context,
                metadata,
                header ))
            (fun ( message,
                   max_operations_ttl,
                   last_allowed_fork_level,
                   context,
                   metadata,
                   header ) ->
              {
                header;
                message;
                max_operations_ttl;
                last_allowed_fork_level;
                context;
                metadata;
              })
            (obj6
               (opt "message" string)
               (req "max_operations_ttl" uint16)
               (req "last_allowed_fork_level" int32)
               (req "context" Context_hash.encoding)
               (req "metadata" bytes)
               (req "header" Block_header.encoding))
      end))

  type pruned_contents = {header : Block_header.t}

  module Pruned_contents =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["pruned_contents"]
      end)
      (Store_helpers.Make_value (struct
        type t = pruned_contents

        let encoding =
          let open Data_encoding in
          conv
            (fun {header} -> header)
            (fun header -> {header})
            (obj1 (req "header" Block_header.encoding))
      end))

  module Operations_index =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Indexed_store.Store)
         (struct
           let name = ["operations"]
         end))
         (Store_helpers.Integer_index)

  module Operation_hashes =
    Operations_index.Make_map
      (struct
        let name = ["hashes"]
      end)
      (Store_helpers.Make_value (struct
        type t = Operation_hash.t list

        let encoding = Data_encoding.list Operation_hash.encoding
      end))

  module Operations =
    Operations_index.Make_map
      (struct
        let name = ["contents"]
      end)
      (Store_helpers.Make_value (struct
        type t = Operation.t list

        let encoding = Data_encoding.(list (dynamic_size Operation.encoding))
      end))

  module Operations_metadata =
    Operations_index.Make_map
      (struct
        let name = ["metadata"]
      end)
      (Store_helpers.Make_value (struct
        type t = Bytes.t list

        let encoding = Data_encoding.(list bytes)
      end))

  type invalid_block = {level : int32; errors : Error_monad.error list}

  module Invalid_block =
    Store_helpers.Make_map
      (Store_helpers.Make_substore
         (Chain.Indexed_store.Store)
         (struct
           let name = ["invalid_blocks"]
         end))
         (Block_hash)
      (Store_helpers.Make_value (struct
        type t = invalid_block

        let encoding =
          let open Data_encoding in
          conv
            (fun {level; errors} -> (level, errors))
            (fun (level, errors) -> {level; errors})
            (tup2 int32 (list Error_monad.error_encoding))
      end))

  let register s =
    Base58.register_resolver Block_hash.b58check_encoding (fun str ->
        let pstr = Block_hash.prefix_path str in
        Chain.Indexed_store.fold_indexes s ~init:[] ~f:(fun chain acc ->
            Indexed_store.resolve_index (s, chain) pstr
            >>= fun l -> Lwt.return (List.rev_append l acc)))

  module Predecessors =
    Store_helpers.Make_map
      (Store_helpers.Make_substore
         (Indexed_store.Store)
         (struct
           let name = ["predecessors"]
         end))
         (Store_helpers.Integer_index)
      (Store_helpers.Make_value (Block_hash))
end

(**************************************************************************
 * Blockchain data
 **************************************************************************)

module Chain_data = struct
  type store = Chain.store

  let get s = s

  module Known_heads =
    Store_helpers.Make_buffered_set
      (Store_helpers.Make_substore
         (Chain.Indexed_store.Store)
         (struct
           let name = ["known_heads"]
         end))
         (Block_hash)
      (Block_hash.Set)

  module Current_head =
    Store_helpers.Make_single_store
      (Chain.Indexed_store.Store)
      (struct
        let name = ["current_head"]
      end)
      (Store_helpers.Make_value (Block_hash))

  module In_main_branch =
    Store_helpers.Make_single_store
      (Block.Indexed_store.Store)
      (struct
        let name = ["in_chain"]
      end)
      (Store_helpers.Make_value (Block_hash))

  (* successor *)

  module Checkpoint =
    Store_helpers.Make_single_store
      (Chain.Indexed_store.Store)
      (struct
        let name = ["checkpoint"]
      end)
      (Store_helpers.Make_value (Block_header))

  module Save_point =
    Store_helpers.Make_single_store
      (Chain.Indexed_store.Store)
      (struct
        let name = ["save_point"]
      end)
      (Store_helpers.Make_value (struct
        type t = Int32.t * Block_hash.t

        let encoding =
          let open Data_encoding in
          tup2 int32 Block_hash.encoding
      end))

  module Caboose =
    Store_helpers.Make_single_store
      (Chain.Indexed_store.Store)
      (struct
        let name = ["caboose"]
      end)
      (Store_helpers.Make_value (struct
        type t = Int32.t * Block_hash.t

        let encoding =
          let open Data_encoding in
          tup2 int32 Block_hash.encoding
      end))
end

(**************************************************************************
 * Protocol store under "protocols/"
 **************************************************************************)

module Protocol = struct
  type store = global_store

  let get x = x

  module Indexed_store =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Raw_store)
         (struct
           let name = ["protocols"]
         end))
         (Protocol_hash)

  module Contents =
    Indexed_store.Make_map
      (struct
        let name = ["contents"]
      end)
      (Store_helpers.Make_value (Protocol))

  module RawContents =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["contents"]
      end)
      (Store_helpers.Raw_value)

  let register s =
    Base58.register_resolver Protocol_hash.b58check_encoding (fun str ->
        let pstr = Protocol_hash.prefix_path str in
        Indexed_store.resolve_index s pstr)
end

let init ?readonly ?mapsize dir =
  Raw_store.init ?readonly ?mapsize dir
  >>=? fun s -> Block.register s ; Protocol.register s ; return s

let close = Raw_store.close

let open_with_atomic_rw = Raw_store.open_with_atomic_rw

let with_atomic_rw = Raw_store.with_atomic_rw
src/lib_shell/store.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_storage.Raw_store.t.

Definition global_store := t.

Module Configuration.

End Configuration.

Module Chain.
  Definition store := global_store * Tezos_base__TzPervasives.Chain_id.t.
  
  Definition get {A B : Type} (s : A) (id : B) : A * B := (s, id).
  
  Definition destroy : Indexed_store.t -> Indexed_store.key -> Lwt.t unit :=
    Indexed_store.remove_all.
  
  Definition list (t : Indexed_store.t) : Lwt.t (list Indexed_store.key) :=
    Indexed_store.fold_indexes t []
      (fun h => fun acc => Lwt._return (cons h acc)).
End Chain.

Module Block.
  Definition store := Chain.store.
  
  Definition get {A : Type} (x : A) : A := x.
  
  Record contents := {
    header : Tezos_base__TzPervasives.Block_header.t;
    message : option string;
    max_operations_ttl : Z;
    last_allowed_fork_level : Stdlib.Int32.t;
    context : Tezos_base__TzPervasives.Context_hash.t;
    metadata : Stdlib.Bytes.t }.
  
  Record pruned_contents := {
    header : Tezos_base__TzPervasives.Block_header.t }.
  
  Record invalid_block := {
    level : int32;
    errors : list Tezos_base__TzPervasives.Error_monad.error }.
  
  Definition register (s : Chain.Indexed_store.t) : unit :=
    Tezos_base__TzPervasives.Base58.register_resolver
      Tezos_base__TzPervasives.Block_hash.b58check_encoding
      (fun str =>
        let pstr := Tezos_base__TzPervasives.Block_hash.prefix_path str in
        Chain.Indexed_store.fold_indexes s []
          (fun chain =>
            fun acc =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Indexed_store.resolve_index (s, chain) pstr)
                (fun l =>
                  Lwt._return (Tezos_base__TzPervasives.List.rev_append l acc)))).
End Block.

Module Chain_data.
  Definition store := Chain.store.
  
  Definition get {A : Type} (s : A) : A := s.
End Chain_data.

Module Protocol.
  Definition store := global_store.
  
  Definition get {A : Type} (x : A) : A := x.
  
  Definition register (s : Indexed_store.t) : unit :=
    Tezos_base__TzPervasives.Base58.register_resolver
      Tezos_base__TzPervasives.Protocol_hash.b58check_encoding
      (fun str =>
        let pstr := Tezos_base__TzPervasives.Protocol_hash.prefix_path str in
        Indexed_store.resolve_index s pstr).
End Protocol.

Definition init (readonly : option bool) (mapsize : option int64) (dir : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Raw_store.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_storage.Raw_store.init readonly mapsize dir)
    (fun s =>
      Block.register s;
      Protocol.register s;
      Tezos_base__TzPervasives._return s).

Definition close : Tezos_storage.Raw_store.t -> unit :=
  Tezos_storage.Raw_store.close.

Definition open_with_atomic_rw {A : Type}
  : (option int64) ->
    string ->
      (Tezos_storage.Raw_store.t ->
        Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A)) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  Tezos_storage.Raw_store.open_with_atomic_rw.

Definition with_atomic_rw {A : Type}
  : Tezos_storage.Raw_store.t -> (unit -> Lwt.t A) -> Lwt.t A :=
  Tezos_storage.Raw_store.with_atomic_rw.
src/lib_shell/store.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Store_sigs

type t

type global_store = t

(** [init ~mapsize path] returns an initialized store at [path] of
    maximum capacity [mapsize] bytes. *)
val init : ?readonly:bool -> ?mapsize:int64 -> string -> t tzresult Lwt.t

val close : t -> unit

val open_with_atomic_rw :
  ?mapsize:int64 ->
  string ->
  (t -> 'a Error_monad.tzresult Lwt.t) ->
  'a tzresult Lwt.t

val with_atomic_rw : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t

(** {2 Configuration} *)

module Configuration : sig
  module History_mode :
    SINGLE_STORE with type t := global_store and type value := History_mode.t
end

(** {2 Chain store} *)

module Chain : sig
  val list : global_store -> Chain_id.t list Lwt.t

  val destroy : global_store -> Chain_id.t -> unit Lwt.t

  type store

  val get : global_store -> Chain_id.t -> store

  module Genesis_hash :
    SINGLE_STORE with type t := store and type value := Block_hash.t

  module Genesis_time :
    SINGLE_STORE with type t := store and type value := Time.Protocol.t

  module Genesis_protocol :
    SINGLE_STORE with type t := store and type value := Protocol_hash.t

  module Genesis_test_protocol :
    SINGLE_STORE with type t := store and type value := Protocol_hash.t

  module Expiration :
    SINGLE_STORE with type t := store and type value := Time.Protocol.t

  module Allow_forked_chain :
    SET_STORE with type t := t and type elt := Chain_id.t

  module Protocol_info :
    MAP_STORE
      with type t = store
       and type key = int
       and type value = Protocol_hash.t * Int32.t
end

(** {2 Mutable chain data} *)

module Chain_data : sig
  type store

  val get : Chain.store -> store

  module Current_head :
    SINGLE_STORE with type t := store and type value := Block_hash.t

  module Known_heads :
    BUFFERED_SET_STORE
      with type t := store
       and type elt := Block_hash.t
       and module Set := Block_hash.Set

  module In_main_branch :
    SINGLE_STORE
      with type t = store * Block_hash.t
       and type value := Block_hash.t

  (* successor *)

  module Checkpoint :
    SINGLE_STORE with type t := store and type value := Block_header.t

  module Save_point :
    SINGLE_STORE with type t := store and type value := Int32.t * Block_hash.t

  module Caboose :
    SINGLE_STORE with type t := store and type value := Int32.t * Block_hash.t
end

(** {2 Block header store} *)

module Block : sig
  type store

  val get : Chain.store -> store

  type contents = {
    header : Block_header.t;
    message : string option;
    max_operations_ttl : int;
    last_allowed_fork_level : Int32.t;
    context : Context_hash.t;
    metadata : Bytes.t;
  }

  module Contents :
    SINGLE_STORE with type t = store * Block_hash.t and type value := contents

  (** Block header storage used for pruned blocks.
      Blocks that are not pruned have their header
      stored in their contents (see {!Store.Block.Contents}).
      For an abstraction over a block header, please see
      the {!State.Block.Header} module.
  *)

  type pruned_contents = {header : Block_header.t}

  module Pruned_contents :
    SINGLE_STORE
      with type t = store * Block_hash.t
       and type value := pruned_contents

  module Operation_hashes :
    MAP_STORE
      with type t = store * Block_hash.t
       and type key = int
       and type value = Operation_hash.t list

  module Operations :
    MAP_STORE
      with type t = store * Block_hash.t
       and type key = int
       and type value = Operation.t list

  module Operations_metadata :
    MAP_STORE
      with type t = store * Block_hash.t
       and type key = int
       and type value = Bytes.t list

  type invalid_block = {level : int32; errors : Error_monad.error list}

  module Invalid_block :
    MAP_STORE
      with type t = store
       and type key = Block_hash.t
       and type value = invalid_block

  (**
     Block predecessors under
     [/blocks/<block_id>/predecessors/<distance>/<block_id>].
     Used to compute block predecessors in [lib_node_shell/state.ml].
  *)
  module Predecessors :
    MAP_STORE
      with type t = store * Block_hash.t
       and type key = int
       and type value = Block_hash.t
end

(** {2 Protocol store} *)

module Protocol : sig
  type store

  val get : global_store -> store

  module Contents :
    MAP_STORE
      with type t := store
       and type key := Protocol_hash.t
       and type value := Protocol.t

  module RawContents :
    SINGLE_STORE
      with type t = store * Protocol_hash.t
       and type value := Bytes.t
end

(** {2 Temporary test chain forking block store} *)

module Forking_block_hash :
  MAP_STORE
    with type t = global_store
     and type key := Chain_id.t
     and type value := Block_hash.t
src/lib_shell/store.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition global_store := t.

Parameter init :
(option bool) ->
  (option int64) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter close : t -> unit.

Parameter open_with_atomic_rw : forall {a : Type},
(option int64) ->
  string ->
    (t -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult a)) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult a).

Parameter with_atomic_rw : forall {a : Type}, t -> (unit -> Lwt.t a) -> Lwt.t a.

Module Configuration.
  unhandled_module
End Configuration.

Module Chain.
  Parameter list : global_store ->
    Lwt.t (list Tezos_base__TzPervasives.Chain_id.t).
  
  Parameter destroy : global_store ->
    Tezos_base__TzPervasives.Chain_id.t -> Lwt.t unit.
  
  Parameter store : Type.
  
  Parameter get : global_store -> Tezos_base__TzPervasives.Chain_id.t -> store.
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
End Chain.

Module Chain_data.
  Parameter store : Type.
  
  Parameter get : Chain.store -> store.
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
End Chain_data.

Module Block.
  Parameter store : Type.
  
  Parameter get : Chain.store -> store.
  
  Record contents := {
    header : Tezos_base__TzPervasives.Block_header.t;
    message : option string;
    max_operations_ttl : Z;
    last_allowed_fork_level : Stdlib.Int32.t;
    context : Tezos_base__TzPervasives.Context_hash.t;
    metadata : Stdlib.Bytes.t }.
  
  unhandled_module
  
  Record pruned_contents := {
    header : Tezos_base__TzPervasives.Block_header.t }.
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  Record invalid_block := {
    level : int32;
    errors : list Tezos_base__TzPervasives.Error_monad.error }.
  
  unhandled_module
  
  unhandled_module
End Block.

Module Protocol.
  Parameter store : Type.
  
  Parameter get : global_store -> store.
  
  unhandled_module
  
  unhandled_module
End Protocol.

unhandled_module
src/lib_shell/test/assert.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let fail_msg ?(expected = "") ?(given = "") fmt =
  Format.kasprintf (fail expected given) fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg

let equal_operation ?msg op1 op2 =
  let eq op1 op2 =
    match (op1, op2) with
    | (None, None) ->
        true
    | (Some op1, Some op2) ->
        Operation.equal op1 op2
    | _ ->
        false
  in
  let prn = function
    | None ->
        "none"
    | Some op ->
        Operation_hash.to_b58check (Operation.hash op)
  in
  equal ?msg ~prn ~eq op1 op2

let equal_block ?msg st1 st2 =
  let eq st1 st2 =
    match (st1, st2) with
    | (None, None) ->
        true
    | (Some st1, Some st2) ->
        Block_header.equal st1 st2
    | _ ->
        false
  in
  let prn = function
    | None ->
        "none"
    | Some st ->
        Block_hash.to_b58check (Block_header.hash st)
  in
  equal ?msg ~prn ~eq st1 st2

let make_equal_list eq prn ?(msg = "") x y =
  let rec iter i x y =
    match (x, y) with
    | (hd_x :: tl_x, hd_y :: tl_y) ->
        if eq hd_x hd_y then iter (succ i) tl_x tl_y
        else
          fail_msg
            ~expected:(prn hd_x)
            ~given:(prn hd_y)
            "%s (at index %d)"
            msg
            i
    | (_ :: _, []) | ([], _ :: _) ->
        fail_msg
          ~expected:""
          ~given:""
          "%s (lists of different sizes %d %d)"
          msg
          (List.length x)
          (List.length y)
    | ([], []) ->
        ()
  in
  iter 0 x y

let equal_string_list ?msg l1 l2 =
  make_equal_list ?msg ( = ) (fun x -> x) l1 l2

let equal_string_list_list ?msg l1 l2 =
  let pr_persist l =
    let res =
      String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
    in
    Printf.sprintf "[%s]" res
  in
  make_equal_list ?msg ( = ) pr_persist l1 l2

let equal_block_set ?msg set1 set2 =
  let b1 = Block_hash.Set.elements set1
  and b2 = Block_hash.Set.elements set2 in
  make_equal_list
    ?msg
    (fun h1 h2 -> Block_hash.equal h1 h2)
    Block_hash.to_string
    b1
    b2

let equal_block_map ?msg ~eq map1 map2 =
  let b1 = Block_hash.Map.bindings map1
  and b2 = Block_hash.Map.bindings map2 in
  make_equal_list
    ?msg
    (fun (h1, b1) (h2, b2) -> Block_hash.equal h1 h2 && eq b1 b2)
    (fun (h1, _) -> Block_hash.to_string h1)
    b1
    b2

let equal_block_hash_list ?msg l1 l2 =
  let pr_block_hash = Block_hash.to_short_b58check in
  make_equal_list ?msg Block_hash.equal pr_block_hash l1 l2

let is_false ?(msg = "") x = if x then fail "false" "true" msg

let is_true ?(msg = "") x = if not x then fail "true" "false" msg

let equal_checkpoint ?msg cp1 cp2 =
  let eq cp1 cp2 =
    match (cp1, cp2) with
    | (None, None) ->
        true
    | (Some (x, bh1), Some (y, bh2)) ->
        Int32.equal x y && Block_hash.equal bh1 bh2
    | _ ->
        false
  in
  let prn = function
    | None ->
        "none"
    | Some (_x, bh) ->
        (*let s = Printf.sprintf "%s" x in*)
        Block_hash.to_b58check bh
  in
  equal ?msg ~prn ~eq cp1 cp2
src/lib_shell/test/assert.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type} (op_star_o_p_t_star : option string)
  : (option string) -> (Stdlib.format4 A Stdlib.Format.formatter unit B) -> A :=
  let expected :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun op_star_o_p_t_star =>
    let given :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => "" % string
      end in
    fun fmt => Stdlib.Format.kasprintf (fail expected given) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  match function_parameter with
  | _ => "" % string
  end.

Definition equal {A : Type} (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun op_star_o_p_t_star =>
    let prn :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

Definition equal_operation
  (msg : option string) (op1 : option Tezos_base__TzPervasives.Operation.t)
  (op2 : option Tezos_base__TzPervasives.Operation.t) : unit :=
  let eq
    (op1 : option Tezos_base__TzPervasives.Operation.t) (op2 :
    option Tezos_base__TzPervasives.Operation.t) : bool :=
    match (op1, op2) with
    | (None, None) => true
    | (Some op1, Some op2) => Tezos_base__TzPervasives.Operation.equal op1 op2
    | _ => false
    end in
  let prn (function_parameter : option Tezos_base__TzPervasives.Operation.t)
    : string :=
    match function_parameter with
    | None => "none" % string
    | Some op =>
      Tezos_base__TzPervasives.Operation_hash.to_b58check
        (Tezos_base__TzPervasives.Operation.hash op)
    end in
  equal (Some eq) (Some prn) msg op1 op2.

Definition equal_block
  (msg : option string) (st1 : option Tezos_base__TzPervasives.Block_header.t)
  (st2 : option Tezos_base__TzPervasives.Block_header.t) : unit :=
  let eq
    (st1 : option Tezos_base__TzPervasives.Block_header.t) (st2 :
    option Tezos_base__TzPervasives.Block_header.t) : bool :=
    match (st1, st2) with
    | (None, None) => true
    | (Some st1, Some st2) =>
      Tezos_base__TzPervasives.Block_header.equal st1 st2
    | _ => false
    end in
  let prn (function_parameter : option Tezos_base__TzPervasives.Block_header.t)
    : string :=
    match function_parameter with
    | None => "none" % string
    | Some st =>
      Tezos_base__TzPervasives.Block_hash.to_b58check
        (Tezos_base__TzPervasives.Block_header.hash st)
    end in
  equal (Some eq) (Some prn) msg st1 st2.

Definition make_equal_list {A : Type}
  (eq : A -> A -> bool) (prn : A -> string) (op_star_o_p_t_star : option string)
  : (list A) -> (list A) -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    fun y =>
      let fix iter (i : Z) (x : list A) (y : list A) : unit :=
        match (x, y) with
        | (cons hd_x tl_x, cons hd_y tl_y) =>
          if eq hd_x hd_y then
            iter (Z.succ i) tl_x tl_y
          else
            fail_msg (Some (prn hd_x)) (Some (prn hd_y))
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " (at index " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format))))
                "%s (at index %d)" % string) msg i
        | (cons _ _, []) | ([], cons _ _) =>
          fail_msg (Some "" % string) (Some "" % string)
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal
                  " (lists of different sizes " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal " " % char
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format))))))
              "%s (lists of different sizes %d %d)" % string) msg
            (Tezos_base__TzPervasives.List.length x)
            (Tezos_base__TzPervasives.List.length y)
        | ([], []) => tt
        end in
      iter 0 x y.

Definition equal_string_list
  (msg : option string) (l1 : list string) (l2 : list string) : unit :=
  make_equal_list equiv_decb (fun x => x) msg l1 l2.

Definition equal_string_list_list
  (msg : option string) (l1 : list (list string)) (l2 : list (list string))
  : unit :=
  let pr_persist (l : list string) : string :=
    let res :=
      Tezos_base__TzPervasives.String.concat ";" % string
        (Tezos_base__TzPervasives.List.map
          (fun s =>
            Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
      in
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "]" % char
              CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
  make_equal_list equiv_decb pr_persist msg l1 l2.

Definition equal_block_set
  (msg : option string) (set1 : Tezos_base__TzPervasives.Block_hash.Set.t)
  (set2 : Tezos_base__TzPervasives.Block_hash.Set.t) : unit :=
  let b1 : list Tezos_base__TzPervasives.Block_hash.Set.elt :=
    Tezos_base__TzPervasives.Block_hash.Set.elements set1
  with b2 : list Tezos_base__TzPervasives.Block_hash.Set.elt :=
    Tezos_base__TzPervasives.Block_hash.Set.elements set2 in
  make_equal_list
    (fun h1 => fun h2 => Tezos_base__TzPervasives.Block_hash.equal h1 h2)
    Tezos_base__TzPervasives.Block_hash.to_string msg b1 b2.

Definition equal_block_map {A : Type}
  (msg : option string) (eq : A -> A -> bool)
  (map1 : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (map2 : Tezos_base__TzPervasives.Block_hash.Map.t A) : unit :=
  let b1 : list (Tezos_base__TzPervasives.Block_hash.Map.key * A) :=
    Tezos_base__TzPervasives.Block_hash.Map.bindings map1
  with b2 : list (Tezos_base__TzPervasives.Block_hash.Map.key * A) :=
    Tezos_base__TzPervasives.Block_hash.Map.bindings map2 in
  make_equal_list
    (fun function_parameter =>
      match function_parameter with
      | (h1, b1) =>
        fun function_parameter =>
          match function_parameter with
          | (h2, b2) =>
            andb (Tezos_base__TzPervasives.Block_hash.equal h1 h2) (eq b1 b2)
          end
      end)
    (fun function_parameter =>
      match function_parameter with
      | (h1, _) => Tezos_base__TzPervasives.Block_hash.to_string h1
      end) msg b1 b2.

Definition equal_block_hash_list
  (msg : option string) (l1 : list Tezos_base__TzPervasives.Block_hash.t)
  (l2 : list Tezos_base__TzPervasives.Block_hash.t) : unit :=
  let pr_block_hash := Tezos_base__TzPervasives.Block_hash.to_short_b58check in
  make_equal_list Tezos_base__TzPervasives.Block_hash.equal pr_block_hash msg l1
    l2.

Definition is_false (op_star_o_p_t_star : option string) : bool -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    if x then
      fail "false" % string "true" % string msg
    else
      tt.

Definition is_true (op_star_o_p_t_star : option string) : bool -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    if negb x then
      fail "true" % string "false" % string msg
    else
      tt.

Definition equal_checkpoint
  (msg : option string)
  (cp1 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t))
  (cp2 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t))
  : unit :=
  let eq
    (cp1 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)) (cp2
    : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)) : bool :=
    match (cp1, cp2) with
    | (None, None) => true
    | (Some (x, bh1), Some (y, bh2)) =>
      andb (Stdlib.Int32.equal x y)
        (Tezos_base__TzPervasives.Block_hash.equal bh1 bh2)
    | _ => false
    end in
  let prn {A : Type}
    (function_parameter : option (A * Tezos_base__TzPervasives.Block_hash.t))
    : string :=
    match function_parameter with
    | None => "none" % string
    | Some (_x, bh) => Tezos_base__TzPervasives.Block_hash.to_b58check bh
    end in
  equal (Some eq) (Some prn) msg cp1 cp2.
src/lib_shell/test/test.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Alcotest.run
    "tezos-state"
    [ ("store", Test_store.tests);
      ("state", Test_state.tests);
      ("store checkpoint", Test_store_checkpoint.tests);
      ("state checkpoint", Test_state_checkpoint.tests) ]
src/lib_shell/test/test.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_shell/test/test_locator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_hash =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

let state_genesis_block =
  {
    State.Chain.time = genesis_time;
    State.Chain.block = genesis_hash;
    State.Chain.protocol = genesis_protocol;
  }

let chain_id = Chain_id.of_block_hash genesis_hash

let proto =
  match Registered_protocol.get genesis_protocol with
  | None ->
      assert false
  | Some proto ->
      proto

module Proto = (val proto)

let incr_timestamp timestamp =
  Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))

let incr_fitness fitness =
  let new_fitness =
    match fitness with
    | [fitness] ->
        Pervasives.(
          Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
          |> Option.unopt ~default:0L |> Int64.succ
          |> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ ->
        Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
  in
  [new_fitness]

(* returns a new state with a single block, genesis *)
let init_chain base_dir : State.Chain.t Lwt.t =
  let store_root = base_dir // "store" in
  let context_root = base_dir // "context" in
  State.init
    ~store_root
    ~context_root
    ~history_mode:Archive
    state_genesis_block
  >>= function
  | Error _ ->
      Pervasives.failwith "read err"
  | Ok (_state, chain, _index, _history_mode) ->
      Lwt.return chain

let block_header ?(context = Context_hash.zero) (pred : State.Block.t) :
    Block_header.t =
  let pred_header = State.Block.shell_header pred in
  let timestamp = incr_timestamp pred_header.timestamp in
  let fitness = incr_fitness pred_header.fitness in
  {
    Block_header.shell =
      {
        level = Int32.add Int32.one (State.Block.level pred);
        proto_level = 0;
        predecessor = State.Block.hash pred;
        timestamp;
        validation_passes = 0;
        operations_hash = Operation_list_list_hash.empty;
        fitness;
        context;
      };
    Block_header.protocol_data = Bytes.of_string "";
  }

let zero = Bytes.create 0

(* adds n blocks on top of an initialized chain *)
let make_empty_chain (chain : State.Chain.t) n : Block_hash.t Lwt.t =
  State.Block.read_opt chain genesis_hash
  >|= Option.unopt_assert ~loc:__POS__
  >>= fun genesis ->
  State.Block.context_exn genesis
  >>= fun empty_context ->
  let header = State.Block.header genesis in
  let timestamp = State.Block.timestamp genesis in
  let empty_context_hash = Context.hash ~time:timestamp empty_context in
  Context.commit ~time:header.shell.timestamp empty_context
  >>= fun context ->
  let header = {header with shell = {header.shell with context}} in
  let empty_result =
    {
      Block_validation.context_hash = empty_context_hash;
      message = None;
      max_operations_ttl = 0;
      last_allowed_fork_level = 0l;
    }
  in
  let rec loop lvl pred =
    if lvl >= n then return pred
    else
      let header =
        {
          header with
          shell =
            {header.shell with predecessor = pred; level = Int32.of_int lvl};
        }
      in
      State.Block.store
        chain
        header
        zero
        []
        []
        empty_result
        ~forking_testchain:false
      >>=? fun _ -> loop (lvl + 1) (Block_header.hash header)
  in
  loop 1 genesis_hash
  >>= function
  | Ok b ->
      Lwt.return b
  | Error err ->
      Error_monad.pp_print_error Format.err_formatter err ;
      assert false

(* helper functions ------------------------------------- *)

(* wall clock time of a unit function *)
let time1 (f : unit -> 'a) : 'a * float =
  let t = Unix.gettimeofday () in
  let res = f () in
  let wall_clock = Unix.gettimeofday () -. t in
  (res, wall_clock)

(* returns result from first run and average time of [runs] runs *)
let time ?(runs = 1) f =
  if runs < 1 then invalid_arg "time negative arg"
  else
    let rec loop cnt sum =
      if cnt = runs then sum
      else
        let (_, t) = time1 f in
        loop (cnt + 1) (sum +. t)
    in
    let (res, t) = time1 f in
    let sum = loop 1 t in
    (res, sum /. float runs)

let rec repeat f n =
  if n < 0 then invalid_arg "repeat: negative arg"
  else if n = 0 then ()
  else
    let _ = f () in
    repeat f (n - 1)

(* ----------------------------------------------------- *)

let print_block b =
  Printf.printf
    "%6i %s\n"
    (Int32.to_int (State.Block.level b))
    (Block_hash.to_b58check (State.Block.hash b))

let print_block_h chain bh =
  State.Block.read_opt chain bh
  >|= Option.unopt_assert ~loc:__POS__
  >|= fun b -> print_block b

(* returns the predecessor at distance one, reading the header *)
let linear_predecessor chain (bh : Block_hash.t) : Block_hash.t option Lwt.t =
  State.Block.read_opt chain bh
  >|= Option.unopt_assert ~loc:__POS__
  >>= fun b ->
  State.Block.predecessor b
  >|= function None -> None | Some pred -> Some (State.Block.hash pred)

let print_chain chain bh =
  let rec loop bh cnt =
    let _ = print_block_h chain bh in
    linear_predecessor chain bh
    >>= function Some pred -> loop pred (cnt + 1) | None -> Lwt.return_unit
  in
  loop bh 0

(* returns the predecessors at ditance n, traversing all n intermediate blocks *)
let linear_predecessor_n (chain : State.Chain.t) (bh : Block_hash.t)
    (distance : int) : Block_hash.t option Lwt.t =
  (* let _ = Printf.printf "LP: %4i " distance; print_block_h chain bh in *)
  if distance < 1 then invalid_arg "distance<1"
  else
    let rec loop bh distance =
      if distance = 0 then Lwt.return_some bh (* reached distance *)
      else
        linear_predecessor chain bh
        >>= function
        | None -> Lwt.return_none | Some pred -> loop pred (distance - 1)
    in
    loop bh distance

(* Tests that the linear predecessor defined above and the
   exponential predecessor implemented in State.predecessor_n
   return the same block and it is the block at the distance
   requested *)
let test_pred (base_dir : string) : unit tzresult Lwt.t =
  let size_chain = 1000 in
  init_chain base_dir
  >>= fun chain ->
  make_empty_chain chain size_chain
  >>= fun head ->
  let test_once distance =
    linear_predecessor_n chain head distance
    >>= fun lin_res ->
    State.Block.read_opt chain head
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun head_block ->
    State.Block.predecessor_n head_block distance
    >>= fun exp_res ->
    match (lin_res, exp_res) with
    | (None, None) ->
        Lwt.return_unit
    | (None, Some _) | (Some _, None) ->
        Assert.fail_msg "mismatch between exponential and linear predecessor_n"
    | (Some lin_res, Some exp_res) ->
        (* check that the two results are the same *)
        assert (lin_res = exp_res) ;
        State.Block.read_opt chain lin_res
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun pred ->
        let level_pred = Int32.to_int (State.Block.level pred) in
        State.Block.read_opt chain head
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun head ->
        let level_start = Int32.to_int (State.Block.level head) in
        (* check distance using the level *)
        assert (level_start - distance = level_pred) ;
        Lwt.return_unit
  in
  let _ = Random.self_init () in
  let range = size_chain + (size_chain / 10) in
  let repeats = 100 in
  return (repeat (fun () -> test_once (1 + Random.int range)) repeats)

let seed =
  let receiver_id =
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 'r')
  in
  let sender_id =
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 's')
  in
  {Block_locator.receiver_id; sender_id}

(* compute locator using the linear predecessor *)
let compute_linear_locator chain_state ~size block =
  let block_hash = State.Block.hash block in
  let header = State.Block.header block in
  Block_locator.compute
    ~get_predecessor:(linear_predecessor_n chain_state)
    block_hash
    header
    ~size
    seed

(* given the size of a chain, returns the size required for a locator
   to reach genesis *)
let compute_size_locator size_chain =
  let repeats = 10. in
  int_of_float ((log (float size_chain /. repeats) /. log 2.) -. 1.) * 10

(* given the size of a locator, returns the size of the chain that it
   can cover back to genesis *)
let compute_size_chain size_locator =
  let repeats = 10. in
  int_of_float (repeats *. (2. ** float (size_locator + 1)))

(* test if the linear and exponential locator are the same and outputs
   their timing.
   Run the test with:
   $ dune build @runbench_locator
   Copy the output to a file timing.dat and plot it with:
   $ test_locator_plot.sh timing.dat
*)
(*
   chain 1 year   518k   covered by locator 150
   chain 2 months 86k    covered by locator 120
*)
let test_locator base_dir =
  let size_chain = 80000 in
  (* timing locators with average over [runs] times *)
  let runs = 10 in
  let _ = Printf.printf "#runs %i\n" runs in
  (* limit after which exp should go linear *)
  let exp_limit = compute_size_chain 120 in
  let _ = Printf.printf "#exp_limit %i\n" exp_limit in
  (* size after which locator always reaches genesis *)
  let locator_limit = compute_size_locator size_chain in
  let _ = Printf.printf "#locator_limit %i\n" locator_limit in
  init_chain base_dir
  >>= fun chain ->
  time1 (fun () -> make_empty_chain chain size_chain)
  |> fun (res, t_chain) ->
  let _ =
    Printf.printf
      "#size_chain %i built in %f sec\n#      size      exp       lins\n"
      size_chain
      t_chain
  in
  res
  >>= fun head ->
  let check_locator size : unit tzresult Lwt.t =
    State.read_chain_data chain (fun _ data ->
        Lwt.return (data.caboose, data.save_point))
    >>= fun ((_, caboose), _save_point) ->
    State.Block.read chain head
    >>=? fun block ->
    time ~runs (fun () -> State.compute_locator chain ~size block seed)
    |> fun (l_exp, t_exp) ->
    time ~runs (fun () -> compute_linear_locator chain ~caboose ~size block)
    |> fun (l_lin, t_lin) ->
    l_exp
    >>= fun l_exp ->
    l_lin
    >>= fun l_lin ->
    let (_, l_exp) = (l_exp : Block_locator.t :> _ * _) in
    let (_, l_lin) = (l_lin : Block_locator.t :> _ * _) in
    let _ = Printf.printf "%10i %f %f\n" size t_exp t_lin in
    List.iter2
      (fun hn ho ->
        if not (Block_hash.equal hn ho) then
          Assert.fail_msg "Invalid locator %i" size)
      l_exp
      l_lin ;
    return_unit
  in
  let stop = locator_limit + 20 in
  let rec loop size =
    if size < stop then check_locator size >>=? fun _ -> loop (size + 5)
    else return_unit
  in
  loop 1

let wrap n f =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
          f dir
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error error ->
              Format.kasprintf Pervasives.failwith "%a" pp_print_error error))

let tests = [wrap "test pred" test_pred]

let bench = [wrap "test locator" test_locator]

let tests =
  try if Sys.argv.(1) = "--no-bench" then tests else tests @ bench
  with _ -> tests @ bench

let () = Alcotest.run ~argv:[|""|] "tezos-shell" [("locator", tests)]
src/lib_shell/test/test_locator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition genesis_hash : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Tezos_base__TzPervasives.Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Tezos_base__TzPervasives.Time.Protocol.of_seconds 0.

Definition state_genesis_block : Tezos_shell.State.Chain.genesis :=
  {| State.Chain.time := genesis_time; State.Chain.block := genesis_hash;
    State.Chain.protocol := genesis_protocol |}.

Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
  Tezos_base__TzPervasives.Chain_id.of_block_hash genesis_hash.

Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
  match Tezos_protocol_updater.Registered_protocol.get genesis_protocol with
  | None => false
  | Some proto => proto
  end.

Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  : Tezos_base__TzPervasives.Time.Protocol.t :=
  Tezos_base__TzPervasives.Time.Protocol.add timestamp
    (Stdlib.Int64.add 1 (Stdlib.Random.int64 10)).

Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
  let new_fitness :=
    match fitness with
    | cons fitness [] =>
      Stdlib.Pervasives.op_pipe_gt
        (Stdlib.Pervasives.op_pipe_gt
          (Stdlib.Pervasives.op_pipe_gt
            (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
              Tezos_base__TzPervasives.Data_encoding.int64 fitness)
            (Tezos_base__TzPervasives.Option.unopt 0)) Stdlib.Int64.succ)
        (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_base__TzPervasives.Data_encoding.int64)
    | _ =>
      Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
        Tezos_base__TzPervasives.Data_encoding.int64 1
    end in
  cons new_fitness [].

Definition init_chain (base_dir : string) : Lwt.t Tezos_shell.State.Chain.t :=
  let store_root := op_div_div base_dir "store" % string in
  let context_root := op_div_div base_dir "context" % string in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.init None None None None store_root context_root
      (Some Archive) state_genesis_block)
    (fun function_parameter =>
      match function_parameter with
      | inr _ => Stdlib.Pervasives.failwith "read err" % string
      | inl (_state, chain, _index, _history_mode) => Lwt._return chain
      end).

Definition block_header
  (op_star_o_p_t_star : option Tezos_base__TzPervasives.Context_hash.t)
  : Tezos_shell.State.Block.t -> Tezos_base__TzPervasives.Block_header.t :=
  let context :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_base__TzPervasives.Context_hash.zero
    end in
  fun pred =>
    let pred_header := Tezos_shell.State.Block.shell_header pred in
    let timestamp := incr_timestamp (timestamp pred_header) in
    let fitness := incr_fitness (fitness pred_header) in
    {|
      Block_header.shell :=
        {|
          level :=
            Stdlib.Int32.add Stdlib.Int32.one
              (Tezos_shell.State.Block.level pred); proto_level := 0;
          predecessor := Tezos_shell.State.Block.hash pred;
          timestamp := timestamp; validation_passes := 0;
          operations_hash :=
            Tezos_base__TzPervasives.Operation_list_list_hash.empty;
          fitness := fitness; context := context |};
      Block_header.protocol_data := Stdlib.Bytes.of_string "" % string |}.

Definition zero : string := Stdlib.Bytes.create 0.

Definition make_empty_chain (chain : Tezos_shell.State.Chain.t) (n : Z)
  : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_pipe_eq
      (Tezos_shell.State.Block.read_opt chain genesis_hash)
      (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
    (fun genesis =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.State.Block.context_exn genesis)
        (fun empty_context =>
          let header := Tezos_shell.State.Block.header genesis in
          let timestamp := Tezos_shell.State.Block.timestamp genesis in
          let empty_context_hash :=
            Tezos_storage.Context.hash timestamp None empty_context in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_storage.Context.commit (timestamp (shell header)) None
              empty_context)
            (fun context =>
              let header := record in
              let empty_result :=
                {| Block_validation.context_hash := empty_context_hash;
                  Block_validation.message := None;
                  Block_validation.max_operations_ttl := 0;
                  Block_validation.last_allowed_fork_level := 0 |} in
              let fix loop (lvl : Z) (pred : Tezos_crypto.Block_hash.t)
                : Lwt.t
                  (Tezos_base__TzPervasives.tzresult Tezos_crypto.Block_hash.t) :=
                if OCaml.Stdlib.ge lvl n then
                  Tezos_base__TzPervasives._return pred
                else
                  let header := record in
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_shell.State.Block.store None chain header zero [] []
                      empty_result false)
                    (fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        loop (Z.add lvl 1)
                          (Tezos_base__TzPervasives.Block_header.hash header)
                      end) in
              Tezos_base__TzPervasives.op_gt_gt_eq (loop 1 genesis_hash)
                (fun function_parameter =>
                  match function_parameter with
                  | inl b => Lwt._return b
                  | inr err =>
                    Tezos_base__TzPervasives.Error_monad.pp_print_error
                      Stdlib.Format.err_formatter err;
                    false
                  end)))).

Definition time1 {a : Type} (f : unit -> a) : a * float :=
  let t := Unix.gettimeofday tt in
  let res := f tt in
  let wall_clock := Stdlib.op_minus_point (Unix.gettimeofday tt) t in
  (res, wall_clock).

Definition time {A : Type} (op_star_o_p_t_star : option Z)
  : (unit -> A) -> A * float :=
  let runs :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 1
    end in
  fun f =>
    if OCaml.Stdlib.lt runs 1 then
      OCaml.Stdlib.invalid_arg "time negative arg" % string
    else
      let fix loop (cnt : Z) (sum : float) : float :=
        if equiv_decb cnt runs then
          sum
        else
          match time1 f with
          | (_, t) => loop (Z.add cnt 1) (Stdlib.op_plus_point sum t)
          end in
      match time1 f with
      | (res, t) =>
        let sum := loop 1 t in
        (res, (Stdlib.op_div_point sum (Stdlib.float runs)))
      end.

Fixpoint repeat {A : Type} (f : unit -> A) (n : Z) : unit :=
  if OCaml.Stdlib.lt n 0 then
    OCaml.Stdlib.invalid_arg "repeat: negative arg" % string
  else
    if equiv_decb n 0 then
      tt
    else
      match f tt with
      | _ => repeat f (Z.sub n 1)
      end.

Definition print_block (b : Tezos_shell.State.Block.t) : unit :=
  Stdlib.Printf.printf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
        (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Right 6)
        CamlinternalFormatBasics.No_precision
        (CamlinternalFormatBasics.Char_literal " " % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format)))) "%6i %s
" % string)
    (Stdlib.Int32.to_int (Tezos_shell.State.Block.level b))
    (Tezos_base__TzPervasives.Block_hash.to_b58check
      (Tezos_shell.State.Block.hash b)).

Definition print_block_h
  (chain : Tezos_shell__State.Chain.t)
  (bh : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_pipe_eq
    (Tezos_base__TzPervasives.op_gt_pipe_eq
      (Tezos_shell.State.Block.read_opt chain bh)
      (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
    (fun b => print_block b).

Definition linear_predecessor
  (chain : Tezos_shell__State.Chain.t)
  (bh : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_base__TzPervasives.op_gt_pipe_eq
      (Tezos_shell.State.Block.read_opt chain bh)
      (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
    (fun b =>
      Tezos_base__TzPervasives.op_gt_pipe_eq
        (Tezos_shell.State.Block.predecessor b)
        (fun function_parameter =>
          match function_parameter with
          | None => None
          | Some pred => Some (Tezos_shell.State.Block.hash pred)
          end)).

Definition print_chain
  (chain : Tezos_shell__State.Chain.t)
  (bh : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  let fix loop (bh : Tezos_base__TzPervasives.Block_hash.t) (cnt : Z)
    : Lwt.t unit :=
    match print_block_h chain bh with
    | _ =>
      Tezos_base__TzPervasives.op_gt_gt_eq (linear_predecessor chain bh)
        (fun function_parameter =>
          match function_parameter with
          | Some pred => loop pred (Z.add cnt 1)
          | None => Lwt.return_unit
          end)
    end in
  loop bh 0.

Definition linear_predecessor_n
  (chain : Tezos_shell.State.Chain.t)
  (bh : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
  : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
  if OCaml.Stdlib.lt distance 1 then
    OCaml.Stdlib.invalid_arg "distance<1" % string
  else
    let fix loop (bh : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
      : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
      if equiv_decb distance 0 then
        Lwt.return_some bh
      else
        Tezos_base__TzPervasives.op_gt_gt_eq (linear_predecessor chain bh)
          (fun function_parameter =>
            match function_parameter with
            | None => Lwt.return_none
            | Some pred => loop pred (Z.sub distance 1)
            end) in
    loop bh distance.

Definition test_pred (base_dir : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let size_chain := 1000 in
  Tezos_base__TzPervasives.op_gt_gt_eq (init_chain base_dir)
    (fun chain =>
      Tezos_base__TzPervasives.op_gt_gt_eq (make_empty_chain chain size_chain)
        (fun head =>
          let test_once (distance : Z) : Lwt.t unit :=
            Tezos_base__TzPervasives.op_gt_gt_eq
              (linear_predecessor_n chain head distance)
              (fun lin_res =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_base__TzPervasives.op_gt_pipe_eq
                    (Tezos_shell.State.Block.read_opt chain head)
                    (Tezos_base__TzPervasives.Option.unopt_assert Stdlib.__POS__))
                  (fun head_block =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.State.Block.predecessor_n head_block distance)
                      (fun exp_res =>
                        match (lin_res, exp_res) with
                        | (None, None) => Lwt.return_unit
                        | (None, Some _) | (Some _, None) =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            "mismatch between exponential and linear predecessor_n"
                              % string
                        | (Some lin_res, Some exp_res) =>
                          equiv_decb lin_res exp_res;
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_base__TzPervasives.op_gt_pipe_eq
                              (Tezos_shell.State.Block.read_opt chain lin_res)
                              (Tezos_base__TzPervasives.Option.unopt_assert
                                Stdlib.__POS__))
                            (fun pred =>
                              let level_pred :=
                                Stdlib.Int32.to_int
                                  (Tezos_shell.State.Block.level pred) in
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_base__TzPervasives.op_gt_pipe_eq
                                  (Tezos_shell.State.Block.read_opt chain head)
                                  (Tezos_base__TzPervasives.Option.unopt_assert
                                    Stdlib.__POS__))
                                (fun head =>
                                  let level_start :=
                                    Stdlib.Int32.to_int
                                      (Tezos_shell.State.Block.level head) in
                                  equiv_decb (Z.sub level_start distance)
                                    level_pred;
                                  Lwt.return_unit))
                        end))) in
          match Stdlib.Random.self_init tt with
          | _ =>
            let range := Z.add size_chain (Z.div size_chain 10) in
            let repeats := 100 in
            Tezos_base__TzPervasives._return
              (repeat
                (fun function_parameter =>
                  match function_parameter with
                  | tt => test_once (Z.add 1 (Stdlib.Random.int range))
                  end) repeats)
          end)).

Definition seed : Tezos_base__TzPervasives.Block_locator.seed :=
  let receiver_id :=
    Tezos_base__TzPervasives.P2p_peer.Id.of_string_exn
      (Tezos_base__TzPervasives.String.make
        Tezos_base__TzPervasives.P2p_peer.Id.size "r" % char) in
  let sender_id :=
    Tezos_base__TzPervasives.P2p_peer.Id.of_string_exn
      (Tezos_base__TzPervasives.String.make
        Tezos_base__TzPervasives.P2p_peer.Id.size "s" % char) in
  {| Block_locator.sender_id := sender_id;
    Block_locator.receiver_id := receiver_id |}.

Definition compute_linear_locator
  (chain_state : Tezos_shell.State.Chain.t) (size : Z)
  (block : Tezos_shell.State.Block.t)
  : Tezos_crypto.Block_hash.t -> Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
  let block_hash := Tezos_shell.State.Block.hash block in
  let header := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.Block_locator.compute
    (linear_predecessor_n chain_state) expected_argument size block_hash header
    seed.

Definition compute_size_locator (size_chain : Z) : Z :=
  let repeats := 10 in
  Z.mul
    (Stdlib.int_of_float
      (Stdlib.op_minus_point
        (Stdlib.op_div_point
          (Stdlib.log (Stdlib.op_div_point (Stdlib.float size_chain) repeats))
          (Stdlib.log 2)) 1)) 10.

Definition compute_size_chain (size_locator : Z) : Z :=
  let repeats := 10 in
  Stdlib.int_of_float
    (Stdlib.op_star_point repeats
      (Stdlib.op_star_star 2 (Stdlib.float (Z.add size_locator 1)))).

Definition test_locator (base_dir : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let size_chain := 80000 in
  let runs := 10 in
  match
    Stdlib.Printf.printf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "#runs " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "#runs %i
" % string)
      runs with
  | _ =>
    let exp_limit := compute_size_chain 120 in
    match
      Stdlib.Printf.printf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "#exp_limit " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal "010" % char
                CamlinternalFormatBasics.End_of_format)))
          "#exp_limit %i
" % string) exp_limit with
    | _ =>
      let locator_limit := compute_size_locator size_chain in
      match
        Stdlib.Printf.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "#locator_limit " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal "010" % char
                  CamlinternalFormatBasics.End_of_format)))
            "#locator_limit %i
" % string) locator_limit with
      | _ =>
        Tezos_base__TzPervasives.op_gt_gt_eq (init_chain base_dir)
          (fun chain =>
            OCaml.Stdlib.reverse_apply
              (time1
                (fun function_parameter =>
                  match function_parameter with
                  | tt => make_empty_chain chain size_chain
                  end))
              (fun function_parameter =>
                match function_parameter with
                | (res, t_chain) =>
                  match
                    Stdlib.Printf.printf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "#size_chain " % string
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_i
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.String_literal
                              " built in " % string
                              (CamlinternalFormatBasics.Float
                                CamlinternalFormatBasics.Float_f
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.String_literal
                                  " sec
#      size      exp       lins
" %
                                    string
                                  CamlinternalFormatBasics.End_of_format)))))
                        "#size_chain %i built in %f sec
#      size      exp       lins
"
                          % string) size_chain t_chain with
                  | _ =>
                    Tezos_base__TzPervasives.op_gt_gt_eq res
                      (fun head =>
                        let check_locator (size : Z)
                          : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_shell.State.read_chain_data chain
                              (fun function_parameter =>
                                match function_parameter with
                                | _ =>
                                  fun data =>
                                    Lwt._return
                                      ((caboose data), (save_point data))
                                end))
                            (fun function_parameter =>
                              match function_parameter with
                              | ((_, caboose), _save_point) =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_shell.State.Block.read chain head)
                                  (fun block =>
                                    OCaml.Stdlib.reverse_apply
                                      (time (Some runs)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_shell.State.compute_locator
                                              chain (Some size) block seed
                                          end))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (l_exp, t_exp) =>
                                          OCaml.Stdlib.reverse_apply
                                            (time (Some runs)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  compute_linear_locator chain
                                                    size block caboose
                                                end))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | (l_lin, t_lin) =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                  l_exp
                                                  (fun l_exp =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      l_lin
                                                      (fun l_lin =>
                                                        match l_exp with
                                                        | (_, l_exp) =>
                                                          match l_lin with
                                                          | (_, l_lin) =>
                                                            match
                                                              Stdlib.Printf.printf
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.Int
                                                                    CamlinternalFormatBasics.Int_i
                                                                    (CamlinternalFormatBasics.Lit_padding
                                                                      CamlinternalFormatBasics.Right
                                                                      10)
                                                                    CamlinternalFormatBasics.No_precision
                                                                    (CamlinternalFormatBasics.Char_literal
                                                                      " " % char
                                                                      (CamlinternalFormatBasics.Float
                                                                        CamlinternalFormatBasics.Float_f
                                                                        CamlinternalFormatBasics.No_padding
                                                                        CamlinternalFormatBasics.No_precision
                                                                        (CamlinternalFormatBasics.Char_literal
                                                                          " " %
                                                                            char
                                                                          (CamlinternalFormatBasics.Float
                                                                            CamlinternalFormatBasics.Float_f
                                                                            CamlinternalFormatBasics.No_padding
                                                                            CamlinternalFormatBasics.No_precision
                                                                            (CamlinternalFormatBasics.Char_literal
                                                                              "010"
                                                                                %
                                                                                char
                                                                              CamlinternalFormatBasics.End_of_format))))))
                                                                  "%10i %f %f
"
                                                                    % string)
                                                                size t_exp t_lin
                                                              with
                                                            | _ =>
                                                              Tezos_base__TzPervasives.List.iter2
                                                                (fun hn =>
                                                                  fun ho =>
                                                                    if
                                                                      negb
                                                                        (Tezos_base__TzPervasives.Block_hash.equal
                                                                          hn ho)
                                                                      then
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        "Invalid locator %i"
                                                                          %
                                                                          string
                                                                        size
                                                                    else
                                                                      tt) l_exp
                                                                l_lin;
                                                              Tezos_base__TzPervasives.return_unit
                                                            end
                                                          end
                                                        end))
                                              end)
                                        end))
                              end) in
                        let stop := Z.add locator_limit 20 in
                        let fix loop (size : Z)
                          : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                          if OCaml.Stdlib.lt size stop then
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (check_locator size)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ => loop (Z.add size 5)
                                end)
                          else
                            Tezos_base__TzPervasives.return_unit in
                        loop 1)
                  end
                end))
      end
    end
  end.

Definition wrap {A B : Type}
  (n : A) (f : string -> Lwt.t (sum unit (list Tezos_base__TzPervasives.error)))
  : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir "tezos_test_" % string
              (fun dir =>
                Tezos_base__TzPervasives.op_gt_gt_eq (f dir)
                  (fun function_parameter =>
                    match function_parameter with
                    | inl tt => Lwt.return_unit
                    | inr error =>
                      Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)
                          "%a" % string) Tezos_base__TzPervasives.pp_print_error
                        error
                    end))
          end
      end).

Definition tests {A : Type} : list A :=
  cons (wrap "test pred" % string test_pred) [].

Definition bench {A : Type} : list A :=
  cons (wrap "test locator" % string test_locator) [].

Definition tests {A : Type} : list A := try.
src/lib_shell/test/test_state.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

let proto =
  match Registered_protocol.get genesis_protocol with
  | None ->
      assert false
  | Some proto ->
      proto

module Proto = (val proto)

let genesis : State.Chain.genesis =
  {time = genesis_time; block = genesis_block; protocol = genesis_protocol}

let chain_id = Chain_id.of_block_hash genesis_block

let incr_fitness fitness =
  let new_fitness =
    match fitness with
    | [fitness] ->
        Pervasives.(
          Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
          |> Option.unopt ~default:0L |> Int64.succ
          |> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ ->
        Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
  in
  [new_fitness]

let incr_timestamp timestamp =
  Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))

let operation op =
  let op : Operation.t =
    {shell = {branch = genesis_block}; proto = Bytes.of_string op}
  in
  (Operation.hash op, op, Data_encoding.Binary.to_bytes Operation.encoding op)

let block_header_data_encoding =
  Data_encoding.(obj1 (req "proto_block_header" string))

let block _state ?(context = Context_hash.zero) ?(operations = [])
    (pred : State.Block.t) name : Block_header.t =
  let operations_hash =
    Operation_list_list_hash.compute [Operation_list_hash.compute operations]
  in
  let pred_header = State.Block.shell_header pred in
  let fitness = incr_fitness pred_header.fitness in
  let timestamp = incr_timestamp pred_header.timestamp in
  let protocol_data =
    Data_encoding.Binary.to_bytes_exn block_header_data_encoding name
  in
  {
    shell =
      {
        level = Int32.succ pred_header.level;
        proto_level = pred_header.proto_level;
        predecessor = State.Block.hash pred;
        validation_passes = 1;
        timestamp;
        operations_hash;
        fitness;
        context;
      };
    protocol_data;
  }

let parsed_block ({shell; protocol_data} : Block_header.t) =
  let protocol_data =
    Data_encoding.Binary.of_bytes_exn
      Proto.block_header_data_encoding
      protocol_data
  in
  ({shell; protocol_data} : Proto.block_header)

let zero = Bytes.create 0

let build_valid_chain state vtbl pred names =
  Lwt_list.fold_left_s
    (fun pred name ->
      State.Block.context_exn pred
      >>= fun predecessor_context ->
      let max_trials = 100 in
      let rec attempt trials context =
        (let (oph, op, _bytes) = operation name in
         let block = block ?context state ~operations:[oph] pred name in
         let hash = Block_header.hash block in
         let pred_header = State.Block.header pred in
         (let predecessor_context =
            Shell_context.wrap_disk_context predecessor_context
          in
          Proto.begin_application
            ~chain_id:Chain_id.zero
            ~predecessor_context
            ~predecessor_timestamp:pred_header.shell.timestamp
            ~predecessor_fitness:pred_header.shell.fitness
            (parsed_block block)
          >>=? fun vstate ->
          (* no operations *)
          Proto.finalize_block vstate)
         >>=? fun (result, _metadata) ->
         let context = Shell_context.unwrap_disk_context result.context in
         Context.commit ~time:block.shell.timestamp context
         >>= fun context_hash ->
         let validation_store =
           ( {
               context_hash;
               message = result.message;
               max_operations_ttl = 1;
               last_allowed_fork_level = result.last_allowed_fork_level;
             }
             : Block_validation.validation_store )
         in
         State.Block.store
           state
           block
           zero
           [[op]]
           [[zero]]
           ( {
               context_hash;
               message = validation_store.message;
               max_operations_ttl = 1;
               last_allowed_fork_level =
                 validation_store.last_allowed_fork_level;
             }
             : Block_validation.validation_store )
           ~forking_testchain:false
         >>=? fun _vblock ->
         State.Block.read state hash
         >>=? fun vblock ->
         Hashtbl.add vtbl name vblock ;
         return vblock)
        >>= function
        | Ok v ->
            if trials < max_trials then
              Format.eprintf
                "Took %d trials to build valid chain"
                (max_trials - trials + 1) ;
            Lwt.return v
        | Error (Validation_errors.Inconsistent_hash (got, _) :: _) ->
            (* Kind of a hack, but at least it tests idempotence to some extent. *)
            if trials <= 0 then assert false
            else (
              Format.eprintf
                "Inconsistent context hash: got %a, retrying (%d)\n"
                Context_hash.pp
                got
                trials ;
              attempt (trials - 1) (Some got) )
        | Error err ->
            Format.eprintf "Error: %a\n" Error_monad.pp_print_error err ;
            assert false
      in
      attempt max_trials None)
    pred
    names
  >>= fun _ -> Lwt.return_unit

type state = {
  vblock : (string, State.Block.t) Hashtbl.t;
  state : State.t;
  chain : State.Chain.t;
}

let vblock s = Hashtbl.find s.vblock

exception Found of string

let vblocks s =
  Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.vblock []
  |> List.sort Pervasives.compare

(*******************************************************)
(*

    Genesis - A1 - A2 - A3 - A4 - A5 - A6 - A7 - A8
                         \
                          B1 - B2 - B3 - B4 - B5 - B6 - B7 - B8
*)

let build_example_tree chain =
  let vtbl = Hashtbl.create 23 in
  Chain.genesis chain
  >>= fun genesis ->
  Hashtbl.add vtbl "Genesis" genesis ;
  let c = ["A1"; "A2"; "A3"; "A4"; "A5"; "A6"; "A7"; "A8"] in
  build_valid_chain chain vtbl genesis c
  >>= fun () ->
  let a3 = Hashtbl.find vtbl "A3" in
  let c = ["B1"; "B2"; "B3"; "B4"; "B5"; "B6"; "B7"; "B8"] in
  build_valid_chain chain vtbl a3 c >>= fun () -> Lwt.return vtbl

let wrap_state_init f base_dir =
  let store_root = base_dir // "store" in
  let context_root = base_dir // "context" in
  State.init
    ~store_mapsize:4_096_000_000L
    ~context_mapsize:4_096_000_000L
    ~store_root
    ~context_root
    genesis
  >>=? fun (state, chain, _index, _history_mode) ->
  build_example_tree chain >>= fun vblock -> f {state; chain; vblock}

let test_init (_ : state) = return_unit

(** State.Block.read *)

let test_read_block (s : state) =
  Lwt_list.iter_s
    (fun (name, vblock) ->
      let hash = State.Block.hash vblock in
      State.Block.read s.chain hash
      >>= function
      | Error _ ->
          Assert.fail_msg "Error while reading valid block %s" name
      | Ok _vblock' ->
          (* FIXME COMPARE read operations ??? *)
          Lwt.return_unit)
    (vblocks s)
  >>= fun () -> return_unit

(****************************************************************************)

(** Chain.set_checkpoint_then_purge_full *)

let test_set_checkpoint_then_purge_full (s : state) =
  State.Chain.checkpoint s.chain
  >>= fun checkpoint ->
  let checkpoint_lvl = checkpoint.shell.level in
  let checkpoint_hash = Block_header.hash checkpoint in
  (* At the beginning the checkpoint is the genesis. *)
  State.Block.read s.chain genesis_block
  >>=? fun read_genesis ->
  let read_genesis_hash =
    Block_header.hash (State.Block.header read_genesis)
  in
  assert (Block_hash.equal checkpoint_hash read_genesis_hash) ;
  assert (checkpoint_lvl = Int32.zero) ;
  let a1 = vblock s "A1" in
  let ha1 = State.Block.hash a1 in
  let b1 = vblock s "B1" in
  let hb1 = State.Block.hash b1 in
  let b2 = vblock s "B2" in
  let hb2 = State.Block.hash b2 in
  let la1 = State.Block.level a1 in
  let lb1 = State.Block.level b1 in
  let lb2 = State.Block.level b2 in
  assert (Int32.compare checkpoint_lvl la1 = -1) ;
  assert (Int32.compare checkpoint_lvl lb1 = -1) ;
  assert (Int32.compare checkpoint_lvl lb2 = -1) ;
  State.Chain.store s.chain
  >>= fun chain_store ->
  let chain_store = Store.Chain.get chain_store (State.Chain.id s.chain) in
  let block_store = Store.Block.get chain_store in
  (* Let us set a new checkpoint "B1" whose level is greater than the genesis. *)
  State.Chain.set_checkpoint_then_purge_full s.chain (State.Block.header b2)
  >>=? fun () ->
  (* Assert b2 does still exist and is the new checkpoint. *)
  State.Block.known s.chain hb2
  >|= (fun b -> assert b)
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >|= (fun b ->
        assert (Block_hash.equal (Block_header.hash b) hb2) ;
        assert (Int32.equal b.shell.level lb2))
  >>= fun () ->
  (* Assert b1 has been pruned.. *)
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* pruned, so we can still access its header. *)
  State.Block.read_opt s.chain hb1
  >|= (function Some _header -> assert true | None -> assert false)
  >>= fun () ->
  (* Assert a1 has also been pruned .. *)
  Store.Block.Contents.known (block_store, ha1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* and we can also access its header. *)
  State.Block.read_opt s.chain ha1
  >|= (function Some _header -> assert true | None -> assert false)
  >>= fun () ->
  (* and is accesible in Store.Block.Header *)
  Store.Block.Pruned_contents.known (block_store, ha1)
  >|= (fun b -> assert b)
  >>= fun () -> return_unit

(** Chain.set_checkpoint_then_purge_rolling *)

let test_set_checkpoint_then_purge_rolling (s : state) =
  State.Chain.checkpoint s.chain
  >>= fun checkpoint ->
  let checkpoint_lvl = checkpoint.shell.level in
  let checkpoint_hash = Block_header.hash checkpoint in
  (* At the beginning the checkpoint is the genesis. *)
  State.Block.read s.chain genesis_block
  >>=? fun read_genesis ->
  let read_genesis_hash =
    Block_header.hash (State.Block.header read_genesis)
  in
  assert (Block_hash.equal checkpoint_hash read_genesis_hash) ;
  assert (checkpoint_lvl = Int32.zero) ;
  let a1 = vblock s "A1" in
  let ha1 = State.Block.hash a1 in
  let b1 = vblock s "B1" in
  let hb1 = State.Block.hash b1 in
  let b2 = vblock s "B2" in
  let hb2 = State.Block.hash b2 in
  let la1 = State.Block.level a1 in
  let lb1 = State.Block.level b1 in
  let lb2 = State.Block.level b2 in
  assert (Int32.compare checkpoint_lvl la1 = -1) ;
  assert (Int32.compare checkpoint_lvl lb1 = -1) ;
  assert (Int32.compare checkpoint_lvl lb2 = -1) ;
  State.Block.max_operations_ttl b2
  >>=? fun max_op_ttl ->
  assert (max_op_ttl > 0) ;
  let ilb1 = Int32.to_int lb1 in
  let ilb2 = Int32.to_int lb2 in
  (* Assert b1 is in the to-prune range. *)
  assert (ilb2 - ilb1 <= min max_op_ttl ilb2) ;
  (* Assert a1 is in the to-delete range. *)
  let ila1 = Int32.to_int la1 in
  assert (ilb2 - ila1 > min max_op_ttl ilb2) ;
  (* Assert b1 is not yet in Store.Block.Header since not pruned *)
  State.Chain.store s.chain
  >>= fun chain_store ->
  let chain_store = Store.Chain.get chain_store (State.Chain.id s.chain) in
  let block_store = Store.Block.get chain_store in
  Store.Block.Pruned_contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* But accessible with State.Block.Header *)
  State.Block.known s.chain hb1
  >|= (fun b -> assert b)
  (* And Store.Block.Contents *)
  >>= fun () ->
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert b)
  (* Let us set a new checkpoint "B1" whose level is greater than the genesis. *)
  >>= fun () ->
  State.Chain.set_checkpoint_then_purge_rolling s.chain (State.Block.header b2)
  >>=? fun () ->
  (* Assert b2 does still exist and is the new checkpoint. *)
  State.Block.known s.chain hb2
  >|= (fun b -> assert b)
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >|= (fun b ->
        assert (Block_hash.equal (Block_header.hash b) hb2) ;
        assert (Int32.equal b.shell.level lb2))
  >>= fun () ->
  (* Assert b1 has been pruned.. *)
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* pruned, so we can still access its header. *)
  State.Block.read_opt s.chain hb1
  >|= (function Some _block -> assert true | None -> assert false)
  >>= fun () ->
  (* Assert b1 is now in Store.Block.Header since it has been pruned *)
  Store.Block.Pruned_contents.known (block_store, hb1)
  >|= (fun b -> assert b)
  >>= fun () ->
  (* And also accessible with State.Block.Header *)
  State.Block.Header.known (block_store, hb1)
  >|= (fun b -> assert b)
  (* But not in Store.Block.Contents *)
  >>= fun () ->
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* Assert a1 has been deleted.. *)
  State.Block.known s.chain ha1
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* deleted, so we can not access its header anymore. *)
  State.Block.read_opt s.chain ha1
  >|= (function Some _header -> assert false | None -> assert true)
  >>= fun () ->
  (* Assert b1 is now in Store.Block.Header since it has been pruned *)
  Store.Block.Pruned_contents.known (block_store, ha1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* And not in State.Block.Header *)
  State.Block.Header.known (block_store, ha1)
  >|= (fun b -> assert (not b))
  (* Neither in Store.Block.Contents *)
  >>= fun () ->
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  (*  *)
  >>= fun () -> return_unit

(****************************************************************************)

(** Chain_traversal.path *)

let rec compare_path p1 p2 =
  match (p1, p2) with
  | ([], []) ->
      true
  | (h1 :: p1, h2 :: p2) ->
      Block_hash.equal h1 h2 && compare_path p1 p2
  | _ ->
      false

let test_path (s : state) =
  let check_path h1 h2 p2 =
    Chain_traversal.path (vblock s h1) (vblock s h2)
    >>= function
    | None ->
        Assert.fail_msg "cannot compute path %s -> %s" h1 h2
    | Some (p : State.Block.t list) ->
        let p = List.map State.Block.hash p in
        let p2 = List.map (fun b -> State.Block.hash (vblock s b)) p2 in
        if not (compare_path p p2) then
          Assert.fail_msg "bad path %s -> %s" h1 h2 ;
        Lwt.return_unit
  in
  check_path "Genesis" "Genesis" []
  >>= fun () ->
  check_path "A1" "A1" []
  >>= fun () ->
  check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"]
  >>= fun () ->
  check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"]
  >>= fun () ->
  check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () -> return_unit

(****************************************************************************)

(** Chain_traversal.common_ancestor *)

let test_ancestor s =
  let check_ancestor h1 h2 expected =
    Chain_traversal.common_ancestor (vblock s h1) (vblock s h2)
    >>= fun a ->
    if not (Block_hash.equal (State.Block.hash a) (State.Block.hash expected))
    then Assert.fail_msg "bad ancestor %s %s" h1 h2 ;
    Lwt.return_unit
  in
  check_ancestor "Genesis" "Genesis" (vblock s "Genesis")
  >>= fun () ->
  check_ancestor "Genesis" "A3" (vblock s "Genesis")
  >>= fun () ->
  check_ancestor "A3" "Genesis" (vblock s "Genesis")
  >>= fun () ->
  check_ancestor "A1" "A1" (vblock s "A1")
  >>= fun () ->
  check_ancestor "A1" "A3" (vblock s "A1")
  >>= fun () ->
  check_ancestor "A3" "A1" (vblock s "A1")
  >>= fun () ->
  check_ancestor "A6" "B6" (vblock s "A3")
  >>= fun () ->
  check_ancestor "B6" "A6" (vblock s "A3")
  >>= fun () ->
  check_ancestor "A4" "B1" (vblock s "A3")
  >>= fun () ->
  check_ancestor "B1" "A4" (vblock s "A3")
  >>= fun () ->
  check_ancestor "A3" "B1" (vblock s "A3")
  >>= fun () ->
  check_ancestor "B1" "A3" (vblock s "A3")
  >>= fun () ->
  check_ancestor "A2" "B1" (vblock s "A2")
  >>= fun () ->
  check_ancestor "B1" "A2" (vblock s "A2") >>= fun () -> return_unit

(****************************************************************************)

let seed =
  let receiver_id =
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 'r')
  in
  let sender_id =
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 's')
  in
  {Block_locator.receiver_id; sender_id}

(** Chain_traversal.block_locator *)

let test_locator s =
  let check_locator length h1 expected =
    State.compute_locator s.chain ~size:length (vblock s h1) seed
    >>= fun l ->
    let (_, l) = (l : Block_locator.t :> _ * _) in
    if List.length l <> List.length expected then
      Assert.fail_msg
        "Invalid locator length %s (found: %d, expected: %d)"
        h1
        (List.length l)
        (List.length expected) ;
    List.iter2
      (fun h h2 ->
        if not (Block_hash.equal h (State.Block.hash @@ vblock s h2)) then
          Assert.fail_msg "Invalid locator %s (expected: %s)" h1 h2)
      l
      expected ;
    Lwt.return_unit
  in
  check_locator 6 "A8" ["A7"; "A6"; "A5"; "A4"; "A3"; "A2"]
  >>= fun () ->
  check_locator 8 "B8" ["B7"; "B6"; "B5"; "B4"; "B3"; "B2"; "B1"; "A3"]
  >>= fun () ->
  check_locator 4 "B8" ["B7"; "B6"; "B5"; "B4"]
  >>= fun () ->
  check_locator 0 "A5" []
  >>= fun () ->
  check_locator 100 "A5" ["A4"; "A3"; "A2"; "A1"; "Genesis"]
  >>= fun () -> return_unit

(****************************************************************************)

(** Chain.known_heads *)

let compare s name heads l =
  if List.length heads <> List.length l then
    Assert.fail_msg
      "unexpected known_heads size (%s: %d %d)"
      name
      (List.length heads)
      (List.length l) ;
  List.iter
    (fun bname ->
      let hash = State.Block.hash (vblock s bname) in
      if
        not
          (List.exists
             (fun b -> Block_hash.equal hash (State.Block.hash b))
             heads)
      then Assert.fail_msg "missing block in known_heads (%s: %s)" name bname)
    l

let test_known_heads s =
  Chain.known_heads s.chain
  >>= fun heads ->
  compare s "initial" heads ["A8"; "B8"] ;
  return_unit

(****************************************************************************)

(** Chain.head/set_head *)

let test_head s =
  Chain.head s.chain
  >>= fun head ->
  if not (Block_hash.equal (State.Block.hash head) genesis_block) then
    Assert.fail_msg "unexpected head" ;
  Chain.set_head s.chain (vblock s "A6")
  >>= fun _ ->
  Chain.head s.chain
  >>= fun head ->
  if
    not
      (Block_hash.equal
         (State.Block.hash head)
         (State.Block.hash @@ vblock s "A6"))
  then Assert.fail_msg "unexpected head" ;
  return_unit

(****************************************************************************)

(** Chain.mem *)

let test_mem s =
  let mem s x = Chain.mem s.chain (State.Block.hash @@ vblock s x) in
  let test_mem s x =
    mem s x
    >>= function
    | true -> Lwt.return_unit | false -> Assert.fail_msg "mem %s" x
  in
  let test_not_mem s x =
    mem s x
    >>= function
    | false -> Lwt.return_unit | true -> Assert.fail_msg "not (mem %s)" x
  in
  test_not_mem s "A3"
  >>= fun () ->
  test_not_mem s "A6"
  >>= fun () ->
  test_not_mem s "A8"
  >>= fun () ->
  test_not_mem s "B1"
  >>= fun () ->
  test_not_mem s "B6"
  >>= fun () ->
  test_not_mem s "B8"
  >>= fun () ->
  Chain.set_head s.chain (vblock s "A8")
  >>= fun _ ->
  test_mem s "A3"
  >>= fun () ->
  test_mem s "A6"
  >>= fun () ->
  test_mem s "A8"
  >>= fun () ->
  test_not_mem s "B1"
  >>= fun () ->
  test_not_mem s "B6"
  >>= fun () ->
  test_not_mem s "B8"
  >>= fun () ->
  Chain.set_head s.chain (vblock s "A6")
  >>= fun _ ->
  test_mem s "A3"
  >>= fun () ->
  test_mem s "A6"
  >>= fun () ->
  test_not_mem s "A8"
  >>= fun () ->
  test_not_mem s "B1"
  >>= fun () ->
  test_not_mem s "B6"
  >>= fun () ->
  test_not_mem s "B8"
  >>= fun () ->
  Chain.set_head s.chain (vblock s "B6")
  >>= fun _ ->
  test_mem s "A3"
  >>= fun () ->
  test_not_mem s "A4"
  >>= fun () ->
  test_not_mem s "A6"
  >>= fun () ->
  test_not_mem s "A8"
  >>= fun () ->
  test_mem s "B1"
  >>= fun () ->
  test_mem s "B6"
  >>= fun () ->
  test_not_mem s "B8"
  >>= fun () ->
  Chain.set_head s.chain (vblock s "B8")
  >>= fun _ ->
  test_mem s "A3"
  >>= fun () ->
  test_not_mem s "A4"
  >>= fun () ->
  test_not_mem s "A6"
  >>= fun () ->
  test_not_mem s "A8"
  >>= fun () ->
  test_mem s "B1"
  >>= fun () ->
  test_mem s "B6" >>= fun () -> test_mem s "B8" >>= fun () -> return_unit

(****************************************************************************)

(** Chain_traversal.new_blocks *)

let test_new_blocks s =
  let test s head h expected_ancestor expected =
    let to_block = vblock s head and from_block = vblock s h in
    Chain_traversal.new_blocks ~from_block ~to_block
    >>= fun (ancestor, blocks) ->
    if
      not
        (Block_hash.equal
           (State.Block.hash ancestor)
           (State.Block.hash @@ vblock s expected_ancestor))
    then
      Assert.fail_msg
        "Invalid ancestor %s -> %s (expected: %s)"
        head
        h
        expected_ancestor ;
    if List.length blocks <> List.length expected then
      Assert.fail_msg
        "Invalid locator length %s (found: %d, expected: %d)"
        h
        (List.length blocks)
        (List.length expected) ;
    List.iter2
      (fun h1 h2 ->
        if
          not
            (Block_hash.equal
               (State.Block.hash h1)
               (State.Block.hash @@ vblock s h2))
        then
          Assert.fail_msg
            "Invalid new blocks %s -> %s (expected: %s)"
            head
            h
            h2)
      blocks
      expected ;
    Lwt.return_unit
  in
  test s "A6" "A6" "A6" []
  >>= fun () ->
  test s "A8" "A6" "A6" ["A7"; "A8"]
  >>= fun () ->
  test s "A8" "B7" "A3" ["A4"; "A5"; "A6"; "A7"; "A8"]
  >>= fun () -> return_unit

(****************************************************************************)

let tests : (string * (state -> unit tzresult Lwt.t)) list =
  [ ("init", test_init);
    ("read_block", test_read_block);
    ("path", test_path);
    ("ancestor", test_ancestor);
    ("locator", test_locator);
    ("known_heads", test_known_heads);
    ("head", test_head);
    ("mem", test_mem);
    ("new_blocks", test_new_blocks);
    ( "set_checkpoint_then_purge_rolling",
      test_set_checkpoint_then_purge_rolling );
    ("set_checkpoint_then_purge_full", test_set_checkpoint_then_purge_full) ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
          wrap_state_init f dir
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error error ->
              Format.kasprintf Pervasives.failwith "%a" pp_print_error error))

let tests = List.map wrap tests
src/lib_shell/test/test_state.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Tezos_base__TzPervasives.Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Tezos_base__TzPervasives.Time.Protocol.of_seconds 0.

Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
  match Tezos_protocol_updater.Registered_protocol.get genesis_protocol with
  | None => false
  | Some proto => proto
  end.

Definition genesis : Tezos_shell.State.Chain.genesis :=
  {| time := genesis_time; block := genesis_block; protocol := genesis_protocol
    |}.

Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
  Tezos_base__TzPervasives.Chain_id.of_block_hash genesis_block.

Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
  let new_fitness :=
    match fitness with
    | cons fitness [] =>
      Stdlib.Pervasives.op_pipe_gt
        (Stdlib.Pervasives.op_pipe_gt
          (Stdlib.Pervasives.op_pipe_gt
            (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
              Tezos_base__TzPervasives.Data_encoding.int64 fitness)
            (Tezos_base__TzPervasives.Option.unopt 0)) Stdlib.Int64.succ)
        (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_base__TzPervasives.Data_encoding.int64)
    | _ =>
      Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
        Tezos_base__TzPervasives.Data_encoding.int64 1
    end in
  cons new_fitness [].

Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  : Tezos_base__TzPervasives.Time.Protocol.t :=
  Tezos_base__TzPervasives.Time.Protocol.add timestamp
    (Stdlib.Int64.add 1 (Stdlib.Random.int64 10)).

Definition operation (op : string)
  : Tezos_crypto.Operation_hash.t * Tezos_base__TzPervasives.Operation.t *
    (option Stdlib.Bytes.t) :=
  let op :=
    {| shell := {| branch := genesis_block |};
      proto := Stdlib.Bytes.of_string op |} in
  ((Tezos_base__TzPervasives.Operation.hash op), op,
    (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes
      Tezos_base__TzPervasives.Operation.encoding op)).

Definition block_header_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding string :=
  Tezos_base__TzPervasives.Data_encoding.obj1
    (Tezos_base__TzPervasives.Data_encoding.req None None
      "proto_block_header" % string
      Tezos_base__TzPervasives.Data_encoding.string).

Definition block {A : Type}
  (_state : A)
  (op_star_o_p_t_star : option Tezos_base__TzPervasives.Context_hash.t)
  : (option (list Tezos_base__TzPervasives.Operation_list_hash.elt)) ->
    Tezos_shell.State.Block.t ->
      string -> Tezos_base__TzPervasives.Block_header.t :=
  let context :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_base__TzPervasives.Context_hash.zero
    end in
  fun op_star_o_p_t_star =>
    let operations :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun pred =>
      fun name =>
        let operations_hash :=
          Tezos_base__TzPervasives.Operation_list_list_hash.compute
            (cons
              (Tezos_base__TzPervasives.Operation_list_hash.compute operations)
              []) in
        let pred_header := Tezos_shell.State.Block.shell_header pred in
        let fitness := incr_fitness (fitness pred_header) in
        let timestamp := incr_timestamp (timestamp pred_header) in
        let protocol_data :=
          Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
            block_header_data_encoding name in
        {|
          shell :=
            {| level := Stdlib.Int32.succ (level pred_header);
              proto_level := proto_level pred_header;
              predecessor := Tezos_shell.State.Block.hash pred;
              timestamp := timestamp; validation_passes := 1;
              operations_hash := operations_hash; fitness := fitness;
              context := context |}; protocol_data := protocol_data |}.

Definition parsed_block
  (function_parameter : Tezos_base__TzPervasives.Block_header.t)
  : Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header) :=
  match function_parameter with
  | {| shell := shell; protocol_data := protocol_data |} =>
    let protocol_data :=
      Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
        Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
        protocol_data in
    {| shell := shell; protocol_data := protocol_data |}
  end.

Definition zero : string := Stdlib.Bytes.create 0.

Definition build_valid_chain
  (state : Tezos_shell__State.Chain.t)
  (vtbl : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t)
  (pred : Tezos_shell.State.Block.t) (names : list string) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Lwt_list.fold_left_s
      (fun pred =>
        fun name =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.context_exn pred)
            (fun predecessor_context =>
              let max_trials := 100 in
              let fix attempt
                (trials : Z) (context :
                option Tezos_base__TzPervasives.Context_hash.t)
                : Lwt.t Tezos_shell.State.Block.t :=
                Tezos_base__TzPervasives.op_gt_gt_eq
                  match operation name with
                  | (oph, op, _bytes) =>
                    let block :=
                      block state context (Some (cons oph [])) pred name in
                    let hash := Tezos_base__TzPervasives.Block_header.hash block
                      in
                    let pred_header := Tezos_shell.State.Block.header pred in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (let predecessor_context :=
                        Tezos_shell_context.Shell_context.wrap_disk_context
                          predecessor_context in
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Proto.(Tezos_protocol_updater__Registered_protocol.T.begin_application)
                          Tezos_base__TzPervasives.Chain_id.zero
                          predecessor_context (timestamp (shell pred_header))
                          (fitness (shell pred_header)) (parsed_block block))
                        (fun vstate =>
                          Proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
                            vstate))
                      (fun function_parameter =>
                        match function_parameter with
                        | (result, _metadata) =>
                          let context :=
                            Tezos_shell_context.Shell_context.unwrap_disk_context
                              (context result) in
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_storage.Context.commit
                              (timestamp (shell block)) None context)
                            (fun context_hash =>
                              let validation_store :=
                                {| context_hash := context_hash;
                                  message := message result;
                                  max_operations_ttl := 1;
                                  last_allowed_fork_level :=
                                    last_allowed_fork_level result |} in
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_shell.State.Block.store None state block
                                  zero (cons (cons op []) [])
                                  (cons (cons zero []) [])
                                  {| context_hash := context_hash;
                                    message := message validation_store;
                                    max_operations_ttl := 1;
                                    last_allowed_fork_level :=
                                      last_allowed_fork_level validation_store
                                    |} false)
                                (fun _vblock =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_shell.State.Block.read state hash)
                                    (fun vblock =>
                                      Stdlib.Hashtbl.add vtbl name vblock;
                                      Tezos_base__TzPervasives._return vblock)))
                        end)
                  end
                  (fun function_parameter =>
                    match function_parameter with
                    | inl v =>
                      if OCaml.Stdlib.lt trials max_trials then
                        Stdlib.Format.eprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Took " % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.String_literal
                                  " trials to build valid chain" % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Took %d trials to build valid chain" % string)
                          (Z.add (Z.sub max_trials trials) 1)
                      else
                        tt;
                      Lwt._return v
                    | inr (cons (Validation_errors.Inconsistent_hash got _) _)
                      =>
                      if OCaml.Stdlib.le trials 0 then
                        false
                      else
                        Stdlib.Format.eprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Inconsistent context hash: got " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  ", retrying (" % string
                                  (CamlinternalFormatBasics.Int
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.String_literal
                                      ")
" % string
                                      CamlinternalFormatBasics.End_of_format)))))
                            "Inconsistent context hash: got %a, retrying (%d)
"
                              % string) Tezos_base__TzPervasives.Context_hash.pp
                          got trials;
                        attempt (Z.sub trials 1) (Some got)
                    | inr err =>
                      Stdlib.Format.eprintf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Error: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal
                                "010" % char
                                CamlinternalFormatBasics.End_of_format)))
                          "Error: %a
" % string)
                        Tezos_base__TzPervasives.Error_monad.pp_print_error err;
                      false
                    end) in
              attempt max_trials None)) pred names)
    (fun function_parameter =>
      match function_parameter with
      | _ => Lwt.return_unit
      end).

Record state := {
  vblock : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t;
  state : Tezos_shell.State.t;
  chain : Tezos_shell.State.Chain.t }.

Definition vblock (s : state) : string -> Tezos_shell.State.Block.t :=
  Stdlib.Hashtbl.find (vblock s).

Definition vblocks (s : state) : list (string * Tezos_shell.State.Block.t) :=
  OCaml.Stdlib.reverse_apply
    (Stdlib.Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc)
      (vblock s) [])
    (Tezos_base__TzPervasives.List.sort Stdlib.Pervasives.compare).

Definition build_example_tree (chain : Tezos_shell.State.Chain.t)
  : Lwt.t (Stdlib.Hashtbl.t string Tezos_shell.State.Block.t) :=
  let vtbl := Stdlib.Hashtbl.create None 23 in
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.genesis chain)
    (fun genesis =>
      Stdlib.Hashtbl.add vtbl "Genesis" % string genesis;
      let c :=
        cons "A1" % string
          (cons "A2" % string
            (cons "A3" % string
              (cons "A4" % string
                (cons "A5" % string
                  (cons "A6" % string
                    (cons "A7" % string (cons "A8" % string []))))))) in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (build_valid_chain chain vtbl genesis c)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let a3 := Stdlib.Hashtbl.find vtbl "A3" % string in
            let c :=
              cons "B1" % string
                (cons "B2" % string
                  (cons "B3" % string
                    (cons "B4" % string
                      (cons "B5" % string
                        (cons "B6" % string
                          (cons "B7" % string (cons "B8" % string []))))))) in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (build_valid_chain chain vtbl a3 c)
              (fun function_parameter =>
                match function_parameter with
                | tt => Lwt._return vtbl
                end)
          end)).

Definition wrap_state_init {A : Type}
  (f : state -> Lwt.t (Tezos_base__TzPervasives.tzresult A)) (base_dir : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  let store_root := op_div_div base_dir "store" % string in
  let context_root := op_div_div base_dir "context" % string in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.init None None (Some 4096000000) (Some 4096000000)
      store_root context_root None genesis)
    (fun function_parameter =>
      match function_parameter with
      | (state, chain, _index, _history_mode) =>
        Tezos_base__TzPervasives.op_gt_gt_eq (build_example_tree chain)
          (fun vblock =>
            f {| vblock := vblock; state := state; chain := chain |})
      end).

Definition test_init (function_parameter : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | _ => Tezos_base__TzPervasives.return_unit
  end.

Definition test_read_block (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Lwt_list.iter_s
      (fun function_parameter =>
        match function_parameter with
        | (name, vblock) =>
          let hash := Tezos_shell.State.Block.hash vblock in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.read (chain s) hash)
            (fun function_parameter =>
              match function_parameter with
              | inr _ =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "Error while reading valid block %s" % string name
              | inl _vblock' => Lwt.return_unit
              end)
        end) (vblocks s))
    (fun function_parameter =>
      match function_parameter with
      | tt => Tezos_base__TzPervasives.return_unit
      end).

Definition test_set_checkpoint_then_purge_full (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.checkpoint (chain s))
    (fun checkpoint =>
      let checkpoint_lvl := level (shell checkpoint) in
      let checkpoint_hash :=
        Tezos_base__TzPervasives.Block_header.hash checkpoint in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.State.Block.read (chain s) genesis_block)
        (fun read_genesis =>
          let read_genesis_hash :=
            Tezos_base__TzPervasives.Block_header.hash
              (Tezos_shell.State.Block.header read_genesis) in
          Tezos_base__TzPervasives.Block_hash.equal checkpoint_hash
            read_genesis_hash;
          equiv_decb checkpoint_lvl Stdlib.Int32.zero;
          let a1 := vblock s "A1" % string in
          let ha1 := Tezos_shell.State.Block.hash a1 in
          let b1 := vblock s "B1" % string in
          let hb1 := Tezos_shell.State.Block.hash b1 in
          let b2 := vblock s "B2" % string in
          let hb2 := Tezos_shell.State.Block.hash b2 in
          let la1 := Tezos_shell.State.Block.level a1 in
          let lb1 := Tezos_shell.State.Block.level b1 in
          let lb2 := Tezos_shell.State.Block.level b2 in
          equiv_decb (Stdlib.Int32.compare checkpoint_lvl la1) (-1);
          equiv_decb (Stdlib.Int32.compare checkpoint_lvl lb1) (-1);
          equiv_decb (Stdlib.Int32.compare checkpoint_lvl lb2) (-1);
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Chain.store (chain s))
            (fun chain_store =>
              let chain_store :=
                Tezos_shell.Store.Chain.get chain_store
                  (Tezos_shell.State.Chain.id (chain s)) in
              let block_store := Tezos_shell.Store.Block.get chain_store in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell.State.Chain.set_checkpoint_then_purge_full
                  (chain s) (Tezos_shell.State.Block.header b2))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_base__TzPervasives.op_gt_pipe_eq
                        (Tezos_shell.State.Block.known (chain s) hb2)
                        (fun b => b))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_base__TzPervasives.op_gt_pipe_eq
                              (Tezos_shell.State.Chain.checkpoint (chain s))
                              (fun b =>
                                Tezos_base__TzPervasives.Block_hash.equal
                                  (Tezos_base__TzPervasives.Block_header.hash b)
                                  hb2;
                                Stdlib.Int32.equal (level (shell b)) lb2))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Tezos_base__TzPervasives.op_gt_pipe_eq
                                    (Tezos_shell.Store.Block.Contents.known
                                      (block_store, hb1)) (fun b => negb b))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_base__TzPervasives.op_gt_pipe_eq
                                          (Tezos_shell.State.Block.read_opt
                                            (chain s) hb1)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | Some _header => true
                                            | None => false
                                            end))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                (Tezos_shell.Store.Block.Contents.known
                                                  (block_store, ha1))
                                                (fun b => negb b))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                    (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                      (Tezos_shell.State.Block.read_opt
                                                        (chain s) ha1)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | Some _header => true
                                                        | None => false
                                                        end))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                            (Tezos_shell.Store.Block.Pruned_contents.known
                                                              (block_store, ha1))
                                                            (fun b => b))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_base__TzPervasives.return_unit
                                                            end)
                                                      end)
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)))).

Definition test_set_checkpoint_then_purge_rolling (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.checkpoint (chain s))
    (fun checkpoint =>
      let checkpoint_lvl := level (shell checkpoint) in
      let checkpoint_hash :=
        Tezos_base__TzPervasives.Block_header.hash checkpoint in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.State.Block.read (chain s) genesis_block)
        (fun read_genesis =>
          let read_genesis_hash :=
            Tezos_base__TzPervasives.Block_header.hash
              (Tezos_shell.State.Block.header read_genesis) in
          Tezos_base__TzPervasives.Block_hash.equal checkpoint_hash
            read_genesis_hash;
          equiv_decb checkpoint_lvl Stdlib.Int32.zero;
          let a1 := vblock s "A1" % string in
          let ha1 := Tezos_shell.State.Block.hash a1 in
          let b1 := vblock s "B1" % string in
          let hb1 := Tezos_shell.State.Block.hash b1 in
          let b2 := vblock s "B2" % string in
          let hb2 := Tezos_shell.State.Block.hash b2 in
          let la1 := Tezos_shell.State.Block.level a1 in
          let lb1 := Tezos_shell.State.Block.level b1 in
          let lb2 := Tezos_shell.State.Block.level b2 in
          equiv_decb (Stdlib.Int32.compare checkpoint_lvl la1) (-1);
          equiv_decb (Stdlib.Int32.compare checkpoint_lvl lb1) (-1);
          equiv_decb (Stdlib.Int32.compare checkpoint_lvl lb2) (-1);
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_shell.State.Block.max_operations_ttl b2)
            (fun max_op_ttl =>
              OCaml.Stdlib.gt max_op_ttl 0;
              let ilb1 := Stdlib.Int32.to_int lb1 in
              let ilb2 := Stdlib.Int32.to_int lb2 in
              OCaml.Stdlib.le (Z.sub ilb2 ilb1)
                (OCaml.Stdlib.min max_op_ttl ilb2);
              let ila1 := Stdlib.Int32.to_int la1 in
              OCaml.Stdlib.gt (Z.sub ilb2 ila1)
                (OCaml.Stdlib.min max_op_ttl ilb2);
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.State.Chain.store (chain s))
                (fun chain_store =>
                  let chain_store :=
                    Tezos_shell.Store.Chain.get chain_store
                      (Tezos_shell.State.Chain.id (chain s)) in
                  let block_store := Tezos_shell.Store.Block.get chain_store in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_base__TzPervasives.op_gt_pipe_eq
                      (Tezos_shell.Store.Block.Pruned_contents.known
                        (block_store, hb1)) (fun b => negb b))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_base__TzPervasives.op_gt_pipe_eq
                            (Tezos_shell.State.Block.known (chain s) hb1)
                            (fun b => b))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (Tezos_base__TzPervasives.op_gt_pipe_eq
                                  (Tezos_shell.Store.Block.Contents.known
                                    (block_store, hb1)) (fun b => b))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_shell.State.Chain.set_checkpoint_then_purge_rolling
                                        (chain s)
                                        (Tezos_shell.State.Block.header b2))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Tezos_base__TzPervasives.op_gt_pipe_eq
                                              (Tezos_shell.State.Block.known
                                                (chain s) hb2) (fun b => b))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                  (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                    (Tezos_shell.State.Chain.checkpoint
                                                      (chain s))
                                                    (fun b =>
                                                      Tezos_base__TzPervasives.Block_hash.equal
                                                        (Tezos_base__TzPervasives.Block_header.hash
                                                          b) hb2;
                                                      Stdlib.Int32.equal
                                                        (level (shell b)) lb2))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                          (Tezos_shell.Store.Block.Contents.known
                                                            (block_store, hb1))
                                                          (fun b => negb b))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                              (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                (Tezos_shell.State.Block.read_opt
                                                                  (chain s) hb1)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | Some _block
                                                                    => true
                                                                  | None =>
                                                                    false
                                                                  end))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                                    (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                      (Tezos_shell.Store.Block.Pruned_contents.known
                                                                        (block_store,
                                                                          hb1))
                                                                      (fun b =>
                                                                        b))
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | tt =>
                                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                                          (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                            (Tezos_shell.State.Block.Header.known
                                                                              (block_store,
                                                                                hb1))
                                                                            (fun
                                                                              b
                                                                              =>
                                                                              b))
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            | tt
                                                                              =>
                                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                                  (Tezos_shell.Store.Block.Contents.known
                                                                                    (block_store,
                                                                                      hb1))
                                                                                  (fun
                                                                                    b
                                                                                    =>
                                                                                    negb
                                                                                      b))
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    tt
                                                                                    =>
                                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                      (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                                        (Tezos_shell.State.Block.known
                                                                                          (chain
                                                                                            s)
                                                                                          ha1)
                                                                                        (fun
                                                                                          b
                                                                                          =>
                                                                                          negb
                                                                                            b))
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          tt
                                                                                          =>
                                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                            (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                                              (Tezos_shell.State.Block.read_opt
                                                                                                (chain
                                                                                                  s)
                                                                                                ha1)
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  Some
                                                                                                    _header
                                                                                                  =>
                                                                                                  false
                                                                                                |
                                                                                                  None
                                                                                                  =>
                                                                                                  true
                                                                                                end))
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                tt
                                                                                                =>
                                                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                  (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                                                    (Tezos_shell.Store.Block.Pruned_contents.known
                                                                                                      (block_store,
                                                                                                        ha1))
                                                                                                    (fun
                                                                                                      b
                                                                                                      =>
                                                                                                      negb
                                                                                                        b))
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    match
                                                                                                      function_parameter
                                                                                                      with
                                                                                                    |
                                                                                                      tt
                                                                                                      =>
                                                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                        (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                                                          (Tezos_shell.State.Block.Header.known
                                                                                                            (block_store,
                                                                                                              ha1))
                                                                                                          (fun
                                                                                                            b
                                                                                                            =>
                                                                                                            negb
                                                                                                              b))
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          match
                                                                                                            function_parameter
                                                                                                            with
                                                                                                          |
                                                                                                            tt
                                                                                                            =>
                                                                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                              (Tezos_base__TzPervasives.op_gt_pipe_eq
                                                                                                                (Tezos_shell.Store.Block.Contents.known
                                                                                                                  (block_store,
                                                                                                                    hb1))
                                                                                                                (fun
                                                                                                                  b
                                                                                                                  =>
                                                                                                                  negb
                                                                                                                    b))
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                match
                                                                                                                  function_parameter
                                                                                                                  with
                                                                                                                |
                                                                                                                  tt
                                                                                                                  =>
                                                                                                                  Tezos_base__TzPervasives.return_unit
                                                                                                                end)
                                                                                                          end)
                                                                                                    end)
                                                                                              end)
                                                                                        end)
                                                                                  end)
                                                                            end)
                                                                      end)
                                                                end)
                                                          end)
                                                    end)
                                              end)
                                        end)
                                  end)
                            end)
                      end))))).

Fixpoint compare_path
  (p1 : list Tezos_base__TzPervasives.Block_hash.t)
  (p2 : list Tezos_base__TzPervasives.Block_hash.t) : bool :=
  match (p1, p2) with
  | ([], []) => true
  | (cons h1 p1, cons h2 p2) =>
    andb (Tezos_base__TzPervasives.Block_hash.equal h1 h2) (compare_path p1 p2)
  | _ => false
  end.

Definition test_path (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let check_path (h1 : string) (h2 : string) (p2 : list string) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Chain_traversal.path (vblock s h1) (vblock s h2))
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            "cannot compute path %s -> %s" % string h1 h2
        | Some (_ as p) =>
          let p :=
            Tezos_base__TzPervasives.List.map Tezos_shell.State.Block.hash p in
          let p2 :=
            Tezos_base__TzPervasives.List.map
              (fun b => Tezos_shell.State.Block.hash (vblock s b)) p2 in
          if negb (compare_path p p2) then
            op_star_t_y_p_e_minus_e_r_r_o_r_star "bad path %s -> %s" % string h1
              h2
          else
            tt;
          Lwt.return_unit
        end) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (check_path "Genesis" % string "Genesis" % string [])
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (check_path "A1" % string "A1" % string [])
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (check_path "A2" % string "A6" % string
                  (cons "A3" % string
                    (cons "A4" % string
                      (cons "A5" % string (cons "A6" % string [])))))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (check_path "B2" % string "B6" % string
                        (cons "B3" % string
                          (cons "B4" % string
                            (cons "B5" % string (cons "B6" % string [])))))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (check_path "A1" % string "B3" % string
                              (cons "A2" % string
                                (cons "A3" % string
                                  (cons "B1" % string
                                    (cons "B2" % string (cons "B3" % string []))))))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        end)
                  end)
            end)
      end).

Definition test_ancestor (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let check_ancestor
    (h1 : string) (h2 : string) (expected : Tezos_shell.State.Block.t)
    : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Chain_traversal.common_ancestor (vblock s h1) (vblock s h2))
      (fun a =>
        if
          negb
            (Tezos_base__TzPervasives.Block_hash.equal
              (Tezos_shell.State.Block.hash a)
              (Tezos_shell.State.Block.hash expected)) then
          op_star_t_y_p_e_minus_e_r_r_o_r_star "bad ancestor %s %s" % string h1
            h2
        else
          tt;
        Lwt.return_unit) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (check_ancestor "Genesis" % string "Genesis" % string
      (vblock s "Genesis" % string))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (check_ancestor "Genesis" % string "A3" % string
            (vblock s "Genesis" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (check_ancestor "A3" % string "Genesis" % string
                  (vblock s "Genesis" % string))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (check_ancestor "A1" % string "A1" % string
                        (vblock s "A1" % string))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (check_ancestor "A1" % string "A3" % string
                              (vblock s "A1" % string))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (check_ancestor "A3" % string "A1" % string
                                    (vblock s "A1" % string))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (check_ancestor "A6" % string
                                          "B6" % string (vblock s "A3" % string))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (check_ancestor "B6" % string
                                                "A6" % string
                                                (vblock s "A3" % string))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                    (check_ancestor
                                                      "A4" % string
                                                      "B1" % string
                                                      (vblock s "A3" % string))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (check_ancestor
                                                            "B1" % string
                                                            "A4" % string
                                                            (vblock s
                                                              "A3" % string))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (check_ancestor
                                                                  "A3" % string
                                                                  "B1" % string
                                                                  (vblock s
                                                                    "A3" %
                                                                      string))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                      (check_ancestor
                                                                        "B1" %
                                                                          string
                                                                        "A3" %
                                                                          string
                                                                        (vblock
                                                                          s
                                                                          "A3" %
                                                                            string))
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                            (check_ancestor
                                                                              "A2"
                                                                                %
                                                                                string
                                                                              "B1"
                                                                                %
                                                                                string
                                                                              (vblock
                                                                                s
                                                                                "A2"
                                                                                  %
                                                                                  string))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                  (check_ancestor
                                                                                    "B1"
                                                                                      %
                                                                                      string
                                                                                    "A2"
                                                                                      %
                                                                                      string
                                                                                    (vblock
                                                                                      s
                                                                                      "A2"
                                                                                        %
                                                                                        string))
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      Tezos_base__TzPervasives.return_unit
                                                                                    end)
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end)
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end).

Definition seed : Tezos_base__TzPervasives.Block_locator.seed :=
  let receiver_id :=
    Tezos_base__TzPervasives.P2p_peer.Id.of_string_exn
      (Tezos_base__TzPervasives.String.make
        Tezos_base__TzPervasives.P2p_peer.Id.size "r" % char) in
  let sender_id :=
    Tezos_base__TzPervasives.P2p_peer.Id.of_string_exn
      (Tezos_base__TzPervasives.String.make
        Tezos_base__TzPervasives.P2p_peer.Id.size "s" % char) in
  {| Block_locator.sender_id := sender_id;
    Block_locator.receiver_id := receiver_id |}.

Definition test_locator (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let check_locator (length : Z) (h1 : string) (expected : list string)
    : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.State.compute_locator (chain s) (Some length) (vblock s h1)
        seed)
      (fun l =>
        match l with
        | (_, l) =>
          if
            nequiv_decb (Tezos_base__TzPervasives.List.length l)
              (Tezos_base__TzPervasives.List.length expected) then
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              "Invalid locator length %s (found: %d, expected: %d)" % string h1
              (Tezos_base__TzPervasives.List.length l)
              (Tezos_base__TzPervasives.List.length expected)
          else
            tt;
          Tezos_base__TzPervasives.List.iter2
            (fun h =>
              fun h2 =>
                if
                  negb
                    (Tezos_base__TzPervasives.Block_hash.equal h
                      (apply Tezos_shell.State.Block.hash (vblock s h2))) then
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "Invalid locator %s (expected: %s)" % string h1 h2
                else
                  tt) l expected;
          Lwt.return_unit
        end) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (check_locator 6 "A8" % string
      (cons "A7" % string
        (cons "A6" % string
          (cons "A5" % string
            (cons "A4" % string (cons "A3" % string (cons "A2" % string [])))))))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (check_locator 8 "B8" % string
            (cons "B7" % string
              (cons "B6" % string
                (cons "B5" % string
                  (cons "B4" % string
                    (cons "B3" % string
                      (cons "B2" % string
                        (cons "B1" % string (cons "A3" % string [])))))))))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (check_locator 4 "B8" % string
                  (cons "B7" % string
                    (cons "B6" % string
                      (cons "B5" % string (cons "B4" % string [])))))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (check_locator 0 "A5" % string [])
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (check_locator 100 "A5" % string
                              (cons "A4" % string
                                (cons "A3" % string
                                  (cons "A2" % string
                                    (cons "A1" % string
                                      (cons "Genesis" % string []))))))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        end)
                  end)
            end)
      end).

Definition compare {A : Type}
  (s : state) (name : A) (heads : list Tezos_shell.State.Block.t)
  (l : list string) : unit :=
  if
    nequiv_decb (Tezos_base__TzPervasives.List.length heads)
      (Tezos_base__TzPervasives.List.length l) then
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      "unexpected known_heads size (%s: %d %d)" % string name
      (Tezos_base__TzPervasives.List.length heads)
      (Tezos_base__TzPervasives.List.length l)
  else
    tt;
  Tezos_base__TzPervasives.List.iter
    (fun bname =>
      let hash := Tezos_shell.State.Block.hash (vblock s bname) in
      if
        negb
          (Tezos_base__TzPervasives.List._exists
            (fun b =>
              Tezos_base__TzPervasives.Block_hash.equal hash
                (Tezos_shell.State.Block.hash b)) heads) then
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          "missing block in known_heads (%s: %s)" % string name bname
      else
        tt) l.

Definition test_known_heads (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.known_heads (chain s))
    (fun heads =>
      compare s "initial" % string heads
        (cons "A8" % string (cons "B8" % string []));
      Tezos_base__TzPervasives.return_unit).

Definition test_head (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.head (chain s))
    (fun head =>
      if
        negb
          (Tezos_base__TzPervasives.Block_hash.equal
            (Tezos_shell.State.Block.hash head) genesis_block) then
        op_star_t_y_p_e_minus_e_r_r_o_r_star "unexpected head" % string
      else
        tt;
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.Chain.set_head (chain s) (vblock s "A6" % string))
        (fun function_parameter =>
          match function_parameter with
          | _ =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.Chain.head (chain s))
              (fun head =>
                if
                  negb
                    (Tezos_base__TzPervasives.Block_hash.equal
                      (Tezos_shell.State.Block.hash head)
                      (apply Tezos_shell.State.Block.hash
                        (vblock s "A6" % string))) then
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "unexpected head" % string
                else
                  tt;
                Tezos_base__TzPervasives.return_unit)
          end)).

Definition test_mem (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let mem (s : state) (x : string) : Lwt.t bool :=
    Tezos_shell.Chain.mem (chain s)
      (apply Tezos_shell.State.Block.hash (vblock s x)) in
  let test_mem (s : state) (x : string) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq (mem s x)
      (fun function_parameter =>
        match function_parameter with
        | true => Lwt.return_unit
        | false => op_star_t_y_p_e_minus_e_r_r_o_r_star "mem %s" % string x
        end) in
  let test_not_mem (s : state) (x : string) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq (mem s x)
      (fun function_parameter =>
        match function_parameter with
        | false => Lwt.return_unit
        | true => op_star_t_y_p_e_minus_e_r_r_o_r_star "not (mem %s)" % string x
        end) in
  Tezos_base__TzPervasives.op_gt_gt_eq (test_not_mem s "A3" % string)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq (test_not_mem s "A6" % string)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (test_not_mem s "A8" % string)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (test_not_mem s "B1" % string)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (test_not_mem s "B6" % string)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (test_not_mem s "B8" % string)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_shell.Chain.set_head (chain s)
                                          (vblock s "A8" % string))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | _ =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (test_mem s "A3" % string)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                    (test_mem s "A6" % string)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (test_mem s
                                                            "A8" % string)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (test_not_mem s
                                                                  "B1" % string)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                      (test_not_mem
                                                                        s
                                                                        "B6" %
                                                                          string)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                            (test_not_mem
                                                                              s
                                                                              "B8"
                                                                                %
                                                                                string)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                  (Tezos_shell.Chain.set_head
                                                                                    (chain
                                                                                      s)
                                                                                    (vblock
                                                                                      s
                                                                                      "A6"
                                                                                        %
                                                                                        string))
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      _
                                                                                      =>
                                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                        (test_mem
                                                                                          s
                                                                                          "A3"
                                                                                            %
                                                                                            string)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            tt
                                                                                            =>
                                                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                              (test_mem
                                                                                                s
                                                                                                "A6"
                                                                                                  %
                                                                                                  string)
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  tt
                                                                                                  =>
                                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                    (test_not_mem
                                                                                                      s
                                                                                                      "A8"
                                                                                                        %
                                                                                                        string)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      match
                                                                                                        function_parameter
                                                                                                        with
                                                                                                      |
                                                                                                        tt
                                                                                                        =>
                                                                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                          (test_not_mem
                                                                                                            s
                                                                                                            "B1"
                                                                                                              %
                                                                                                              string)
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            match
                                                                                                              function_parameter
                                                                                                              with
                                                                                                            |
                                                                                                              tt
                                                                                                              =>
                                                                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                (test_not_mem
                                                                                                                  s
                                                                                                                  "B6"
                                                                                                                    %
                                                                                                                    string)
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  match
                                                                                                                    function_parameter
                                                                                                                    with
                                                                                                                  |
                                                                                                                    tt
                                                                                                                    =>
                                                                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                      (test_not_mem
                                                                                                                        s
                                                                                                                        "B8"
                                                                                                                          %
                                                                                                                          string)
                                                                                                                      (fun
                                                                                                                        function_parameter
                                                                                                                        =>
                                                                                                                        match
                                                                                                                          function_parameter
                                                                                                                          with
                                                                                                                        |
                                                                                                                          tt
                                                                                                                          =>
                                                                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                            (Tezos_shell.Chain.set_head
                                                                                                                              (chain
                                                                                                                                s)
                                                                                                                              (vblock
                                                                                                                                s
                                                                                                                                "B6"
                                                                                                                                  %
                                                                                                                                  string))
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              match
                                                                                                                                function_parameter
                                                                                                                                with
                                                                                                                              |
                                                                                                                                _
                                                                                                                                =>
                                                                                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                  (test_mem
                                                                                                                                    s
                                                                                                                                    "A3"
                                                                                                                                      %
                                                                                                                                      string)
                                                                                                                                  (fun
                                                                                                                                    function_parameter
                                                                                                                                    =>
                                                                                                                                    match
                                                                                                                                      function_parameter
                                                                                                                                      with
                                                                                                                                    |
                                                                                                                                      tt
                                                                                                                                      =>
                                                                                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                        (test_not_mem
                                                                                                                                          s
                                                                                                                                          "A4"
                                                                                                                                            %
                                                                                                                                            string)
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          match
                                                                                                                                            function_parameter
                                                                                                                                            with
                                                                                                                                          |
                                                                                                                                            tt
                                                                                                                                            =>
                                                                                                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                              (test_not_mem
                                                                                                                                                s
                                                                                                                                                "A6"
                                                                                                                                                  %
                                                                                                                                                  string)
                                                                                                                                              (fun
                                                                                                                                                function_parameter
                                                                                                                                                =>
                                                                                                                                                match
                                                                                                                                                  function_parameter
                                                                                                                                                  with
                                                                                                                                                |
                                                                                                                                                  tt
                                                                                                                                                  =>
                                                                                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                    (test_not_mem
                                                                                                                                                      s
                                                                                                                                                      "A8"
                                                                                                                                                        %
                                                                                                                                                        string)
                                                                                                                                                    (fun
                                                                                                                                                      function_parameter
                                                                                                                                                      =>
                                                                                                                                                      match
                                                                                                                                                        function_parameter
                                                                                                                                                        with
                                                                                                                                                      |
                                                                                                                                                        tt
                                                                                                                                                        =>
                                                                                                                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                          (test_mem
                                                                                                                                                            s
                                                                                                                                                            "B1"
                                                                                                                                                              %
                                                                                                                                                              string)
                                                                                                                                                          (fun
                                                                                                                                                            function_parameter
                                                                                                                                                            =>
                                                                                                                                                            match
                                                                                                                                                              function_parameter
                                                                                                                                                              with
                                                                                                                                                            |
                                                                                                                                                              tt
                                                                                                                                                              =>
                                                                                                                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                (test_mem
                                                                                                                                                                  s
                                                                                                                                                                  "B6"
                                                                                                                                                                    %
                                                                                                                                                                    string)
                                                                                                                                                                (fun
                                                                                                                                                                  function_parameter
                                                                                                                                                                  =>
                                                                                                                                                                  match
                                                                                                                                                                    function_parameter
                                                                                                                                                                    with
                                                                                                                                                                  |
                                                                                                                                                                    tt
                                                                                                                                                                    =>
                                                                                                                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                      (test_not_mem
                                                                                                                                                                        s
                                                                                                                                                                        "B8"
                                                                                                                                                                          %
                                                                                                                                                                          string)
                                                                                                                                                                      (fun
                                                                                                                                                                        function_parameter
                                                                                                                                                                        =>
                                                                                                                                                                        match
                                                                                                                                                                          function_parameter
                                                                                                                                                                          with
                                                                                                                                                                        |
                                                                                                                                                                          tt
                                                                                                                                                                          =>
                                                                                                                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                            (Tezos_shell.Chain.set_head
                                                                                                                                                                              (chain
                                                                                                                                                                                s)
                                                                                                                                                                              (vblock
                                                                                                                                                                                s
                                                                                                                                                                                "B8"
                                                                                                                                                                                  %
                                                                                                                                                                                  string))
                                                                                                                                                                            (fun
                                                                                                                                                                              function_parameter
                                                                                                                                                                              =>
                                                                                                                                                                              match
                                                                                                                                                                                function_parameter
                                                                                                                                                                                with
                                                                                                                                                                              |
                                                                                                                                                                                _
                                                                                                                                                                                =>
                                                                                                                                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                                  (test_mem
                                                                                                                                                                                    s
                                                                                                                                                                                    "A3"
                                                                                                                                                                                      %
                                                                                                                                                                                      string)
                                                                                                                                                                                  (fun
                                                                                                                                                                                    function_parameter
                                                                                                                                                                                    =>
                                                                                                                                                                                    match
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      with
                                                                                                                                                                                    |
                                                                                                                                                                                      tt
                                                                                                                                                                                      =>
                                                                                                                                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                                        (test_not_mem
                                                                                                                                                                                          s
                                                                                                                                                                                          "A4"
                                                                                                                                                                                            %
                                                                                                                                                                                            string)
                                                                                                                                                                                        (fun
                                                                                                                                                                                          function_parameter
                                                                                                                                                                                          =>
                                                                                                                                                                                          match
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            with
                                                                                                                                                                                          |
                                                                                                                                                                                            tt
                                                                                                                                                                                            =>
                                                                                                                                                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                                              (test_not_mem
                                                                                                                                                                                                s
                                                                                                                                                                                                "A6"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  string)
                                                                                                                                                                                              (fun
                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                =>
                                                                                                                                                                                                match
                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                  with
                                                                                                                                                                                                |
                                                                                                                                                                                                  tt
                                                                                                                                                                                                  =>
                                                                                                                                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                                                    (test_not_mem
                                                                                                                                                                                                      s
                                                                                                                                                                                                      "A8"
                                                                                                                                                                                                        %
                                                                                                                                                                                                        string)
                                                                                                                                                                                                    (fun
                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                      =>
                                                                                                                                                                                                      match
                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                        with
                                                                                                                                                                                                      |
                                                                                                                                                                                                        tt
                                                                                                                                                                                                        =>
                                                                                                                                                                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                                                          (test_mem
                                                                                                                                                                                                            s
                                                                                                                                                                                                            "B1"
                                                                                                                                                                                                              %
                                                                                                                                                                                                              string)
                                                                                                                                                                                                          (fun
                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                            =>
                                                                                                                                                                                                            match
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              with
                                                                                                                                                                                                            |
                                                                                                                                                                                                              tt
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                                                                (test_mem
                                                                                                                                                                                                                  s
                                                                                                                                                                                                                  "B6"
                                                                                                                                                                                                                    %
                                                                                                                                                                                                                    string)
                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  match
                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                    with
                                                                                                                                                                                                                  |
                                                                                                                                                                                                                    tt
                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                                                                                                                                      (test_mem
                                                                                                                                                                                                                        s
                                                                                                                                                                                                                        "B8"
                                                                                                                                                                                                                          %
                                                                                                                                                                                                                          string)
                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                        match
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          with
                                                                                                                                                                                                                        |
                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          Tezos_base__TzPervasives.return_unit
                                                                                                                                                                                                                        end)
                                                                                                                                                                                                                  end)
                                                                                                                                                                                                            end)
                                                                                                                                                                                                      end)
                                                                                                                                                                                                end)
                                                                                                                                                                                          end)
                                                                                                                                                                                    end)
                                                                                                                                                                              end)
                                                                                                                                                                        end)
                                                                                                                                                                  end)
                                                                                                                                                            end)
                                                                                                                                                      end)
                                                                                                                                                end)
                                                                                                                                          end)
                                                                                                                                    end)
                                                                                                                              end)
                                                                                                                        end)
                                                                                                                  end)
                                                                                                            end)
                                                                                                      end)
                                                                                                end)
                                                                                          end)
                                                                                    end)
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end)
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end).

Definition test_new_blocks (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let test
    (s : state) (head : string) (h : string) (expected_ancestor : string)
    (expected : list string) : Lwt.t unit :=
    let to_block : Tezos_shell.State.Block.t :=
      vblock s head
    with from_block : Tezos_shell.State.Block.t :=
      vblock s h in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.Chain_traversal.new_blocks from_block to_block)
      (fun function_parameter =>
        match function_parameter with
        | (ancestor, blocks) =>
          if
            negb
              (Tezos_base__TzPervasives.Block_hash.equal
                (Tezos_shell.State.Block.hash ancestor)
                (apply Tezos_shell.State.Block.hash (vblock s expected_ancestor)))
            then
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              "Invalid ancestor %s -> %s (expected: %s)" % string head h
              expected_ancestor
          else
            tt;
          if
            nequiv_decb (Tezos_base__TzPervasives.List.length blocks)
              (Tezos_base__TzPervasives.List.length expected) then
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              "Invalid locator length %s (found: %d, expected: %d)" % string h
              (Tezos_base__TzPervasives.List.length blocks)
              (Tezos_base__TzPervasives.List.length expected)
          else
            tt;
          Tezos_base__TzPervasives.List.iter2
            (fun h1 =>
              fun h2 =>
                if
                  negb
                    (Tezos_base__TzPervasives.Block_hash.equal
                      (Tezos_shell.State.Block.hash h1)
                      (apply Tezos_shell.State.Block.hash (vblock s h2))) then
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "Invalid new blocks %s -> %s (expected: %s)" % string head h
                    h2
                else
                  tt) blocks expected;
          Lwt.return_unit
        end) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (test s "A6" % string "A6" % string "A6" % string [])
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (test s "A8" % string "A6" % string "A6" % string
            (cons "A7" % string (cons "A8" % string [])))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (test s "A8" % string "B7" % string "A3" % string
                  (cons "A4" % string
                    (cons "A5" % string
                      (cons "A6" % string
                        (cons "A7" % string (cons "A8" % string []))))))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            end)
      end).

Definition tests
  : list (string * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  cons ("init" % string, test_init)
    (cons ("read_block" % string, test_read_block)
      (cons ("path" % string, test_path)
        (cons ("ancestor" % string, test_ancestor)
          (cons ("locator" % string, test_locator)
            (cons ("known_heads" % string, test_known_heads)
              (cons ("head" % string, test_head)
                (cons ("mem" % string, test_mem)
                  (cons ("new_blocks" % string, test_new_blocks)
                    (cons
                      ("set_checkpoint_then_purge_rolling" % string,
                        test_set_checkpoint_then_purge_rolling)
                      (cons
                        ("set_checkpoint_then_purge_full" % string,
                          test_set_checkpoint_then_purge_full) [])))))))))).

Definition wrap {A B : Type}
  (function_parameter :
    A * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) : B :=
  match function_parameter with
  | (n, f) =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir
                "tezos_test_" % string
                (fun dir =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (wrap_state_init f dir)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl tt => Lwt.return_unit
                      | inr error =>
                        Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string)
                          Tezos_base__TzPervasives.pp_print_error error
                      end))
            end
        end)
  end.

Definition tests {A : Type} : list A :=
  Tezos_base__TzPervasives.List.map wrap tests.
src/lib_shell/test/test_state_checkpoint.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

let proto =
  match Registered_protocol.get genesis_protocol with
  | None ->
      assert false
  | Some proto ->
      proto

module Proto = (val proto)

let genesis : State.Chain.genesis =
  {time = genesis_time; block = genesis_block; protocol = genesis_protocol}

let incr_fitness fitness =
  let new_fitness =
    match fitness with
    | [fitness] ->
        Pervasives.(
          Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
          |> Option.unopt ~default:0L |> Int64.succ
          |> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ ->
        Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
  in
  [new_fitness]

let incr_timestamp timestamp =
  Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))

let operation op =
  let op : Operation.t =
    {shell = {branch = genesis_block}; proto = Bytes.of_string op}
  in
  (Operation.hash op, op, Data_encoding.Binary.to_bytes Operation.encoding op)

let block_header_data_encoding =
  Data_encoding.(obj1 (req "proto_block_header" string))

let block _state ?(context = Context_hash.zero) ?(operations = [])
    (pred : State.Block.t) name : Block_header.t =
  let operations_hash =
    Operation_list_list_hash.compute [Operation_list_hash.compute operations]
  in
  let pred_header = State.Block.shell_header pred in
  let fitness = incr_fitness pred_header.fitness in
  let timestamp = incr_timestamp pred_header.timestamp in
  let protocol_data =
    Data_encoding.Binary.to_bytes_exn block_header_data_encoding name
  in
  {
    shell =
      {
        level = Int32.succ pred_header.level;
        proto_level = pred_header.proto_level;
        predecessor = State.Block.hash pred;
        validation_passes = 1;
        timestamp;
        operations_hash;
        fitness;
        context;
      };
    protocol_data;
  }

let parsed_block ({shell; protocol_data} : Block_header.t) =
  let protocol_data =
    Data_encoding.Binary.of_bytes_exn
      Proto.block_header_data_encoding
      protocol_data
  in
  ({shell; protocol_data} : Proto.block_header)

let zero = Bytes.create 0

let block_header_data_encoding =
  Data_encoding.(obj1 (req "proto_block_header" string))

let build_valid_chain state vtbl pred names =
  Lwt_list.fold_left_s
    (fun pred name ->
      State.Block.context_exn pred
      >>= fun predecessor_context ->
      let max_trials = 100 in
      let rec attempt trials context =
        (let (oph, op, _bytes) = operation name in
         let block = block ?context state ~operations:[oph] pred name in
         let hash = Block_header.hash block in
         let pred_header = State.Block.header pred in
         (let predecessor_context =
            Shell_context.wrap_disk_context predecessor_context
          in
          Proto.begin_application
            ~chain_id:Chain_id.zero
            ~predecessor_context
            ~predecessor_timestamp:pred_header.shell.timestamp
            ~predecessor_fitness:pred_header.shell.fitness
            (parsed_block block)
          >>=? fun vstate ->
          (* no operations *)
          Proto.finalize_block vstate)
         >>=? fun (result, _metadata) ->
         let context = Shell_context.unwrap_disk_context result.context in
         Context.commit
           ~time:(Time.System.to_protocol (Systime_os.now ()))
           ?message:result.message
           context
         >>= fun context_hash ->
         let validation_store =
           ( {
               context_hash;
               message = result.message;
               max_operations_ttl = result.max_operations_ttl;
               last_allowed_fork_level = result.last_allowed_fork_level;
             }
             : Tezos_validation.Block_validation.validation_store )
         in
         State.Block.store
           state
           block
           zero
           [[op]]
           [[zero]]
           validation_store
           ~forking_testchain:false
         >>=? fun _vblock ->
         State.Block.read state hash
         >>=? fun vblock ->
         Hashtbl.add vtbl name vblock ;
         return vblock)
        >>= function
        | Ok v ->
            if trials < max_trials then
              Format.eprintf
                "Took %d trials to build valid chain"
                (max_trials - trials + 1) ;
            Lwt.return v
        | Error (Validation_errors.Inconsistent_hash (got, _) :: _) ->
            (* Kind of a hack, but at least it tests idempotence to some extent. *)
            if trials <= 0 then assert false
            else (
              Format.eprintf
                "Inconsistent context hash: got %a, retrying (%d)\n"
                Context_hash.pp
                got
                trials ;
              attempt (trials - 1) (Some got) )
        | Error err ->
            Format.eprintf "Error: %a\n" Error_monad.pp_print_error err ;
            assert false
      in
      attempt max_trials None)
    pred
    names
  >>= fun _ -> Lwt.return_unit

type state = {
  vblock : (string, State.Block.t) Hashtbl.t;
  state : State.t;
  chain : State.Chain.t;
}

let vblock s = Hashtbl.find s.vblock

exception Found of string

let vblocks s =
  Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.vblock []
  |> List.sort Pervasives.compare

(*******************************************************)
(*

    Genesis - A1 - A2 - A3 - A4 - A5
                    \
                     B1 - B2 - B3 - B4 - B5
*)

let build_example_tree chain =
  let vtbl = Hashtbl.create 23 in
  Chain.genesis chain
  >>= fun genesis ->
  Hashtbl.add vtbl "Genesis" genesis ;
  let c = ["A1"; "A2"; "A3"; "A4"; "A5"] in
  build_valid_chain chain vtbl genesis c
  >>= fun () ->
  let a2 = Hashtbl.find vtbl "A2" in
  let c = ["B1"; "B2"; "B3"; "B4"; "B5"] in
  build_valid_chain chain vtbl a2 c >>= fun () -> Lwt.return vtbl

let wrap_state_init f base_dir =
  let store_root = base_dir // "store" in
  let context_root = base_dir // "context" in
  State.init
    ~store_mapsize:4_096_000_000L
    ~context_mapsize:4_096_000_000L
    ~store_root
    ~context_root
    genesis
  >>=? fun (state, chain, _index, _history_mode) ->
  build_example_tree chain
  >>= fun vblock -> f {state; chain; vblock} >>=? fun () -> return_unit

(** State.Chain.checkpoint *)

(*
- Valid branch are kept after setting a checkpoint. Bad branch are cut
- Setting a checkpoint in the future does not remove anything
- Reaching a checkpoint in the future with the right block keeps that
block and remove any concurrent branch
- Reaching a checkpoint in the future with a bad block remove that block and
does not prevent a future good block from correctly being reached
- There are no bad quadratic behaviours *)

let test_basic_checkpoint s =
  let block = vblock s "A1" in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  let c_level = checkpoint_header.shell.level in
  let c_block = Block_header.hash checkpoint_header in
  if
    (not (Block_hash.equal c_block (State.Block.hash block)))
    && Int32.equal c_level (State.Block.level block)
  then Assert.fail_msg "unexpected checkpoint"
  else return_unit

(*
   - cp: checkpoint

  Genesis - A1 - A2 (cp) - A3 - A4 - A5
                  \
                   B1 - B2 - B3 - B4 - B5
  *)

(* State.Chain.acceptable_block:
   will the block is compatible with the current checkpoint? *)

let test_acceptable_block s =
  let block = vblock s "A2" in
  let header = State.Block.header block in
  (* let level = State.Block.level block in
   * let block_hash = State.Block.hash block  in *)
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  (* it is accepted only if the current head is lower than the checkpoint *)
  let block_1 = vblock s "A1" in
  Chain.set_head s.chain block_1
  >>=? fun head ->
  let header = State.Block.header head in
  State.Chain.acceptable_block s.chain header
  >>= fun is_accepted_block ->
  if is_accepted_block then return_unit
  else Assert.fail_msg "unacceptable block"

(*
  Genesis - A1 - A2 (cp) - A3 - A4 - A5
                  \
                   B1 - B2 - B3 - B4 - B5
  *)

(* State.Block.is_valid_for_checkpoint :
   is the block still valid for a given checkpoint ? *)

let test_is_valid_checkpoint s =
  let block = vblock s "A2" in
  let header = State.Block.header block in
  (* let block_hash = State.Block.hash block in
   * let level = State.Block.level block in *)
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  (* "b3" is valid because:
     a1 - a2 (checkpoint) - b1 - b2 - b3
     it is not valid when the checkpoint change to a pick different than a2.
  *)
  State.Block.is_valid_for_checkpoint (vblock s "B3") checkpoint_header
  >>= fun is_valid ->
  if is_valid then return_unit else Assert.fail_msg "invalid checkpoint"

(* return a block with the best fitness amongst the known blocks which
    are compatible with the given checkpoint *)

let test_best_know_head_for_checkpoint s =
  let block = vblock s "A2" in
  let checkpoint = State.Block.header block in
  State.Chain.set_checkpoint s.chain checkpoint
  >>= fun () ->
  Chain.set_head s.chain (vblock s "B3")
  >>= fun _head ->
  State.best_known_head_for_checkpoint s.chain checkpoint
  >>= fun _block ->
  (* the block returns with the best fitness is B3 at level 5 *)
  return_unit

(*
   setting checkpoint in the future does not remove anything

   Genesis - A1 - A2(cp) - A3 - A4 - A5
                  \
                  B1 - B2 - B3 - B4 - B5
*)

let test_future_checkpoint s =
  let block = vblock s "A2" in
  let block_hash = State.Block.hash block in
  let level = State.Block.level block in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  let c_level = checkpoint_header.shell.level in
  let c_block = Block_header.hash checkpoint_header in
  if Int32.equal c_level level && not (Block_hash.equal c_block block_hash)
  then Assert.fail_msg "unexpected checkpoint"
  else return_unit

(*
   setting checkpoint in the future does not remove anything
   - iv = invalid
  - (0): level of this block in the chain

  Two exammples:
    * Genesis (0)- A1 (1) - A2(2) - A3(3) - A4(4) - A5(5) (invalid)
                            \
                            B1(3) - B2(4) - B3 (5)(cp) - B4(6) - B5(7)

    * Genesis - A1 - A2 - A3 - A4 - A5 (cp)
                      \
                      B1 - B2 - B3 (iv)- B4 (iv) - B5 (iv)
*)

let test_future_checkpoint_bad_good_block s =
  let block = vblock s "A5" in
  let block_hash = State.Block.hash block in
  let level = State.Block.level block in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  let c_level = checkpoint_header.shell.level in
  let c_block = Block_header.hash checkpoint_header in
  if Int32.equal c_level level && not (Block_hash.equal c_block block_hash)
  then Assert.fail_msg "unexpected checkpoint"
  else
    State.Block.is_valid_for_checkpoint (vblock s "B2") checkpoint_header
    >>= fun is_valid ->
    if is_valid then return_unit else Assert.fail_msg "invalid checkpoint"

(* check if the checkpoint can be reached

   Genesis - A1 (cp) - A2 (head) - A3 - A4 - A5
                        \
                        B1 - B2 - B3 - B4 - B5

*)

let test_reach_checkpoint s =
  let mem s x = Chain.mem s.chain (State.Block.hash @@ vblock s x) in
  let test_mem s x =
    mem s x
    >>= function
    | true -> Lwt.return_unit | false -> Assert.fail_msg "mem %s" x
  in
  let test_not_mem s x =
    mem s x
    >>= function
    | false -> Lwt.return_unit | true -> Assert.fail_msg "not (mem %s)" x
  in
  let block = vblock s "A1" in
  let block_hash = State.Block.hash block in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  let time_now = Time.System.to_protocol (Systime_os.now ()) in
  if
    Time.Protocol.compare
      (Time.Protocol.add time_now 15L)
      header.shell.timestamp
    >= 0
  then
    let checkpoint_hash = Block_header.hash checkpoint_header in
    if
      Int32.equal header.shell.level checkpoint_header.shell.level
      && not (Block_hash.equal checkpoint_hash block_hash)
    then Assert.fail_msg "checkpoint error"
    else
      Chain.set_head s.chain (vblock s "A2")
      >>= fun _ ->
      Chain.head s.chain
      >>= fun head ->
      let checkpoint_reached =
        (State.Block.header head).shell.level >= checkpoint_header.shell.level
      in
      if checkpoint_reached then
        (* if reached the checkpoint, every block before the checkpoint
           must be the part of the chain *)
        if header.shell.level <= checkpoint_header.shell.level then
          test_mem s "Genesis"
          >>= fun () ->
          test_mem s "A1"
          >>= fun () ->
          test_mem s "A2"
          >>= fun () ->
          test_not_mem s "A3"
          >>= fun () -> test_not_mem s "B1" >>= fun () -> return_unit
        else Assert.fail_msg "checkpoint error"
      else Assert.fail_msg "checkpoint error"
  else Assert.fail_msg "fail future block header"

(*
   Chain.Validator function may_update_checkpoint

   - ncp: new checkpoint

   Genesis - A1 - A2 - A3 (cp) - A4 - A5
                  \
                  B1 - B2 - B3 - B4 - B5

   Genesis - A1 (ncp) - A2 - A3 (cp) - A4 (ncp) - A5
                       \
                       B1 - B2 - B3 - B4 - B5
*)

let may_update_checkpoint chain_state new_head =
  State.Chain.checkpoint chain_state
  >>= fun checkpoint_header ->
  (* FIXME: the new level is always return 0l even
     if the new_head is A4 at level 4l
     Or TODO: set a level where allow to have a fork
  *)
  let old_level = checkpoint_header.shell.level in
  State.Block.last_allowed_fork_level new_head
  >>=? fun new_level ->
  if new_level <= old_level then return_unit
  else
    let head_level = State.Block.level new_head in
    State.Block.predecessor_n
      new_head
      (Int32.to_int (Int32.sub head_level new_level))
    >>= function
    | None ->
        return @@ Assert.fail_msg "Unexpected None in predecessor query"
    | Some hash -> (
        State.Block.read_opt chain_state hash
        >>= function
        | None ->
            assert false
        | Some b ->
            State.Chain.set_checkpoint chain_state (State.Block.header b)
            >>= fun () -> return_unit )

let test_may_update_checkpoint s =
  let block = vblock s "A3" in
  let checkpoint = State.Block.header block in
  State.Chain.set_checkpoint s.chain checkpoint
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun _ ->
  Chain.set_head s.chain (vblock s "A4")
  >>= fun _ ->
  Chain.head s.chain
  >>= fun head -> may_update_checkpoint s.chain head >>=? fun () -> return ()

(* Check function may_update_checkpoint in Node.ml

   Genesis - A1 - A2 (cp) - A3 - A4 - A5
                  \
                  B1 - B2 - B3 - B4 - B5

   chain after update:
   Genesis - A1 - A2 - A3(cp) - A4 - A5
                  \
                  B1 - B2 - B3 - B4 - B5
*)

let note_may_update_checkpoint chain_state checkpoint =
  match checkpoint with
  | None ->
      Lwt.return_unit
  | Some checkpoint ->
      State.best_known_head_for_checkpoint chain_state checkpoint
      >>= fun new_head ->
      Chain.set_head chain_state new_head
      >>= fun _ -> State.Chain.set_checkpoint chain_state checkpoint

let test_note_may_update_checkpoint s =
  (* set checkpoint at (2l, A2) *)
  let block = vblock s "A2" in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  (* set new checkpoint at (3l, A3) *)
  let block = vblock s "A3" in
  let checkpoint = State.Block.header block in
  note_may_update_checkpoint s.chain (Some checkpoint)
  >>= fun () -> return_unit

(****************************************************************************)

let tests : (string * (state -> unit tzresult Lwt.t)) list =
  [ ("basic checkpoint", test_basic_checkpoint);
    ("is valid checkpoint", test_is_valid_checkpoint);
    ("acceptable block", test_acceptable_block);
    ("best know head", test_best_know_head_for_checkpoint);
    ("future checkpoint", test_future_checkpoint);
    ("future checkpoint bad/good block", test_future_checkpoint_bad_good_block);
    ("test_reach_checkpoint", test_reach_checkpoint);
    ("update checkpoint", test_may_update_checkpoint);
    ("update checkpoint in node", test_note_may_update_checkpoint) ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
          wrap_state_init f dir
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error error ->
              Format.kasprintf Pervasives.failwith "%a" pp_print_error error))

let tests = List.map wrap tests
src/lib_shell/test/test_state_checkpoint.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Tezos_base__TzPervasives.Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Tezos_base__TzPervasives.Time.Protocol.of_seconds 0.

Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
  match Tezos_protocol_updater.Registered_protocol.get genesis_protocol with
  | None => false
  | Some proto => proto
  end.

Definition genesis : Tezos_shell.State.Chain.genesis :=
  {| time := genesis_time; block := genesis_block; protocol := genesis_protocol
    |}.

Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
  let new_fitness :=
    match fitness with
    | cons fitness [] =>
      Stdlib.Pervasives.op_pipe_gt
        (Stdlib.Pervasives.op_pipe_gt
          (Stdlib.Pervasives.op_pipe_gt
            (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
              Tezos_base__TzPervasives.Data_encoding.int64 fitness)
            (Tezos_base__TzPervasives.Option.unopt 0)) Stdlib.Int64.succ)
        (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_base__TzPervasives.Data_encoding.int64)
    | _ =>
      Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
        Tezos_base__TzPervasives.Data_encoding.int64 1
    end in
  cons new_fitness [].

Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  : Tezos_base__TzPervasives.Time.Protocol.t :=
  Tezos_base__TzPervasives.Time.Protocol.add timestamp
    (Stdlib.Int64.add 1 (Stdlib.Random.int64 10)).

Definition operation (op : string)
  : Tezos_crypto.Operation_hash.t * Tezos_base__TzPervasives.Operation.t *
    (option Stdlib.Bytes.t) :=
  let op :=
    {| shell := {| branch := genesis_block |};
      proto := Stdlib.Bytes.of_string op |} in
  ((Tezos_base__TzPervasives.Operation.hash op), op,
    (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes
      Tezos_base__TzPervasives.Operation.encoding op)).

Definition block_header_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding string :=
  Tezos_base__TzPervasives.Data_encoding.obj1
    (Tezos_base__TzPervasives.Data_encoding.req None None
      "proto_block_header" % string
      Tezos_base__TzPervasives.Data_encoding.string).

Definition block {A : Type}
  (_state : A)
  (op_star_o_p_t_star : option Tezos_base__TzPervasives.Context_hash.t)
  : (option (list Tezos_base__TzPervasives.Operation_list_hash.elt)) ->
    Tezos_shell.State.Block.t ->
      string -> Tezos_base__TzPervasives.Block_header.t :=
  let context :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_base__TzPervasives.Context_hash.zero
    end in
  fun op_star_o_p_t_star =>
    let operations :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun pred =>
      fun name =>
        let operations_hash :=
          Tezos_base__TzPervasives.Operation_list_list_hash.compute
            (cons
              (Tezos_base__TzPervasives.Operation_list_hash.compute operations)
              []) in
        let pred_header := Tezos_shell.State.Block.shell_header pred in
        let fitness := incr_fitness (fitness pred_header) in
        let timestamp := incr_timestamp (timestamp pred_header) in
        let protocol_data :=
          Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
            block_header_data_encoding name in
        {|
          shell :=
            {| level := Stdlib.Int32.succ (level pred_header);
              proto_level := proto_level pred_header;
              predecessor := Tezos_shell.State.Block.hash pred;
              timestamp := timestamp; validation_passes := 1;
              operations_hash := operations_hash; fitness := fitness;
              context := context |}; protocol_data := protocol_data |}.

Definition parsed_block
  (function_parameter : Tezos_base__TzPervasives.Block_header.t)
  : Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header) :=
  match function_parameter with
  | {| shell := shell; protocol_data := protocol_data |} =>
    let protocol_data :=
      Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
        Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
        protocol_data in
    {| shell := shell; protocol_data := protocol_data |}
  end.

Definition zero : string := Stdlib.Bytes.create 0.

Definition block_header_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding string :=
  Tezos_base__TzPervasives.Data_encoding.obj1
    (Tezos_base__TzPervasives.Data_encoding.req None None
      "proto_block_header" % string
      Tezos_base__TzPervasives.Data_encoding.string).

Definition build_valid_chain
  (state : Tezos_shell__State.Chain.t)
  (vtbl : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t)
  (pred : Tezos_shell.State.Block.t) (names : list string) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Lwt_list.fold_left_s
      (fun pred =>
        fun name =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.State.Block.context_exn pred)
            (fun predecessor_context =>
              let max_trials := 100 in
              let fix attempt
                (trials : Z) (context :
                option Tezos_base__TzPervasives.Context_hash.t)
                : Lwt.t Tezos_shell.State.Block.t :=
                Tezos_base__TzPervasives.op_gt_gt_eq
                  match operation name with
                  | (oph, op, _bytes) =>
                    let block :=
                      block state context (Some (cons oph [])) pred name in
                    let hash := Tezos_base__TzPervasives.Block_header.hash block
                      in
                    let pred_header := Tezos_shell.State.Block.header pred in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (let predecessor_context :=
                        Tezos_shell_context.Shell_context.wrap_disk_context
                          predecessor_context in
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Proto.(Tezos_protocol_updater__Registered_protocol.T.begin_application)
                          Tezos_base__TzPervasives.Chain_id.zero
                          predecessor_context (timestamp (shell pred_header))
                          (fitness (shell pred_header)) (parsed_block block))
                        (fun vstate =>
                          Proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
                            vstate))
                      (fun function_parameter =>
                        match function_parameter with
                        | (result, _metadata) =>
                          let context :=
                            Tezos_shell_context.Shell_context.unwrap_disk_context
                              (context result) in
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_storage.Context.commit
                              (Tezos_base__TzPervasives.Time.System.to_protocol
                                (Tezos_stdlib_unix.Systime_os.now tt))
                              (message result) context)
                            (fun context_hash =>
                              let validation_store :=
                                {| context_hash := context_hash;
                                  message := message result;
                                  max_operations_ttl :=
                                    max_operations_ttl result;
                                  last_allowed_fork_level :=
                                    last_allowed_fork_level result |} in
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_shell.State.Block.store None state block
                                  zero (cons (cons op []) [])
                                  (cons (cons zero []) []) validation_store
                                  false)
                                (fun _vblock =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_shell.State.Block.read state hash)
                                    (fun vblock =>
                                      Stdlib.Hashtbl.add vtbl name vblock;
                                      Tezos_base__TzPervasives._return vblock)))
                        end)
                  end
                  (fun function_parameter =>
                    match function_parameter with
                    | inl v =>
                      if OCaml.Stdlib.lt trials max_trials then
                        Stdlib.Format.eprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Took " % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.String_literal
                                  " trials to build valid chain" % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Took %d trials to build valid chain" % string)
                          (Z.add (Z.sub max_trials trials) 1)
                      else
                        tt;
                      Lwt._return v
                    | inr (cons (Validation_errors.Inconsistent_hash got _) _)
                      =>
                      if OCaml.Stdlib.le trials 0 then
                        false
                      else
                        Stdlib.Format.eprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Inconsistent context hash: got " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  ", retrying (" % string
                                  (CamlinternalFormatBasics.Int
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.String_literal
                                      ")
" % string
                                      CamlinternalFormatBasics.End_of_format)))))
                            "Inconsistent context hash: got %a, retrying (%d)
"
                              % string) Tezos_base__TzPervasives.Context_hash.pp
                          got trials;
                        attempt (Z.sub trials 1) (Some got)
                    | inr err =>
                      Stdlib.Format.eprintf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Error: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal
                                "010" % char
                                CamlinternalFormatBasics.End_of_format)))
                          "Error: %a
" % string)
                        Tezos_base__TzPervasives.Error_monad.pp_print_error err;
                      false
                    end) in
              attempt max_trials None)) pred names)
    (fun function_parameter =>
      match function_parameter with
      | _ => Lwt.return_unit
      end).

Record state := {
  vblock : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t;
  state : Tezos_shell.State.t;
  chain : Tezos_shell.State.Chain.t }.

Definition vblock (s : state) : string -> Tezos_shell.State.Block.t :=
  Stdlib.Hashtbl.find (vblock s).

Definition vblocks (s : state) : list (string * Tezos_shell.State.Block.t) :=
  OCaml.Stdlib.reverse_apply
    (Stdlib.Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc)
      (vblock s) [])
    (Tezos_base__TzPervasives.List.sort Stdlib.Pervasives.compare).

Definition build_example_tree (chain : Tezos_shell.State.Chain.t)
  : Lwt.t (Stdlib.Hashtbl.t string Tezos_shell.State.Block.t) :=
  let vtbl := Stdlib.Hashtbl.create None 23 in
  Tezos_base__TzPervasives.op_gt_gt_eq (Tezos_shell.Chain.genesis chain)
    (fun genesis =>
      Stdlib.Hashtbl.add vtbl "Genesis" % string genesis;
      let c :=
        cons "A1" % string
          (cons "A2" % string
            (cons "A3" % string (cons "A4" % string (cons "A5" % string []))))
        in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (build_valid_chain chain vtbl genesis c)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let a2 := Stdlib.Hashtbl.find vtbl "A2" % string in
            let c :=
              cons "B1" % string
                (cons "B2" % string
                  (cons "B3" % string
                    (cons "B4" % string (cons "B5" % string [])))) in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (build_valid_chain chain vtbl a2 c)
              (fun function_parameter =>
                match function_parameter with
                | tt => Lwt._return vtbl
                end)
          end)).

Definition wrap_state_init
  (f : state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (base_dir : string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let store_root := op_div_div base_dir "store" % string in
  let context_root := op_div_div base_dir "context" % string in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.State.init None None (Some 4096000000) (Some 4096000000)
      store_root context_root None genesis)
    (fun function_parameter =>
      match function_parameter with
      | (state, chain, _index, _history_mode) =>
        Tezos_base__TzPervasives.op_gt_gt_eq (build_example_tree chain)
          (fun vblock =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (f {| vblock := vblock; state := state; chain := chain |})
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives.return_unit
                end))
      end).

Definition test_basic_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A1" % string in
  let header := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.checkpoint (chain s))
          (fun checkpoint_header =>
            let c_level := level (shell checkpoint_header) in
            let c_block :=
              Tezos_base__TzPervasives.Block_header.hash checkpoint_header in
            if
              andb
                (negb
                  (Tezos_base__TzPervasives.Block_hash.equal c_block
                    (Tezos_shell.State.Block.hash block)))
                (Stdlib.Int32.equal c_level
                  (Tezos_shell.State.Block.level block)) then
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                "unexpected checkpoint" % string
            else
              Tezos_base__TzPervasives.return_unit)
      end).

Definition test_acceptable_block (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let header := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let block_1 := vblock s "A1" % string in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_shell.Chain.set_head (chain s) block_1)
          (fun head =>
            let header := Tezos_shell.State.Block.header head in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Chain.acceptable_block (chain s) header)
              (fun is_accepted_block =>
                if is_accepted_block then
                  Tezos_base__TzPervasives.return_unit
                else
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "unacceptable block" % string))
      end).

Definition test_is_valid_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let header := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.checkpoint (chain s))
          (fun checkpoint_header =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Block.is_valid_for_checkpoint
                (vblock s "B3" % string) checkpoint_header)
              (fun is_valid =>
                if is_valid then
                  Tezos_base__TzPervasives.return_unit
                else
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "invalid checkpoint" % string))
      end).

Definition test_best_know_head_for_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let checkpoint := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) checkpoint)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Chain.set_head (chain s) (vblock s "B3" % string))
          (fun _head =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.best_known_head_for_checkpoint (chain s)
                checkpoint) (fun _block => Tezos_base__TzPervasives.return_unit))
      end).

Definition test_future_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let block_hash := Tezos_shell.State.Block.hash block in
  let level := Tezos_shell.State.Block.level block in
  let header := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.checkpoint (chain s))
          (fun checkpoint_header =>
            let c_level := level (shell checkpoint_header) in
            let c_block :=
              Tezos_base__TzPervasives.Block_header.hash checkpoint_header in
            if
              andb (Stdlib.Int32.equal c_level level)
                (negb
                  (Tezos_base__TzPervasives.Block_hash.equal c_block block_hash))
              then
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                "unexpected checkpoint" % string
            else
              Tezos_base__TzPervasives.return_unit)
      end).

Definition test_future_checkpoint_bad_good_block (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A5" % string in
  let block_hash := Tezos_shell.State.Block.hash block in
  let level := Tezos_shell.State.Block.level block in
  let header := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.checkpoint (chain s))
          (fun checkpoint_header =>
            let c_level := level (shell checkpoint_header) in
            let c_block :=
              Tezos_base__TzPervasives.Block_header.hash checkpoint_header in
            if
              andb (Stdlib.Int32.equal c_level level)
                (negb
                  (Tezos_base__TzPervasives.Block_hash.equal c_block block_hash))
              then
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                "unexpected checkpoint" % string
            else
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.State.Block.is_valid_for_checkpoint
                  (vblock s "B2" % string) checkpoint_header)
                (fun is_valid =>
                  if is_valid then
                    Tezos_base__TzPervasives.return_unit
                  else
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      "invalid checkpoint" % string))
      end).

Definition test_reach_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let mem (s : state) (x : string) : Lwt.t bool :=
    Tezos_shell.Chain.mem (chain s)
      (apply Tezos_shell.State.Block.hash (vblock s x)) in
  let test_mem (s : state) (x : string) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq (mem s x)
      (fun function_parameter =>
        match function_parameter with
        | true => Lwt.return_unit
        | false => op_star_t_y_p_e_minus_e_r_r_o_r_star "mem %s" % string x
        end) in
  let test_not_mem (s : state) (x : string) : Lwt.t unit :=
    Tezos_base__TzPervasives.op_gt_gt_eq (mem s x)
      (fun function_parameter =>
        match function_parameter with
        | false => Lwt.return_unit
        | true => op_star_t_y_p_e_minus_e_r_r_o_r_star "not (mem %s)" % string x
        end) in
  let block := vblock s "A1" % string in
  let block_hash := Tezos_shell.State.Block.hash block in
  let header := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.checkpoint (chain s))
          (fun checkpoint_header =>
            let time_now :=
              Tezos_base__TzPervasives.Time.System.to_protocol
                (Tezos_stdlib_unix.Systime_os.now tt) in
            if
              OCaml.Stdlib.ge
                (Tezos_base__TzPervasives.Time.Protocol.compare
                  (Tezos_base__TzPervasives.Time.Protocol.add time_now 15)
                  (timestamp (shell header))) 0 then
              let checkpoint_hash :=
                Tezos_base__TzPervasives.Block_header.hash checkpoint_header in
              if
                andb
                  (Stdlib.Int32.equal (level (shell header))
                    (level (shell checkpoint_header)))
                  (negb
                    (Tezos_base__TzPervasives.Block_hash.equal checkpoint_hash
                      block_hash)) then
                op_star_t_y_p_e_minus_e_r_r_o_r_star "checkpoint error" % string
              else
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Chain.set_head (chain s) (vblock s "A2" % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_shell.Chain.head (chain s))
                        (fun head =>
                          let checkpoint_reached :=
                            OCaml.Stdlib.ge
                              (level
                                (shell (Tezos_shell.State.Block.header head)))
                              (level (shell checkpoint_header)) in
                          if checkpoint_reached then
                            if
                              OCaml.Stdlib.le (level (shell header))
                                (level (shell checkpoint_header)) then
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (test_mem s "Genesis" % string)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (test_mem s "A1" % string)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (test_mem s "A2" % string)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                  (test_not_mem s "A3" % string)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (test_not_mem s
                                                          "B1" % string)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)
                                                    end)
                                              end)
                                        end)
                                  end)
                            else
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                "checkpoint error" % string
                          else
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              "checkpoint error" % string)
                    end)
            else
              op_star_t_y_p_e_minus_e_r_r_o_r_star
                "fail future block header" % string)
      end).

Definition may_update_checkpoint
  (chain_state : Tezos_shell.State.Chain.chain_state)
  (new_head : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.checkpoint chain_state)
    (fun checkpoint_header =>
      let old_level := level (shell checkpoint_header) in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell.State.Block.last_allowed_fork_level new_head)
        (fun new_level =>
          if OCaml.Stdlib.le new_level old_level then
            Tezos_base__TzPervasives.return_unit
          else
            let head_level := Tezos_shell.State.Block.level new_head in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_shell.State.Block.predecessor_n new_head
                (Stdlib.Int32.to_int (Stdlib.Int32.sub head_level new_level)))
              (fun function_parameter =>
                match function_parameter with
                | None =>
                  apply Tezos_base__TzPervasives._return
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      "Unexpected None in predecessor query" % string)
                | Some hash =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_shell.State.Block.read_opt chain_state hash)
                    (fun function_parameter =>
                      match function_parameter with
                      | None => false
                      | Some b =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_shell.State.Chain.set_checkpoint chain_state
                            (Tezos_shell.State.Block.header b))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_unit
                            end)
                      end)
                end))).

Definition test_may_update_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A3" % string in
  let checkpoint := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) checkpoint)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.State.Chain.checkpoint (chain s))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Chain.set_head (chain s) (vblock s "A4" % string))
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.Chain.head (chain s))
                      (fun head =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (may_update_checkpoint (chain s) head)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives._return tt
                            end))
                  end)
            end)
      end).

Definition note_may_update_checkpoint
  (chain_state : Tezos_shell.State.Chain.t)
  (checkpoint : option Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
  match checkpoint with
  | None => Lwt.return_unit
  | Some checkpoint =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell.State.best_known_head_for_checkpoint chain_state checkpoint)
      (fun new_head =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_shell.Chain.set_head chain_state new_head)
          (fun function_parameter =>
            match function_parameter with
            | _ => Tezos_shell.State.Chain.set_checkpoint chain_state checkpoint
            end))
  end.

Definition test_note_may_update_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let header := Tezos_shell.State.Block.header block in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell.State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let block := vblock s "A3" % string in
        let checkpoint := Tezos_shell.State.Block.header block in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (note_may_update_checkpoint (chain s) (Some checkpoint))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition tests
  : list (string * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  cons ("basic checkpoint" % string, test_basic_checkpoint)
    (cons ("is valid checkpoint" % string, test_is_valid_checkpoint)
      (cons ("acceptable block" % string, test_acceptable_block)
        (cons ("best know head" % string, test_best_know_head_for_checkpoint)
          (cons ("future checkpoint" % string, test_future_checkpoint)
            (cons
              ("future checkpoint bad/good block" % string,
                test_future_checkpoint_bad_good_block)
              (cons ("test_reach_checkpoint" % string, test_reach_checkpoint)
                (cons ("update checkpoint" % string, test_may_update_checkpoint)
                  (cons
                    ("update checkpoint in node" % string,
                      test_note_may_update_checkpoint) [])))))))).

Definition wrap {A B : Type}
  (function_parameter :
    A * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) : B :=
  match function_parameter with
  | (n, f) =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir
                "tezos_test_" % string
                (fun dir =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (wrap_state_init f dir)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl tt => Lwt.return_unit
                      | inr error =>
                        Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string)
                          Tezos_base__TzPervasives.pp_print_error error
                      end))
            end
        end)
  end.

Definition tests {A : Type} : list A :=
  Tezos_base__TzPervasives.List.map wrap tests.
src/lib_shell/test/test_store.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Store

let ( >>= ) = Lwt.bind

let ( >|= ) = Lwt.( >|= )

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

(** *)

let mapsize = 4_096_000_000L (* ~4 GiB *)

let wrap_store_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "store" in
      Store.init ~mapsize root
      >>= function
      | Ok store ->
          Lwt.finalize
            (fun () -> f store)
            (fun () -> Store.close store ; Lwt.return_unit)
      | Error err ->
          Format.kasprintf
            Pervasives.failwith
            "@[Cannot initialize store:@ %a@]"
            pp_print_error
            err)

let wrap_raw_store_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "store" in
      Raw_store.init ~mapsize root
      >>= function
      | Ok store ->
          Lwt.finalize
            (fun () -> f store)
            (fun () -> Raw_store.close store ; Lwt.return_unit)
      | Error err ->
          Format.kasprintf
            Pervasives.failwith
            "@[Cannot initialize store:@ %a@]"
            pp_print_error
            err)

let test_init _ = Lwt.return_unit

let chain_id = Chain_id.of_block_hash genesis_block

(** Operation store *)

let make proto : Operation.t = {shell = {branch = genesis_block}; proto}

let op1 = make (Bytes.of_string "Capadoce")

let oph1 = Operation.hash op1

let op2 = make (Bytes.of_string "Kivu")

let oph2 = Operation.hash op2

(** Block store *)

let lolblock ?(operations = []) header =
  let operations_hash =
    Operation_list_list_hash.compute [Operation_list_hash.compute operations]
  in
  let block_header =
    {
      Block_header.shell =
        {
          timestamp = Time.Protocol.of_seconds (Random.int64 1500L);
          level = 0l;
          (* dummy *)
          proto_level = 0;
          (* dummy *)
          validation_passes = Random.int 32;
          predecessor = genesis_block;
          operations_hash;
          fitness =
            [ Bytes.of_string @@ string_of_int @@ String.length header;
              Bytes.of_string @@ string_of_int @@ 12 ];
          context = Context_hash.zero;
        };
      protocol_data = Bytes.of_string header;
    }
  in
  let block_contents =
    {
      header = block_header;
      Store.Block.metadata = Bytes.create 0;
      max_operations_ttl = 0;
      message = None;
      context = Context_hash.zero;
      last_allowed_fork_level = 0l;
    }
  in
  (block_header, block_contents)

let ((b1_header, b1_contents) as b1) = lolblock "Blop !"

let bh1 = Block_header.hash b1_header

let ((b2_header, b2_contents) as b2) = lolblock "Tacatlopo"

let bh2 = Block_header.hash b2_header

let ((b3_header, b3_contents) as b3) =
  lolblock ~operations:[oph1; oph2] "Persil"

let bh3 = Block_header.hash b3_header

let bh3' =
  let raw = Bytes.of_string @@ Block_hash.to_string bh3 in
  Bytes.set raw 31 '\000' ;
  Bytes.set raw 30 '\000' ;
  Block_hash.of_string_exn @@ Bytes.to_string raw

let equal ((b1_header, b1_contents) : Block_header.t * Store.Block.contents)
    ((b2_header, b2_contents) : Block_header.t * Store.Block.contents) =
  Block_header.equal b1_header b2_header
  && b1_contents.message = b2_contents.message

let check_block s h b =
  Store.Block.Contents.read (s, h)
  >>= function
  | Ok bc' -> (
      Store.Block.Pruned_contents.read (s, h)
      >>= function
      | Ok {header} when equal b (header, bc') ->
          Lwt.return_unit
      | Ok _ ->
          Format.eprintf
            "Error while reading block %a\n%!"
            Block_hash.pp_short
            h ;
          exit 1
      | Error err ->
          Format.eprintf
            "@[Error while reading block header %a:@ %a\n@]"
            Block_hash.pp_short
            h
            pp_print_error
            err ;
          exit 1 )
  | Error err ->
      Format.eprintf
        "@[Error while reading block %a:@ %a\n@]"
        Block_hash.pp_short
        h
        pp_print_error
        err ;
      exit 1

let test_block s =
  let s = Store.Chain.get s chain_id in
  let s = Store.Block.get s in
  Block.Contents.store (s, bh1) b1_contents
  >>= fun () ->
  Block.Contents.store (s, bh2) b2_contents
  >>= fun () ->
  Block.Contents.store (s, bh3) b3_contents
  >>= fun () ->
  Block.Pruned_contents.store (s, bh1) {header = b1_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh2) {header = b2_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh3) {header = b3_header}
  >>= fun () ->
  check_block s bh1 b1
  >>= fun () -> check_block s bh2 b2 >>= fun () -> check_block s bh3 b3

let test_expand s =
  let s = Store.Chain.get s chain_id in
  let s = Store.Block.get s in
  Block.Contents.store (s, bh1) b1_contents
  >>= fun () ->
  Block.Contents.store (s, bh2) b2_contents
  >>= fun () ->
  Block.Contents.store (s, bh3) b3_contents
  >>= fun () ->
  Block.Contents.store (s, bh3') b3_contents
  >>= fun () ->
  Block.Pruned_contents.store (s, bh1) {header = b1_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh2) {header = b2_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh3) {header = b3_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh3') {header = b3_header}
  >>= fun () ->
  Base58.complete (Block_hash.to_short_b58check bh1)
  >>= fun res ->
  Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b58check bh1] ;
  Base58.complete (Block_hash.to_short_b58check bh2)
  >>= fun res ->
  Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b58check bh2] ;
  Base58.complete (Block_hash.to_short_b58check bh3)
  >>= fun res ->
  Assert.equal_string_list
    ~msg:__LOC__
    (List.sort String.compare res)
    [Block_hash.to_b58check bh3'; Block_hash.to_b58check bh3] ;
  Lwt.return_unit

(** Generic store *)

let check (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) k d =
  Store.read_opt s k
  >|= function
  | Some d' when Bytes.equal d d' ->
      ()
  | Some d' ->
      Assert.fail_msg
        ~expected:(Bytes.to_string d)
        ~given:(Bytes.to_string d')
        "Error while reading key %d %S\n%!"
        Bytes.(compare d d')
        (String.concat Filename.dir_sep k)
  | None ->
      Assert.fail_msg
        ~expected:(Bytes.to_string d)
        ~given:""
        "Error while reading key %S\n%!"
        (String.concat Filename.dir_sep k)

let check_none (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) k =
  Store.read_opt s k
  >|= function
  | None ->
      ()
  | Some _ ->
      Assert.fail_msg
        "Error while reading non-existent key %S\n%!"
        (String.concat Filename.dir_sep k)

let test_generic (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  Store.store s ["day"; "current"] (Bytes.of_string "Mercredi")
  >>= fun () ->
  Store.store s ["day"; "next"] (Bytes.of_string "Jeudi")
  >>= fun () ->
  Store.store s ["day"; "truc"; "chose"] (Bytes.of_string "Vendredi")
  >>= fun () ->
  check (module Store) s ["day"; "current"] (Bytes.of_string "Mercredi")
  >>= fun () ->
  check (module Store) s ["day"; "next"] (Bytes.of_string "Jeudi")
  >>= fun () -> check_none (module Store) s ["day"]

let list (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) k =
  Store.keys s k

let test_generic_list (type t)
    (module Store : Store_sigs.STORE with type t = t) (s : Store.t) =
  Store.store s ["a"; "b"] (Bytes.of_string "Novembre")
  >>= fun () ->
  Store.store s ["a"; "c"] (Bytes.of_string "Juin")
  >>= fun () ->
  Store.store s ["a"; "d"; "e"] (Bytes.of_string "Septembre")
  >>= fun () ->
  Store.store s ["f"] (Bytes.of_string "Avril")
  >>= fun () ->
  Store.store s ["g"; "h"] (Bytes.of_string "Avril")
  >>= fun () ->
  list (module Store) s []
  >>= fun l ->
  Assert.equal_string_list_list
    ~msg:__LOC__
    [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
    (List.sort compare l) ;
  list (module Store) s ["a"]
  >>= fun l ->
  Assert.equal_string_list_list
    ~msg:__LOC__
    [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
    (List.sort compare l) ;
  list (module Store) s ["f"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [] l ;
  list (module Store) s ["g"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] (List.sort compare l) ;
  list (module Store) s ["i"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [] l ;
  Lwt.return_unit

(** HashSet *)

open Store_helpers

let test_hashset (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  let module BlockSet = Block_hash.Set in
  let module StoreSet =
    Make_buffered_set
      (Make_substore
         (Store)
         (struct
           let name = ["test_set"]
         end))
         (Block_hash)
      (BlockSet)
  in
  let bhset = BlockSet.(add bh2 (add bh1 empty)) in
  StoreSet.store_all s bhset
  >>= fun () ->
  StoreSet.read_all s
  >>= fun bhset' ->
  Assert.equal_block_set ~msg:__LOC__ bhset bhset' ;
  let bhset2 = BlockSet.(bhset |> add bh3 |> remove bh1) in
  StoreSet.store_all s bhset2
  >>= fun () ->
  StoreSet.read_all s
  >>= fun bhset2' ->
  Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2' ;
  StoreSet.fold s ~init:BlockSet.empty ~f:(fun bh acc ->
      Lwt.return (BlockSet.add bh acc))
  >>= fun bhset2'' ->
  Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2'' ;
  Store.store s ["day"; "current"] (Bytes.of_string "Mercredi")
  >>= fun () ->
  StoreSet.remove_all s
  >>= fun () ->
  StoreSet.read_all s
  >>= fun empty ->
  Assert.equal_block_set ~msg:__LOC__ BlockSet.empty empty ;
  check (module Store) s ["day"; "current"] (Bytes.of_string "Mercredi")
  >>= fun () -> Lwt.return_unit

(** HashMap *)

let test_hashmap (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  let module BlockMap = Block_hash.Map in
  let module StoreMap =
    Make_buffered_map
      (Make_substore
         (Store)
         (struct
           let name = ["test_map"]
         end))
         (Block_hash)
      (Make_value (struct
        type t = int * char

        let encoding =
          Data_encoding.(tup2 int31 (conv int_of_char char_of_int int8))
      end))
      (BlockMap)
  in
  let eq = ( = ) in
  let map = BlockMap.(empty |> add bh1 (1, 'a') |> add bh2 (2, 'b')) in
  StoreMap.store_all s map
  >>= fun () ->
  StoreMap.read_all s
  >>= fun map' ->
  Assert.equal_block_map ~msg:__LOC__ ~eq map map' ;
  let map2 = map |> BlockMap.add bh3 (3, 'c') |> BlockMap.remove bh1 in
  StoreMap.store_all s map2
  >>= fun () ->
  StoreMap.read_all s
  >>= fun map2' ->
  Assert.equal_block_map ~msg:__LOC__ ~eq map2 map2' ;
  Lwt.return_unit

(** Functors *)

let test_single (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  let module Single =
    Make_single_store
      (Store)
      (struct
        let name = ["plop"]
      end)
      (Make_value (struct
        type t = int * string

        let encoding = Data_encoding.(tup2 int31 string)
      end))
  in
  Single.known s
  >>= fun known ->
  Assert.is_false ~msg:__LOC__ known ;
  Single.read_opt s
  >>= fun v' ->
  Assert.equal ~msg:__LOC__ None v' ;
  let v = (3, "Non!") in
  Single.store s v
  >>= fun () ->
  Single.known s
  >>= fun known ->
  Assert.is_true ~msg:__LOC__ known ;
  Single.read_opt s
  >>= fun v' ->
  Assert.equal ~msg:__LOC__ (Some v) v' ;
  Single.remove s
  >>= fun () ->
  Single.known s
  >>= fun known ->
  Assert.is_false ~msg:__LOC__ known ;
  Single.read_opt s
  >>= fun v' ->
  Assert.equal ~msg:__LOC__ None v' ;
  Lwt.return_unit

module Sub =
  Make_substore
    (Raw_store)
    (struct
      let name = ["plop"; "plip"]
    end)

module SubBlocks =
  Make_indexed_substore
    (Make_substore
       (Raw_store)
       (struct
         let name = ["blocks"]
       end))
       (Block_hash)

module SubBlocksSet =
  SubBlocks.Make_buffered_set
    (struct
      let name = ["test_set"]
    end)
    (Block_hash.Set)

module SubBlocksMap =
  SubBlocks.Make_buffered_map
    (struct
      let name = ["test_map"]
    end)
    (Make_value (struct
      type t = int * string

      let encoding = Data_encoding.(tup2 int31 string)
    end))
    (Block_hash.Map)

let test_subblock s =
  SubBlocksSet.known s bh1
  >>= fun known ->
  Assert.is_false ~msg:__LOC__ known ;
  SubBlocksSet.store s bh1
  >>= fun () ->
  SubBlocksSet.store s bh2
  >>= fun () ->
  SubBlocksSet.known s bh2
  >>= fun known ->
  Assert.is_true ~msg:__LOC__ known ;
  SubBlocksSet.read_all s
  >>= fun set ->
  let set' = Block_hash.Set.(empty |> add bh1 |> add bh2) in
  Assert.equal_block_set ~msg:__LOC__ set set' ;
  SubBlocksSet.remove s bh2
  >>= fun () ->
  let set = Block_hash.Set.(empty |> add bh3' |> add bh3) in
  SubBlocksSet.store_all s set
  >>= fun () ->
  SubBlocksSet.elements s
  >>= fun elts ->
  Assert.equal_block_hash_list
    ~msg:__LOC__
    (List.sort Block_hash.compare elts)
    (List.sort Block_hash.compare [bh3; bh3']) ;
  SubBlocksSet.store s bh2
  >>= fun () ->
  SubBlocksSet.remove s bh3
  >>= fun () ->
  SubBlocksSet.elements s
  >>= fun elts ->
  Assert.equal_block_hash_list
    ~msg:__LOC__
    (List.sort Block_hash.compare elts)
    (List.sort Block_hash.compare [bh2; bh3']) ;
  SubBlocksMap.known s bh1
  >>= fun known ->
  Assert.is_false ~msg:__LOC__ known ;
  let v1 = (3, "Non!") and v2 = (12, "Beurk.") in
  SubBlocksMap.store s bh1 v1
  >>= fun () ->
  SubBlocksMap.store s bh2 v2
  >>= fun () ->
  SubBlocksMap.known s bh1
  >>= fun known ->
  SubBlocksMap.read_opt s bh1
  >>= fun v1' ->
  Assert.equal ~msg:__LOC__ (Some v1) v1' ;
  Assert.is_true ~msg:__LOC__ known ;
  let map = Block_hash.Map.(empty |> add bh1 v1 |> add bh2 v2) in
  SubBlocksMap.read_all s
  >>= fun map' ->
  Assert.equal_block_map ~eq:( = ) ~msg:__LOC__ map map' ;
  SubBlocksSet.remove_all s
  >>= fun () ->
  SubBlocksSet.elements s
  >>= fun elts ->
  Assert.equal_block_hash_list ~msg:__LOC__ elts [] ;
  SubBlocksMap.read_all s
  >>= fun map' ->
  Assert.equal_block_map ~eq:( = ) ~msg:__LOC__ map map' ;
  SubBlocksSet.store s bh3
  >>= fun () ->
  SubBlocks.indexes s
  >>= fun keys ->
  Assert.equal_block_hash_list
    ~msg:__LOC__
    (List.sort Block_hash.compare keys)
    (List.sort Block_hash.compare [bh1; bh2; bh3]) ;
  Lwt.return_unit

module SubSubBlocks =
  Make_indexed_substore
    (Make_substore
       (SubBlocks.Store)
       (struct
         let name = ["sub_blocks"]
       end))
       (Block_hash)

(** *)

let tests_raw : (string * (Raw_store.t -> unit Lwt.t)) list =
  [ ("init", test_init);
    ("generic", test_generic (module Raw_store));
    ("generic_substore", test_generic (module Sub));
    ( "generic_indexedstore",
      fun s -> test_generic (module SubBlocks.Store) (s, bh1) );
    ( "generic_indexedsubstore",
      fun s -> test_generic (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("single", test_single (module Raw_store));
    ("single_substore", test_single (module Sub));
    ( "single_indexedstore",
      fun s -> test_single (module SubBlocks.Store) (s, bh1) );
    ( "single_indexedsubstore",
      fun s -> test_single (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("generic_list", test_generic_list (module Raw_store));
    ("generic_substore_list", test_generic_list (module Sub));
    ( "generic_indexedstore_list",
      fun s -> test_generic_list (module SubBlocks.Store) (s, bh1) );
    ( "generic_indexedsubstore_list",
      fun s -> test_generic_list (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("hashset", test_hashset (module Raw_store));
    ("hashset_substore", test_hashset (module Sub));
    ( "hashset_indexedstore",
      fun s -> test_hashset (module SubBlocks.Store) (s, bh1) );
    ( "hashset_indexedsubstore",
      fun s -> test_hashset (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("hashmap", test_hashmap (module Raw_store));
    ("hashmap_substore", test_hashmap (module Sub));
    ( "hashmap_indexedstore",
      fun s -> test_hashmap (module SubBlocks.Store) (s, bh1) );
    ( "hashmap_indexedsubstore",
      fun s -> test_hashmap (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("subblock", test_subblock) ]

let tests : (string * (Store.t -> unit Lwt.t)) list =
  [("expand", test_expand); ("block", test_block)]

let tests =
  List.map
    (fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_raw_store_init f))
    tests_raw
  @ List.map
      (fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_store_init f))
      tests
src/lib_shell/test/test_store.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell.Store.

Definition op_gt_gt_eq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.bind.

Definition op_gt_pipe_eq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
  Lwt.op_gt_pipe_eq.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Tezos_base__TzPervasives.Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Tezos_base__TzPervasives.Time.Protocol.of_seconds 0.

Definition mapsize : int64 := 4096000000.

Definition wrap_store_init {A B : Type}
  (f : Tezos_shell.Store.t -> Lwt.t A) (function_parameter : B)
  : unit -> Lwt.t A :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir "tezos_test_" % string
          (fun base_dir =>
            let root := op_div_div base_dir "store" % string in
            op_gt_gt_eq (Tezos_shell.Store.init None (Some mapsize) root)
              (fun function_parameter =>
                match function_parameter with
                | inl store =>
                  Lwt.finalize
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => f store
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_shell.Store.close store;
                        Lwt.return_unit
                      end)
                | inr err =>
                  Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Cannot initialize store:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Cannot initialize store:@ %a@]" % string)
                    Tezos_base__TzPervasives.pp_print_error err
                end))
      end
  end.

Definition wrap_raw_store_init {A B : Type}
  (f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
  : unit -> Lwt.t A :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir "tezos_test_" % string
          (fun base_dir =>
            let root := op_div_div base_dir "store" % string in
            op_gt_gt_eq (Tezos_storage.Raw_store.init None (Some mapsize) root)
              (fun function_parameter =>
                match function_parameter with
                | inl store =>
                  Lwt.finalize
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => f store
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_storage.Raw_store.close store;
                        Lwt.return_unit
                      end)
                | inr err =>
                  Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Cannot initialize store:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Cannot initialize store:@ %a@]" % string)
                    Tezos_base__TzPervasives.pp_print_error err
                end))
      end
  end.

Definition test_init {A : Type} (function_parameter : A) : Lwt.t unit :=
  match function_parameter with
  | _ => Lwt.return_unit
  end.

Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
  Tezos_base__TzPervasives.Chain_id.of_block_hash genesis_block.

Definition make (proto : Stdlib.Bytes.t)
  : Tezos_base__TzPervasives.Operation.t :=
  {| shell := {| branch := genesis_block |}; proto := proto |}.

Definition op1 : Tezos_base__TzPervasives.Operation.t :=
  make (Stdlib.Bytes.of_string "Capadoce" % string).

Definition oph1 : Tezos_crypto.Operation_hash.t :=
  Tezos_base__TzPervasives.Operation.hash op1.

Definition op2 : Tezos_base__TzPervasives.Operation.t :=
  make (Stdlib.Bytes.of_string "Kivu" % string).

Definition oph2 : Tezos_crypto.Operation_hash.t :=
  Tezos_base__TzPervasives.Operation.hash op2.

Definition lolblock
  (op_star_o_p_t_star :
    option (list Tezos_base__TzPervasives.Operation_list_hash.elt))
  : string ->
    Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents :=
  let operations :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun header =>
    let operations_hash :=
      Tezos_base__TzPervasives.Operation_list_list_hash.compute
        (cons (Tezos_base__TzPervasives.Operation_list_hash.compute operations)
          []) in
    let block_header :=
      {|
        Block_header.shell :=
          {| level := 0; proto_level := 0; predecessor := genesis_block;
            timestamp :=
              Tezos_base__TzPervasives.Time.Protocol.of_seconds
                (Stdlib.Random.int64 1500);
            validation_passes := Stdlib.Random.int 32;
            operations_hash := operations_hash;
            fitness :=
              cons
                (apply Stdlib.Bytes.of_string
                  (apply OCaml.Stdlib.string_of_int
                    (Tezos_base__TzPervasives.String.length header)))
                (cons
                  (apply Stdlib.Bytes.of_string
                    (apply OCaml.Stdlib.string_of_int 12)) []);
            context := Tezos_base__TzPervasives.Context_hash.zero |};
        Block_header.protocol_data := Stdlib.Bytes.of_string header |} in
    let block_contents :=
      {| Store.Block.header := block_header; Store.Block.message := None;
        Store.Block.max_operations_ttl := 0;
        Store.Block.last_allowed_fork_level := 0;
        Store.Block.context := Tezos_base__TzPervasives.Context_hash.zero;
        Store.Block.metadata := Stdlib.Bytes.create 0 |} in
    (block_header, block_contents).

Definition bh1 : Tezos_crypto.Block_hash.t :=
  Tezos_base__TzPervasives.Block_header.hash b1_header.

Definition bh2 : Tezos_crypto.Block_hash.t :=
  Tezos_base__TzPervasives.Block_header.hash b2_header.

Definition bh3 : Tezos_crypto.Block_hash.t :=
  Tezos_base__TzPervasives.Block_header.hash b3_header.

Definition bh3' : Tezos_base__TzPervasives.Block_hash.t :=
  let raw :=
    apply Stdlib.Bytes.of_string
      (Tezos_base__TzPervasives.Block_hash.to_string bh3) in
  Stdlib.Bytes.set raw 31 "000" % char;
  Stdlib.Bytes.set raw 30 "000" % char;
  apply Tezos_base__TzPervasives.Block_hash.of_string_exn
    (Stdlib.Bytes.to_string raw).

Definition equal
  (function_parameter :
    Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
  : (Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
    -> bool :=
  match function_parameter with
  | (b1_header, b1_contents) =>
    fun function_parameter =>
      match function_parameter with
      | (b2_header, b2_contents) =>
        andb (Tezos_base__TzPervasives.Block_header.equal b1_header b2_header)
          (equiv_decb (message b1_contents) (message b2_contents))
      end
  end.

Definition check_block
  (s : Tezos_shell__Store.Block.store)
  (h : Tezos_base__TzPervasives.Block_hash.t)
  (b :
    Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
  : Lwt.t unit :=
  op_gt_gt_eq (Tezos_shell.Store.Block.Contents.read (s, h))
    (fun function_parameter =>
      match function_parameter with
      | inl bc' =>
        op_gt_gt_eq (Tezos_shell.Store.Block.Pruned_contents.read (s, h))
          (fun function_parameter =>
            match function_parameter with
            | inl {| header := header |} => Lwt.return_unit
            | inl _ =>
              Stdlib.Format.eprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Error while reading block " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Flush
                          CamlinternalFormatBasics.End_of_format))))
                  "Error while reading block %a
%!" % string)
                Tezos_base__TzPervasives.Block_hash.pp_short h;
              Stdlib.exit 1
            | inr err =>
              Stdlib.Format.eprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Error while reading block header " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal ":" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal
                                "010" % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format))))))))
                  "@[Error while reading block header %a:@ %a
@]" % string)
                Tezos_base__TzPervasives.Block_hash.pp_short h
                Tezos_base__TzPervasives.pp_print_error err;
              Stdlib.exit 1
            end)
      | inr err =>
        Stdlib.Format.eprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (CamlinternalFormatBasics.String_literal
                "Error while reading block " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ":" % char
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format))))))))
            "@[Error while reading block %a:@ %a
@]" % string)
          Tezos_base__TzPervasives.Block_hash.pp_short h
          Tezos_base__TzPervasives.pp_print_error err;
        Stdlib.exit 1
      end).

Definition test_block (s : Tezos_shell__Store.global_store) : Lwt.t unit :=
  let s := Tezos_shell.Store.Chain.get s chain_id in
  let s := Tezos_shell.Store.Block.get s in
  op_gt_gt_eq (Tezos_shell.Store.Block.Contents.store (s, bh1) b1_contents)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        op_gt_gt_eq
          (Tezos_shell.Store.Block.Contents.store (s, bh2) b2_contents)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              op_gt_gt_eq
                (Tezos_shell.Store.Block.Contents.store (s, bh3) b3_contents)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_gt_gt_eq
                      (Tezos_shell.Store.Block.Pruned_contents.store (s, bh1)
                        {| header := b1_header |})
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          op_gt_gt_eq
                            (Tezos_shell.Store.Block.Pruned_contents.store
                              (s, bh2) {| header := b2_header |})
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                op_gt_gt_eq
                                  (Tezos_shell.Store.Block.Pruned_contents.store
                                    (s, bh3) {| header := b3_header |})
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      op_gt_gt_eq (check_block s bh1 b1)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            op_gt_gt_eq (check_block s bh2 b2)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt => check_block s bh3 b3
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end).

Definition test_expand (s : Tezos_shell__Store.global_store) : Lwt.t unit :=
  let s := Tezos_shell.Store.Chain.get s chain_id in
  let s := Tezos_shell.Store.Block.get s in
  op_gt_gt_eq (Tezos_shell.Store.Block.Contents.store (s, bh1) b1_contents)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        op_gt_gt_eq
          (Tezos_shell.Store.Block.Contents.store (s, bh2) b2_contents)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              op_gt_gt_eq
                (Tezos_shell.Store.Block.Contents.store (s, bh3) b3_contents)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_gt_gt_eq
                      (Tezos_shell.Store.Block.Contents.store (s, bh3')
                        b3_contents)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          op_gt_gt_eq
                            (Tezos_shell.Store.Block.Pruned_contents.store
                              (s, bh1) {| header := b1_header |})
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                op_gt_gt_eq
                                  (Tezos_shell.Store.Block.Pruned_contents.store
                                    (s, bh2) {| header := b2_header |})
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      op_gt_gt_eq
                                        (Tezos_shell.Store.Block.Pruned_contents.store
                                          (s, bh3) {| header := b3_header |})
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            op_gt_gt_eq
                                              (Tezos_shell.Store.Block.Pruned_contents.store
                                                (s, bh3')
                                                {| header := b3_header |})
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  op_gt_gt_eq
                                                    (Tezos_base__TzPervasives.Base58.complete
                                                      None
                                                      (Tezos_base__TzPervasives.Block_hash.to_short_b58check
                                                        bh1))
                                                    (fun res =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Stdlib.__LOC__ res
                                                        (cons
                                                          (Tezos_base__TzPervasives.Block_hash.to_b58check
                                                            bh1) []);
                                                      op_gt_gt_eq
                                                        (Tezos_base__TzPervasives.Base58.complete
                                                          None
                                                          (Tezos_base__TzPervasives.Block_hash.to_short_b58check
                                                            bh2))
                                                        (fun res =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Stdlib.__LOC__ res
                                                            (cons
                                                              (Tezos_base__TzPervasives.Block_hash.to_b58check
                                                                bh2) []);
                                                          op_gt_gt_eq
                                                            (Tezos_base__TzPervasives.Base58.complete
                                                              None
                                                              (Tezos_base__TzPervasives.Block_hash.to_short_b58check
                                                                bh3))
                                                            (fun res =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                Stdlib.__LOC__
                                                                (Tezos_base__TzPervasives.List.sort
                                                                  Tezos_base__TzPervasives.String.compare
                                                                  res)
                                                                (cons
                                                                  (Tezos_base__TzPervasives.Block_hash.to_b58check
                                                                    bh3')
                                                                  (cons
                                                                    (Tezos_base__TzPervasives.Block_hash.to_b58check
                                                                      bh3) []));
                                                              Lwt.return_unit)))
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end).

Definition check {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> (list string) -> Stdlib.Bytes.t -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    fun k =>
      fun d =>
        op_gt_pipe_eq (Store.(Tezos_storage__Store_sigs.STORE.read_opt) s k)
          (fun function_parameter =>
            match function_parameter with
            | Some d' => tt
            | Some d' =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star (Stdlib.Bytes.to_string d)
                (Stdlib.Bytes.to_string d')
                "Error while reading key %d %S
%!" % string
                (Stdlib.Bytes.compare d d')
                (Tezos_base__TzPervasives.String.concat Stdlib.Filename.dir_sep
                  k)
            | None =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star (Stdlib.Bytes.to_string d)
                "" % string "Error while reading key %S
%!" % string
                (Tezos_base__TzPervasives.String.concat Stdlib.Filename.dir_sep
                  k)
            end).

Definition check_none {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> (list string) -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    fun k =>
      op_gt_pipe_eq (Store.(Tezos_storage__Store_sigs.STORE.read_opt) s k)
        (fun function_parameter =>
          match function_parameter with
          | None => tt
          | Some _ =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              "Error while reading non-existent key %S
%!" % string
              (Tezos_base__TzPervasives.String.concat Stdlib.Filename.dir_sep k)
          end).

Definition test_generic {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    op_gt_gt_eq
      (Store.(Tezos_storage__Store_sigs.STORE.store) s
        (cons "day" % string (cons "current" % string []))
        (Stdlib.Bytes.of_string "Mercredi" % string))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_gt_gt_eq
            (Store.(Tezos_storage__Store_sigs.STORE.store) s
              (cons "day" % string (cons "next" % string []))
              (Stdlib.Bytes.of_string "Jeudi" % string))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_gt_gt_eq
                  (Store.(Tezos_storage__Store_sigs.STORE.store) s
                    (cons "day" % string
                      (cons "truc" % string (cons "chose" % string [])))
                    (Stdlib.Bytes.of_string "Vendredi" % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_gt_gt_eq
                        (check Store s
                          (cons "day" % string (cons "current" % string []))
                          (Stdlib.Bytes.of_string "Mercredi" % string))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_gt_gt_eq
                              (check Store s
                                (cons "day" % string (cons "next" % string []))
                                (Stdlib.Bytes.of_string "Jeudi" % string))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  check_none Store s (cons "day" % string [])
                                end)
                          end)
                    end)
              end)
        end).

Definition list {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> (list string) -> Lwt.t (list (list string)) :=
  let Store := projT2 Store in
  fun s => fun k => Store.(Tezos_storage__Store_sigs.STORE.keys) s k.

Definition test_generic_list {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    op_gt_gt_eq
      (Store.(Tezos_storage__Store_sigs.STORE.store) s
        (cons "a" % string (cons "b" % string []))
        (Stdlib.Bytes.of_string "Novembre" % string))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_gt_gt_eq
            (Store.(Tezos_storage__Store_sigs.STORE.store) s
              (cons "a" % string (cons "c" % string []))
              (Stdlib.Bytes.of_string "Juin" % string))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                op_gt_gt_eq
                  (Store.(Tezos_storage__Store_sigs.STORE.store) s
                    (cons "a" % string
                      (cons "d" % string (cons "e" % string [])))
                    (Stdlib.Bytes.of_string "Septembre" % string))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_gt_gt_eq
                        (Store.(Tezos_storage__Store_sigs.STORE.store) s
                          (cons "f" % string [])
                          (Stdlib.Bytes.of_string "Avril" % string))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            op_gt_gt_eq
                              (Store.(Tezos_storage__Store_sigs.STORE.store) s
                                (cons "g" % string (cons "h" % string []))
                                (Stdlib.Bytes.of_string "Avril" % string))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_gt_gt_eq (list Store s [])
                                    (fun l =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Stdlib.__LOC__
                                        (cons
                                          (cons "a" % string
                                            (cons "b" % string []))
                                          (cons
                                            (cons "a" % string
                                              (cons "c" % string []))
                                            (cons
                                              (cons "a" % string
                                                (cons "d" % string
                                                  (cons "e" % string [])))
                                              (cons (cons "f" % string [])
                                                (cons
                                                  (cons "g" % string
                                                    (cons "h" % string [])) [])))))
                                        (Tezos_base__TzPervasives.List.sort
                                          OCaml.Stdlib.compare l);
                                      op_gt_gt_eq
                                        (list Store s (cons "a" % string []))
                                        (fun l =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Stdlib.__LOC__
                                            (cons
                                              (cons "a" % string
                                                (cons "b" % string []))
                                              (cons
                                                (cons "a" % string
                                                  (cons "c" % string []))
                                                (cons
                                                  (cons "a" % string
                                                    (cons "d" % string
                                                      (cons "e" % string [])))
                                                  [])))
                                            (Tezos_base__TzPervasives.List.sort
                                              OCaml.Stdlib.compare l);
                                          op_gt_gt_eq
                                            (list Store s (cons "f" % string []))
                                            (fun l =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Stdlib.__LOC__ [] l;
                                              op_gt_gt_eq
                                                (list Store s
                                                  (cons "g" % string []))
                                                (fun l =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Stdlib.__LOC__
                                                    (cons
                                                      (cons "g" % string
                                                        (cons "h" % string []))
                                                      [])
                                                    (Tezos_base__TzPervasives.List.sort
                                                      OCaml.Stdlib.compare l);
                                                  op_gt_gt_eq
                                                    (list Store s
                                                      (cons "i" % string []))
                                                    (fun l =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Stdlib.__LOC__ [] l;
                                                      Lwt.return_unit)))))
                                end)
                          end)
                    end)
              end)
        end).

Import Tezos_storage.Store_helpers.

Definition test_hashset {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    let BlockSet := Tezos_base__TzPervasives.Block_hash.Set in
    let StoreSet := unsupported_functor_application in
    let bhset := BlockSet.add bh2 (BlockSet.add bh1 BlockSet.empty) in
    op_gt_gt_eq
      (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all) s bhset)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_gt_gt_eq
            (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all) s)
            (fun bhset' =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ bhset bhset';
              let bhset2 :=
                OCaml.Stdlib.reverse_apply
                  (OCaml.Stdlib.reverse_apply bhset (BlockSet.add bh3))
                  (BlockSet.remove bh1) in
              op_gt_gt_eq
                (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all)
                  s bhset2)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_gt_gt_eq
                      (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
                        s)
                      (fun bhset2' =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                          bhset2 bhset2';
                        op_gt_gt_eq
                          (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.fold)
                            s BlockSet.empty
                            (fun bh =>
                              fun acc => Lwt._return (BlockSet.add bh acc)))
                          (fun bhset2'' =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                              bhset2 bhset2'';
                            op_gt_gt_eq
                              (Store.(Tezos_storage__Store_sigs.STORE.store) s
                                (cons "day" % string
                                  (cons "current" % string []))
                                (Stdlib.Bytes.of_string "Mercredi" % string))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  op_gt_gt_eq
                                    (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove_all)
                                      s)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        op_gt_gt_eq
                                          (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
                                            s)
                                          (fun empty =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Stdlib.__LOC__ BlockSet.empty
                                              empty;
                                            op_gt_gt_eq
                                              (check Store s
                                                (cons "day" % string
                                                  (cons "current" % string []))
                                                (Stdlib.Bytes.of_string
                                                  "Mercredi" % string))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt => Lwt.return_unit
                                                end))
                                      end)
                                end)))
                  end))
        end).

Definition test_hashmap {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    let BlockMap := Tezos_base__TzPervasives.Block_hash.Map in
    let StoreMap := unsupported_functor_application in
    let eq := equiv_decb in
    let map :=
      OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply BlockMap.empty
          (BlockMap.add bh1 (1, "a" % char))) (BlockMap.add bh2 (2, "b" % char))
      in
    op_gt_gt_eq
      (StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store_all) s map)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          op_gt_gt_eq
            (StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all) s)
            (fun map' =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ eq map map';
              let map2 :=
                OCaml.Stdlib.reverse_apply
                  (OCaml.Stdlib.reverse_apply map
                    (BlockMap.add bh3 (3, "c" % char))) (BlockMap.remove bh1) in
              op_gt_gt_eq
                (StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store_all)
                  s map2)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    op_gt_gt_eq
                      (StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
                        s)
                      (fun map2' =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ eq
                          map2 map2';
                        Lwt.return_unit)
                  end))
        end).

Definition test_single {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    let Single := unsupported_functor_application in
    op_gt_gt_eq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
      (fun known =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ known;
        op_gt_gt_eq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt) s)
          (fun v' =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ None v';
            let v := (3, "Non!" % string) in
            op_gt_gt_eq
              (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.store) s v)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  op_gt_gt_eq
                    (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
                    (fun known =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ known;
                      op_gt_gt_eq
                        (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
                          s)
                        (fun v' =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                            (Some v) v';
                          op_gt_gt_eq
                            (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.remove)
                              s)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                op_gt_gt_eq
                                  (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known)
                                    s)
                                  (fun known =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      Stdlib.__LOC__ known;
                                    op_gt_gt_eq
                                      (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
                                        s)
                                      (fun v' =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Stdlib.__LOC__ None v';
                                        Lwt.return_unit))
                              end)))
                end))).

Definition test_subblock
  (s : SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.t))
  : Lwt.t unit :=
  op_gt_gt_eq
    (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.known) s bh1)
    (fun known =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ known;
      op_gt_gt_eq
        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store) s bh1)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            op_gt_gt_eq
              (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store)
                s bh2)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  op_gt_gt_eq
                    (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.known)
                      s bh2)
                    (fun known =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ known;
                      op_gt_gt_eq
                        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
                          s)
                        (fun set =>
                          let set' :=
                            OCaml.Stdlib.reverse_apply
                              (OCaml.Stdlib.reverse_apply
                                Tezos_base__TzPervasives.Block_hash.Set.empty
                                (Tezos_base__TzPervasives.Block_hash.Set.add bh1))
                              (Tezos_base__TzPervasives.Block_hash.Set.add bh2)
                            in
                          op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                            set set';
                          op_gt_gt_eq
                            (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove)
                              s bh2)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                let set :=
                                  OCaml.Stdlib.reverse_apply
                                    (OCaml.Stdlib.reverse_apply
                                      Tezos_base__TzPervasives.Block_hash.Set.empty
                                      (Tezos_base__TzPervasives.Block_hash.Set.add
                                        bh3'))
                                    (Tezos_base__TzPervasives.Block_hash.Set.add
                                      bh3) in
                                op_gt_gt_eq
                                  (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all)
                                    s set)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      op_gt_gt_eq
                                        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
                                          s)
                                        (fun elts =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Stdlib.__LOC__
                                            (Tezos_base__TzPervasives.List.sort
                                              Tezos_base__TzPervasives.Block_hash.compare
                                              elts)
                                            (Tezos_base__TzPervasives.List.sort
                                              Tezos_base__TzPervasives.Block_hash.compare
                                              (cons bh3 (cons bh3' [])));
                                          op_gt_gt_eq
                                            (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store)
                                              s bh2)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                op_gt_gt_eq
                                                  (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove)
                                                    s bh3)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      op_gt_gt_eq
                                                        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
                                                          s)
                                                        (fun elts =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Stdlib.__LOC__
                                                            (Tezos_base__TzPervasives.List.sort
                                                              Tezos_base__TzPervasives.Block_hash.compare
                                                              elts)
                                                            (Tezos_base__TzPervasives.List.sort
                                                              Tezos_base__TzPervasives.Block_hash.compare
                                                              (cons bh2
                                                                (cons bh3' [])));
                                                          op_gt_gt_eq
                                                            (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.known)
                                                              s bh1)
                                                            (fun known =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                Stdlib.__LOC__
                                                                known;
                                                              let v1
                                                                : Z * string :=
                                                                (3,
                                                                  "Non!" %
                                                                    string)
                                                              with v2
                                                                : Z * string :=
                                                                (12,
                                                                  "Beurk." %
                                                                    string) in
                                                              op_gt_gt_eq
                                                                (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store)
                                                                  s bh1 v1)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    op_gt_gt_eq
                                                                      (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store)
                                                                        s bh2 v2)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          op_gt_gt_eq
                                                                            (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.known)
                                                                              s
                                                                              bh1)
                                                                            (fun
                                                                              known
                                                                              =>
                                                                              op_gt_gt_eq
                                                                                (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_opt)
                                                                                  s
                                                                                  bh1)
                                                                                (fun
                                                                                  v1'
                                                                                  =>
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    Stdlib.__LOC__
                                                                                    (Some
                                                                                      v1)
                                                                                    v1';
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    Stdlib.__LOC__
                                                                                    known;
                                                                                  let
                                                                                    map :=
                                                                                    OCaml.Stdlib.reverse_apply
                                                                                      (OCaml.Stdlib.reverse_apply
                                                                                        Tezos_base__TzPervasives.Block_hash.Map.empty
                                                                                        (Tezos_base__TzPervasives.Block_hash.Map.add
                                                                                          bh1
                                                                                          v1))
                                                                                      (Tezos_base__TzPervasives.Block_hash.Map.add
                                                                                        bh2
                                                                                        v2)
                                                                                    in
                                                                                  op_gt_gt_eq
                                                                                    (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
                                                                                      s)
                                                                                    (fun
                                                                                      map'
                                                                                      =>
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        equiv_decb
                                                                                        Stdlib.__LOC__
                                                                                        map
                                                                                        map';
                                                                                      op_gt_gt_eq
                                                                                        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove_all)
                                                                                          s)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            tt
                                                                                            =>
                                                                                            op_gt_gt_eq
                                                                                              (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
                                                                                                s)
                                                                                              (fun
                                                                                                elts
                                                                                                =>
                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  Stdlib.__LOC__
                                                                                                  elts
                                                                                                  [];
                                                                                                op_gt_gt_eq
                                                                                                  (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
                                                                                                    s)
                                                                                                  (fun
                                                                                                    map'
                                                                                                    =>
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      equiv_decb
                                                                                                      Stdlib.__LOC__
                                                                                                      map
                                                                                                      map';
                                                                                                    op_gt_gt_eq
                                                                                                      (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store)
                                                                                                        s
                                                                                                        bh3)
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        match
                                                                                                          function_parameter
                                                                                                          with
                                                                                                        |
                                                                                                          tt
                                                                                                          =>
                                                                                                          op_gt_gt_eq
                                                                                                            (SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.indexes)
                                                                                                              s)
                                                                                                            (fun
                                                                                                              keys
                                                                                                              =>
                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                Stdlib.__LOC__
                                                                                                                (Tezos_base__TzPervasives.List.sort
                                                                                                                  Tezos_base__TzPervasives.Block_hash.compare
                                                                                                                  keys)
                                                                                                                (Tezos_base__TzPervasives.List.sort
                                                                                                                  Tezos_base__TzPervasives.Block_hash.compare
                                                                                                                  (cons
                                                                                                                    bh1
                                                                                                                    (cons
                                                                                                                      bh2
                                                                                                                      (cons
                                                                                                                        bh3
                                                                                                                        []))));
                                                                                                              Lwt.return_unit)
                                                                                                        end)))
                                                                                          end))))
                                                                        end)
                                                                  end)))
                                                    end)
                                              end))
                                    end)
                              end)))
                end)
          end)).

Definition tests_raw
  : list (string * (Tezos_storage.Raw_store.t -> Lwt.t unit)) :=
  cons ("init" % string, test_init)
    (cons ("generic" % string, (test_generic Tezos_storage.Raw_store))
      (cons ("generic_substore" % string, (test_generic Sub))
        (cons
          ("generic_indexedstore" % string,
            (fun s =>
              test_generic
                SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                (s, bh1)))
          (cons
            ("generic_indexedsubstore" % string,
              (fun s =>
                test_generic
                  SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                  ((s, bh1), bh2)))
            (cons ("single" % string, (test_single Tezos_storage.Raw_store))
              (cons ("single_substore" % string, (test_single Sub))
                (cons
                  ("single_indexedstore" % string,
                    (fun s =>
                      test_single
                        SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                        (s, bh1)))
                  (cons
                    ("single_indexedsubstore" % string,
                      (fun s =>
                        test_single
                          SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                          ((s, bh1), bh2)))
                    (cons
                      ("generic_list" % string,
                        (test_generic_list Tezos_storage.Raw_store))
                      (cons
                        ("generic_substore_list" % string,
                          (test_generic_list Sub))
                        (cons
                          ("generic_indexedstore_list" % string,
                            (fun s =>
                              test_generic_list
                                SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                (s, bh1)))
                          (cons
                            ("generic_indexedsubstore_list" % string,
                              (fun s =>
                                test_generic_list
                                  SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                  ((s, bh1), bh2)))
                            (cons
                              ("hashset" % string,
                                (test_hashset Tezos_storage.Raw_store))
                              (cons
                                ("hashset_substore" % string, (test_hashset Sub))
                                (cons
                                  ("hashset_indexedstore" % string,
                                    (fun s =>
                                      test_hashset
                                        SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                        (s, bh1)))
                                  (cons
                                    ("hashset_indexedsubstore" % string,
                                      (fun s =>
                                        test_hashset
                                          SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                          ((s, bh1), bh2)))
                                    (cons
                                      ("hashmap" % string,
                                        (test_hashmap Tezos_storage.Raw_store))
                                      (cons
                                        ("hashmap_substore" % string,
                                          (test_hashmap Sub))
                                        (cons
                                          ("hashmap_indexedstore" % string,
                                            (fun s =>
                                              test_hashmap
                                                SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                                (s, bh1)))
                                          (cons
                                            ("hashmap_indexedsubstore" % string,
                                              (fun s =>
                                                test_hashmap
                                                  SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                                  ((s, bh1), bh2)))
                                            (cons
                                              ("subblock" % string,
                                                test_subblock) []))))))))))))))))))))).

Definition tests : list (string * (Tezos_shell.Store.t -> Lwt.t unit)) :=
  cons ("expand" % string, test_expand) (cons ("block" % string, test_block) []).

Definition tests {A : Type} : list A :=
  OCaml.Stdlib.app
    (Tezos_base__TzPervasives.List.map
      (fun function_parameter =>
        match function_parameter with
        | (s, f) =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star s variant (wrap_raw_store_init f)
        end) tests_raw)
    (Tezos_base__TzPervasives.List.map
      (fun function_parameter =>
        match function_parameter with
        | (s, f) =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star s variant (wrap_store_init f)
        end) tests).
src/lib_shell/test/test_store_checkpoint.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let mapsize = 4_096_000_000L (* ~4 GiB *)

let ( // ) = Filename.concat

let wrap_raw_store_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "store" in
      Raw_store.init ~mapsize root
      >>= function
      | Ok store ->
          Lwt.finalize
            (fun () -> f store)
            (fun () -> Raw_store.close store ; Lwt.return_unit)
      | Error err ->
          Format.kasprintf
            Pervasives.failwith
            "@[Cannot initialize store:@ %a@]"
            pp_print_error
            err)

(**************************************************************************)
(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

(**************************************************************************)
(** Block store *)

let lolblock ?(operations = []) header =
  let operations_hash =
    Operation_list_list_hash.compute [Operation_list_hash.compute operations]
  in
  let block_header =
    {
      Block_header.shell =
        {
          timestamp = Time.Protocol.of_seconds (Random.int64 1500L);
          level = 0l;
          (* dummy *)
          proto_level = 0;
          (* dummy *)
          validation_passes = Random.int 32;
          predecessor = genesis_block;
          operations_hash;
          fitness =
            [ Bytes.of_string @@ string_of_int @@ String.length header;
              Bytes.of_string @@ string_of_int @@ 12 ];
          context = Context_hash.zero;
        };
      protocol_data = Bytes.of_string header;
    }
  in
  let block_contents =
    {
      header = block_header;
      Store.Block.metadata = Bytes.create 0;
      max_operations_ttl = 0;
      message = None;
      context = Context_hash.zero;
      last_allowed_fork_level = 0l;
    }
  in
  (block_header, block_contents)

let (block_header, _) = lolblock "A1"

let block_hash = Block_header.hash block_header

(****************************************************)

open Store_helpers

let test_single (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  let module Single =
    Make_single_store
      (Store)
      (struct
        let name = ["checkpoint"]
      end)
      (Store_helpers.Make_value (struct
        type t = Int32.t * Block_hash.t

        let encoding = Data_encoding.(tup2 int32 Block_hash.encoding)
      end))
  in
  (* is there any checkpoint in store *)
  Single.known s
  >>= fun is_known ->
  Assert.is_false ~msg:__LOC__ is_known ;
  Single.read_opt s
  >>= fun checkpoint' ->
  Assert.equal_checkpoint ~msg:__LOC__ None checkpoint' ;
  (* store new checkpoint: (1, A1) *)
  let checkpoint = (1l, block_hash) in
  Single.store s checkpoint
  >>= fun () ->
  Single.known s
  >>= fun is_known ->
  Assert.is_true ~msg:__LOC__ is_known ;
  Single.read_opt s
  >>= fun checkpoint' ->
  Assert.equal_checkpoint ~msg:__LOC__ (Some checkpoint) checkpoint' ;
  (* remove the checkpoint just store *)
  Single.remove s
  >>= fun () ->
  Single.known s
  >>= fun is_known ->
  Assert.is_false ~msg:__LOC__ is_known ;
  Single.read_opt s
  >>= fun checkpoint' ->
  Assert.equal_checkpoint ~msg:__LOC__ None checkpoint' ;
  Lwt.return_unit

(**************************************************************************)

let tests_raw : (string * (Raw_store.t -> unit Lwt.t)) list =
  [("single", test_single (module Raw_store))]

let tests =
  List.map
    (fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_raw_store_init f))
    tests_raw
src/lib_shell/test/test_store_checkpoint.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition mapsize : int64 := 4096000000.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition wrap_raw_store_init {A B : Type}
  (f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
  : unit -> Lwt.t A :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir "tezos_test_" % string
          (fun base_dir =>
            let root := op_div_div base_dir "store" % string in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_storage.Raw_store.init None (Some mapsize) root)
              (fun function_parameter =>
                match function_parameter with
                | inl store =>
                  Lwt.finalize
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => f store
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_storage.Raw_store.close store;
                        Lwt.return_unit
                      end)
                | inr err =>
                  Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Cannot initialize store:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Cannot initialize store:@ %a@]" % string)
                    Tezos_base__TzPervasives.pp_print_error err
                end))
      end
  end.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition lolblock
  (op_star_o_p_t_star :
    option (list Tezos_base__TzPervasives.Operation_list_hash.elt))
  : string ->
    Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents :=
  let operations :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun header =>
    let operations_hash :=
      Tezos_base__TzPervasives.Operation_list_list_hash.compute
        (cons (Tezos_base__TzPervasives.Operation_list_hash.compute operations)
          []) in
    let block_header :=
      {|
        Block_header.shell :=
          {| level := 0; proto_level := 0; predecessor := genesis_block;
            timestamp :=
              Tezos_base__TzPervasives.Time.Protocol.of_seconds
                (Stdlib.Random.int64 1500);
            validation_passes := Stdlib.Random.int 32;
            operations_hash := operations_hash;
            fitness :=
              cons
                (apply Stdlib.Bytes.of_string
                  (apply OCaml.Stdlib.string_of_int
                    (Tezos_base__TzPervasives.String.length header)))
                (cons
                  (apply Stdlib.Bytes.of_string
                    (apply OCaml.Stdlib.string_of_int 12)) []);
            context := Tezos_base__TzPervasives.Context_hash.zero |};
        Block_header.protocol_data := Stdlib.Bytes.of_string header |} in
    let block_contents :=
      {| Store.Block.header := block_header; Store.Block.message := None;
        Store.Block.max_operations_ttl := 0;
        Store.Block.last_allowed_fork_level := 0;
        Store.Block.context := Tezos_base__TzPervasives.Context_hash.zero;
        Store.Block.metadata := Stdlib.Bytes.create 0 |} in
    (block_header, block_contents).

Definition block_hash : Tezos_crypto.Block_hash.t :=
  Tezos_base__TzPervasives.Block_header.hash block_header.

Import Tezos_storage.Store_helpers.

Definition test_single {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    let Single := unsupported_functor_application in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
      (fun is_known =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ is_known;
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt) s)
          (fun checkpoint' =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ None checkpoint';
            let checkpoint := (1, block_hash) in
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.store) s
                checkpoint)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
                    (fun is_known =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                        is_known;
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
                          s)
                        (fun checkpoint' =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                            (Some checkpoint) checkpoint';
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.remove)
                              s)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known)
                                    s)
                                  (fun is_known =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      Stdlib.__LOC__ is_known;
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
                                        s)
                                      (fun checkpoint' =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Stdlib.__LOC__ None checkpoint';
                                        Lwt.return_unit))
                              end)))
                end))).

Definition tests_raw
  : list (string * (Tezos_storage.Raw_store.t -> Lwt.t unit)) :=
  cons ("single" % string, (test_single Tezos_storage.Raw_store)) [].

Definition tests {A : Type} : list A :=
  Tezos_base__TzPervasives.List.map
    (fun function_parameter =>
      match function_parameter with
      | (s, f) =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star s variant (wrap_raw_store_init f)
      end) tests_raw.
src/lib_shell/validator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.validator"
end)

type t = {
  state : State.t;
  db : Distributed_db.t;
  block_validator : Block_validator.t;
  chain_validator_limits : Chain_validator.limits;
  peer_validator_limits : Peer_validator.limits;
  block_validator_limits : Block_validator.limits;
  prevalidator_limits : Prevalidator.limits;
  start_testchain : bool;
  valid_block_input : State.Block.t Lwt_watcher.input;
  chains_input : (Chain_id.t * bool) Lwt_watcher.input;
  active_chains : Chain_validator.t Chain_id.Table.t;
}

let create state db peer_validator_limits block_validator_limits
    block_validator_kind prevalidator_limits chain_validator_limits
    ~start_testchain =
  Block_validator.create
    block_validator_limits
    db
    block_validator_kind
    ~start_testchain
  >>=? fun block_validator ->
  let valid_block_input = Lwt_watcher.create_input () in
  let chains_input = Lwt_watcher.create_input () in
  return
    {
      state;
      db;
      start_testchain;
      block_validator;
      block_validator_limits;
      prevalidator_limits;
      peer_validator_limits;
      chain_validator_limits;
      valid_block_input;
      chains_input;
      active_chains = Chain_id.Table.create 7;
    }

let activate v ~start_prevalidator ~validator_process chain_state =
  let chain_id = State.Chain.id chain_state in
  lwt_log_notice
    Tag.DSL.(
      fun f ->
        f "activate chain %a" -% t event "active_chain"
        -% a State_logging.chain_id chain_id)
  >>= fun () ->
  match Chain_id.Table.find_opt v.active_chains chain_id with
  | Some chain ->
      return chain
  | None ->
      Chain_validator.create
        ~start_prevalidator
        ~start_testchain:v.start_testchain
        ~active_chains:v.active_chains
        ~block_validator_process:validator_process
        v.peer_validator_limits
        v.prevalidator_limits
        v.block_validator
        v.valid_block_input
        v.chains_input
        v.db
        chain_state
        v.chain_validator_limits

let get_exn {active_chains; _} chain_id =
  Chain_id.Table.find active_chains chain_id

let get {active_chains; _} chain_id =
  match Chain_id.Table.find_opt active_chains chain_id with
  | Some nv ->
      Ok nv
  | None ->
      error (Validation_errors.Inactive_chain chain_id)

let get_active_chains {active_chains; _} =
  let l = Chain_id.Table.fold (fun c _ acc -> c :: acc) active_chains [] in
  List.rev l

let validate_block v ?(force = false) ?chain_id bytes operations =
  let hash = Block_hash.hash_bytes [bytes] in
  match Block_header.of_bytes bytes with
  | None ->
      failwith "Cannot parse block header."
  | Some block ->
      ( match chain_id with
      | None -> (
          Distributed_db.read_block_header v.db block.shell.predecessor
          >>= function
          | None ->
              failwith
                "Unknown predecessor (%a), cannot inject the block."
                Block_hash.pp_short
                block.shell.predecessor
          | Some (chain_id, _bh) ->
              Lwt.return (get v chain_id) )
      | Some chain_id -> (
          Lwt.return (get v chain_id)
          >>=? fun nv ->
          if force then return nv
          else
            Distributed_db.Block_header.known
              (Chain_validator.chain_db nv)
              block.shell.predecessor
            >>= function
            | true ->
                return nv
            | false ->
                failwith
                  "Unknown predecessor (%a), cannot inject the block."
                  Block_hash.pp_short
                  block.shell.predecessor ) )
      >>=? fun nv ->
      let validation =
        Chain_validator.validate_block nv ~force hash block operations
      in
      return (hash, validation)

let shutdown {active_chains; block_validator; _} =
  let block_validator_job =
    lwt_log_notice
      Tag.DSL.(
        fun f -> f "Shutting down the block validator..." -% t event "shutdown")
    >>= fun () -> Block_validator.shutdown block_validator
  in
  let chain_validator_jobs =
    List.of_seq
    @@ Seq.map
         (fun (id, nv) ->
           lwt_log_notice
             Tag.DSL.(
               fun f ->
                 f "Shutting down the chain validator %a..."
                 -% t event "shutdown"
                 -% a State_logging.chain_id id)
           >>= fun () -> Chain_validator.shutdown nv)
         (Chain_id.Table.to_seq active_chains)
  in
  Lwt.join (block_validator_job :: chain_validator_jobs)

let watcher {valid_block_input; _} =
  Lwt_watcher.create_stream valid_block_input

let chains_watcher {chains_input; _} = Lwt_watcher.create_stream chains_input

let inject_operation v ?chain_id op =
  ( match chain_id with
  | None -> (
      Distributed_db.read_block_header v.db op.Operation.shell.branch
      >>= function
      | None ->
          failwith
            "Unknown branch (%a), cannot inject the operation."
            Block_hash.pp_short
            op.shell.branch
      | Some (chain_id, _bh) ->
          Lwt.return (get v chain_id) )
  | Some chain_id -> (
      Lwt.return (get v chain_id)
      >>=? fun nv ->
      Distributed_db.Block_header.known
        (Chain_validator.chain_db nv)
        op.shell.branch
      >>= function
      | true ->
          return nv
      | false ->
          failwith
            "Unknown branch (%a), cannot inject the operation."
            Block_hash.pp_short
            op.shell.branch ) )
  >>=? fun nv ->
  let pv_opt = Chain_validator.prevalidator nv in
  match pv_opt with
  | Some pv ->
      Prevalidator.inject_operation pv op
  | None ->
      failwith "Prevalidator is not running, cannot inject the operation."

let distributed_db {db; _} = db
src/lib_shell/validator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  state : Tezos_shell.State.t;
  db : Tezos_shell.Distributed_db.t;
  block_validator : Tezos_shell.Block_validator.t;
  chain_validator_limits : Tezos_shell.Chain_validator.limits;
  peer_validator_limits : Tezos_shell.Peer_validator.limits;
  block_validator_limits : Tezos_shell.Block_validator.limits;
  prevalidator_limits : Tezos_shell.Prevalidator.limits;
  start_testchain : bool;
  valid_block_input :
    Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
  chains_input :
    Tezos_base__TzPervasives.Lwt_watcher.input
      (Tezos_base__TzPervasives.Chain_id.t * bool);
  active_chains :
    Tezos_base__TzPervasives.Chain_id.Table.t Tezos_shell.Chain_validator.t }.

Definition create
  (state : Tezos_shell.State.t) (db : Tezos_shell.Distributed_db.t)
  (peer_validator_limits : Tezos_shell.Peer_validator.limits)
  (block_validator_limits : Tezos_shell.Block_validator.limits)
  (block_validator_kind : Tezos_shell.Block_validator_process.t)
  (prevalidator_limits : Tezos_shell.Prevalidator.limits)
  (chain_validator_limits : Tezos_shell.Chain_validator.limits)
  (start_testchain : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell.Block_validator.create block_validator_limits db
      block_validator_kind start_testchain)
    (fun block_validator =>
      let valid_block_input :=
        Tezos_base__TzPervasives.Lwt_watcher.create_input tt in
      let chains_input := Tezos_base__TzPervasives.Lwt_watcher.create_input tt
        in
      Tezos_base__TzPervasives._return
        {| state := state; db := db; block_validator := block_validator;
          chain_validator_limits := chain_validator_limits;
          peer_validator_limits := peer_validator_limits;
          block_validator_limits := block_validator_limits;
          prevalidator_limits := prevalidator_limits;
          start_testchain := start_testchain;
          valid_block_input := valid_block_input; chains_input := chains_input;
          active_chains := Tezos_base__TzPervasives.Chain_id.Table.create 7 |}).

Definition activate
  (v : t) (start_prevalidator : bool)
  (validator_process : Tezos_shell.Block_validator_process.t)
  (chain_state : Tezos_shell.State.Chain.chain_state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.Chain_validator.t) :=
  let chain_id := Tezos_shell.State.Chain.id chain_state in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_log_notice
      (fun f =>
        Tag.DSL.op_minus_percent
          (Tag.DSL.op_minus_percent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "activate chain " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "activate chain %a" % string))
            (Tag.DSL.t event "active_chain" % string))
          (Tag.DSL.a Tezos_shell_services.State_logging.chain_id chain_id)))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        match
          Tezos_base__TzPervasives.Chain_id.Table.find_opt (active_chains v)
            chain_id with
        | Some chain => Tezos_base__TzPervasives._return chain
        | None =>
          Tezos_shell.Chain_validator.create start_prevalidator
            (start_testchain v) (active_chains v) validator_process
            (peer_validator_limits v) (prevalidator_limits v)
            (block_validator v) (valid_block_input v) (chains_input v) (db v)
            chain_state (chain_validator_limits v)
        end
      end).

Definition get_exn (function_parameter : t)
  : Tezos_base__TzPervasives.Chain_id.Table.key -> Tezos_shell.Chain_validator.t :=
  match function_parameter with
  | {| active_chains := active_chains |} =>
    fun chain_id =>
      Tezos_base__TzPervasives.Chain_id.Table.find active_chains chain_id
  end.

Definition get (function_parameter : t)
  : Tezos_base__TzPervasives.Chain_id.Table.key ->
    sum Tezos_shell.Chain_validator.t (list Tezos_base__TzPervasives.error) :=
  match function_parameter with
  | {| active_chains := active_chains |} =>
    fun chain_id =>
      match
        Tezos_base__TzPervasives.Chain_id.Table.find_opt active_chains chain_id
        with
      | Some nv => inl nv
      | None =>
        Tezos_base__TzPervasives.error
          (Validation_errors.Inactive_chain chain_id)
      end
  end.

Definition get_active_chains (function_parameter : t)
  : list Tezos_base__TzPervasives.Chain_id.Table.key :=
  match function_parameter with
  | {| active_chains := active_chains |} =>
    let l :=
      Tezos_base__TzPervasives.Chain_id.Table.fold
        (fun c =>
          fun function_parameter =>
            match function_parameter with
            | _ => fun acc => cons c acc
            end) active_chains [] in
    Tezos_base__TzPervasives.List.rev l
  end.

Definition validate_block (v : t) (op_star_o_p_t_star : option bool)
  : (option Tezos_base__TzPervasives.Chain_id.Table.key) ->
    Stdlib.Bytes.t ->
      (list (list Tezos_base__TzPervasives.Operation.t)) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Block_hash.t *
              (Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  (option Tezos_shell.State.Block.t))))) :=
  let force :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun chain_id =>
    fun bytes =>
      fun operations =>
        let hash :=
          Tezos_base__TzPervasives.Block_hash.hash_bytes None (cons string [])
          in
        match Tezos_base__TzPervasives.Block_header.of_bytes string with
        | None =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Cannot parse block header." % string
                CamlinternalFormatBasics.End_of_format)
              "Cannot parse block header." % string)
        | Some block =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            match chain_id with
            | None =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Distributed_db.read_block_header (db v)
                  (predecessor (shell block)))
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    Tezos_base__TzPervasives.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Unknown predecessor (" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              "), cannot inject the block." % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Unknown predecessor (%a), cannot inject the block." %
                          string) Tezos_base__TzPervasives.Block_hash.pp_short
                      (predecessor (shell block))
                  | Some (chain_id, _bh) => Lwt._return (get v chain_id)
                  end)
            | Some chain_id =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Lwt._return (get v chain_id))
                (fun nv =>
                  if force then
                    Tezos_base__TzPervasives._return nv
                  else
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_shell.Distributed_db.Block_header.known
                        (Tezos_shell.Chain_validator.chain_db nv)
                        (predecessor (shell block)))
                      (fun function_parameter =>
                        match function_parameter with
                        | true => Tezos_base__TzPervasives._return nv
                        | false =>
                          Tezos_base__TzPervasives.failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Unknown predecessor (" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    "), cannot inject the block." % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "Unknown predecessor (%a), cannot inject the block."
                                % string)
                            Tezos_base__TzPervasives.Block_hash.pp_short
                            (predecessor (shell block))
                        end))
            end
            (fun nv =>
              let validation :=
                Tezos_shell.Chain_validator.validate_block nv (Some force) hash
                  block operations in
              Tezos_base__TzPervasives._return (hash, validation))
        end.

Definition shutdown (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | {| block_validator := block_validator; active_chains := active_chains |} =>
    let block_validator_job :=
      Tezos_base__TzPervasives.op_gt_gt_eq
        (lwt_log_notice
          (fun f =>
            Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Shutting down the block validator..." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Shutting down the block validator..." % string))
              (Tag.DSL.t event "shutdown" % string)))
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_shell.Block_validator.shutdown block_validator
          end) in
    let chain_validator_jobs :=
      apply Tezos_base__TzPervasives.List.of_seq
        (Stdlib.Seq.map
          (fun function_parameter =>
            match function_parameter with
            | (id, nv) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (lwt_log_notice
                  (fun f =>
                    Tag.DSL.op_minus_percent
                      (Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Shutting down the chain validator " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  "..." % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Shutting down the chain validator %a..." % string))
                        (Tag.DSL.t event "shutdown" % string))
                      (Tag.DSL.a Tezos_shell_services.State_logging.chain_id id)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_shell.Chain_validator.shutdown nv
                  end)
            end) (Tezos_base__TzPervasives.Chain_id.Table.to_seq active_chains))
      in
    Lwt.join (cons block_validator_job chain_validator_jobs)
  end.

Definition watcher (function_parameter : t)
  : (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  match function_parameter with
  | {| valid_block_input := valid_block_input |} =>
    Tezos_base__TzPervasives.Lwt_watcher.create_stream valid_block_input
  end.

Definition chains_watcher (function_parameter : t)
  : (Lwt_stream.t (Tezos_base__TzPervasives.Chain_id.t * bool)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  match function_parameter with
  | {| chains_input := chains_input |} =>
    Tezos_base__TzPervasives.Lwt_watcher.create_stream chains_input
  end.

Definition inject_operation
  (v : t) (chain_id : option Tezos_base__TzPervasives.Chain_id.Table.key)
  (op : Tezos_base__TzPervasives.Operation.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match chain_id with
    | None =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_shell.Distributed_db.read_block_header (db v)
          (branch (Operation.shell op)))
        (fun function_parameter =>
          match function_parameter with
          | None =>
            Tezos_base__TzPervasives.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Unknown branch (" % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "), cannot inject the operation." % string
                      CamlinternalFormatBasics.End_of_format)))
                "Unknown branch (%a), cannot inject the operation." % string)
              Tezos_base__TzPervasives.Block_hash.pp_short (branch (shell op))
          | Some (chain_id, _bh) => Lwt._return (get v chain_id)
          end)
    | Some chain_id =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Lwt._return (get v chain_id))
        (fun nv =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_shell.Distributed_db.Block_header.known
              (Tezos_shell.Chain_validator.chain_db nv) (branch (shell op)))
            (fun function_parameter =>
              match function_parameter with
              | true => Tezos_base__TzPervasives._return nv
              | false =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Unknown branch (" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          "), cannot inject the operation." % string
                          CamlinternalFormatBasics.End_of_format)))
                    "Unknown branch (%a), cannot inject the operation." % string)
                  Tezos_base__TzPervasives.Block_hash.pp_short
                  (branch (shell op))
              end))
    end
    (fun nv =>
      let pv_opt := Tezos_shell.Chain_validator.prevalidator nv in
      match pv_opt with
      | Some pv => Tezos_shell.Prevalidator.inject_operation pv op
      | None =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Prevalidator is not running, cannot inject the operation." %
                string CamlinternalFormatBasics.End_of_format)
            "Prevalidator is not running, cannot inject the operation." % string)
      end).

Definition distributed_db (function_parameter : t)
  : Tezos_shell.Distributed_db.t :=
  match function_parameter with
  | {| db := db |} => db
  end.
src/lib_shell/validator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Shell - Main entry point of the validation scheduler. *)

type t

val create :
  State.t ->
  Distributed_db.t ->
  Peer_validator.limits ->
  Block_validator.limits ->
  Block_validator_process.t ->
  Prevalidator.limits ->
  Chain_validator.limits ->
  start_testchain:bool ->
  t tzresult Lwt.t

val shutdown : t -> unit Lwt.t

(** Start the validation scheduler of a given chain. *)
val activate :
  t ->
  start_prevalidator:bool ->
  validator_process:Block_validator_process.t ->
  State.Chain.t ->
  Chain_validator.t tzresult Lwt.t

val get : t -> Chain_id.t -> Chain_validator.t tzresult

val get_exn : t -> Chain_id.t -> Chain_validator.t

val get_active_chains : t -> Chain_id.t list

(** Force the validation of a block. *)
val validate_block :
  t ->
  ?force:bool ->
  ?chain_id:Chain_id.t ->
  Bytes.t ->
  Operation.t list list ->
  (Block_hash.t * State.Block.t option tzresult Lwt.t) tzresult Lwt.t

(** Monitor all the valid block (for all activate chains). *)
val watcher : t -> State.Block.t Lwt_stream.t * Lwt_watcher.stopper

val chains_watcher :
  t -> (Chain_id.t * bool) Lwt_stream.t * Lwt_watcher.stopper

val inject_operation :
  t -> ?chain_id:Chain_id.t -> Operation.t -> unit tzresult Lwt.t

val distributed_db : t -> Distributed_db.t
src/lib_shell/validator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create :
Tezos_shell.State.t ->
  Tezos_shell.Distributed_db.t ->
    Tezos_shell.Peer_validator.limits ->
      Tezos_shell.Block_validator.limits ->
        Tezos_shell.Block_validator_process.t ->
          Tezos_shell.Prevalidator.limits ->
            Tezos_shell.Chain_validator.limits ->
              bool -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter shutdown : t -> Lwt.t unit.

Parameter activate :
t ->
  bool ->
    Tezos_shell.Block_validator_process.t ->
      Tezos_shell.State.Chain.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.Chain_validator.t).

Parameter get :
t ->
  Tezos_base__TzPervasives.Chain_id.t ->
    Tezos_base__TzPervasives.tzresult Tezos_shell.Chain_validator.t.

Parameter get_exn :
t -> Tezos_base__TzPervasives.Chain_id.t -> Tezos_shell.Chain_validator.t.

Parameter get_active_chains : t -> list Tezos_base__TzPervasives.Chain_id.t.

Parameter validate_block :
t ->
  (option bool) ->
    (option Tezos_base__TzPervasives.Chain_id.t) ->
      Stdlib.Bytes.t ->
        (list (list Tezos_base__TzPervasives.Operation.t)) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (Tezos_base__TzPervasives.Block_hash.t *
                (Lwt.t
                  (Tezos_base__TzPervasives.tzresult
                    (option Tezos_shell.State.Block.t))))).

Parameter watcher :
t ->
  (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper.

Parameter chains_watcher :
t ->
  (Lwt_stream.t (Tezos_base__TzPervasives.Chain_id.t * bool)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper.

Parameter inject_operation :
t ->
  (option Tezos_base__TzPervasives.Chain_id.t) ->
    Tezos_base__TzPervasives.Operation.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter distributed_db : t -> Tezos_shell.Distributed_db.t.
src/lib_shell/worker.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type NAME = sig
  val base : string list

  type t

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

module type EVENT = sig
  type t

  val level : t -> Internal_event.level

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

module type REQUEST = sig
  type 'a t

  type view

  val view : 'a t -> view

  val encoding : view Data_encoding.t

  val pp : Format.formatter -> view -> unit
end

module type TYPES = sig
  type state

  type parameters

  type view

  val view : state -> parameters -> view

  val encoding : view Data_encoding.t

  val pp : Format.formatter -> view -> unit
end

module type LOGGER = sig
  module Event : EVENT

  module Request : REQUEST

  type status =
    | WorkerEvent of Event.t
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Terminated
    | Timeout
    | Crashed of error list
    | Started of string option
    | Triggering_shutdown
    | Duplicate of string

  type t = status Time.System.stamped

  module MakeDefinition (Static : sig
    val worker_name : string
  end) : Internal_event.EVENT_DEFINITION with type t = t
end

(** An error returned when trying to communicate with a worker that
    has been closed.*)
type worker_name = {base : string; name : string}

type Error_monad.error += Closed of worker_name

let () =
  register_error_kind
    `Permanent
    ~id:"worker.closed"
    ~title:"Worker closed"
    ~description:
      "An operation on a worker could not complete before it was shut down."
    ~pp:(fun ppf w ->
      Format.fprintf ppf "Worker %s[%s] has been shut down." w.base w.name)
    Data_encoding.(
      conv
        (fun {base; name} -> (base, name))
        (fun (name, base) -> {base; name})
        (obj1 (req "worker" (tup2 string string))))
    (function Closed w -> Some w | _ -> None)
    (fun w -> Closed w)

module type T = sig
  module Name : NAME

  module Event : EVENT

  module Request : REQUEST

  module Types : TYPES

  (** A handle to a specific worker, parameterized by the type of
      internal message buffer. *)
  type 'kind t

  (** A handle to a table of workers. *)
  type 'kind table

  (** Internal buffer kinds used as parameters to {!t}. *)
  type 'a queue

  and bounded

  and infinite

  type dropbox

  (** Supported kinds of internal buffers. *)
  type _ buffer_kind =
    | Queue : infinite queue buffer_kind
    | Bounded : {size : int} -> bounded queue buffer_kind
    | Dropbox : {
        merge :
          dropbox t -> any_request -> any_request option -> any_request option;
      }
        -> dropbox buffer_kind

  and any_request = Any_request : _ Request.t -> any_request

  (** Create a table of workers. *)
  val create_table : 'kind buffer_kind -> 'kind table

  (** The callback handlers specific to each worker instance. *)
  module type HANDLERS = sig
    (** Placeholder replaced with {!t} with the right parameters
        provided by the type of buffer chosen at {!launch}.*)
    type self

    (** Builds the initial internal state of a worker at launch.
        It is possible to initialize the message queue.
        Of course calling {!state} will fail at that point. *)
    val on_launch :
      self -> Name.t -> Types.parameters -> Types.state tzresult Lwt.t

    (** The main request processor, i.e. the body of the event loop. *)
    val on_request : self -> 'a Request.t -> 'a tzresult Lwt.t

    (** Called when no request has been made before the timeout, if
        the parameter has been passed to {!launch}. *)
    val on_no_request : self -> unit tzresult Lwt.t

    (** A function called when terminating a worker. *)
    val on_close : self -> unit Lwt.t

    (** A function called at the end of the worker loop in case of an
        abnormal error. This function can handle the error by
        returning [Ok ()], or leave the default unexpected error
        behaviour by returning its parameter. A possibility is to
        handle the error for ad-hoc logging, and still use
        {!trigger_shutdown} to kill the worker. *)
    val on_error :
      self ->
      Request.view ->
      Worker_types.request_status ->
      error list ->
      unit tzresult Lwt.t

    (** A function called at the end of the worker loop in case of a
        successful treatment of the current request. *)
    val on_completion :
      self -> 'a Request.t -> 'a -> Worker_types.request_status -> unit Lwt.t
  end

  (** Creates a new worker instance.
      Parameter [queue_size] not passed means unlimited queue. *)
  val launch :
    'kind table ->
    ?timeout:Time.System.Span.t ->
    Worker_types.limits ->
    Name.t ->
    Types.parameters ->
    (module HANDLERS with type self = 'kind t) ->
    'kind t tzresult Lwt.t

  (** Triggers a worker termination and waits for its completion.
      Cannot be called from within the handlers.  *)
  val shutdown : _ t -> unit Lwt.t

  module type BOX = sig
    type t

    val put_request : t -> 'a Request.t -> unit

    val put_request_and_wait : t -> 'a Request.t -> 'a tzresult Lwt.t
  end

  module type QUEUE = sig
    type 'a t

    val push_request_and_wait : 'q t -> 'a Request.t -> 'a tzresult Lwt.t

    val push_request : 'q t -> 'a Request.t -> unit Lwt.t

    val pending_requests : 'a t -> (Time.System.t * Request.view) list

    val pending_requests_length : 'a t -> int
  end

  module type BOUNDED_QUEUE = sig
    type t

    val try_push_request_now : t -> 'a Request.t -> bool
  end

  module Dropbox : sig
    include BOX with type t := dropbox t
  end

  module Queue : sig
    include QUEUE with type 'a t := 'a queue t

    include BOUNDED_QUEUE with type t := bounded queue t

    (** Adds a message to the queue immediately. *)
    val push_request_now : infinite queue t -> 'a Request.t -> unit
  end

  (** Detects cancellation from within the request handler to stop
      asynchronous operations. *)
  val protect :
    _ t ->
    ?on_error:(error list -> 'b tzresult Lwt.t) ->
    (unit -> 'b tzresult Lwt.t) ->
    'b tzresult Lwt.t

  (** Exports the canceler to allow cancellation of other tasks when this
      worker is shutdowned or when it dies. *)
  val canceler : _ t -> Lwt_canceler.t

  (** Triggers a worker termination. *)
  val trigger_shutdown : _ t -> unit

  (** Recod an event in the backlog. *)
  val record_event : _ t -> Event.t -> unit

  (** Record an event and make sure it is logged. *)
  val log_event : _ t -> Event.t -> unit Lwt.t

  (** Access the internal state, once initialized. *)
  val state : _ t -> Types.state

  (** Access the event backlog. *)
  val last_events : _ t -> (Internal_event.level * Event.t list) list

  (** Introspect the message queue, gives the times requests were pushed. *)
  val pending_requests : _ queue t -> (Time.System.t * Request.view) list

  (** Get the running status of a worker. *)
  val status : _ t -> Worker_types.worker_status

  (** Get the request being treated by a worker.
      Gives the time the request was pushed, and the time its
      treatment started. *)
  val current_request :
    _ t -> (Time.System.t * Time.System.t * Request.view) option

  val information : _ t -> Worker_types.worker_information

  (** Introspect the state of a worker. *)
  val view : _ t -> Types.view

  (** Lists the running workers in this group. *)
  val list : 'a table -> (Name.t * 'a t) list

  (** [find_opt table n] is [Some worker] if the [worker] is in the [table] and
      has name [n]. *)
  val find_opt : 'a table -> Name.t -> 'a t option
end

module Make
    (Name : NAME)
    (Event : EVENT)
    (Request : REQUEST)
    (Types : TYPES)
    (Logger : LOGGER with module Event = Event and module Request = Request) =
struct
  module Name = Name
  module Event = Event
  module Request = Request
  module Types = Types
  module Logger = Logger

  let base_name = String.concat "-" Name.base

  type message = Message : 'a Request.t * 'a tzresult Lwt.u option -> message

  type 'a queue

  and bounded

  and infinite

  type dropbox

  type _ buffer_kind =
    | Queue : infinite queue buffer_kind
    | Bounded : {size : int} -> bounded queue buffer_kind
    | Dropbox : {
        merge :
          dropbox t -> any_request -> any_request option -> any_request option;
      }
        -> dropbox buffer_kind

  and any_request = Any_request : _ Request.t -> any_request

  and _ buffer =
    | Queue_buffer :
        (Time.System.t * message) Lwt_pipe.t
        -> infinite queue buffer
    | Bounded_buffer :
        (Time.System.t * message) Lwt_pipe.t
        -> bounded queue buffer
    | Dropbox_buffer :
        (Time.System.t * message) Lwt_dropbox.t
        -> dropbox buffer

  and 'kind t = {
    limits : Worker_types.limits;
    timeout : Time.System.Span.t option;
    parameters : Types.parameters;
    mutable (* only for init *) worker : unit Lwt.t;
    mutable (* only for init *) state : Types.state option;
    buffer : 'kind buffer;
    event_log : (Internal_event.level * Event.t Ring.t) list;
    canceler : Lwt_canceler.t;
    name : Name.t;
    id : int;
    mutable status : Worker_types.worker_status;
    mutable current_request :
      (Time.System.t * Time.System.t * Request.view) option;
    logEvent : (module Internal_event.EVENT with type t = Logger.t);
    table : 'kind table;
  }

  and 'kind table = {
    buffer_kind : 'kind buffer_kind;
    mutable last_id : int;
    instances : (Name.t, 'kind t) Hashtbl.t;
  }

  let queue_item ?u r = (Systime_os.now (), Message (r, u))

  let drop_request w merge message_box request =
    try
      match
        match Lwt_dropbox.peek message_box with
        | None ->
            merge w (Any_request request) None
        | Some (_, Message (old, _)) ->
            Lwt.ignore_result (Lwt_dropbox.take message_box) ;
            merge w (Any_request request) (Some (Any_request old))
      with
      | None ->
          ()
      | Some (Any_request neu) ->
          Lwt_dropbox.put message_box (Systime_os.now (), Message (neu, None))
    with Lwt_dropbox.Closed -> ()

  let push_request_and_wait w message_queue request =
    let (t, u) = Lwt.wait () in
    Lwt.catch
      (fun () ->
        Lwt_pipe.push message_queue (queue_item ~u request) >>= fun () -> t)
      (function
        | Lwt_pipe.Closed ->
            let name = Format.asprintf "%a" Name.pp w.name in
            fail (Closed {base = base_name; name})
        | exn ->
            fail (Exn exn))

  let drop_request_and_wait w message_box request =
    let (t, u) = Lwt.wait () in
    Lwt.catch
      (fun () ->
        Lwt_dropbox.put message_box (queue_item ~u request) ;
        t)
      (function
        | Lwt_pipe.Closed ->
            let name = Format.asprintf "%a" Name.pp w.name in
            fail (Closed {base = base_name; name})
        | exn ->
            fail (Exn exn))

  module type BOX = sig
    type t

    val put_request : t -> 'a Request.t -> unit

    val put_request_and_wait : t -> 'a Request.t -> 'a tzresult Lwt.t
  end

  module type QUEUE = sig
    type 'a t

    val push_request_and_wait : 'q t -> 'a Request.t -> 'a tzresult Lwt.t

    val push_request : 'q t -> 'a Request.t -> unit Lwt.t

    val pending_requests : 'a t -> (Time.System.t * Request.view) list

    val pending_requests_length : 'a t -> int
  end

  module type BOUNDED_QUEUE = sig
    type t

    val try_push_request_now : t -> 'a Request.t -> bool
  end

  module Dropbox = struct
    let put_request (w : dropbox t) request =
      let (Dropbox {merge}) = w.table.buffer_kind in
      let (Dropbox_buffer message_box) = w.buffer in
      drop_request w merge message_box request

    let put_request_and_wait (w : dropbox t) request =
      let (Dropbox_buffer message_box) = w.buffer in
      drop_request_and_wait w message_box request
  end

  module Queue = struct
    let push_request (type a) (w : a queue t) request =
      match w.buffer with
      | Queue_buffer message_queue ->
          Lwt_pipe.push message_queue (queue_item request)
      | Bounded_buffer message_queue ->
          Lwt_pipe.push message_queue (queue_item request)

    let push_request_now (w : infinite queue t) request =
      let (Queue_buffer message_queue) = w.buffer in
      Lwt_pipe.push_now_exn message_queue (queue_item request)

    let try_push_request_now (w : bounded queue t) request =
      let (Bounded_buffer message_queue) = w.buffer in
      Lwt_pipe.push_now message_queue (queue_item request)

    let push_request_and_wait (type a) (w : a queue t) request =
      let message_queue =
        match w.buffer with
        | Queue_buffer message_queue ->
            message_queue
        | Bounded_buffer message_queue ->
            message_queue
      in
      push_request_and_wait w message_queue request

    let pending_requests (type a) (w : a queue t) =
      let message_queue =
        match w.buffer with
        | Queue_buffer message_queue ->
            message_queue
        | Bounded_buffer message_queue ->
            message_queue
      in
      List.map
        (function (t, Message (req, _)) -> (t, Request.view req))
        (Lwt_pipe.peek_all message_queue)

    let pending_requests_length (type a) (w : a queue t) =
      let pipe_length (type a) (q : a buffer) =
        match q with
        | Queue_buffer queue ->
            Lwt_pipe.length queue
        | Bounded_buffer queue ->
            Lwt_pipe.length queue
        | Dropbox_buffer _ ->
            1
      in
      pipe_length w.buffer
  end

  let close (type a) (w : a t) =
    let wakeup = function
      | (_, Message (_, Some u)) ->
          let name = Format.asprintf "%a" Name.pp w.name in
          Lwt.wakeup_later u (error (Closed {base = base_name; name}))
      | (_, Message (_, None)) ->
          ()
    in
    let close_queue message_queue =
      let messages = Lwt_pipe.pop_all_now message_queue in
      List.iter wakeup messages ;
      Lwt_pipe.close message_queue
    in
    match w.buffer with
    | Queue_buffer message_queue ->
        close_queue message_queue
    | Bounded_buffer message_queue ->
        close_queue message_queue
    | Dropbox_buffer message_box ->
        Option.iter ~f:wakeup (Lwt_dropbox.peek message_box) ;
        Lwt_dropbox.close message_box

  let pop (type a) (w : a t) =
    let pop_queue message_queue =
      match w.timeout with
      | None ->
          Lwt_pipe.pop message_queue >>= fun m -> return_some m
      | Some timeout ->
          Lwt_pipe.pop_with_timeout (Systime_os.sleep timeout) message_queue
          >>= fun m -> return m
    in
    match w.buffer with
    | Queue_buffer message_queue ->
        pop_queue message_queue
    | Bounded_buffer message_queue ->
        pop_queue message_queue
    | Dropbox_buffer message_box -> (
      match w.timeout with
      | None ->
          Lwt_dropbox.take message_box >>= fun m -> return_some m
      | Some timeout ->
          Lwt_dropbox.take_with_timeout (Systime_os.sleep timeout) message_box
          >>= fun m -> return m )

  let trigger_shutdown w = Lwt.ignore_result (Lwt_canceler.cancel w.canceler)

  let canceler {canceler; _} = canceler

  let lwt_emit w (status : Logger.status) =
    let (module LogEvent) = w.logEvent in
    let time = Systime_os.now () in
    LogEvent.emit
      ~section:(Internal_event.Section.make_sanitized Name.base)
      (fun () -> Time.System.stamp ~time status)
    >>= function
    | Ok () ->
        Lwt.return_unit
    | Error el ->
        Format.kasprintf
          Lwt.fail_with
          "Worker_event.emit: %a"
          pp_print_error
          el

  let log_event w evt =
    lwt_emit w (Logger.WorkerEvent evt)
    >>= fun () ->
    if Event.level evt >= w.limits.backlog_level then
      Ring.add (List.assoc (Event.level evt) w.event_log) evt ;
    Lwt.return_unit

  let record_event w evt = Lwt.ignore_result (log_event w evt)

  module type HANDLERS = sig
    type self

    val on_launch :
      self -> Name.t -> Types.parameters -> Types.state tzresult Lwt.t

    val on_request : self -> 'a Request.t -> 'a tzresult Lwt.t

    val on_no_request : self -> unit tzresult Lwt.t

    val on_close : self -> unit Lwt.t

    val on_error :
      self ->
      Request.view ->
      Worker_types.request_status ->
      error list ->
      unit tzresult Lwt.t

    val on_completion :
      self -> 'a Request.t -> 'a -> Worker_types.request_status -> unit Lwt.t
  end

  let create_table buffer_kind =
    {buffer_kind; last_id = 0; instances = Hashtbl.create 10}

  let worker_loop (type kind) handlers (w : kind t) =
    let (module Handlers : HANDLERS with type self = kind t) = handlers in
    let do_close errs =
      let t0 =
        match w.status with
        | Running t0 ->
            t0
        | Launching _ | Closing _ | Closed _ ->
            assert false
      in
      w.status <- Closing (t0, Systime_os.now ()) ;
      close w ;
      Lwt_canceler.cancel w.canceler
      >>= fun () ->
      w.status <- Closed (t0, Systime_os.now (), errs) ;
      Hashtbl.remove w.table.instances w.name ;
      Handlers.on_close w
      >>= fun () ->
      w.state <- None ;
      Lwt.ignore_result
        ( List.iter (fun (_, ring) -> Ring.clear ring) w.event_log ;
          Lwt.return_unit ) ;
      Lwt.return_unit
    in
    let rec loop () =
      protect ~canceler:w.canceler (fun () -> pop w)
      >>=? (function
             | None ->
                 Handlers.on_no_request w
             | Some (pushed, Message (request, u)) -> (
                 let current_request = Request.view request in
                 let treated = Systime_os.now () in
                 w.current_request <- Some (pushed, treated, current_request) ;
                 match u with
                 | None ->
                     Handlers.on_request w request
                     >>=? fun res ->
                     let completed = Systime_os.now () in
                     w.current_request <- None ;
                     let status = Worker_types.{pushed; treated; completed} in
                     Handlers.on_completion w request res status
                     >>= fun () ->
                     lwt_emit w (Request (current_request, status, None))
                     >>= fun () -> return_unit
                 | Some u ->
                     Handlers.on_request w request
                     >>= fun res ->
                     Lwt.wakeup_later u res ;
                     Lwt.return res
                     >>=? fun res ->
                     let completed = Systime_os.now () in
                     let status = Worker_types.{pushed; treated; completed} in
                     w.current_request <- None ;
                     Handlers.on_completion w request res status
                     >>= fun () ->
                     lwt_emit w (Request (current_request, status, None))
                     >>= fun () -> return_unit ))
      >>= function
      | Ok () ->
          loop ()
      | Error (Canceled :: _)
      | Error (Exn Lwt.Canceled :: _)
      | Error (Exn Lwt_pipe.Closed :: _)
      | Error (Exn Lwt_dropbox.Closed :: _) ->
          lwt_emit w Terminated >>= fun () -> do_close None
      | Error errs -> (
          ( match w.current_request with
          | Some (pushed, treated, request) ->
              let completed = Systime_os.now () in
              w.current_request <- None ;
              Handlers.on_error
                w
                request
                Worker_types.{pushed; treated; completed}
                errs
          | None ->
              assert false )
          >>= function
          | Ok () ->
              loop ()
          | Error (Timeout :: _ as errs) ->
              lwt_emit w Terminated >>= fun () -> do_close (Some errs)
          | Error errs ->
              lwt_emit w (Crashed errs) >>= fun () -> do_close (Some errs) )
    in
    loop ()

  let launch :
      type kind.
      kind table ->
      ?timeout:Time.System.Span.t ->
      Worker_types.limits ->
      Name.t ->
      Types.parameters ->
      (module HANDLERS with type self = kind t) ->
      kind t tzresult Lwt.t =
   fun table ?timeout limits name parameters (module Handlers) ->
    let name_s = Format.asprintf "%a" Name.pp name in
    let full_name =
      if name_s = "" then base_name
      else Format.asprintf "%s_%s" base_name name_s
    in
    if Hashtbl.mem table.instances name then
      invalid_arg
        (Format.asprintf "Worker.launch: duplicate worker %s" full_name)
    else
      let id =
        table.last_id <- table.last_id + 1 ;
        table.last_id
      in
      let id_name =
        if name_s = "" then base_name else Format.asprintf "%s_%d" base_name id
      in
      let canceler = Lwt_canceler.create () in
      let buffer : kind buffer =
        match table.buffer_kind with
        | Queue ->
            Queue_buffer (Lwt_pipe.create ())
        | Bounded {size} ->
            Bounded_buffer (Lwt_pipe.create ~size:(size, fun _ -> 1) ())
        | Dropbox _ ->
            Dropbox_buffer (Lwt_dropbox.create ())
      in
      let event_log =
        let levels =
          Internal_event.[Debug; Info; Notice; Warning; Error; Fatal]
        in
        List.map (fun l -> (l, Ring.create limits.backlog_size)) levels
      in
      let module Definition = Logger.MakeDefinition (struct
        let worker_name = id_name
      end) in
      let module LogEvent = Internal_event.Make (Definition) in
      let w =
        {
          limits;
          parameters;
          name;
          canceler;
          table;
          buffer;
          state = None;
          id;
          worker = Lwt.return_unit;
          event_log;
          timeout;
          current_request = None;
          logEvent = (module LogEvent);
          status = Launching (Systime_os.now ());
        }
      in
      Hashtbl.add table.instances name w ;
      ( if id_name = base_name then lwt_emit w (Started None)
      else lwt_emit w (Started (Some name_s)) )
      >>= fun () ->
      Handlers.on_launch w name parameters
      >>=? fun state ->
      w.status <- Running (Systime_os.now ()) ;
      w.state <- Some state ;
      w.worker <-
        Lwt_utils.worker
          full_name
          ~on_event:Internal_event.Lwt_worker_event.on_event
          ~run:(fun () -> worker_loop (module Handlers) w)
          ~cancel:(fun () -> Lwt_canceler.cancel w.canceler) ;
      return w

  let shutdown w =
    lwt_emit w Triggering_shutdown
    >>= fun () -> Lwt_canceler.cancel w.canceler >>= fun () -> w.worker

  let state w =
    match (w.state, w.status) with
    | (None, Launching _) ->
        invalid_arg
          (Format.asprintf
             "Worker.state (%s[%a]): state called before worker was initialized"
             base_name
             Name.pp
             w.name)
    | (None, (Closing _ | Closed _)) ->
        invalid_arg
          (Format.asprintf
             "Worker.state (%s[%a]): state called after worker was terminated"
             base_name
             Name.pp
             w.name)
    | (None, _) ->
        assert false
    | (Some state, _) ->
        state

  let pending_requests q = Queue.pending_requests q

  let last_events w =
    List.map (fun (level, ring) -> (level, Ring.elements ring)) w.event_log

  let status {status; _} = status

  let current_request {current_request; _} = current_request

  let information (type a) (w : a t) =
    {
      Worker_types.instances_number = Hashtbl.length w.table.instances;
      wstatus = w.status;
      queue_length =
        ( match w.buffer with
        | Queue_buffer pipe ->
            Lwt_pipe.length pipe
        | Bounded_buffer pipe ->
            Lwt_pipe.length pipe
        | Dropbox_buffer _ ->
            1 );
    }

  let view w = Types.view (state w) w.parameters

  let list {instances; _} =
    Hashtbl.fold (fun n w acc -> (n, w) :: acc) instances []

  let find_opt {instances; _} = Hashtbl.find_opt instances

  (* TODO? add a list of cancelers for nested protection ? *)
  let protect {canceler; _} ?on_error f = protect ?on_error ~canceler f
end
src/lib_shell/worker.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module NAME.
  Record signature {t : Type} := {
    base : list string;
    t := t;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
    pp : Stdlib.Format.formatter -> t -> unit;
  }.
  Arguments signature : clear implicits.
End NAME.

Module EVENT.
  Record signature {t : Type} := {
    t := t;
    level : t -> Tezos_base__TzPervasives.Internal_event.level;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
    pp : Stdlib.Format.formatter -> t -> unit;
  }.
  Arguments signature : clear implicits.
End EVENT.

Module REQUEST.
  Record signature {t view : Type} := {
    polymorphic_abstract_type;
    view := view;
    view : forall {a : Type}, (t a) -> view;
    encoding : Tezos_base__TzPervasives.Data_encoding.t view;
    pp : Stdlib.Format.formatter -> view -> unit;
  }.
  Arguments signature : clear implicits.
End REQUEST.

Module TYPES.
  Record signature {state parameters view : Type} := {
    state := state;
    parameters := parameters;
    view := view;
    view : state -> parameters -> view;
    encoding : Tezos_base__TzPervasives.Data_encoding.t view;
    pp : Stdlib.Format.formatter -> view -> unit;
  }.
  Arguments signature : clear implicits.
End TYPES.

Module LOGGER.
  Record signature {Event_t Request_t Request_view status : Type} := {
    Event : EVENT.signature Event_t;
    Request : REQUEST.signature Request_t Request_view;
    status := status;
    t := Tezos_base__TzPervasives.Time.System.stamped status;
    MakeDefinition : functor;
  }.
  Arguments signature : clear implicits.
End LOGGER.

Record worker_name := {
  base : string;
  name : string }.

Module T.
  Record signature {Name_t Event_t Request_t Request_view Types_state
    Types_parameters Types_view t table queue bounded infinite dropbox
    buffer_kind any_request : Type} := {
    Name : NAME.signature Name_t;
    Event : EVENT.signature Event_t;
    Request : REQUEST.signature Request_t Request_view;
    Types : TYPES.signature Types_state Types_parameters Types_view;
    polymorphic_abstract_type;
    polymorphic_abstract_type;
    mutual_type;
    dropbox := dropbox;
    mutual_type;
    create_table : forall {kind : Type}, (buffer_kind kind) -> table kind;
    module_type;
    launch : forall {kind : Type}, (table kind) ->
      (option Tezos_base__TzPervasives.Time.System.Span.t) ->
        Tezos_shell_services.Worker_types.limits ->
          Name.(NAME.t) ->
            Types.(TYPES.parameters) ->
              {_ : unit & HANDLERS.signature (t kind)} ->
                Lwt.t (Tezos_base__TzPervasives.tzresult (t kind));
    shutdown : forall {_ : Type}, (t _) -> Lwt.t unit;
    module_type;
    module_type;
    module_type;
    Dropbox : signature;
    Queue : signature;
    protect : forall {_ b : Type}, (t _) ->
      (option
        ((list Tezos_base__TzPervasives.error) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult b))) ->
        (unit -> Lwt.t (Tezos_base__TzPervasives.tzresult b)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult b);
    canceler : forall {_ : Type}, (t _) ->
      Tezos_base__TzPervasives.Lwt_canceler.t;
    trigger_shutdown : forall {_ : Type}, (t _) -> unit;
    record_event : forall {_ : Type}, (t _) -> Event.(EVENT.t) -> unit;
    log_event : forall {_ : Type}, (t _) -> Event.(EVENT.t) -> Lwt.t unit;
    state : forall {_ : Type}, (t _) -> Types.(TYPES.state);
    last_events : forall {_ : Type}, (t _) ->
      list
        (Tezos_base__TzPervasives.Internal_event.level * (list Event.(EVENT.t)));
    pending_requests : forall {_ : Type}, (t (queue _)) ->
      list (Tezos_base__TzPervasives.Time.System.t * Request.(REQUEST.view));
    status : forall {_ : Type}, (t _) ->
      Tezos_shell_services.Worker_types.worker_status;
    current_request : forall {_ : Type}, (t _) ->
      option
        (Tezos_base__TzPervasives.Time.System.t *
          Tezos_base__TzPervasives.Time.System.t * Request.(REQUEST.view));
    information : forall {_ : Type}, (t _) ->
      Tezos_shell_services.Worker_types.worker_information;
    view : forall {_ : Type}, (t _) -> Types.(TYPES.view);
    list : forall {a : Type}, (table a) -> list (Name.(NAME.t) * (t a));
    find_opt : forall {a : Type}, (table a) -> Name.(NAME.t) -> option (t a);
  }.
  Arguments signature : clear implicits.
End T.
src/lib_shell/worker.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Lwt based local event loops with automated introspection *)

(** {2 Parameters to build a worker group} *)

(** The name of the group of workers corresponding to an instantiation
    of {!Make}, as well as the name of each worker in that group. *)
module type NAME = sig
  (** The name/path of the worker group *)
  val base : string list

  (** The abstract name of a single worker *)
  type t

  (** Serializer for the introspection RPCs *)
  val encoding : t Data_encoding.t

  (** Pretty printer for displaying the worker name *)
  val pp : Format.formatter -> t -> unit
end

(** Events that are used for logging and introspection.
    Events are pretty printed immediately in the log, and stored in
    the worker's event backlog for introspection. *)
module type EVENT = sig
  (** The type of an event. *)
  type t

  (** Assigns a logging level to each event.
      Events can be ignored for logging w.r.t. the global node configuration.
      Events can be ignored for introspection w.r.t. to the worker's
      {!Worker_types.limits}. *)
  val level : t -> Internal_event.level

  (** Serializer for the introspection RPCs *)
  val encoding : t Data_encoding.t

  (** Pretty printer, also used for logging *)
  val pp : Format.formatter -> t -> unit
end

(** The type of messages that are fed to the worker's event loop. *)
module type REQUEST = sig
  (** The type of events.
      It is possible to wait for an event to be processed from outside
      the worker using {!push_request_and_wait}. In this case, the
      handler for this event can return a value. The parameter is the
      type of this value. *)
  type 'a t

  (** As requests can contain arbitrary data that may not be
      serializable and are polymorphic, this view type is a
      monomorphic projection sufficient for introspection. *)
  type view

  (** The projection function from full request to simple views. *)
  val view : 'a t -> view

  (** Serializer for the introspection RPCs *)
  val encoding : view Data_encoding.t

  (** Pretty printer, also used for logging by {!Request_event}. *)
  val pp : Format.formatter -> view -> unit
end

(** The (imperative) state of the event loop. *)
module type TYPES = sig
  (** The internal state that is passed to the event handlers. *)
  type state

  (** The parameters provided when launching a new worker. *)
  type parameters

  (** A simplified view of the worker's state for introspection. *)
  type view

  (** The projection function from full state to simple views. *)
  val view : state -> parameters -> view

  (** Serializer for the introspection RPCs *)
  val encoding : view Data_encoding.t

  (** Pretty printer for introspection. *)
  val pp : Format.formatter -> view -> unit
end

module type LOGGER = sig
  module Event : EVENT

  module Request : REQUEST

  type status =
    | WorkerEvent of Event.t
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Terminated
    | Timeout
    | Crashed of error list
    | Started of string option
    | Triggering_shutdown
    | Duplicate of string

  type t = status Time.System.stamped

  module MakeDefinition (Static : sig
    val worker_name : string
  end) : Internal_event.EVENT_DEFINITION with type t = t
end

(** {2 Worker group maker} *)

(** An error returned when trying to communicate with a worker that
    has been closed. *)
type worker_name = {base : string; name : string}

type Error_monad.error += Closed of worker_name

(** Functor to build a group of workers.
    At that point, all the types are fixed and introspectable,
    but the actual parameters and event handlers can be tweaked
    for each individual worker. *)
module type T = sig
  module Name : NAME

  module Event : EVENT

  module Request : REQUEST

  module Types : TYPES

  (** A handle to a specific worker, parameterized by the type of
      internal message buffer. *)
  type 'kind t

  (** A handle to a table of workers. *)
  type 'kind table

  (** Internal buffer kinds used as parameters to {!t}. *)
  type 'a queue

  and bounded

  and infinite

  type dropbox

  (** Supported kinds of internal buffers. *)
  type _ buffer_kind =
    | Queue : infinite queue buffer_kind
    | Bounded : {size : int} -> bounded queue buffer_kind
    | Dropbox : {
        merge :
          dropbox t -> any_request -> any_request option -> any_request option;
      }
        -> dropbox buffer_kind

  and any_request = Any_request : _ Request.t -> any_request

  (** Create a table of workers. *)
  val create_table : 'kind buffer_kind -> 'kind table

  (** The callback handlers specific to each worker instance. *)
  module type HANDLERS = sig
    (** Placeholder replaced with {!t} with the right parameters
        provided by the type of buffer chosen at {!launch}.*)
    type self

    (** Builds the initial internal state of a worker at launch.
        It is possible to initialize the message queue.
        Of course calling {!state} will fail at that point. *)
    val on_launch :
      self -> Name.t -> Types.parameters -> Types.state tzresult Lwt.t

    (** The main request processor, i.e. the body of the event loop. *)
    val on_request : self -> 'a Request.t -> 'a tzresult Lwt.t

    (** Called when no request has been made before the timeout, if
        the parameter has been passed to {!launch}. *)
    val on_no_request : self -> unit tzresult Lwt.t

    (** A function called when terminating a worker. *)
    val on_close : self -> unit Lwt.t

    (** A function called at the end of the worker loop in case of an
        abnormal error. This function can handle the error by
        returning [Ok ()], or leave the default unexpected error
        behavior by returning its parameter. A possibility is to
        handle the error for ad-hoc logging, and still use
        {!trigger_shutdown} to kill the worker. *)
    val on_error :
      self ->
      Request.view ->
      Worker_types.request_status ->
      error list ->
      unit tzresult Lwt.t

    (** A function called at the end of the worker loop in case of a
        successful treatment of the current request. *)
    val on_completion :
      self -> 'a Request.t -> 'a -> Worker_types.request_status -> unit Lwt.t
  end

  (** Creates a new worker instance.
      Parameter [queue_size] not passed means unlimited queue. *)
  val launch :
    'kind table ->
    ?timeout:Time.System.Span.t ->
    Worker_types.limits ->
    Name.t ->
    Types.parameters ->
    (module HANDLERS with type self = 'kind t) ->
    'kind t tzresult Lwt.t

  (** Triggers a worker termination and waits for its completion.
      Cannot be called from within the handlers.  *)
  val shutdown : _ t -> unit Lwt.t

  (** The following interface are common elements of multiple modules below.
      They are used to minimize repetition. *)
  module type BOX = sig
    (** With [BOX]es, you can put a request right at the front *)
    type t

    val put_request : t -> 'a Request.t -> unit

    val put_request_and_wait : t -> 'a Request.t -> 'a tzresult Lwt.t
  end

  module type QUEUE = sig
    (** With [QUEUE]s, you can push requests in the queue *)
    type 'a t

    val push_request_and_wait : 'q t -> 'a Request.t -> 'a tzresult Lwt.t

    val push_request : 'q t -> 'a Request.t -> unit Lwt.t

    val pending_requests : 'a t -> (Time.System.t * Request.view) list

    val pending_requests_length : 'a t -> int
  end

  module type BOUNDED_QUEUE = sig
    (** With [BOUNDED_QUEUE]s, you can push requests in the queue tentatively *)
    type t

    val try_push_request_now : t -> 'a Request.t -> bool
  end

  module Dropbox : sig
    include BOX with type t := dropbox t
  end

  module Queue : sig
    include QUEUE with type 'a t := 'a queue t

    include BOUNDED_QUEUE with type t := bounded queue t

    (** Adds a message to the queue immediately. *)
    val push_request_now : infinite queue t -> 'a Request.t -> unit
  end

  (** Detects cancellation from within the request handler to stop
      asynchronous operations. *)
  val protect :
    _ t ->
    ?on_error:(error list -> 'b tzresult Lwt.t) ->
    (unit -> 'b tzresult Lwt.t) ->
    'b tzresult Lwt.t

  (** Exports the canceler to allow cancellation of other tasks when this
      worker is shutdown or when it dies. *)
  val canceler : _ t -> Lwt_canceler.t

  (** Triggers a worker termination. *)
  val trigger_shutdown : _ t -> unit

  (** Record an event in the backlog. *)
  val record_event : _ t -> Event.t -> unit

  (** Record an event and make sure it is logged. *)
  val log_event : _ t -> Event.t -> unit Lwt.t

  (** Access the internal state, once initialized. *)
  val state : _ t -> Types.state

  (** Access the event backlog. *)
  val last_events : _ t -> (Internal_event.level * Event.t list) list

  (** Introspect the message queue, gives the times requests were pushed. *)
  val pending_requests : _ queue t -> (Time.System.t * Request.view) list

  (** Get the running status of a worker. *)
  val status : _ t -> Worker_types.worker_status

  (** Get the request being treated by a worker.
      Gives the time the request was pushed, and the time its
      treatment started. *)
  val current_request :
    _ t -> (Time.System.t * Time.System.t * Request.view) option

  val information : _ t -> Worker_types.worker_information

  (** Introspect the state of a worker. *)
  val view : _ t -> Types.view

  (** Lists the running workers in this group. *)
  val list : 'a table -> (Name.t * 'a t) list

  (** [find_opt table n] is [Some worker] if the [worker] is in the [table] and
      has name [n]. *)
  val find_opt : 'a table -> Name.t -> 'a t option
end

module Make
    (Name : NAME)
    (Event : EVENT)
    (Request : REQUEST)
    (Types : TYPES)
    (Logger : LOGGER with module Event = Event and module Request = Request) :
  T
    with module Name = Name
     and module Event = Event
     and module Request = Request
     and module Types = Types
src/lib_shell/worker.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

module_type

module_type

module_type

Record worker_name := {
  base : string;
  name : string }.

extensible_type

module_type

unhandled_module
src/lib_shell/worker_directory.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let build_rpc_directory state =
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let register0 s f =
    dir := RPC_directory.register !dir s (fun () p q -> f p q)
  in
  let register1 s f =
    dir := RPC_directory.register !dir s (fun ((), a) p q -> f a p q)
  in
  let register2 s f =
    dir := RPC_directory.register !dir s (fun (((), a), b) p q -> f a b p q)
  in
  (* Workers : Prevalidators *)
  register0 Worker_services.Prevalidators.S.list (fun () () ->
      let workers = Prevalidator.running_workers () in
      let statuses =
        List.map
          (fun (chain_id, _, t) ->
            ( chain_id,
              Prevalidator.status t,
              Prevalidator.information t,
              Prevalidator.pipeline_length t ))
          workers
      in
      return statuses) ;
  register1 Worker_services.Prevalidators.S.state (fun chain () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      let workers = Prevalidator.running_workers () in
      let (_, _, t) =
        (* NOTE: it is technically possible to use the Prevalidator interface to
         * register multiple Prevalidator for a single chain (using distinct
         * protocols). However, this is never done. *)
        List.find (fun (c, _, _) -> Chain_id.equal c chain_id) workers
      in
      let status = Prevalidator.status t in
      let pending_requests = Prevalidator.pending_requests t in
      let backlog = Prevalidator.last_events t in
      let current_request = Prevalidator.current_request t in
      return {Worker_types.status; pending_requests; backlog; current_request}) ;
  (* Workers : Block_validator *)
  register0 Worker_services.Block_validator.S.state (fun () () ->
      let w = Block_validator.running_worker () in
      return
        {
          Worker_types.status = Block_validator.status w;
          pending_requests = Block_validator.pending_requests w;
          backlog = Block_validator.last_events w;
          current_request = Block_validator.current_request w;
        }) ;
  (* Workers : Peer validators *)
  register1 Worker_services.Peer_validators.S.list (fun chain () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      return
        (List.filter_map
           (fun ((id, peer_id), w) ->
             if Chain_id.equal id chain_id then
               Some
                 ( peer_id,
                   Peer_validator.status w,
                   Peer_validator.information w,
                   Peer_validator.pipeline_length w )
             else None)
           (Peer_validator.running_workers ()))) ;
  register2 Worker_services.Peer_validators.S.state (fun chain peer_id () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      let w =
        List.assoc (chain_id, peer_id) (Peer_validator.running_workers ())
      in
      return
        {
          Worker_types.status = Peer_validator.status w;
          pending_requests = [];
          backlog = Peer_validator.last_events w;
          current_request = Peer_validator.current_request w;
        }) ;
  (* Workers : Net validators *)
  register0 Worker_services.Chain_validators.S.list (fun () () ->
      return
        (List.map
           (fun (id, w) ->
             ( id,
               Chain_validator.status w,
               Chain_validator.information w,
               Chain_validator.pending_requests_length w ))
           (Chain_validator.running_workers ()))) ;
  register1 Worker_services.Chain_validators.S.state (fun chain () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      let w = List.assoc chain_id (Chain_validator.running_workers ()) in
      return
        {
          Worker_types.status = Chain_validator.status w;
          pending_requests = Chain_validator.pending_requests w;
          backlog = Chain_validator.last_events w;
          current_request = Chain_validator.current_request w;
        }) ;
  (* DistributedDB *)
  register1 Worker_services.Chain_validators.S.ddb_state (fun chain () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      let w = List.assoc chain_id (Chain_validator.running_workers ()) in
      return (Chain_validator.ddb_information w)) ;
  !dir
src/lib_shell/worker_directory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition build_rpc_directory (state : Tezos_shell.State.t)
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  let dir := Stdlib.ref Tezos_base__TzPervasives.RPC_directory.empty in
  let register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | tt => fun p => fun q => f p q
          end)) in
  let register1 {A B C D : Type}
    (s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
    A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | (tt, a) => fun p => fun q => f a p q
          end)) in
  let register2 {A B C D E : Type}
    (s : Tezos_rpc.RPC_service.t variant unit ((unit * A) * B) C D E) (f :
    A -> B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E))
    : unit :=
    Stdlib.op_colon_eq dir
      (Tezos_base__TzPervasives.RPC_directory.register
        (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          match function_parameter with
          | ((tt, a), b) => fun p => fun q => f a b p q
          end)) in
  register0 Tezos_shell_services.Worker_services.Prevalidators.S.list
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            let workers := Tezos_shell.Prevalidator.running_workers tt in
            let statuses :=
              Tezos_base__TzPervasives.List.map
                (fun function_parameter =>
                  match function_parameter with
                  | (chain_id, _, t) =>
                    (chain_id, (Tezos_shell.Prevalidator.status t),
                      (Tezos_shell.Prevalidator.information t),
                      (Tezos_shell.Prevalidator.pipeline_length t))
                  end) workers in
            Tezos_base__TzPervasives._return statuses
          end
      end);
  register1 Tezos_shell_services.Worker_services.Prevalidators.S.state
    (fun chain =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Chain_directory.get_chain_id state chain)
                (fun chain_id =>
                  let workers := Tezos_shell.Prevalidator.running_workers tt in
                  match
                    Tezos_base__TzPervasives.List.find
                      (fun function_parameter =>
                        match function_parameter with
                        | (c, _, _) =>
                          Tezos_base__TzPervasives.Chain_id.equal c chain_id
                        end) workers with
                  | (_, _, t) =>
                    let status := Tezos_shell.Prevalidator.status t in
                    let pending_requests :=
                      Tezos_shell.Prevalidator.pending_requests t in
                    let backlog := Tezos_shell.Prevalidator.last_events t in
                    let current_request :=
                      Tezos_shell.Prevalidator.current_request t in
                    Tezos_base__TzPervasives._return
                      {| Worker_types.status := status;
                        Worker_types.pending_requests := pending_requests;
                        Worker_types.backlog := backlog;
                        Worker_types.current_request := current_request |}
                  end)
            end
        end);
  register0 Tezos_shell_services.Worker_services.Block_validator.S.state
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            let w := Tezos_shell.Block_validator.running_worker tt in
            Tezos_base__TzPervasives._return
              {| Worker_types.status := Tezos_shell.Block_validator.status w;
                Worker_types.pending_requests :=
                  Tezos_shell.Block_validator.pending_requests w;
                Worker_types.backlog :=
                  Tezos_shell.Block_validator.last_events w;
                Worker_types.current_request :=
                  Tezos_shell.Block_validator.current_request w |}
          end
      end);
  register1 Tezos_shell_services.Worker_services.Peer_validators.S.list
    (fun chain =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Chain_directory.get_chain_id state chain)
                (fun chain_id =>
                  Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.List.filter_map
                      (fun function_parameter =>
                        match function_parameter with
                        | ((id, peer_id), w) =>
                          if Tezos_base__TzPervasives.Chain_id.equal id chain_id
                            then
                            Some
                              (peer_id, (Tezos_shell.Peer_validator.status w),
                                (Tezos_shell.Peer_validator.information w),
                                (Tezos_shell.Peer_validator.pipeline_length w))
                          else
                            None
                        end) (Tezos_shell.Peer_validator.running_workers tt)))
            end
        end);
  register2 Tezos_shell_services.Worker_services.Peer_validators.S.state
    (fun chain =>
      fun peer_id =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_shell.Chain_directory.get_chain_id state chain)
                  (fun chain_id =>
                    let w :=
                      Tezos_base__TzPervasives.List.assoc (chain_id, peer_id)
                        (Tezos_shell.Peer_validator.running_workers tt) in
                    Tezos_base__TzPervasives._return
                      {|
                        Worker_types.status :=
                          Tezos_shell.Peer_validator.status w;
                        Worker_types.pending_requests := [];
                        Worker_types.backlog :=
                          Tezos_shell.Peer_validator.last_events w;
                        Worker_types.current_request :=
                          Tezos_shell.Peer_validator.current_request w |})
              end
          end);
  register0 Tezos_shell_services.Worker_services.Chain_validators.S.list
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives._return
              (Tezos_base__TzPervasives.List.map
                (fun function_parameter =>
                  match function_parameter with
                  | (id, w) =>
                    (id, (Tezos_shell.Chain_validator.status w),
                      (Tezos_shell.Chain_validator.information w),
                      (Tezos_shell.Chain_validator.pending_requests_length w))
                  end) (Tezos_shell.Chain_validator.running_workers tt))
          end
      end);
  register1 Tezos_shell_services.Worker_services.Chain_validators.S.state
    (fun chain =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Chain_directory.get_chain_id state chain)
                (fun chain_id =>
                  let w :=
                    Tezos_base__TzPervasives.List.assoc chain_id
                      (Tezos_shell.Chain_validator.running_workers tt) in
                  Tezos_base__TzPervasives._return
                    {|
                      Worker_types.status :=
                        Tezos_shell.Chain_validator.status w;
                      Worker_types.pending_requests :=
                        Tezos_shell.Chain_validator.pending_requests w;
                      Worker_types.backlog :=
                        Tezos_shell.Chain_validator.last_events w;
                      Worker_types.current_request :=
                        Tezos_shell.Chain_validator.current_request w |})
            end
        end);
  register1 Tezos_shell_services.Worker_services.Chain_validators.S.ddb_state
    (fun chain =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_shell.Chain_directory.get_chain_id state chain)
                (fun chain_id =>
                  let w :=
                    Tezos_base__TzPervasives.List.assoc chain_id
                      (Tezos_shell.Chain_validator.running_workers tt) in
                  Tezos_base__TzPervasives._return
                    (Tezos_shell.Chain_validator.ddb_information w))
            end
        end);
  Stdlib.op_exclamation dir.
src/lib_shell/worker_directory.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val build_rpc_directory : State.t -> unit RPC_directory.t
src/lib_shell/worker_directory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter build_rpc_directory :
Tezos_shell.State.t -> Tezos_base__TzPervasives.RPC_directory.t unit.
src/lib_shell/worker_logger.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Worker

module Make (Event : EVENT) (Request : REQUEST) = struct
  module Event = Event
  module Request = Request

  type status =
    | WorkerEvent of Event.t
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Terminated
    | Timeout
    | Crashed of error list
    | Started of string option
    | Triggering_shutdown
    | Duplicate of string

  type t = status Time.System.stamped

  let status_encoding =
    let open Data_encoding in
    Time.System.stamped_encoding
    @@ union
         [ case
             (Tag 0)
             ~title:"Event"
             Event.encoding
             (function WorkerEvent e -> Some e | _ -> None)
             (fun e -> WorkerEvent e);
           case
             (Tag 1)
             ~title:"Request"
             (obj3
                (req "request_view" (dynamic_size Request.encoding))
                (req "request_status" Worker_types.request_status_encoding)
                (req "errors" (option (list error_encoding))))
             (function Request (v, s, e) -> Some (v, s, e) | _ -> None)
             (fun (v, s, e) -> Request (v, s, e));
           case
             (Tag 2)
             ~title:"Terminated"
             Data_encoding.empty
             (function Terminated -> Some () | _ -> None)
             (fun () -> Terminated);
           case
             (Tag 3)
             ~title:"Timeout"
             Data_encoding.empty
             (function Timeout -> Some () | _ -> None)
             (fun () -> Timeout);
           case
             (Tag 4)
             ~title:"Crashed"
             (list error_encoding)
             (function Crashed errs -> Some errs | _ -> None)
             (fun errs -> Crashed errs);
           case
             (Tag 5)
             ~title:"Started"
             (option string)
             (function Started n -> Some n | _ -> None)
             (fun n -> Started n);
           case
             (Tag 6)
             ~title:"Triggering_shutdown"
             Data_encoding.empty
             (function Triggering_shutdown -> Some () | _ -> None)
             (fun () -> Triggering_shutdown);
           case
             (Tag 7)
             ~title:"Duplicate"
             string
             (function Duplicate n -> Some n | _ -> None)
             (fun n -> Duplicate n) ]

  let pp base_name ppf = function
    | WorkerEvent evt ->
        Format.fprintf ppf "%a" Event.pp evt
    | Request (view, {pushed; treated; completed}, None) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
    | Request (view, {pushed; treated; completed}, Some errors) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
          (Format.pp_print_list Error_monad.pp)
          errors
    | Terminated ->
        Format.fprintf ppf "@[Worker terminated [%s] @]" base_name
    | Timeout ->
        Format.fprintf ppf "@[Worker terminated with timeout [%s] @]" base_name
    | Crashed errs ->
        Format.fprintf
          ppf
          "@[<v 0>Worker crashed [%s]:@,%a@]"
          base_name
          (Format.pp_print_list Error_monad.pp)
          errs
    | Started None ->
        Format.fprintf ppf "Worker started"
    | Started (Some n) ->
        Format.fprintf ppf "Worker started for %s" n
    | Triggering_shutdown ->
        Format.fprintf ppf "Triggering shutdown"
    | Duplicate name ->
        let full_name =
          if name = "" then base_name
          else Format.asprintf "%s_%s" base_name name
        in
        Format.fprintf ppf "Worker.launch: duplicate worker %s" full_name

  module MakeDefinition (Static : sig
    val worker_name : string
  end) : Internal_event.EVENT_DEFINITION with type t = t = struct
    let name = Static.worker_name

    type nonrec t = t

    let encoding =
      let open Data_encoding in
      let v0_encoding = status_encoding in
      With_version.(encoding ~name (first_version v0_encoding))

    let pp ppf (status : t) =
      Format.fprintf ppf "%a" (pp Static.worker_name) status.data

    let doc = "Worker status."

    let level (status : t) =
      match status.data with
      | WorkerEvent evt ->
          Event.level evt
      | Request _ ->
          Internal_event.Debug
      | Terminated | Timeout | Started _ ->
          Internal_event.Notice
      | Crashed _ ->
          Internal_event.Error
      | Triggering_shutdown ->
          Internal_event.Debug
      | Duplicate _ ->
          Internal_event.Error
  end
end
src/lib_shell/worker_logger.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell.Worker.
src/lib_shell_services/block_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

type chain = [`Main | `Test | `Hash of Chain_id.t]

let parse_chain s =
  try
    match s with
    | "main" ->
        Ok `Main
    | "test" ->
        Ok `Test
    | h ->
        Ok (`Hash (Chain_id.of_b58check_exn h))
  with _ -> Error "Cannot parse chain identifier."

let chain_to_string = function
  | `Main ->
      "main"
  | `Test ->
      "test"
  | `Hash h ->
      Chain_id.to_b58check h

let chain_arg =
  let name = "chain_id" in
  let descr =
    "A chain identifier. This is either a chain hash in Base58Check notation \
     or a one the predefined aliases: 'main', 'test'."
  in
  let construct = chain_to_string in
  let destruct = parse_chain in
  RPC_arg.make ~name ~descr ~construct ~destruct ()

type block =
  [ `Genesis
  | `Head of int
  | `Alias of [`Caboose | `Checkpoint | `Save_point] * int
  | `Hash of Block_hash.t * int
  | `Level of Int32.t ]

let parse_block s =
  let delims = ['~'; '-'; '+'] in
  let count_delims s =
    List.map
      (fun d ->
        (String.fold_left (fun i c -> if c = d then i + 1 else i) 0 s, d))
      delims
  in
  let split_on_delim counts =
    match List.fold_left (fun i (v, _) -> i + v) 0 counts with
    | 0 ->
        ([s], ' ')
    | 1 ->
        let delim = List.assoc 1 counts in
        (String.split delim s, delim)
    | _ ->
        raise Exit
  in
  try
    match split_on_delim (count_delims s) with
    | (["genesis"], _) ->
        Ok `Genesis
    | (["genesis"; n], '+') ->
        Ok (`Level (Int32.of_string n))
    | (["head"], _) ->
        Ok (`Head 0)
    | (["head"; n], '~') | (["head"; n], '-') ->
        Ok (`Head (int_of_string n))
    | (["checkpoint"], _) ->
        Ok (`Alias (`Checkpoint, 0))
    | (["checkpoint"; n], '~') | (["checkpoint"; n], '-') ->
        Ok (`Alias (`Checkpoint, int_of_string n))
    | (["checkpoint"; n], '+') ->
        Ok (`Alias (`Checkpoint, -int_of_string n))
    | (["save_point"], _) ->
        Ok (`Alias (`Save_point, 0))
    | (["save_point"; n], '~') | (["save_point"; n], '-') ->
        Ok (`Alias (`Save_point, int_of_string n))
    | (["save_point"; n], '+') ->
        Ok (`Alias (`Save_point, -int_of_string n))
    | (["caboose"], _) ->
        Ok (`Alias (`Caboose, 0))
    | (["caboose"; n], '~') | (["caboose"; n], '-') ->
        Ok (`Alias (`Caboose, int_of_string n))
    | (["caboose"; n], '+') ->
        Ok (`Alias (`Caboose, -int_of_string n))
    | ([hol], _) -> (
      match Block_hash.of_b58check_opt hol with
      | Some h ->
          Ok (`Hash (h, 0))
      | None ->
          let l = Int32.of_string s in
          if Compare.Int32.(l < 0l) then raise Exit
          else if Compare.Int32.(l = 0l) then Ok `Genesis
          else Ok (`Level (Int32.of_string s)) )
    | ([h; n], '~') | ([h; n], '-') ->
        Ok (`Hash (Block_hash.of_b58check_exn h, int_of_string n))
    | ([h; n], '+') ->
        Ok (`Hash (Block_hash.of_b58check_exn h, -int_of_string n))
    | _ ->
        raise Exit
  with _ -> Error "Cannot parse block identifier."

let alias_to_string = function
  | `Checkpoint ->
      "checkpoint"
  | `Save_point ->
      "save_point"
  | `Caboose ->
      "caboose"

let to_string = function
  | `Genesis ->
      "genesis"
  | `Alias (a, 0) ->
      alias_to_string a
  | `Alias (a, n) when n < 0 ->
      Printf.sprintf "%s+%d" (alias_to_string a) (-n)
  | `Alias (a, n) ->
      Printf.sprintf "%s~%d" (alias_to_string a) n
  | `Head 0 ->
      "head"
  | `Head n when n < 0 ->
      Printf.sprintf "head+%d" (-n)
  | `Head n ->
      Printf.sprintf "head~%d" n
  | `Hash (h, 0) ->
      Block_hash.to_b58check h
  | `Hash (h, n) when n < 0 ->
      Printf.sprintf "%s+%d" (Block_hash.to_b58check h) (-n)
  | `Hash (h, n) ->
      Printf.sprintf "%s~%d" (Block_hash.to_b58check h) n
  | `Level i ->
      Printf.sprintf "%d" (Int32.to_int i)

let blocks_arg =
  let name = "block_id" in
  let descr =
    "A block identifier. This is either a block hash in Base58Check notation, \
     one the predefined aliases: 'genesis', 'head' or a block level (index in \
     the chain). One might also use 'head~N' or '<hash>~N' where N is an \
     integer to denote the Nth predecessor of the designated block.Also, \
     '<hash>+N' denotes the Nth successor of a block."
  in
  let construct = to_string in
  let destruct = parse_block in
  RPC_arg.make ~name ~descr ~construct ~destruct ()

type chain_prefix = unit * chain

type prefix = chain_prefix * block

let chain_path = RPC_path.(root / "chains" /: chain_arg)

let mempool_path p = RPC_path.(p / "mempool")

let live_blocks_path p = RPC_path.(p / "live_blocks")

let dir_path : (chain_prefix, chain_prefix) RPC_path.t =
  RPC_path.(open_root / "blocks")

let path = RPC_path.(dir_path /: blocks_arg)

type operation_list_quota = {max_size : int; max_op : int option}

let operation_list_quota_encoding =
  conv
    (fun {max_size; max_op} -> (max_size, max_op))
    (fun (max_size, max_op) -> {max_size; max_op})
    (obj2 (req "max_size" int31) (opt "max_op" int31))

type raw_context = Key of Bytes.t | Dir of (string * raw_context) list | Cut

let rec pp_raw_context ppf = function
  | Cut ->
      Format.fprintf ppf "..."
  | Key v ->
      Hex.pp ppf (Hex.of_bytes v)
  | Dir l ->
      Format.fprintf
        ppf
        "{@[<v 1>@,%a@]@,}"
        (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf (s, t) ->
             Format.fprintf ppf "%s : %a" s pp_raw_context t))
        l

let raw_context_encoding =
  mu "raw_context" (fun encoding ->
      union
        [ case
            (Tag 0)
            bytes
            ~title:"Key"
            (function Key k -> Some k | _ -> None)
            (fun k -> Key k);
          case
            (Tag 1)
            (assoc encoding)
            ~title:"Dir"
            (function Dir k -> Some k | _ -> None)
            (fun k -> Dir k);
          case
            (Tag 2)
            null
            ~title:"Cut"
            (function Cut -> Some () | _ -> None)
            (fun () -> Cut) ])

type error += Invalid_depth_arg of int

let () =
  register_error_kind
    `Permanent
    ~id:"raw_context.invalid_depth"
    ~title:"Invalid depth argument"
    ~description:"The raw context extraction depth argument must be positive."
    ~pp:(fun ppf depth ->
      Format.fprintf ppf "Extraction depth %d is invalid" depth)
    Data_encoding.(obj1 (req "depth" int31))
    (function Invalid_depth_arg depth -> Some depth | _ -> None)
    (fun depth -> Invalid_depth_arg depth)

module type PROTO = sig
  val hash : Protocol_hash.t

  type block_header_data

  val block_header_data_encoding : block_header_data Data_encoding.t

  type block_header_metadata

  val block_header_metadata_encoding : block_header_metadata Data_encoding.t

  type operation_data

  type operation_receipt

  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  val operation_data_encoding : operation_data Data_encoding.t

  val operation_receipt_encoding : operation_receipt Data_encoding.t

  val operation_data_and_receipt_encoding :
    (operation_data * operation_receipt) Data_encoding.t
end

type protocols = {
  current_protocol : Protocol_hash.t;
  next_protocol : Protocol_hash.t;
}

let raw_protocol_encoding =
  conv
    (fun {current_protocol; next_protocol} ->
      ((current_protocol, next_protocol), ()))
    (fun ((current_protocol, next_protocol), ()) ->
      {current_protocol; next_protocol})
    (merge_objs
       (obj2
          (req "protocol" Protocol_hash.encoding)
          (req "next_protocol" Protocol_hash.encoding))
       unit)

module Make (Proto : PROTO) (Next_proto : PROTO) = struct
  let protocol_hash = Protocol_hash.to_b58check Proto.hash

  let next_protocol_hash = Protocol_hash.to_b58check Next_proto.hash

  type raw_block_header = {
    shell : Block_header.shell_header;
    protocol_data : Proto.block_header_data;
  }

  let raw_block_header_encoding =
    def "raw_block_header"
    @@ conv
         (fun {shell; protocol_data} -> (shell, protocol_data))
         (fun (shell, protocol_data) -> {shell; protocol_data})
         (merge_objs
            Block_header.shell_header_encoding
            Proto.block_header_data_encoding)

  type block_header = {
    chain_id : Chain_id.t;
    hash : Block_hash.t;
    shell : Block_header.shell_header;
    protocol_data : Proto.block_header_data;
  }

  let block_header_encoding =
    def "block_header"
    @@ conv
         (fun {chain_id; hash; shell; protocol_data} ->
           (((), chain_id, hash), {shell; protocol_data}))
         (fun (((), chain_id, hash), {shell; protocol_data}) ->
           {chain_id; hash; shell; protocol_data})
         (merge_objs
            (obj3
               (req "protocol" (constant protocol_hash))
               (req "chain_id" Chain_id.encoding)
               (req "hash" Block_hash.encoding))
            raw_block_header_encoding)

  type block_metadata = {
    protocol_data : Proto.block_header_metadata;
    test_chain_status : Test_chain_status.t;
    (* for the next block: *)
    max_operations_ttl : int;
    max_operation_data_length : int;
    max_block_header_length : int;
    operation_list_quota : operation_list_quota list;
  }

  let block_metadata_encoding =
    def "block_header_metadata"
    @@ conv
         (fun { protocol_data;
                test_chain_status;
                max_operations_ttl;
                max_operation_data_length;
                max_block_header_length;
                operation_list_quota } ->
           ( ( (),
               (),
               test_chain_status,
               max_operations_ttl,
               max_operation_data_length,
               max_block_header_length,
               operation_list_quota ),
             protocol_data ))
         (fun ( ( (),
                  (),
                  test_chain_status,
                  max_operations_ttl,
                  max_operation_data_length,
                  max_block_header_length,
                  operation_list_quota ),
                protocol_data ) ->
           {
             protocol_data;
             test_chain_status;
             max_operations_ttl;
             max_operation_data_length;
             max_block_header_length;
             operation_list_quota;
           })
         (merge_objs
            (obj7
               (req "protocol" (constant protocol_hash))
               (req "next_protocol" (constant next_protocol_hash))
               (req "test_chain_status" Test_chain_status.encoding)
               (req "max_operations_ttl" int31)
               (req "max_operation_data_length" int31)
               (req "max_block_header_length" int31)
               (req
                  "max_operation_list_length"
                  (dynamic_size (list operation_list_quota_encoding))))
            Proto.block_header_metadata_encoding)

  let next_operation_encoding =
    let open Data_encoding in
    def "next_operation"
    @@ conv
         (fun Next_proto.{shell; protocol_data} ->
           ((), (shell, protocol_data)))
         (fun ((), (shell, protocol_data)) -> {shell; protocol_data})
         (merge_objs
            (obj1 (req "protocol" (constant next_protocol_hash)))
            (merge_objs
               (dynamic_size Operation.shell_header_encoding)
               (dynamic_size Next_proto.operation_data_encoding)))

  type operation = {
    chain_id : Chain_id.t;
    hash : Operation_hash.t;
    shell : Operation.shell_header;
    protocol_data : Proto.operation_data;
    receipt : Proto.operation_receipt;
  }

  let operation_encoding =
    def "operation"
    @@
    let open Data_encoding in
    conv
      (fun {chain_id; hash; shell; protocol_data; receipt} ->
        (((), chain_id, hash), (shell, (protocol_data, receipt))))
      (fun (((), chain_id, hash), (shell, (protocol_data, receipt))) ->
        {chain_id; hash; shell; protocol_data; receipt})
      (merge_objs
         (obj3
            (req "protocol" (constant protocol_hash))
            (req "chain_id" Chain_id.encoding)
            (req "hash" Operation_hash.encoding))
         (merge_objs
            (dynamic_size Operation.shell_header_encoding)
            (dynamic_size Proto.operation_data_and_receipt_encoding)))

  type block_info = {
    chain_id : Chain_id.t;
    hash : Block_hash.t;
    header : raw_block_header;
    metadata : block_metadata;
    operations : operation list list;
  }

  let block_info_encoding =
    conv
      (fun {chain_id; hash; header; metadata; operations} ->
        ((), chain_id, hash, header, metadata, operations))
      (fun ((), chain_id, hash, header, metadata, operations) ->
        {chain_id; hash; header; metadata; operations})
      (obj6
         (req "protocol" (constant protocol_hash))
         (req "chain_id" Chain_id.encoding)
         (req "hash" Block_hash.encoding)
         (req "header" (dynamic_size raw_block_header_encoding))
         (req "metadata" (dynamic_size block_metadata_encoding))
         (req "operations" (list (dynamic_size (list operation_encoding)))))

  module S = struct
    let path : prefix RPC_path.context = RPC_path.open_root

    let hash =
      RPC_service.get_service
        ~description:"The block's hash, its unique identifier."
        ~query:RPC_query.empty
        ~output:Block_hash.encoding
        RPC_path.(path / "hash")

    let header =
      RPC_service.get_service
        ~description:"The whole block header."
        ~query:RPC_query.empty
        ~output:block_header_encoding
        RPC_path.(path / "header")

    let raw_header =
      RPC_service.get_service
        ~description:"The whole block header (unparsed)."
        ~query:RPC_query.empty
        ~output:bytes
        RPC_path.(path / "header" / "raw")

    let metadata =
      RPC_service.get_service
        ~description:"All the metadata associated to the block."
        ~query:RPC_query.empty
        ~output:block_metadata_encoding
        RPC_path.(path / "metadata")

    let protocols =
      RPC_service.get_service
        ~description:"Current and next protocol."
        ~query:RPC_query.empty
        ~output:raw_protocol_encoding
        RPC_path.(path / "protocols")

    module Header = struct
      let path = RPC_path.(path / "header")

      let shell_header =
        RPC_service.get_service
          ~description:"The shell-specific fragment of the block header."
          ~query:RPC_query.empty
          ~output:Block_header.shell_header_encoding
          RPC_path.(path / "shell")

      let protocol_data =
        RPC_service.get_service
          ~description:"The version-specific fragment of the block header."
          ~query:RPC_query.empty
          ~output:
            (conv
               (fun h -> ((), h))
               (fun ((), h) -> h)
               (merge_objs
                  (obj1 (req "protocol" (constant protocol_hash)))
                  Proto.block_header_data_encoding))
          RPC_path.(path / "protocol_data")

      let raw_protocol_data =
        RPC_service.get_service
          ~description:
            "The version-specific fragment of the block header (unparsed)."
          ~query:RPC_query.empty
          ~output:bytes
          RPC_path.(path / "protocol_data" / "raw")
    end

    module Operations = struct
      let path = RPC_path.(path / "operations")

      let operations =
        RPC_service.get_service
          ~description:"All the operations included in the block."
          ~query:RPC_query.empty
          ~output:(list (dynamic_size (list operation_encoding)))
          path

      let list_arg =
        let name = "list_offset" in
        let descr = "Index `n` of the requested validation pass." in
        let construct = string_of_int in
        let destruct s =
          try Ok (int_of_string s)
          with _ -> Error (Format.sprintf "Invalid list offset (%s)" s)
        in
        RPC_arg.make ~name ~descr ~construct ~destruct ()

      let offset_arg =
        let name = "operation_offset" in
        let descr =
          "Index `m` of the requested operation in its validation pass."
        in
        let construct = string_of_int in
        let destruct s =
          try Ok (int_of_string s)
          with _ -> Error (Format.sprintf "Invalid operation offset (%s)" s)
        in
        RPC_arg.make ~name ~descr ~construct ~destruct ()

      let operations_in_pass =
        RPC_service.get_service
          ~description:
            "All the operations included in `n-th` validation pass of the \
             block."
          ~query:RPC_query.empty
          ~output:(list operation_encoding)
          RPC_path.(path /: list_arg)

      let operation =
        RPC_service.get_service
          ~description:
            "The `m-th` operation in the `n-th` validation pass of the block."
          ~query:RPC_query.empty
          ~output:operation_encoding
          RPC_path.(path /: list_arg /: offset_arg)
    end

    module Operation_hashes = struct
      let path = RPC_path.(path / "operation_hashes")

      let operation_hashes =
        RPC_service.get_service
          ~description:
            "The hashes of all the operations included in the block."
          ~query:RPC_query.empty
          ~output:(list (list Operation_hash.encoding))
          path

      let operation_hashes_in_pass =
        RPC_service.get_service
          ~description:
            "All the operations included in `n-th` validation pass of the \
             block."
          ~query:RPC_query.empty
          ~output:(list Operation_hash.encoding)
          RPC_path.(path /: Operations.list_arg)

      let operation_hash =
        RPC_service.get_service
          ~description:
            "The hash of then `m-th` operation in the `n-th` validation pass \
             of the block."
          ~query:RPC_query.empty
          ~output:Operation_hash.encoding
          RPC_path.(path /: Operations.list_arg /: Operations.offset_arg)
    end

    module Helpers = struct
      let path = RPC_path.(path / "helpers")

      module Forge = struct
        let block_header =
          RPC_service.post_service
            ~description:"Forge a block header"
            ~query:RPC_query.empty
            ~input:Block_header.encoding
            ~output:(obj1 (req "block" bytes))
            RPC_path.(path / "forge_block_header")
      end

      module Preapply = struct
        let path = RPC_path.(path / "preapply")

        let block_result_encoding =
          obj2
            (req "shell_header" Block_header.shell_header_encoding)
            (req
               "operations"
               (list (Preapply_result.encoding RPC_error.encoding)))

        type block_param = {
          protocol_data : Next_proto.block_header_data;
          operations : Next_proto.operation list list;
        }

        let block_param_encoding =
          conv
            (fun {protocol_data; operations} -> (protocol_data, operations))
            (fun (protocol_data, operations) -> {protocol_data; operations})
            (obj2
               (req
                  "protocol_data"
                  (conv
                     (fun h -> ((), h))
                     (fun ((), h) -> h)
                     (merge_objs
                        (obj1 (req "protocol" (constant next_protocol_hash)))
                        (dynamic_size Next_proto.block_header_data_encoding))))
               (req
                  "operations"
                  (list (dynamic_size (list next_operation_encoding)))))

        let block_query =
          let open RPC_query in
          query (fun sort timestamp ->
              object
                method sort_operations = sort

                method timestamp = timestamp
              end)
          |+ flag "sort" (fun t -> t#sort_operations)
          |+ opt_field "timestamp" Time.Protocol.rpc_arg (fun t -> t#timestamp)
          |> seal

        let block =
          RPC_service.post_service
            ~description:
              "Simulate the validation of a block that would contain the \
               given operations and return the resulting fitness and context \
               hash."
            ~query:block_query
            ~input:block_param_encoding
            ~output:block_result_encoding
            RPC_path.(path / "block")

        let operations =
          RPC_service.post_service
            ~description:"Simulate the validation of an operation."
            ~query:RPC_query.empty
            ~input:(list next_operation_encoding)
            ~output:
              (list
                 (dynamic_size Next_proto.operation_data_and_receipt_encoding))
            RPC_path.(path / "operations")
      end

      let complete =
        let prefix_arg =
          let destruct s = Ok s and construct s = s in
          RPC_arg.make ~name:"prefix" ~destruct ~construct ()
        in
        RPC_service.get_service
          ~description:
            "Try to complete a prefix of a Base58Check-encoded data. This RPC \
             is actually able to complete hashes of block, operations, \
             public_keys and contracts."
          ~query:RPC_query.empty
          ~output:(list string)
          RPC_path.(path / "complete" /: prefix_arg)
    end

    module Context = struct
      let path = RPC_path.(path / "context" / "raw" / "bytes")

      let context_path_arg : string RPC_arg.t =
        let name = "context_path" in
        let descr = "A path inside the context" in
        let construct s = s in
        let destruct s = Ok s in
        RPC_arg.make ~name ~descr ~construct ~destruct ()

      let raw_context_query : < depth : int option > RPC_query.t =
        let open RPC_query in
        query (fun depth ->
            object
              method depth = depth
            end)
        |+ opt_field "depth" RPC_arg.int (fun t -> t#depth)
        |> seal

      let read =
        RPC_service.get_service
          ~description:"Returns the raw context."
          ~query:raw_context_query
          ~output:raw_context_encoding
          RPC_path.(path /:* context_path_arg)
    end

    let info =
      RPC_service.get_service
        ~description:"All the information about a block."
        ~query:RPC_query.empty
        ~output:block_info_encoding
        path

    module Mempool = struct
      type t = {
        applied : (Operation_hash.t * Next_proto.operation) list;
        refused : (Next_proto.operation * error list) Operation_hash.Map.t;
        branch_refused :
          (Next_proto.operation * error list) Operation_hash.Map.t;
        branch_delayed :
          (Next_proto.operation * error list) Operation_hash.Map.t;
        unprocessed : Next_proto.operation Operation_hash.Map.t;
      }

      let encoding =
        conv
          (fun {applied; refused; branch_refused; branch_delayed; unprocessed} ->
            (applied, refused, branch_refused, branch_delayed, unprocessed))
          (fun (applied, refused, branch_refused, branch_delayed, unprocessed) ->
            {applied; refused; branch_refused; branch_delayed; unprocessed})
          (obj5
             (req
                "applied"
                (list
                   (conv
                      (fun (hash, (op : Next_proto.operation)) ->
                        ((hash, op.shell), op.protocol_data))
                      (fun ((hash, shell), protocol_data) ->
                        (hash, {shell; protocol_data}))
                      (merge_objs
                         (merge_objs
                            (obj1 (req "hash" Operation_hash.encoding))
                            (dynamic_size Operation.shell_header_encoding))
                         (dynamic_size Next_proto.operation_data_encoding)))))
             (req
                "refused"
                (Operation_hash.Map.encoding
                   (merge_objs
                      (dynamic_size next_operation_encoding)
                      (obj1 (req "error" RPC_error.encoding)))))
             (req
                "branch_refused"
                (Operation_hash.Map.encoding
                   (merge_objs
                      (dynamic_size next_operation_encoding)
                      (obj1 (req "error" RPC_error.encoding)))))
             (req
                "branch_delayed"
                (Operation_hash.Map.encoding
                   (merge_objs
                      (dynamic_size next_operation_encoding)
                      (obj1 (req "error" RPC_error.encoding)))))
             (req
                "unprocessed"
                (Operation_hash.Map.encoding
                   (dynamic_size next_operation_encoding))))

      let pending_operations path =
        (* TODO: branch_delayed/... *)
        RPC_service.get_service
          ~description:"List the prevalidated operations."
          ~query:RPC_query.empty
          ~output:encoding
          RPC_path.(path / "pending_operations")

      let mempool_query =
        let open RPC_query in
        query (fun applied refused branch_refused branch_delayed ->
            object
              method applied = applied

              method refused = refused

              method branch_refused = branch_refused

              method branch_delayed = branch_delayed
            end)
        |+ field
             ~descr:"Include applied operations (set by default)"
             "applied"
             RPC_arg.bool
             true
             (fun t -> t#applied)
        |+ field
             ~descr:"Include refused operations"
             "refused"
             RPC_arg.bool
             false
             (fun t -> t#refused)
        |+ field
             ~descr:"Include branch refused operations"
             "branch_refused"
             RPC_arg.bool
             false
             (fun t -> t#branch_refused)
        |+ field
             ~descr:"Include branch delayed operations (set by default)"
             "branch_delayed"
             RPC_arg.bool
             true
             (fun t -> t#branch_delayed)
        |> seal

      let monitor_operations path =
        RPC_service.get_service
          ~description:"Monitor the mempool operations."
          ~query:mempool_query
          ~output:(list next_operation_encoding)
          RPC_path.(path / "monitor_operations")

      let request_operations path =
        RPC_service.post_service
          ~description:"Request the operations of your peers."
          ~input:Data_encoding.empty
          ~query:RPC_query.empty
          ~output:Data_encoding.empty
          RPC_path.(path / "request_operations")
    end

    let live_blocks =
      RPC_service.get_service
        ~description:
          "List the ancestors of the given block which, if referred to as the \
           branch in an operation header, are recent enough for that \
           operation to be included in the current block."
        ~query:RPC_query.empty
        ~output:Block_hash.Set.encoding
        RPC_path.(live_blocks_path open_root)
  end

  let path = RPC_path.prefix chain_path path

  let make_call0 s ctxt a b q p =
    let s = RPC_service.prefix path s in
    RPC_context.make_call2 s ctxt a b q p

  let make_call1 s ctxt a b c q p =
    let s = RPC_service.prefix path s in
    RPC_context.make_call3 s ctxt a b c q p

  let make_call2 s ctxt a b c d q p =
    let s = RPC_service.prefix path s in
    RPC_context.make_call s ctxt (((((), a), b), c), d) q p

  let hash ctxt =
    let f = make_call0 S.hash ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () ->
      match block with `Hash (h, 0) -> return h | _ -> f chain block () ()

  let header ctxt =
    let f = make_call0 S.header ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  let raw_header ctxt =
    let f = make_call0 S.raw_header ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  let metadata ctxt =
    let f = make_call0 S.metadata ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  let protocols ctxt =
    let f = make_call0 S.protocols ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  module Header = struct
    module S = S.Header

    let shell_header ctxt =
      let f = make_call0 S.shell_header ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

    let protocol_data ctxt =
      let f = make_call0 S.protocol_data ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

    let raw_protocol_data ctxt =
      let f = make_call0 S.raw_protocol_data ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
  end

  module Operations = struct
    module S = S.Operations

    let operations ctxt =
      let f = make_call0 S.operations ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

    let operations_in_pass ctxt =
      let f = make_call1 S.operations_in_pass ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) n -> f chain block n () ()

    let operation ctxt =
      let f = make_call2 S.operation ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) n m -> f chain block n m () ()
  end

  module Operation_hashes = struct
    module S = S.Operation_hashes

    let operation_hashes ctxt =
      let f = make_call0 S.operation_hashes ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

    let operation_hashes_in_pass ctxt =
      let f = make_call1 S.operation_hashes_in_pass ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) n -> f chain block n () ()

    let operation_hash ctxt =
      let f = make_call2 S.operation_hash ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) n m -> f chain block n m () ()
  end

  module Context = struct
    module S = S.Context

    let read ctxt =
      let f = make_call1 S.read ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) ?depth path ->
        f
          chain
          block
          path
          (object
             method depth = depth
          end)
          ()
  end

  module Helpers = struct
    module S = S.Helpers

    module Forge = struct
      module S = S.Forge

      let block_header ctxt =
        let f = make_call0 S.block_header ctxt in
        fun ?(chain = `Main) ?(block = `Head 0) header ->
          f chain block () header
    end

    module Preapply = struct
      module S = S.Preapply

      let block ctxt =
        let f = make_call0 S.block ctxt in
        fun ?(chain = `Main)
            ?(block = `Head 0)
            ?(sort = false)
            ?timestamp
            ~protocol_data
            operations ->
          f
            chain
            block
            (object
               method sort_operations = sort

               method timestamp = timestamp
            end)
            {protocol_data; operations}

      let operations ctxt =
        let f = make_call0 S.operations ctxt in
        fun ?(chain = `Main) ?(block = `Head 0) operations ->
          f chain block () operations
    end

    let complete ctxt =
      let f = make_call1 S.complete ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) s -> f chain block s () ()
  end

  let info ctxt =
    let f = make_call0 S.info ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  module Mempool = struct
    type t = S.Mempool.t = {
      applied : (Operation_hash.t * Next_proto.operation) list;
      refused : (Next_proto.operation * error list) Operation_hash.Map.t;
      branch_refused :
        (Next_proto.operation * error list) Operation_hash.Map.t;
      branch_delayed :
        (Next_proto.operation * error list) Operation_hash.Map.t;
      unprocessed : Next_proto.operation Operation_hash.Map.t;
    }

    let pending_operations ctxt ?(chain = `Main) () =
      let s = S.Mempool.pending_operations (mempool_path chain_path) in
      RPC_context.make_call1 s ctxt chain () ()

    let monitor_operations ctxt ?(chain = `Main) ?(applied = true)
        ?(branch_delayed = true) ?(branch_refused = false) ?(refused = false)
        () =
      let s = S.Mempool.monitor_operations (mempool_path chain_path) in
      RPC_context.make_streamed_call
        s
        ctxt
        ((), chain)
        (object
           method applied = applied

           method refused = refused

           method branch_refused = branch_refused

           method branch_delayed = branch_delayed
        end)
        ()

    let request_operations ctxt ?(chain = `Main) () =
      let s = S.Mempool.request_operations (mempool_path chain_path) in
      RPC_context.make_call1 s ctxt chain () ()
  end

  let live_blocks ctxt =
    let f = make_call0 S.live_blocks ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
end

module Fake_protocol = struct
  let hash = Protocol_hash.zero

  type block_header_data = unit

  let block_header_data_encoding = Data_encoding.empty

  type block_header_metadata = unit

  let block_header_metadata_encoding = Data_encoding.empty

  type operation_data = unit

  type operation_receipt = unit

  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  let operation_data_encoding = Data_encoding.empty

  let operation_receipt_encoding = Data_encoding.empty

  let operation_data_and_receipt_encoding =
    Data_encoding.conv
      (fun ((), ()) -> ())
      (fun () -> ((), ()))
      Data_encoding.empty
end

module Empty = Make (Fake_protocol) (Fake_protocol)

let () =
  Printexc.register_printer (function
      | ( Json_schema.Cannot_parse _
        | Json_schema.Dangling_reference _
        | Json_schema.Bad_reference _
        | Json_schema.Unexpected _
        | Json_schema.Duplicate_definition _ ) as exn ->
          Some
            (Format.asprintf "%a" (fun ppf -> Json_schema.print_error ppf) exn)
      | _ ->
          None)

let protocols = Empty.protocols
src/lib_shell_services/block_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Data_encoding.

Definition chain := variant.

Definition parse_chain (s : string) : sum variant string := try.

Definition chain_to_string (function_parameter : variant) : string :=
  match function_parameter with
  | Main => "main" % string
  | Test => "test" % string
  | Hash h => Tezos_base__TzPervasives.Chain_id.to_b58check h
  end.

Definition chain_arg : Tezos_base__TzPervasives.RPC_arg.arg variant :=
  let name := "chain_id" % string in
  let descr :=
    "A chain identifier. This is either a chain hash in Base58Check notation or a one the predefined aliases: 'main', 'test'."
      % string in
  let construct := chain_to_string in
  let destruct := parse_chain in
  Tezos_base__TzPervasives.RPC_arg.make (Some descr) name destruct construct tt.

Definition block := variant.

Definition parse_block (s : string) : sum variant string :=
  let delims := cons "~" % char (cons "-" % char (cons "+" % char [])) in
  let count_delims (s : string) : list (Z * ascii) :=
    Tezos_base__TzPervasives.List.map
      (fun d =>
        ((Tezos_base__TzPervasives.String.fold_left
          (fun i =>
            fun c =>
              if equiv_decb c d then
                Z.add i 1
              else
                i) 0 s), d)) delims in
  let split_on_delim (counts : list (Z * ascii)) : (list string) * ascii :=
    match
      Tezos_base__TzPervasives.List.fold_left
        (fun i =>
          fun function_parameter =>
            match function_parameter with
            | (v, _) => Z.add i v
            end) 0 counts with
    | 0 => ((cons s []), " " % char)
    | 1 =>
      let delim := Tezos_base__TzPervasives.List.assoc 1 counts in
      ((Tezos_base__TzPervasives.String.split delim None None s), delim)
    | _ => Stdlib.raise Exit
    end in
  try.

Definition alias_to_string (function_parameter : variant) : string :=
  match function_parameter with
  | Checkpoint => "checkpoint" % string
  | Save_point => "save_point" % string
  | Caboose => "caboose" % string
  end.

Definition to_string (function_parameter : variant) : string :=
  match function_parameter with
  | Genesis => "genesis" % string
  | Alias (a, 0) => alias_to_string a
  | Alias (a, n) =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "+" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s+%d" % string)
      (alias_to_string a) (Z.opp n)
  | Alias (a, n) =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "~" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s~%d" % string)
      (alias_to_string a) n
  | Head 0 => "head" % string
  | Head n =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "head+" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "head+%d" % string)
      (Z.opp n)
  | Head n =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "head~" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "head~%d" % string) n
  | Hash (h, 0) => Tezos_base__TzPervasives.Block_hash.to_b58check h
  | Hash (h, n) =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "+" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s+%d" % string)
      (Tezos_base__TzPervasives.Block_hash.to_b58check h) (Z.opp n)
  | Hash (h, n) =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "~" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s~%d" % string)
      (Tezos_base__TzPervasives.Block_hash.to_b58check h) n
  | Level i =>
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          CamlinternalFormatBasics.End_of_format) "%d" % string)
      (Stdlib.Int32.to_int i)
  end.

Definition blocks_arg : Tezos_base__TzPervasives.RPC_arg.arg variant :=
  let name := "block_id" % string in
  let descr :=
    "A block identifier. This is either a block hash in Base58Check notation, one the predefined aliases: 'genesis', 'head' or a block level (index in the chain). One might also use 'head~N' or '<hash>~N' where N is an integer to denote the Nth predecessor of the designated block.Also, '<hash>+N' denotes the Nth successor of a block."
      % string in
  let construct := to_string in
  let destruct := parse_block in
  Tezos_base__TzPervasives.RPC_arg.make (Some descr) name destruct construct tt.

Definition chain_prefix := unit * chain.

Definition prefix := chain_prefix * block.

Definition chain_path
  : Tezos_base__TzPervasives.RPC_path.path unit (unit * variant) :=
  Tezos_base__TzPervasives.RPC_path.op_div_colon
    (Tezos_base__TzPervasives.RPC_path.op_div
      Tezos_base__TzPervasives.RPC_path.root "chains" % string) chain_arg.

Definition mempool_path {A B : Type}
  (p : Tezos_base__TzPervasives.RPC_path.path A B)
  : Tezos_base__TzPervasives.RPC_path.path A B :=
  Tezos_base__TzPervasives.RPC_path.op_div p "mempool" % string.

Definition live_blocks_path {A B : Type}
  (p : Tezos_base__TzPervasives.RPC_path.path A B)
  : Tezos_base__TzPervasives.RPC_path.path A B :=
  Tezos_base__TzPervasives.RPC_path.op_div p "live_blocks" % string.

Definition dir_path
  : Tezos_base__TzPervasives.RPC_path.t chain_prefix chain_prefix :=
  Tezos_base__TzPervasives.RPC_path.op_div
    Tezos_base__TzPervasives.RPC_path.open_root "blocks" % string.

Definition path
  : Tezos_base__TzPervasives.RPC_path.path chain_prefix (chain_prefix * variant) :=
  Tezos_base__TzPervasives.RPC_path.op_div_colon dir_path blocks_arg.

Record operation_list_quota := {
  max_size : Z;
  max_op : option Z }.

Definition operation_list_quota_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding operation_list_quota :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| max_size := max_size; max_op := max_op |} => (max_size, max_op)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (max_size, max_op) => {| max_size := max_size; max_op := max_op |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj2
      (Tezos_base__TzPervasives.Data_encoding.req None None "max_size" % string
        Tezos_base__TzPervasives.Data_encoding.int31)
      (Tezos_base__TzPervasives.Data_encoding.opt None None "max_op" % string
        Tezos_base__TzPervasives.Data_encoding.int31)).

Inductive raw_context : Type :=
| Key : Stdlib.Bytes.t -> raw_context
| Dir : (list (string * raw_context)) -> raw_context
| Cut : raw_context.

Fixpoint pp_raw_context
  (ppf : Stdlib.Format.formatter) (function_parameter : raw_context) : unit :=
  match function_parameter with
  | Cut =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "..." % string
          CamlinternalFormatBasics.End_of_format) "..." % string)
  | Key v => Hex.pp ppf (Hex.of_bytes None v)
  | Dir l =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "{" % char
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 1>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Char_literal "}" % char
                      CamlinternalFormatBasics.End_of_format)))))))
        "{@[<v 1>@,%a@]@,}" % string)
      (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_cut)
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | (s, t) =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal " : " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)))
                  "%s : %a" % string) s pp_raw_context t
            end)) l
  end.

Definition raw_context_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding raw_context :=
  Tezos_base__TzPervasives.Data_encoding.mu "raw_context" % string None None
    (fun encoding =>
      Tezos_base__TzPervasives.Data_encoding.union None
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Key" % string None
            (Tag 0) Tezos_base__TzPervasives.Data_encoding.bytes
            (fun function_parameter =>
              match function_parameter with
              | Key k => Some k
              | _ => None
              end) (fun k => Key k))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case "Dir" % string None
              (Tag 1) (Tezos_base__TzPervasives.Data_encoding.assoc encoding)
              (fun function_parameter =>
                match function_parameter with
                | Dir k => Some k
                | _ => None
                end) (fun k => Dir k))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case "Cut" % string None
                (Tag 2) Tezos_base__TzPervasives.Data_encoding.null
                (fun function_parameter =>
                  match function_parameter with
                  | Cut => Some tt
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Cut
                  end)) [])))).

Module PROTO.
  Record signature {block_header_data block_header_metadata operation_data
    operation_receipt operation : Type} := {
    hash : Tezos_base__TzPervasives.Protocol_hash.t;
    block_header_data := block_header_data;
    block_header_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
      block_header_data;
    block_header_metadata := block_header_metadata;
    block_header_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.t
      block_header_metadata;
    operation_data := operation_data;
    operation_receipt := operation_receipt;
    operation := operation;
    operation_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
      operation_data;
    operation_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
      operation_receipt;
    operation_data_and_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
      (operation_data * operation_receipt);
  }.
  Arguments signature : clear implicits.
End PROTO.

Record protocols := {
  current_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  next_protocol : Tezos_base__TzPervasives.Protocol_hash.t }.

Definition raw_protocol_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding protocols :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        current_protocol := current_protocol;
          next_protocol := next_protocol
          |} => ((current_protocol, next_protocol), tt)
      end)
    (fun function_parameter =>
      match function_parameter with
      | ((current_protocol, next_protocol), tt) =>
        {| current_protocol := current_protocol; next_protocol := next_protocol
          |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.merge_objs
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "protocol" % string Tezos_base__TzPervasives.Protocol_hash.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "next_protocol" % string
          Tezos_base__TzPervasives.Protocol_hash.encoding))
      Tezos_base__TzPervasives.Data_encoding.unit).

Module Fake_protocol.
  Definition hash : Tezos_base__TzPervasives.Protocol_hash.t :=
    Tezos_base__TzPervasives.Protocol_hash.zero.
  
  Definition block_header_data := unit.
  
  Definition block_header_data_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Tezos_base__TzPervasives.Data_encoding.empty.
  
  Definition block_header_metadata := unit.
  
  Definition block_header_metadata_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Tezos_base__TzPervasives.Data_encoding.empty.
  
  Definition operation_data := unit.
  
  Definition operation_receipt := unit.
  
  Record operation := {
    shell : Tezos_base__TzPervasives.Operation.shell_header;
    protocol_data : operation_data }.
  
  Definition operation_data_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Tezos_base__TzPervasives.Data_encoding.empty.
  
  Definition operation_receipt_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Tezos_base__TzPervasives.Data_encoding.empty.
  
  Definition operation_data_and_receipt_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding (unit * unit) :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | (tt, tt) => tt
        end)
      (fun function_parameter =>
        match function_parameter with
        | tt => (tt, tt)
        end) None Tezos_base__TzPervasives.Data_encoding.empty.
End Fake_protocol.

Definition protocols {E F i o p q : Type}
  : (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (E * p * q * i * o)) * F) * F) ->
    (option variant) ->
      (option variant) ->
        unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult protocols) :=
  Empty.protocols.
src/lib_shell_services/block_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type chain = [`Main | `Test | `Hash of Chain_id.t]

type chain_prefix = unit * chain

val chain_path : (unit, chain_prefix) RPC_path.t

val parse_chain : string -> (chain, string) result

val chain_to_string : chain -> string

val chain_arg : chain RPC_arg.t

type block =
  [ `Genesis
  | `Head of int
  | `Alias of [`Caboose | `Checkpoint | `Save_point] * int
  | `Hash of Block_hash.t * int
  | `Level of Int32.t ]

val parse_block : string -> (block, string) result

val to_string : block -> string

type prefix = (unit * chain) * block

val dir_path : (chain_prefix, chain_prefix) RPC_path.t

val path : (chain_prefix, chain_prefix * block) RPC_path.t

val mempool_path : ('a, 'b) RPC_path.t -> ('a, 'b) RPC_path.t

val live_blocks_path : ('a, 'b) RPC_path.t -> ('a, 'b) RPC_path.t

type operation_list_quota = {max_size : int; max_op : int option}

type raw_context = Key of Bytes.t | Dir of (string * raw_context) list | Cut

val pp_raw_context : Format.formatter -> raw_context -> unit

type error += Invalid_depth_arg of int

module type PROTO = sig
  val hash : Protocol_hash.t

  type block_header_data

  val block_header_data_encoding : block_header_data Data_encoding.t

  type block_header_metadata

  val block_header_metadata_encoding : block_header_metadata Data_encoding.t

  type operation_data

  type operation_receipt

  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  val operation_data_encoding : operation_data Data_encoding.t

  val operation_receipt_encoding : operation_receipt Data_encoding.t

  val operation_data_and_receipt_encoding :
    (operation_data * operation_receipt) Data_encoding.t
end

type protocols = {
  current_protocol : Protocol_hash.t;
  next_protocol : Protocol_hash.t;
}

val protocols :
  #RPC_context.simple ->
  ?chain:chain ->
  ?block:block ->
  unit ->
  protocols tzresult Lwt.t

module Make (Proto : PROTO) (Next_proto : PROTO) : sig
  val path : (unit, chain_prefix * block) RPC_path.t

  type raw_block_header = {
    shell : Block_header.shell_header;
    protocol_data : Proto.block_header_data;
  }

  type block_header = {
    chain_id : Chain_id.t;
    hash : Block_hash.t;
    shell : Block_header.shell_header;
    protocol_data : Proto.block_header_data;
  }

  type block_metadata = {
    protocol_data : Proto.block_header_metadata;
    test_chain_status : Test_chain_status.t;
    max_operations_ttl : int;
    max_operation_data_length : int;
    max_block_header_length : int;
    operation_list_quota : operation_list_quota list;
  }

  type operation = {
    chain_id : Chain_id.t;
    hash : Operation_hash.t;
    shell : Operation.shell_header;
    protocol_data : Proto.operation_data;
    receipt : Proto.operation_receipt;
  }

  type block_info = {
    chain_id : Chain_id.t;
    hash : Block_hash.t;
    header : raw_block_header;
    metadata : block_metadata;
    operations : operation list list;
  }

  open RPC_context

  val info :
    #simple ->
    ?chain:chain ->
    ?block:block ->
    unit ->
    block_info tzresult Lwt.t

  val hash :
    #simple ->
    ?chain:chain ->
    ?block:block ->
    unit ->
    Block_hash.t tzresult Lwt.t

  val raw_header :
    #simple -> ?chain:chain -> ?block:block -> unit -> Bytes.t tzresult Lwt.t

  val header :
    #simple ->
    ?chain:chain ->
    ?block:block ->
    unit ->
    block_header tzresult Lwt.t

  val metadata :
    #simple ->
    ?chain:chain ->
    ?block:block ->
    unit ->
    block_metadata tzresult Lwt.t

  module Header : sig
    val shell_header :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      unit ->
      Block_header.shell_header tzresult Lwt.t

    val protocol_data :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      unit ->
      Proto.block_header_data tzresult Lwt.t

    val raw_protocol_data :
      #simple -> ?chain:chain -> ?block:block -> unit -> Bytes.t tzresult Lwt.t
  end

  module Operations : sig
    val operations :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      unit ->
      operation list list tzresult Lwt.t

    val operations_in_pass :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      int ->
      operation list tzresult Lwt.t

    val operation :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      int ->
      int ->
      operation tzresult Lwt.t
  end

  module Operation_hashes : sig
    val operation_hashes :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      unit ->
      Operation_hash.t list list tzresult Lwt.t

    val operation_hashes_in_pass :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      int ->
      Operation_hash.t list tzresult Lwt.t

    val operation_hash :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      int ->
      int ->
      Operation_hash.t tzresult Lwt.t
  end

  module Context : sig
    val read :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      ?depth:int ->
      string list ->
      raw_context tzresult Lwt.t
  end

  module Helpers : sig
    module Forge : sig
      val block_header :
        #RPC_context.simple ->
        ?chain:chain ->
        ?block:block ->
        Block_header.t ->
        Bytes.t tzresult Lwt.t
    end

    module Preapply : sig
      val block :
        #simple ->
        ?chain:chain ->
        ?block:block ->
        ?sort:bool ->
        ?timestamp:Time.Protocol.t ->
        protocol_data:Next_proto.block_header_data ->
        Next_proto.operation list list ->
        (Block_header.shell_header * error Preapply_result.t list) tzresult
        Lwt.t

      val operations :
        #simple ->
        ?chain:chain ->
        ?block:block ->
        Next_proto.operation list ->
        (Next_proto.operation_data * Next_proto.operation_receipt) list
        tzresult
        Lwt.t
    end

    val complete :
      #simple ->
      ?chain:chain ->
      ?block:block ->
      string ->
      string list tzresult Lwt.t
  end

  module Mempool : sig
    type t = {
      applied : (Operation_hash.t * Next_proto.operation) list;
      refused : (Next_proto.operation * error list) Operation_hash.Map.t;
      branch_refused :
        (Next_proto.operation * error list) Operation_hash.Map.t;
      branch_delayed :
        (Next_proto.operation * error list) Operation_hash.Map.t;
      unprocessed : Next_proto.operation Operation_hash.Map.t;
    }

    val pending_operations :
      #simple -> ?chain:chain -> unit -> t tzresult Lwt.t

    val monitor_operations :
      #streamed ->
      ?chain:chain ->
      ?applied:bool ->
      ?branch_delayed:bool ->
      ?branch_refused:bool ->
      ?refused:bool ->
      unit ->
      (Next_proto.operation list Lwt_stream.t * stopper) tzresult Lwt.t

    val request_operations :
      #simple -> ?chain:chain -> unit -> unit tzresult Lwt.t
  end

  val live_blocks :
    #simple ->
    ?chain:chain ->
    ?block:block ->
    unit ->
    Block_hash.Set.t tzresult Lwt.t

  module S : sig
    val hash : ([`GET], prefix, prefix, unit, unit, Block_hash.t) RPC_service.t

    val info : ([`GET], prefix, prefix, unit, unit, block_info) RPC_service.t

    val header :
      ([`GET], prefix, prefix, unit, unit, block_header) RPC_service.t

    val raw_header :
      ([`GET], prefix, prefix, unit, unit, Bytes.t) RPC_service.t

    val metadata :
      ([`GET], prefix, prefix, unit, unit, block_metadata) RPC_service.t

    val protocols :
      ([`GET], prefix, prefix, unit, unit, protocols) RPC_service.t

    module Header : sig
      val shell_header :
        ( [`GET],
          prefix,
          prefix,
          unit,
          unit,
          Block_header.shell_header )
        RPC_service.t

      val protocol_data :
        ( [`GET],
          prefix,
          prefix,
          unit,
          unit,
          Proto.block_header_data )
        RPC_service.t

      val raw_protocol_data :
        ([`GET], prefix, prefix, unit, unit, Bytes.t) RPC_service.t
    end

    module Operations : sig
      val operations :
        ([`GET], prefix, prefix, unit, unit, operation list list) RPC_service.t

      val operations_in_pass :
        ( [`GET],
          prefix,
          prefix * int,
          unit,
          unit,
          operation list )
        RPC_service.t

      val operation :
        ( [`GET],
          prefix,
          (prefix * int) * int,
          unit,
          unit,
          operation )
        RPC_service.t
    end

    module Operation_hashes : sig
      val operation_hashes :
        ( [`GET],
          prefix,
          prefix,
          unit,
          unit,
          Tezos_crypto.Operation_hash.t list list )
        RPC_service.t

      val operation_hashes_in_pass :
        ( [`GET],
          prefix,
          prefix * int,
          unit,
          unit,
          Tezos_crypto.Operation_hash.t list )
        RPC_service.t

      val operation_hash :
        ( [`GET],
          prefix,
          (prefix * int) * int,
          unit,
          unit,
          Tezos_crypto.Operation_hash.t )
        RPC_service.t
    end

    module Context : sig
      val read :
        ( [`GET],
          prefix,
          prefix * string list,
          < depth : int option >,
          unit,
          raw_context )
        RPC_service.t
    end

    module Helpers : sig
      module Forge : sig
        val block_header :
          ( [`POST],
            prefix,
            prefix,
            unit,
            Block_header.t,
            Bytes.t )
          RPC_service.service
      end

      module Preapply : sig
        type block_param = {
          protocol_data : Next_proto.block_header_data;
          operations : Next_proto.operation list list;
        }

        val block :
          ( [`POST],
            prefix,
            prefix,
            < sort_operations : bool ; timestamp : Time.Protocol.t option >,
            block_param,
            Block_header.shell_header * error Preapply_result.t list )
          RPC_service.t

        val operations :
          ( [`POST],
            prefix,
            prefix,
            unit,
            Next_proto.operation list,
            (Next_proto.operation_data * Next_proto.operation_receipt) list )
          RPC_service.t
      end

      val complete :
        ( [`GET],
          prefix,
          prefix * string,
          unit,
          unit,
          string list )
        RPC_service.t
    end

    module Mempool : sig
      val encoding : Mempool.t Data_encoding.t

      val pending_operations :
        ('a, 'b) RPC_path.t ->
        ([`GET], 'a, 'b, unit, unit, Mempool.t) RPC_service.t

      val monitor_operations :
        ('a, 'b) RPC_path.t ->
        ( [`GET],
          'a,
          'b,
          < applied : bool
          ; branch_delayed : bool
          ; branch_refused : bool
          ; refused : bool >,
          unit,
          Next_proto.operation list )
        RPC_service.t

      val request_operations :
        ('a, 'b) RPC_path.t ->
        ([`POST], 'a, 'b, unit, unit, unit) RPC_service.t
    end

    val live_blocks :
      ([`GET], prefix, prefix, unit, unit, Block_hash.Set.t) RPC_service.t
  end
end

module Fake_protocol : PROTO

module Empty : module type of Make (Fake_protocol) (Fake_protocol)
src/lib_shell_services/block_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition chain := variant.

Definition chain_prefix := unit * chain.

Parameter chain_path : Tezos_base__TzPervasives.RPC_path.t unit chain_prefix.

Parameter parse_chain : string -> sum chain string.

Parameter chain_to_string : chain -> string.

Parameter chain_arg : Tezos_base__TzPervasives.RPC_arg.t chain.

Definition block := variant.

Parameter parse_block : string -> sum block string.

Parameter to_string : block -> string.

Definition prefix := (unit * chain) * block.

Parameter dir_path :
Tezos_base__TzPervasives.RPC_path.t chain_prefix chain_prefix.

Parameter path :
Tezos_base__TzPervasives.RPC_path.t chain_prefix (chain_prefix * block).

Parameter mempool_path : forall {a b : Type},
(Tezos_base__TzPervasives.RPC_path.t a b) ->
  Tezos_base__TzPervasives.RPC_path.t a b.

Parameter live_blocks_path : forall {a b : Type},
(Tezos_base__TzPervasives.RPC_path.t a b) ->
  Tezos_base__TzPervasives.RPC_path.t a b.

Record operation_list_quota := {
  max_size : Z;
  max_op : option Z }.

Inductive raw_context : Type :=
| Key : Stdlib.Bytes.t -> raw_context
| Dir : (list (string * raw_context)) -> raw_context
| Cut : raw_context.

Parameter pp_raw_context : Stdlib.Format.formatter -> raw_context -> unit.

extensible_type

module_type

Record protocols := {
  current_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  next_protocol : Tezos_base__TzPervasives.Protocol_hash.t }.

Parameter protocols : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  (option chain) ->
    (option block) ->
      unit -> Lwt.t (Tezos_base__TzPervasives.tzresult protocols).

unhandled_module

unhandled_module

unhandled_module
src/lib_shell_services/block_validator_errors.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type block_error =
  | Cannot_parse_operation of Operation_hash.t
  | Invalid_fitness of {expected : Fitness.t; found : Fitness.t}
  | Non_increasing_timestamp
  | Non_increasing_fitness
  | Invalid_level of {expected : Int32.t; found : Int32.t}
  | Invalid_proto_level of {expected : int; found : int}
  | Replayed_operation of Operation_hash.t
  | Outdated_operation of {
      operation : Operation_hash.t;
      originating_block : Block_hash.t;
    }
  | Expired_chain of {
      chain_id : Chain_id.t;
      expiration : Time.Protocol.t;
      timestamp : Time.Protocol.t;
    }
  | Unexpected_number_of_validation_passes of int (* uint8 *)
  | Too_many_operations of {pass : int; found : int; max : int}
  | Oversized_operation of {
      operation : Operation_hash.t;
      size : int;
      max : int;
    }
  | Unallowed_pass of {
      operation : Operation_hash.t;
      pass : int;
      allowed_pass : int list;
    }
  | Cannot_parse_block_header
  | Economic_protocol_error of error list

let errno : Unix.error Data_encoding.t =
  let open Data_encoding in
  union
    [ case
        ~title:"unknown_unix_error"
        (Tag 0)
        int8
        (function Unix.EUNKNOWNERR i -> Some i | _ -> None)
        (fun i -> EUNKNOWNERR i);
      case
        ~title:"unix_error"
        (Tag 1)
        (string_enum
           Unix.
             [ ("2big", E2BIG);
               ("acces", EACCES);
               ("again", EAGAIN);
               ("badf", EBADF);
               ("busy", EBUSY);
               ("child", ECHILD);
               ("deadlk", EDEADLK);
               ("dom", EDOM);
               ("exist", EEXIST);
               ("fault", EFAULT);
               ("fbig", EFBIG);
               ("intr", EINTR);
               ("inval", EINVAL);
               ("io", EIO);
               ("isdir", EISDIR);
               ("mfile", EMFILE);
               ("mlink", EMLINK);
               ("nametoolong", ENAMETOOLONG);
               ("nfile", ENFILE);
               ("nodev", ENODEV);
               ("noent", ENOENT);
               ("noexec", ENOEXEC);
               ("nolck", ENOLCK);
               ("nomem", ENOMEM);
               ("nospc", ENOSPC);
               ("nosys", ENOSYS);
               ("notdir", ENOTDIR);
               ("notempty", ENOTEMPTY);
               ("notty", ENOTTY);
               ("nxio", ENXIO);
               ("perm", EPERM);
               ("pipe", EPIPE);
               ("range", ERANGE);
               ("rofs", EROFS);
               ("spipe", ESPIPE);
               ("srch", ESRCH);
               ("xdev", EXDEV);
               ("wouldblock", EWOULDBLOCK);
               ("inprogress", EINPROGRESS);
               ("already", EALREADY);
               ("notsock", ENOTSOCK);
               ("destaddrreq", EDESTADDRREQ);
               ("msgsize", EMSGSIZE);
               ("prototype", EPROTOTYPE);
               ("noprotoopt", ENOPROTOOPT);
               ("protonosupport", EPROTONOSUPPORT);
               ("socktnosupport", ESOCKTNOSUPPORT);
               ("opnotsupp", EOPNOTSUPP);
               ("pfnosupport", EPFNOSUPPORT);
               ("afnosupport", EAFNOSUPPORT);
               ("addrinuse", EADDRINUSE);
               ("addrnotavail", EADDRNOTAVAIL);
               ("netdown", ENETDOWN);
               ("netunreach", ENETUNREACH);
               ("netreset", ENETRESET);
               ("connaborted", ECONNABORTED);
               ("connreset", ECONNRESET);
               ("nobufs", ENOBUFS);
               ("isconn", EISCONN);
               ("notconn", ENOTCONN);
               ("shutdown", ESHUTDOWN);
               ("toomanyrefs", ETOOMANYREFS);
               ("timedout", ETIMEDOUT);
               ("connrefused", ECONNREFUSED);
               ("hostdown", EHOSTDOWN);
               ("hostunreach", EHOSTUNREACH);
               ("loop", ELOOP);
               ("overflow", EOVERFLOW) ])
        (fun x -> Some x)
        (fun x -> x) ]

let block_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Cannot_parse_operation"
        (obj2
           (req "error" (constant "cannot_parse_operation"))
           (req "operation" Operation_hash.encoding))
        (function
          | Cannot_parse_operation operation ->
              Some ((), operation)
          | _ ->
              None)
        (fun ((), operation) -> Cannot_parse_operation operation);
      case
        (Tag 1)
        ~title:"Invalid_fitness"
        (obj3
           (req "error" (constant "invalid_fitness"))
           (req "expected" Fitness.encoding)
           (req "found" Fitness.encoding))
        (function
          | Invalid_fitness {expected; found} ->
              Some ((), expected, found)
          | _ ->
              None)
        (fun ((), expected, found) -> Invalid_fitness {expected; found});
      case
        (Tag 2)
        ~title:"Non_increasing_timestamp"
        (obj1 (req "error" (constant "non_increasing_timestamp")))
        (function Non_increasing_timestamp -> Some () | _ -> None)
        (fun () -> Non_increasing_timestamp);
      case
        (Tag 3)
        ~title:"Non_increasing_fitness"
        (obj1 (req "error" (constant "non_increasing_fitness")))
        (function Non_increasing_fitness -> Some () | _ -> None)
        (fun () -> Non_increasing_fitness);
      case
        (Tag 4)
        ~title:"Invalid_level"
        (obj3
           (req "error" (constant "invalid_level"))
           (req "expected" int32)
           (req "found" int32))
        (function
          | Invalid_level {expected; found} ->
              Some ((), expected, found)
          | _ ->
              None)
        (fun ((), expected, found) -> Invalid_level {expected; found});
      case
        (Tag 5)
        ~title:"Invalid_proto_level"
        (obj3
           (req "error" (constant "invalid_proto_level"))
           (req "expected" uint8)
           (req "found" uint8))
        (function
          | Invalid_proto_level {expected; found} ->
              Some ((), expected, found)
          | _ ->
              None)
        (fun ((), expected, found) -> Invalid_proto_level {expected; found});
      case
        (Tag 6)
        ~title:"Replayed_operation"
        (obj2
           (req "error" (constant "replayed_operation"))
           (req "operation" Operation_hash.encoding))
        (function
          | Replayed_operation operation -> Some ((), operation) | _ -> None)
        (fun ((), operation) -> Replayed_operation operation);
      case
        (Tag 7)
        ~title:"Outdated_operation"
        (obj3
           (req "error" (constant "outdated_operation"))
           (req "operation" Operation_hash.encoding)
           (req "originating_block" Block_hash.encoding))
        (function
          | Outdated_operation {operation; originating_block} ->
              Some ((), operation, originating_block)
          | _ ->
              None)
        (fun ((), operation, originating_block) ->
          Outdated_operation {operation; originating_block});
      case
        (Tag 8)
        ~title:"Expired_chain"
        (obj4
           (req "error" (constant "expired_chain"))
           (req "chain_id" Chain_id.encoding)
           (req "expiration" Time.Protocol.encoding)
           (req "timestamp" Time.Protocol.encoding))
        (function
          | Expired_chain {chain_id; expiration; timestamp} ->
              Some ((), chain_id, expiration, timestamp)
          | _ ->
              None)
        (fun ((), chain_id, expiration, timestamp) ->
          Expired_chain {chain_id; expiration; timestamp});
      case
        (Tag 9)
        ~title:"Unexpected_number_of_validation_passes"
        (obj2
           (req "error" (constant "unexpected_number_of_passes"))
           (req "found" uint8))
        (function
          | Unexpected_number_of_validation_passes n ->
              Some ((), n)
          | _ ->
              None)
        (fun ((), n) -> Unexpected_number_of_validation_passes n);
      case
        (Tag 10)
        ~title:"Too_many_operations"
        (obj4
           (req "error" (constant "too_many_operations"))
           (req "validation_pass" uint8)
           (req "found" uint16)
           (req "max" uint16))
        (function
          | Too_many_operations {pass; found; max} ->
              Some ((), pass, found, max)
          | _ ->
              None)
        (fun ((), pass, found, max) -> Too_many_operations {pass; found; max});
      case
        (Tag 11)
        ~title:"Oversized_operation"
        (obj4
           (req "error" (constant "oversized_operation"))
           (req "operation" Operation_hash.encoding)
           (req "found" int31)
           (req "max" int31))
        (function
          | Oversized_operation {operation; size; max} ->
              Some ((), operation, size, max)
          | _ ->
              None)
        (fun ((), operation, size, max) ->
          Oversized_operation {operation; size; max});
      case
        (Tag 12)
        ~title:"Unallowed_pass"
        (obj4
           (req "error" (constant "invalid_pass"))
           (req "operation" Operation_hash.encoding)
           (req "pass" uint8)
           (req "allowed_pass" (list uint8)))
        (function
          | Unallowed_pass {operation; pass; allowed_pass} ->
              Some ((), operation, pass, allowed_pass)
          | _ ->
              None)
        (fun ((), operation, pass, allowed_pass) ->
          Unallowed_pass {operation; pass; allowed_pass});
      case
        (Tag 13)
        ~title:"Cannot_parse_block_header"
        (obj1 (req "error" (constant "cannot_parse_bock_header")))
        (function Cannot_parse_block_header -> Some () | _ -> None)
        (fun () -> Cannot_parse_block_header) ]

let pp_block_error ppf = function
  | Cannot_parse_operation oph ->
      Format.fprintf
        ppf
        "Failed to parse the operation %a."
        Operation_hash.pp_short
        oph
  | Invalid_fitness {expected; found} ->
      Format.fprintf
        ppf
        "@[<v 2>Invalid fitness:@  expected %a@  found %a@]"
        Fitness.pp
        expected
        Fitness.pp
        found
  | Non_increasing_timestamp ->
      Format.fprintf ppf "Non increasing timestamp"
  | Non_increasing_fitness ->
      Format.fprintf ppf "Non increasing fitness"
  | Invalid_level {expected; found} ->
      Format.fprintf
        ppf
        "Invalid level:@  expected %ld@  found %ld"
        expected
        found
  | Invalid_proto_level {expected; found} ->
      Format.fprintf
        ppf
        "Invalid protocol level:@  expected %d@  found %d"
        expected
        found
  | Replayed_operation oph ->
      Format.fprintf
        ppf
        "The operation %a was previously included in the chain."
        Operation_hash.pp_short
        oph
  | Outdated_operation {operation; originating_block} ->
      Format.fprintf
        ppf
        "The operation %a is outdated (originated in block: %a)"
        Operation_hash.pp_short
        operation
        Block_hash.pp_short
        originating_block
  | Expired_chain {chain_id; expiration; timestamp} ->
      Format.fprintf
        ppf
        "The block timestamp (%a) is later than its chain expiration date: %a \
         (chain: %a)."
        Time.System.pp_hum
        (Time.System.of_protocol_exn timestamp)
        Time.System.pp_hum
        (Time.System.of_protocol_exn expiration)
        Chain_id.pp_short
        chain_id
  | Unexpected_number_of_validation_passes n ->
      Format.fprintf ppf "Invalid number of validation passes (found: %d)" n
  | Too_many_operations {pass; found; max} ->
      Format.fprintf
        ppf
        "Too many operations in validation pass %d (found: %d, max: %d)"
        pass
        found
        max
  | Oversized_operation {operation; size; max} ->
      Format.fprintf
        ppf
        "Oversized operation %a (size: %d, max: %d)"
        Operation_hash.pp_short
        operation
        size
        max
  | Unallowed_pass {operation; pass; allowed_pass} ->
      Format.fprintf
        ppf
        "Operation %a included in validation pass %d,  while only the \
         following passes are allowed: @[<h>%a@]"
        Operation_hash.pp_short
        operation
        pass
        Format.(pp_print_list pp_print_int)
        allowed_pass
  | Cannot_parse_block_header ->
      Format.fprintf ppf "Failed to parse the block header."
  | Economic_protocol_error err ->
      Format.fprintf
        ppf
        "Failed to validate the economic-protocol content of the block: %a."
        Error_monad.pp_print_error
        err

type validation_process_error =
  | Missing_handshake
  | Inconsistent_handshake of string
  | Protocol_dynlink_failure of string

let validation_process_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Missing_handshake"
        (obj1 (req "constant" (constant "missing_handshake")))
        (function Missing_handshake -> Some () | _ -> None)
        (fun () -> Missing_handshake);
      case
        (Tag 1)
        ~title:"Inconsistent_handshake"
        (obj1 (req "inconsistent_handshake" string))
        (function Inconsistent_handshake msg -> Some msg | _ -> None)
        (fun msg -> Inconsistent_handshake msg);
      case
        (Tag 2)
        ~title:"Protocol_dynlink_failure"
        (obj1 (req "pretocol_dynlink_failure" string))
        (function Protocol_dynlink_failure msg -> Some msg | _ -> None)
        (fun msg -> Protocol_dynlink_failure msg) ]

let pp_validation_process_error ppf = function
  | Missing_handshake ->
      Format.fprintf
        ppf
        "Missing handshake while initializing validation process."
  | Protocol_dynlink_failure msg ->
      Format.fprintf ppf "%s" msg
  | Inconsistent_handshake msg ->
      Format.fprintf ppf "Inconsistent handshake: %s." msg

type error +=
  | Invalid_block of {block : Block_hash.t; error : block_error}
  | Unavailable_protocol of {block : Block_hash.t; protocol : Protocol_hash.t}
  | Inconsistent_operations_hash of {
      block : Block_hash.t;
      expected : Operation_list_list_hash.t;
      found : Operation_list_list_hash.t;
    }
  | Failed_to_checkout_context of Context_hash.t
  | System_error of {errno : Unix.error; fn : string; msg : string}
  | Missing_test_protocol of Protocol_hash.t
  | Validation_process_failed of validation_process_error

let () =
  Error_monad.register_error_kind
    `Permanent
    ~id:"validator.invalid_block"
    ~title:"Invalid block"
    ~description:"Invalid block."
    ~pp:(fun ppf (block, error) ->
      Format.fprintf
        ppf
        "@[<v 2>Invalid block %a@ %a@]"
        Block_hash.pp_short
        block
        pp_block_error
        error)
    Data_encoding.(
      merge_objs
        (obj1 (req "invalid_block" Block_hash.encoding))
        block_error_encoding)
    (function
      | Invalid_block {block; error} -> Some (block, error) | _ -> None)
    (fun (block, error) -> Invalid_block {block; error}) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"validator.unavailable_protocol"
    ~title:"Missing protocol"
    ~description:"The protocol required for validating a block is missing."
    ~pp:(fun ppf (block, protocol) ->
      Format.fprintf
        ppf
        "Missing protocol (%a) when validating the block %a."
        Protocol_hash.pp_short
        protocol
        Block_hash.pp_short
        block)
    Data_encoding.(
      obj2
        (req "block" Block_hash.encoding)
        (req "missing_protocol" Protocol_hash.encoding))
    (function
      | Unavailable_protocol {block; protocol} ->
          Some (block, protocol)
      | _ ->
          None)
    (fun (block, protocol) -> Unavailable_protocol {block; protocol}) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"validator.inconsistent_operations_hash"
    ~title:"Invalid merkle tree"
    ~description:
      "The provided list of operations is inconsistent with the block header."
    ~pp:(fun ppf (block, expected, found) ->
      Format.fprintf
        ppf
        "@[<v 2>The provided list of operations for block %a  is inconsistent \
         with the block header@  expected: %a@  found: %a@]"
        Block_hash.pp_short
        block
        Operation_list_list_hash.pp_short
        expected
        Operation_list_list_hash.pp_short
        found)
    Data_encoding.(
      obj3
        (req "block" Block_hash.encoding)
        (req "expected" Operation_list_list_hash.encoding)
        (req "found" Operation_list_list_hash.encoding))
    (function
      | Inconsistent_operations_hash {block; expected; found} ->
          Some (block, expected, found)
      | _ ->
          None)
    (fun (block, expected, found) ->
      Inconsistent_operations_hash {block; expected; found}) ;
  Error_monad.register_error_kind
    `Permanent
    ~id:"Block_validator_process.failed_to_checkout_context"
    ~title:"Fail during checkout context"
    ~description:"The context checkout failed using a given hash"
    ~pp:(fun ppf (hash : Context_hash.t) ->
      Format.fprintf
        ppf
        "@[Failed to checkout the context with hash %a@]"
        Context_hash.pp_short
        hash)
    Data_encoding.(obj1 (req "hash" Context_hash.encoding))
    (function Failed_to_checkout_context h -> Some h | _ -> None)
    (fun h -> Failed_to_checkout_context h) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"Validator_process.system_error_while_validating"
    ~title:"Failed to validate block because of a system error"
    ~description:"The validator failed because of a system error"
    ~pp:(fun ppf (errno, fn, msg) ->
      Format.fprintf
        ppf
        "System error while validating a block (in function %s(%s)):@ %s"
        fn
        msg
        (Unix.error_message errno))
    Data_encoding.(
      obj3 (req "errno" errno) (req "function" string) (req "msg" string))
    (function
      | System_error {errno; fn; msg} -> Some (errno, fn, msg) | _ -> None)
    (fun (errno, fn, msg) -> System_error {errno; fn; msg}) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"validator.missing_test_protocol"
    ~title:"Missing test protocol"
    ~description:"Missing test protocol when forking the test chain"
    ~pp:(fun ppf protocol ->
      Format.fprintf
        ppf
        "Missing test protocol %a when forking the test chain."
        Protocol_hash.pp
        protocol)
    Data_encoding.(obj1 (req "test_protocol" Protocol_hash.encoding))
    (function Missing_test_protocol protocol -> Some protocol | _ -> None)
    (fun protocol -> Missing_test_protocol protocol) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"validator.validation_process_failed"
    ~title:"Validation process failed"
    ~description:"Failed to validate block using exteranl validation process."
    ~pp:(fun ppf error ->
      Format.fprintf
        ppf
        "Failed to validate block using exteranl validation process. %a"
        pp_validation_process_error
        error)
    Data_encoding.(obj1 (req "error" validation_process_error_encoding))
    (function Validation_process_failed error -> Some error | _ -> None)
    (fun error -> Validation_process_failed error)

let invalid_block block error = Invalid_block {block; error}
src/lib_shell_services/block_validator_errors.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive block_error : Type :=
| Cannot_parse_operation : Tezos_base__TzPervasives.Operation_hash.t ->
  block_error
| Invalid_fitness : Tezos_base__TzPervasives.Fitness.t ->
  Tezos_base__TzPervasives.Fitness.t -> block_error
| Non_increasing_timestamp : block_error
| Non_increasing_fitness : block_error
| Invalid_level : Stdlib.Int32.t -> Stdlib.Int32.t -> block_error
| Invalid_proto_level : Z -> Z -> block_error
| Replayed_operation : Tezos_base__TzPervasives.Operation_hash.t -> block_error
| Outdated_operation : Tezos_base__TzPervasives.Operation_hash.t ->
  Tezos_base__TzPervasives.Block_hash.t -> block_error
| Expired_chain : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Time.Protocol.t ->
  Tezos_base__TzPervasives.Time.Protocol.t -> block_error
| Unexpected_number_of_validation_passes : Z -> block_error
| Too_many_operations : Z -> Z -> Z -> block_error
| Oversized_operation : Tezos_base__TzPervasives.Operation_hash.t -> Z -> Z ->
  block_error
| Unallowed_pass : Tezos_base__TzPervasives.Operation_hash.t -> Z -> (list Z) ->
  block_error
| Cannot_parse_block_header : block_error
| Economic_protocol_error : (list Tezos_base__TzPervasives.error) -> block_error.

Definition errno : Tezos_base__TzPervasives.Data_encoding.t Unix.error :=
  Tezos_base__TzPervasives.Data_encoding.union None
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case "unknown_unix_error" % string
        None (Tag 0) Tezos_base__TzPervasives.Data_encoding.int8
        (fun function_parameter =>
          match function_parameter with
          | Unix.EUNKNOWNERR i => Some i
          | _ => None
          end) (fun i => EUNKNOWNERR i))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "unix_error" % string None
          (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.string_enum
            (cons ("2big" % string, E2BIG)
              (cons ("acces" % string, EACCES)
                (cons ("again" % string, EAGAIN)
                  (cons ("badf" % string, EBADF)
                    (cons ("busy" % string, EBUSY)
                      (cons ("child" % string, ECHILD)
                        (cons ("deadlk" % string, EDEADLK)
                          (cons ("dom" % string, EDOM)
                            (cons ("exist" % string, EEXIST)
                              (cons ("fault" % string, EFAULT)
                                (cons ("fbig" % string, EFBIG)
                                  (cons ("intr" % string, EINTR)
                                    (cons ("inval" % string, EINVAL)
                                      (cons ("io" % string, EIO)
                                        (cons ("isdir" % string, EISDIR)
                                          (cons ("mfile" % string, EMFILE)
                                            (cons ("mlink" % string, EMLINK)
                                              (cons
                                                ("nametoolong" % string,
                                                  ENAMETOOLONG)
                                                (cons ("nfile" % string, ENFILE)
                                                  (cons
                                                    ("nodev" % string, ENODEV)
                                                    (cons
                                                      ("noent" % string, ENOENT)
                                                      (cons
                                                        ("noexec" % string,
                                                          ENOEXEC)
                                                        (cons
                                                          ("nolck" % string,
                                                            ENOLCK)
                                                          (cons
                                                            ("nomem" % string,
                                                              ENOMEM)
                                                            (cons
                                                              ("nospc" % string,
                                                                ENOSPC)
                                                              (cons
                                                                ("nosys" %
                                                                  string, ENOSYS)
                                                                (cons
                                                                  ("notdir" %
                                                                    string,
                                                                    ENOTDIR)
                                                                  (cons
                                                                    ("notempty"
                                                                      % string,
                                                                      ENOTEMPTY)
                                                                    (cons
                                                                      ("notty" %
                                                                        string,
                                                                        ENOTTY)
                                                                      (cons
                                                                        ("nxio"
                                                                          %
                                                                          string,
                                                                          ENXIO)
                                                                        (cons
                                                                          ("perm"
                                                                            %
                                                                            string,
                                                                            EPERM)
                                                                          (cons
                                                                            ("pipe"
                                                                              %
                                                                              string,
                                                                              EPIPE)
                                                                            (cons
                                                                              ("range"
                                                                                %
                                                                                string,
                                                                                ERANGE)
                                                                              (cons
                                                                                ("rofs"
                                                                                  %
                                                                                  string,
                                                                                  EROFS)
                                                                                (cons
                                                                                  ("spipe"
                                                                                    %
                                                                                    string,
                                                                                    ESPIPE)
                                                                                  (cons
                                                                                    ("srch"
                                                                                      %
                                                                                      string,
                                                                                      ESRCH)
                                                                                    (cons
                                                                                      ("xdev"
                                                                                        %
                                                                                        string,
                                                                                        EXDEV)
                                                                                      (cons
                                                                                        ("wouldblock"
                                                                                          %
                                                                                          string,
                                                                                          EWOULDBLOCK)
                                                                                        (cons
                                                                                          ("inprogress"
                                                                                            %
                                                                                            string,
                                                                                            EINPROGRESS)
                                                                                          (cons
                                                                                            ("already"
                                                                                              %
                                                                                              string,
                                                                                              EALREADY)
                                                                                            (cons
                                                                                              ("notsock"
                                                                                                %
                                                                                                string,
                                                                                                ENOTSOCK)
                                                                                              (cons
                                                                                                ("destaddrreq"
                                                                                                  %
                                                                                                  string,
                                                                                                  EDESTADDRREQ)
                                                                                                (cons
                                                                                                  ("msgsize"
                                                                                                    %
                                                                                                    string,
                                                                                                    EMSGSIZE)
                                                                                                  (cons
                                                                                                    ("prototype"
                                                                                                      %
                                                                                                      string,
                                                                                                      EPROTOTYPE)
                                                                                                    (cons
                                                                                                      ("noprotoopt"
                                                                                                        %
                                                                                                        string,
                                                                                                        ENOPROTOOPT)
                                                                                                      (cons
                                                                                                        ("protonosupport"
                                                                                                          %
                                                                                                          string,
                                                                                                          EPROTONOSUPPORT)
                                                                                                        (cons
                                                                                                          ("socktnosupport"
                                                                                                            %
                                                                                                            string,
                                                                                                            ESOCKTNOSUPPORT)
                                                                                                          (cons
                                                                                                            ("opnotsupp"
                                                                                                              %
                                                                                                              string,
                                                                                                              EOPNOTSUPP)
                                                                                                            (cons
                                                                                                              ("pfnosupport"
                                                                                                                %
                                                                                                                string,
                                                                                                                EPFNOSUPPORT)
                                                                                                              (cons
                                                                                                                ("afnosupport"
                                                                                                                  %
                                                                                                                  string,
                                                                                                                  EAFNOSUPPORT)
                                                                                                                (cons
                                                                                                                  ("addrinuse"
                                                                                                                    %
                                                                                                                    string,
                                                                                                                    EADDRINUSE)
                                                                                                                  (cons
                                                                                                                    ("addrnotavail"
                                                                                                                      %
                                                                                                                      string,
                                                                                                                      EADDRNOTAVAIL)
                                                                                                                    (cons
                                                                                                                      ("netdown"
                                                                                                                        %
                                                                                                                        string,
                                                                                                                        ENETDOWN)
                                                                                                                      (cons
                                                                                                                        ("netunreach"
                                                                                                                          %
                                                                                                                          string,
                                                                                                                          ENETUNREACH)
                                                                                                                        (cons
                                                                                                                          ("netreset"
                                                                                                                            %
                                                                                                                            string,
                                                                                                                            ENETRESET)
                                                                                                                          (cons
                                                                                                                            ("connaborted"
                                                                                                                              %
                                                                                                                              string,
                                                                                                                              ECONNABORTED)
                                                                                                                            (cons
                                                                                                                              ("connreset"
                                                                                                                                %
                                                                                                                                string,
                                                                                                                                ECONNRESET)
                                                                                                                              (cons
                                                                                                                                ("nobufs"
                                                                                                                                  %
                                                                                                                                  string,
                                                                                                                                  ENOBUFS)
                                                                                                                                (cons
                                                                                                                                  ("isconn"
                                                                                                                                    %
                                                                                                                                    string,
                                                                                                                                    EISCONN)
                                                                                                                                  (cons
                                                                                                                                    ("notconn"
                                                                                                                                      %
                                                                                                                                      string,
                                                                                                                                      ENOTCONN)
                                                                                                                                    (cons
                                                                                                                                      ("shutdown"
                                                                                                                                        %
                                                                                                                                        string,
                                                                                                                                        ESHUTDOWN)
                                                                                                                                      (cons
                                                                                                                                        ("toomanyrefs"
                                                                                                                                          %
                                                                                                                                          string,
                                                                                                                                          ETOOMANYREFS)
                                                                                                                                        (cons
                                                                                                                                          ("timedout"
                                                                                                                                            %
                                                                                                                                            string,
                                                                                                                                            ETIMEDOUT)
                                                                                                                                          (cons
                                                                                                                                            ("connrefused"
                                                                                                                                              %
                                                                                                                                              string,
                                                                                                                                              ECONNREFUSED)
                                                                                                                                            (cons
                                                                                                                                              ("hostdown"
                                                                                                                                                %
                                                                                                                                                string,
                                                                                                                                                EHOSTDOWN)
                                                                                                                                              (cons
                                                                                                                                                ("hostunreach"
                                                                                                                                                  %
                                                                                                                                                  string,
                                                                                                                                                  EHOSTUNREACH)
                                                                                                                                                (cons
                                                                                                                                                  ("loop"
                                                                                                                                                    %
                                                                                                                                                    string,
                                                                                                                                                    ELOOP)
                                                                                                                                                  (cons
                                                                                                                                                    ("overflow"
                                                                                                                                                      %
                                                                                                                                                      string,
                                                                                                                                                      EOVERFLOW)
                                                                                                                                                    [])))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
          (fun x => Some x) (fun x => x)) [])).

Definition block_error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding block_error :=
  Tezos_base__TzPervasives.Data_encoding.union None
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case
        "Cannot_parse_operation" % string None (Tag 0)
        (Tezos_base__TzPervasives.Data_encoding.obj2
          (Tezos_base__TzPervasives.Data_encoding.req None None "error" % string
            (Tezos_base__TzPervasives.Data_encoding.constant
              "cannot_parse_operation" % string))
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "operation" % string
            Tezos_base__TzPervasives.Operation_hash.encoding))
        (fun function_parameter =>
          match function_parameter with
          | Cannot_parse_operation operation => Some (tt, operation)
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | (tt, operation) => Cannot_parse_operation operation
          end))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Invalid_fitness" % string
          None (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.obj3
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "error" % string
              (Tezos_base__TzPervasives.Data_encoding.constant
                "invalid_fitness" % string))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "expected" % string Tezos_base__TzPervasives.Fitness.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "found" % string Tezos_base__TzPervasives.Fitness.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Invalid_fitness {| expected := expected; found := found |} =>
              Some (tt, expected, found)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (tt, expected, found) =>
              Invalid_fitness {| expected := expected; found := found |}
            end))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case
            "Non_increasing_timestamp" % string None (Tag 2)
            (Tezos_base__TzPervasives.Data_encoding.obj1
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "error" % string
                (Tezos_base__TzPervasives.Data_encoding.constant
                  "non_increasing_timestamp" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Non_increasing_timestamp => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => Non_increasing_timestamp
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case
              "Non_increasing_fitness" % string None (Tag 3)
              (Tezos_base__TzPervasives.Data_encoding.obj1
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "error" % string
                  (Tezos_base__TzPervasives.Data_encoding.constant
                    "non_increasing_fitness" % string)))
              (fun function_parameter =>
                match function_parameter with
                | Non_increasing_fitness => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | tt => Non_increasing_fitness
                end))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case
                "Invalid_level" % string None (Tag 4)
                (Tezos_base__TzPervasives.Data_encoding.obj3
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "error" % string
                    (Tezos_base__TzPervasives.Data_encoding.constant
                      "invalid_level" % string))
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "expected" % string
                    Tezos_base__TzPervasives.Data_encoding.int32)
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "found" % string
                    Tezos_base__TzPervasives.Data_encoding.int32))
                (fun function_parameter =>
                  match function_parameter with
                  | Invalid_level {| expected := expected; found := found |} =>
                    Some (tt, expected, found)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (tt, expected, found) =>
                    Invalid_level {| expected := expected; found := found |}
                  end))
              (cons
                (Tezos_base__TzPervasives.Data_encoding.case
                  "Invalid_proto_level" % string None (Tag 5)
                  (Tezos_base__TzPervasives.Data_encoding.obj3
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "error" % string
                      (Tezos_base__TzPervasives.Data_encoding.constant
                        "invalid_proto_level" % string))
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "expected" % string
                      Tezos_base__TzPervasives.Data_encoding.uint8)
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "found" % string
                      Tezos_base__TzPervasives.Data_encoding.uint8))
                  (fun function_parameter =>
                    match function_parameter with
                    |
                      Invalid_proto_level {|
                        expected := expected; found := found |} =>
                      Some (tt, expected, found)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | (tt, expected, found) =>
                      Invalid_proto_level
                        {| expected := expected; found := found |}
                    end))
                (cons
                  (Tezos_base__TzPervasives.Data_encoding.case
                    "Replayed_operation" % string None (Tag 6)
                    (Tezos_base__TzPervasives.Data_encoding.obj2
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "error" % string
                        (Tezos_base__TzPervasives.Data_encoding.constant
                          "replayed_operation" % string))
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "operation" % string
                        Tezos_base__TzPervasives.Operation_hash.encoding))
                    (fun function_parameter =>
                      match function_parameter with
                      | Replayed_operation operation => Some (tt, operation)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | (tt, operation) => Replayed_operation operation
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Data_encoding.case
                      "Outdated_operation" % string None (Tag 7)
                      (Tezos_base__TzPervasives.Data_encoding.obj3
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "error" % string
                          (Tezos_base__TzPervasives.Data_encoding.constant
                            "outdated_operation" % string))
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "operation" % string
                          Tezos_base__TzPervasives.Operation_hash.encoding)
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "originating_block" % string
                          Tezos_base__TzPervasives.Block_hash.encoding))
                      (fun function_parameter =>
                        match function_parameter with
                        |
                          Outdated_operation {|
                            operation := operation;
                              originating_block := originating_block
                              |} => Some (tt, operation, originating_block)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | (tt, operation, originating_block) =>
                          Outdated_operation
                            {| operation := operation;
                              originating_block := originating_block |}
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Data_encoding.case
                        "Expired_chain" % string None (Tag 8)
                        (Tezos_base__TzPervasives.Data_encoding.obj4
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "error" % string
                            (Tezos_base__TzPervasives.Data_encoding.constant
                              "expired_chain" % string))
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "chain_id" % string
                            Tezos_base__TzPervasives.Chain_id.encoding)
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "expiration" % string
                            Tezos_base__TzPervasives.Time.Protocol.encoding)
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "timestamp" % string
                            Tezos_base__TzPervasives.Time.Protocol.encoding))
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Expired_chain {|
                              chain_id := chain_id;
                                expiration := expiration;
                                timestamp := timestamp
                                |} => Some (tt, chain_id, expiration, timestamp)
                          | _ => None
                          end)
                        (fun function_parameter =>
                          match function_parameter with
                          | (tt, chain_id, expiration, timestamp) =>
                            Expired_chain
                              {| chain_id := chain_id; expiration := expiration;
                                timestamp := timestamp |}
                          end))
                      (cons
                        (Tezos_base__TzPervasives.Data_encoding.case
                          "Unexpected_number_of_validation_passes" % string None
                          (Tag 9)
                          (Tezos_base__TzPervasives.Data_encoding.obj2
                            (Tezos_base__TzPervasives.Data_encoding.req None
                              None "error" % string
                              (Tezos_base__TzPervasives.Data_encoding.constant
                                "unexpected_number_of_passes" % string))
                            (Tezos_base__TzPervasives.Data_encoding.req None
                              None "found" % string
                              Tezos_base__TzPervasives.Data_encoding.uint8))
                          (fun function_parameter =>
                            match function_parameter with
                            | Unexpected_number_of_validation_passes n =>
                              Some (tt, n)
                            | _ => None
                            end)
                          (fun function_parameter =>
                            match function_parameter with
                            | (tt, n) =>
                              Unexpected_number_of_validation_passes n
                            end))
                        (cons
                          (Tezos_base__TzPervasives.Data_encoding.case
                            "Too_many_operations" % string None (Tag 10)
                            (Tezos_base__TzPervasives.Data_encoding.obj4
                              (Tezos_base__TzPervasives.Data_encoding.req None
                                None "error" % string
                                (Tezos_base__TzPervasives.Data_encoding.constant
                                  "too_many_operations" % string))
                              (Tezos_base__TzPervasives.Data_encoding.req None
                                None "validation_pass" % string
                                Tezos_base__TzPervasives.Data_encoding.uint8)
                              (Tezos_base__TzPervasives.Data_encoding.req None
                                None "found" % string
                                Tezos_base__TzPervasives.Data_encoding.uint16)
                              (Tezos_base__TzPervasives.Data_encoding.req None
                                None "max" % string
                                Tezos_base__TzPervasives.Data_encoding.uint16))
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Too_many_operations {|
                                  pass := pass;
                                    found := found;
                                    max := max
                                    |} => Some (tt, pass, found, max)
                              | _ => None
                              end)
                            (fun function_parameter =>
                              match function_parameter with
                              | (tt, pass, found, max) =>
                                Too_many_operations
                                  {| pass := pass; found := found; max := max |}
                              end))
                          (cons
                            (Tezos_base__TzPervasives.Data_encoding.case
                              "Oversized_operation" % string None (Tag 11)
                              (Tezos_base__TzPervasives.Data_encoding.obj4
                                (Tezos_base__TzPervasives.Data_encoding.req None
                                  None "error" % string
                                  (Tezos_base__TzPervasives.Data_encoding.constant
                                    "oversized_operation" % string))
                                (Tezos_base__TzPervasives.Data_encoding.req None
                                  None "operation" % string
                                  Tezos_base__TzPervasives.Operation_hash.encoding)
                                (Tezos_base__TzPervasives.Data_encoding.req None
                                  None "found" % string
                                  Tezos_base__TzPervasives.Data_encoding.int31)
                                (Tezos_base__TzPervasives.Data_encoding.req None
                                  None "max" % string
                                  Tezos_base__TzPervasives.Data_encoding.int31))
                              (fun function_parameter =>
                                match function_parameter with
                                |
                                  Oversized_operation {|
                                    operation := operation;
                                      size := size;
                                      max := max
                                      |} => Some (tt, operation, size, max)
                                | _ => None
                                end)
                              (fun function_parameter =>
                                match function_parameter with
                                | (tt, operation, size, max) =>
                                  Oversized_operation
                                    {| operation := operation; size := size;
                                      max := max |}
                                end))
                            (cons
                              (Tezos_base__TzPervasives.Data_encoding.case
                                "Unallowed_pass" % string None (Tag 12)
                                (Tezos_base__TzPervasives.Data_encoding.obj4
                                  (Tezos_base__TzPervasives.Data_encoding.req
                                    None None "error" % string
                                    (Tezos_base__TzPervasives.Data_encoding.constant
                                      "invalid_pass" % string))
                                  (Tezos_base__TzPervasives.Data_encoding.req
                                    None None "operation" % string
                                    Tezos_base__TzPervasives.Operation_hash.encoding)
                                  (Tezos_base__TzPervasives.Data_encoding.req
                                    None None "pass" % string
                                    Tezos_base__TzPervasives.Data_encoding.uint8)
                                  (Tezos_base__TzPervasives.Data_encoding.req
                                    None None "allowed_pass" % string
                                    (Tezos_base__TzPervasives.Data_encoding.list
                                      None
                                      Tezos_base__TzPervasives.Data_encoding.uint8)))
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    Unallowed_pass {|
                                      operation := operation;
                                        pass := pass;
                                        allowed_pass := allowed_pass
                                        |} =>
                                    Some (tt, operation, pass, allowed_pass)
                                  | _ => None
                                  end)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (tt, operation, pass, allowed_pass) =>
                                    Unallowed_pass
                                      {| operation := operation; pass := pass;
                                        allowed_pass := allowed_pass |}
                                  end))
                              (cons
                                (Tezos_base__TzPervasives.Data_encoding.case
                                  "Cannot_parse_block_header" % string None
                                  (Tag 13)
                                  (Tezos_base__TzPervasives.Data_encoding.obj1
                                    (Tezos_base__TzPervasives.Data_encoding.req
                                      None None "error" % string
                                      (Tezos_base__TzPervasives.Data_encoding.constant
                                        "cannot_parse_bock_header" % string)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Cannot_parse_block_header => Some tt
                                    | _ => None
                                    end)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Cannot_parse_block_header
                                    end)) [])))))))))))))).

Definition pp_block_error
  (ppf : Stdlib.Format.formatter) (function_parameter : block_error) : unit :=
  match function_parameter with
  | Cannot_parse_operation oph =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to parse the operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "." % char
              CamlinternalFormatBasics.End_of_format)))
        "Failed to parse the operation %a." % string)
      Tezos_base__TzPervasives.Operation_hash.pp_short oph
  | Invalid_fitness {| expected := expected; found := found |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Invalid fitness:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String_literal " expected " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal " found " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))))))
        "@[<v 2>Invalid fitness:@  expected %a@  found %a@]" % string)
      Tezos_base__TzPervasives.Fitness.pp expected
      Tezos_base__TzPervasives.Fitness.pp found
  | Non_increasing_timestamp =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Non increasing timestamp" % string
          CamlinternalFormatBasics.End_of_format)
        "Non increasing timestamp" % string)
  | Non_increasing_fitness =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Non increasing fitness" % string
          CamlinternalFormatBasics.End_of_format)
        "Non increasing fitness" % string)
  | Invalid_level {| expected := expected; found := found |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid level:" % string
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal " expected " % string
              (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal " found " % string
                    (CamlinternalFormatBasics.Int32
                      CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid level:@  expected %ld@  found %ld" % string) expected found
  | Invalid_proto_level {| expected := expected; found := found |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Invalid protocol level:" % string
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal " expected " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal " found " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid protocol level:@  expected %d@  found %d" % string) expected
      found
  | Replayed_operation oph =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "The operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " was previously included in the chain." % string
              CamlinternalFormatBasics.End_of_format)))
        "The operation %a was previously included in the chain." % string)
      Tezos_base__TzPervasives.Operation_hash.pp_short oph
  |
    Outdated_operation {|
      operation := operation; originating_block := originating_block |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "The operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " is outdated (originated in block: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "The operation %a is outdated (originated in block: %a)" % string)
      Tezos_base__TzPervasives.Operation_hash.pp_short operation
      Tezos_base__TzPervasives.Block_hash.pp_short originating_block
  |
    Expired_chain {|
      chain_id := chain_id;
        expiration := expiration;
        timestamp := timestamp
        |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "The block timestamp (" % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              ") is later than its chain expiration date: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " (chain: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ")." % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "The block timestamp (%a) is later than its chain expiration date: %a (chain: %a)."
          % string) Tezos_base__TzPervasives.Time.System.pp_hum
      (Tezos_base__TzPervasives.Time.System.of_protocol_exn timestamp)
      Tezos_base__TzPervasives.Time.System.pp_hum
      (Tezos_base__TzPervasives.Time.System.of_protocol_exn expiration)
      Tezos_base__TzPervasives.Chain_id.pp_short chain_id
  | Unexpected_number_of_validation_passes n =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Invalid number of validation passes (found: " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Invalid number of validation passes (found: %d)" % string) n
  | Too_many_operations {| pass := pass; found := found; max := max |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Too many operations in validation pass " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " (found: " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal ", max: " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format)))))))
        "Too many operations in validation pass %d (found: %d, max: %d)" %
          string) pass found max
  | Oversized_operation {| operation := operation; size := size; max := max |}
    =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Oversized operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " (size: " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal ", max: " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format)))))))
        "Oversized operation %a (size: %d, max: %d)" % string)
      Tezos_base__TzPervasives.Operation_hash.pp_short operation size max
  |
    Unallowed_pass {|
      operation := operation; pass := pass; allowed_pass := allowed_pass |}
    =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " included in validation pass " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal
                  ",  while only the following passes are allowed: " % string
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal "<h>" % string
                          CamlinternalFormatBasics.End_of_format) "<h>" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))))
        "Operation %a included in validation pass %d,  while only the following passes are allowed: @[<h>%a@]"
          % string) Tezos_base__TzPervasives.Operation_hash.pp_short operation
      pass (Stdlib.Format.pp_print_list None Stdlib.Format.pp_print_int)
      allowed_pass
  | Cannot_parse_block_header =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to parse the block header." % string
          CamlinternalFormatBasics.End_of_format)
        "Failed to parse the block header." % string)
  | Economic_protocol_error err =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to validate the economic-protocol content of the block: " %
            string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "." % char
              CamlinternalFormatBasics.End_of_format)))
        "Failed to validate the economic-protocol content of the block: %a." %
          string) Tezos_base__TzPervasives.Error_monad.pp_print_error err
  end.

Inductive validation_process_error : Type :=
| Missing_handshake : validation_process_error
| Inconsistent_handshake : string -> validation_process_error
| Protocol_dynlink_failure : string -> validation_process_error.

Definition validation_process_error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding validation_process_error :=
  Tezos_base__TzPervasives.Data_encoding.union None
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case "Missing_handshake" % string
        None (Tag 0)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "constant" % string
            (Tezos_base__TzPervasives.Data_encoding.constant
              "missing_handshake" % string)))
        (fun function_parameter =>
          match function_parameter with
          | Missing_handshake => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | tt => Missing_handshake
          end))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case
          "Inconsistent_handshake" % string None (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.obj1
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "inconsistent_handshake" % string
              Tezos_base__TzPervasives.Data_encoding.string))
          (fun function_parameter =>
            match function_parameter with
            | Inconsistent_handshake msg => Some msg
            | _ => None
            end) (fun msg => Inconsistent_handshake msg))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case
            "Protocol_dynlink_failure" % string None (Tag 2)
            (Tezos_base__TzPervasives.Data_encoding.obj1
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "pretocol_dynlink_failure" % string
                Tezos_base__TzPervasives.Data_encoding.string))
            (fun function_parameter =>
              match function_parameter with
              | Protocol_dynlink_failure msg => Some msg
              | _ => None
              end) (fun msg => Protocol_dynlink_failure msg)) []))).

Definition pp_validation_process_error
  (ppf : Stdlib.Format.formatter)
  (function_parameter : validation_process_error) : unit :=
  match function_parameter with
  | Missing_handshake =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Missing handshake while initializing validation process." % string
          CamlinternalFormatBasics.End_of_format)
        "Missing handshake while initializing validation process." % string)
  | Protocol_dynlink_failure msg =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) msg
  | Inconsistent_handshake msg =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Inconsistent handshake: " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "." % char
              CamlinternalFormatBasics.End_of_format)))
        "Inconsistent handshake: %s." % string) msg
  end.

Definition invalid_block
  (block : Tezos_base__TzPervasives.Block_hash.t) (error : block_error)
  : Tezos_base__TzPervasives.error :=
  Invalid_block {| block := block; error := error |}.
src/lib_shell_services/block_validator_errors.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type block_error =
  | Cannot_parse_operation of Operation_hash.t
  | Invalid_fitness of {expected : Fitness.t; found : Fitness.t}
  | Non_increasing_timestamp
  | Non_increasing_fitness
  | Invalid_level of {expected : Int32.t; found : Int32.t}
  | Invalid_proto_level of {expected : int; found : int}
  | Replayed_operation of Operation_hash.t
  | Outdated_operation of {
      operation : Operation_hash.t;
      originating_block : Block_hash.t;
    }
  | Expired_chain of {
      chain_id : Chain_id.t;
      expiration : Time.Protocol.t;
      timestamp : Time.Protocol.t;
    }
  | Unexpected_number_of_validation_passes of int (* uint8 *)
  | Too_many_operations of {pass : int; found : int; max : int}
  | Oversized_operation of {
      operation : Operation_hash.t;
      size : int;
      max : int;
    }
  | Unallowed_pass of {
      operation : Operation_hash.t;
      pass : int;
      allowed_pass : int list;
    }
  | Cannot_parse_block_header
  | Economic_protocol_error of error list

type validation_process_error =
  | Missing_handshake
  | Inconsistent_handshake of string
  | Protocol_dynlink_failure of string

type error +=
  | Invalid_block of {block : Block_hash.t; error : block_error}
  | Unavailable_protocol of {block : Block_hash.t; protocol : Protocol_hash.t}
  | Inconsistent_operations_hash of {
      block : Block_hash.t;
      expected : Operation_list_list_hash.t;
      found : Operation_list_list_hash.t;
    }
  | Failed_to_checkout_context of Context_hash.t
  | System_error of {errno : Unix.error; fn : string; msg : string}
  | Missing_test_protocol of Protocol_hash.t
  | Validation_process_failed of validation_process_error

val invalid_block : Block_hash.t -> block_error -> error
src/lib_shell_services/block_validator_errors.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive block_error : Type :=
| Cannot_parse_operation : Tezos_base__TzPervasives.Operation_hash.t ->
  block_error
| Invalid_fitness : Tezos_base__TzPervasives.Fitness.t ->
  Tezos_base__TzPervasives.Fitness.t -> block_error
| Non_increasing_timestamp : block_error
| Non_increasing_fitness : block_error
| Invalid_level : Stdlib.Int32.t -> Stdlib.Int32.t -> block_error
| Invalid_proto_level : Z -> Z -> block_error
| Replayed_operation : Tezos_base__TzPervasives.Operation_hash.t -> block_error
| Outdated_operation : Tezos_base__TzPervasives.Operation_hash.t ->
  Tezos_base__TzPervasives.Block_hash.t -> block_error
| Expired_chain : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Time.Protocol.t ->
  Tezos_base__TzPervasives.Time.Protocol.t -> block_error
| Unexpected_number_of_validation_passes : Z -> block_error
| Too_many_operations : Z -> Z -> Z -> block_error
| Oversized_operation : Tezos_base__TzPervasives.Operation_hash.t -> Z -> Z ->
  block_error
| Unallowed_pass : Tezos_base__TzPervasives.Operation_hash.t -> Z -> (list Z) ->
  block_error
| Cannot_parse_block_header : block_error
| Economic_protocol_error : (list Tezos_base__TzPervasives.error) -> block_error.

Inductive validation_process_error : Type :=
| Missing_handshake : validation_process_error
| Inconsistent_handshake : string -> validation_process_error
| Protocol_dynlink_failure : string -> validation_process_error.

extensible_type

Parameter invalid_block :
Tezos_base__TzPervasives.Block_hash.t ->
  block_error -> Tezos_base__TzPervasives.error.
src/lib_shell_services/block_validator_worker_state.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request = struct
  type view = {
    chain_id : Chain_id.t;
    block : Block_hash.t;
    peer : P2p_peer.Id.t option;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {chain_id; block; peer} -> (block, chain_id, peer))
      (fun (block, chain_id, peer) -> {chain_id; block; peer})
      (obj3
         (req "block" Block_hash.encoding)
         (req "chain_id" Chain_id.encoding)
         (opt "peer" P2p_peer.Id.encoding))

  let pp ppf {chain_id; block; peer} =
    Format.fprintf
      ppf
      "Validation of %a (chain: %a)"
      Block_hash.pp
      block
      Chain_id.pp_short
      chain_id ;
    match peer with
    | None ->
        ()
    | Some peer ->
        Format.fprintf ppf "from peer %a" P2p_peer.Id.pp_short peer
end

module Event = struct
  type t =
    | Validation_success of Request.view * Worker_types.request_status
    | Validation_failure of
        Request.view * Worker_types.request_status * error list
    | Debug of string

  let level req =
    match req with
    | Debug _ ->
        Internal_event.Debug
    | Validation_success _ | Validation_failure _ ->
        Internal_event.Notice

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Debug"
          (obj1 (req "message" string))
          (function Debug msg -> Some msg | _ -> None)
          (fun msg -> Debug msg);
        case
          (Tag 1)
          ~title:"Validation_success"
          (obj2
             (req "successful_validation" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function Validation_success (r, s) -> Some (r, s) | _ -> None)
          (fun (r, s) -> Validation_success (r, s));
        case
          (Tag 2)
          ~title:"Validation_failure"
          (obj3
             (req "failed_validation" Request.encoding)
             (req "status" Worker_types.request_status_encoding)
             (dft "errors" RPC_error.encoding []))
          (function
            | Validation_failure (r, s, err) -> Some (r, s, err) | _ -> None)
          (fun (r, s, err) -> Validation_failure (r, s, err)) ]

  let pp ppf = function
    | Debug msg ->
        Format.fprintf ppf "%s" msg
    | Validation_success (req, {pushed; treated; completed}) ->
        Format.fprintf
          ppf
          "@[<v 0>Block %a successfully validated@,%a@]"
          Block_hash.pp
          req.block
          Worker_types.pp_status
          {pushed; treated; completed}
    | Validation_failure (req, {pushed; treated; completed}, errs) ->
        Format.fprintf
          ppf
          "@[<v 0>Validation of block %a failed@,%a, %a@]"
          Block_hash.pp
          req.block
          Worker_types.pp_status
          {pushed; treated; completed}
          (Format.pp_print_list Error_monad.pp)
          errs
end

module Worker_state = struct
  type view = unit

  let encoding = Data_encoding.empty

  let pp _ppf _view = ()
end
src/lib_shell_services/block_validator_worker_state.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Record view := {
    chain_id : Tezos_base__TzPervasives.Chain_id.t;
    block : Tezos_base__TzPervasives.Block_hash.t;
    peer : option Tezos_base__TzPervasives.P2p_peer.Id.t }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| chain_id := chain_id; block := block; peer := peer |} =>
          (block, chain_id, peer)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (block, chain_id, peer) =>
          {| chain_id := chain_id; block := block; peer := peer |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj3
        (Tezos_base__TzPervasives.Data_encoding.req None None "block" % string
          Tezos_base__TzPervasives.Block_hash.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
        (Tezos_base__TzPervasives.Data_encoding.opt None None "peer" % string
          Tezos_base__TzPervasives.P2p_peer.Id.encoding)).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
    : unit :=
    match function_parameter with
    | {| chain_id := chain_id; block := block; peer := peer |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Validation of " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " (chain: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))))
          "Validation of %a (chain: %a)" % string)
        Tezos_base__TzPervasives.Block_hash.pp block
        Tezos_base__TzPervasives.Chain_id.pp_short chain_id;
      match peer with
      | None => tt
      | Some peer =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "from peer " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "from peer %a" % string)
          Tezos_base__TzPervasives.P2p_peer.Id.pp_short peer
      end
    end.
End Request.

Module Event.
  Inductive t : Type :=
  | Validation_success : Request.view ->
    Tezos_shell_services.Worker_types.request_status -> t
  | Validation_failure : Request.view ->
    Tezos_shell_services.Worker_types.request_status ->
    (list Tezos_base__TzPervasives.error) -> t
  | Debug : string -> t.
  
  Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
    match req with
    | Debug _ => Internal_event.Debug
    | Validation_success _ _ | Validation_failure _ _ _ => Internal_event.Notice
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    Tezos_base__TzPervasives.Data_encoding.union None
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Debug" % string None
          (Tag 0)
          (Tezos_base__TzPervasives.Data_encoding.obj1
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "message" % string Tezos_base__TzPervasives.Data_encoding.string))
          (fun function_parameter =>
            match function_parameter with
            | Debug msg => Some msg
            | _ => None
            end) (fun msg => Debug msg))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case
            "Validation_success" % string None (Tag 1)
            (Tezos_base__TzPervasives.Data_encoding.obj2
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "successful_validation" % string Request.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "status" % string
                Tezos_shell_services.Worker_types.request_status_encoding))
            (fun function_parameter =>
              match function_parameter with
              | Validation_success r s => Some (r, s)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (r, s) => Validation_success r s
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case
              "Validation_failure" % string None (Tag 2)
              (Tezos_base__TzPervasives.Data_encoding.obj3
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "failed_validation" % string Request.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "status" % string
                  Tezos_shell_services.Worker_types.request_status_encoding)
                (Tezos_base__TzPervasives.Data_encoding.dft None None
                  "errors" % string Tezos_base__TzPervasives.RPC_error.encoding
                  []))
              (fun function_parameter =>
                match function_parameter with
                | Validation_failure r s err => Some (r, s, err)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (r, s, err) => Validation_failure r s err
                end)) []))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Debug msg =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) msg
    |
      Validation_success req {|
        pushed := pushed; treated := treated; completed := completed |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal "Block " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  " successfully validated" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))
          "@[<v 0>Block %a successfully validated@,%a@]" % string)
        Tezos_base__TzPervasives.Block_hash.pp (block req)
        Tezos_shell_services.Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
    |
      Validation_failure req {|
        pushed := pushed; treated := treated; completed := completed |} errs
      =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Validation of block " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " failed" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal ", " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))))))
          "@[<v 0>Validation of block %a failed@,%a, %a@]" % string)
        Tezos_base__TzPervasives.Block_hash.pp (block req)
        Tezos_shell_services.Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
        (Stdlib.Format.pp_print_list None
          Tezos_base__TzPervasives.Error_monad.pp) errs
    end.
End Event.

Module Worker_state.
  Definition view := unit.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Tezos_base__TzPervasives.Data_encoding.empty.
  
  Definition pp {A B : Type} (_ppf : A) (_view : B) : unit := tt.
End Worker_state.
src/lib_shell_services/block_validator_worker_state.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request : sig
  type view = {
    chain_id : Chain_id.t;
    block : Block_hash.t;
    peer : P2p_peer.Id.t option;
  }

  val encoding : view Data_encoding.encoding

  val pp : Format.formatter -> view -> unit
end

module Event : sig
  type t =
    | Validation_success of Request.view * Worker_types.request_status
    | Validation_failure of
        Request.view * Worker_types.request_status * error list
    | Debug of string

  val level : t -> Internal_event.level

  val encoding : t Data_encoding.encoding

  val pp : Format.formatter -> t -> unit
end

module Worker_state : sig
  type view = unit

  val encoding : view Data_encoding.encoding

  val pp : Format.formatter -> view -> unit
end
src/lib_shell_services/block_validator_worker_state.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Record view := {
    chain_id : Tezos_base__TzPervasives.Chain_id.t;
    block : Tezos_base__TzPervasives.Block_hash.t;
    peer : option Tezos_base__TzPervasives.P2p_peer.Id.t }.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding view.
  
  Parameter pp : Stdlib.Format.formatter -> view -> unit.
End Request.

Module Event.
  Inductive t : Type :=
  | Validation_success : Request.view ->
    Tezos_shell_services.Worker_types.request_status -> t
  | Validation_failure : Request.view ->
    Tezos_shell_services.Worker_types.request_status ->
    (list Tezos_base__TzPervasives.error) -> t
  | Debug : string -> t.
  
  Parameter level : t -> Tezos_base__TzPervasives.Internal_event.level.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding t.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
End Event.

Module Worker_state.
  Definition view := unit.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding view.
  
  Parameter pp : Stdlib.Format.formatter -> view -> unit.
End Worker_state.
src/lib_shell_services/chain_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

type chain = [`Main | `Test | `Hash of Chain_id.t]

let chain_arg = Block_services.chain_arg

let to_string = Block_services.chain_to_string

let parse_chain = Block_services.parse_chain

type invalid_block = {
  hash : Block_hash.t;
  level : Int32.t;
  errors : error list;
}

type prefix = Block_services.chain_prefix

let path = Block_services.chain_path

let checkpoint_encoding =
  obj4
    (req "block" Block_header.encoding)
    (req "save_point" int32)
    (req "caboose" int32)
    (req "history_mode" History_mode.encoding)

let invalid_block_encoding =
  conv
    (fun {hash; level; errors} -> (hash, level, errors))
    (fun (hash, level, errors) -> {hash; level; errors})
    (obj3
       (req "block" Block_hash.encoding)
       (req "level" int32)
       (req "errors" RPC_error.encoding))

module S = struct
  let path : prefix RPC_path.context = RPC_path.open_root

  let chain_id =
    RPC_service.get_service
      ~description:"The chain unique identifier."
      ~query:RPC_query.empty
      ~output:Chain_id.encoding
      RPC_path.(path / "chain_id")

  let checkpoint =
    RPC_service.get_service
      ~description:"The current checkpoint for this chain."
      ~query:RPC_query.empty
      ~output:checkpoint_encoding
      RPC_path.(path / "checkpoint")

  module Blocks = struct
    let list_query =
      let open RPC_query in
      query (fun length heads min_date ->
          object
            method length = length

            method heads = heads

            method min_date = min_date
          end)
      |+ opt_field
           "length"
           ~descr:
             "The requested number of predecessors to returns (per requested \
              head)."
           RPC_arg.int
           (fun x -> x#length)
      |+ multi_field
           "head"
           ~descr:
             "An empty argument requests blocks from the current heads. A non \
              empty list allow to request specific fragment of the chain."
           Block_hash.rpc_arg
           (fun x -> x#heads)
      |+ opt_field
           "min_date"
           ~descr:
             "When `min_date` is provided, heads with a timestamp before \
              `min_date` are filtered out"
           Time.Protocol.rpc_arg
           (fun x -> x#min_date)
      |> seal

    let path = RPC_path.(path / "blocks")

    let list =
      let open Data_encoding in
      RPC_service.get_service
        ~description:
          "Lists known heads of the blockchain sorted with decreasing \
           fitness. Optional arguments allows to returns the list of \
           predecessors for known heads or the list of predecessors for a \
           given list of blocks."
        ~query:list_query
        ~output:(list (list Block_hash.encoding))
        path
  end

  module Invalid_blocks = struct
    let path = RPC_path.(path / "invalid_blocks")

    let list =
      RPC_service.get_service
        ~description:
          "Lists blocks that have been declared invalid along with the errors \
           that led to them being declared invalid."
        ~query:RPC_query.empty
        ~output:(list invalid_block_encoding)
        path

    let get =
      RPC_service.get_service
        ~description:"The errors that appears during the block (in)validation."
        ~query:RPC_query.empty
        ~output:invalid_block_encoding
        RPC_path.(path /: Block_hash.rpc_arg)

    let delete =
      RPC_service.delete_service
        ~description:"Remove an invalid block for the tezos storage"
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        RPC_path.(path /: Block_hash.rpc_arg)
  end
end

let make_call0 s ctxt chain q p =
  let s = RPC_service.prefix path s in
  RPC_context.make_call1 s ctxt chain q p

let make_call1 s ctxt chain a q p =
  let s = RPC_service.prefix path s in
  RPC_context.make_call2 s ctxt chain a q p

let chain_id ctxt =
  let f = make_call0 S.chain_id ctxt in
  fun ?(chain = `Main) () ->
    match chain with `Hash h -> return h | _ -> f chain () ()

let checkpoint ctxt ?(chain = `Main) () =
  make_call0 S.checkpoint ctxt chain () ()

module Blocks = struct
  let list ctxt =
    let f = make_call0 S.Blocks.list ctxt in
    fun ?(chain = `Main) ?(heads = []) ?length ?min_date () ->
      f
        chain
        (object
           method heads = heads

           method length = length

           method min_date = min_date
        end)
        ()

  include Block_services.Empty

  type protocols = Block_services.protocols = {
    current_protocol : Protocol_hash.t;
    next_protocol : Protocol_hash.t;
  }

  let protocols = Block_services.protocols
end

module Mempool = Block_services.Empty.Mempool

module Invalid_blocks = struct
  let list ctxt =
    let f = make_call0 S.Invalid_blocks.list ctxt in
    fun ?(chain = `Main) () -> f chain () ()

  let get ctxt =
    let f = make_call1 S.Invalid_blocks.get ctxt in
    fun ?(chain = `Main) block -> f chain block () ()

  let delete ctxt =
    let f = make_call1 S.Invalid_blocks.delete ctxt in
    fun ?(chain = `Main) block -> f chain block () ()
end
src/lib_shell_services/chain_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Data_encoding.

Definition chain := variant.

Definition chain_arg
  : Tezos_base__TzPervasives.RPC_arg.t Tezos_shell_services.Block_services.chain :=
  Tezos_shell_services.Block_services.chain_arg.

Definition to_string : Tezos_shell_services.Block_services.chain -> string :=
  Tezos_shell_services.Block_services.chain_to_string.

Definition parse_chain
  : string -> sum Tezos_shell_services.Block_services.chain string :=
  Tezos_shell_services.Block_services.parse_chain.

Record invalid_block := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  level : Stdlib.Int32.t;
  errors : list Tezos_base__TzPervasives.error }.

Definition prefix := Tezos_shell_services.Block_services.chain_prefix.

Definition path
  : Tezos_base__TzPervasives.RPC_path.t unit
    Tezos_shell_services.Block_services.chain_prefix :=
  Tezos_shell_services.Block_services.chain_path.

Definition checkpoint_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    (Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
      Tezos_shell_services.History_mode.t) :=
  Tezos_base__TzPervasives.Data_encoding.obj4
    (Tezos_base__TzPervasives.Data_encoding.req None None "block" % string
      Tezos_base__TzPervasives.Block_header.encoding)
    (Tezos_base__TzPervasives.Data_encoding.req None None "save_point" % string
      Tezos_base__TzPervasives.Data_encoding.int32)
    (Tezos_base__TzPervasives.Data_encoding.req None None "caboose" % string
      Tezos_base__TzPervasives.Data_encoding.int32)
    (Tezos_base__TzPervasives.Data_encoding.req None None
      "history_mode" % string Tezos_shell_services.History_mode.encoding).

Definition invalid_block_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding invalid_block :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| hash := hash; level := level; errors := errors |} =>
        (hash, level, errors)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (hash, level, errors) =>
        {| hash := hash; level := level; errors := errors |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj3
      (Tezos_base__TzPervasives.Data_encoding.req None None "block" % string
        Tezos_base__TzPervasives.Block_hash.encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "level" % string
        Tezos_base__TzPervasives.Data_encoding.int32)
      (Tezos_base__TzPervasives.Data_encoding.req None None "errors" % string
        Tezos_base__TzPervasives.RPC_error.encoding)).

Module S.
  Definition path : Tezos_base__TzPervasives.RPC_path.context prefix :=
    Tezos_base__TzPervasives.RPC_path.open_root.
  
  Definition chain_id
    : Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
      unit Tezos_base__TzPervasives.Chain_id.t :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "The chain unique identifier." % string)
      Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.Chain_id.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div path "chain_id" % string).
  
  Definition checkpoint
    : Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
      unit
      (Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
        Tezos_shell_services.History_mode.t) :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "The current checkpoint for this chain." % string)
      Tezos_base__TzPervasives.RPC_query.empty checkpoint_encoding
      (Tezos_base__TzPervasives.RPC_path.op_div path "checkpoint" % string).
  
  Module Blocks.
    Definition list_query
      : Tezos_base__TzPervasives.RPC_query.t
        (((option Z) *
          ((list Tezos_base__TzPervasives.Block_hash.t) *
            ((option Tezos_base__TzPervasives.Time.Protocol.t) * nil)))) :=
      OCaml.Stdlib.reverse_apply
        (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
          (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
            (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
              (Tezos_base__TzPervasives.RPC_query.query
                (fun length => fun heads => fun min_date => object))
              (Tezos_base__TzPervasives.RPC_query.opt_field
                (Some
                  "The requested number of predecessors to returns (per requested head)."
                    % string) "length" % string
                Tezos_base__TzPervasives.RPC_arg.int (fun x => send)))
            (Tezos_base__TzPervasives.RPC_query.multi_field
              (Some
                "An empty argument requests blocks from the current heads. A non empty list allow to request specific fragment of the chain."
                  % string) "head" % string
              Tezos_base__TzPervasives.Block_hash.rpc_arg (fun x => send)))
          (Tezos_base__TzPervasives.RPC_query.opt_field
            (Some
              "When `min_date` is provided, heads with a timestamp before `min_date` are filtered out"
                % string) "min_date" % string
            Tezos_base__TzPervasives.Time.Protocol.rpc_arg (fun x => send)))
        Tezos_base__TzPervasives.RPC_query.seal.
    
    Definition path : Tezos_base__TzPervasives.RPC_path.path prefix prefix :=
      Tezos_base__TzPervasives.RPC_path.op_div path "blocks" % string.
    
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant prefix prefix
        (((option Z) *
          ((list Tezos_base__TzPervasives.Block_hash.t) *
            ((option Tezos_base__TzPervasives.Time.Protocol.t) * nil)))) unit
        (list (list Tezos_base__TzPervasives.Block_hash.t)) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "Lists known heads of the blockchain sorted with decreasing fitness. Optional arguments allows to returns the list of predecessors for known heads or the list of predecessors for a given list of blocks."
            % string) list_query
        (Tezos_base__TzPervasives.Data_encoding.list None
          (Tezos_base__TzPervasives.Data_encoding.list None
            Tezos_base__TzPervasives.Block_hash.encoding)) path.
  End Blocks.
  
  Module Invalid_blocks.
    Definition path : Tezos_base__TzPervasives.RPC_path.path prefix prefix :=
      Tezos_base__TzPervasives.RPC_path.op_div path "invalid_blocks" % string.
    
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
        unit (list invalid_block) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "Lists blocks that have been declared invalid along with the errors that led to them being declared invalid."
            % string) Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_base__TzPervasives.Data_encoding.list None invalid_block_encoding)
        path.
    
    Definition get
      : Tezos_base__TzPervasives.RPC_service.service variant prefix
        (prefix * Tezos_base__TzPervasives.Block_hash.t) unit unit invalid_block :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "The errors that appears during the block (in)validation." % string)
        Tezos_base__TzPervasives.RPC_query.empty invalid_block_encoding
        (Tezos_base__TzPervasives.RPC_path.op_div_colon path
          Tezos_base__TzPervasives.Block_hash.rpc_arg).
    
    Definition delete
      : Tezos_base__TzPervasives.RPC_service.service variant prefix
        (prefix * Tezos_base__TzPervasives.Block_hash.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.delete_service
        (Some "Remove an invalid block for the tezos storage" % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div_colon path
          Tezos_base__TzPervasives.Block_hash.rpc_arg).
  End Invalid_blocks.
End S.

Definition make_call0 {A B C D I J i o p q : Type}
  (s :
    Tezos_base__TzPervasives.RPC_service.raw variant
      Tezos_shell_services.Block_services.chain_prefix (unit * A) B C D
      Tezos_rpc.RPC_service.error)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (I * p * q * i * o)) * J) * J) (chain : A) (q : B) (p : C)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult D) :=
  let s := Tezos_base__TzPervasives.RPC_service.prefix path s in
  Tezos_base__TzPervasives.RPC_context.make_call1 s ctxt chain q p.

Definition make_call1 {A B C D E J K i o p q : Type}
  (s :
    Tezos_base__TzPervasives.RPC_service.raw variant
      Tezos_shell_services.Block_services.chain_prefix ((unit * A) * B) C D E
      Tezos_rpc.RPC_service.error)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (J * p * q * i * o)) * K) * K) (chain : A) (a : B) (q : C) (p : D)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult E) :=
  let s := Tezos_base__TzPervasives.RPC_service.prefix path s in
  Tezos_base__TzPervasives.RPC_context.make_call2 s ctxt chain a q p.

Definition chain_id {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : (option variant) ->
    unit ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Chain_id.t) :=
  let f := make_call0 S.chain_id ctxt in
  fun op_star_o_p_t_star =>
    let chain :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => variant
      end in
    fun function_parameter =>
      match function_parameter with
      | tt =>
        match chain with
        | Hash h => Tezos_base__TzPervasives._return h
        | _ => f chain tt tt
        end
      end.

Definition checkpoint {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_star_o_p_t_star : option variant)
  : unit ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
          Tezos_shell_services.History_mode.t)) :=
  let chain :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end in
  fun function_parameter =>
    match function_parameter with
    | tt => make_call0 S.checkpoint ctxt chain tt tt
    end.

Module Blocks.
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : (option variant) ->
      (option (list Tezos_base__TzPervasives.Block_hash.t)) ->
        (option Z) ->
          (option Tezos_base__TzPervasives.Time.Protocol.t) ->
            unit ->
              Lwt.t
                (Tezos_error_monad.Error_monad.tzresult
                  (list (list Tezos_base__TzPervasives.Block_hash.t))) :=
    let f := make_call0 S.Blocks.list ctxt in
    fun op_star_o_p_t_star =>
      let chain :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => variant
        end in
      fun op_star_o_p_t_star =>
        let heads :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => []
          end in
        fun length =>
          fun min_date =>
            fun function_parameter =>
              match function_parameter with
              | tt => f chain object tt
              end.
  
  Record protocols := {
    current_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
    next_protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
  
  Definition protocols {E F i o p q : Type}
    : (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) ->
      (option Tezos_shell_services.Block_services.chain) ->
        (option Tezos_shell_services.Block_services.block) ->
          unit ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_shell_services.Block_services.protocols) :=
    Tezos_shell_services.Block_services.protocols.
End Blocks.

Module Invalid_blocks.
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : (option variant) ->
      unit ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult (list invalid_block)) :=
    let f := make_call0 S.Invalid_blocks.list ctxt in
    fun op_star_o_p_t_star =>
      let chain :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => variant
        end in
      fun function_parameter =>
        match function_parameter with
        | tt => f chain tt tt
        end.
  
  Definition get {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : (option Tezos_shell_services.Block_services.chain) ->
      Tezos_base__TzPervasives.Block_hash.t ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult invalid_block) :=
    let f := make_call1 S.Invalid_blocks.get ctxt in
    fun op_star_o_p_t_star =>
      let chain :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => variant
        end in
      fun block => f chain block tt tt.
  
  Definition delete {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : (option Tezos_shell_services.Block_services.chain) ->
      Tezos_base__TzPervasives.Block_hash.t ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let f := make_call1 S.Invalid_blocks.delete ctxt in
    fun op_star_o_p_t_star =>
      let chain :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => variant
        end in
      fun block => f chain block tt tt.
End Invalid_blocks.
src/lib_shell_services/chain_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type chain = [`Main | `Test | `Hash of Chain_id.t]

val parse_chain : string -> (chain, string) result

val to_string : chain -> string

val chain_arg : chain RPC_arg.t

type invalid_block = {
  hash : Block_hash.t;
  level : Int32.t;
  errors : error list;
}

type prefix = unit * chain

val path : (unit, prefix) RPC_path.path

open RPC_context

val chain_id : #simple -> ?chain:chain -> unit -> Chain_id.t tzresult Lwt.t

val checkpoint :
  #simple ->
  ?chain:chain ->
  unit ->
  (Block_header.t * int32 * int32 * History_mode.t) tzresult Lwt.t

module Mempool = Block_services.Empty.Mempool

module Blocks : sig
  val list :
    #simple ->
    ?chain:chain ->
    ?heads:Block_hash.t list ->
    ?length:int ->
    ?min_date:Time.Protocol.t ->
    unit ->
    Block_hash.t list list tzresult Lwt.t

  include module type of Block_services.Empty

  type protocols = {
    current_protocol : Protocol_hash.t;
    next_protocol : Protocol_hash.t;
  }

  val protocols :
    #RPC_context.simple ->
    ?chain:chain ->
    ?block:Block_services.block ->
    unit ->
    protocols tzresult Lwt.t
end

module Invalid_blocks : sig
  val list :
    #simple -> ?chain:chain -> unit -> invalid_block list tzresult Lwt.t

  val get :
    #simple -> ?chain:chain -> Block_hash.t -> invalid_block tzresult Lwt.t

  val delete : #simple -> ?chain:chain -> Block_hash.t -> unit tzresult Lwt.t
end

module S : sig
  val chain_id : ([`GET], prefix, prefix, unit, unit, Chain_id.t) RPC_service.t

  val checkpoint :
    ( [`GET],
      prefix,
      prefix,
      unit,
      unit,
      Block_header.t * int32 * int32 * History_mode.t )
    RPC_service.t

  module Blocks : sig
    val path : (prefix, prefix) RPC_path.t

    val list :
      ( [`GET],
        prefix,
        prefix,
        < heads : Block_hash.t list
        ; length : int option
        ; min_date : Time.Protocol.t option >,
        unit,
        Block_hash.t list list )
      RPC_service.t
  end

  module Invalid_blocks : sig
    val list :
      ([`GET], prefix, prefix, unit, unit, invalid_block list) RPC_service.t

    val get :
      ( [`GET],
        prefix,
        prefix * Block_hash.t,
        unit,
        unit,
        invalid_block )
      RPC_service.t

    val delete :
      ( [`DELETE],
        prefix,
        prefix * Block_hash.t,
        unit,
        unit,
        unit )
      RPC_service.t
  end
end
src/lib_shell_services/chain_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition chain := variant.

Parameter parse_chain : string -> sum chain string.

Parameter to_string : chain -> string.

Parameter chain_arg : Tezos_base__TzPervasives.RPC_arg.t chain.

Record invalid_block := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  level : Stdlib.Int32.t;
  errors : list Tezos_base__TzPervasives.error }.

Definition prefix := unit * chain.

Parameter path : Tezos_base__TzPervasives.RPC_path.path unit prefix.

Parameter chain_id : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  (option chain) ->
    unit ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Chain_id.t).

Parameter checkpoint : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  (option chain) ->
    unit ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
            Tezos_shell_services.History_mode.t)).

unhandled_module

Module Blocks.
  Parameter list : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    (option chain) ->
      (option (list Tezos_base__TzPervasives.Block_hash.t)) ->
        (option Z) ->
          (option Tezos_base__TzPervasives.Time.Protocol.t) ->
            unit ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  (list (list Tezos_base__TzPervasives.Block_hash.t))).
  
  include
  
  Record protocols := {
    current_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
    next_protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
  
  Parameter protocols : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    (option chain) ->
      (option Tezos_shell_services.Block_services.block) ->
        unit -> Lwt.t (Tezos_base__TzPervasives.tzresult protocols).
End Blocks.

Module Invalid_blocks.
  Parameter list : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    (option chain) ->
      unit -> Lwt.t (Tezos_base__TzPervasives.tzresult (list invalid_block)).
  
  Parameter get : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    (option chain) ->
      Tezos_base__TzPervasives.Block_hash.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult invalid_block).
  
  Parameter delete : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    (option chain) ->
      Tezos_base__TzPervasives.Block_hash.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit).
End Invalid_blocks.

Module S.
  Parameter chain_id : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant prefix prefix unit unit Tezos_base__TzPervasives.Chain_id.t.
  
  Parameter checkpoint : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant prefix prefix unit unit
    (Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
      Tezos_shell_services.History_mode.t).
  
  Module Blocks.
    Parameter path : Tezos_base__TzPervasives.RPC_path.t prefix prefix.
    
    Parameter list : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant prefix prefix
      (((option Tezos_base__TzPervasives.Time.Protocol.t) *
        ((option Z) * ((list Tezos_base__TzPervasives.Block_hash.t) * nil))))
      unit (list (list Tezos_base__TzPervasives.Block_hash.t)).
  End Blocks.
  
  Module Invalid_blocks.
    Parameter list : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant prefix prefix unit unit (list invalid_block).
    
    Parameter get : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant prefix (prefix * Tezos_base__TzPervasives.Block_hash.t) unit unit
      invalid_block.
    
    Parameter delete : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant prefix (prefix * Tezos_base__TzPervasives.Block_hash.t) unit unit
      unit.
  End Invalid_blocks.
End S.
src/lib_shell_services/chain_validator_worker_state.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request = struct
  type view = Block_hash.t

  let encoding = Block_hash.encoding

  let pp = Block_hash.pp
end

module Event = struct
  type update = Ignored_head | Branch_switch | Head_increment

  type t =
    | Processed_block of {
        request : Request.view;
        request_status : Worker_types.request_status;
        update : update;
        fitness : Fitness.t;
      }
    | Could_not_switch_testchain of error list

  let level = function
    | Processed_block req -> (
      match req.update with
      | Ignored_head ->
          Internal_event.Info
      | Branch_switch | Head_increment ->
          Internal_event.Notice )
    | Could_not_switch_testchain _ ->
        Internal_event.Error

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Processed_block"
          (obj4
             (req "request" Request.encoding)
             (req "status" Worker_types.request_status_encoding)
             (req
                "outcome"
                (string_enum
                   [ ("ignored", Ignored_head);
                     ("branch", Branch_switch);
                     ("increment", Head_increment) ]))
             (req "fitness" Fitness.encoding))
          (function
            | Processed_block {request; request_status; update; fitness} ->
                Some (request, request_status, update, fitness)
            | _ ->
                None)
          (fun (request, request_status, update, fitness) ->
            Processed_block {request; request_status; update; fitness});
        case
          (Tag 1)
          ~title:"Could_not_switch_testchain"
          RPC_error.encoding
          (function Could_not_switch_testchain err -> Some err | _ -> None)
          (fun err -> Could_not_switch_testchain err) ]

  let pp ppf = function
    | Processed_block req ->
        Format.fprintf ppf "@[<v 0>" ;
        ( match req.update with
        | Ignored_head ->
            Format.fprintf
              ppf
              "Current head is better than %a (fitness %a), we do not switch@,"
        | Branch_switch ->
            Format.fprintf
              ppf
              "Update current head to %a (fitness %a), changing branch@,"
        | Head_increment ->
            Format.fprintf
              ppf
              "Update current head to %a (fitness %a), same branch@," )
          Request.pp
          req.request
          Fitness.pp
          req.fitness ;
        Format.fprintf ppf "%a@]" Worker_types.pp_status req.request_status
    | Could_not_switch_testchain err ->
        Format.fprintf
          ppf
          "@[<v 0>Error while switching test chain:@ %a@]"
          (Format.pp_print_list Error_monad.pp)
          err
end

module Worker_state = struct
  type view = {
    active_peers : P2p_peer.Id.t list;
    bootstrapped_peers : P2p_peer.Id.t list;
    bootstrapped : bool;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {bootstrapped; bootstrapped_peers; active_peers} ->
        (bootstrapped, bootstrapped_peers, active_peers))
      (fun (bootstrapped, bootstrapped_peers, active_peers) ->
        {bootstrapped; bootstrapped_peers; active_peers})
      (obj3
         (req "bootstrapped" bool)
         (req "bootstrapped_peers" (list P2p_peer.Id.encoding))
         (req "active_peers" (list P2p_peer.Id.encoding)))

  let pp ppf {bootstrapped; bootstrapped_peers; active_peers} =
    Format.fprintf
      ppf
      "@[<v 0>Network is%s bootstrapped.@,\
       @[<v 2>Active peers:%a@]@,\
       @[<v 2>Bootstrapped peers:%a@]@]"
      (if bootstrapped then "" else " not yet")
      (fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_peer.Id.pp))
      active_peers
      (fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_peer.Id.pp))
      bootstrapped_peers
end

module Distributed_db_state = struct
  type table_scheduler = {table_length : int; scheduler_length : int}

  type view = {
    p2p_readers_length : int;
    active_chains_length : int;
    operation_db : table_scheduler;
    operations_db : table_scheduler;
    block_header_db : table_scheduler;
    operations_hashed_db : table_scheduler;
    active_connections_length : int;
    active_peers_length : int;
  }

  let table_scheduler_encoding =
    let open Data_encoding in
    conv
      (fun {table_length; scheduler_length} ->
        (table_length, scheduler_length))
      (fun (table_length, scheduler_length) ->
        {table_length; scheduler_length})
      (obj2 (req "table_length" int31) (req "scheduler_length" int31))

  let encoding =
    let open Data_encoding in
    conv
      (fun { p2p_readers_length;
             active_chains_length;
             operation_db;
             operations_db;
             block_header_db;
             operations_hashed_db;
             active_connections_length;
             active_peers_length } ->
        ( p2p_readers_length,
          active_chains_length,
          operation_db,
          operations_db,
          block_header_db,
          operations_hashed_db,
          active_connections_length,
          active_peers_length ))
      (fun ( p2p_readers_length,
             active_chains_length,
             operation_db,
             operations_db,
             block_header_db,
             operations_hashed_db,
             active_connections_length,
             active_peers_length ) ->
        {
          p2p_readers_length;
          active_chains_length;
          operation_db;
          operations_db;
          block_header_db;
          operations_hashed_db;
          active_connections_length;
          active_peers_length;
        })
      (obj8
         (req "p2p_readers" int31)
         (req "active_chains" int31)
         (req "operation_db" table_scheduler_encoding)
         (req "operations_db" table_scheduler_encoding)
         (req "block_header_db" table_scheduler_encoding)
         (req "operations_hashed_db" table_scheduler_encoding)
         (req "active_connections" int31)
         (req "active_peers" int31))
end
src/lib_shell_services/chain_validator_worker_state.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Definition view := Tezos_base__TzPervasives.Block_hash.t.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Block_hash.t :=
    Tezos_base__TzPervasives.Block_hash.encoding.
  
  Definition pp
    : Stdlib.Format.formatter -> Tezos_base__TzPervasives.Block_hash.t -> unit :=
    Tezos_base__TzPervasives.Block_hash.pp.
End Request.

Module Event.
  Inductive update : Type :=
  | Ignored_head : update
  | Branch_switch : update
  | Head_increment : update.
  
  Inductive t : Type :=
  | Processed_block : Request.view ->
    Tezos_shell_services.Worker_types.request_status -> update ->
    Tezos_base__TzPervasives.Fitness.t -> t
  | Could_not_switch_testchain : (list Tezos_base__TzPervasives.error) -> t.
  
  Definition level (function_parameter : t)
    : Tezos_base__TzPervasives.Internal_event.level :=
    match function_parameter with
    | Processed_block req =>
      match update req with
      | Ignored_head => Internal_event.Info
      | Branch_switch | Head_increment => Internal_event.Notice
      end
    | Could_not_switch_testchain _ => Internal_event.Error
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    Tezos_base__TzPervasives.Data_encoding.union None
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Processed_block" % string
          None (Tag 0)
          (Tezos_base__TzPervasives.Data_encoding.obj4
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "request" % string Request.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "status" % string
              Tezos_shell_services.Worker_types.request_status_encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "outcome" % string
              (Tezos_base__TzPervasives.Data_encoding.string_enum
                (cons ("ignored" % string, Ignored_head)
                  (cons ("branch" % string, Branch_switch)
                    (cons ("increment" % string, Head_increment) [])))))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "fitness" % string Tezos_base__TzPervasives.Fitness.encoding))
          (fun function_parameter =>
            match function_parameter with
            |
              Processed_block {|
                request := request;
                  request_status := request_status;
                  update := update;
                  fitness := fitness
                  |} => Some (request, request_status, update, fitness)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (request, request_status, update, fitness) =>
              Processed_block
                {| request := request; request_status := request_status;
                  update := update; fitness := fitness |}
            end))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case
            "Could_not_switch_testchain" % string None (Tag 1)
            Tezos_base__TzPervasives.RPC_error.encoding
            (fun function_parameter =>
              match function_parameter with
              | Could_not_switch_testchain err => Some err
              | _ => None
              end) (fun err => Could_not_switch_testchain err)) [])).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Processed_block req =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string);
      match update req with
      | Ignored_head =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Current head is better than " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " (fitness " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "), we do not switch" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        CamlinternalFormatBasics.End_of_format))))))
            "Current head is better than %a (fitness %a), we do not switch@," %
              string)
      | Branch_switch =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Update current head to " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " (fitness " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "), changing branch" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        CamlinternalFormatBasics.End_of_format))))))
            "Update current head to %a (fitness %a), changing branch@," % string)
      | Head_increment =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Update current head to " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " (fitness " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "), same branch" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        CamlinternalFormatBasics.End_of_format))))))
            "Update current head to %a (fitness %a), same branch@," % string)
      end Request.pp (request req) Tezos_base__TzPervasives.Fitness.pp
        (fitness req);
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format)) "%a@]" % string)
        Tezos_shell_services.Worker_types.pp_status (request_status req)
    | Could_not_switch_testchain err =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Error while switching test chain:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "@[<v 0>Error while switching test chain:@ %a@]" % string)
        (Stdlib.Format.pp_print_list None
          Tezos_base__TzPervasives.Error_monad.pp) err
    end.
End Event.

Module Worker_state.
  Record view := {
    active_peers : list Tezos_base__TzPervasives.P2p_peer.Id.t;
    bootstrapped_peers : list Tezos_base__TzPervasives.P2p_peer.Id.t;
    bootstrapped : bool }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          active_peers := active_peers;
            bootstrapped_peers := bootstrapped_peers;
            bootstrapped := bootstrapped
            |} => (bootstrapped, bootstrapped_peers, active_peers)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (bootstrapped, bootstrapped_peers, active_peers) =>
          {| active_peers := active_peers;
            bootstrapped_peers := bootstrapped_peers;
            bootstrapped := bootstrapped |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj3
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "bootstrapped" % string Tezos_base__TzPervasives.Data_encoding.bool)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "bootstrapped_peers" % string
          (Tezos_base__TzPervasives.Data_encoding.list None
            Tezos_base__TzPervasives.P2p_peer.Id.encoding))
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "active_peers" % string
          (Tezos_base__TzPervasives.Data_encoding.list None
            Tezos_base__TzPervasives.P2p_peer.Id.encoding))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
    : unit :=
    match function_parameter with
    | {|
      active_peers := active_peers;
        bootstrapped_peers := bootstrapped_peers;
        bootstrapped := bootstrapped
        |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal "Network is" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal
                  " bootstrapped." % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Active peers:" % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "Bootstrapped peers:" % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format)))))))))))))))
          "@[<v 0>Network is%s bootstrapped.@,@[<v 2>Active peers:%a@]@,@[<v 2>Bootstrapped peers:%a@]@]"
            % string)
        (if bootstrapped then
          "" % string
        else
          " not yet" % string)
        (fun ppf =>
          Tezos_base__TzPervasives.List.iter
            (Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "- " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))
                "@,- %a" % string) Tezos_base__TzPervasives.P2p_peer.Id.pp))
        active_peers
        (fun ppf =>
          Tezos_base__TzPervasives.List.iter
            (Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "- " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))
                "@,- %a" % string) Tezos_base__TzPervasives.P2p_peer.Id.pp))
        bootstrapped_peers
    end.
End Worker_state.

Module Distributed_db_state.
  Record table_scheduler := {
    table_length : Z;
    scheduler_length : Z }.
  
  Record view := {
    p2p_readers_length : Z;
    active_chains_length : Z;
    operation_db : table_scheduler;
    operations_db : table_scheduler;
    block_header_db : table_scheduler;
    operations_hashed_db : table_scheduler;
    active_connections_length : Z;
    active_peers_length : Z }.
  
  Definition table_scheduler_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding table_scheduler :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          table_length := table_length;
            scheduler_length := scheduler_length
            |} => (table_length, scheduler_length)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (table_length, scheduler_length) =>
          {| table_length := table_length; scheduler_length := scheduler_length
            |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "table_length" % string Tezos_base__TzPervasives.Data_encoding.int31)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "scheduler_length" % string
          Tezos_base__TzPervasives.Data_encoding.int31)).
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          p2p_readers_length := p2p_readers_length;
            active_chains_length := active_chains_length;
            operation_db := operation_db;
            operations_db := operations_db;
            block_header_db := block_header_db;
            operations_hashed_db := operations_hashed_db;
            active_connections_length := active_connections_length;
            active_peers_length := active_peers_length
            |} =>
          (p2p_readers_length, active_chains_length, operation_db,
            operations_db, block_header_db, operations_hashed_db,
            active_connections_length, active_peers_length)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (p2p_readers_length, active_chains_length, operation_db,
            operations_db, block_header_db, operations_hashed_db,
            active_connections_length, active_peers_length) =>
          {| p2p_readers_length := p2p_readers_length;
            active_chains_length := active_chains_length;
            operation_db := operation_db; operations_db := operations_db;
            block_header_db := block_header_db;
            operations_hashed_db := operations_hashed_db;
            active_connections_length := active_connections_length;
            active_peers_length := active_peers_length |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj8
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "p2p_readers" % string Tezos_base__TzPervasives.Data_encoding.int31)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "active_chains" % string Tezos_base__TzPervasives.Data_encoding.int31)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "operation_db" % string table_scheduler_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "operations_db" % string table_scheduler_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "block_header_db" % string table_scheduler_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "operations_hashed_db" % string table_scheduler_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "active_connections" % string
          Tezos_base__TzPervasives.Data_encoding.int31)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "active_peers" % string Tezos_base__TzPervasives.Data_encoding.int31)).
End Distributed_db_state.
src/lib_shell_services/chain_validator_worker_state.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request : sig
  type view = Block_hash.t

  val encoding : view Data_encoding.encoding

  val pp : Format.formatter -> view -> unit
end

module Event : sig
  type update = Ignored_head | Branch_switch | Head_increment

  type t =
    | Processed_block of {
        request : Request.view;
        request_status : Worker_types.request_status;
        update : update;
        fitness : Fitness.t;
      }
    | Could_not_switch_testchain of error list

  val level : t -> Internal_event.level

  val encoding : t Data_encoding.encoding

  val pp : Format.formatter -> t -> unit
end

module Worker_state : sig
  type view = {
    active_peers : P2p_peer.Id.t list;
    bootstrapped_peers : P2p_peer.Id.t list;
    bootstrapped : bool;
  }

  val encoding : view Data_encoding.encoding

  val pp : Format.formatter -> view -> unit
end

module Distributed_db_state : sig
  type table_scheduler = {table_length : int; scheduler_length : int}

  type view = {
    p2p_readers_length : int;
    active_chains_length : int;
    operation_db : table_scheduler;
    operations_db : table_scheduler;
    block_header_db : table_scheduler;
    operations_hashed_db : table_scheduler;
    active_connections_length : int;
    active_peers_length : int;
  }

  val encoding : view Data_encoding.encoding
end
src/lib_shell_services/chain_validator_worker_state.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Definition view := Tezos_base__TzPervasives.Block_hash.t.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding view.
  
  Parameter pp : Stdlib.Format.formatter -> view -> unit.
End Request.

Module Event.
  Inductive update : Type :=
  | Ignored_head : update
  | Branch_switch : update
  | Head_increment : update.
  
  Inductive t : Type :=
  | Processed_block : Request.view ->
    Tezos_shell_services.Worker_types.request_status -> update ->
    Tezos_base__TzPervasives.Fitness.t -> t
  | Could_not_switch_testchain : (list Tezos_base__TzPervasives.error) -> t.
  
  Parameter level : t -> Tezos_base__TzPervasives.Internal_event.level.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding t.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
End Event.

Module Worker_state.
  Record view := {
    active_peers : list Tezos_base__TzPervasives.P2p_peer.Id.t;
    bootstrapped_peers : list Tezos_base__TzPervasives.P2p_peer.Id.t;
    bootstrapped : bool }.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding view.
  
  Parameter pp : Stdlib.Format.formatter -> view -> unit.
End Worker_state.

Module Distributed_db_state.
  Record table_scheduler := {
    table_length : Z;
    scheduler_length : Z }.
  
  Record view := {
    p2p_readers_length : Z;
    active_chains_length : Z;
    operation_db : table_scheduler;
    operations_db : table_scheduler;
    block_header_db : table_scheduler;
    operations_hashed_db : table_scheduler;
    active_connections_length : Z;
    active_peers_length : Z }.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding view.
End Distributed_db_state.
src/lib_shell_services/connection_metadata.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {disable_mempool : bool; private_node : bool}

let encoding =
  let open Data_encoding in
  (conv
     (fun {disable_mempool; private_node} -> (disable_mempool, private_node))
     (fun (disable_mempool, private_node) -> {disable_mempool; private_node}))
    (obj2 (req "disable_mempool" bool) (req "private_node" bool))

let pp _ppf _ = ()
src/lib_shell_services/connection_metadata.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  disable_mempool : bool;
  private_node : bool }.

Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
  (Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| disable_mempool := disable_mempool; private_node := private_node |}
        => (disable_mempool, private_node)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (disable_mempool, private_node) =>
        {| disable_mempool := disable_mempool; private_node := private_node |}
      end)) None
    (Tezos_base__TzPervasives.Data_encoding.obj2
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "disable_mempool" % string Tezos_base__TzPervasives.Data_encoding.bool)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "private_node" % string Tezos_base__TzPervasives.Data_encoding.bool)).

Definition pp {A B : Type} (_ppf : A) (function_parameter : B) : unit :=
  match function_parameter with
  | _ => tt
  end.
src/lib_shell_services/connection_metadata.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** All the metadata associated to a running connection. *)

type t = {disable_mempool : bool; private_node : bool}

val encoding : t Data_encoding.t

val pp : Format.formatter -> t -> unit
src/lib_shell_services/connection_metadata.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  disable_mempool : bool;
  private_node : bool }.

Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.

Parameter pp : Stdlib.Format.formatter -> t -> unit.
src/lib_shell_services/history_mode.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs. <contact@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Archive | Full | Rolling

let encoding =
  Data_encoding.string_enum
    [("archive", Archive); ("full", Full); ("rolling", Rolling)]

let equal hm1 hm2 =
  match (hm1, hm2) with
  | (Archive, Archive) | (Full, Full) | (Rolling, Rolling) ->
      true
  | (Archive, _) | (Full, _) | (Rolling, _) ->
      false

let pp ppf = function
  | Archive ->
      Format.fprintf ppf "archive"
  | Full ->
      Format.fprintf ppf "full"
  | Rolling ->
      Format.fprintf ppf "rolling"

let tag = Tag.def "history_mode" pp
src/lib_shell_services/history_mode.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Archive : t
| Full : t
| Rolling : t.

Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
  Tezos_base__TzPervasives.Data_encoding.string_enum
    (cons ("archive" % string, Archive)
      (cons ("full" % string, Full) (cons ("rolling" % string, Rolling) []))).

Definition equal (hm1 : t) (hm2 : t) : bool :=
  match (hm1, hm2) with
  | (Archive, Archive) | (Full, Full) | (Rolling, Rolling) => true
  | (Archive, _) | (Full, _) | (Rolling, _) => false
  end.

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | Archive =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "archive" % string
          CamlinternalFormatBasics.End_of_format) "archive" % string)
  | Full =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "full" % string
          CamlinternalFormatBasics.End_of_format) "full" % string)
  | Rolling =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "rolling" % string
          CamlinternalFormatBasics.End_of_format) "rolling" % string)
  end.

Definition tag : Tezos_base__TzPervasives.Tag.def t :=
  Tezos_base__TzPervasives.Tag.def None "history_mode" % string pp.
src/lib_shell_services/history_mode.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs. <contact@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Archive | Full | Rolling

val encoding : t RPC_encoding.t

val equal : t -> t -> bool

val pp : Format.formatter -> t -> unit

val tag : t Tag.def
src/lib_shell_services/history_mode.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Archive : t
| Full : t
| Rolling : t.

Parameter encoding : Tezos_base__TzPervasives.RPC_encoding.t t.

Parameter equal : t -> t -> bool.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter tag : Tezos_base__TzPervasives.Tag.def t.
src/lib_shell_services/injection_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module S = struct
  open Data_encoding

  let path = RPC_path.(root / "injection")

  let block_query =
    let open RPC_query in
    query (fun async force chain ->
        object
          method async = async

          method force = force

          method chain = chain
        end)
    |+ flag "async" (fun t -> t#async)
    |+ flag "force" (fun t -> t#force)
    |+ opt_field "chain" Chain_services.chain_arg (fun t -> t#chain)
    |> seal

  let block_param =
    obj2
      (req "data" bytes)
      (req
         "operations"
         (list (dynamic_size (list (dynamic_size Operation.encoding)))))

  let block =
    RPC_service.post_service
      ~description:
        "Inject a block in the node and broadcast it. The `operations` \
         embedded in `blockHeader` might be pre-validated using a contextual \
         RPCs from the latest block (e.g. '/blocks/head/context/preapply'). \
         Returns the ID of the block. By default, the RPC will wait for the \
         block to be validated before answering. If ?async is true, the \
         function returns immediately. Otherwise, the block will be validated \
         before the result is returned. If ?force is true, it will be \
         injected even on non strictly increasing fitness. An optional ?chain \
         parameter can be used to specify whether to inject on the test chain \
         or the main chain."
      ~query:block_query
      ~input:block_param
      ~output:Block_hash.encoding
      RPC_path.(path / "block")

  let operation_query =
    let open RPC_query in
    query (fun async chain ->
        object
          method async = async

          method chain = chain
        end)
    |+ flag "async" (fun t -> t#async)
    |+ opt_field "chain" Chain_services.chain_arg (fun t -> t#chain)
    |> seal

  let operation =
    RPC_service.post_service
      ~description:
        "Inject an operation in node and broadcast it. Returns the ID of the \
         operation. The `signedOperationContents` should be constructed using \
         a contextual RPCs from the latest block and signed by the client. By \
         default, the RPC will wait for the operation to be (pre-)validated \
         before answering. See RPCs under /blocks/prevalidation for more \
         details on the prevalidation context. If ?async is true, the \
         function returns immediately. Otherwise, the operation will be \
         validated before the result is returned. An optional ?chain \
         parameter can be used to specify whether to inject on the test chain \
         or the main chain."
      ~query:operation_query
      ~input:bytes
      ~output:Operation_hash.encoding
      RPC_path.(path / "operation")

  let protocol_query =
    let open RPC_query in
    query (fun async ->
        object
          method async = async
        end)
    |+ flag "async" (fun t -> t#async)
    |> seal

  let protocol =
    RPC_service.post_service
      ~description:
        "Inject a protocol in node. Returns the ID of the protocol. If ?async \
         is true, the function returns immediately. Otherwise, the protocol \
         will be validated before the result is returned."
      ~query:protocol_query
      ~input:Protocol.encoding
      ~output:Protocol_hash.encoding
      RPC_path.(path / "protocol")
end

open RPC_context

let block ctxt ?(async = false) ?(force = false) ?chain raw operations =
  make_call
    S.block
    ctxt
    ()
    (object
       method async = async

       method force = force

       method chain = chain
    end)
    (raw, operations)

let operation ctxt ?(async = false) ?chain operation =
  make_call
    S.operation
    ctxt
    ()
    (object
       method async = async

       method chain = chain
    end)
    operation

let protocol ctxt ?(async = false) protocol =
  make_call
    S.protocol
    ctxt
    ()
    (object
       method async = async
    end)
    protocol
src/lib_shell_services/injection_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Import Tezos_base__TzPervasives.Data_encoding.
  
  Definition path : Tezos_base__TzPervasives.RPC_path.path unit unit :=
    Tezos_base__TzPervasives.RPC_path.op_div
      Tezos_base__TzPervasives.RPC_path.root "injection" % string.
  
  Definition block_query
    : Tezos_base__TzPervasives.RPC_query.t
      ((bool *
        (bool * ((option Tezos_shell_services.Chain_services.chain) * nil)))) :=
    OCaml.Stdlib.reverse_apply
      (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
        (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
          (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
            (Tezos_base__TzPervasives.RPC_query.query
              (fun async => fun force => fun chain => object))
            (Tezos_base__TzPervasives.RPC_query.flag None "async" % string
              (fun t => send)))
          (Tezos_base__TzPervasives.RPC_query.flag None "force" % string
            (fun t => send)))
        (Tezos_base__TzPervasives.RPC_query.opt_field None "chain" % string
          Tezos_shell_services.Chain_services.chain_arg (fun t => send)))
      Tezos_base__TzPervasives.RPC_query.seal.
  
  Definition block_param
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (Stdlib.Bytes.t * (list (list Tezos_base__TzPervasives.Operation.t))) :=
    Tezos_base__TzPervasives.Data_encoding.obj2
      (Tezos_base__TzPervasives.Data_encoding.req None None "data" % string
        Tezos_base__TzPervasives.Data_encoding.bytes)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "operations" % string
        (Tezos_base__TzPervasives.Data_encoding.list None
          (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
            (Tezos_base__TzPervasives.Data_encoding.list None
              (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                Tezos_base__TzPervasives.Operation.encoding))))).
  
  Definition block
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit
      ((bool *
        (bool * ((option Tezos_shell_services.Chain_services.chain) * nil))))
      (Stdlib.Bytes.t * (list (list Tezos_base__TzPervasives.Operation.t)))
      Tezos_base__TzPervasives.Block_hash.t :=
    Tezos_base__TzPervasives.RPC_service.post_service
      (Some
        "Inject a block in the node and broadcast it. The `operations` embedded in `blockHeader` might be pre-validated using a contextual RPCs from the latest block (e.g. '/blocks/head/context/preapply'). Returns the ID of the block. By default, the RPC will wait for the block to be validated before answering. If ?async is true, the function returns immediately. Otherwise, the block will be validated before the result is returned. If ?force is true, it will be injected even on non strictly increasing fitness. An optional ?chain parameter can be used to specify whether to inject on the test chain or the main chain."
          % string) block_query block_param
      Tezos_base__TzPervasives.Block_hash.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div path "block" % string).
  
  Definition operation_query
    : Tezos_base__TzPervasives.RPC_query.t
      ((bool * ((option Tezos_shell_services.Chain_services.chain) * nil))) :=
    OCaml.Stdlib.reverse_apply
      (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
        (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
          (Tezos_base__TzPervasives.RPC_query.query
            (fun async => fun chain => object))
          (Tezos_base__TzPervasives.RPC_query.flag None "async" % string
            (fun t => send)))
        (Tezos_base__TzPervasives.RPC_query.opt_field None "chain" % string
          Tezos_shell_services.Chain_services.chain_arg (fun t => send)))
      Tezos_base__TzPervasives.RPC_query.seal.
  
  Definition operation
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit
      ((bool * ((option Tezos_shell_services.Chain_services.chain) * nil)))
      Stdlib.Bytes.t Tezos_base__TzPervasives.Operation_hash.t :=
    Tezos_base__TzPervasives.RPC_service.post_service
      (Some
        "Inject an operation in node and broadcast it. Returns the ID of the operation. The `signedOperationContents` should be constructed using a contextual RPCs from the latest block and signed by the client. By default, the RPC will wait for the operation to be (pre-)validated before answering. See RPCs under /blocks/prevalidation for more details on the prevalidation context. If ?async is true, the function returns immediately. Otherwise, the operation will be validated before the result is returned. An optional ?chain parameter can be used to specify whether to inject on the test chain or the main chain."
          % string) operation_query Tezos_base__TzPervasives.Data_encoding.bytes
      Tezos_base__TzPervasives.Operation_hash.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div path "operation" % string).
  
  Definition protocol_query
    : Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
    OCaml.Stdlib.reverse_apply
      (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
        (Tezos_base__TzPervasives.RPC_query.query (fun async => object))
        (Tezos_base__TzPervasives.RPC_query.flag None "async" % string
          (fun t => send))) Tezos_base__TzPervasives.RPC_query.seal.
  
  Definition protocol
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit
      ((bool * nil)) Tezos_base__TzPervasives.Protocol.t
      Tezos_base__TzPervasives.Protocol_hash.t :=
    Tezos_base__TzPervasives.RPC_service.post_service
      (Some
        "Inject a protocol in node. Returns the ID of the protocol. If ?async is true, the function returns immediately. Otherwise, the protocol will be validated before the result is returned."
          % string) protocol_query Tezos_base__TzPervasives.Protocol.encoding
      Tezos_base__TzPervasives.Protocol_hash.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div path "protocol" % string).
End S.

Import Tezos_base__TzPervasives.RPC_context.

Definition block {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_star_o_p_t_star : option bool)
  : (option bool) ->
    (option Tezos_shell_services.Chain_services.chain) ->
      Stdlib.Bytes.t ->
        (list (list Tezos_base__TzPervasives.Operation.t)) ->
          Lwt.t
            (Tezos_error_monad.Error_monad.tzresult
              Tezos_base__TzPervasives.Block_hash.t) :=
  let async :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun op_star_o_p_t_star =>
    let force :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun chain =>
      fun raw =>
        fun operations =>
          Tezos_base__TzPervasives.RPC_context.make_call S.block ctxt tt object
            (raw, operations).

Definition operation {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_star_o_p_t_star : option bool)
  : (option Tezos_shell_services.Chain_services.chain) ->
    Stdlib.Bytes.t ->
      Lwt.t
        (Tezos_error_monad.Error_monad.tzresult
          Tezos_base__TzPervasives.Operation_hash.t) :=
  let async :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun chain =>
    fun operation =>
      Tezos_base__TzPervasives.RPC_context.make_call S.operation ctxt tt object
        operation.

Definition protocol {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_star_o_p_t_star : option bool)
  : Tezos_base__TzPervasives.Protocol.t ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_base__TzPervasives.Protocol_hash.t) :=
  let async :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun protocol =>
    Tezos_base__TzPervasives.RPC_context.make_call S.protocol ctxt tt object
      protocol.
src/lib_shell_services/injection_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open RPC_context

(** [block cctxt ?async ?force raw_block] tries to inject
    [raw_block] inside the node. If [?async] is [true], [raw_block]
    will be validated before the result is returned. If [?force] is
    true, the block will be injected even on non strictly increasing
    fitness. *)
val block :
  #simple ->
  ?async:bool ->
  ?force:bool ->
  ?chain:Chain_services.chain ->
  Bytes.t ->
  Operation.t list list ->
  Block_hash.t tzresult Lwt.t

val operation :
  #simple ->
  ?async:bool ->
  ?chain:Chain_services.chain ->
  Bytes.t ->
  Operation_hash.t tzresult Lwt.t

val protocol :
  #simple -> ?async:bool -> Protocol.t -> Protocol_hash.t tzresult Lwt.t

module S : sig
  val block :
    ( [`POST],
      unit,
      unit,
      < async : bool ; force : bool ; chain : Chain_services.chain option >,
      Bytes.t * Operation.t list list,
      Block_hash.t )
    RPC_service.t

  val operation :
    ( [`POST],
      unit,
      unit,
      < async : bool ; chain : Chain_services.chain option >,
      Bytes.t,
      Operation_hash.t )
    RPC_service.t

  val protocol :
    ( [`POST],
      unit,
      unit,
      < async : bool >,
      Protocol.t,
      Protocol_hash.t )
    RPC_service.t
end
src/lib_shell_services/injection_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter block : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  (option bool) ->
    (option bool) ->
      (option Tezos_shell_services.Chain_services.chain) ->
        Stdlib.Bytes.t ->
          (list (list Tezos_base__TzPervasives.Operation.t)) ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_base__TzPervasives.Block_hash.t).

Parameter operation : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  (option bool) ->
    (option Tezos_shell_services.Chain_services.chain) ->
      Stdlib.Bytes.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_base__TzPervasives.Operation_hash.t).

Parameter protocol : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  (option bool) ->
    Tezos_base__TzPervasives.Protocol.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Protocol_hash.t).

Module S.
  Parameter block : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit
    (((option Tezos_shell_services.Chain_services.chain) * (bool * (bool * nil))))
    (Stdlib.Bytes.t * (list (list Tezos_base__TzPervasives.Operation.t)))
    Tezos_base__TzPervasives.Block_hash.t.
  
  Parameter operation : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit
    (((option Tezos_shell_services.Chain_services.chain) * (bool * nil)))
    Stdlib.Bytes.t Tezos_base__TzPervasives.Operation_hash.t.
  
  Parameter protocol : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit ((bool * nil)) Tezos_base__TzPervasives.Protocol.t
    Tezos_base__TzPervasives.Protocol_hash.t.
End S.
src/lib_shell_services/monitor_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type chain_status =
  | Active_main of Chain_id.t
  | Active_test of {
      chain : Chain_id.t;
      protocol : Protocol_hash.t;
      expiration_date : Time.Protocol.t;
    }
  | Stopping of Chain_id.t

let chain_status_encoding =
  let open Data_encoding in
  union
    ~tag_size:`Uint8
    [ case
        (Tag 0)
        ~title:"Main"
        (obj1 (req "chain_id" Chain_id.encoding))
        (function Active_main chain_id -> Some chain_id | _ -> None)
        (fun chain_id -> Active_main chain_id);
      case
        (Tag 1)
        ~title:"Test"
        (obj3
           (req "chain_id" Chain_id.encoding)
           (req "test_protocol" Protocol_hash.encoding)
           (req "expiration_date" Time.Protocol.encoding))
        (function
          | Active_test {chain; protocol; expiration_date} ->
              Some (chain, protocol, expiration_date)
          | _ ->
              None)
        (fun (chain, protocol, expiration_date) ->
          Active_test {chain; protocol; expiration_date});
      case
        (Tag 2)
        ~title:"Stopping"
        (obj1 (req "stopping" Chain_id.encoding))
        (function Stopping chain_id -> Some chain_id | _ -> None)
        (fun chain_id -> Stopping chain_id) ]

module S = struct
  open Data_encoding

  let path = RPC_path.(root / "monitor")

  let bootstrapped =
    RPC_service.get_service
      ~description:
        "Wait for the node to have synchronized its chain with a few peers \
         (configured by the node's administrator), streaming head updates \
         that happen during the bootstrapping process, and closing the stream \
         at the end. If the node was already bootstrapped, returns the \
         current head immediately."
      ~query:RPC_query.empty
      ~output:
        (obj2
           (req "block" Block_hash.encoding)
           (req "timestamp" Time.Protocol.encoding))
      RPC_path.(path / "bootstrapped")

  let valid_blocks_query =
    let open RPC_query in
    query (fun protocols next_protocols chains ->
        object
          method protocols = protocols

          method next_protocols = next_protocols

          method chains = chains
        end)
    |+ multi_field "protocol" Protocol_hash.rpc_arg (fun t -> t#protocols)
    |+ multi_field "next_protocol" Protocol_hash.rpc_arg (fun t ->
           t#next_protocols)
    |+ multi_field "chain" Chain_services.chain_arg (fun t -> t#chains)
    |> seal

  let valid_blocks =
    RPC_service.get_service
      ~description:
        "Monitor all blocks that are successfully validated by the node, \
         disregarding whether they were selected as the new head or not."
      ~query:valid_blocks_query
      ~output:
        (merge_objs
           (obj2
              (req "chain_id" Chain_id.encoding)
              (req "hash" Block_hash.encoding))
           Block_header.encoding)
      RPC_path.(path / "valid_blocks")

  let heads_query =
    let open RPC_query in
    query (fun next_protocols ->
        object
          method next_protocols = next_protocols
        end)
    |+ multi_field "next_protocol" Protocol_hash.rpc_arg (fun t ->
           t#next_protocols)
    |> seal

  let heads =
    RPC_service.get_service
      ~description:
        "Monitor all blocks that are successfully validated by the node and \
         selected as the new head of the given chain."
      ~query:heads_query
      ~output:
        (merge_objs
           (obj1 (req "hash" Block_hash.encoding))
           Block_header.encoding)
      RPC_path.(path / "heads" /: Chain_services.chain_arg)

  let protocols =
    RPC_service.get_service
      ~description:
        "Monitor all economic protocols that are retrieved and successfully \
         loaded and compiled by the node."
      ~query:RPC_query.empty
      ~output:Protocol_hash.encoding
      RPC_path.(path / "protocols")

  let commit_hash =
    RPC_service.get_service
      ~description:"Get information on the build of the node."
      ~query:RPC_query.empty
      ~output:string
      RPC_path.(path / "commit_hash")

  let active_chains =
    RPC_service.get_service
      ~description:
        "Monitor every chain creation and destruction. Currently active \
         chains will be given as first elements"
      ~query:RPC_query.empty
      ~output:(Data_encoding.list chain_status_encoding)
      RPC_path.(path / "active_chains")
end

open RPC_context

let bootstrapped ctxt = make_streamed_call S.bootstrapped ctxt () () ()

let valid_blocks ctxt ?(chains = [`Main]) ?(protocols = [])
    ?(next_protocols = []) () =
  make_streamed_call
    S.valid_blocks
    ctxt
    ()
    (object
       method chains = chains

       method protocols = protocols

       method next_protocols = next_protocols
    end)
    ()

let heads ctxt ?(next_protocols = []) chain =
  make_streamed_call
    S.heads
    ctxt
    ((), chain)
    (object
       method next_protocols = next_protocols
    end)
    ()

let protocols ctxt = make_streamed_call S.protocols ctxt () () ()

let commit_hash ctxt = make_call S.commit_hash ctxt () () ()

let active_chains ctxt = make_streamed_call S.active_chains ctxt () () ()
src/lib_shell_services/monitor_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive chain_status : Type :=
| Active_main : Tezos_base__TzPervasives.Chain_id.t -> chain_status
| Active_test : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Protocol_hash.t ->
  Tezos_base__TzPervasives.Time.Protocol.t -> chain_status
| Stopping : Tezos_base__TzPervasives.Chain_id.t -> chain_status.

Definition chain_status_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding chain_status :=
  Tezos_base__TzPervasives.Data_encoding.union (Some variant)
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case "Main" % string None (Tag 0)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding))
        (fun function_parameter =>
          match function_parameter with
          | Active_main chain_id => Some chain_id
          | _ => None
          end) (fun chain_id => Active_main chain_id))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Test" % string None
          (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.obj3
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "test_protocol" % string
              Tezos_base__TzPervasives.Protocol_hash.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "expiration_date" % string
              Tezos_base__TzPervasives.Time.Protocol.encoding))
          (fun function_parameter =>
            match function_parameter with
            |
              Active_test {|
                chain := chain;
                  protocol := protocol;
                  expiration_date := expiration_date
                  |} => Some (chain, protocol, expiration_date)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (chain, protocol, expiration_date) =>
              Active_test
                {| chain := chain; protocol := protocol;
                  expiration_date := expiration_date |}
            end))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Stopping" % string None
            (Tag 2)
            (Tezos_base__TzPervasives.Data_encoding.obj1
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "stopping" % string Tezos_base__TzPervasives.Chain_id.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Stopping chain_id => Some chain_id
              | _ => None
              end) (fun chain_id => Stopping chain_id)) []))).

Module S.
  Import Tezos_base__TzPervasives.Data_encoding.
  
  Definition path : Tezos_base__TzPervasives.RPC_path.path unit unit :=
    Tezos_base__TzPervasives.RPC_path.op_div
      Tezos_base__TzPervasives.RPC_path.root "monitor" % string.
  
  Definition bootstrapped
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Time.Protocol.t) :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some
        "Wait for the node to have synchronized its chain with a few peers (configured by the node's administrator), streaming head updates that happen during the bootstrapping process, and closing the stream at the end. If the node was already bootstrapped, returns the current head immediately."
          % string) Tezos_base__TzPervasives.RPC_query.empty
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None "block" % string
          Tezos_base__TzPervasives.Block_hash.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "timestamp" % string Tezos_base__TzPervasives.Time.Protocol.encoding))
      (Tezos_base__TzPervasives.RPC_path.op_div path "bootstrapped" % string).
  
  Definition valid_blocks_query
    : Tezos_base__TzPervasives.RPC_query.t
      (((list Tezos_base__TzPervasives.Protocol_hash.t) *
        ((list Tezos_base__TzPervasives.Protocol_hash.t) *
          ((list Tezos_shell_services.Chain_services.chain) * nil)))) :=
    OCaml.Stdlib.reverse_apply
      (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
        (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
          (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
            (Tezos_base__TzPervasives.RPC_query.query
              (fun protocols => fun next_protocols => fun chains => object))
            (Tezos_base__TzPervasives.RPC_query.multi_field None
              "protocol" % string Tezos_base__TzPervasives.Protocol_hash.rpc_arg
              (fun t => send)))
          (Tezos_base__TzPervasives.RPC_query.multi_field None
            "next_protocol" % string
            Tezos_base__TzPervasives.Protocol_hash.rpc_arg (fun t => send)))
        (Tezos_base__TzPervasives.RPC_query.multi_field None "chain" % string
          Tezos_shell_services.Chain_services.chain_arg (fun t => send)))
      Tezos_base__TzPervasives.RPC_query.seal.
  
  Definition valid_blocks
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit
      (((list Tezos_base__TzPervasives.Protocol_hash.t) *
        ((list Tezos_base__TzPervasives.Protocol_hash.t) *
          ((list Tezos_shell_services.Chain_services.chain) * nil)))) unit
      ((Tezos_base__TzPervasives.Chain_id.t *
        Tezos_base__TzPervasives.Block_hash.t) *
        Tezos_base__TzPervasives.Block_header.t) :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some
        "Monitor all blocks that are successfully validated by the node, disregarding whether they were selected as the new head or not."
          % string) valid_blocks_query
      (Tezos_base__TzPervasives.Data_encoding.merge_objs
        (Tezos_base__TzPervasives.Data_encoding.obj2
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
          (Tezos_base__TzPervasives.Data_encoding.req None None "hash" % string
            Tezos_base__TzPervasives.Block_hash.encoding))
        Tezos_base__TzPervasives.Block_header.encoding)
      (Tezos_base__TzPervasives.RPC_path.op_div path "valid_blocks" % string).
  
  Definition heads_query
    : Tezos_base__TzPervasives.RPC_query.t
      (((list Tezos_base__TzPervasives.Protocol_hash.t) * nil)) :=
    OCaml.Stdlib.reverse_apply
      (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
        (Tezos_base__TzPervasives.RPC_query.query (fun next_protocols => object))
        (Tezos_base__TzPervasives.RPC_query.multi_field None
          "next_protocol" % string
          Tezos_base__TzPervasives.Protocol_hash.rpc_arg (fun t => send)))
      Tezos_base__TzPervasives.RPC_query.seal.
  
  Definition heads
    : Tezos_base__TzPervasives.RPC_service.service variant unit
      (unit * Tezos_shell_services.Chain_services.chain)
      (((list Tezos_base__TzPervasives.Protocol_hash.t) * nil)) unit
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t) :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some
        "Monitor all blocks that are successfully validated by the node and selected as the new head of the given chain."
          % string) heads_query
      (Tezos_base__TzPervasives.Data_encoding.merge_objs
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None "hash" % string
            Tezos_base__TzPervasives.Block_hash.encoding))
        Tezos_base__TzPervasives.Block_header.encoding)
      (Tezos_base__TzPervasives.RPC_path.op_div_colon
        (Tezos_base__TzPervasives.RPC_path.op_div path "heads" % string)
        Tezos_shell_services.Chain_services.chain_arg).
  
  Definition protocols
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.Protocol_hash.t :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some
        "Monitor all economic protocols that are retrieved and successfully loaded and compiled by the node."
          % string) Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.Protocol_hash.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div path "protocols" % string).
  
  Definition commit_hash
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      string :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "Get information on the build of the node." % string)
      Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.Data_encoding.string
      (Tezos_base__TzPervasives.RPC_path.op_div path "commit_hash" % string).
  
  Definition active_chains
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      (list chain_status) :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some
        "Monitor every chain creation and destruction. Currently active chains will be given as first elements"
          % string) Tezos_base__TzPervasives.RPC_query.empty
      (Tezos_base__TzPervasives.Data_encoding.list None chain_status_encoding)
      (Tezos_base__TzPervasives.RPC_path.op_div path "active_chains" % string).
End S.

Import Tezos_base__TzPervasives.RPC_context.

Definition bootstrapped {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Lwt_stream.t
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Time.Protocol.t)) *
        Tezos_base__TzPervasives.RPC_context.stopper)) :=
  Tezos_base__TzPervasives.RPC_context.make_streamed_call S.bootstrapped ctxt tt
    tt tt.

Definition valid_blocks {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  (op_star_o_p_t_star : option (list variant))
  : (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
    (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
      unit ->
        Lwt.t
          (Tezos_error_monad.Error_monad.tzresult
            ((Lwt_stream.t
              ((Tezos_base__TzPervasives.Chain_id.t *
                Tezos_base__TzPervasives.Block_hash.t) *
                Tezos_base__TzPervasives.Block_header.t)) *
              Tezos_base__TzPervasives.RPC_context.stopper)) :=
  let chains :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => cons variant []
    end in
  fun op_star_o_p_t_star =>
    let protocols :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun op_star_o_p_t_star =>
      let next_protocols :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => []
        end in
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.RPC_context.make_streamed_call S.valid_blocks
            ctxt tt object tt
        end.

Definition heads {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  (op_star_o_p_t_star : option (list Tezos_base__TzPervasives.Protocol_hash.t))
  : Tezos_shell_services.Chain_services.chain ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        ((Lwt_stream.t
          (Tezos_base__TzPervasives.Block_hash.t *
            Tezos_base__TzPervasives.Block_header.t)) *
          Tezos_base__TzPervasives.RPC_context.stopper)) :=
  let next_protocols :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun chain =>
    Tezos_base__TzPervasives.RPC_context.make_streamed_call S.heads ctxt
      (tt, chain) object tt.

Definition protocols {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Lwt_stream.t Tezos_base__TzPervasives.Protocol_hash.t) *
        Tezos_base__TzPervasives.RPC_context.stopper)) :=
  Tezos_base__TzPervasives.RPC_context.make_streamed_call S.protocols ctxt tt tt
    tt.

Definition commit_hash {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult string) :=
  Tezos_base__TzPervasives.RPC_context.make_call S.commit_hash ctxt tt tt tt.

Definition active_chains {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Lwt_stream.t (list chain_status)) *
        Tezos_base__TzPervasives.RPC_context.stopper)) :=
  Tezos_base__TzPervasives.RPC_context.make_streamed_call S.active_chains ctxt
    tt tt tt.
src/lib_shell_services/monitor_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open RPC_context

type chain_status =
  | Active_main of Chain_id.t
  | Active_test of {
      chain : Chain_id.t;
      protocol : Protocol_hash.t;
      expiration_date : Time.Protocol.t;
    }
  | Stopping of Chain_id.t

val bootstrapped :
  #streamed ->
  ((Block_hash.t * Time.Protocol.t) Lwt_stream.t * stopper) tzresult Lwt.t

val valid_blocks :
  #streamed ->
  ?chains:Chain_services.chain list ->
  ?protocols:Protocol_hash.t list ->
  ?next_protocols:Protocol_hash.t list ->
  unit ->
  (((Chain_id.t * Block_hash.t) * Block_header.t) Lwt_stream.t * stopper)
  tzresult
  Lwt.t

val heads :
  #streamed ->
  ?next_protocols:Protocol_hash.t list ->
  Chain_services.chain ->
  ((Block_hash.t * Block_header.t) Lwt_stream.t * stopper) tzresult Lwt.t

val protocols :
  #streamed -> (Protocol_hash.t Lwt_stream.t * stopper) tzresult Lwt.t

val commit_hash : #simple -> string tzresult Lwt.t

val active_chains :
  #streamed -> (chain_status list Lwt_stream.t * stopper) tzresult Lwt.t

module S : sig
  val bootstrapped :
    ( [`GET],
      unit,
      unit,
      unit,
      unit,
      Block_hash.t * Time.Protocol.t )
    RPC_service.t

  val valid_blocks :
    ( [`GET],
      unit,
      unit,
      < chains : Chain_services.chain list
      ; next_protocols : Protocol_hash.t list
      ; protocols : Protocol_hash.t list >,
      unit,
      (Chain_id.t * Block_hash.t) * Block_header.t )
    RPC_service.t

  val heads :
    ( [`GET],
      unit,
      unit * Chain_services.chain,
      < next_protocols : Protocol_hash.t list >,
      unit,
      Block_hash.t * Block_header.t )
    RPC_service.t

  val protocols :
    ([`GET], unit, unit, unit, unit, Protocol_hash.t) RPC_service.t

  val commit_hash : ([`GET], unit, unit, unit, unit, string) RPC_service.t

  val active_chains :
    ([`GET], unit, unit, unit, unit, chain_status list) RPC_service.t
end
src/lib_shell_services/monitor_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive chain_status : Type :=
| Active_main : Tezos_base__TzPervasives.Chain_id.t -> chain_status
| Active_test : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Protocol_hash.t ->
  Tezos_base__TzPervasives.Time.Protocol.t -> chain_status
| Stopping : Tezos_base__TzPervasives.Chain_id.t -> chain_status.

Parameter bootstrapped : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  (o -> unit) ->
    (unit -> unit) ->
      p ->
        q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
  * (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Lwt_stream.t
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Time.Protocol.t)) *
        Tezos_base__TzPervasives.RPC_context.stopper)).

Parameter valid_blocks : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  (o -> unit) ->
    (unit -> unit) ->
      p ->
        q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
  * (_ * p * q * i * o)) * _) * _) ->
  (option (list Tezos_shell_services.Chain_services.chain)) ->
    (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
      (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
        unit ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              ((Lwt_stream.t
                ((Tezos_base__TzPervasives.Chain_id.t *
                  Tezos_base__TzPervasives.Block_hash.t) *
                  Tezos_base__TzPervasives.Block_header.t)) *
                Tezos_base__TzPervasives.RPC_context.stopper)).

Parameter heads : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  (o -> unit) ->
    (unit -> unit) ->
      p ->
        q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
  * (_ * p * q * i * o)) * _) * _) ->
  (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
    Tezos_shell_services.Chain_services.chain ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          ((Lwt_stream.t
            (Tezos_base__TzPervasives.Block_hash.t *
              Tezos_base__TzPervasives.Block_header.t)) *
            Tezos_base__TzPervasives.RPC_context.stopper)).

Parameter protocols : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  (o -> unit) ->
    (unit -> unit) ->
      p ->
        q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
  * (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Lwt_stream.t Tezos_base__TzPervasives.Protocol_hash.t) *
        Tezos_base__TzPervasives.RPC_context.stopper)).

Parameter commit_hash : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t (Tezos_base__TzPervasives.tzresult string).

Parameter active_chains : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  (o -> unit) ->
    (unit -> unit) ->
      p ->
        q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
  * (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Lwt_stream.t (list chain_status)) *
        Tezos_base__TzPervasives.RPC_context.stopper)).

Module S.
  Parameter bootstrapped : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit
    (Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Time.Protocol.t).
  
  Parameter valid_blocks : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit
    (((list Tezos_shell_services.Chain_services.chain) *
      ((list Tezos_base__TzPervasives.Protocol_hash.t) *
        ((list Tezos_base__TzPervasives.Protocol_hash.t) * nil)))) unit
    ((Tezos_base__TzPervasives.Chain_id.t *
      Tezos_base__TzPervasives.Block_hash.t) *
      Tezos_base__TzPervasives.Block_header.t).
  
  Parameter heads : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit (unit * Tezos_shell_services.Chain_services.chain)
    (((list Tezos_base__TzPervasives.Protocol_hash.t) * nil)) unit
    (Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t).
  
  Parameter protocols : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit Tezos_base__TzPervasives.Protocol_hash.t.
  
  Parameter commit_hash : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit string.
  
  Parameter active_chains : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit (list chain_status).
End S.
src/lib_shell_services/p2p_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let wait_query =
  let open RPC_query in
  query (fun wait ->
      object
        method wait = wait
      end)
  |+ flag "wait" (fun t -> t#wait)
  |> seal

let monitor_query =
  let open RPC_query in
  query (fun monitor ->
      object
        method monitor = monitor
      end)
  |+ flag "monitor" (fun t -> t#monitor)
  |> seal

let timeout_query =
  let open RPC_query in
  query (fun timeout ->
      object
        method timeout = timeout
      end)
  |+ field
       "timeout"
       Time.System.Span.rpc_arg
       (Time.System.Span.of_seconds_exn 10.)
       (fun t -> t#timeout)
  |> seal

module S = struct
  let self =
    RPC_service.get_service
      ~description:"Return the node's peer id"
      ~query:RPC_query.empty
      ~output:P2p_peer.Id.encoding
      RPC_path.(root / "network" / "self")

  let version =
    RPC_service.get_service
      ~description:"Supported network layer version."
      ~query:RPC_query.empty
      ~output:Network_version.encoding
      RPC_path.(root / "network" / "version")

  (* DEPRECATED: use [version] instead. *)
  let versions =
    RPC_service.get_service
      ~description:"DEPRECATED: use `version` instead."
      ~query:RPC_query.empty
      ~output:(Data_encoding.list Network_version.encoding)
      RPC_path.(root / "network" / "versions")

  let stat =
    RPC_service.get_service
      ~description:"Global network bandwidth statistics in B/s."
      ~query:RPC_query.empty
      ~output:P2p_stat.encoding
      RPC_path.(root / "network" / "stat")

  let events =
    RPC_service.get_service
      ~description:"Stream of all network events"
      ~query:RPC_query.empty
      ~output:P2p_connection.Pool_event.encoding
      RPC_path.(root / "network" / "log")

  let connect =
    RPC_service.put_service
      ~description:"Connect to a peer"
      ~query:timeout_query
      ~input:Data_encoding.empty
      ~output:Data_encoding.empty
      RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg)
end

open RPC_context

let self ctxt = make_call S.self ctxt () () ()

let stat ctxt = make_call S.stat ctxt () () ()

let version ctxt = make_call S.version ctxt () () ()

let versions ctxt = make_call S.versions ctxt () () ()

(* DEPRECATED: use [version] instead. *)

let events ctxt = make_streamed_call S.events ctxt () () ()

let connect ctxt ~timeout peer_id =
  make_call1
    S.connect
    ctxt
    peer_id
    (object
       method timeout = timeout
    end)
    ()

module Connections = struct
  type connection_info = Connection_metadata.t P2p_connection.Info.t

  let connection_info_encoding =
    P2p_connection.Info.encoding Connection_metadata.encoding

  module S = struct
    let list =
      RPC_service.get_service
        ~description:"List the running P2P connection."
        ~query:RPC_query.empty
        ~output:(Data_encoding.list connection_info_encoding)
        RPC_path.(root / "network" / "connections")

    let info =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:connection_info_encoding
        ~description:
          "Details about the current P2P connection to the given peer."
        RPC_path.(root / "network" / "connections" /: P2p_peer.Id.rpc_arg)

    let kick =
      RPC_service.delete_service
        ~query:wait_query
        ~output:Data_encoding.empty
        ~description:
          "Forced close of the current P2P connection to the given peer."
        RPC_path.(root / "network" / "connections" /: P2p_peer.Id.rpc_arg)
  end

  let list ctxt = make_call S.list ctxt () () ()

  let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()

  let kick ctxt ?(wait = false) peer_id =
    make_call1
      S.kick
      ctxt
      peer_id
      (object
         method wait = wait
      end)
      ()
end

module Points = struct
  module S = struct
    let info =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:P2p_point.Info.encoding
        ~description:"Details about a given `IP:addr`."
        RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg)

    let events =
      RPC_service.get_service
        ~query:monitor_query
        ~output:(Data_encoding.list P2p_point.Pool_event.encoding)
        ~description:"Monitor network events related to an `IP:addr`."
        RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg / "log")

    let list =
      let filter_query =
        let open RPC_query in
        query (fun filters ->
            object
              method filters = filters
            end)
        |+ multi_field "filter" P2p_point.Filter.rpc_arg (fun t -> t#filters)
        |> seal
      in
      RPC_service.get_service
        ~query:filter_query
        ~output:
          Data_encoding.(
            list (tup2 P2p_point.Id.encoding P2p_point.Info.encoding))
        ~description:
          "List the pool of known `IP:port` used for establishing P2P \
           connections."
        RPC_path.(root / "network" / "points")

    let ban =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:
          "Blacklist the given address and remove it from the whitelist if \
           present."
        RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg / "ban")

    let unban =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Remove an address from the blacklist."
        RPC_path.(
          root / "network" / "points" /: P2p_point.Id.rpc_arg / "unban")

    let trust =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:
          "Trust a given address permanently and remove it from the blacklist \
           if present. Connections from this address can still be closed on \
           authentication if the peer is greylisted."
        RPC_path.(
          root / "network" / "points" /: P2p_point.Id.rpc_arg / "trust")

    let untrust =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Remove an address from the whitelist."
        RPC_path.(
          root / "network" / "points" /: P2p_point.Id.rpc_arg / "untrust")

    let banned =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.bool
        ~description:"Check is a given address is blacklisted or greylisted."
        RPC_path.(
          root / "network" / "points" /: P2p_point.Id.rpc_arg / "banned")
  end

  open RPC_context

  let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()

  let events ctxt point =
    make_streamed_call
      S.events
      ctxt
      ((), point)
      (object
         method monitor = true
      end)
      ()

  let list ?(filter = []) ctxt =
    make_call
      S.list
      ctxt
      ()
      (object
         method filters = filter
      end)
      ()

  let ban ctxt peer_id = make_call1 S.ban ctxt peer_id () ()

  let unban ctxt peer_id = make_call1 S.unban ctxt peer_id () ()

  let trust ctxt peer_id = make_call1 S.trust ctxt peer_id () ()

  let untrust ctxt peer_id = make_call1 S.untrust ctxt peer_id () ()

  let banned ctxt peer_id = make_call1 S.banned ctxt peer_id () ()
end

module Peers = struct
  module S = struct
    let info =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:
          (P2p_peer.Info.encoding
             Peer_metadata.encoding
             Connection_metadata.encoding)
        ~description:"Details about a given peer."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg)

    let events =
      RPC_service.get_service
        ~query:monitor_query
        ~output:(Data_encoding.list P2p_peer.Pool_event.encoding)
        ~description:"Monitor network events related to a given peer."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "log")

    let list =
      let filter =
        let open RPC_query in
        query (fun filters ->
            object
              method filters = filters
            end)
        |+ multi_field "filter" P2p_peer.Filter.rpc_arg (fun t -> t#filters)
        |> seal
      in
      RPC_service.get_service
        ~query:filter
        ~output:
          Data_encoding.(
            list
              (tup2
                 P2p_peer.Id.encoding
                 (P2p_peer.Info.encoding
                    Peer_metadata.encoding
                    Connection_metadata.encoding)))
        ~description:"List the peers the node ever met."
        RPC_path.(root / "network" / "peers")

    let ban =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:
          "Blacklist the given peer and remove it from the whitelist if \
           present."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "ban")

    let unban =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Remove the given peer from the blacklist."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "unban")

    let trust =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:
          "Whitelist a given peer permanently and remove it from the \
           blacklist if present. The peer cannot be blocked (but its host IP \
           still can)."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "trust")

    let untrust =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Remove a given peer from the whitelist."
        RPC_path.(
          root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "untrust")

    let banned =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.bool
        ~description:"Check if a given peer is blacklisted or greylisted."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "banned")
  end

  let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()

  let events ctxt point =
    make_streamed_call
      S.events
      ctxt
      ((), point)
      (object
         method monitor = true
      end)
      ()

  let list ?(filter = []) ctxt =
    make_call
      S.list
      ctxt
      ()
      (object
         method filters = filter
      end)
      ()

  let ban ctxt point_id = make_call1 S.ban ctxt point_id () ()

  let unban ctxt point_id = make_call1 S.unban ctxt point_id () ()

  let trust ctxt point_id = make_call1 S.trust ctxt point_id () ()

  let untrust ctxt point_id = make_call1 S.untrust ctxt point_id () ()

  let banned ctxt point_id = make_call1 S.banned ctxt point_id () ()
end

module ACL = struct
  module S = struct
    let clear =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Clear all greylists tables."
        RPC_path.(root / "network" / "greylist" / "clear")
  end

  let clear ctxt = make_call S.clear ctxt () ()
end
src/lib_shell_services/p2p_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition wait_query : Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
  OCaml.Stdlib.reverse_apply
    (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
      (Tezos_base__TzPervasives.RPC_query.query (fun wait => object))
      (Tezos_base__TzPervasives.RPC_query.flag None "wait" % string
        (fun t => send))) Tezos_base__TzPervasives.RPC_query.seal.

Definition monitor_query
  : Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
  OCaml.Stdlib.reverse_apply
    (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
      (Tezos_base__TzPervasives.RPC_query.query (fun monitor => object))
      (Tezos_base__TzPervasives.RPC_query.flag None "monitor" % string
        (fun t => send))) Tezos_base__TzPervasives.RPC_query.seal.

Definition timeout_query
  : Tezos_base__TzPervasives.RPC_query.t
    ((Tezos_base__TzPervasives.Time.System.Span.t * nil)) :=
  OCaml.Stdlib.reverse_apply
    (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
      (Tezos_base__TzPervasives.RPC_query.query (fun timeout => object))
      (Tezos_base__TzPervasives.RPC_query.field None "timeout" % string
        Tezos_base__TzPervasives.Time.System.Span.rpc_arg
        (Tezos_base__TzPervasives.Time.System.Span.of_seconds_exn 10)
        (fun t => send))) Tezos_base__TzPervasives.RPC_query.seal.

Module S.
  Definition self
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.P2p_peer.Id.t :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "Return the node's peer id" % string)
      Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.P2p_peer.Id.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "network" % string)
        "self" % string).
  
  Definition version
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.Network_version.t :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "Supported network layer version." % string)
      Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.Network_version.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "network" % string)
        "version" % string).
  
  Definition versions
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      (list Tezos_base__TzPervasives.Network_version.t) :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "DEPRECATED: use `version` instead." % string)
      Tezos_base__TzPervasives.RPC_query.empty
      (Tezos_base__TzPervasives.Data_encoding.list None
        Tezos_base__TzPervasives.Network_version.encoding)
      (Tezos_base__TzPervasives.RPC_path.op_div
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "network" % string)
        "versions" % string).
  
  Definition stat
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.P2p_stat.t :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "Global network bandwidth statistics in B/s." % string)
      Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.P2p_stat.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "network" % string)
        "stat" % string).
  
  Definition events
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.P2p_connection.Pool_event.t :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "Stream of all network events" % string)
      Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.P2p_connection.Pool_event.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "network" % string)
        "log" % string).
  
  Definition connect
    : Tezos_base__TzPervasives.RPC_service.service variant unit
      (unit * Tezos_base__TzPervasives.P2p_point.Id.t)
      ((Tezos_base__TzPervasives.Time.System.Span.t * nil)) unit unit :=
    Tezos_base__TzPervasives.RPC_service.put_service
      (Some "Connect to a peer" % string) timeout_query
      Tezos_base__TzPervasives.Data_encoding.empty
      Tezos_base__TzPervasives.Data_encoding.empty
      (Tezos_base__TzPervasives.RPC_path.op_div_colon
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div
            Tezos_base__TzPervasives.RPC_path.root "network" % string)
          "points" % string) Tezos_base__TzPervasives.P2p_point.Id.rpc_arg).
End S.

Import Tezos_base__TzPervasives.RPC_context.

Definition self {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.P2p_peer.Id.t) :=
  Tezos_base__TzPervasives.RPC_context.make_call S.self ctxt tt tt tt.

Definition stat {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult Tezos_base__TzPervasives.P2p_stat.t) :=
  Tezos_base__TzPervasives.RPC_context.make_call S.stat ctxt tt tt tt.

Definition version {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.Network_version.t) :=
  Tezos_base__TzPervasives.RPC_context.make_call S.version ctxt tt tt tt.

Definition versions {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      (list Tezos_base__TzPervasives.Network_version.t)) :=
  Tezos_base__TzPervasives.RPC_context.make_call S.versions ctxt tt tt tt.

Definition events {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Lwt_stream.t Tezos_base__TzPervasives.P2p_connection.Pool_event.t) *
        Tezos_base__TzPervasives.RPC_context.stopper)) :=
  Tezos_base__TzPervasives.RPC_context.make_streamed_call S.events ctxt tt tt tt.

Definition connect {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (timeout : Tezos_base__TzPervasives.Time.System.Span.t)
  (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  Tezos_base__TzPervasives.RPC_context.make_call1 S.connect ctxt peer_id object
    tt.

Module Connections.
  Definition connection_info :=
    Tezos_base__TzPervasives.P2p_connection.Info.t
      Tezos_shell_services.Connection_metadata.t.
  
  Definition connection_info_encoding
    : Tezos_data_encoding.Data_encoding.t
      (Tezos_base__TzPervasives.P2p_connection.Info.t
        Tezos_shell_services.Connection_metadata.t) :=
    Tezos_base__TzPervasives.P2p_connection.Info.encoding
      Tezos_shell_services.Connection_metadata.encoding.
  
  Module S.
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        (list
          (Tezos_base__TzPervasives.P2p_connection.Info.t
            Tezos_shell_services.Connection_metadata.t)) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "List the running P2P connection." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_base__TzPervasives.Data_encoding.list None
          connection_info_encoding)
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div
            Tezos_base__TzPervasives.RPC_path.root "network" % string)
          "connections" % string).
    
    Definition info
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
        (Tezos_base__TzPervasives.P2p_connection.Info.t
          Tezos_shell_services.Connection_metadata.t) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "Details about the current P2P connection to the given peer." % string)
        Tezos_base__TzPervasives.RPC_query.empty connection_info_encoding
        (Tezos_base__TzPervasives.RPC_path.op_div_colon
          (Tezos_base__TzPervasives.RPC_path.op_div
            (Tezos_base__TzPervasives.RPC_path.op_div
              Tezos_base__TzPervasives.RPC_path.root "network" % string)
            "connections" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg).
    
    Definition kick
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) ((bool * nil)) unit unit :=
      Tezos_base__TzPervasives.RPC_service.delete_service
        (Some
          "Forced close of the current P2P connection to the given peer." %
            string) wait_query Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div_colon
          (Tezos_base__TzPervasives.RPC_path.op_div
            (Tezos_base__TzPervasives.RPC_path.op_div
              Tezos_base__TzPervasives.RPC_path.root "network" % string)
            "connections" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg).
  End S.
  
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (list
          (Tezos_base__TzPervasives.P2p_connection.Info.t
            Tezos_shell_services.Connection_metadata.t))) :=
    Tezos_base__TzPervasives.RPC_context.make_call S.list ctxt tt tt tt.
  
  Definition info {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_base__TzPervasives.P2p_connection.Info.t
          Tezos_shell_services.Connection_metadata.t)) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.info ctxt peer_id tt tt.
  
  Definition kick {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F) (op_star_o_p_t_star : option bool)
    : Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let wait :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun peer_id =>
      Tezos_base__TzPervasives.RPC_context.make_call1 S.kick ctxt peer_id object
        tt.
End Connections.

Module Points.
  Module S.
    Definition info
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
        Tezos_base__TzPervasives.P2p_point.Info.t :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Details about a given `IP:addr`." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.P2p_point.Info.encoding
        (Tezos_base__TzPervasives.RPC_path.op_div_colon
          (Tezos_base__TzPervasives.RPC_path.op_div
            (Tezos_base__TzPervasives.RPC_path.op_div
              Tezos_base__TzPervasives.RPC_path.root "network" % string)
            "points" % string) Tezos_base__TzPervasives.P2p_point.Id.rpc_arg).
    
    Definition events
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) ((bool * nil)) unit
        (list Tezos_base__TzPervasives.P2p_point.Pool_event.t) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Monitor network events related to an `IP:addr`." % string)
        monitor_query
        (Tezos_base__TzPervasives.Data_encoding.list None
          Tezos_base__TzPervasives.P2p_point.Pool_event.encoding)
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "points" % string) Tezos_base__TzPervasives.P2p_point.Id.rpc_arg)
          "log" % string).
    
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit
        (((list Tezos_base__TzPervasives.P2p_point.Filter.t) * nil)) unit
        (list
          (Tezos_base__TzPervasives.P2p_point.Id.t *
            Tezos_base__TzPervasives.P2p_point.Info.t)) :=
      let filter_query :=
        OCaml.Stdlib.reverse_apply
          (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
            (Tezos_base__TzPervasives.RPC_query.query (fun filters => object))
            (Tezos_base__TzPervasives.RPC_query.multi_field None
              "filter" % string
              Tezos_base__TzPervasives.P2p_point.Filter.rpc_arg (fun t => send)))
          Tezos_base__TzPervasives.RPC_query.seal in
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "List the pool of known `IP:port` used for establishing P2P connections."
            % string) filter_query
        (Tezos_base__TzPervasives.Data_encoding.list None
          (Tezos_base__TzPervasives.Data_encoding.tup2
            Tezos_base__TzPervasives.P2p_point.Id.encoding
            Tezos_base__TzPervasives.P2p_point.Info.encoding))
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div
            Tezos_base__TzPervasives.RPC_path.root "network" % string)
          "points" % string).
    
    Definition ban
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "Blacklist the given address and remove it from the whitelist if present."
            % string) Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "points" % string) Tezos_base__TzPervasives.P2p_point.Id.rpc_arg)
          "ban" % string).
    
    Definition unban
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Remove an address from the blacklist." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "points" % string) Tezos_base__TzPervasives.P2p_point.Id.rpc_arg)
          "unban" % string).
    
    Definition trust
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "Trust a given address permanently and remove it from the blacklist if present. Connections from this address can still be closed on authentication if the peer is greylisted."
            % string) Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "points" % string) Tezos_base__TzPervasives.P2p_point.Id.rpc_arg)
          "trust" % string).
    
    Definition untrust
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Remove an address from the whitelist." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "points" % string) Tezos_base__TzPervasives.P2p_point.Id.rpc_arg)
          "untrust" % string).
    
    Definition banned
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit bool :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Check is a given address is blacklisted or greylisted." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.bool
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "points" % string) Tezos_base__TzPervasives.P2p_point.Id.rpc_arg)
          "banned" % string).
  End S.
  
  Import Tezos_base__TzPervasives.RPC_context.
  
  Definition info {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_base__TzPervasives.P2p_point.Info.t) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.info ctxt peer_id tt tt.
  
  Definition events {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        (o -> unit) ->
          (unit -> unit) ->
            p ->
              q ->
                i ->
                  Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
        * (E * p * q * i * o)) * F) * F)
    (point : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        ((Lwt_stream.t (list Tezos_base__TzPervasives.P2p_point.Pool_event.t)) *
          Tezos_base__TzPervasives.RPC_context.stopper)) :=
    Tezos_base__TzPervasives.RPC_context.make_streamed_call S.events ctxt
      (tt, point) object tt.
  
  Definition list {E F i o p q : Type}
    (op_star_o_p_t_star :
      option (list Tezos_base__TzPervasives.P2p_point.Filter.t))
    : (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) ->
      Lwt.t
        (Tezos_error_monad.Error_monad.tzresult
          (list
            (Tezos_base__TzPervasives.P2p_point.Id.t *
              Tezos_base__TzPervasives.P2p_point.Info.t))) :=
    let filter :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun ctxt =>
      Tezos_base__TzPervasives.RPC_context.make_call S.list ctxt tt object tt.
  
  Definition ban {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.ban ctxt peer_id tt tt.
  
  Definition unban {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.unban ctxt peer_id tt tt.
  
  Definition trust {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.trust ctxt peer_id tt tt.
  
  Definition untrust {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.untrust ctxt peer_id tt tt.
  
  Definition banned {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.banned ctxt peer_id tt tt.
End Points.

Module Peers.
  Module S.
    Definition info
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
        (Tezos_base__TzPervasives.P2p_peer.Info.t
          Tezos_shell_services.Peer_metadata.t
          Tezos_shell_services.Connection_metadata.t) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Details about a given peer." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_base__TzPervasives.P2p_peer.Info.encoding
          Tezos_shell_services.Peer_metadata.encoding
          Tezos_shell_services.Connection_metadata.encoding)
        (Tezos_base__TzPervasives.RPC_path.op_div_colon
          (Tezos_base__TzPervasives.RPC_path.op_div
            (Tezos_base__TzPervasives.RPC_path.op_div
              Tezos_base__TzPervasives.RPC_path.root "network" % string)
            "peers" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg).
    
    Definition events
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) ((bool * nil)) unit
        (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Monitor network events related to a given peer." % string)
        monitor_query
        (Tezos_base__TzPervasives.Data_encoding.list None
          Tezos_base__TzPervasives.P2p_peer.Pool_event.encoding)
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "peers" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg)
          "log" % string).
    
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit
        (((list Tezos_base__TzPervasives.P2p_peer.Filter.t) * nil)) unit
        (list
          (Tezos_base__TzPervasives.P2p_peer.Id.t *
            (Tezos_base__TzPervasives.P2p_peer.Info.t
              Tezos_shell_services.Peer_metadata.t
              Tezos_shell_services.Connection_metadata.t))) :=
      let filter :=
        OCaml.Stdlib.reverse_apply
          (Tezos_base__TzPervasives.RPC_query.op_pipe_plus
            (Tezos_base__TzPervasives.RPC_query.query (fun filters => object))
            (Tezos_base__TzPervasives.RPC_query.multi_field None
              "filter" % string Tezos_base__TzPervasives.P2p_peer.Filter.rpc_arg
              (fun t => send))) Tezos_base__TzPervasives.RPC_query.seal in
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "List the peers the node ever met." % string) filter
        (Tezos_base__TzPervasives.Data_encoding.list None
          (Tezos_base__TzPervasives.Data_encoding.tup2
            Tezos_base__TzPervasives.P2p_peer.Id.encoding
            (Tezos_base__TzPervasives.P2p_peer.Info.encoding
              Tezos_shell_services.Peer_metadata.encoding
              Tezos_shell_services.Connection_metadata.encoding)))
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div
            Tezos_base__TzPervasives.RPC_path.root "network" % string)
          "peers" % string).
    
    Definition ban
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "Blacklist the given peer and remove it from the whitelist if present."
            % string) Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "peers" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg)
          "ban" % string).
    
    Definition unban
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Remove the given peer from the blacklist." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "peers" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg)
          "unban" % string).
    
    Definition trust
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "Whitelist a given peer permanently and remove it from the blacklist if present. The peer cannot be blocked (but its host IP still can)."
            % string) Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "peers" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg)
          "trust" % string).
    
    Definition untrust
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Remove a given peer from the whitelist." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "peers" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg)
          "untrust" % string).
    
    Definition banned
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit bool :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Check if a given peer is blacklisted or greylisted." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.bool
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "network" % string)
              "peers" % string) Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg)
          "banned" % string).
  End S.
  
  Definition info {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_base__TzPervasives.P2p_peer.Info.t
          Tezos_shell_services.Peer_metadata.t
          Tezos_shell_services.Connection_metadata.t)) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.info ctxt peer_id tt tt.
  
  Definition events {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        (o -> unit) ->
          (unit -> unit) ->
            p ->
              q ->
                i ->
                  Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
        * (E * p * q * i * o)) * F) * F)
    (point : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        ((Lwt_stream.t (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t)) *
          Tezos_base__TzPervasives.RPC_context.stopper)) :=
    Tezos_base__TzPervasives.RPC_context.make_streamed_call S.events ctxt
      (tt, point) object tt.
  
  Definition list {E F i o p q : Type}
    (op_star_o_p_t_star :
      option (list Tezos_base__TzPervasives.P2p_peer.Filter.t))
    : (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) ->
      Lwt.t
        (Tezos_error_monad.Error_monad.tzresult
          (list
            (Tezos_base__TzPervasives.P2p_peer.Id.t *
              (Tezos_base__TzPervasives.P2p_peer.Info.t
                Tezos_shell_services.Peer_metadata.t
                Tezos_shell_services.Connection_metadata.t)))) :=
    let filter :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun ctxt =>
      Tezos_base__TzPervasives.RPC_context.make_call S.list ctxt tt object tt.
  
  Definition ban {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.ban ctxt point_id tt tt.
  
  Definition unban {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.unban ctxt point_id tt tt.
  
  Definition trust {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.trust ctxt point_id tt tt.
  
  Definition untrust {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.untrust ctxt point_id tt
      tt.
  
  Definition banned {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.banned ctxt point_id tt tt.
End Peers.

Module ACL.
  Module S.
    Definition clear
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        unit :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Clear all greylists tables." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        Tezos_base__TzPervasives.Data_encoding.empty
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div
            (Tezos_base__TzPervasives.RPC_path.op_div
              Tezos_base__TzPervasives.RPC_path.root "network" % string)
            "greylist" % string) "clear" % string).
  End S.
  
  Definition clear {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Tezos_base__TzPervasives.RPC_context.make_call S.clear ctxt tt tt.
End ACL.
src/lib_shell_services/p2p_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open RPC_context

val self : #simple -> P2p_peer.Id.t tzresult Lwt.t

val stat : #simple -> P2p_stat.t tzresult Lwt.t

val version : #simple -> Network_version.t tzresult Lwt.t

(* DEPRECATED: use [version] instead. *)
val versions : #simple -> Network_version.t list tzresult Lwt.t

val events :
  #streamed ->
  (P2p_connection.Pool_event.t Lwt_stream.t * stopper) tzresult Lwt.t

val connect :
  #simple -> timeout:Ptime.Span.t -> P2p_point.Id.t -> unit tzresult Lwt.t

module S : sig
  val self : ([`GET], unit, unit, unit, unit, P2p_peer.Id.t) RPC_service.t

  val stat : ([`GET], unit, unit, unit, unit, P2p_stat.t) RPC_service.t

  val version :
    ([`GET], unit, unit, unit, unit, Network_version.t) RPC_service.t

  (* DEPRECATED: use [version] instead. *)
  val versions :
    ([`GET], unit, unit, unit, unit, Network_version.t list) RPC_service.t

  val events :
    ([`GET], unit, unit, unit, unit, P2p_connection.Pool_event.t) RPC_service.t

  val connect :
    ( [`PUT],
      unit,
      unit * P2p_point.Id.t,
      < timeout : Ptime.Span.t >,
      unit,
      unit )
    RPC_service.t
end

module Connections : sig
  open RPC_context

  type connection_info = Connection_metadata.t P2p_connection.Info.t

  val list : #simple -> connection_info list tzresult Lwt.t

  val info : #simple -> P2p_peer.Id.t -> connection_info tzresult Lwt.t

  val kick : #simple -> ?wait:bool -> P2p_peer.Id.t -> unit tzresult Lwt.t

  module S : sig
    val list :
      ([`GET], unit, unit, unit, unit, connection_info list) RPC_service.t

    val info :
      ( [`GET],
        unit,
        unit * P2p_peer.Id.t,
        unit,
        unit,
        connection_info )
      RPC_service.t

    val kick :
      ( [`DELETE],
        unit,
        unit * P2p_peer.Id.t,
        < wait : bool >,
        unit,
        unit )
      RPC_service.t
  end
end

module Points : sig
  val list :
    ?filter:P2p_point.Filter.t list ->
    #simple ->
    (P2p_point.Id.t * P2p_point.Info.t) list tzresult Lwt.t

  val info : #simple -> P2p_point.Id.t -> P2p_point.Info.t tzresult Lwt.t

  val events :
    #streamed ->
    P2p_point.Id.t ->
    (P2p_point.Pool_event.t list Lwt_stream.t * stopper) tzresult Lwt.t

  val ban : #simple -> P2p_point.Id.t -> unit tzresult Lwt.t

  val unban : #simple -> P2p_point.Id.t -> unit tzresult Lwt.t

  val trust : #simple -> P2p_point.Id.t -> unit tzresult Lwt.t

  val untrust : #simple -> P2p_point.Id.t -> unit tzresult Lwt.t

  val banned : #simple -> P2p_point.Id.t -> bool tzresult Lwt.t

  module S : sig
    val list :
      ( [`GET],
        unit,
        unit,
        < filters : P2p_point.Filter.t list >,
        unit,
        (P2p_point.Id.t * P2p_point.Info.t) list )
      RPC_service.t

    val info :
      ( [`GET],
        unit,
        unit * P2p_point.Id.t,
        unit,
        unit,
        P2p_point.Info.t )
      RPC_service.t

    val events :
      ( [`GET],
        unit,
        unit * P2p_point.Id.t,
        < monitor : bool >,
        unit,
        P2p_point.Pool_event.t list )
      RPC_service.t

    val ban :
      ([`GET], unit, unit * P2p_point.Id.t, unit, unit, unit) RPC_service.t

    val unban :
      ([`GET], unit, unit * P2p_point.Id.t, unit, unit, unit) RPC_service.t

    val trust :
      ([`GET], unit, unit * P2p_point.Id.t, unit, unit, unit) RPC_service.t

    val untrust :
      ([`GET], unit, unit * P2p_point.Id.t, unit, unit, unit) RPC_service.t

    val banned :
      ([`GET], unit, unit * P2p_point.Id.t, unit, unit, bool) RPC_service.t
  end
end

module Peers : sig
  val list :
    ?filter:P2p_peer.Filter.t list ->
    #simple ->
    (P2p_peer.Id.t * (Peer_metadata.t, Connection_metadata.t) P2p_peer.Info.t)
    list
    tzresult
    Lwt.t

  val info :
    #simple ->
    P2p_peer.Id.t ->
    (Peer_metadata.t, Connection_metadata.t) P2p_peer.Info.t tzresult Lwt.t

  val events :
    #streamed ->
    P2p_peer.Id.t ->
    (P2p_peer.Pool_event.t list Lwt_stream.t * stopper) tzresult Lwt.t

  val ban : #simple -> P2p_peer.Id.t -> unit tzresult Lwt.t

  val unban : #simple -> P2p_peer.Id.t -> unit tzresult Lwt.t

  val trust : #simple -> P2p_peer.Id.t -> unit tzresult Lwt.t

  val untrust : #simple -> P2p_peer.Id.t -> unit tzresult Lwt.t

  val banned : #simple -> P2p_peer.Id.t -> bool tzresult Lwt.t

  module S : sig
    val list :
      ( [`GET],
        unit,
        unit,
        < filters : P2p_peer.Filter.t list >,
        unit,
        ( P2p_peer.Id.t
        * (Peer_metadata.t, Connection_metadata.t) P2p_peer.Info.t )
        list )
      RPC_service.t

    val info :
      ( [`GET],
        unit,
        unit * P2p_peer.Id.t,
        unit,
        unit,
        (Peer_metadata.t, Connection_metadata.t) P2p_peer.Info.t )
      RPC_service.t

    val events :
      ( [`GET],
        unit,
        unit * P2p_peer.Id.t,
        < monitor : bool >,
        unit,
        P2p_peer.Pool_event.t list )
      RPC_service.t

    val ban :
      ([`GET], unit, unit * P2p_peer.Id.t, unit, unit, unit) RPC_service.t

    val unban :
      ([`GET], unit, unit * P2p_peer.Id.t, unit, unit, unit) RPC_service.t

    val trust :
      ([`GET], unit, unit * P2p_peer.Id.t, unit, unit, unit) RPC_service.t

    val untrust :
      ([`GET], unit, unit * P2p_peer.Id.t, unit, unit, unit) RPC_service.t

    val banned :
      ([`GET], unit, unit * P2p_peer.Id.t, unit, unit, bool) RPC_service.t
  end
end

module ACL : sig
  val clear : #simple -> unit -> unit tzresult Lwt.t

  module S : sig
    val clear : ([`GET], unit, unit, unit, unit, unit) RPC_service.t
  end
end
src/lib_shell_services/p2p_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter self : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.P2p_peer.Id.t).

Parameter stat : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.P2p_stat.t).

Parameter version : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Network_version.t).

Parameter versions : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_base__TzPervasives.Network_version.t)).

Parameter events : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  (o -> unit) ->
    (unit -> unit) ->
      p ->
        q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
  * (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Lwt_stream.t Tezos_base__TzPervasives.P2p_connection.Pool_event.t) *
        Tezos_base__TzPervasives.RPC_context.stopper)).

Parameter connect : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Ptime.Span.t ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Module S.
  Parameter self : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit Tezos_base__TzPervasives.P2p_peer.Id.t.
  
  Parameter stat : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit Tezos_base__TzPervasives.P2p_stat.t.
  
  Parameter version : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit Tezos_base__TzPervasives.Network_version.t.
  
  Parameter versions : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit
    (list Tezos_base__TzPervasives.Network_version.t).
  
  Parameter events : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit
    Tezos_base__TzPervasives.P2p_connection.Pool_event.t.
  
  Parameter connect : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit (unit * Tezos_base__TzPervasives.P2p_point.Id.t)
    ((Ptime.Span.t * nil)) unit unit.
End S.

Module Connections.
  Definition connection_info :=
    Tezos_base__TzPervasives.P2p_connection.Info.t
      Tezos_shell_services.Connection_metadata.t.
  
  Parameter list : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Lwt.t (Tezos_base__TzPervasives.tzresult (list connection_info)).
  
  Parameter info : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult connection_info).
  
  Parameter kick : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    (option bool) ->
      Tezos_base__TzPervasives.P2p_peer.Id.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Module S.
    Parameter list : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit unit unit unit (list connection_info).
    
    Parameter info : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
      connection_info.
    
    Parameter kick : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t)
      ((bool * nil)) unit unit.
  End S.
End Connections.

Module Points.
  Parameter list : forall {_ i o p q variant : Type}, (option
    (list Tezos_base__TzPervasives.P2p_point.Filter.t)) ->
    (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (_ * p * q * i * o)) * _) * _) ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list
            (Tezos_base__TzPervasives.P2p_point.Id.t *
              Tezos_base__TzPervasives.P2p_point.Info.t))).
  
  Parameter info : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.P2p_point.Info.t).
  
  Parameter events : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    (o -> unit) ->
      (unit -> unit) ->
        p ->
          q ->
            i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
    * (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          ((Lwt_stream.t (list Tezos_base__TzPervasives.P2p_point.Pool_event.t))
            * Tezos_base__TzPervasives.RPC_context.stopper)).
  
  Parameter ban : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter unban : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter trust : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter untrust : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter banned : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult bool).
  
  Module S.
    Parameter list : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit unit
      (((list Tezos_base__TzPervasives.P2p_point.Filter.t) * nil)) unit
      (list
        (Tezos_base__TzPervasives.P2p_point.Id.t *
          Tezos_base__TzPervasives.P2p_point.Info.t)).
    
    Parameter info : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
      Tezos_base__TzPervasives.P2p_point.Info.t.
    
    Parameter events : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_point.Id.t)
      ((bool * nil)) unit (list Tezos_base__TzPervasives.P2p_point.Pool_event.t).
    
    Parameter ban : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
      unit.
    
    Parameter unban : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
      unit.
    
    Parameter trust : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
      unit.
    
    Parameter untrust : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
      unit.
    
    Parameter banned : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
      bool.
  End S.
End Points.

Module Peers.
  Parameter list : forall {_ i o p q variant : Type}, (option
    (list Tezos_base__TzPervasives.P2p_peer.Filter.t)) ->
    (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (_ * p * q * i * o)) * _) * _) ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list
            (Tezos_base__TzPervasives.P2p_peer.Id.t *
              (Tezos_base__TzPervasives.P2p_peer.Info.t
                Tezos_shell_services.Peer_metadata.t
                Tezos_shell_services.Connection_metadata.t)))).
  
  Parameter info : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_base__TzPervasives.P2p_peer.Info.t
            Tezos_shell_services.Peer_metadata.t
            Tezos_shell_services.Connection_metadata.t)).
  
  Parameter events : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    (o -> unit) ->
      (unit -> unit) ->
        p ->
          q ->
            i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
    * (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          ((Lwt_stream.t (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t))
            * Tezos_base__TzPervasives.RPC_context.stopper)).
  
  Parameter ban : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter unban : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter trust : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter untrust : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Parameter banned : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult bool).
  
  Module S.
    Parameter list : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit unit
      (((list Tezos_base__TzPervasives.P2p_peer.Filter.t) * nil)) unit
      (list
        (Tezos_base__TzPervasives.P2p_peer.Id.t *
          (Tezos_base__TzPervasives.P2p_peer.Info.t
            Tezos_shell_services.Peer_metadata.t
            Tezos_shell_services.Connection_metadata.t))).
    
    Parameter info : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
      (Tezos_base__TzPervasives.P2p_peer.Info.t
        Tezos_shell_services.Peer_metadata.t
        Tezos_shell_services.Connection_metadata.t).
    
    Parameter events : forall {nil variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t)
      ((bool * nil)) unit (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t).
    
    Parameter ban : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
      unit.
    
    Parameter unban : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
      unit.
    
    Parameter trust : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
      unit.
    
    Parameter untrust : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
      unit.
    
    Parameter banned : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
      bool.
  End S.
End Peers.

Module ACL.
  Parameter clear : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    unit -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
  
  Module S.
    Parameter clear : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit unit unit unit unit.
  End S.
End ACL.
src/lib_shell_services/peer_metadata.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type counter = Z.t

let counter = Data_encoding.z

let (( + ) : counter -> counter -> counter) = Z.add

let zero : counter = Z.zero

let one : counter = Z.one

(* Distributed DB peer metadata *)
type messages = {
  mutable branch : counter;
  mutable head : counter;
  mutable block_header : counter;
  mutable operations : counter;
  mutable protocols : counter;
  mutable operation_hashes_for_block : counter;
  mutable operations_for_block : counter;
  mutable other : counter;
}

let sent_requests_encoding =
  let open Data_encoding in
  (conv
     (fun { branch;
            head;
            block_header;
            operations;
            protocols;
            operation_hashes_for_block;
            operations_for_block;
            other } ->
       ( branch,
         head,
         block_header,
         operations,
         protocols,
         operation_hashes_for_block,
         operations_for_block,
         other ))
     (fun ( branch,
            head,
            block_header,
            operations,
            protocols,
            operation_hashes_for_block,
            operations_for_block,
            other ) ->
       {
         branch;
         head;
         block_header;
         operations;
         protocols;
         operation_hashes_for_block;
         operations_for_block;
         other;
       }))
    (obj8
       (req "branch" counter)
       (req "head" counter)
       (req "block_header" counter)
       (req "operations" counter)
       (req "protocols" counter)
       (req "operation_hashes_for_block" counter)
       (req "operations_for_block" counter)
       (req "other" counter))

type requests_kind =
  | Branch
  | Head
  | Block_header
  | Operations
  | Protocols
  | Operation_hashes_for_block
  | Operations_for_block
  | Other

type requests = {
  sent : messages;  (** p2p sent messages of type requests *)
  received : messages;  (** p2p received messages of type requests *)
  failed : messages;
      (** p2p messages of type requests that we failed to send *)
  scheduled : messages;  (** p2p messages ent via request scheduler *)
}

let requests_encoding =
  let open Data_encoding in
  (conv
     (fun {sent; received; failed; scheduled} ->
       (sent, received, failed, scheduled))
     (fun (sent, received, failed, scheduled) ->
       {sent; received; failed; scheduled}))
    (obj4
       (req "sent" sent_requests_encoding)
       (req "received" sent_requests_encoding)
       (req "failed" sent_requests_encoding)
       (req "scheduled" sent_requests_encoding))

(* Prevalidator peer metadata *)
type prevalidator_results = {
  cannot_download : counter;
  cannot_parse : counter;
  refused_by_prefilter : counter;
  refused_by_postfilter : counter;
  (* prevalidation results *)
  applied : counter;
  branch_delayed : counter;
  branch_refused : counter;
  refused : counter;
  duplicate : counter;
  outdated : counter;
}

let prevalidator_results_encoding =
  let open Data_encoding in
  conv
    (fun { cannot_download;
           cannot_parse;
           refused_by_prefilter;
           refused_by_postfilter;
           applied;
           branch_delayed;
           branch_refused;
           refused;
           duplicate;
           outdated } ->
      ( cannot_download,
        cannot_parse,
        refused_by_prefilter,
        refused_by_postfilter,
        applied,
        branch_delayed,
        branch_refused,
        refused,
        duplicate,
        outdated ))
    (fun ( cannot_download,
           cannot_parse,
           refused_by_prefilter,
           refused_by_postfilter,
           applied,
           branch_delayed,
           branch_refused,
           refused,
           duplicate,
           outdated ) ->
      {
        cannot_download;
        cannot_parse;
        refused_by_prefilter;
        refused_by_postfilter;
        applied;
        branch_delayed;
        branch_refused;
        refused;
        duplicate;
        outdated;
      })
    (obj10
       (req "cannot_download" counter)
       (req "cannot_parse" counter)
       (req "refused_by_prefilter" counter)
       (req "refused_by_postfilter" counter)
       (req "applied" counter)
       (req "branch_delayed" counter)
       (req "branch_refused" counter)
       (req "refused" counter)
       (req "duplicate" counter)
       (req "outdated" counter))

type resource_kind = Block | Operations | Protocol

type advertisement = Head | Branch

type metadata =
  (* Distributed_db *)
  | Received_request of requests_kind
  | Sent_request of requests_kind
  | Failed_request of requests_kind
  | Scheduled_request of requests_kind
  | Received_response of requests_kind
  | Sent_response of requests_kind
  | Unexpected_response
  | Unactivated_chain
  | Inactive_chain
  | Future_block
  | Unadvertised of resource_kind
  | Sent_advertisement of advertisement
  | Received_advertisement of advertisement
  | Outdated_response (* TODO : unused *)
  (* Peer validator *)
  | Valid_blocks
  | Old_heads
  (* Prevalidation *)
  | Cannot_download
  | Cannot_parse
  | Refused_by_prefilter
  | Refused_by_postfilter
  | Applied
  | Branch_delayed
  | Branch_refused
  | Refused
  | Duplicate
  | Outdated

type responses = {
  mutable sent : messages;  (** p2p sent messages of type responses *)
  mutable failed : messages;  (** p2p sent messages of type responses *)
  mutable received : messages;  (** p2p received responses *)
  mutable unexpected : counter;
      (** p2p received responses that were unexpected *)
  mutable outdated : counter;
      (** p2p received responses that are now outdated *)
}

let responses_encoding =
  let open Data_encoding in
  (conv
     (fun {sent; failed; received; unexpected; outdated} ->
       (sent, failed, received, unexpected, outdated))
     (fun (sent, failed, received, unexpected, outdated) ->
       {sent; failed; received; unexpected; outdated}))
    (obj5
       (req "sent" sent_requests_encoding)
       (req "failed" sent_requests_encoding)
       (req "received" sent_requests_encoding)
       (req "unexpected" counter)
       (req "outdated" counter))

type unadvertised = {
  mutable block : counter;  (** requests for unadvertised block *)
  mutable operations : counter;  (** requests for unadvertised operations *)
  mutable protocol : counter;  (** requests for unadvertised protocol *)
}

let unadvertised_encoding =
  let open Data_encoding in
  (conv
     (fun {block; operations; protocol} -> (block, operations, protocol))
     (fun (block, operations, protocol) -> {block; operations; protocol}))
    (obj3
       (req "block" counter)
       (req "operations" counter)
       (req "protocol" counter))

type advertisements_kind = {mutable head : counter; mutable branch : counter}

let advertisements_kind_encoding =
  let open Data_encoding in
  (conv
     (fun {head; branch} -> (head, branch))
     (fun (head, branch) -> {head; branch}))
    (obj2 (req "head" counter) (req "branch" counter))

type advertisements = {
  mutable sent : advertisements_kind;
  mutable received : advertisements_kind;
}

let advertisements_encoding =
  let open Data_encoding in
  (conv
     (fun {sent; received} -> (sent, received))
     (fun (sent, received) -> {sent; received}))
    (obj2
       (req "sent" advertisements_kind_encoding)
       (req "received" advertisements_kind_encoding))

type t = {
  mutable responses : responses;  (** responses sent/received *)
  mutable requests : requests;  (** requests sent/received  *)
  mutable valid_blocks : counter;  (** new valid blocks advertized by a peer *)
  mutable old_heads : counter;  (** previously validated blocks from a peer *)
  mutable prevalidator_results : prevalidator_results;
      (** prevalidator metadata *)
  mutable unactivated_chains : counter;
      (** requests from unactivated chains *)
  mutable inactive_chains : counter;  (** advertise inactive chains *)
  mutable future_blocks_advertised : counter;  (** future blocks *)
  mutable unadvertised : unadvertised;
      (** requests for unadvertised resources *)
  mutable advertisements : advertisements;  (** advertisements sent *)
}

let empty () =
  let empty_request () =
    {
      branch = zero;
      head = zero;
      block_header = zero;
      operations = zero;
      protocols = zero;
      operation_hashes_for_block = zero;
      operations_for_block = zero;
      other = zero;
    }
  in
  {
    responses =
      {
        sent = empty_request ();
        failed = empty_request ();
        received = empty_request ();
        unexpected = zero;
        outdated = zero;
      };
    requests =
      {
        sent = empty_request ();
        failed = empty_request ();
        scheduled = empty_request ();
        received = empty_request ();
      };
    valid_blocks = zero;
    old_heads = zero;
    prevalidator_results =
      {
        cannot_download = zero;
        cannot_parse = zero;
        refused_by_prefilter = zero;
        refused_by_postfilter = zero;
        applied = zero;
        branch_delayed = zero;
        branch_refused = zero;
        refused = zero;
        duplicate = zero;
        outdated = zero;
      };
    unactivated_chains = zero;
    inactive_chains = zero;
    future_blocks_advertised = zero;
    unadvertised = {block = zero; operations = zero; protocol = zero};
    advertisements =
      {
        sent = {head = zero; branch = zero};
        received = {head = zero; branch = zero};
      };
  }

let encoding =
  let open Data_encoding in
  (conv
     (fun { responses;
            requests;
            valid_blocks;
            old_heads;
            prevalidator_results;
            unactivated_chains;
            inactive_chains;
            future_blocks_advertised;
            unadvertised;
            advertisements } ->
       ( ( responses,
           requests,
           valid_blocks,
           old_heads,
           prevalidator_results,
           unactivated_chains,
           inactive_chains,
           future_blocks_advertised ),
         (unadvertised, advertisements) ))
     (fun ( ( responses,
              requests,
              valid_blocks,
              old_heads,
              prevalidator_results,
              unactivated_chains,
              inactive_chains,
              future_blocks_advertised ),
            (unadvertised, advertisements) ) ->
       {
         responses;
         requests;
         valid_blocks;
         old_heads;
         prevalidator_results;
         unactivated_chains;
         inactive_chains;
         future_blocks_advertised;
         unadvertised;
         advertisements;
       }))
    (merge_objs
       (obj8
          (req "responses" responses_encoding)
          (req "requests" requests_encoding)
          (req "valid_blocks" counter)
          (req "old_heads" counter)
          (req "prevalidator_results" prevalidator_results_encoding)
          (req "unactivated_chains" counter)
          (req "inactive_chains" counter)
          (req "future_blocks_advertised" counter))
       (obj2
          (req "unadvertised" unadvertised_encoding)
          (req "advertisements" advertisements_encoding)))

let incr_requests (msgs : messages) (req : requests_kind) =
  match req with
  | Branch ->
      msgs.branch <- msgs.branch + one
  | Head ->
      msgs.head <- msgs.head + one
  | Block_header ->
      msgs.block_header <- msgs.block_header + one
  | Operations ->
      msgs.operations <- msgs.operations + one
  | Protocols ->
      msgs.protocols <- msgs.protocols + one
  | Operation_hashes_for_block ->
      msgs.operation_hashes_for_block <- msgs.operation_hashes_for_block + one
  | Operations_for_block ->
      msgs.operations_for_block <- msgs.operations_for_block + one
  | Other ->
      msgs.other <- msgs.other + one

let incr_unadvertised {unadvertised = u; _} = function
  | Block ->
      u.block <- u.block + one
  | Operations ->
      u.operations <- u.operations + one
  | Protocol ->
      u.protocol <- u.protocol + one

let incr ({responses = rsps; requests = rqst; _} as m) metadata =
  match metadata with
  (* requests *)
  | Received_request req ->
      incr_requests rqst.received req
  | Sent_request req ->
      incr_requests rqst.sent req
  | Scheduled_request req ->
      incr_requests rqst.scheduled req
  | Failed_request req ->
      incr_requests rqst.failed req
  (* responses *)
  | Received_response req ->
      incr_requests rsps.received req
  | Sent_response req ->
      incr_requests rsps.sent req
  | Unexpected_response ->
      rsps.unexpected <- rsps.unexpected + one
  | Outdated_response ->
      rsps.outdated <- rsps.outdated + one
  (* Advertisements *)
  | Sent_advertisement ad -> (
    match ad with
    | Head ->
        m.advertisements.sent.head <- m.advertisements.sent.head + one
    | Branch ->
        m.advertisements.sent.branch <- m.advertisements.sent.branch + one )
  | Received_advertisement ad -> (
    match ad with
    | Head ->
        m.advertisements.received.head <- m.advertisements.received.head + one
    | Branch ->
        m.advertisements.received.branch <-
          m.advertisements.received.branch + one )
  (* Unexpected erroneous msg *)
  | Unactivated_chain ->
      m.unactivated_chains <- m.unactivated_chains + one
  | Inactive_chain ->
      m.inactive_chains <- m.inactive_chains + one
  | Future_block ->
      m.future_blocks_advertised <- m.future_blocks_advertised + one
  | Unadvertised u ->
      incr_unadvertised m u
  (* Peer validator *)
  | Valid_blocks ->
      m.valid_blocks <- m.valid_blocks + one
  | Old_heads ->
      m.old_heads <- m.old_heads + one
  (* prevalidation *)
  | Cannot_download ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          cannot_download = m.prevalidator_results.cannot_download + one;
        }
  | Cannot_parse ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          cannot_parse = m.prevalidator_results.cannot_parse + one;
        }
  | Refused_by_prefilter ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          refused_by_prefilter =
            m.prevalidator_results.refused_by_prefilter + one;
        }
  | Refused_by_postfilter ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          refused_by_postfilter =
            m.prevalidator_results.refused_by_postfilter + one;
        }
  | Applied ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          applied = m.prevalidator_results.applied + one;
        }
  | Branch_delayed ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          branch_delayed = m.prevalidator_results.branch_delayed + one;
        }
  | Branch_refused ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          branch_refused = m.prevalidator_results.branch_refused + one;
        }
  | Refused ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          refused = m.prevalidator_results.refused + one;
        }
  | Duplicate ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          duplicate = m.prevalidator_results.duplicate + one;
        }
  | Outdated ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          outdated = m.prevalidator_results.outdated + one;
        }

(* shortcuts to update sent/failed requests/responses *)
let update_requests {requests = {sent; failed; _}; _} kind = function
  | true ->
      incr_requests sent kind
  | false ->
      incr_requests failed kind

let update_responses {responses = {sent; failed; _}; _} kind = function
  | true ->
      incr_requests sent kind
  | false ->
      incr_requests failed kind

(* Scores computation *)
(* TODO:
   - scores cannot be kept as integers (use big numbers?)
   - they scores should probably be reset frequently (at each block/cycle?)
   - we might still need to keep some kind of score history
       - store only best/worst/last_value/mean/variance... ?
   - do we need to keep "good" scores ?
        - maybe "bad" scores are enough to reduce resources
          allocated to misbehaving peers *)
let distributed_db_score _ =
  (* TODO *)
  1.0

let prevalidation_score {prevalidator_results = _; _} =
  (* TODO *)
  1.0

let score _ =
  (* TODO *)
  1.0
src/lib_shell_services/peer_metadata.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition counter := Z.t.

Definition counter : Tezos_base__TzPervasives.Data_encoding.encoding Z.t :=
  Tezos_base__TzPervasives.Data_encoding.z.

Definition zero : counter := Z.zero.

Definition one : counter := Z.one.

Record messages := {
  branch : counter;
  head : counter;
  block_header : counter;
  operations : counter;
  protocols : counter;
  operation_hashes_for_block : counter;
  operations_for_block : counter;
  other : counter }.

Definition sent_requests_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding messages :=
  (Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        branch := branch;
          head := head;
          block_header := block_header;
          operations := operations;
          protocols := protocols;
          operation_hashes_for_block := operation_hashes_for_block;
          operations_for_block := operations_for_block;
          other := other
          |} =>
        (branch, head, block_header, operations, protocols,
          operation_hashes_for_block, operations_for_block, other)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        (branch, head, block_header, operations, protocols,
          operation_hashes_for_block, operations_for_block, other) =>
        {| branch := branch; head := head; block_header := block_header;
          operations := operations; protocols := protocols;
          operation_hashes_for_block := operation_hashes_for_block;
          operations_for_block := operations_for_block; other := other |}
      end)) None
    (Tezos_base__TzPervasives.Data_encoding.obj8
      (Tezos_base__TzPervasives.Data_encoding.req None None "branch" % string
        counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "head" % string
        counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "block_header" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "operations" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "protocols" % string
        counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "operation_hashes_for_block" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "operations_for_block" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "other" % string
        counter)).

Inductive requests_kind : Type :=
| Branch : requests_kind
| Head : requests_kind
| Block_header : requests_kind
| Operations : requests_kind
| Protocols : requests_kind
| Operation_hashes_for_block : requests_kind
| Operations_for_block : requests_kind
| Other : requests_kind.

Record requests := {
  sent : messages;
  received : messages;
  failed : messages;
  scheduled : messages }.

Definition requests_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding requests :=
  (Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        sent := sent;
          received := received;
          failed := failed;
          scheduled := scheduled
          |} => (sent, received, failed, scheduled)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (sent, received, failed, scheduled) =>
        {| sent := sent; received := received; failed := failed;
          scheduled := scheduled |}
      end)) None
    (Tezos_base__TzPervasives.Data_encoding.obj4
      (Tezos_base__TzPervasives.Data_encoding.req None None "sent" % string
        sent_requests_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "received" % string
        sent_requests_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "failed" % string
        sent_requests_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "scheduled" % string
        sent_requests_encoding)).

Record prevalidator_results := {
  cannot_download : counter;
  cannot_parse : counter;
  refused_by_prefilter : counter;
  refused_by_postfilter : counter;
  applied : counter;
  branch_delayed : counter;
  branch_refused : counter;
  refused : counter;
  duplicate : counter;
  outdated : counter }.

Definition prevalidator_results_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding prevalidator_results :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        cannot_download := cannot_download;
          cannot_parse := cannot_parse;
          refused_by_prefilter := refused_by_prefilter;
          refused_by_postfilter := refused_by_postfilter;
          applied := applied;
          branch_delayed := branch_delayed;
          branch_refused := branch_refused;
          refused := refused;
          duplicate := duplicate;
          outdated := outdated
          |} =>
        (cannot_download, cannot_parse, refused_by_prefilter,
          refused_by_postfilter, applied, branch_delayed, branch_refused,
          refused, duplicate, outdated)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        (cannot_download, cannot_parse, refused_by_prefilter,
          refused_by_postfilter, applied, branch_delayed, branch_refused,
          refused, duplicate, outdated) =>
        {| cannot_download := cannot_download; cannot_parse := cannot_parse;
          refused_by_prefilter := refused_by_prefilter;
          refused_by_postfilter := refused_by_postfilter; applied := applied;
          branch_delayed := branch_delayed; branch_refused := branch_refused;
          refused := refused; duplicate := duplicate; outdated := outdated |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj10
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "cannot_download" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "cannot_parse" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "refused_by_prefilter" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "refused_by_postfilter" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "applied" % string
        counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "branch_delayed" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "branch_refused" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "refused" % string
        counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "duplicate" % string
        counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "outdated" % string
        counter)).

Inductive resource_kind : Type :=
| Block : resource_kind
| Operations : resource_kind
| Protocol : resource_kind.

Inductive advertisement : Type :=
| Head : advertisement
| Branch : advertisement.

Inductive metadata : Type :=
| Received_request : requests_kind -> metadata
| Sent_request : requests_kind -> metadata
| Failed_request : requests_kind -> metadata
| Scheduled_request : requests_kind -> metadata
| Received_response : requests_kind -> metadata
| Sent_response : requests_kind -> metadata
| Unexpected_response : metadata
| Unactivated_chain : metadata
| Inactive_chain : metadata
| Future_block : metadata
| Unadvertised : resource_kind -> metadata
| Sent_advertisement : advertisement -> metadata
| Received_advertisement : advertisement -> metadata
| Outdated_response : metadata
| Valid_blocks : metadata
| Old_heads : metadata
| Cannot_download : metadata
| Cannot_parse : metadata
| Refused_by_prefilter : metadata
| Refused_by_postfilter : metadata
| Applied : metadata
| Branch_delayed : metadata
| Branch_refused : metadata
| Refused : metadata
| Duplicate : metadata
| Outdated : metadata.

Record responses := {
  sent : messages;
  failed : messages;
  received : messages;
  unexpected : counter;
  outdated : counter }.

Definition responses_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding responses :=
  (Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        sent := sent;
          failed := failed;
          received := received;
          unexpected := unexpected;
          outdated := outdated
          |} => (sent, failed, received, unexpected, outdated)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (sent, failed, received, unexpected, outdated) =>
        {| sent := sent; failed := failed; received := received;
          unexpected := unexpected; outdated := outdated |}
      end)) None
    (Tezos_base__TzPervasives.Data_encoding.obj5
      (Tezos_base__TzPervasives.Data_encoding.req None None "sent" % string
        sent_requests_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "failed" % string
        sent_requests_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "received" % string
        sent_requests_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "unexpected" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "outdated" % string
        counter)).

Record unadvertised := {
  block : counter;
  operations : counter;
  protocol : counter }.

Definition unadvertised_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding unadvertised :=
  (Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| block := block; operations := operations; protocol := protocol |} =>
        (block, operations, protocol)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (block, operations, protocol) =>
        {| block := block; operations := operations; protocol := protocol |}
      end)) None
    (Tezos_base__TzPervasives.Data_encoding.obj3
      (Tezos_base__TzPervasives.Data_encoding.req None None "block" % string
        counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "operations" % string counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "protocol" % string
        counter)).

Record advertisements_kind := {
  head : counter;
  branch : counter }.

Definition advertisements_kind_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding advertisements_kind :=
  (Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| head := head; branch := branch |} => (head, branch)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (head, branch) => {| head := head; branch := branch |}
      end)) None
    (Tezos_base__TzPervasives.Data_encoding.obj2
      (Tezos_base__TzPervasives.Data_encoding.req None None "head" % string
        counter)
      (Tezos_base__TzPervasives.Data_encoding.req None None "branch" % string
        counter)).

Record advertisements := {
  sent : advertisements_kind;
  received : advertisements_kind }.

Definition advertisements_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding advertisements :=
  (Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| sent := sent; received := received |} => (sent, received)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (sent, received) => {| sent := sent; received := received |}
      end)) None
    (Tezos_base__TzPervasives.Data_encoding.obj2
      (Tezos_base__TzPervasives.Data_encoding.req None None "sent" % string
        advertisements_kind_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "received" % string
        advertisements_kind_encoding)).

Record t := {
  responses : responses;
  requests : requests;
  valid_blocks : counter;
  old_heads : counter;
  prevalidator_results : prevalidator_results;
  unactivated_chains : counter;
  inactive_chains : counter;
  future_blocks_advertised : counter;
  unadvertised : unadvertised;
  advertisements : advertisements }.

Definition empty (function_parameter : unit) : t :=
  match function_parameter with
  | tt =>
    let empty_request (function_parameter : unit) : messages :=
      match function_parameter with
      | tt =>
        {| branch := zero; head := zero; block_header := zero;
          operations := zero; protocols := zero;
          operation_hashes_for_block := zero; operations_for_block := zero;
          other := zero |}
      end in
    {|
      responses :=
        {| sent := empty_request tt; failed := empty_request tt;
          received := empty_request tt; unexpected := zero; outdated := zero |};
      requests :=
        {| sent := empty_request tt; received := empty_request tt;
          failed := empty_request tt; scheduled := empty_request tt |};
      valid_blocks := zero; old_heads := zero;
      prevalidator_results :=
        {| cannot_download := zero; cannot_parse := zero;
          refused_by_prefilter := zero; refused_by_postfilter := zero;
          applied := zero; branch_delayed := zero; branch_refused := zero;
          refused := zero; duplicate := zero; outdated := zero |};
      unactivated_chains := zero; inactive_chains := zero;
      future_blocks_advertised := zero;
      unadvertised := {| block := zero; operations := zero; protocol := zero |};
      advertisements :=
        {| sent := {| head := zero; branch := zero |};
          received := {| head := zero; branch := zero |} |} |}
  end.

Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
  (Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        responses := responses;
          requests := requests;
          valid_blocks := valid_blocks;
          old_heads := old_heads;
          prevalidator_results := prevalidator_results;
          unactivated_chains := unactivated_chains;
          inactive_chains := inactive_chains;
          future_blocks_advertised := future_blocks_advertised;
          unadvertised := unadvertised;
          advertisements := advertisements
          |} =>
        ((responses, requests, valid_blocks, old_heads, prevalidator_results,
          unactivated_chains, inactive_chains, future_blocks_advertised),
          (unadvertised, advertisements))
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        ((responses, requests, valid_blocks, old_heads, prevalidator_results,
          unactivated_chains, inactive_chains, future_blocks_advertised),
          (unadvertised, advertisements)) =>
        {| responses := responses; requests := requests;
          valid_blocks := valid_blocks; old_heads := old_heads;
          prevalidator_results := prevalidator_results;
          unactivated_chains := unactivated_chains;
          inactive_chains := inactive_chains;
          future_blocks_advertised := future_blocks_advertised;
          unadvertised := unadvertised; advertisements := advertisements |}
      end)) None
    (Tezos_base__TzPervasives.Data_encoding.merge_objs
      (Tezos_base__TzPervasives.Data_encoding.obj8
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "responses" % string responses_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "requests" % string requests_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "valid_blocks" % string counter)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "old_heads" % string counter)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "prevalidator_results" % string prevalidator_results_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "unactivated_chains" % string counter)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "inactive_chains" % string counter)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "future_blocks_advertised" % string counter))
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "unadvertised" % string unadvertised_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "advertisements" % string advertisements_encoding))).

Definition incr_requests (msgs : messages) (req : requests_kind) : unit :=
  match req with
  | Branch => set_field
  | Head => set_field
  | Block_header => set_field
  | Operations => set_field
  | Protocols => set_field
  | Operation_hashes_for_block => set_field
  | Operations_for_block => set_field
  | Other => set_field
  end.

Definition incr_unadvertised (function_parameter : t) : resource_kind -> unit :=
  match function_parameter with
  | {| unadvertised := u |} =>
    fun function_parameter =>
      match function_parameter with
      | Block => set_field
      | Operations => set_field
      | Protocol => set_field
      end
  end.

Definition incr (function_parameter : t) : metadata -> unit :=
  match function_parameter with
  | {| responses := rsps; requests := rqst |} as m =>
    fun metadata =>
      match metadata with
      | Received_request req => incr_requests (received rqst) req
      | Sent_request req => incr_requests (sent rqst) req
      | Scheduled_request req => incr_requests (scheduled rqst) req
      | Failed_request req => incr_requests (failed rqst) req
      | Received_response req => incr_requests (received rsps) req
      | Sent_response req => incr_requests (sent rsps) req
      | Unexpected_response => set_field
      | Outdated_response => set_field
      | Sent_advertisement ad =>
        match ad with
        | Head => set_field
        | Branch => set_field
        end
      | Received_advertisement ad =>
        match ad with
        | Head => set_field
        | Branch => set_field
        end
      | Unactivated_chain => set_field
      | Inactive_chain => set_field
      | Future_block => set_field
      | Unadvertised u => incr_unadvertised m u
      | Valid_blocks => set_field
      | Old_heads => set_field
      | Cannot_download => set_field
      | Cannot_parse => set_field
      | Refused_by_prefilter => set_field
      | Refused_by_postfilter => set_field
      | Applied => set_field
      | Branch_delayed => set_field
      | Branch_refused => set_field
      | Refused => set_field
      | Duplicate => set_field
      | Outdated => set_field
      end
  end.

Definition update_requests (function_parameter : t)
  : requests_kind -> bool -> unit :=
  match function_parameter with
  | {| requests := {| sent := sent; failed := failed |} |} =>
    fun kind =>
      fun function_parameter =>
        match function_parameter with
        | true => incr_requests sent kind
        | false => incr_requests failed kind
        end
  end.

Definition update_responses (function_parameter : t)
  : requests_kind -> bool -> unit :=
  match function_parameter with
  | {| responses := {| sent := sent; failed := failed |} |} =>
    fun kind =>
      fun function_parameter =>
        match function_parameter with
        | true => incr_requests sent kind
        | false => incr_requests failed kind
        end
  end.

Definition distributed_db_score {A : Type} (function_parameter : A) : float :=
  match function_parameter with
  | _ => 1
  end.

Definition prevalidation_score (function_parameter : t) : float :=
  match function_parameter with
  | {| prevalidator_results := _ |} => 1
  end.

Definition score {A : Type} (function_parameter : A) : float :=
  match function_parameter with
  | _ => 1
  end.
src/lib_shell_services/peer_metadata.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** All the (persistent) metadata associated to a peer. *)

type t

val encoding : t Data_encoding.t

val empty : unit -> t

(** the aggregate score function computed from
    the metadata collected for a peer *)
val distributed_db_score : t -> float

val prevalidation_score : t -> float

val score : t -> float

type requests_kind =
  | Branch
  | Head
  | Block_header
  | Operations
  | Protocols
  | Operation_hashes_for_block
  | Operations_for_block
  | Other

type resource_kind = Block | Operations | Protocol

type advertisement = Head | Branch

type metadata =
  (* Distributed_db *)
  | Received_request of requests_kind
  | Sent_request of requests_kind
  | Failed_request of requests_kind
  | Scheduled_request of requests_kind
  | Received_response of requests_kind
  | Sent_response of requests_kind
  | Unexpected_response
  | Unactivated_chain
  | Inactive_chain
  | Future_block
  | Unadvertised of resource_kind
  | Sent_advertisement of advertisement
  | Received_advertisement of advertisement
  | Outdated_response (* TODO : unused *)
  (* Peer validator *)
  | Valid_blocks
  | Old_heads
  (* Prevalidation *)
  | Cannot_download
  | Cannot_parse
  | Refused_by_prefilter
  | Refused_by_postfilter
  | Applied
  | Branch_delayed
  | Branch_refused
  | Refused
  | Duplicate
  | Outdated

(** incr score counters . Used to compute the final score for a peer *)
val incr : t -> metadata -> unit

val update_requests : t -> requests_kind -> bool -> unit

val update_responses : t -> requests_kind -> bool -> unit
src/lib_shell_services/peer_metadata.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.

Parameter empty : unit -> t.

Parameter distributed_db_score : t -> float.

Parameter prevalidation_score : t -> float.

Parameter score : t -> float.

Inductive requests_kind : Type :=
| Branch : requests_kind
| Head : requests_kind
| Block_header : requests_kind
| Operations : requests_kind
| Protocols : requests_kind
| Operation_hashes_for_block : requests_kind
| Operations_for_block : requests_kind
| Other : requests_kind.

Inductive resource_kind : Type :=
| Block : resource_kind
| Operations : resource_kind
| Protocol : resource_kind.

Inductive advertisement : Type :=
| Head : advertisement
| Branch : advertisement.

Inductive metadata : Type :=
| Received_request : requests_kind -> metadata
| Sent_request : requests_kind -> metadata
| Failed_request : requests_kind -> metadata
| Scheduled_request : requests_kind -> metadata
| Received_response : requests_kind -> metadata
| Sent_response : requests_kind -> metadata
| Unexpected_response : metadata
| Unactivated_chain : metadata
| Inactive_chain : metadata
| Future_block : metadata
| Unadvertised : resource_kind -> metadata
| Sent_advertisement : advertisement -> metadata
| Received_advertisement : advertisement -> metadata
| Outdated_response : metadata
| Valid_blocks : metadata
| Old_heads : metadata
| Cannot_download : metadata
| Cannot_parse : metadata
| Refused_by_prefilter : metadata
| Refused_by_postfilter : metadata
| Applied : metadata
| Branch_delayed : metadata
| Branch_refused : metadata
| Refused : metadata
| Duplicate : metadata
| Outdated : metadata.

Parameter incr : t -> metadata -> unit.

Parameter update_requests : t -> requests_kind -> bool -> unit.

Parameter update_responses : t -> requests_kind -> bool -> unit.
src/lib_shell_services/peer_validator_worker_state.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request = struct
  type view = New_head of Block_hash.t | New_branch of Block_hash.t * int

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"New_head"
          (obj2
             (req "request" (constant "new_head"))
             (req "block" Block_hash.encoding))
          (function New_head h -> Some ((), h) | _ -> None)
          (fun ((), h) -> New_head h);
        case
          (Tag 1)
          ~title:"New_branch"
          (obj3
             (req "request" (constant "new_branch"))
             (req "block" Block_hash.encoding)
             (req "locators" int31))
          (function New_branch (h, l) -> Some ((), h, l) | _ -> None)
          (fun ((), h, l) -> New_branch (h, l)) ]

  let pp ppf = function
    | New_head hash ->
        Format.fprintf ppf "New head %a" Block_hash.pp hash
    | New_branch (hash, len) ->
        Format.fprintf
          ppf
          "New branch %a, locator length %d"
          Block_hash.pp
          hash
          len
end

module Event = struct
  type t =
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Debug of string

  let level req =
    match req with
    | Debug _ ->
        Internal_event.Debug
    | Request _ ->
        Internal_event.Info

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Debug"
          (obj1 (req "message" string))
          (function Debug msg -> Some msg | _ -> None)
          (fun msg -> Debug msg);
        case
          (Tag 1)
          ~title:"Request"
          (obj2
             (req "request" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function Request (req, t, None) -> Some (req, t) | _ -> None)
          (fun (req, t) -> Request (req, t, None));
        case
          (Tag 2)
          ~title:"Failed request"
          (obj3
             (req "error" RPC_error.encoding)
             (req "failed_request" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function
            | Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
          (fun (errs, req, t) -> Request (req, t, Some errs)) ]

  let pp ppf = function
    | Debug msg ->
        Format.fprintf ppf "%s" msg
    | Request (view, {pushed; treated; completed}, None) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
    | Request (view, {pushed; treated; completed}, Some errors) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
          (Format.pp_print_list Error_monad.pp)
          errors
end

module Worker_state = struct
  type pipeline_length = {
    fetched_header_length : int;
    fetched_block_length : int;
  }

  let pipeline_length_encoding =
    let open Data_encoding in
    conv
      (function
        | {fetched_header_length; fetched_block_length} ->
            (fetched_header_length, fetched_block_length))
      (function
        | (fetched_header_length, fetched_block_length) ->
            {fetched_header_length; fetched_block_length})
      (obj2 (req "fetched_headers" int31) (req "fetched_blocks" int31))

  type view = {
    bootstrapped : bool;
    pipeline_length : pipeline_length;
    mutable last_validated_head : Block_hash.t;
    mutable last_advertised_head : Block_hash.t;
  }

  let encoding =
    let open Data_encoding in
    conv
      (function
        | { bootstrapped;
            pipeline_length;
            last_validated_head;
            last_advertised_head } ->
            ( bootstrapped,
              pipeline_length,
              last_validated_head,
              last_advertised_head ))
      (function
        | ( bootstrapped,
            pipeline_length,
            last_validated_head,
            last_advertised_head ) ->
            {
              bootstrapped;
              pipeline_length;
              last_validated_head;
              last_advertised_head;
            })
      (obj4
         (req "bootstrapped" bool)
         (req "pipelines" pipeline_length_encoding)
         (req "last_validated_head" Block_hash.encoding)
         (req "last_advertised_head" Block_hash.encoding))

  let pp ppf state =
    Format.fprintf
      ppf
      "@[<v 0>Bootstrapped: %s@,\
       Pipeline_length: %d - %d @,\
       Last validated head: %a@,\
       Last advertised head: %a@]"
      (if state.bootstrapped then "yes" else "no")
      state.pipeline_length.fetched_header_length
      state.pipeline_length.fetched_block_length
      Block_hash.pp
      state.last_validated_head
      Block_hash.pp
      state.last_advertised_head
end
src/lib_shell_services/peer_validator_worker_state.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Inductive view : Type :=
  | New_head : Tezos_base__TzPervasives.Block_hash.t -> view
  | New_branch : Tezos_base__TzPervasives.Block_hash.t -> Z -> view.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    Tezos_base__TzPervasives.Data_encoding.union None
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "New_head" % string None
          (Tag 0)
          (Tezos_base__TzPervasives.Data_encoding.obj2
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "request" % string
              (Tezos_base__TzPervasives.Data_encoding.constant
                "new_head" % string))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "block" % string Tezos_base__TzPervasives.Block_hash.encoding))
          (fun function_parameter =>
            match function_parameter with
            | New_head h => Some (tt, h)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (tt, h) => New_head h
            end))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "New_branch" % string
            None (Tag 1)
            (Tezos_base__TzPervasives.Data_encoding.obj3
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "request" % string
                (Tezos_base__TzPervasives.Data_encoding.constant
                  "new_branch" % string))
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "block" % string Tezos_base__TzPervasives.Block_hash.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "locators" % string Tezos_base__TzPervasives.Data_encoding.int31))
            (fun function_parameter =>
              match function_parameter with
              | New_branch h l => Some (tt, h, l)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tt, h, l) => New_branch h l
              end)) [])).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
    : unit :=
    match function_parameter with
    | New_head hash =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "New head " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "New head %a" % string)
        Tezos_base__TzPervasives.Block_hash.pp hash
    | New_branch hash len =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "New branch " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                ", locator length " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))))
          "New branch %a, locator length %d" % string)
        Tezos_base__TzPervasives.Block_hash.pp hash len
    end.
End Request.

Module Event.
  Inductive t : Type :=
  | Request :
    (Request.view * Tezos_shell_services.Worker_types.request_status *
      (option (list Tezos_base__TzPervasives.error))) -> t
  | Debug : string -> t.
  
  Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
    match req with
    | Debug _ => Internal_event.Debug
    | Request _ => Internal_event.Info
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    Tezos_base__TzPervasives.Data_encoding.union None
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Debug" % string None
          (Tag 0)
          (Tezos_base__TzPervasives.Data_encoding.obj1
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "message" % string Tezos_base__TzPervasives.Data_encoding.string))
          (fun function_parameter =>
            match function_parameter with
            | Debug msg => Some msg
            | _ => None
            end) (fun msg => Debug msg))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Request" % string None
            (Tag 1)
            (Tezos_base__TzPervasives.Data_encoding.obj2
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "request" % string Request.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "status" % string
                Tezos_shell_services.Worker_types.request_status_encoding))
            (fun function_parameter =>
              match function_parameter with
              | Request (req, t, None) => Some (req, t)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (req, t) => Request (req, t, None)
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case
              "Failed request" % string None (Tag 2)
              (Tezos_base__TzPervasives.Data_encoding.obj3
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "error" % string Tezos_base__TzPervasives.RPC_error.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "failed_request" % string Request.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "status" % string
                  Tezos_shell_services.Worker_types.request_status_encoding))
              (fun function_parameter =>
                match function_parameter with
                | Request (req, t, Some errs) => Some (errs, req, t)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (errs, req, t) => Request (req, t, (Some errs))
                end)) []))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Debug msg =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) msg
    |
      Request
        (view, {|
          pushed := pushed; treated := treated; completed := completed |},
          None) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format))))))
          "@[<v 0>%a@, %a@]" % string) Request.pp view
        Tezos_shell_services.Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
    |
      Request
        (view, {|
          pushed := pushed; treated := treated; completed := completed |},
          Some errors) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ", " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))))
          "@[<v 0>%a@, %a, %a@]" % string) Request.pp view
        Tezos_shell_services.Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
        (Stdlib.Format.pp_print_list None
          Tezos_base__TzPervasives.Error_monad.pp) errors
    end.
End Event.

Module Worker_state.
  Record pipeline_length := {
    fetched_header_length : Z;
    fetched_block_length : Z }.
  
  Definition pipeline_length_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding pipeline_length :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          fetched_header_length := fetched_header_length;
            fetched_block_length := fetched_block_length
            |} => (fetched_header_length, fetched_block_length)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (fetched_header_length, fetched_block_length) =>
          {| fetched_header_length := fetched_header_length;
            fetched_block_length := fetched_block_length |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "fetched_headers" % string
          Tezos_base__TzPervasives.Data_encoding.int31)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "fetched_blocks" % string Tezos_base__TzPervasives.Data_encoding.int31)).
  
  Record view := {
    bootstrapped : bool;
    pipeline_length : pipeline_length;
    last_validated_head : Tezos_base__TzPervasives.Block_hash.t;
    last_advertised_head : Tezos_base__TzPervasives.Block_hash.t }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          bootstrapped := bootstrapped;
            pipeline_length := pipeline_length;
            last_validated_head := last_validated_head;
            last_advertised_head := last_advertised_head
            |} =>
          (bootstrapped, pipeline_length, last_validated_head,
            last_advertised_head)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (bootstrapped, pipeline_length, last_validated_head,
            last_advertised_head) =>
          {| bootstrapped := bootstrapped; pipeline_length := pipeline_length;
            last_validated_head := last_validated_head;
            last_advertised_head := last_advertised_head |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj4
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "bootstrapped" % string Tezos_base__TzPervasives.Data_encoding.bool)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "pipelines" % string pipeline_length_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "last_validated_head" % string
          Tezos_base__TzPervasives.Block_hash.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "last_advertised_head" % string
          Tezos_base__TzPervasives.Block_hash.encoding)).
  
  Definition pp (ppf : Stdlib.Format.formatter) (state : view) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.String_literal "Bootstrapped: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Pipeline_length: " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal " - " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal " " % char
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "Last validated head: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "Last advertised head: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))))
        "@[<v 0>Bootstrapped: %s@,Pipeline_length: %d - %d @,Last validated head: %a@,Last advertised head: %a@]"
          % string)
      (if bootstrapped state then
        "yes" % string
      else
        "no" % string) (fetched_header_length (pipeline_length state))
      (fetched_block_length (pipeline_length state))
      Tezos_base__TzPervasives.Block_hash.pp (last_validated_head state)
      Tezos_base__TzPervasives.Block_hash.pp (last_advertised_head state).
End Worker_state.
src/lib_shell_services/peer_validator_worker_state.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request : sig
  type view = New_head of Block_hash.t | New_branch of Block_hash.t * int

  val encoding : view Data_encoding.encoding

  val pp : Format.formatter -> view -> unit
end

module Event : sig
  type t =
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Debug of string

  val level : t -> Internal_event.level

  val encoding : t Data_encoding.encoding

  val pp : Format.formatter -> t -> unit
end

module Worker_state : sig
  type pipeline_length = {
    fetched_header_length : int;
    fetched_block_length : int;
  }

  val pipeline_length_encoding : pipeline_length Data_encoding.encoding

  type view = {
    bootstrapped : bool;
    pipeline_length : pipeline_length;
    mutable last_validated_head : Block_hash.t;
    mutable last_advertised_head : Block_hash.t;
  }

  val encoding : view Data_encoding.encoding

  val pp : Format.formatter -> view -> unit
end
src/lib_shell_services/peer_validator_worker_state.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Inductive view : Type :=
  | New_head : Tezos_base__TzPervasives.Block_hash.t -> view
  | New_branch : Tezos_base__TzPervasives.Block_hash.t -> Z -> view.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding view.
  
  Parameter pp : Stdlib.Format.formatter -> view -> unit.
End Request.

Module Event.
  Inductive t : Type :=
  | Request :
    (Request.view * Tezos_shell_services.Worker_types.request_status *
      (option (list Tezos_base__TzPervasives.error))) -> t
  | Debug : string -> t.
  
  Parameter level : t -> Tezos_base__TzPervasives.Internal_event.level.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding t.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
End Event.

Module Worker_state.
  Record pipeline_length := {
    fetched_header_length : Z;
    fetched_block_length : Z }.
  
  Parameter pipeline_length_encoding : Tezos_base__TzPervasives.Data_encoding.encoding
    pipeline_length.
  
  Record view := {
    bootstrapped : bool;
    pipeline_length : pipeline_length;
    last_validated_head : Tezos_base__TzPervasives.Block_hash.t;
    last_advertised_head : Tezos_base__TzPervasives.Block_hash.t }.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.encoding view.
  
  Parameter pp : Stdlib.Format.formatter -> view -> unit.
End Worker_state.
src/lib_shell_services/prevalidator_worker_state.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request = struct
  type 'a t =
    | Flush : Block_hash.t -> unit t
    | Notify : P2p_peer.Id.t * Mempool.t -> unit t
    | Leftover : unit t
    | Inject : Operation.t -> unit t
    | Arrived : Operation_hash.t * Operation.t -> unit t
    | Advertise : unit t

  type view = View : _ t -> view

  let view req = View req

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Flush"
          (obj2
             (req "request" (constant "flush"))
             (req "block" Block_hash.encoding))
          (function View (Flush hash) -> Some ((), hash) | _ -> None)
          (fun ((), hash) -> View (Flush hash));
        case
          (Tag 1)
          ~title:"Notify"
          (obj3
             (req "request" (constant "notify"))
             (req "peer" P2p_peer.Id.encoding)
             (req "mempool" Mempool.encoding))
          (function
            | View (Notify (peer, mempool)) ->
                Some ((), peer, mempool)
            | _ ->
                None)
          (fun ((), peer, mempool) -> View (Notify (peer, mempool)));
        case
          (Tag 2)
          ~title:"Inject"
          (obj2
             (req "request" (constant "inject"))
             (req "operation" Operation.encoding))
          (function View (Inject op) -> Some ((), op) | _ -> None)
          (fun ((), op) -> View (Inject op));
        case
          (Tag 3)
          ~title:"Arrived"
          (obj3
             (req "request" (constant "arrived"))
             (req "operation_hash" Operation_hash.encoding)
             (req "operation" Operation.encoding))
          (function
            | View (Arrived (oph, op)) -> Some ((), oph, op) | _ -> None)
          (fun ((), oph, op) -> View (Arrived (oph, op)));
        case
          (Tag 4)
          ~title:"Advertise"
          (obj1 (req "request" (constant "advertise")))
          (function View Advertise -> Some () | _ -> None)
          (fun () -> View Advertise) ]

  let pp ppf (View r) =
    match r with
    | Flush hash ->
        Format.fprintf ppf "switching to new head %a" Block_hash.pp hash
    | Notify (id, {Mempool.known_valid; pending}) ->
        Format.fprintf
          ppf
          "@[<v 2>notified by %a of operations"
          P2p_peer.Id.pp
          id ;
        List.iter
          (fun oph ->
            Format.fprintf ppf "@,%a (applied)" Operation_hash.pp oph)
          known_valid ;
        List.iter
          (fun oph ->
            Format.fprintf ppf "@,%a (pending)" Operation_hash.pp oph)
          (Operation_hash.Set.elements pending) ;
        Format.fprintf ppf "@]"
    | Leftover ->
        Format.fprintf ppf "process next batch of operation"
    | Inject op ->
        Format.fprintf
          ppf
          "injecting operation %a"
          Operation_hash.pp
          (Operation.hash op)
    | Arrived (oph, _) ->
        Format.fprintf ppf "operation %a arrived" Operation_hash.pp oph
    | Advertise ->
        Format.fprintf ppf "advertising pending operations"
end

module Event = struct
  type t =
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Debug of string

  let level req =
    let open Request in
    match req with
    | Debug _ ->
        Internal_event.Debug
    | Request (View (Flush _), _, _) ->
        Internal_event.Notice
    | Request (View (Notify _), _, _) ->
        Internal_event.Debug
    | Request (View Leftover, _, _) ->
        Internal_event.Debug
    | Request (View (Inject _), _, _) ->
        Internal_event.Notice
    | Request (View (Arrived _), _, _) ->
        Internal_event.Debug
    | Request (View Advertise, _, _) ->
        Internal_event.Debug

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Debug"
          (obj1 (req "message" string))
          (function Debug msg -> Some msg | _ -> None)
          (fun msg -> Debug msg);
        case
          (Tag 1)
          ~title:"Request"
          (obj2
             (req "request" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function Request (req, t, None) -> Some (req, t) | _ -> None)
          (fun (req, t) -> Request (req, t, None));
        case
          (Tag 2)
          ~title:"Failed request"
          (obj3
             (req "error" RPC_error.encoding)
             (req "failed_request" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function
            | Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
          (fun (errs, req, t) -> Request (req, t, Some errs)) ]

  let pp ppf = function
    | Debug msg ->
        Format.fprintf ppf "%s" msg
    | Request (view, {pushed; treated; completed}, None) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
    | Request (view, {pushed; treated; completed}, Some errors) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
          (Format.pp_print_list Error_monad.pp)
          errors
end

module Worker_state = struct
  type view = {
    head : Block_hash.t;
    timestamp : Time.System.t;
    fetching : Operation_hash.Set.t;
    pending : Operation_hash.Set.t;
    applied : Operation_hash.t list;
    delayed : Operation_hash.Set.t;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {head; timestamp; fetching; pending; applied; delayed} ->
        (head, timestamp, fetching, pending, applied, delayed))
      (fun (head, timestamp, fetching, pending, applied, delayed) ->
        {head; timestamp; fetching; pending; applied; delayed})
      (obj6
         (req "head" Block_hash.encoding)
         (req "timestamp" Time.System.encoding)
         (req "fetching" Operation_hash.Set.encoding)
         (req "pending" Operation_hash.Set.encoding)
         (req "applied" (list Operation_hash.encoding))
         (req "delayed" Operation_hash.Set.encoding))

  let pp ppf view =
    Format.fprintf
      ppf
      "@[<v 0>Head: %a@,\
       Timestamp: %a@,\n\
      \       @[<v 2>Fetching: %a@]@,\n\
      \       @[<v 2>Pending: %a@]@,\n\
      \       @[<v 2>Applied: %a@]@,\n\
      \       @[<v 2>Delayed: %a@]@]"
      Block_hash.pp
      view.head
      Time.System.pp_hum
      view.timestamp
      (Format.pp_print_list Operation_hash.pp)
      (Operation_hash.Set.elements view.fetching)
      (Format.pp_print_list Operation_hash.pp)
      (Operation_hash.Set.elements view.pending)
      (Format.pp_print_list Operation_hash.pp)
      view.applied
      (Format.pp_print_list Operation_hash.pp)
      (Operation_hash.Set.elements view.delayed)
end
src/lib_shell_services/prevalidator_worker_state.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Inductive t : forall (a : Type), Type :=
  | Flush : Tezos_base__TzPervasives.Block_hash.t -> t unit
  | Notify : Tezos_base__TzPervasives.P2p_peer.Id.t ->
    Tezos_base__TzPervasives.Mempool.t -> t unit
  | Leftover : t unit
  | Inject : Tezos_base__TzPervasives.Operation.t -> t unit
  | Arrived : Tezos_base__TzPervasives.Operation_hash.t ->
    Tezos_base__TzPervasives.Operation.t -> t unit
  | Advertise : t unit.
  
  Inductive view : Type :=
  | View : forall {A : Type}, (t A) -> view.
  
  Definition view {A : Type} (req : t A) : view := View req.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    Tezos_base__TzPervasives.Data_encoding.union None
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Flush" % string None
          (Tag 0)
          (Tezos_base__TzPervasives.Data_encoding.obj2
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "request" % string
              (Tezos_base__TzPervasives.Data_encoding.constant "flush" % string))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "block" % string Tezos_base__TzPervasives.Block_hash.encoding))
          (fun function_parameter =>
            match function_parameter with
            | View (Flush hash) => Some (tt, hash)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (tt, hash) => View (Flush hash)
            end))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Notify" % string None
            (Tag 1)
            (Tezos_base__TzPervasives.Data_encoding.obj3
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "request" % string
                (Tezos_base__TzPervasives.Data_encoding.constant
                  "notify" % string))
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "peer" % string Tezos_base__TzPervasives.P2p_peer.Id.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "mempool" % string Tezos_base__TzPervasives.Mempool.encoding))
            (fun function_parameter =>
              match function_parameter with
              | View (Notify peer mempool) => Some (tt, peer, mempool)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tt, peer, mempool) => View (Notify peer mempool)
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case "Inject" % string None
              (Tag 2)
              (Tezos_base__TzPervasives.Data_encoding.obj2
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "request" % string
                  (Tezos_base__TzPervasives.Data_encoding.constant
                    "inject" % string))
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "operation" % string
                  Tezos_base__TzPervasives.Operation.encoding))
              (fun function_parameter =>
                match function_parameter with
                | View (Inject op) => Some (tt, op)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (tt, op) => View (Inject op)
                end))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case "Arrived" % string
                None (Tag 3)
                (Tezos_base__TzPervasives.Data_encoding.obj3
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "request" % string
                    (Tezos_base__TzPervasives.Data_encoding.constant
                      "arrived" % string))
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "operation_hash" % string
                    Tezos_base__TzPervasives.Operation_hash.encoding)
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "operation" % string
                    Tezos_base__TzPervasives.Operation.encoding))
                (fun function_parameter =>
                  match function_parameter with
                  | View (Arrived oph op) => Some (tt, oph, op)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (tt, oph, op) => View (Arrived oph op)
                  end))
              (cons
                (Tezos_base__TzPervasives.Data_encoding.case
                  "Advertise" % string None (Tag 4)
                  (Tezos_base__TzPervasives.Data_encoding.obj1
                    (Tezos_base__TzPervasives.Data_encoding.req None None
                      "request" % string
                      (Tezos_base__TzPervasives.Data_encoding.constant
                        "advertise" % string)))
                  (fun function_parameter =>
                    match function_parameter with
                    | View Advertise => Some tt
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => View Advertise
                    end)) []))))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
    : unit :=
    match function_parameter with
    | View r =>
      match r with
      | Flush hash =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "switching to new head " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "switching to new head %a" % string)
          Tezos_base__TzPervasives.Block_hash.pp hash
      |
        Notify id {|
          Mempool.known_valid := known_valid; Mempool.pending := pending |}
        =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal "notified by " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " of operations" % string
                    CamlinternalFormatBasics.End_of_format))))
            "@[<v 2>notified by %a of operations" % string)
          Tezos_base__TzPervasives.P2p_peer.Id.pp id;
        Tezos_base__TzPervasives.List.iter
          (fun oph =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " (applied)" % string
                      CamlinternalFormatBasics.End_of_format)))
                "@,%a (applied)" % string)
              Tezos_base__TzPervasives.Operation_hash.pp oph) known_valid;
        Tezos_base__TzPervasives.List.iter
          (fun oph =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " (pending)" % string
                      CamlinternalFormatBasics.End_of_format)))
                "@,%a (pending)" % string)
              Tezos_base__TzPervasives.Operation_hash.pp oph)
          (Tezos_base__TzPervasives.Operation_hash.Set.elements pending);
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format) "@]" % string)
      | Leftover =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "process next batch of operation" % string
              CamlinternalFormatBasics.End_of_format)
            "process next batch of operation" % string)
      | Inject op =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "injecting operation " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "injecting operation %a" % string)
          Tezos_base__TzPervasives.Operation_hash.pp
          (Tezos_base__TzPervasives.Operation.hash op)
      | Arrived oph _ =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "operation " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " arrived" % string
                  CamlinternalFormatBasics.End_of_format)))
            "operation %a arrived" % string)
          Tezos_base__TzPervasives.Operation_hash.pp oph
      | Advertise =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "advertising pending operations" % string
              CamlinternalFormatBasics.End_of_format)
            "advertising pending operations" % string)
      end
    end.
End Request.

Module Event.
  Inductive t : Type :=
  | Request :
    (Request.view * Tezos_shell_services.Worker_types.request_status *
      (option (list Tezos_base__TzPervasives.error))) -> t
  | Debug : string -> t.
  
  Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
    match req with
    | Debug _ => Internal_event.Debug
    | Request (View (Flush _), _, _) => Internal_event.Notice
    | Request (View (Notify _ _), _, _) => Internal_event.Debug
    | Request (View Leftover, _, _) => Internal_event.Debug
    | Request (View (Inject _), _, _) => Internal_event.Notice
    | Request (View (Arrived _ _), _, _) => Internal_event.Debug
    | Request (View Advertise, _, _) => Internal_event.Debug
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    Tezos_base__TzPervasives.Data_encoding.union None
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Debug" % string None
          (Tag 0)
          (Tezos_base__TzPervasives.Data_encoding.obj1
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "message" % string Tezos_base__TzPervasives.Data_encoding.string))
          (fun function_parameter =>
            match function_parameter with
            | Debug msg => Some msg
            | _ => None
            end) (fun msg => Debug msg))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Request" % string None
            (Tag 1)
            (Tezos_base__TzPervasives.Data_encoding.obj2
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "request" % string Request.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "status" % string
                Tezos_shell_services.Worker_types.request_status_encoding))
            (fun function_parameter =>
              match function_parameter with
              | Request (req, t, None) => Some (req, t)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (req, t) => Request (req, t, None)
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case
              "Failed request" % string None (Tag 2)
              (Tezos_base__TzPervasives.Data_encoding.obj3
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "error" % string Tezos_base__TzPervasives.RPC_error.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "failed_request" % string Request.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "status" % string
                  Tezos_shell_services.Worker_types.request_status_encoding))
              (fun function_parameter =>
                match function_parameter with
                | Request (req, t, Some errs) => Some (errs, req, t)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (errs, req, t) => Request (req, t, (Some errs))
                end)) []))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Debug msg =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) msg
    |
      Request
        (view, {|
          pushed := pushed; treated := treated; completed := completed |},
          None) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format))))))
          "@[<v 0>%a@, %a@]" % string) Request.pp view
        Tezos_shell_services.Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
    |
      Request
        (view, {|
          pushed := pushed; treated := treated; completed := completed |},
          Some errors) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ", " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))))
          "@[<v 0>%a@, %a, %a@]" % string) Request.pp view
        Tezos_shell_services.Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
        (Stdlib.Format.pp_print_list None
          Tezos_base__TzPervasives.Error_monad.pp) errors
    end.
End Event.

Module Worker_state.
  Record view := {
    head : Tezos_base__TzPervasives.Block_hash.t;
    timestamp : Tezos_base__TzPervasives.Time.System.t;
    fetching : Tezos_base__TzPervasives.Operation_hash.Set.t;
    pending : Tezos_base__TzPervasives.Operation_hash.Set.t;
    applied : list Tezos_base__TzPervasives.Operation_hash.t;
    delayed : Tezos_base__TzPervasives.Operation_hash.Set.t }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          head := head;
            timestamp := timestamp;
            fetching := fetching;
            pending := pending;
            applied := applied;
            delayed := delayed
            |} => (head, timestamp, fetching, pending, applied, delayed)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (head, timestamp, fetching, pending, applied, delayed) =>
          {| head := head; timestamp := timestamp; fetching := fetching;
            pending := pending; applied := applied; delayed := delayed |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj6
        (Tezos_base__TzPervasives.Data_encoding.req None None "head" % string
          Tezos_base__TzPervasives.Block_hash.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "timestamp" % string Tezos_base__TzPervasives.Time.System.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "fetching" % string
          Tezos_base__TzPervasives.Operation_hash.Set.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "pending" % string
          Tezos_base__TzPervasives.Operation_hash.Set.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "applied" % string
          (Tezos_base__TzPervasives.Data_encoding.list None
            Tezos_base__TzPervasives.Operation_hash.encoding))
        (Tezos_base__TzPervasives.Data_encoding.req None None "delayed" % string
          Tezos_base__TzPervasives.Operation_hash.Set.encoding)).
  
  Definition pp (ppf : Stdlib.Format.formatter) (view : view) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.String_literal "Head: " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "Timestamp: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String_literal
                        "
       " % string
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "Fetching: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "
       " % string
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<v 2>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<v 2>" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "Pending: " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@," % string 0 0)
                                              (CamlinternalFormatBasics.String_literal
                                                "
       " % string
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "<v 2>" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "<v 2>" % string))
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Applied: " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_box
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          (CamlinternalFormatBasics.Break
                                                            "@," % string 0 0)
                                                          (CamlinternalFormatBasics.String_literal
                                                            "
       " % string
                                                            (CamlinternalFormatBasics.Formatting_gen
                                                              (CamlinternalFormatBasics.Open_box
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "<v 2>" %
                                                                      string
                                                                    CamlinternalFormatBasics.End_of_format)
                                                                  "<v 2>" %
                                                                    string))
                                                              (CamlinternalFormatBasics.String_literal
                                                                "Delayed: " %
                                                                  string
                                                                (CamlinternalFormatBasics.Alpha
                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                    CamlinternalFormatBasics.Close_box
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      CamlinternalFormatBasics.Close_box
                                                                      CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))))))))
        "@[<v 0>Head: %a@,Timestamp: %a@,
       @[<v 2>Fetching: %a@]@,
       @[<v 2>Pending: %a@]@,
       @[<v 2>Applied: %a@]@,
       @[<v 2>Delayed: %a@]@]"
          % string) Tezos_base__TzPervasives.Block_hash.pp (head view)
      Tezos_base__TzPervasives.Time.System.pp_hum (timestamp view)
      (Stdlib.Format.pp_print_list None
        Tezos_base__TzPervasives.Operation_hash.pp)
      (Tezos_base__TzPervasives.Operation_hash.Set.elements (fetching view))
      (Stdlib.Format.pp_print_list None
        Tezos_base__TzPervasives.Operation_hash.pp)
      (Tezos_base__TzPervasives.Operation_hash.Set.elements (pending view))
      (Stdlib.Format.pp_print_list None
        Tezos_base__TzPervasives.Operation_hash.pp) (applied view)
      (Stdlib.Format.pp_print_list None
        Tezos_base__TzPervasives.Operation_hash.pp)
      (Tezos_base__TzPervasives.Operation_hash.Set.elements (delayed view)).
End Worker_state.
src/lib_shell_services/prevalidator_worker_state.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request : sig
  type 'a t =
    | Flush : Block_hash.t -> unit t
    | Notify : P2p_peer.Id.t * Mempool.t -> unit t
    | Leftover : unit t
    | Inject : Operation.t -> unit t
    | Arrived : Operation_hash.t * Operation.t -> unit t
    | Advertise : unit t

  type view = View : _ t -> view

  val view : 'a t -> view

  val encoding : view Data_encoding.t

  val pp : Format.formatter -> view -> unit
end

module Event : sig
  type t =
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Debug of string

  val level : t -> Internal_event.level

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

module Worker_state : sig
  type view = {
    head : Block_hash.t;
    timestamp : Time.System.t;
    fetching : Operation_hash.Set.t;
    pending : Operation_hash.Set.t;
    applied : Operation_hash.t list;
    delayed : Operation_hash.Set.t;
  }

  val encoding : view Data_encoding.t

  val pp : Format.formatter -> view -> unit
end
src/lib_shell_services/prevalidator_worker_state.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Inductive t : forall (a : Type), Type :=
  | Flush : Tezos_base__TzPervasives.Block_hash.t -> t unit
  | Notify : Tezos_base__TzPervasives.P2p_peer.Id.t ->
    Tezos_base__TzPervasives.Mempool.t -> t unit
  | Leftover : t unit
  | Inject : Tezos_base__TzPervasives.Operation.t -> t unit
  | Arrived : Tezos_base__TzPervasives.Operation_hash.t ->
    Tezos_base__TzPervasives.Operation.t -> t unit
  | Advertise : t unit.
  
  Inductive view : Type :=
  | View : forall {A : Type}, (t A) -> view.
  
  Parameter view : forall {a : Type}, (t a) -> view.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t view.
  
  Parameter pp : Stdlib.Format.formatter -> view -> unit.
End Request.

Module Event.
  Inductive t : Type :=
  | Request :
    (Request.view * Tezos_shell_services.Worker_types.request_status *
      (option (list Tezos_base__TzPervasives.error))) -> t
  | Debug : string -> t.
  
  Parameter level : t -> Tezos_base__TzPervasives.Internal_event.level.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
End Event.

Module Worker_state.
  Record view := {
    head : Tezos_base__TzPervasives.Block_hash.t;
    timestamp : Tezos_base__TzPervasives.Time.System.t;
    fetching : Tezos_base__TzPervasives.Operation_hash.Set.t;
    pending : Tezos_base__TzPervasives.Operation_hash.Set.t;
    applied : list Tezos_base__TzPervasives.Operation_hash.t;
    delayed : Tezos_base__TzPervasives.Operation_hash.Set.t }.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t view.
  
  Parameter pp : Stdlib.Format.formatter -> view -> unit.
End Worker_state.
src/lib_shell_services/protocol_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

module S = struct
  let protocols_arg = Protocol_hash.rpc_arg

  let contents =
    RPC_service.get_service
      ~query:RPC_query.empty
      ~output:Protocol.encoding
      RPC_path.(root / "protocols" /: protocols_arg)

  let list =
    RPC_service.get_service
      ~query:RPC_query.empty
      ~output:(list Protocol_hash.encoding)
      RPC_path.(root / "protocols")

  let fetch =
    RPC_service.get_service
      ~description:"Fetch a protocol from the network."
      ~query:RPC_query.empty
      ~output:unit
      RPC_path.(root / "fetch_protocol" /: protocols_arg)
end

open RPC_context

let contents ctxt h = make_call1 S.contents ctxt h () ()

let list ctxt = make_call S.list ctxt () () ()

let fetch ctxt h = make_call1 S.fetch ctxt h () ()
src/lib_shell_services/protocol_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Data_encoding.

Module S.
  Definition protocols_arg
    : Tezos_rpc.RPC_arg.t Tezos_base__TzPervasives.Protocol_hash.t :=
    Tezos_base__TzPervasives.Protocol_hash.rpc_arg.
  
  Definition contents
    : Tezos_base__TzPervasives.RPC_service.service variant unit
      (unit * Tezos_base__TzPervasives.Protocol_hash.t) unit unit
      Tezos_base__TzPervasives.Protocol.t :=
    Tezos_base__TzPervasives.RPC_service.get_service None
      Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.Protocol.encoding
      (Tezos_base__TzPervasives.RPC_path.op_div_colon
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "protocols" % string)
        protocols_arg).
  
  Definition list
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      (list Tezos_base__TzPervasives.Protocol_hash.t) :=
    Tezos_base__TzPervasives.RPC_service.get_service None
      Tezos_base__TzPervasives.RPC_query.empty
      (Tezos_base__TzPervasives.Data_encoding.list None
        Tezos_base__TzPervasives.Protocol_hash.encoding)
      (Tezos_base__TzPervasives.RPC_path.op_div
        Tezos_base__TzPervasives.RPC_path.root "protocols" % string).
  
  Definition fetch
    : Tezos_base__TzPervasives.RPC_service.service variant unit
      (unit * Tezos_base__TzPervasives.Protocol_hash.t) unit unit unit :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "Fetch a protocol from the network." % string)
      Tezos_base__TzPervasives.RPC_query.empty
      Tezos_base__TzPervasives.Data_encoding.unit
      (Tezos_base__TzPervasives.RPC_path.op_div_colon
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "fetch_protocol" % string)
        protocols_arg).
End S.

Import Tezos_base__TzPervasives.RPC_context.

Definition contents {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (h : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult Tezos_base__TzPervasives.Protocol.t) :=
  Tezos_base__TzPervasives.RPC_context.make_call1 S.contents ctxt h tt tt.

Definition list {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      (list Tezos_base__TzPervasives.Protocol_hash.t)) :=
  Tezos_base__TzPervasives.RPC_context.make_call S.list ctxt tt tt tt.

Definition fetch {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (h : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  Tezos_base__TzPervasives.RPC_context.make_call1 S.fetch ctxt h tt tt.
src/lib_shell_services/protocol_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open RPC_context

val contents : #simple -> Protocol_hash.t -> Protocol.t tzresult Lwt.t

val list : #simple -> Protocol_hash.t list tzresult Lwt.t

val fetch : #simple -> Protocol_hash.t -> unit tzresult Lwt.t

module S : sig
  val contents :
    ( [`GET],
      unit,
      unit * Protocol_hash.t,
      unit,
      unit,
      Protocol.t )
    RPC_service.t

  val list :
    ([`GET], unit, unit, unit, unit, Protocol_hash.t list) RPC_service.t

  val fetch :
    ([`GET], unit, unit * Protocol_hash.t, unit, unit, unit) RPC_service.t
end
src/lib_shell_services/protocol_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter contents : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Tezos_base__TzPervasives.Protocol_hash.t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Protocol.t).

Parameter list : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_base__TzPervasives.Protocol_hash.t)).

Parameter fetch : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Tezos_base__TzPervasives.Protocol_hash.t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Module S.
  Parameter contents : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit (unit * Tezos_base__TzPervasives.Protocol_hash.t) unit unit
    Tezos_base__TzPervasives.Protocol.t.
  
  Parameter list : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit unit unit unit (list Tezos_base__TzPervasives.Protocol_hash.t).
  
  Parameter fetch : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
    variant unit (unit * Tezos_base__TzPervasives.Protocol_hash.t) unit unit
    unit.
End S.
src/lib_shell_services/shell_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type chain = Chain_services.chain

type block = Block_services.block

module Chain = Chain_services
module Blocks = Chain.Blocks
module Invalid_blocks = Chain.Invalid_blocks
module Mempool = Chain.Mempool
module Protocol = Protocol_services
module Monitor = Monitor_services
module Injection = Injection_services
module P2p = P2p_services
module Worker = Worker_services
src/lib_shell_services/shell_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition chain := Tezos_shell_services.Chain_services.chain.

Definition block := Tezos_shell_services.Block_services.block.
src/lib_shell_services/shell_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type chain = Chain_services.chain

type block = Block_services.block

module Chain = Chain_services
module Blocks = Chain.Blocks
module Invalid_blocks = Chain.Invalid_blocks
module Mempool = Chain.Mempool
module Protocol = Protocol_services
module Monitor = Monitor_services
module Injection = Injection_services
module P2p = P2p_services
module Worker = Worker_services
src/lib_shell_services/shell_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition chain := Tezos_shell_services.Chain_services.chain.

Definition block := Tezos_shell_services.Block_services.block.

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module
src/lib_shell_services/stat_services.ml 
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Gc

let gc_stat_encoding =
  let open Data_encoding in
  conv
    (fun { minor_words;
           promoted_words;
           major_words;
           minor_collections;
           major_collections;
           heap_words;
           heap_chunks;
           live_words;
           live_blocks;
           free_words;
           free_blocks;
           largest_free;
           fragments;
           compactions;
           top_heap_words;
           stack_size } ->
      ( ( minor_words,
          promoted_words,
          major_words,
          minor_collections,
          major_collections ),
        ( (heap_words, heap_chunks, live_words, live_blocks, free_words),
          ( free_blocks,
            largest_free,
            fragments,
            compactions,
            top_heap_words,
            stack_size ) ) ))
    (fun ( ( minor_words,
             promoted_words,
             major_words,
             minor_collections,
             major_collections ),
           ( (heap_words, heap_chunks, live_words, live_blocks, free_words),
             ( free_blocks,
               largest_free,
               fragments,
               compactions,
               top_heap_words,
               stack_size ) ) ) ->
      {
        minor_words;
        promoted_words;
        major_words;
        minor_collections;
        major_collections;
        heap_words;
        heap_chunks;
        live_words;
        live_blocks;
        free_words;
        free_blocks;
        largest_free;
        fragments;
        compactions;
        top_heap_words;
        stack_size;
      })
    (merge_objs
       (obj5
          (req "minor_words" float)
          (req "promoted_words" float)
          (req "major_words" float)
          (req "minor_collections" int31)
          (req "major_collections" int31))
       (merge_objs
          (obj5
             (req "heap_words" int31)
             (req "heap_chunks" int31)
             (req "live_words" int31)
             (req "live_blocks" int31)
             (req "free_words" int31))
          (obj6
             (req "free_blocks" int31)
             (req "largest_free" int31)
             (req "fragments" int31)
             (req "compactions" int31)
             (req "top_heap_words" int31)
             (req "stack_size" int31))))

let proc_stat_encoding =
  let open Memory in
  let open Data_encoding in
  union
    ~tag_size:`Uint8
    [ case
        (Tag 0)
        (conv
           (fun {page_size; size; resident; shared; text; lib; data; dt} ->
             (page_size, size, resident, shared, text, lib, data, dt))
           (fun (page_size, size, resident, shared, text, lib, data, dt) ->
             {page_size; size; resident; shared; text; lib; data; dt})
           (obj8
              (req "page_size" int31)
              (req "size" int64)
              (req "resident" int64)
              (req "shared" int64)
              (req "text" int64)
              (req "lib" int64)
              (req "data" int64)
              (req "dt" int64)))
        ~title:"Linux_proc_statm"
        (function Statm x -> Some x | _ -> None)
        (function res -> Statm res);
      case
        (Tag 1)
        (conv
           (fun {page_size; mem; resident} -> (page_size, mem, resident))
           (fun (page_size, mem, resident) -> {page_size; mem; resident})
           (obj3
              (req "page_size" int31)
              (req "mem" float)
              (req "resident" int64)))
        ~title:"Darwin_ps"
        (function Ps x -> Some x | _ -> None)
        (function res -> Ps res) ]

module S = struct
  let gc =
    RPC_service.get_service
      ~description:"Gets stats from the OCaml Garbage Collector"
      ~query:RPC_query.empty
      ~output:gc_stat_encoding
      RPC_path.(root / "stats" / "gc")

  let memory =
    RPC_service.get_service
      ~description:"Gets memory usage stats"
      ~query:RPC_query.empty
      ~output:proc_stat_encoding
      RPC_path.(root / "stats" / "memory")
end

let gc ctxt = RPC_context.make_call S.gc ctxt () () ()

let memory ctxt = RPC_context.make_call S.memory ctxt () () ()
src/lib_shell_services/stat_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Stdlib.Gc.

Definition gc_stat_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Gc.stat :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        minor_words := minor_words;
          promoted_words := promoted_words;
          major_words := major_words;
          minor_collections := minor_collections;
          major_collections := major_collections;
          heap_words := heap_words;
          heap_chunks := heap_chunks;
          live_words := live_words;
          live_blocks := live_blocks;
          free_words := free_words;
          free_blocks := free_blocks;
          largest_free := largest_free;
          fragments := fragments;
          compactions := compactions;
          top_heap_words := top_heap_words;
          stack_size := stack_size
          |} =>
        ((minor_words, promoted_words, major_words, minor_collections,
          major_collections),
          ((heap_words, heap_chunks, live_words, live_blocks, free_words),
            (free_blocks, largest_free, fragments, compactions, top_heap_words,
              stack_size)))
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        ((minor_words, promoted_words, major_words, minor_collections,
          major_collections),
          ((heap_words, heap_chunks, live_words, live_blocks, free_words),
            (free_blocks, largest_free, fragments, compactions, top_heap_words,
              stack_size))) =>
        {| minor_words := minor_words; promoted_words := promoted_words;
          major_words := major_words; minor_collections := minor_collections;
          major_collections := major_collections; heap_words := heap_words;
          heap_chunks := heap_chunks; live_words := live_words;
          live_blocks := live_blocks; free_words := free_words;
          free_blocks := free_blocks; largest_free := largest_free;
          fragments := fragments; compactions := compactions;
          top_heap_words := top_heap_words; stack_size := stack_size |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.merge_objs
      (Tezos_base__TzPervasives.Data_encoding.obj5
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "minor_words" % string Tezos_base__TzPervasives.Data_encoding.float)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "promoted_words" % string Tezos_base__TzPervasives.Data_encoding.float)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "major_words" % string Tezos_base__TzPervasives.Data_encoding.float)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "minor_collections" % string
          Tezos_base__TzPervasives.Data_encoding.int31)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "major_collections" % string
          Tezos_base__TzPervasives.Data_encoding.int31))
      (Tezos_base__TzPervasives.Data_encoding.merge_objs
        (Tezos_base__TzPervasives.Data_encoding.obj5
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "heap_words" % string Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "heap_chunks" % string Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "live_words" % string Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "live_blocks" % string Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "free_words" % string Tezos_base__TzPervasives.Data_encoding.int31))
        (Tezos_base__TzPervasives.Data_encoding.obj6
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "free_blocks" % string Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "largest_free" % string Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "fragments" % string Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "compactions" % string Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "top_heap_words" % string
            Tezos_base__TzPervasives.Data_encoding.int31)
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "stack_size" % string Tezos_base__TzPervasives.Data_encoding.int31)))).

Definition proc_stat_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_base__TzPervasives.Memory.mem_stats :=
  Tezos_base__TzPervasives.Data_encoding.union (Some variant)
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case "Linux_proc_statm" % string
        None (Tag 0)
        (Tezos_base__TzPervasives.Data_encoding.conv
          (fun function_parameter =>
            match function_parameter with
            | {|
              page_size := page_size;
                size := size;
                resident := resident;
                shared := shared;
                text := text;
                lib := lib;
                data := data;
                dt := dt
                |} => (page_size, size, resident, shared, text, lib, data, dt)
            end)
          (fun function_parameter =>
            match function_parameter with
            | (page_size, size, resident, shared, text, lib, data, dt) =>
              {| page_size := page_size; size := size; resident := resident;
                shared := shared; text := text; lib := lib; data := data;
                dt := dt |}
            end) None
          (Tezos_base__TzPervasives.Data_encoding.obj8
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "page_size" % string Tezos_base__TzPervasives.Data_encoding.int31)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "size" % string Tezos_base__TzPervasives.Data_encoding.int64)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "resident" % string Tezos_base__TzPervasives.Data_encoding.int64)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "shared" % string Tezos_base__TzPervasives.Data_encoding.int64)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "text" % string Tezos_base__TzPervasives.Data_encoding.int64)
            (Tezos_base__TzPervasives.Data_encoding.req None None "lib" % string
              Tezos_base__TzPervasives.Data_encoding.int64)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "data" % string Tezos_base__TzPervasives.Data_encoding.int64)
            (Tezos_base__TzPervasives.Data_encoding.req None None "dt" % string
              Tezos_base__TzPervasives.Data_encoding.int64)))
        (fun function_parameter =>
          match function_parameter with
          | Statm x => Some x
          | _ => None
          end) (fun res => Statm res))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Darwin_ps" % string None
          (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.conv
            (fun function_parameter =>
              match function_parameter with
              | {| page_size := page_size; mem := mem; resident := resident |}
                => (page_size, mem, resident)
              end)
            (fun function_parameter =>
              match function_parameter with
              | (page_size, mem, resident) =>
                {| page_size := page_size; mem := mem; resident := resident |}
              end) None
            (Tezos_base__TzPervasives.Data_encoding.obj3
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "page_size" % string
                Tezos_base__TzPervasives.Data_encoding.int31)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "mem" % string Tezos_base__TzPervasives.Data_encoding.float)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "resident" % string Tezos_base__TzPervasives.Data_encoding.int64)))
          (fun function_parameter =>
            match function_parameter with
            | Ps x => Some x
            | _ => None
            end) (fun res => Ps res)) [])).

Module S.
  Definition gc
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Stdlib.Gc.stat :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "Gets stats from the OCaml Garbage Collector" % string)
      Tezos_base__TzPervasives.RPC_query.empty gc_stat_encoding
      (Tezos_base__TzPervasives.RPC_path.op_div
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "stats" % string) "gc" % string).
  
  Definition memory
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.Memory.mem_stats :=
    Tezos_base__TzPervasives.RPC_service.get_service
      (Some "Gets memory usage stats" % string)
      Tezos_base__TzPervasives.RPC_query.empty proc_stat_encoding
      (Tezos_base__TzPervasives.RPC_path.op_div
        (Tezos_base__TzPervasives.RPC_path.op_div
          Tezos_base__TzPervasives.RPC_path.root "stats" % string)
        "memory" % string).
End S.

Definition gc {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult Stdlib.Gc.stat) :=
  Tezos_base__TzPervasives.RPC_context.make_call S.gc ctxt tt tt tt.

Definition memory {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.Memory.mem_stats) :=
  Tezos_base__TzPervasives.RPC_context.make_call S.memory ctxt tt tt tt.
src/lib_shell_services/stat_services.mli 
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module S : sig
  val gc : ([`GET], unit, unit, unit, unit, Gc.stat) RPC_service.service

  val memory :
    ([`GET], unit, unit, unit, unit, Memory.mem_stats) RPC_service.service
end

val gc : #RPC_context.simple -> Gc.stat Error_monad.tzresult Lwt.t

val memory : #RPC_context.simple -> Memory.mem_stats Error_monad.tzresult Lwt.t
src/lib_shell_services/stat_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Parameter gc : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.service
    variant unit unit unit unit Stdlib.Gc.stat.
  
  Parameter memory : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.service
    variant unit unit unit unit Tezos_base__TzPervasives.Memory.mem_stats.
End S.

Parameter gc : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult Stdlib.Gc.stat).

Parameter memory : forall {_ i o p q variant : Type},
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
  p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
  (_ * p * q * i * o)) * _) * _) ->
  Lwt.t
    (Tezos_base__TzPervasives.Error_monad.tzresult
      Tezos_base__TzPervasives.Memory.mem_stats).
src/lib_shell_services/state_logging.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.state"
end)

let chain_id = Tag.def ~doc:"Chain ID" "chain_id" Chain_id.pp
src/lib_shell_services/state_logging.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition chain_id : Tag.def Tezos_base__TzPervasives.Chain_id.t :=
  Tag.def (Some "Chain ID" % string) "chain_id" % string
    Tezos_base__TzPervasives.Chain_id.pp.
src/lib_shell_services/state_logging.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.SEMLOG

val chain_id : Chain_id.t Tag.def
src/lib_shell_services/state_logging.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter chain_id : Tag.def Tezos_base__TzPervasives.Chain_id.t.
src/lib_shell_services/validation_errors.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(***************** Prevalidation errors ***********************************)

type error += Parse_error

type error += Too_many_operations

type error += Oversized_operation of {size : int; max : int}

type error +=
  | Future_block_header of {
      block : Block_hash.t;
      block_time : Time.Protocol.t;
      time : Time.System.t;
    }

let () =
  (* Parse error *)
  register_error_kind
    `Permanent
    ~id:"node.prevalidation.parse_error"
    ~title:"Parsing error in prevalidation"
    ~description:
      "Raised when an operation has not been parsed correctly during \
       prevalidation."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Operation parsing error in prevalidation.")
    Data_encoding.empty
    (function Parse_error -> Some () | _ -> None)
    (fun () -> Parse_error) ;
  (* Too many operations *)
  register_error_kind
    `Temporary
    ~id:"node.prevalidation.too_many_operations"
    ~title:"Too many pending operations in prevalidation"
    ~description:"The prevalidation context is full."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Too many operations in prevalidation context.")
    Data_encoding.empty
    (function Too_many_operations -> Some () | _ -> None)
    (fun () -> Too_many_operations) ;
  (* Oversized operation *)
  register_error_kind
    `Permanent
    ~id:"node.prevalidation.oversized_operation"
    ~title:"Oversized operation"
    ~description:"The operation size is bigger than allowed."
    ~pp:(fun ppf (size, max) ->
      Format.fprintf ppf "Oversized operation (size: %d, max: %d)" size max)
    Data_encoding.(obj2 (req "size" int31) (req "max_size" int31))
    (function
      | Oversized_operation {size; max} -> Some (size, max) | _ -> None)
    (fun (size, max) -> Oversized_operation {size; max}) ;
  (* Block from the future *)
  register_error_kind
    `Temporary
    ~id:"node.prevalidation.future_block_header"
    ~title:"Future block header"
    ~description:"The block was annotated with a time too far in the future."
    ~pp:(fun ppf (block, block_time, time) ->
      Format.fprintf
        ppf
        "Future block header (block: %a, block_time: %a, time: %a)"
        Block_hash.pp
        block
        Time.System.pp_hum
        (Time.System.of_protocol_exn block_time)
        Time.System.pp_hum
        time)
    Data_encoding.(
      obj3
        (req "block" Block_hash.encoding)
        (req "block_time" Time.Protocol.encoding)
        (req "time" Time.System.encoding))
    (function
      | Future_block_header {block; block_time; time} ->
          Some (block, block_time, time)
      | _ ->
          None)
    (fun (block, block_time, time) ->
      Future_block_header {block; block_time; time})

(************************* State errors ***********************************)

type error += Unknown_chain of Chain_id.t

type error += Bad_data_dir

type error += Block_not_invalid of Block_hash.t

let () =
  (* Unknown network *)
  register_error_kind
    `Permanent
    ~id:"node.state.unknown_chain"
    ~title:"Unknown chain"
    ~description:
      "The chain identifier could not be found in the chain identifiers table."
    ~pp:(fun ppf id -> Format.fprintf ppf "Unknown chain %a" Chain_id.pp id)
    Data_encoding.(obj1 (req "chain" Chain_id.encoding))
    (function Unknown_chain x -> Some x | _ -> None)
    (fun x -> Unknown_chain x) ;
  register_error_kind
    `Permanent
    ~id:"node.state.bad_data_dir"
    ~title:"Bad data directory"
    ~description:
      "The data directory could not be read. This could be because it was \
       generated with an old version of the tezos-node program. Deleting and \
       regenerating this directory may fix the problem."
    ~pp:(fun ppf () -> Format.fprintf ppf "Bad data directory.")
    Data_encoding.empty
    (function Bad_data_dir -> Some () | _ -> None)
    (fun () -> Bad_data_dir) ;
  (* Block not invalid *)
  register_error_kind
    `Permanent
    ~id:"node.state.block_not_invalid"
    ~title:"Block not invalid"
    ~description:"The invalid block to be unmarked was not actually invalid."
    ~pp:(fun ppf block ->
      Format.fprintf
        ppf
        "Block %a was expected to be invalid, but was not actually invalid."
        Block_hash.pp
        block)
    Data_encoding.(obj1 (req "block" Block_hash.encoding))
    (function Block_not_invalid block -> Some block | _ -> None)
    (fun block -> Block_not_invalid block)

(* Block database error *)

type error += Inconsistent_hash of Context_hash.t * Context_hash.t

let () =
  (* Inconsistent hash *)
  register_error_kind
    `Permanent
    ~id:"node.state.block.inconsistent_context_hash"
    ~title:"Inconsistent commit hash"
    ~description:
      "When commiting the context of a block, the announced context hash was \
       not the one computed at commit time."
    ~pp:(fun ppf (got, exp) ->
      Format.fprintf
        ppf
        "@[<v 2>Inconsistent hash:@ got: %a@ expected: %a"
        Context_hash.pp
        got
        Context_hash.pp
        exp)
    Data_encoding.(
      obj2
        (req "wrong_context_hash" Context_hash.encoding)
        (req "expected_context_hash" Context_hash.encoding))
    (function Inconsistent_hash (got, exp) -> Some (got, exp) | _ -> None)
    (fun (got, exp) -> Inconsistent_hash (got, exp))

(******************* Bootstrap pipeline errors ****************************)

type error += Invalid_locator of P2p_peer.Id.t * Block_locator.t

type error += Too_short_locator of P2p_peer.Id.t * Block_locator.t

let () =
  (* Invalid locator *)
  register_error_kind
    `Permanent
    ~id:"node.bootstrap_pipeline.invalid_locator"
    ~title:"Invalid block locator"
    ~description:"Block locator is invalid."
    ~pp:(fun ppf (id, locator) ->
      Format.fprintf
        ppf
        "Invalid block locator on peer %a:\n%a"
        P2p_peer.Id.pp
        id
        Block_locator.pp
        locator)
    Data_encoding.(
      obj2
        (req "id" P2p_peer.Id.encoding)
        (req "locator" Block_locator.encoding))
    (function Invalid_locator (id, loc) -> Some (id, loc) | _ -> None)
    (fun (id, loc) -> Invalid_locator (id, loc)) ;
  (* Too short locator *)
  register_error_kind
    `Permanent
    ~id:"node.bootstrap_pipeline.too_short_locator"
    ~title:"Too short locator"
    ~description:"Block locator is too short."
    ~pp:(fun ppf (id, locator) ->
      Format.fprintf
        ppf
        "Too short locator on peer %a:\n%a"
        P2p_peer.Id.pp
        id
        Block_locator.pp
        locator)
    Data_encoding.(
      obj2
        (req "id" P2p_peer.Id.encoding)
        (req "locator" Block_locator.encoding))
    (function Too_short_locator (id, loc) -> Some (id, loc) | _ -> None)
    (fun (id, loc) -> Too_short_locator (id, loc))

(******************* Protocol validator errors ****************************)

type protocol_error = Compilation_failed | Dynlinking_failed

type error +=
  | Invalid_protocol of {hash : Protocol_hash.t; error : protocol_error}

let protocol_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Compilation failed"
        (obj1 (req "error" (constant "compilation_failed")))
        (function Compilation_failed -> Some () | _ -> None)
        (fun () -> Compilation_failed);
      case
        (Tag 1)
        ~title:"Dynlinking failed"
        (obj1 (req "error" (constant "dynlinking_failed")))
        (function Dynlinking_failed -> Some () | _ -> None)
        (fun () -> Dynlinking_failed) ]

let pp_protocol_error ppf = function
  | Compilation_failed ->
      Format.fprintf ppf "compilation error"
  | Dynlinking_failed ->
      Format.fprintf ppf "dynlinking error"

let () =
  (* Invalid protocol *)
  register_error_kind
    `Permanent
    ~id:"node.protocol_validator.invalid_protocol"
    ~title:"Invalid protocol"
    ~description:"Invalid protocol."
    ~pp:(fun ppf (protocol, error) ->
      Format.fprintf
        ppf
        "@[<v 2>Invalid protocol %a@ %a@]"
        Protocol_hash.pp_short
        protocol
        pp_protocol_error
        error)
    Data_encoding.(
      merge_objs
        (obj1 (req "invalid_protocol" Protocol_hash.encoding))
        protocol_error_encoding)
    (function
      | Invalid_protocol {hash; error} -> Some (hash, error) | _ -> None)
    (fun (hash, error) -> Invalid_protocol {hash; error})

(********************* Peer validator errors ******************************)

type error += Unknown_ancestor | Known_invalid

let () =
  (* Unknown ancestor *)
  register_error_kind
    `Permanent
    ~id:"node.peer_validator.unknown_ancestor"
    ~title:"Unknown ancestor"
    ~description:"Unknown ancestor block found in the peer's chain"
    ~pp:(fun ppf () -> Format.fprintf ppf "Unknown ancestor")
    Data_encoding.empty
    (function Unknown_ancestor -> Some () | _ -> None)
    (fun () -> Unknown_ancestor) ;
  (* Known invalid *)
  register_error_kind
    `Permanent
    ~id:"node.peer_validator.known_invalid"
    ~title:"Known invalid"
    ~description:"Known invalid block found in the peer's chain"
    ~pp:(fun ppf () -> Format.fprintf ppf "Known invalid")
    Data_encoding.empty
    (function Known_invalid -> Some () | _ -> None)
    (fun () -> Known_invalid)

(************************ Validator errors ********************************)

type error += Inactive_chain of Chain_id.t

type error += Checkpoint_error of Block_hash.t * P2p_peer.Id.t option

let () =
  (* Inactive network *)
  register_error_kind
    `Branch
    ~id:"node.validator.inactive_chain"
    ~title:"Inactive chain"
    ~description:"Attempted validation of a block from an inactive chain."
    ~pp:(fun ppf chain ->
      Format.fprintf
        ppf
        "Tried to validate a block from chain %a, that is not currently \
         considered active."
        Chain_id.pp
        chain)
    Data_encoding.(obj1 (req "inactive_chain" Chain_id.encoding))
    (function Inactive_chain chain -> Some chain | _ -> None)
    (fun chain -> Inactive_chain chain) ;
  register_error_kind
    `Branch
    ~id:"node.validator.checkpoint_error"
    ~title:"Block incompatible with the current checkpoint."
    ~description:
      "The block belongs to a branch that is not compatible with the current \
       checkpoint."
    ~pp:(fun ppf (block, peer) ->
      match peer with
      | None ->
          Format.fprintf
            ppf
            "The block %a is incompatible with the current checkpoint."
            Block_hash.pp_short
            block
      | Some peer ->
          Format.fprintf
            ppf
            "The peer %a send us a block which is a sibling of the configured \
             checkpoint (%a)."
            P2p_peer.Id.pp
            peer
            Block_hash.pp_short
            block)
    Data_encoding.(
      obj2 (req "block" Block_hash.encoding) (opt "peer" P2p_peer.Id.encoding))
    (function
      | Checkpoint_error (block, peer) -> Some (block, peer) | _ -> None)
    (fun (block, peer) -> Checkpoint_error (block, peer))
src/lib_shell_services/validation_errors.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive protocol_error : Type :=
| Compilation_failed : protocol_error
| Dynlinking_failed : protocol_error.

Definition protocol_error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding protocol_error :=
  Tezos_base__TzPervasives.Data_encoding.union None
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case "Compilation failed" % string
        None (Tag 0)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None "error" % string
            (Tezos_base__TzPervasives.Data_encoding.constant
              "compilation_failed" % string)))
        (fun function_parameter =>
          match function_parameter with
          | Compilation_failed => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | tt => Compilation_failed
          end))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case
          "Dynlinking failed" % string None (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.obj1
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "error" % string
              (Tezos_base__TzPervasives.Data_encoding.constant
                "dynlinking_failed" % string)))
          (fun function_parameter =>
            match function_parameter with
            | Dynlinking_failed => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | tt => Dynlinking_failed
            end)) [])).

Definition pp_protocol_error
  (ppf : Stdlib.Format.formatter) (function_parameter : protocol_error)
  : unit :=
  match function_parameter with
  | Compilation_failed =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "compilation error" % string
          CamlinternalFormatBasics.End_of_format) "compilation error" % string)
  | Dynlinking_failed =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "dynlinking error" % string
          CamlinternalFormatBasics.End_of_format) "dynlinking error" % string)
  end.
src/lib_shell_services/validation_errors.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(***************** Prevalidation errors ***********************************)

type error += Parse_error

type error += Too_many_operations

type error += Oversized_operation of {size : int; max : int}

type error +=
  | Future_block_header of {
      block : Block_hash.t;
      block_time : Time.Protocol.t;
      time : Time.System.t;
    }

(************************* State errors ***********************************)

type error += Unknown_chain of Chain_id.t

type error += Bad_data_dir

type error += Block_not_invalid of Block_hash.t

(* Block database error *)

type error += Inconsistent_hash of Context_hash.t * Context_hash.t

(******************* Bootstrap pipeline errors ****************************)

type error += Invalid_locator of P2p_peer.Id.t * Block_locator.t

type error += Too_short_locator of P2p_peer.Id.t * Block_locator.t

(******************* Protocol validator errors ****************************)

type protocol_error = Compilation_failed | Dynlinking_failed

type error +=
  | Invalid_protocol of {hash : Protocol_hash.t; error : protocol_error}

(********************* Peer validator errors ******************************)

type error += Unknown_ancestor | Known_invalid

(************************ Validator errors ********************************)

type error += Inactive_chain of Chain_id.t

type error += Checkpoint_error of Block_hash.t * P2p_peer.Id.t option
src/lib_shell_services/validation_errors.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

Inductive protocol_error : Type :=
| Compilation_failed : protocol_error
| Dynlinking_failed : protocol_error.

extensible_type

extensible_type

extensible_type

extensible_type
src/lib_shell_services/worker_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

module Prevalidators = struct
  module S = struct
    let list =
      RPC_service.get_service
        ~description:"Lists the Prevalidator workers and their status."
        ~query:RPC_query.empty
        ~output:
          (list
             (obj4
                (req "chain_id" Chain_id.encoding)
                (req
                   "status"
                   (Worker_types.worker_status_encoding RPC_error.encoding))
                (req
                   "information"
                   (Worker_types.worker_information_encoding RPC_error.encoding))
                (req "pipelines" int8)))
        RPC_path.(root / "workers" / "prevalidators")

    let state =
      RPC_service.get_service
        ~description:"Introspect the state of prevalidator workers."
        ~query:RPC_query.empty
        ~output:
          (Worker_types.full_status_encoding
             Prevalidator_worker_state.Request.encoding
             Prevalidator_worker_state.Event.encoding
             RPC_error.encoding)
        RPC_path.(
          root / "workers" / "prevalidators" /: Chain_services.chain_arg)
  end

  open RPC_context

  let list ctxt = make_call S.list ctxt () () ()

  let state ctxt h = make_call1 S.state ctxt h () ()
end

module Block_validator = struct
  module S = struct
    let state =
      RPC_service.get_service
        ~description:"Introspect the state of the block_validator worker."
        ~query:RPC_query.empty
        ~output:
          (Worker_types.full_status_encoding
             Block_validator_worker_state.Request.encoding
             Block_validator_worker_state.Event.encoding
             RPC_error.encoding)
        RPC_path.(root / "workers" / "block_validator")
  end

  open RPC_context

  let state ctxt = make_call S.state ctxt () () ()
end

module Peer_validators = struct
  module S = struct
    let list =
      RPC_service.get_service
        ~description:"Lists the peer validator workers and their status."
        ~query:RPC_query.empty
        ~output:
          (list
             (obj4
                (req "peer_id" P2p_peer.Id.encoding)
                (req
                   "status"
                   (Worker_types.worker_status_encoding RPC_error.encoding))
                (req
                   "information"
                   (Worker_types.worker_information_encoding RPC_error.encoding))
                (req
                   "pipelines"
                   Peer_validator_worker_state.Worker_state
                   .pipeline_length_encoding)))
        RPC_path.(
          root / "workers" / "chain_validators" /: Chain_services.chain_arg
          / "peers_validators")

    let state =
      RPC_service.get_service
        ~description:"Introspect the state of a peer validator worker."
        ~query:RPC_query.empty
        ~output:
          (Worker_types.full_status_encoding
             Peer_validator_worker_state.Request.encoding
             Peer_validator_worker_state.Event.encoding
             RPC_error.encoding)
        RPC_path.(
          root / "workers" / "chain_validators" /: Chain_services.chain_arg
          / "peers_validators" /: P2p_peer.Id.rpc_arg)
  end

  open RPC_context

  let list ctxt n = make_call1 S.list ctxt n () ()

  let state ctxt n h = make_call2 S.state ctxt n h () ()
end

module Chain_validators = struct
  module S = struct
    let list =
      RPC_service.get_service
        ~description:"Lists the chain validator workers and their status."
        ~query:RPC_query.empty
        ~output:
          (list
             (obj4
                (req "chain_id" Chain_id.encoding)
                (req
                   "status"
                   (Worker_types.worker_status_encoding RPC_error.encoding))
                (req
                   "information"
                   (Worker_types.worker_information_encoding RPC_error.encoding))
                (req "pipelines" int8)))
        RPC_path.(root / "workers" / "chain_validators")

    let state =
      RPC_service.get_service
        ~description:"Introspect the state of a chain validator worker."
        ~query:RPC_query.empty
        ~output:
          (Worker_types.full_status_encoding
             Chain_validator_worker_state.Request.encoding
             Chain_validator_worker_state.Event.encoding
             RPC_error.encoding)
        RPC_path.(
          root / "workers" / "chain_validators" /: Chain_services.chain_arg)

    let ddb_state =
      RPC_service.get_service
        ~description:
          "Introspect the state of the DDB attached to a chain validator \
           worker."
        ~query:RPC_query.empty
        ~output:Chain_validator_worker_state.Distributed_db_state.encoding
        RPC_path.(
          root / "workers" / "chain_validators" /: Chain_services.chain_arg
          / "ddb")
  end

  open RPC_context

  let list ctxt = make_call S.list ctxt () () ()

  let state ctxt h = make_call1 S.state ctxt h () ()

  let ddb_state ctxt h = make_call1 S.ddb_state ctxt h () ()
end
src/lib_shell_services/worker_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Data_encoding.

Module Prevalidators.
  Module S.
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z)) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Lists the Prevalidator workers and their status." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_base__TzPervasives.Data_encoding.list None
          (Tezos_base__TzPervasives.Data_encoding.obj4
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "status" % string
              (Tezos_shell_services.Worker_types.worker_status_encoding
                Tezos_base__TzPervasives.RPC_error.encoding))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "information" % string
              (Tezos_shell_services.Worker_types.worker_information_encoding
                Tezos_base__TzPervasives.RPC_error.encoding))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "pipelines" % string Tezos_base__TzPervasives.Data_encoding.int8)))
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div
            Tezos_base__TzPervasives.RPC_path.root "workers" % string)
          "prevalidators" % string).
    
    Definition state
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_shell_services.Chain_services.chain) unit unit
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Prevalidator_worker_state.Request.view
          Tezos_shell_services.Prevalidator_worker_state.Event.t) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Introspect the state of prevalidator workers." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_shell_services.Worker_types.full_status_encoding
          Tezos_shell_services.Prevalidator_worker_state.Request.encoding
          Tezos_shell_services.Prevalidator_worker_state.Event.encoding
          Tezos_base__TzPervasives.RPC_error.encoding)
        (Tezos_base__TzPervasives.RPC_path.op_div_colon
          (Tezos_base__TzPervasives.RPC_path.op_div
            (Tezos_base__TzPervasives.RPC_path.op_div
              Tezos_base__TzPervasives.RPC_path.root "workers" % string)
            "prevalidators" % string)
          Tezos_shell_services.Chain_services.chain_arg).
  End S.
  
  Import Tezos_base__TzPervasives.RPC_context.
  
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z))) :=
    Tezos_base__TzPervasives.RPC_context.make_call S.list ctxt tt tt tt.
  
  Definition state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (h : Tezos_shell_services.Chain_services.chain)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Prevalidator_worker_state.Request.view
          Tezos_shell_services.Prevalidator_worker_state.Event.t)) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.state ctxt h tt tt.
End Prevalidators.

Module Block_validator.
  Module S.
    Definition state
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Block_validator_worker_state.Request.view
          Tezos_shell_services.Block_validator_worker_state.Event.t) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Introspect the state of the block_validator worker." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_shell_services.Worker_types.full_status_encoding
          Tezos_shell_services.Block_validator_worker_state.Request.encoding
          Tezos_shell_services.Block_validator_worker_state.Event.encoding
          Tezos_base__TzPervasives.RPC_error.encoding)
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div
            Tezos_base__TzPervasives.RPC_path.root "workers" % string)
          "block_validator" % string).
  End S.
  
  Import Tezos_base__TzPervasives.RPC_context.
  
  Definition state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Block_validator_worker_state.Request.view
          Tezos_shell_services.Block_validator_worker_state.Event.t)) :=
    Tezos_base__TzPervasives.RPC_context.make_call S.state ctxt tt tt tt.
End Block_validator.

Module Peer_validators.
  Module S.
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_shell_services.Chain_services.chain) unit unit
        (list
          (Tezos_base__TzPervasives.P2p_peer.Id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information *
            Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length)) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Lists the peer validator workers and their status." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_base__TzPervasives.Data_encoding.list None
          (Tezos_base__TzPervasives.Data_encoding.obj4
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "peer_id" % string Tezos_base__TzPervasives.P2p_peer.Id.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "status" % string
              (Tezos_shell_services.Worker_types.worker_status_encoding
                Tezos_base__TzPervasives.RPC_error.encoding))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "information" % string
              (Tezos_shell_services.Worker_types.worker_information_encoding
                Tezos_base__TzPervasives.RPC_error.encoding))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "pipelines" % string
              Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length_encoding)))
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "workers" % string)
              "chain_validators" % string)
            Tezos_shell_services.Chain_services.chain_arg)
          "peers_validators" % string).
    
    Definition state
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        ((unit * Tezos_shell_services.Chain_services.chain) *
          Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Peer_validator_worker_state.Request.view
          Tezos_shell_services.Peer_validator_worker_state.Event.t) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Introspect the state of a peer validator worker." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_shell_services.Worker_types.full_status_encoding
          Tezos_shell_services.Peer_validator_worker_state.Request.encoding
          Tezos_shell_services.Peer_validator_worker_state.Event.encoding
          Tezos_base__TzPervasives.RPC_error.encoding)
        (Tezos_base__TzPervasives.RPC_path.op_div_colon
          (Tezos_base__TzPervasives.RPC_path.op_div
            (Tezos_base__TzPervasives.RPC_path.op_div_colon
              (Tezos_base__TzPervasives.RPC_path.op_div
                (Tezos_base__TzPervasives.RPC_path.op_div
                  Tezos_base__TzPervasives.RPC_path.root "workers" % string)
                "chain_validators" % string)
              Tezos_shell_services.Chain_services.chain_arg)
            "peers_validators" % string)
          Tezos_base__TzPervasives.P2p_peer.Id.rpc_arg).
  End S.
  
  Import Tezos_base__TzPervasives.RPC_context.
  
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (n : Tezos_shell_services.Chain_services.chain)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (list
          (Tezos_base__TzPervasives.P2p_peer.Id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information *
            Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length))) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.list ctxt n tt tt.
  
  Definition state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (n : Tezos_shell_services.Chain_services.chain)
    (h : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Peer_validator_worker_state.Request.view
          Tezos_shell_services.Peer_validator_worker_state.Event.t)) :=
    Tezos_base__TzPervasives.RPC_context.make_call2 S.state ctxt n h tt tt.
End Peer_validators.

Module Chain_validators.
  Module S.
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z)) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Lists the chain validator workers and their status." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_base__TzPervasives.Data_encoding.list None
          (Tezos_base__TzPervasives.Data_encoding.obj4
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "status" % string
              (Tezos_shell_services.Worker_types.worker_status_encoding
                Tezos_base__TzPervasives.RPC_error.encoding))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "information" % string
              (Tezos_shell_services.Worker_types.worker_information_encoding
                Tezos_base__TzPervasives.RPC_error.encoding))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "pipelines" % string Tezos_base__TzPervasives.Data_encoding.int8)))
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div
            Tezos_base__TzPervasives.RPC_path.root "workers" % string)
          "chain_validators" % string).
    
    Definition state
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_shell_services.Chain_services.chain) unit unit
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Chain_validator_worker_state.Request.view
          Tezos_shell_services.Chain_validator_worker_state.Event.t) :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some "Introspect the state of a chain validator worker." % string)
        Tezos_base__TzPervasives.RPC_query.empty
        (Tezos_shell_services.Worker_types.full_status_encoding
          Tezos_shell_services.Chain_validator_worker_state.Request.encoding
          Tezos_shell_services.Chain_validator_worker_state.Event.encoding
          Tezos_base__TzPervasives.RPC_error.encoding)
        (Tezos_base__TzPervasives.RPC_path.op_div_colon
          (Tezos_base__TzPervasives.RPC_path.op_div
            (Tezos_base__TzPervasives.RPC_path.op_div
              Tezos_base__TzPervasives.RPC_path.root "workers" % string)
            "chain_validators" % string)
          Tezos_shell_services.Chain_services.chain_arg).
    
    Definition ddb_state
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_shell_services.Chain_services.chain) unit unit
        Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
      Tezos_base__TzPervasives.RPC_service.get_service
        (Some
          "Introspect the state of the DDB attached to a chain validator worker."
            % string) Tezos_base__TzPervasives.RPC_query.empty
        Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.encoding
        (Tezos_base__TzPervasives.RPC_path.op_div
          (Tezos_base__TzPervasives.RPC_path.op_div_colon
            (Tezos_base__TzPervasives.RPC_path.op_div
              (Tezos_base__TzPervasives.RPC_path.op_div
                Tezos_base__TzPervasives.RPC_path.root "workers" % string)
              "chain_validators" % string)
            Tezos_shell_services.Chain_services.chain_arg) "ddb" % string).
  End S.
  
  Import Tezos_base__TzPervasives.RPC_context.
  
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z))) :=
    Tezos_base__TzPervasives.RPC_context.make_call S.list ctxt tt tt tt.
  
  Definition state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (h : Tezos_shell_services.Chain_services.chain)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Chain_validator_worker_state.Request.view
          Tezos_shell_services.Chain_validator_worker_state.Event.t)) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.state ctxt h tt tt.
  
  Definition ddb_state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (h : Tezos_shell_services.Chain_services.chain)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view) :=
    Tezos_base__TzPervasives.RPC_context.make_call1 S.ddb_state ctxt h tt tt.
End Chain_validators.
src/lib_shell_services/worker_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open RPC_context

module Prevalidators : sig
  open Prevalidator_worker_state

  val list :
    #simple ->
    ( Chain_id.t
    * Worker_types.worker_status
    * Worker_types.worker_information
    * int )
    list
    tzresult
    Lwt.t

  val state :
    #simple ->
    Chain_services.chain ->
    (Request.view, Event.t) Worker_types.full_status tzresult Lwt.t

  module S : sig
    val list :
      ( [`GET],
        unit,
        unit,
        unit,
        unit,
        ( Chain_id.t
        * Worker_types.worker_status
        * Worker_types.worker_information
        * int )
        list )
      RPC_service.t

    val state :
      ( [`GET],
        unit,
        unit * Chain_services.chain,
        unit,
        unit,
        (Request.view, Event.t) Worker_types.full_status )
      RPC_service.t
  end
end

module Block_validator : sig
  open Block_validator_worker_state

  val state :
    #simple -> (Request.view, Event.t) Worker_types.full_status tzresult Lwt.t

  module S : sig
    val state :
      ( [`GET],
        unit,
        unit,
        unit,
        unit,
        (Request.view, Event.t) Worker_types.full_status )
      RPC_service.t
  end
end

module Peer_validators : sig
  open Peer_validator_worker_state

  val list :
    #simple ->
    Chain_services.chain ->
    ( P2p_peer.Id.t
    * Worker_types.worker_status
    * Worker_types.worker_information
    * Peer_validator_worker_state.Worker_state.pipeline_length )
    list
    tzresult
    Lwt.t

  val state :
    #simple ->
    Chain_services.chain ->
    P2p_peer.Id.t ->
    (Request.view, Event.t) Worker_types.full_status tzresult Lwt.t

  module S : sig
    val list :
      ( [`GET],
        unit,
        unit * Chain_services.chain,
        unit,
        unit,
        ( P2p_peer.Id.t
        * Worker_types.worker_status
        * Worker_types.worker_information
        * Peer_validator_worker_state.Worker_state.pipeline_length )
        list )
      RPC_service.t

    val state :
      ( [`GET],
        unit,
        (unit * Chain_services.chain) * P2p_peer.Id.t,
        unit,
        unit,
        (Request.view, Event.t) Worker_types.full_status )
      RPC_service.t
  end
end

module Chain_validators : sig
  open Chain_validator_worker_state

  val list :
    #simple ->
    ( Chain_id.t
    * Worker_types.worker_status
    * Worker_types.worker_information
    * int )
    list
    tzresult
    Lwt.t

  val state :
    #simple ->
    Chain_services.chain ->
    (Request.view, Event.t) Worker_types.full_status tzresult Lwt.t

  val ddb_state :
    #simple -> Chain_services.chain -> Distributed_db_state.view tzresult Lwt.t

  module S : sig
    val list :
      ( [`GET],
        unit,
        unit,
        unit,
        unit,
        ( Chain_id.t
        * Worker_types.worker_status
        * Worker_types.worker_information
        * int )
        list )
      RPC_service.t

    val state :
      ( [`GET],
        unit,
        unit * Chain_services.chain,
        unit,
        unit,
        (Request.view, Event.t) Worker_types.full_status )
      RPC_service.t

    val ddb_state :
      ( [`GET],
        unit,
        unit * Chain_services.chain,
        unit,
        unit,
        Distributed_db_state.view )
      RPC_service.t
  end
end
src/lib_shell_services/worker_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Prevalidators.
  Parameter list : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z))).
  
  Parameter state : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_shell_services.Chain_services.chain ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_shell_services.Worker_types.full_status
            Tezos_shell_services.Prevalidator_worker_state.Request.view
            Tezos_shell_services.Prevalidator_worker_state.Event.t)).
  
  Module S.
    Parameter list : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit unit unit unit
      (list
        (Tezos_base__TzPervasives.Chain_id.t *
          Tezos_shell_services.Worker_types.worker_status *
          Tezos_shell_services.Worker_types.worker_information * Z)).
    
    Parameter state : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_shell_services.Chain_services.chain) unit unit
      (Tezos_shell_services.Worker_types.full_status
        Tezos_shell_services.Prevalidator_worker_state.Request.view
        Tezos_shell_services.Prevalidator_worker_state.Event.t).
  End S.
End Prevalidators.

Module Block_validator.
  Parameter state : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Block_validator_worker_state.Request.view
          Tezos_shell_services.Block_validator_worker_state.Event.t)).
  
  Module S.
    Parameter state : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit unit unit unit
      (Tezos_shell_services.Worker_types.full_status
        Tezos_shell_services.Block_validator_worker_state.Request.view
        Tezos_shell_services.Block_validator_worker_state.Event.t).
  End S.
End Block_validator.

Module Peer_validators.
  Parameter list : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_shell_services.Chain_services.chain ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list
            (Tezos_base__TzPervasives.P2p_peer.Id.t *
              Tezos_shell_services.Worker_types.worker_status *
              Tezos_shell_services.Worker_types.worker_information *
              Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length))).
  
  Parameter state : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_shell_services.Chain_services.chain ->
      Tezos_base__TzPervasives.P2p_peer.Id.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_shell_services.Worker_types.full_status
              Tezos_shell_services.Peer_validator_worker_state.Request.view
              Tezos_shell_services.Peer_validator_worker_state.Event.t)).
  
  Module S.
    Parameter list : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_shell_services.Chain_services.chain) unit unit
      (list
        (Tezos_base__TzPervasives.P2p_peer.Id.t *
          Tezos_shell_services.Worker_types.worker_status *
          Tezos_shell_services.Worker_types.worker_information *
          Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length)).
    
    Parameter state : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit
      ((unit * Tezos_shell_services.Chain_services.chain) *
        Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
      (Tezos_shell_services.Worker_types.full_status
        Tezos_shell_services.Peer_validator_worker_state.Request.view
        Tezos_shell_services.Peer_validator_worker_state.Event.t).
  End S.
End Peer_validators.

Module Chain_validators.
  Parameter list : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z))).
  
  Parameter state : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_shell_services.Chain_services.chain ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_shell_services.Worker_types.full_status
            Tezos_shell_services.Chain_validator_worker_state.Request.view
            Tezos_shell_services.Chain_validator_worker_state.Event.t)).
  
  Parameter ddb_state : forall {_ i o p q variant : Type}, (((((Tezos_rpc.RPC_service.t
    variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (_ * p * q * i * o)) * _) * _) ->
    Tezos_shell_services.Chain_services.chain ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view).
  
  Module S.
    Parameter list : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit unit unit unit
      (list
        (Tezos_base__TzPervasives.Chain_id.t *
          Tezos_shell_services.Worker_types.worker_status *
          Tezos_shell_services.Worker_types.worker_information * Z)).
    
    Parameter state : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_shell_services.Chain_services.chain) unit unit
      (Tezos_shell_services.Worker_types.full_status
        Tezos_shell_services.Chain_validator_worker_state.Request.view
        Tezos_shell_services.Chain_validator_worker_state.Event.t).
    
    Parameter ddb_state : forall {variant : Type}, Tezos_base__TzPervasives.RPC_service.t
      variant unit (unit * Tezos_shell_services.Chain_services.chain) unit unit
      Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view.
  End S.
End Chain_validators.
src/lib_shell_services/worker_types.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type limits = {backlog_size : int; backlog_level : Internal_event.level}

type worker_status =
  | Launching of Time.System.t
  | Running of Time.System.t
  | Closing of Time.System.t * Time.System.t
  | Closed of Time.System.t * Time.System.t * error list option

let worker_status_encoding error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Launching"
        (obj2
           (req "phase" (constant "launching"))
           (req "since" Time.System.encoding))
        (function Launching t -> Some ((), t) | _ -> None)
        (fun ((), t) -> Launching t);
      case
        (Tag 1)
        ~title:"Running"
        (obj2
           (req "phase" (constant "running"))
           (req "since" Time.System.encoding))
        (function Running t -> Some ((), t) | _ -> None)
        (fun ((), t) -> Running t);
      case
        (Tag 2)
        ~title:"Closing"
        (obj3
           (req "phase" (constant "closing"))
           (req "birth" Time.System.encoding)
           (req "since" Time.System.encoding))
        (function Closing (t0, t) -> Some ((), t0, t) | _ -> None)
        (fun ((), t0, t) -> Closing (t0, t));
      case
        (Tag 3)
        ~title:"Closed"
        (obj3
           (req "phase" (constant "closed"))
           (req "birth" Time.System.encoding)
           (req "since" Time.System.encoding))
        (function Closed (t0, t, None) -> Some ((), t0, t) | _ -> None)
        (fun ((), t0, t) -> Closed (t0, t, None));
      case
        (Tag 4)
        ~title:"Crashed"
        (obj4
           (req "phase" (constant "crashed"))
           (req "birth" Time.System.encoding)
           (req "since" Time.System.encoding)
           (req "errors" error_encoding))
        (function
          | Closed (t0, t, Some errs) -> Some ((), t0, t, errs) | _ -> None)
        (fun ((), t0, t, errs) -> Closed (t0, t, Some errs)) ]

type worker_information = {
  instances_number : int;
  wstatus : worker_status;
  queue_length : int;
}

let worker_information_encoding error_encoding =
  Data_encoding.(
    conv
      (fun {instances_number; wstatus; queue_length} ->
        (instances_number, wstatus, queue_length))
      (fun (instances_number, wstatus, queue_length) ->
        {instances_number; wstatus; queue_length})
      (obj3
         (req "instances" int31)
         (req "status" (worker_status_encoding error_encoding))
         (req "queue_length" int31)))

type request_status = {
  pushed : Time.System.t;
  treated : Time.System.t;
  completed : Time.System.t;
}

let request_status_encoding =
  let open Data_encoding in
  conv
    (fun {pushed; treated; completed} -> (pushed, treated, completed))
    (fun (pushed, treated, completed) -> {pushed; treated; completed})
    (obj3
       (req "pushed" Time.System.encoding)
       (req "treated" Time.System.encoding)
       (req "completed" Time.System.encoding))

type ('req, 'evt) full_status = {
  status : worker_status;
  pending_requests : (Time.System.t * 'req) list;
  backlog : (Internal_event.level * 'evt list) list;
  current_request : (Time.System.t * Time.System.t * 'req) option;
}

let full_status_encoding req_encoding evt_encoding error_encoding =
  let open Data_encoding in
  let requests_encoding =
    list
      (obj2
         (req "pushed" Time.System.encoding)
         (req "request" (dynamic_size req_encoding)))
  in
  let events_encoding =
    list
      (obj2
         (req "level" Internal_event.Level.encoding)
         (req "events" (dynamic_size (list (dynamic_size evt_encoding)))))
  in
  let current_request_encoding =
    obj3
      (req "pushed" Time.System.encoding)
      (req "treated" Time.System.encoding)
      (req "request" req_encoding)
  in
  conv
    (fun {status; pending_requests; backlog; current_request} ->
      (status, pending_requests, backlog, current_request))
    (fun (status, pending_requests, backlog, current_request) ->
      {status; pending_requests; backlog; current_request})
    (obj4
       (req "status" (worker_status_encoding error_encoding))
       (req "pending_requests" requests_encoding)
       (req "backlog" events_encoding)
       (opt "current_request" current_request_encoding))

let pp_status ppf {pushed; treated; completed} =
  let completed = Ptime.diff completed treated
  and treated = Ptime.diff treated pushed in
  Format.fprintf
    ppf
    "Request pushed on %a, treated in %a, completed in %a "
    Time.System.pp_hum
    pushed
    Ptime.Span.pp
    treated
    Ptime.Span.pp
    completed
src/lib_shell_services/worker_types.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  backlog_size : Z;
  backlog_level : Tezos_base__TzPervasives.Internal_event.level }.

Inductive worker_status : Type :=
| Launching : Tezos_base__TzPervasives.Time.System.t -> worker_status
| Running : Tezos_base__TzPervasives.Time.System.t -> worker_status
| Closing : Tezos_base__TzPervasives.Time.System.t ->
  Tezos_base__TzPervasives.Time.System.t -> worker_status
| Closed : Tezos_base__TzPervasives.Time.System.t ->
  Tezos_base__TzPervasives.Time.System.t ->
  (option (list Tezos_base__TzPervasives.error)) -> worker_status.

Definition worker_status_encoding
  (error_encoding :
    Tezos_base__TzPervasives.Data_encoding.encoding
      (list Tezos_base__TzPervasives.error))
  : Tezos_base__TzPervasives.Data_encoding.encoding worker_status :=
  Tezos_base__TzPervasives.Data_encoding.union None
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case "Launching" % string None
        (Tag 0)
        (Tezos_base__TzPervasives.Data_encoding.obj2
          (Tezos_base__TzPervasives.Data_encoding.req None None "phase" % string
            (Tezos_base__TzPervasives.Data_encoding.constant
              "launching" % string))
          (Tezos_base__TzPervasives.Data_encoding.req None None "since" % string
            Tezos_base__TzPervasives.Time.System.encoding))
        (fun function_parameter =>
          match function_parameter with
          | Launching t => Some (tt, t)
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | (tt, t) => Launching t
          end))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "Running" % string None
          (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.obj2
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "phase" % string
              (Tezos_base__TzPervasives.Data_encoding.constant
                "running" % string))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "since" % string Tezos_base__TzPervasives.Time.System.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Running t => Some (tt, t)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (tt, t) => Running t
            end))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Closing" % string None
            (Tag 2)
            (Tezos_base__TzPervasives.Data_encoding.obj3
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "phase" % string
                (Tezos_base__TzPervasives.Data_encoding.constant
                  "closing" % string))
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "birth" % string Tezos_base__TzPervasives.Time.System.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "since" % string Tezos_base__TzPervasives.Time.System.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Closing t0 t => Some (tt, t0, t)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tt, t0, t) => Closing t0 t
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case "Closed" % string None
              (Tag 3)
              (Tezos_base__TzPervasives.Data_encoding.obj3
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "phase" % string
                  (Tezos_base__TzPervasives.Data_encoding.constant
                    "closed" % string))
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "birth" % string Tezos_base__TzPervasives.Time.System.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "since" % string Tezos_base__TzPervasives.Time.System.encoding))
              (fun function_parameter =>
                match function_parameter with
                | Closed t0 t None => Some (tt, t0, t)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (tt, t0, t) => Closed t0 t None
                end))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case "Crashed" % string
                None (Tag 4)
                (Tezos_base__TzPervasives.Data_encoding.obj4
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "phase" % string
                    (Tezos_base__TzPervasives.Data_encoding.constant
                      "crashed" % string))
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "birth" % string
                    Tezos_base__TzPervasives.Time.System.encoding)
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "since" % string
                    Tezos_base__TzPervasives.Time.System.encoding)
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "errors" % string error_encoding))
                (fun function_parameter =>
                  match function_parameter with
                  | Closed t0 t (Some errs) => Some (tt, t0, t, errs)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (tt, t0, t, errs) => Closed t0 t (Some errs)
                  end)) []))))).

Record worker_information := {
  instances_number : Z;
  wstatus : worker_status;
  queue_length : Z }.

Definition worker_information_encoding
  (error_encoding :
    Tezos_base__TzPervasives.Data_encoding.encoding
      (list Tezos_base__TzPervasives.error))
  : Tezos_base__TzPervasives.Data_encoding.encoding worker_information :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        instances_number := instances_number;
          wstatus := wstatus;
          queue_length := queue_length
          |} => (instances_number, wstatus, queue_length)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (instances_number, wstatus, queue_length) =>
        {| instances_number := instances_number; wstatus := wstatus;
          queue_length := queue_length |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj3
      (Tezos_base__TzPervasives.Data_encoding.req None None "instances" % string
        Tezos_base__TzPervasives.Data_encoding.int31)
      (Tezos_base__TzPervasives.Data_encoding.req None None "status" % string
        (worker_status_encoding error_encoding))
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "queue_length" % string Tezos_base__TzPervasives.Data_encoding.int31)).

Record request_status := {
  pushed : Tezos_base__TzPervasives.Time.System.t;
  treated : Tezos_base__TzPervasives.Time.System.t;
  completed : Tezos_base__TzPervasives.Time.System.t }.

Definition request_status_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding request_status :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| pushed := pushed; treated := treated; completed := completed |} =>
        (pushed, treated, completed)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (pushed, treated, completed) =>
        {| pushed := pushed; treated := treated; completed := completed |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj3
      (Tezos_base__TzPervasives.Data_encoding.req None None "pushed" % string
        Tezos_base__TzPervasives.Time.System.encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "treated" % string
        Tezos_base__TzPervasives.Time.System.encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "completed" % string
        Tezos_base__TzPervasives.Time.System.encoding)).

Record full_status {req evt : Type} := {
  status : worker_status;
  pending_requests : list (Tezos_base__TzPervasives.Time.System.t * req);
  backlog : list (Tezos_base__TzPervasives.Internal_event.level * (list evt));
  current_request :
    option
      (Tezos_base__TzPervasives.Time.System.t *
        Tezos_base__TzPervasives.Time.System.t * req) }.
Arguments full_status : clear implicits.

Definition full_status_encoding {A B : Type}
  (req_encoding : Tezos_base__TzPervasives.Data_encoding.encoding A)
  (evt_encoding : Tezos_base__TzPervasives.Data_encoding.encoding B)
  (error_encoding :
    Tezos_base__TzPervasives.Data_encoding.encoding
      (list Tezos_base__TzPervasives.error))
  : Tezos_base__TzPervasives.Data_encoding.encoding (full_status A B) :=
  let requests_encoding :=
    Tezos_base__TzPervasives.Data_encoding.list None
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None "pushed" % string
          Tezos_base__TzPervasives.Time.System.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "request" % string
          (Tezos_base__TzPervasives.Data_encoding.dynamic_size None req_encoding)))
    in
  let events_encoding :=
    Tezos_base__TzPervasives.Data_encoding.list None
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None "level" % string
          Tezos_base__TzPervasives.Internal_event.Level.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "events" % string
          (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
            (Tezos_base__TzPervasives.Data_encoding.list None
              (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                evt_encoding))))) in
  let current_request_encoding :=
    Tezos_base__TzPervasives.Data_encoding.obj3
      (Tezos_base__TzPervasives.Data_encoding.req None None "pushed" % string
        Tezos_base__TzPervasives.Time.System.encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "treated" % string
        Tezos_base__TzPervasives.Time.System.encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "request" % string
        req_encoding) in
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        status := status;
          pending_requests := pending_requests;
          backlog := backlog;
          current_request := current_request
          |} => (status, pending_requests, backlog, current_request)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (status, pending_requests, backlog, current_request) =>
        {| status := status; pending_requests := pending_requests;
          backlog := backlog; current_request := current_request |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj4
      (Tezos_base__TzPervasives.Data_encoding.req None None "status" % string
        (worker_status_encoding error_encoding))
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "pending_requests" % string requests_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "backlog" % string
        events_encoding)
      (Tezos_base__TzPervasives.Data_encoding.opt None None
        "current_request" % string current_request_encoding)).

Definition pp_status
  (ppf : Stdlib.Format.formatter) (function_parameter : request_status)
  : unit :=
  match function_parameter with
  | {| pushed := pushed; treated := treated; completed := completed |} =>
    let completed : Ptime.span :=
      Ptime.diff completed treated
    with treated : Ptime.span :=
      Ptime.diff treated pushed in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Request pushed on " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal ", treated in " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  ", completed in " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal " " % char
                      CamlinternalFormatBasics.End_of_format)))))))
        "Request pushed on %a, treated in %a, completed in %a " % string)
      Tezos_base__TzPervasives.Time.System.pp_hum pushed Ptime.Span.pp treated
      Ptime.Span.pp completed
  end.
src/lib_shell_services/worker_types.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Some memory and time limits. *)
type limits = {
  backlog_size : int;
      (** Number of event stored in the backlog for each debug level. *)
  backlog_level : Internal_event.level;
      (** Stores events at least as important as this value. *)
}

(** The running status of an individual worker. *)
type worker_status =
  | Launching of Time.System.t
  | Running of Time.System.t
  | Closing of Time.System.t * Time.System.t
  | Closed of Time.System.t * Time.System.t * error list option

(** Worker status serializer for RPCs. *)
val worker_status_encoding :
  error list Data_encoding.t -> worker_status Data_encoding.t

type worker_information = {
  instances_number : int;
  wstatus : worker_status;
  queue_length : int;
}

val worker_information_encoding :
  error list Data_encoding.t -> worker_information Data_encoding.t

(** The running status of an individual request. *)
type request_status = {
  pushed : Time.System.t;
  treated : Time.System.t;
  completed : Time.System.t;
}

(** Request status serializer for RPCs. *)
val request_status_encoding : request_status Data_encoding.t

(** The full status of an individual worker. *)
type ('req, 'evt) full_status = {
  status : worker_status;
  pending_requests : (Time.System.t * 'req) list;
  backlog : (Internal_event.level * 'evt list) list;
  current_request : (Time.System.t * Time.System.t * 'req) option;
}

(** Full worker status serializer for RPCs. *)
val full_status_encoding :
  'req Data_encoding.t ->
  'evt Data_encoding.t ->
  error list Data_encoding.t ->
  ('req, 'evt) full_status Data_encoding.t

val pp_status : Format.formatter -> request_status -> unit
src/lib_shell_services/worker_types.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  backlog_size : Z;
  backlog_level : Tezos_base__TzPervasives.Internal_event.level }.

Inductive worker_status : Type :=
| Launching : Tezos_base__TzPervasives.Time.System.t -> worker_status
| Running : Tezos_base__TzPervasives.Time.System.t -> worker_status
| Closing : Tezos_base__TzPervasives.Time.System.t ->
  Tezos_base__TzPervasives.Time.System.t -> worker_status
| Closed : Tezos_base__TzPervasives.Time.System.t ->
  Tezos_base__TzPervasives.Time.System.t ->
  (option (list Tezos_base__TzPervasives.error)) -> worker_status.

Parameter worker_status_encoding :
(Tezos_base__TzPervasives.Data_encoding.t (list Tezos_base__TzPervasives.error))
  -> Tezos_base__TzPervasives.Data_encoding.t worker_status.

Record worker_information := {
  instances_number : Z;
  wstatus : worker_status;
  queue_length : Z }.

Parameter worker_information_encoding :
(Tezos_base__TzPervasives.Data_encoding.t (list Tezos_base__TzPervasives.error))
  -> Tezos_base__TzPervasives.Data_encoding.t worker_information.

Record request_status := {
  pushed : Tezos_base__TzPervasives.Time.System.t;
  treated : Tezos_base__TzPervasives.Time.System.t;
  completed : Tezos_base__TzPervasives.Time.System.t }.

Parameter request_status_encoding :
Tezos_base__TzPervasives.Data_encoding.t request_status.

Record full_status {req evt : Type} := {
  status : worker_status;
  pending_requests : list (Tezos_base__TzPervasives.Time.System.t * req);
  backlog : list (Tezos_base__TzPervasives.Internal_event.level * (list evt));
  current_request :
    option
      (Tezos_base__TzPervasives.Time.System.t *
        Tezos_base__TzPervasives.Time.System.t * req) }.
Arguments full_status : clear implicits.

Parameter full_status_encoding : forall {evt req : Type},
(Tezos_base__TzPervasives.Data_encoding.t req) ->
  (Tezos_base__TzPervasives.Data_encoding.t evt) ->
    (Tezos_base__TzPervasives.Data_encoding.t
      (list Tezos_base__TzPervasives.error)) ->
      Tezos_base__TzPervasives.Data_encoding.t (full_status req evt).

Parameter pp_status : Stdlib.Format.formatter -> request_status -> unit.
src/lib_signer_backends/encrypted.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type Base58.data += Encrypted_ed25519 of Bytes.t

type Base58.data += Encrypted_secp256k1 of Bytes.t

type Base58.data += Encrypted_p256 of Bytes.t

open Client_keys

let scheme = "encrypted"

module Raw = struct
  (* https://tools.ietf.org/html/rfc2898#section-4.1 *)
  let salt_len = 8

  (* Fixed zero nonce *)
  let nonce = Crypto_box.zero_nonce

  (* Secret keys for Ed25519, secp256k1, P256 are 32 bytes long. *)
  let encrypted_size = Crypto_box.boxzerobytes + 32

  let pbkdf ~salt ~password =
    Pbkdf.SHA512.pbkdf2 ~count:32768 ~dk_len:32l ~salt ~password

  let encrypt ~password sk =
    let salt = Hacl.Rand.gen salt_len in
    let key = Crypto_box.Secretbox.unsafe_of_bytes (pbkdf ~salt ~password) in
    let msg =
      match (sk : Signature.secret_key) with
      | Ed25519 sk ->
          Data_encoding.Binary.to_bytes_exn Ed25519.Secret_key.encoding sk
      | Secp256k1 sk ->
          Data_encoding.Binary.to_bytes_exn Secp256k1.Secret_key.encoding sk
      | P256 sk ->
          Data_encoding.Binary.to_bytes_exn P256.Secret_key.encoding sk
    in
    Bigstring.concat "" [salt; Crypto_box.Secretbox.box key msg nonce]

  let decrypt algo ~password ~encrypted_sk =
    let salt = Bigstring.sub encrypted_sk 0 salt_len in
    let encrypted_sk = Bigstring.sub encrypted_sk salt_len encrypted_size in
    let key = Crypto_box.Secretbox.unsafe_of_bytes (pbkdf ~salt ~password) in
    match (Crypto_box.Secretbox.box_open key encrypted_sk nonce, algo) with
    | (None, _) ->
        return_none
    | (Some bytes, Signature.Ed25519) -> (
      match
        Data_encoding.Binary.of_bytes Ed25519.Secret_key.encoding bytes
      with
      | Some sk ->
          return_some (Ed25519 sk : Signature.Secret_key.t)
      | None ->
          failwith
            "Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
      )
    | (Some bytes, Signature.Secp256k1) -> (
      match
        Data_encoding.Binary.of_bytes Secp256k1.Secret_key.encoding bytes
      with
      | Some sk ->
          return_some (Secp256k1 sk : Signature.Secret_key.t)
      | None ->
          failwith
            "Corrupted wallet, deciphered key is not a valid Secp256k1 secret \
             key" )
    | (Some bytes, Signature.P256) -> (
      match Data_encoding.Binary.of_bytes P256.Secret_key.encoding bytes with
      | Some sk ->
          return_some (P256 sk : Signature.Secret_key.t)
      | None ->
          failwith
            "Corrupted wallet, deciphered key is not a valid P256 secret key" )
end

module Encodings = struct
  let ed25519 =
    let length = Hacl.Sign.skbytes + Crypto_box.boxzerobytes + Raw.salt_len in
    Base58.register_encoding
      ~prefix:Base58.Prefix.ed25519_encrypted_seed
      ~length
      ~to_raw:(fun sk -> Bytes.to_string sk)
      ~of_raw:(fun buf ->
        if String.length buf <> length then None
        else Some (Bytes.of_string buf))
      ~wrap:(fun sk -> Encrypted_ed25519 sk)

  let secp256k1 =
    let open Libsecp256k1.External in
    let length = Key.secret_bytes + Crypto_box.boxzerobytes + Raw.salt_len in
    Base58.register_encoding
      ~prefix:Base58.Prefix.secp256k1_encrypted_secret_key
      ~length
      ~to_raw:(fun sk -> Bytes.to_string sk)
      ~of_raw:(fun buf ->
        if String.length buf <> length then None
        else Some (Bytes.of_string buf))
      ~wrap:(fun sk -> Encrypted_secp256k1 sk)

  let p256 =
    let length =
      Uecc.(sk_size secp256r1) + Crypto_box.boxzerobytes + Raw.salt_len
    in
    Base58.register_encoding
      ~prefix:Base58.Prefix.p256_encrypted_secret_key
      ~length
      ~to_raw:(fun sk -> Bytes.to_string sk)
      ~of_raw:(fun buf ->
        if String.length buf <> length then None
        else Some (Bytes.of_string buf))
      ~wrap:(fun sk -> Encrypted_p256 sk)

  let () =
    Base58.check_encoded_prefix ed25519 "edesk" 88 ;
    Base58.check_encoded_prefix secp256k1 "spesk" 88 ;
    Base58.check_encoded_prefix p256 "p2esk" 88
end

let decrypted = Hashtbl.create 13

(* we cache the password in this list to avoid
   asking the user all the time *)
let passwords = ref []

let rec interactive_decrypt_loop (cctxt : #Client_context.prompter) ?name
    ~encrypted_sk algo =
  ( match name with
  | None ->
      cctxt#prompt_password "Enter password for encrypted key: "
  | Some name ->
      cctxt#prompt_password "Enter password for encrypted key \"%s\": " name )
  >>=? fun password ->
  Raw.decrypt algo ~password ~encrypted_sk
  >>=? function
  | Some sk ->
      passwords := password :: !passwords ;
      return sk
  | None ->
      interactive_decrypt_loop cctxt ?name ~encrypted_sk algo

(* add all passwords obtained by [ctxt#load_passwords] to the list of known passwords *)
let password_file_load ctxt =
  match ctxt#load_passwords with
  | Some stream ->
      Lwt_stream.iter
        (fun p -> passwords := Bigstring.of_string p :: !passwords)
        stream
      >>= fun () -> return_unit
  | None ->
      return_unit

let rec noninteractive_decrypt_loop algo ~encrypted_sk = function
  | [] ->
      return_none
  | password :: passwords -> (
      Raw.decrypt algo ~password ~encrypted_sk
      >>=? function
      | None ->
          noninteractive_decrypt_loop algo ~encrypted_sk passwords
      | Some sk ->
          return_some sk )

let decrypt_payload cctxt ?name encrypted_sk =
  ( match Base58.decode encrypted_sk with
  | Some (Encrypted_ed25519 encrypted_sk) ->
      return (Signature.Ed25519, encrypted_sk)
  | Some (Encrypted_secp256k1 encrypted_sk) ->
      return (Signature.Secp256k1, encrypted_sk)
  | Some (Encrypted_p256 encrypted_sk) ->
      return (Signature.P256, encrypted_sk)
  | _ ->
      failwith "Not a Base58Check-encoded encrypted key" )
  >>=? fun (algo, encrypted_sk) ->
  let encrypted_sk = Bigstring.of_bytes encrypted_sk in
  noninteractive_decrypt_loop algo ~encrypted_sk !passwords
  >>=? function
  | Some sk ->
      return sk
  | None ->
      interactive_decrypt_loop cctxt ?name ~encrypted_sk algo

let decrypt (cctxt : #Client_context.prompter) ?name sk_uri =
  let payload = Uri.path (sk_uri : sk_uri :> Uri.t) in
  decrypt_payload cctxt ?name payload
  >>=? fun sk ->
  Hashtbl.replace decrypted sk_uri sk ;
  return sk

let decrypt_all (cctxt : #Client_context.io_wallet) =
  Secret_key.load cctxt
  >>=? fun sks ->
  password_file_load cctxt
  >>=? fun () ->
  iter_s
    (fun (name, sk_uri) ->
      if Uri.scheme (sk_uri : sk_uri :> Uri.t) <> Some scheme then return_unit
      else decrypt cctxt ~name sk_uri >>=? fun _ -> return_unit)
    sks

let decrypt_list (cctxt : #Client_context.io_wallet) keys =
  Secret_key.load cctxt
  >>=? fun sks ->
  password_file_load cctxt
  >>=? fun () ->
  iter_s
    (fun (name, sk_uri) ->
      if
        Uri.scheme (sk_uri : sk_uri :> Uri.t) = Some scheme
        && (keys = [] || List.mem name keys)
      then decrypt cctxt ~name sk_uri >>=? fun _ -> return_unit
      else return_unit)
    sks

let rec read_password (cctxt : #Client_context.io) =
  cctxt#prompt_password "Enter password to encrypt your key: "
  >>=? fun password ->
  cctxt#prompt_password "Confirm password: "
  >>=? fun confirm ->
  if not (Bigstring.equal password confirm) then
    cctxt#message "Passwords do not match." >>= fun () -> read_password cctxt
  else return password

let encrypt cctxt sk =
  read_password cctxt
  >>=? fun password ->
  let payload = Raw.encrypt ~password sk in
  let encoding =
    match sk with
    | Ed25519 _ ->
        Encodings.ed25519
    | Secp256k1 _ ->
        Encodings.secp256k1
    | P256 _ ->
        Encodings.p256
  in
  let payload = Bigstring.to_bytes payload in
  let path = Base58.simple_encode encoding payload in
  let sk_uri = Client_keys.make_sk_uri (Uri.make ~scheme ~path ()) in
  Hashtbl.replace decrypted sk_uri sk ;
  return sk_uri

module Make (C : sig
  val cctxt : Client_context.prompter
end) =
struct
  let scheme = "encrypted"

  let title = "Built-in signer using encrypted keys."

  let description =
    "Valid secret key URIs are of the form\n\
    \ - encrypted:<encrypted_key>\n\
     where <encrypted_key> is the encrypted (password protected using Nacl's \
     cryptobox and pbkdf) secret key, formatted in unprefixed Base58.\n\
     Valid public key URIs are of the form\n\
    \ - encrypted:<public_key>\n\
     where <public_key> is the public key in Base58."

  let public_key = Unencrypted.public_key

  let public_key_hash = Unencrypted.public_key_hash

  let import_secret_key = Unencrypted.import_secret_key

  let neuterize sk_uri =
    decrypt C.cctxt sk_uri
    >>=? fun sk ->
    return (Unencrypted.make_pk (Signature.Secret_key.to_public_key sk))

  let sign ?watermark sk_uri buf =
    decrypt C.cctxt sk_uri
    >>=? fun sk -> return (Signature.sign ?watermark sk buf)

  let deterministic_nonce sk_uri buf =
    decrypt C.cctxt sk_uri
    >>=? fun sk -> return (Signature.deterministic_nonce sk buf)

  let deterministic_nonce_hash sk_uri buf =
    decrypt C.cctxt sk_uri
    >>=? fun sk -> return (Signature.deterministic_nonce_hash sk buf)

  let supports_deterministic_nonces _ = return_true
end
src/lib_signer_backends/encrypted.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base.Client_keys.

Definition scheme : string := "encrypted" % string.

Module Raw.
  Definition salt_len : Z := 8.
  
  Definition nonce : Tezos_base__TzPervasives.Crypto_box.nonce :=
    Tezos_base__TzPervasives.Crypto_box.zero_nonce.
  
  Definition encrypted_size : Z :=
    Z.add Tezos_base__TzPervasives.Crypto_box.boxzerobytes 32.
  
  Definition pbkdf (salt : Bigstring.t) (password : Bigstring.t)
    : Bigstring.t := Pbkdf.SHA512.(Pbkdf.S.pbkdf2) password salt 32768 32.
  
  Definition encrypt
    (password : Bigstring.t)
    (sk : Tezos_base__TzPervasives.Signature.secret_key) : Bigstring.t :=
    let salt := Hacl.Rand.gen salt_len in
    let key :=
      Tezos_base__TzPervasives.Crypto_box.Secretbox.unsafe_of_bytes
        (pbkdf salt password) in
    let msg :=
      match sk with
      | Ed25519 sk =>
        Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_base__TzPervasives.Ed25519.Secret_key.encoding sk
      | Secp256k1 sk =>
        Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_base__TzPervasives.Secp256k1.Secret_key.encoding sk
      | P256 sk =>
        Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_base__TzPervasives.P256.Secret_key.encoding sk
      end in
    Bigstring.concat "" % string
      (cons salt
        (cons (Tezos_base__TzPervasives.Crypto_box.Secretbox.box key msg nonce)
          [])).
  
  Definition decrypt
    (algo : Tezos_base__TzPervasives.Signature.algo) (password : Bigstring.t)
    (encrypted_sk : Bigstring.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
    let salt := Bigstring.sub encrypted_sk 0 salt_len in
    let encrypted_sk := Bigstring.sub encrypted_sk salt_len encrypted_size in
    let key :=
      Tezos_base__TzPervasives.Crypto_box.Secretbox.unsafe_of_bytes
        (pbkdf salt password) in
    match
      ((Tezos_base__TzPervasives.Crypto_box.Secretbox.box_open key encrypted_sk
        nonce), algo) with
    | (None, _) => Tezos_base__TzPervasives.return_none
    | (Some bytes, Signature.Ed25519) =>
      match
        Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
          Tezos_base__TzPervasives.Ed25519.Secret_key.encoding string with
      | Some sk => Tezos_base__TzPervasives.return_some (Ed25519 sk)
      | None =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
                % string CamlinternalFormatBasics.End_of_format)
            "Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
              % string)
      end
    | (Some bytes, Signature.Secp256k1) =>
      match
        Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
          Tezos_base__TzPervasives.Secp256k1.Secret_key.encoding string with
      | Some sk => Tezos_base__TzPervasives.return_some (Secp256k1 sk)
      | None =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Corrupted wallet, deciphered key is not a valid Secp256k1 secret key"
                % string CamlinternalFormatBasics.End_of_format)
            "Corrupted wallet, deciphered key is not a valid Secp256k1 secret key"
              % string)
      end
    | (Some bytes, Signature.P256) =>
      match
        Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
          Tezos_base__TzPervasives.P256.Secret_key.encoding string with
      | Some sk => Tezos_base__TzPervasives.return_some (P256 sk)
      | None =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Corrupted wallet, deciphered key is not a valid P256 secret key"
                % string CamlinternalFormatBasics.End_of_format)
            "Corrupted wallet, deciphered key is not a valid P256 secret key" %
              string)
      end
    end.
End Raw.

Module Encodings.
  Definition ed25519
    : Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
    let length :=
      Z.add
        (Z.add Hacl.Sign.skbytes
          Tezos_base__TzPervasives.Crypto_box.boxzerobytes) Raw.salt_len in
    Tezos_base__TzPervasives.Base58.register_encoding
      Tezos_base__TzPervasives.Base58.Prefix.ed25519_encrypted_seed length
      (fun sk => Stdlib.Bytes.to_string sk)
      (fun buf =>
        if nequiv_decb (Tezos_base__TzPervasives.String.length buf) length then
          None
        else
          Some (Stdlib.Bytes.of_string buf)) (fun sk => Encrypted_ed25519 sk).
  
  Definition secp256k1
    : Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
    let length :=
      Z.add
        (Z.add Libsecp256k1.External.Key.secret_bytes
          Tezos_base__TzPervasives.Crypto_box.boxzerobytes) Raw.salt_len in
    Tezos_base__TzPervasives.Base58.register_encoding
      Tezos_base__TzPervasives.Base58.Prefix.secp256k1_encrypted_secret_key
      length (fun sk => Stdlib.Bytes.to_string sk)
      (fun buf =>
        if nequiv_decb (Tezos_base__TzPervasives.String.length buf) length then
          None
        else
          Some (Stdlib.Bytes.of_string buf)) (fun sk => Encrypted_secp256k1 sk).
  
  Definition p256 : Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
    let length :=
      Z.add
        (Z.add (Uecc.sk_size Uecc.secp256r1)
          Tezos_base__TzPervasives.Crypto_box.boxzerobytes) Raw.salt_len in
    Tezos_base__TzPervasives.Base58.register_encoding
      Tezos_base__TzPervasives.Base58.Prefix.p256_encrypted_secret_key length
      (fun sk => Stdlib.Bytes.to_string sk)
      (fun buf =>
        if nequiv_decb (Tezos_base__TzPervasives.String.length buf) length then
          None
        else
          Some (Stdlib.Bytes.of_string buf)) (fun sk => Encrypted_p256 sk).
End Encodings.

Definition decrypted
  : Stdlib.Hashtbl.t Tezos_client_base.Client_keys.sk_uri
    Tezos_base__TzPervasives.Signature.Secret_key.t :=
  Stdlib.Hashtbl.create None 13.

Definition passwords : Stdlib.ref (list Bigstring.t) := Stdlib.ref [].

Fixpoint interactive_decrypt_loop {B a : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
  (name : option string) (encrypted_sk : Bigstring.t)
  (algo : Tezos_base__TzPervasives.Signature.algo)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match name with
    | None =>
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Enter password for encrypted key: " % string
            CamlinternalFormatBasics.End_of_format)
          "Enter password for encrypted key: " % string)
    | Some name =>
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Enter password for encrypted key """ % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal """: " % string
                CamlinternalFormatBasics.End_of_format)))
          "Enter password for encrypted key ""%s"": " % string) name
    end
    (fun password =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Raw.decrypt algo password encrypted_sk)
        (fun function_parameter =>
          match function_parameter with
          | Some sk =>
            Stdlib.op_colon_eq passwords
              (cons password (Stdlib.op_exclamation passwords));
            Tezos_base__TzPervasives._return sk
          | None => interactive_decrypt_loop cctxt name encrypted_sk algo
          end)).

Definition password_file_load {A : Type}
  (ctxt : ((option (Lwt_stream.t string)) * A))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match send with
  | Some stream =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Lwt_stream.iter
        (fun p =>
          Stdlib.op_colon_eq passwords
            (cons (Bigstring.of_string p) (Stdlib.op_exclamation passwords)))
        stream)
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives.return_unit
        end)
  | None => Tezos_base__TzPervasives.return_unit
  end.

Fixpoint noninteractive_decrypt_loop
  (algo : Tezos_base__TzPervasives.Signature.algo) (encrypted_sk : Bigstring.t)
  (function_parameter : list Bigstring.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
  match function_parameter with
  | [] => Tezos_base__TzPervasives.return_none
  | cons password passwords =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Raw.decrypt algo password encrypted_sk)
      (fun function_parameter =>
        match function_parameter with
        | None => noninteractive_decrypt_loop algo encrypted_sk passwords
        | Some sk => Tezos_base__TzPervasives.return_some sk
        end)
  end.

Definition decrypt_payload {B a : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
  (name : option string) (encrypted_sk : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match Tezos_base__TzPervasives.Base58.decode None encrypted_sk with
    | Some (Encrypted_ed25519 encrypted_sk) =>
      Tezos_base__TzPervasives._return (Signature.Ed25519, encrypted_sk)
    | Some (Encrypted_secp256k1 encrypted_sk) =>
      Tezos_base__TzPervasives._return (Signature.Secp256k1, encrypted_sk)
    | Some (Encrypted_p256 encrypted_sk) =>
      Tezos_base__TzPervasives._return (Signature.P256, encrypted_sk)
    | _ =>
      Tezos_base__TzPervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Not a Base58Check-encoded encrypted key" % string
            CamlinternalFormatBasics.End_of_format)
          "Not a Base58Check-encoded encrypted key" % string)
    end
    (fun function_parameter =>
      match function_parameter with
      | (algo, encrypted_sk) =>
        let encrypted_sk := Bigstring.of_bytes encrypted_sk in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (noninteractive_decrypt_loop algo encrypted_sk
            (Stdlib.op_exclamation passwords))
          (fun function_parameter =>
            match function_parameter with
            | Some sk => Tezos_base__TzPervasives._return sk
            | None => interactive_decrypt_loop cctxt name encrypted_sk algo
            end)
      end).

Definition decrypt {B a : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
  (name : option string) (sk_uri : Tezos_client_base.Client_keys.sk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  let payload := Uri.path sk_uri in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (decrypt_payload cctxt name payload)
    (fun sk =>
      Stdlib.Hashtbl.replace decrypted sk_uri sk;
      Tezos_base__TzPervasives._return sk).

Definition decrypt_all {C a b : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                  (a * b)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
                        *
                        ((((Tezos_client_base.Client_context.lwt_format a
                          (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
                          * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) * C)))))))))))) * C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_base.Client_keys.Secret_key.load cctxt)
    (fun sks =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question (password_file_load cctxt)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.iter_s
              (fun function_parameter =>
                match function_parameter with
                | (name, sk_uri) =>
                  if nequiv_decb (Uri.scheme sk_uri) (Some scheme) then
                    Tezos_base__TzPervasives.return_unit
                  else
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (decrypt cctxt (Some name) sk_uri)
                      (fun function_parameter =>
                        match function_parameter with
                        | _ => Tezos_base__TzPervasives.return_unit
                        end)
                end) sks
          end)).

Definition decrypt_list {C a b : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                  (a * b)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
                        *
                        ((((Tezos_client_base.Client_context.lwt_format a
                          (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
                          * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) * C)))))))))))) * C)
  (keys : list string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_base.Client_keys.Secret_key.load cctxt)
    (fun sks =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question (password_file_load cctxt)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.iter_s
              (fun function_parameter =>
                match function_parameter with
                | (name, sk_uri) =>
                  if
                    andb (equiv_decb (Uri.scheme sk_uri) (Some scheme))
                      (orb (equiv_decb keys [])
                        (Tezos_base__TzPervasives.List.mem name keys)) then
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (decrypt cctxt (Some name) sk_uri)
                      (fun function_parameter =>
                        match function_parameter with
                        | _ => Tezos_base__TzPervasives.return_unit
                        end)
                  else
                    Tezos_base__TzPervasives.return_unit
                end) sks
          end)).

Fixpoint read_password {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
            *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) * C))))))) * C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Enter password to encrypt your key: " % string
          CamlinternalFormatBasics.End_of_format)
        "Enter password to encrypt your key: " % string))
    (fun password =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Confirm password: " % string
              CamlinternalFormatBasics.End_of_format)
            "Confirm password: " % string))
        (fun confirm =>
          if negb (Bigstring.equal password confirm) then
            Tezos_base__TzPervasives.op_gt_gt_eq
              (send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Passwords do not match." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Passwords do not match." % string))
              (fun function_parameter =>
                match function_parameter with
                | tt => read_password cctxt
                end)
          else
            Tezos_base__TzPervasives._return password)).

Definition encrypt {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
            *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) * C))))))) * C)
  (sk : Tezos_base__TzPervasives.Signature.secret_key)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.sk_uri) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (read_password cctxt)
    (fun password =>
      let payload := Raw.encrypt password sk in
      let encoding :=
        match sk with
        | Ed25519 _ => Encodings.ed25519
        | Secp256k1 _ => Encodings.secp256k1
        | P256 _ => Encodings.p256
        end in
      let payload := Bigstring.to_bytes payload in
      let path :=
        Tezos_base__TzPervasives.Base58.simple_encode None encoding payload in
      let sk_uri :=
        Tezos_client_base.Client_keys.make_sk_uri
          (Uri.make (Some scheme) None None None (Some path) None None tt) in
      Stdlib.Hashtbl.replace decrypted sk_uri sk;
      Tezos_base__TzPervasives._return sk_uri).
src/lib_signer_backends/encrypted.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make (C : sig
  val cctxt : Client_context.prompter
end) : Client_keys.SIGNER

val decrypt :
  #Client_context.prompter ->
  ?name:string ->
  Client_keys.sk_uri ->
  Signature.secret_key tzresult Lwt.t

val decrypt_all : #Client_context.io_wallet -> unit tzresult Lwt.t

val decrypt_list :
  #Client_context.io_wallet -> string list -> unit tzresult Lwt.t

val encrypt :
  #Client_context.io ->
  Signature.secret_key ->
  Client_keys.sk_uri tzresult Lwt.t
src/lib_signer_backends/encrypted.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

Parameter decrypt : forall {_ a : Type},
(((((Tezos_client_base.Client_context.lwt_format a
  (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
  ((((Tezos_client_base.Client_context.lwt_format a
    (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * _)) * _) ->
  (option string) ->
    Tezos_client_base.Client_keys.sk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Signature.secret_key).

Parameter decrypt_all : forall {_ a b : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
              *
              (((string ->
                (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
                *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  ((((Tezos_client_base.Client_context.lwt_format a
                    (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a
                      (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
                      (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) * _)))))))))))) * _) ->
  Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter decrypt_list : forall {_ a b : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
              *
              (((string ->
                (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
                *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  ((((Tezos_client_base.Client_context.lwt_format a
                    (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a
                      (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
                      (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) * _)))))))))))) * _) ->
  (list string) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter encrypt : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a
  (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
  ((((Tezos_client_base.Client_context.lwt_format a
    (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * _))))))) * _) ->
  Tezos_base__TzPervasives.Signature.secret_key ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.sk_uri).
src/lib_signer_backends/http.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Http_gen.Make (struct
  let scheme = "http"
end)
src/lib_signer_backends/http.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_signer_backends/http.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make
    (RPC_client : RPC_client.S) (P : sig
      val authenticate :
        Signature.Public_key_hash.t list ->
        Bytes.t ->
        Signature.t tzresult Lwt.t

      val logger : RPC_client.logger
    end) : Client_keys.SIGNER

val make_base : string -> int -> Uri.t
src/lib_signer_backends/http.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

Parameter make_base : string -> Z -> Uri.t.
src/lib_signer_backends/http_gen.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make (N : sig
  val scheme : string
end) =
struct
  open Client_keys

  let scheme = N.scheme

  module Make
      (RPC_client : RPC_client.S) (P : sig
        val authenticate :
          Signature.Public_key_hash.t list ->
          Bytes.t ->
          Signature.t tzresult Lwt.t

        val logger : RPC_client.logger
      end) =
  struct
    let scheme = scheme

    let title =
      "Built-in tezos-signer using remote signer through hardcoded " ^ scheme
      ^ " requests."

    let description =
      "Valid locators are of this form:\n" ^ " - " ^ scheme
      ^ "://host/tz1...\n" ^ " - " ^ scheme
      ^ "://host:port/path/to/service/tz1...\n"
      ^ "Environment variable TEZOS_SIGNER_HTTP_HEADERS can be specified to \
         add headers to the requests (only 'host' and custom 'x-...' headers \
         are supported)."

    let headers =
      match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HEADERS" with
      | None ->
          None
      | Some contents ->
          let lines = String.split_on_char '\n' contents in
          Some
            (List.fold_left
               (fun acc line ->
                 match String.index_opt line ':' with
                 | None ->
                     Pervasives.failwith
                       "Http signer: invalid TEZOS_SIGNER_HTTP_HEADERS \
                        environment variable, missing colon"
                 | Some pos ->
                     let header = String.trim (String.sub line 0 pos) in
                     let header = String.lowercase_ascii header in
                     if
                       header <> "host"
                       && ( String.length header < 2
                          || String.sub header 0 2 <> "x-" )
                     then
                       Pervasives.failwith
                         "Http signer: invalid TEZOS_SIGNER_HTTP_HEADERS \
                          environment variable, only 'host' or 'x-' headers \
                          are supported" ;
                     let value =
                       String.trim
                         (String.sub
                            line
                            (pos + 1)
                            (String.length line - pos - 1))
                     in
                     (header, value) :: acc)
               []
               lines)

    let parse uri =
      (* extract `tz1..` from the last component of the path *)
      assert (Uri.scheme uri = Some scheme) ;
      let path = Uri.path uri in
      ( match String.rindex_opt path '/' with
      | None ->
          failwith "Invalid locator %a" Uri.pp_hum uri
      | Some i ->
          let pkh =
            try String.sub path (i + 1) (String.length path - i - 1)
            with _ -> ""
          in
          let path = String.sub path 0 i in
          return (Uri.with_path uri path, pkh) )
      >>=? fun (base, pkh) ->
      Lwt.return (Signature.Public_key_hash.of_b58check pkh)
      >>=? fun pkh -> return (base, pkh)

    let public_key uri =
      parse (uri : pk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.public_key
        ((), pkh)
        ()
        ()

    let neuterize uri =
      return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))

    let public_key_hash uri =
      public_key uri
      >>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)

    let import_secret_key ~io:_ = public_key_hash

    let get_signature base pkh msg =
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.authorized_keys
        ()
        ()
        ()
      >>=? function
      | Some authorized_keys ->
          P.authenticate
            authorized_keys
            (Signer_messages.Sign.Request.to_sign ~pkh ~data:msg)
          >>=? fun signature -> return_some signature
      | None ->
          return_none

    let sign ?watermark uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      let msg =
        match watermark with
        | None ->
            msg
        | Some watermark ->
            Bytes.cat (Signature.bytes_of_watermark watermark) msg
      in
      get_signature base pkh msg
      >>=? fun signature ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.sign
        ((), pkh)
        signature
        msg

    let deterministic_nonce uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      get_signature base pkh msg
      >>=? fun signature ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.deterministic_nonce
        ((), pkh)
        signature
        msg

    let deterministic_nonce_hash uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      get_signature base pkh msg
      >>=? fun signature ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.deterministic_nonce_hash
        ((), pkh)
        signature
        msg

    let supports_deterministic_nonces uri =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.supports_deterministic_nonces
        ((), pkh)
        ()
        ()
      >>= function
      | Ok ans ->
          return ans
      | Error (RPC_context.Not_found _ :: _) ->
          return_false
      | Error _ as res ->
          Lwt.return res
  end

  let make_base host port = Uri.make ~scheme ~host ~port ()
end
src/lib_signer_backends/http_gen.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_signer_backends/http_gen.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make (N : sig
  val scheme : string
end) : sig
  module Make
      (RPC_client : RPC_client.S) (P : sig
        val authenticate :
          Signature.Public_key_hash.t list ->
          Bytes.t ->
          Signature.t tzresult Lwt.t

        val logger : RPC_client.logger
      end) : Client_keys.SIGNER

  val make_base : string -> int -> Uri.t
end
src/lib_signer_backends/http_gen.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module
src/lib_signer_backends/https.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Http_gen.Make (struct
  let scheme = "https"
end)
src/lib_signer_backends/https.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_signer_backends/https.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make
    (RPC_client : RPC_client.S) (P : sig
      val authenticate :
        Signature.Public_key_hash.t list ->
        Bytes.t ->
        Signature.t tzresult Lwt.t

      val logger : RPC_client.logger
    end) : Client_keys.SIGNER

val make_base : string -> int -> Uri.t
src/lib_signer_backends/https.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

Parameter make_base : string -> Z -> Uri.t.
src/lib_signer_backends/test/test_encrypted.ml 
(**************************************************************************)
(*                                                                        *)
(*    Copyright (c) 2014 - 2018.                                          *)
(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
(*                                                                        *)
(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
(*                                                                        *)
(**************************************************************************)

open Error_monad

let loops = 10

let passwords =
  List.map
    Bigstring.of_string
    [ "ahThie5H";
      "aVah7eid";
      "Hihohh1n";
      "mui0Hoox";
      "Piu7pual";
      "paik6aiW";
      "caeS5me5";
      "boh5dauL";
      "zaiK1Oht";
      "Oogh4hah";
      "kiY5ohlo";
      "booth0Ei";
      "xa2Aidao";
      "aju6oXu4";
      "gooruGh9";
      "ahy4Daih";
      "chosh0Wu";
      "Cheij6za";
      "quee9ooL";
      "Sohs9are";
      "Pae3gay7";
      "Naif5iel";
      " eir6Aed1";
      "aa6Aesai";
      "" ]

let nb_passwds = List.length passwords

let fake_ctx () =
  object
    val mutable i = 0

    val mutable distributed = false

    inherit Client_context.simple_printer (fun _ _ -> Lwt.return_unit)

    method prompt : type a. (a, string tzresult) Client_context.lwt_format -> a
        =
      Format.kasprintf (fun _ -> return "")

    method prompt_password : type a.
        (a, Bigstring.t tzresult) Client_context.lwt_format -> a =
      Format.kasprintf (fun _ ->
          (* return Bigstring.empty *)
          match distributed with
          | false ->
              distributed <- true ;
              return (List.nth passwords 0)
          | true ->
              i <- (if i = nb_passwds - 1 then 0 else succ i) ;
              distributed <- false ;
              return (List.nth passwords i))
  end

let make_sk_uris =
  List.map (fun path ->
      Client_keys.make_sk_uri (Uri.make ~scheme:"encrypted" ~path ()))

let ed25519_sks =
  [ "edsk3kMNLNdzLPbbABASDLARft8JRZ3Wpwibn8SMAb4KmuWSMJmAFd";
    "edsk3Kqr8VHRx9kmR8Pj5qRGcmvQH34cForiMaMz1Ahhq5DkZp7FxJ";
    "edsk2mBu4w9sMGhryvvXK53dXgpcNdZWi8pJQ1QL2rAgRPrE5y12az" ]

let ed25519_sks_encrypted =
  make_sk_uris
    [ "edesk1oGXxunJ5FTGpQ6o1xdop8VGKdT36Fj7LwWF9HLjzEqaCC4V6tdRVN1jaeJTfCHS8bYf7U2YhMK2yW6jSUy";
      "edesk1s4xEifbUdUkghHHimbNUuyQ4eidDVJdc8JtPRUon758hBqZNZsQxadUDFRSRiUdLoFqBG35HAiLKafyczw";
      "edesk1zY5jEs4QXrF9tXxFq1mfW9PkatdRxCKQ2Q598y5LLz65nQj4eWxefYFp8YLerya1haRdGe5NWckHDb5ApM"
    ]

let secp256k1_sks =
  [ "spsk24attf9uuQ7PUKFHxTm6E3TMqB6SPkFiMbXPBur7JNrvupW2xg";
    "spsk2H32XfWL7MkW58r76q6Yu5tJg77YGgVyjwq7EvLUHhn4JmAtEG";
    "spsk3KQ56REAUGc6Gn87xCRnWyPwR2Un667vegQVuU16ZcgNyLCooh" ]

let secp256k1_sks_encrypted =
  make_sk_uris
    [ "spesk2CXQHDbzrcNatRzmg83Dto6kX6BWwpP2zGs4Zks9LDsXzaX6mAYRj5ZrrdgyZQap4DS9YRRLNSpaVC2TSsk";
      "spesk1upiFp23osWSUTgHcx8DCVpTrMr9xtdqVQkQDWj5sFG7vqcWLDaNv9AKKcF27Nb266YfuAGF2hEbcyAxHmK";
      "spesk1w7d68hzTWJusk5Xn5oz8EgDXbotDW9BXb5ksFjr8Jd94Kxnu5yKAhgRszojhMUoJ1EEt5BtPpGpkgCjELq"
    ]

let p256_sks =
  [ "p2sk2YQcwF5h7qgRztocEMrfizUwZaM41f4v7zWneiig2Y5AxajqYC";
    "p2sk2XiSoQC9tvejVBDJyvkbHUq2kvcQHdJJ2wM8rii228DkjKV2b5";
    "p2sk3ZsfsEaxDNn74orv91Ruu35fomzF373aT9ForA4fDo54c47o6H" ]

let p256_sks_encrypted =
  make_sk_uris
    [ "p2esk2JMFpR9yaSpgsaKQYLqFnv16t4gowJ4cgjj7D7iMfoaJz2vZuH7Tdi11MrX6FC2yhfs2nvy5VRxAvzH1STE";
      "p2esk1nfobVL73mY5Y18W8Ltb3Vm6Nf5Th7trN3yA3ucyyP4AH93XfyRatkh9AxxaDtnju1EtArykjroEQHDT97k";
      "p2esk2Ge1jrVak7NhxksimzaQjRCTLx5vxUZ4Akgq3spGQLx6N41h6aKXeEYDgxN5eztnPwD6QiCHCfVAKXLPNm8"
    ]

let sk_testable =
  Alcotest.testable Signature.Secret_key.pp Signature.Secret_key.equal

let test_vectors () =
  let open Encrypted in
  iter_s
    (fun (sks, encrypted_sks) ->
      let ctx = fake_ctx () in
      let sks = List.map Signature.Secret_key.of_b58check_exn sks in
      map_s (decrypt ctx) encrypted_sks
      >>=? fun decs ->
      assert (decs = sks) ;
      return_unit)
    [ (ed25519_sks, ed25519_sks_encrypted);
      (secp256k1_sks, secp256k1_sks_encrypted);
      (p256_sks, p256_sks_encrypted) ]

let test_random algo =
  let open Encrypted in
  let ctx = fake_ctx () in
  let decrypt_ctx = (ctx :> Client_context.prompter) in
  let rec inner i =
    if i >= loops then return_unit
    else
      let (_, _, sk) = Signature.generate_key ~algo () in
      encrypt ctx sk
      >>=? fun sk_uri ->
      decrypt decrypt_ctx sk_uri
      >>=? fun decrypted_sk ->
      Alcotest.check sk_testable "test_encrypt: decrypt" sk decrypted_sk ;
      inner (succ i)
  in
  inner 0

let test_random _switch () =
  iter_s test_random Signature.[Ed25519; Secp256k1; P256]
  >>= function
  | Ok _ -> Lwt.return_unit | Error _ -> Lwt.fail_with "test_random"

let test_vectors _switch () =
  test_vectors ()
  >>= function
  | Ok _ -> Lwt.return_unit | Error _ -> Lwt.fail_with "test_vectors"

let tests =
  [ Alcotest_lwt.test_case "random_roundtrip" `Quick test_random;
    Alcotest_lwt.test_case "vectors_decrypt" `Quick test_vectors ]

let () = Alcotest.run "tezos-signer-backends" [("encrypted", tests)]
src/lib_signer_backends/test/test_encrypted.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Error_monad.

Definition loops : Z := 10.

Definition passwords : list Bigstring.t :=
  Tezos_base__TzPervasives.List.map Bigstring.of_string
    (cons "ahThie5H" % string
      (cons "aVah7eid" % string
        (cons "Hihohh1n" % string
          (cons "mui0Hoox" % string
            (cons "Piu7pual" % string
              (cons "paik6aiW" % string
                (cons "caeS5me5" % string
                  (cons "boh5dauL" % string
                    (cons "zaiK1Oht" % string
                      (cons "Oogh4hah" % string
                        (cons "kiY5ohlo" % string
                          (cons "booth0Ei" % string
                            (cons "xa2Aidao" % string
                              (cons "aju6oXu4" % string
                                (cons "gooruGh9" % string
                                  (cons "ahy4Daih" % string
                                    (cons "chosh0Wu" % string
                                      (cons "Cheij6za" % string
                                        (cons "quee9ooL" % string
                                          (cons "Sohs9are" % string
                                            (cons "Pae3gay7" % string
                                              (cons "Naif5iel" % string
                                                (cons " eir6Aed1" % string
                                                  (cons "aa6Aesai" % string
                                                    (cons "" % string []))))))))))))))))))))))))).

Definition nb_passwds : Z := Tezos_base__TzPervasives.List.length passwords.

Definition fake_ctx {a b : Type} (function_parameter : unit)
  : ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
            * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a
              (Tezos_base__TzPervasives.Error_monad.tzresult string)) -> a) *
              (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a
                (Tezos_base__TzPervasives.Error_monad.tzresult Bigstring.t)) ->
                a) * (a)) * nil))))))) :=
  match function_parameter with
  | tt => object
  end.

Definition make_sk_uris
  : (list string) -> list Tezos_client_base.Client_keys.sk_uri :=
  Tezos_base__TzPervasives.List.map
    (fun path =>
      Tezos_client_base.Client_keys.make_sk_uri
        (Uri.make (Some "encrypted" % string) None None None (Some path) None
          None tt)).

Definition ed25519_sks : list string :=
  cons "edsk3kMNLNdzLPbbABASDLARft8JRZ3Wpwibn8SMAb4KmuWSMJmAFd" % string
    (cons "edsk3Kqr8VHRx9kmR8Pj5qRGcmvQH34cForiMaMz1Ahhq5DkZp7FxJ" % string
      (cons "edsk2mBu4w9sMGhryvvXK53dXgpcNdZWi8pJQ1QL2rAgRPrE5y12az" % string [])).

Definition ed25519_sks_encrypted : list Tezos_client_base.Client_keys.sk_uri :=
  make_sk_uris
    (cons
      "edesk1oGXxunJ5FTGpQ6o1xdop8VGKdT36Fj7LwWF9HLjzEqaCC4V6tdRVN1jaeJTfCHS8bYf7U2YhMK2yW6jSUy"
        % string
      (cons
        "edesk1s4xEifbUdUkghHHimbNUuyQ4eidDVJdc8JtPRUon758hBqZNZsQxadUDFRSRiUdLoFqBG35HAiLKafyczw"
          % string
        (cons
          "edesk1zY5jEs4QXrF9tXxFq1mfW9PkatdRxCKQ2Q598y5LLz65nQj4eWxefYFp8YLerya1haRdGe5NWckHDb5ApM"
            % string []))).

Definition secp256k1_sks : list string :=
  cons "spsk24attf9uuQ7PUKFHxTm6E3TMqB6SPkFiMbXPBur7JNrvupW2xg" % string
    (cons "spsk2H32XfWL7MkW58r76q6Yu5tJg77YGgVyjwq7EvLUHhn4JmAtEG" % string
      (cons "spsk3KQ56REAUGc6Gn87xCRnWyPwR2Un667vegQVuU16ZcgNyLCooh" % string [])).

Definition secp256k1_sks_encrypted
  : list Tezos_client_base.Client_keys.sk_uri :=
  make_sk_uris
    (cons
      "spesk2CXQHDbzrcNatRzmg83Dto6kX6BWwpP2zGs4Zks9LDsXzaX6mAYRj5ZrrdgyZQap4DS9YRRLNSpaVC2TSsk"
        % string
      (cons
        "spesk1upiFp23osWSUTgHcx8DCVpTrMr9xtdqVQkQDWj5sFG7vqcWLDaNv9AKKcF27Nb266YfuAGF2hEbcyAxHmK"
          % string
        (cons
          "spesk1w7d68hzTWJusk5Xn5oz8EgDXbotDW9BXb5ksFjr8Jd94Kxnu5yKAhgRszojhMUoJ1EEt5BtPpGpkgCjELq"
            % string []))).

Definition p256_sks : list string :=
  cons "p2sk2YQcwF5h7qgRztocEMrfizUwZaM41f4v7zWneiig2Y5AxajqYC" % string
    (cons "p2sk2XiSoQC9tvejVBDJyvkbHUq2kvcQHdJJ2wM8rii228DkjKV2b5" % string
      (cons "p2sk3ZsfsEaxDNn74orv91Ruu35fomzF373aT9ForA4fDo54c47o6H" % string [])).

Definition p256_sks_encrypted : list Tezos_client_base.Client_keys.sk_uri :=
  make_sk_uris
    (cons
      "p2esk2JMFpR9yaSpgsaKQYLqFnv16t4gowJ4cgjj7D7iMfoaJz2vZuH7Tdi11MrX6FC2yhfs2nvy5VRxAvzH1STE"
        % string
      (cons
        "p2esk1nfobVL73mY5Y18W8Ltb3Vm6Nf5Th7trN3yA3ucyyP4AH93XfyRatkh9AxxaDtnju1EtArykjroEQHDT97k"
          % string
        (cons
          "p2esk2Ge1jrVak7NhxksimzaQjRCTLx5vxUZ4Akgq3spGQLx6N41h6aKXeEYDgxN5eztnPwD6QiCHCfVAKXLPNm8"
            % string []))).

Definition sk_testable {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    Tezos_base__TzPervasives.Signature.Secret_key.pp
    Tezos_base__TzPervasives.Signature.Secret_key.equal.

Definition test_vectors (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Error_monad.iter_s
      (fun function_parameter =>
        match function_parameter with
        | (sks, encrypted_sks) =>
          let ctx := fake_ctx tt in
          let sks :=
            Tezos_base__TzPervasives.List.map
              Tezos_base__TzPervasives.Signature.Secret_key.of_b58check_exn sks
            in
          Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq_question
            (Tezos_base__TzPervasives.Error_monad.map_s
              (let arg := Tezos_signer_backends.Encrypted.decrypt ctx in
              fun eta => arg None eta) encrypted_sks)
            (fun decs =>
              equiv_decb decs sks;
              Tezos_base__TzPervasives.Error_monad.return_unit)
        end)
      (cons (ed25519_sks, ed25519_sks_encrypted)
        (cons (secp256k1_sks, secp256k1_sks_encrypted)
          (cons (p256_sks, p256_sks_encrypted) [])))
  end.

Definition test_random (algo : Tezos_base__TzPervasives.Signature.algo)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
  let ctx := fake_ctx tt in
  let decrypt_ctx := ctx in
  let fix inner (i : Z)
    : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
    if OCaml.Stdlib.ge i loops then
      Tezos_base__TzPervasives.Error_monad.return_unit
    else
      match Tezos_base__TzPervasives.Signature.generate_key (Some algo) None tt
        with
      | (_, _, sk) =>
        Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq_question
          (Tezos_signer_backends.Encrypted.encrypt ctx sk)
          (fun sk_uri =>
            Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq_question
              (Tezos_signer_backends.Encrypted.decrypt decrypt_ctx None sk_uri)
              (fun decrypted_sk =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star sk_testable
                  "test_encrypt: decrypt" % string sk decrypted_sk;
                inner (Z.succ i)))
      end in
  inner 0.

Definition test_random {A : Type} (_switch : A) (function_parameter : unit)
  : Lwt.t unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq
      (Tezos_base__TzPervasives.Error_monad.iter_s test_random
        (cons Ed25519 (cons Secp256k1 (cons P256 []))))
      (fun function_parameter =>
        match function_parameter with
        | inl _ => Lwt.return_unit
        | inr _ => Lwt.fail_with "test_random" % string
        end)
  end.

Definition test_vectors {A : Type} (_switch : A) (function_parameter : unit)
  : Lwt.t unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq (test_vectors tt)
      (fun function_parameter =>
        match function_parameter with
        | inl _ => Lwt.return_unit
        | inr _ => Lwt.fail_with "test_vectors" % string
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "random_roundtrip" % string variant
      test_random)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star "vectors_decrypt" % string variant
        test_vectors) []).
src/lib_signer_backends/unencrypted.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys

let scheme = "unencrypted"

let title = "Built-in signer using raw unencrypted keys."

let description =
  "Please DO NOT USE this signer outside of test environments.\n\
   Valid secret key URIs are of the form\n\
  \ - unencrypted:<key>\n\
   where <key> is the secret key in Base58.\n\
   Valid public key URIs are of the form\n\
  \ - unencrypted:<public_key>\n\
   where <public_key> is the public key in Base58."

let secret_key sk_uri =
  Lwt.return
    (Signature.Secret_key.of_b58check (Uri.path (sk_uri : sk_uri :> Uri.t)))

let make_sk sk =
  Client_keys.make_sk_uri
    (Uri.make ~scheme ~path:(Signature.Secret_key.to_b58check sk) ())

let public_key pk_uri =
  Lwt.return
    (Signature.Public_key.of_b58check (Uri.path (pk_uri : pk_uri :> Uri.t)))

let make_pk pk =
  Client_keys.make_pk_uri
    (Uri.make ~scheme ~path:(Signature.Public_key.to_b58check pk) ())

let neuterize sk_uri =
  secret_key sk_uri
  >>=? fun sk -> return (make_pk (Signature.Secret_key.to_public_key sk))

let public_key_hash pk_uri =
  public_key pk_uri
  >>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)

let import_secret_key ~io:_ = public_key_hash

let sign ?watermark sk_uri buf =
  secret_key sk_uri >>=? fun sk -> return (Signature.sign ?watermark sk buf)

let deterministic_nonce sk_uri buf =
  secret_key sk_uri
  >>=? fun sk -> return (Signature.deterministic_nonce sk buf)

let deterministic_nonce_hash sk_uri buf =
  secret_key sk_uri
  >>=? fun sk -> return (Signature.deterministic_nonce_hash sk buf)

let supports_deterministic_nonces _ = return_true
src/lib_signer_backends/unencrypted.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base.Client_keys.

Definition scheme : string := "unencrypted" % string.

Definition title : string :=
  "Built-in signer using raw unencrypted keys." % string.

Definition description : string :=
  "Please DO NOT USE this signer outside of test environments.
Valid secret key URIs are of the form
 - unencrypted:<key>
where <key> is the secret key in Base58.
Valid public key URIs are of the form
 - unencrypted:<public_key>
where <public_key> is the public key in Base58."
    % string.

Definition secret_key (sk_uri : Tezos_client_base.Client_keys.sk_uri)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  Lwt._return
    (Tezos_base__TzPervasives.Signature.Secret_key.of_b58check (Uri.path sk_uri)).

Definition make_sk (sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
  : Tezos_client_base.Client_keys.sk_uri :=
  Tezos_client_base.Client_keys.make_sk_uri
    (Uri.make (Some scheme) None None None
      (Some (Tezos_base__TzPervasives.Signature.Secret_key.to_b58check sk)) None
      None tt).

Definition public_key (pk_uri : Tezos_client_base.Client_keys.pk_uri)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.Signature.Public_key.t) :=
  Lwt._return
    (Tezos_base__TzPervasives.Signature.Public_key.of_b58check (Uri.path pk_uri)).

Definition make_pk (pk : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Tezos_client_base.Client_keys.pk_uri :=
  Tezos_client_base.Client_keys.make_pk_uri
    (Uri.make (Some scheme) None None None
      (Some (Tezos_base__TzPervasives.Signature.Public_key.to_b58check pk)) None
      None tt).

Definition neuterize (sk_uri : Tezos_client_base.Client_keys.sk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.pk_uri) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (secret_key sk_uri)
    (fun sk =>
      Tezos_base__TzPervasives._return
        (make_pk
          (Tezos_base__TzPervasives.Signature.Secret_key.to_public_key sk))).

Definition public_key_hash (pk_uri : Tezos_client_base.Client_keys.pk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_crypto__Signature.Public_key_hash.t *
        (option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (public_key pk_uri)
    (fun pk =>
      Tezos_base__TzPervasives._return
        ((Tezos_base__TzPervasives.Signature.Public_key.hash pk), (Some pk))).

Definition import_secret_key {A : Type} (function_parameter : A)
  : Tezos_client_base.Client_keys.pk_uri ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_crypto__Signature.Public_key_hash.t *
          (option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
  match function_parameter with
  | _ => public_key_hash
  end.

Definition sign
  (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (secret_key sk_uri)
    (fun sk =>
      Tezos_base__TzPervasives._return
        (Tezos_base__TzPervasives.Signature.sign watermark sk buf)).

Definition deterministic_nonce
  (sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (secret_key sk_uri)
    (fun sk =>
      Tezos_base__TzPervasives._return
        (Tezos_base__TzPervasives.Signature.deterministic_nonce sk buf)).

Definition deterministic_nonce_hash
  (sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (secret_key sk_uri)
    (fun sk =>
      Tezos_base__TzPervasives._return
        (Tezos_base__TzPervasives.Signature.deterministic_nonce_hash sk buf)).

Definition supports_deterministic_nonces {A : Type} (function_parameter : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  match function_parameter with
  | _ => Tezos_base__TzPervasives.return_true
  end.
src/lib_signer_backends/unencrypted.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Client_keys.SIGNER

val make_pk : Signature.public_key -> Client_keys.pk_uri

val make_sk : Signature.secret_key -> Client_keys.sk_uri
src/lib_signer_backends/unencrypted.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter make_pk :
Tezos_base__TzPervasives.Signature.public_key ->
  Tezos_client_base.Client_keys.pk_uri.

Parameter make_sk :
Tezos_base__TzPervasives.Signature.secret_key ->
  Tezos_client_base.Client_keys.sk_uri.
src/lib_signer_backends/unix/ledger.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys

include Internal_event.Legacy_logging.Make (struct
  let name = "client.signer.ledger"
end)

module Bip32_path = struct
  let hard = Int32.logor 0x8000_0000l

  let unhard = Int32.logand 0x7fff_ffffl

  let is_hard n = Int32.logand 0x8000_0000l n <> 0l

  let tezos_root = [hard 44l; hard 1729l]

  let node_of_string str =
    match Int32.of_string_opt str with
    | Some node ->
        Some node
    | None -> (
      match Int32.of_string_opt String.(sub str 0 (length str - 1)) with
      | None ->
          None
      | Some node ->
          Some (hard node) )

  let node_of_string_exn str =
    match node_of_string str with
    | None ->
        invalid_arg (Printf.sprintf "node_of_string_exn: got %S" str)
    | Some str ->
        str

  let pp_node ppf node =
    match is_hard node with
    | true ->
        Fmt.pf ppf "%ldh" (unhard node)
    | false ->
        Fmt.pf ppf "%ld" node

  let string_of_node = Fmt.to_to_string pp_node

  let path_of_string_exn s =
    match String.split_on_char '/' s with
    | [""] ->
        []
    | nodes ->
        List.map node_of_string_exn nodes

  let path_of_string s = try Some (path_of_string_exn s) with _ -> None

  let pp_path = Fmt.(list ~sep:(const char '/') pp_node)

  let string_of_path = Fmt.to_to_string pp_path
end

type error +=
  | LedgerError of Ledgerwallet.Transport.error
  | Ledger_signing_hash_mismatch of string * string

let error_encoding =
  let open Data_encoding in
  conv
    (fun e -> Format.asprintf "%a" Ledgerwallet.Transport.pp_error e)
    (fun _ -> invalid_arg "Ledger error is not deserializable")
    (obj1 (req "ledger-error" string))

let () =
  register_error_kind
    `Permanent
    ~id:"signer.ledger"
    ~title:"Ledger error"
    ~description:"Error communicating with a Ledger Nano device"
    ~pp:(fun ppf e ->
      Format.fprintf ppf "@[Ledger %a@]" Ledgerwallet.Transport.pp_error e)
    error_encoding
    (function LedgerError e -> Some e | _ -> None)
    (fun e -> LedgerError e)

let () =
  let description ledger_hash computed_hash =
    let paren fmt hash_opt =
      match Base.Option.bind ~f:Blake2B.of_string_opt hash_opt with
      | None ->
          ()
      | Some hash ->
          Format.fprintf fmt " (%a)" Blake2B.pp_short hash
    in
    Format.asprintf
      "The ledger returned a hash%a which doesn't match the independently \
       computed hash%a."
      paren
      ledger_hash
      paren
      computed_hash
  in
  register_error_kind
    `Permanent
    ~id:"signer.ledger.signing-hash-mismatch"
    ~title:"Ledger signing-hash mismatch"
    ~description:(description None None)
    ~pp:(fun ppf (lh, ch) ->
      Format.pp_print_string ppf (description (Some lh) (Some ch)))
    Data_encoding.(
      obj2 (req "ledger-hash" string) (req "computed-hash" string))
    (function
      | Ledger_signing_hash_mismatch (lh, ch) -> Some (lh, ch) | _ -> None)
    (fun (lh, ch) -> Ledger_signing_hash_mismatch (lh, ch))

(** Wrappers around Ledger APDUs. *)
module Ledger_commands = struct
  let wrap_ledger_cmd f =
    let buf = Buffer.create 100 in
    let pp =
      Format.make_formatter
        (fun s ofs lgth -> Buffer.add_substring buf s ofs lgth)
        (fun () ->
          debug "%s%!" (Buffer.contents buf) ;
          Buffer.clear buf)
    in
    let res = f pp in
    lwt_debug "%!"
    >>= fun () ->
    match res with Error err -> fail (LedgerError err) | Ok v -> return v

  let get_version ~device_info h =
    let buf = Buffer.create 100 in
    let pp = Format.formatter_of_buffer buf in
    let version = Ledgerwallet_tezos.get_version ~pp h in
    debug "%s" (Buffer.contents buf) ;
    match version with
    | Error e ->
        warn
          "WARNING:@ The device at [%s] is not a Tezos application@ %a"
          device_info.Hidapi.path
          Ledgerwallet.Transport.pp_error
          e ;
        return_none
    | Ok version ->
        ( if (version.major, version.minor) < (1, 4) then
          failwith
            "Version %a of the ledger apps is not supported by this client"
            Ledgerwallet_tezos.Version.pp
            version
        else return_unit )
        >>=? fun () ->
        wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_git_commit ~pp h)
        >>=? fun git_commit ->
        log_info
          "Found a %a application at [%s] (git-description: %S)"
          Ledgerwallet_tezos.Version.pp
          version
          device_info.path
          git_commit ;
        let cleaned_up =
          (* The ledger sends a NUL-terminated C-String: *)
          if git_commit.[String.length git_commit - 1] = '\x00' then
            String.sub git_commit 0 (String.length git_commit - 1)
          else git_commit
        in
        return_some (version, cleaned_up)

  let secp256k1_ctx =
    Libsecp256k1.External.Context.create ~sign:false ~verify:false ()

  let public_key_returning_instruction which ?(prompt = false) hidapi curve
      path =
    let path = Bip32_path.tezos_root @ path in
    ( match which with
    | `Get_public_key ->
        wrap_ledger_cmd (fun pp ->
            Ledgerwallet_tezos.get_public_key ~prompt ~pp hidapi curve path)
    | `Authorize_baking ->
        wrap_ledger_cmd (fun pp ->
            Ledgerwallet_tezos.authorize_baking ~pp hidapi curve path)
    | `Setup (main_chain_id, main_hwm, test_hwm) ->
        wrap_ledger_cmd (fun pp ->
            Ledgerwallet_tezos.setup_baking
              ~pp
              hidapi
              curve
              path
              ~main_chain_id
              ~main_hwm
              ~test_hwm) )
    >>|? fun pk ->
    match curve with
    | Ed25519 | Bip32_ed25519 ->
        let pk = Cstruct.to_bytes pk in
        TzEndian.set_int8 pk 0 0 ;
        (* hackish, but works. *)
        Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding pk
    | Secp256k1 ->
        let open Libsecp256k1.External in
        let buf = Bigstring.create (Key.compressed_pk_bytes + 1) in
        let pk = Key.read_pk_exn secp256k1_ctx (Cstruct.to_bigarray pk) in
        EndianBigstring.BigEndian.set_int8 buf 0 1 ;
        let _nb_written = Key.write secp256k1_ctx ~pos:1 buf pk in
        Data_encoding.Binary.of_bytes_exn
          Signature.Public_key.encoding
          (Bigstring.to_bytes buf)
    | Secp256r1 -> (
        let open Uecc in
        let pklen = compressed_size secp256r1 in
        let buf = Bigstring.create (pklen + 1) in
        match pk_of_bytes secp256r1 (Cstruct.to_bigarray pk) with
        | None ->
            Pervasives.failwith
              "Impossible to read P256 public key from Ledger"
        | Some pk ->
            EndianBigstring.BigEndian.set_int8 buf 0 2 ;
            let _nb_written =
              write_key ~compress:true (Bigstring.sub buf 1 pklen) pk
            in
            Data_encoding.Binary.of_bytes_exn
              Signature.Public_key.encoding
              (Bigstring.to_bytes buf) )

  let get_public_key = public_key_returning_instruction `Get_public_key

  let pkh_of_pk = Signature.Public_key.hash

  let public_key ?(first_import : Client_context.io_wallet option) hid curve
      path =
    match first_import with
    | Some cctxt ->
        get_public_key ~prompt:false hid curve path
        >>=? fun pk ->
        let pkh = pkh_of_pk pk in
        cctxt#message
          "Please validate@ (and write down)@ the public key hash@ displayed@ \
           on the Ledger,@ it should be equal@ to `%a`:"
          Signature.Public_key_hash.pp
          pkh
        >>= fun () -> get_public_key ~prompt:true hid curve path
    | None ->
        get_public_key ~prompt:false hid curve path

  let public_key_hash ?first_import hid curve path =
    public_key ?first_import hid curve path
    >>=? fun pk -> return (pkh_of_pk pk, pk)

  let get_authorized_path hid version =
    let open Ledgerwallet_tezos.Version in
    if version.major < 2 then
      wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_authorized_key ~pp hid)
      >>|? fun path -> `Legacy_path path
    else
      wrap_ledger_cmd (fun pp ->
          Ledgerwallet_tezos.get_authorized_path_and_curve ~pp hid)
      >>= function
      | Error
          (LedgerError
             (AppError
               { status =
                   Ledgerwallet.Transport.Status.Referenced_data_not_found;
                 _ })
          :: _) ->
          return `No_baking_authorized
      | Error _ as e ->
          Lwt.return e
      | Ok (path, curve) ->
          return (`Path_curve (path, curve))

  let sign ?watermark ~version hid curve path (base_msg : Bytes.t) =
    let msg =
      Option.unopt_map watermark ~default:base_msg ~f:(fun watermark ->
          Bytes.cat (Signature.bytes_of_watermark watermark) base_msg)
    in
    let path = Bip32_path.tezos_root @ path in
    wrap_ledger_cmd (fun pp ->
        let {Ledgerwallet_tezos.Version.major; minor; patch; _} = version in
        let open Rresult.R.Infix in
        if (major, minor, patch) <= (2, 0, 0) then
          Ledgerwallet_tezos.sign ~pp hid curve path (Cstruct.of_bytes msg)
          >>= fun s -> Ok (None, s)
        else
          Ledgerwallet_tezos.sign_and_hash
            ~pp
            hid
            curve
            path
            (Cstruct.of_bytes msg)
          >>= fun (h, s) -> Ok (Some h, s))
    >>=? fun (hash_opt, signature) ->
    ( match hash_opt with
    | None ->
        return_unit
    | Some hsh ->
        let hash_msg = Blake2B.hash_bytes [msg] in
        let ledger_one = Blake2B.of_bytes_exn (Cstruct.to_bytes hsh) in
        if Blake2B.equal hash_msg ledger_one then return_unit
        else
          fail
            (Ledger_signing_hash_mismatch
               (Blake2B.to_string ledger_one, Blake2B.to_string hash_msg)) )
    >>=? fun () ->
    match curve with
    | Ed25519 | Bip32_ed25519 ->
        let signature = Ed25519.of_bytes_exn (Cstruct.to_bytes signature) in
        return (Signature.of_ed25519 signature)
    | Secp256k1 ->
        (* Remove parity info *)
        Cstruct.(set_uint8 signature 0 (get_uint8 signature 0 land 0xfe)) ;
        let signature = Cstruct.to_bigarray signature in
        let open Libsecp256k1.External in
        let signature = Sign.read_der_exn secp256k1_ctx signature in
        let bytes = Sign.to_bytes secp256k1_ctx signature in
        let signature = Secp256k1.of_bytes_exn (Bigstring.to_bytes bytes) in
        return (Signature.of_secp256k1 signature)
    | Secp256r1 ->
        (* Remove parity info *)
        Cstruct.(set_uint8 signature 0 (get_uint8 signature 0 land 0xfe)) ;
        let signature = Cstruct.to_bigarray signature in
        let open Libsecp256k1.External in
        (* We use secp256r1 library to extract P256 DER signature. *)
        let signature = Sign.read_der_exn secp256k1_ctx signature in
        let buf = Sign.to_bytes secp256k1_ctx signature in
        let signature = P256.of_bytes_exn (Bigstring.to_bytes buf) in
        return (Signature.of_p256 signature)

  let get_deterministic_nonce hid curve path msg =
    let path = Bip32_path.tezos_root @ path in
    wrap_ledger_cmd (fun pp ->
        Ledgerwallet_tezos.get_deterministic_nonce
          ~pp
          hid
          curve
          path
          (Cstruct.of_bytes msg))
    >>=? fun nonce -> return (Bigstring.of_bytes (Cstruct.to_bytes nonce))
end

(** Identification of a ledger's root key through crouching-tigers
    (not the keys used for an account). *)
module Ledger_id = struct
  (**
     The “ID” of the ledger is the animals (or pkh) corresponding to
     ["/ed25519/"] (first curve, no path).
  *)
  type t = Animals of Ledger_names.t | Pkh of Signature.public_key_hash

  let animals_of_pkh pkh =
    pkh |> Signature.Public_key_hash.to_string |> Ledger_names.crouching_tiger

  let curve = Ledgerwallet_tezos.Ed25519

  let get hidapi =
    Ledger_commands.get_public_key hidapi curve []
    >>=? fun pk ->
    let pkh = Signature.Public_key.hash pk in
    let animals = animals_of_pkh pkh in
    return (Animals animals)

  let pp ppf = function
    | Animals a ->
        Ledger_names.pp ppf a
    | Pkh pkh ->
        Signature.Public_key_hash.pp ppf pkh

  let to_animals = function Animals a -> a | Pkh pkh -> animals_of_pkh pkh

  let equal a b = to_animals a = to_animals b
end

(** An account is a given key-pair corresponding to a
    [ledger + curve + derivation-path]. *)
module Ledger_account = struct
  type t = {
    ledger : Ledger_id.t;
    curve : Ledgerwallet_tezos.curve;
    path : int32 list;
  }
end

(** {!Ledger_uri.t} represents a parsed ["ledger://..."] URI which may
    refer to a {!Ledger_id.t} or a full blown {!Ledger_account.t}. *)
module Ledger_uri = struct
  type t = [`Ledger of Ledger_id.t | `Ledger_account of Ledger_account.t]

  let int32_of_path_element_exn ~allow_weak x =
    let failf ppf = Printf.ksprintf Pervasives.failwith ppf in
    let len = String.length x in
    match x.[len - 1] with
    | exception _ ->
        failf "Empty path element"
    | '\'' | 'h' -> (
        let intpart = String.sub x 0 (len - 1) in
        match Int32.of_string_opt intpart with
        | Some i ->
            Bip32_path.hard i
        | None ->
            failf "Path is not an integer: %S" intpart )
    | _ when allow_weak -> (
      match Int32.of_string_opt x with
      | Some i ->
          i
      | None ->
          failf "Path is not a non-hardened integer: %S" x )
    | _ ->
        failf
          "Non-hardened paths are not allowed for this derivation scheme (%S)"
          x

  let parse_animals animals =
    match String.split '-' animals with
    | [c; t; h; d] ->
        Some {Ledger_names.c; t; h; d}
    | _ ->
        None

  let derivation_supports_weak_paths = function
    | Ledgerwallet_tezos.Ed25519 ->
        false
    | Ledgerwallet_tezos.Secp256k1 ->
        true
    | Ledgerwallet_tezos.Secp256r1 ->
        true
    | Ledgerwallet_tezos.Bip32_ed25519 ->
        true

  let parse ?allow_weak uri : t tzresult Lwt.t =
    let host = Uri.host uri in
    ( match Option.apply host ~f:Signature.Public_key_hash.of_b58check_opt with
    | Some pkh ->
        return (Ledger_id.Pkh pkh)
    | None -> (
      match Option.apply host ~f:parse_animals with
      | Some animals ->
          return (Ledger_id.Animals animals)
      | None ->
          failwith "Cannot parse host of URI: %s" (Uri.to_string uri) ) )
    >>=? fun ledger ->
    let components = String.split '/' (Uri.path uri) in
    match components with
    | s :: tl ->
        let (curve, more_path) =
          match Ledgerwallet_tezos.curve_of_string s with
          | Some curve ->
              (curve, tl)
          | None ->
              (Ledger_id.curve, s :: tl)
        in
        let actually_allow_weak =
          match allow_weak with
          | None ->
              derivation_supports_weak_paths curve
          | Some x ->
              x
        in
        ( try
            return
              (List.map
                 (int32_of_path_element_exn ~allow_weak:actually_allow_weak)
                 more_path)
          with Failure s ->
            failwith
              "Failed to parse Curve/BIP32 path from %s (%s): %s"
              (Uri.path uri)
              (Uri.to_string uri)
              s )
        >>=? fun bip32 ->
        return (`Ledger_account Ledger_account.{ledger; curve; path = bip32})
    | [] ->
        return (`Ledger ledger)

  let ledger_uri_or_alias_param next =
    let name = "account-alias-or-ledger-uri" in
    let desc =
      "An imported ledger alias or a ledger URI (e.g. \
       \"ledger://animal/curve/path\")."
    in
    let open Clic in
    param
      ~name
      ~desc
      (parameter (fun cctxt str ->
           Public_key.find_opt cctxt str
           >>=? (function
                  | Some ((x : pk_uri), _) ->
                      return (x :> Uri.t)
                  | None -> (
                    try return (Uri.of_string str)
                    with e ->
                      failwith
                        "Error while parsing URI: %s"
                        (Printexc.to_string e) ))
           >>=? fun uri -> parse uri))
      next

  let pp : _ -> t -> unit =
   fun ppf ->
    Format.(
      function
      | `Ledger lid ->
          fprintf ppf "ledger://%a" Ledger_id.pp lid
      | `Ledger_account {Ledger_account.ledger; curve; path} ->
          fprintf
            ppf
            "ledger://%a/%a/%a"
            Ledger_id.pp
            ledger
            Ledgerwallet_tezos.pp_curve
            curve
            Bip32_path.pp_path
            path)

  let if_matches (meta_uri : t) ledger_id cont =
    match meta_uri with
    | `Ledger l ->
        if Ledger_id.equal l ledger_id then cont () else return_none
    | `Ledger_account {Ledger_account.ledger; _} ->
        if Ledger_id.equal ledger ledger_id then cont () else return_none

  let full_account (ledger_uri : t) =
    match ledger_uri with
    | `Ledger_account acc ->
        return acc
    | `Ledger ledger_id ->
        failwith
          "Insufficient information: you need to provide a curve & BIP32 path \
           (%a)."
          Ledger_id.pp
          ledger_id
end

(** Filters allow early dismissal of HID devices/ledgers which
    searching for a ledger. *)
module Filter = struct
  type version_filter = Ledgerwallet_tezos.Version.t * string -> bool

  type t = [`None | `Hid_path of string | `Version of string * version_filter]

  let version_matches (t : t) version_commit =
    match t with `Version (_, f) -> f version_commit | _ -> true

  let is_app : _ -> _ -> t =
   fun msg app ->
    `Version
      ( msg,
        fun ({Ledgerwallet_tezos.Version.app_class; _}, _) -> app = app_class
      )

  let is_baking = is_app "App = Baking" Ledgerwallet_tezos.Version.TezBake

  let pp ppf (f : t) =
    let open Format in
    match f with
    | `None ->
        fprintf ppf "None"
    | `Hid_path s ->
        fprintf ppf "HID-path: %s" s
    | `Version (s, _) ->
        fprintf ppf "%s" s
end

(* Those constants are provided by the vendor (e.g. check the udev
   rules they provide): *)
let vendor_id = 0x2c97

let product_id_nano_s = 0x0001

let product_id_nano_x = 0x0004

let use_ledger ?(filter : Filter.t = `None) f =
  let ledgers =
    Hidapi.enumerate ~vendor_id ~product_id:product_id_nano_s ()
    @ Hidapi.enumerate ~vendor_id ~product_id:product_id_nano_x ()
  in
  debug
    "Found %d Ledger(s) %s"
    (List.length ledgers)
    (String.concat
       " -- "
       (List.map
          Hidapi.(
            fun l -> Printf.sprintf "(%04x, %04x)" l.vendor_id l.product_id)
          ledgers)) ;
  let process_device device_info f =
    log_info "Processing Ledger at path [%s]" device_info.Hidapi.path ;
    (* HID interfaces get the number 0
       (cf. https://github.com/LedgerHQ/ledger-nano-s/issues/48)
       *BUT* on MacOSX the Hidapi library does not report the interface-number
       so we look at the usage-page (which is even more unspecified but used by
       prominent Ledger users:
       https://github.com/LedgerHQ/ledgerjs/commit/333ade0d55dc9c59bcc4b451cf7c976e78629681).
    *)
    if
      device_info.Hidapi.interface_number = 0
      || device_info.Hidapi.interface_number = -1
         && device_info.Hidapi.usage_page = 0xffa0
    then
      match filter with
      | `Hid_path hp when device_info.path <> hp ->
          return_none
      | _ -> (
        match Hidapi.(open_path device_info.path) with
        | None ->
            return_none
        | Some h ->
            Lwt.finalize
              (fun () ->
                Ledger_commands.get_version ~device_info h
                >>=? function
                | Some version_git
                  when Filter.version_matches filter version_git ->
                    Ledger_id.get h
                    >>=? fun ledger_id -> f h version_git device_info ledger_id
                | None | Some _ ->
                    return_none)
              (fun () -> Hidapi.close h ; Lwt.return_unit) )
    else return_none
  in
  let rec go = function
    | [] ->
        return_none
    | h :: t -> (
        process_device h f
        >>=? function Some x -> return_some x | None -> go t )
  in
  go ledgers

let min_version_of_derivation_scheme = function
  | Ledgerwallet_tezos.Ed25519 ->
      (1, 3, 0)
  | Ledgerwallet_tezos.Secp256k1 ->
      (1, 3, 0)
  | Ledgerwallet_tezos.Secp256r1 ->
      (1, 3, 0)
  | Ledgerwallet_tezos.Bip32_ed25519 ->
      (2, 1, 0)

let is_derivation_scheme_supported version curve =
  Ledgerwallet_tezos.Version.(
    let {major; minor; patch; _} = version in
    (major, minor, patch) >= min_version_of_derivation_scheme curve)

let use_ledger_or_fail ~ledger_uri ?filter ?msg f =
  use_ledger ?filter (fun hidapi (version, git_commit) device_info ledger_id ->
      Ledger_uri.if_matches ledger_uri ledger_id (fun () ->
          let go () = f hidapi (version, git_commit) device_info ledger_id in
          match ledger_uri with
          | `Ledger_account {curve; _} ->
              if is_derivation_scheme_supported version curve then go ()
              else
                Ledgerwallet_tezos.(
                  failwith
                    "To use derivation scheme %a you need %a or later but \
                     you're using %a."
                    pp_curve
                    curve
                    Version.pp
                    (let (a, b, c) = min_version_of_derivation_scheme curve in
                     {version with major = a; minor = b; patch = c})
                    Version.pp
                    version)
          | _ ->
              go ()))
  >>=? function
  | Some o ->
      return o
  | None ->
      failwith
        "%sFound no ledger corresponding to %a%t."
        (Option.unopt_map ~default:"" ~f:(Printf.sprintf "%s: ") msg)
        Ledger_uri.pp
        ledger_uri
        (fun ppf ->
          match filter with
          | Some f ->
              Format.fprintf ppf " with filter \"%a\"" Filter.pp f
          | None ->
              ())

(** A global {!Hashtbl.t} which allows us to avoid calling
    {!Signer_implementation.get_public_key} too often. *)
module Global_cache : sig
  val record :
    pk_uri -> pk:Signature.public_key -> pkh:Signature.public_key_hash -> unit

  val get : pk_uri -> (Signature.public_key_hash * Signature.public_key) option
end = struct
  let _cache :
      (pk_uri, Signature.Public_key_hash.t * Signature.Public_key.t) Hashtbl.t
      =
    Hashtbl.create 13

  let record pk_uri ~pk ~pkh = Hashtbl.replace _cache pk_uri (pkh, pk)

  let get pk_uri = Hashtbl.find_opt _cache pk_uri
end

(** The implementation of the “signer-plugin.” *)
module Signer_implementation : Client_keys.SIGNER = struct
  let scheme = "ledger"

  let title = "Built-in signer using a Ledger Nano device."

  let description =
    Printf.sprintf
      "Valid URIs are of the form\n\
      \ - ledger://<animals>/<curve>[/<path>]\n\
       where:\n\
      \ - <animals> is the identifier of the ledger of the form \
       'crouching-tiger-hidden-dragon' and can be obtained with the command \
       `tezos-client list connected ledgers` (which also provides full \
       examples).\n\
       - <curve> is the signing curve, e.g. `ed1551`\n\
       - <path> is a BIP32 path anchored at m/%s. The ledger does not yet \
       support non-hardened paths, so each node of the path must be hardened."
      Bip32_path.(string_of_path tezos_root)

  let neuterize (sk : sk_uri) = return (make_pk_uri (sk :> Uri.t))

  let pkh_of_pk = Signature.Public_key.hash

  let public_key_maybe_prompt ?(first_import : Client_context.io_wallet option)
      (pk_uri : pk_uri) =
    match Global_cache.get pk_uri with
    | Some (_, pk) ->
        return pk
    | None -> (
        Ledger_uri.parse (pk_uri :> Uri.t)
        >>=? (fun ledger_uri ->
               Ledger_uri.full_account ledger_uri
               >>=? fun {curve; path; _} ->
               use_ledger_or_fail
                 ~ledger_uri
                 (fun hidapi (_version, _git_commit) _device_info _ledger_id ->
                   Ledger_commands.public_key ?first_import hidapi curve path
                   >>=? fun pk ->
                   let pkh = pkh_of_pk pk in
                   Global_cache.record pk_uri ~pkh ~pk ;
                   return_some pk))
        >>= function
        | Error err -> failwith "%a" pp_print_error err | Ok v -> return v )

  let public_key_hash_maybe_prompt ?first_import pk_uri =
    match Global_cache.get pk_uri with
    | Some (pkh, pk) ->
        return (pkh, Some pk)
    | None ->
        public_key_maybe_prompt ?first_import pk_uri
        >>=? fun pk -> return (pkh_of_pk pk, Some pk)

  let public_key = public_key_maybe_prompt ?first_import:None

  let public_key_hash = public_key_hash_maybe_prompt ?first_import:None

  let import_secret_key ~io pk_uri =
    public_key_hash_maybe_prompt ~first_import:io pk_uri

  let sign ?watermark (sk_uri : sk_uri) msg =
    Ledger_uri.parse (sk_uri :> Uri.t)
    >>=? fun ledger_uri ->
    Ledger_uri.full_account ledger_uri
    >>=? fun {curve; path; _} ->
    use_ledger_or_fail
      ~ledger_uri
      (fun hidapi (version, _git_commit) _device_info _ledger_id ->
        Ledger_commands.sign ?watermark ~version hidapi curve path msg
        >>=? fun bytes -> return_some bytes)

  let deterministic_nonce (sk_uri : sk_uri) msg =
    Ledger_uri.parse (sk_uri :> Uri.t)
    >>=? fun ledger_uri ->
    Ledger_uri.full_account ledger_uri
    >>=? fun {curve; path; _} ->
    use_ledger_or_fail
      ~ledger_uri
      (fun hidapi (_version, _git_commit) _device_info _ledger_id ->
        Ledger_commands.get_deterministic_nonce hidapi curve path msg
        >>=? fun bytes -> return_some bytes)

  let deterministic_nonce_hash (sk : sk_uri) msg =
    deterministic_nonce sk msg
    >>=? fun nonce ->
    return (Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce]))

  let supports_deterministic_nonces _ = return_true
end

(* The Ledger uses a special value 0x00000000 for the “any” chain-id: *)
let pp_ledger_chain_id fmt s =
  match s with
  | "\x00\x00\x00\x00" ->
      Format.fprintf fmt "'Unspecified'"
  | other ->
      Format.fprintf fmt "%a" Chain_id.pp (Chain_id.of_string_exn other)

(** Commands for both ledger applications. *)
let generic_commands group =
  Clic.
    [ command
        ~group
        ~desc:"List supported Ledger Nano devices connected."
        no_options
        (fixed ["list"; "connected"; "ledgers"])
        (fun () (cctxt : Client_context.full) ->
          use_ledger
            (fun _hidapi (version, git_commit) device_info ledger_id ->
              let open Hidapi in
              cctxt#message
                "%t"
                Format.(
                  fun ppf ->
                    let intro =
                      asprintf
                        "Found a %a (git-description: %S) application running \
                         on %s %s at [%s]."
                        Ledgerwallet_tezos.Version.pp
                        version
                        git_commit
                        ( device_info.manufacturer_string
                        |> Option.unopt ~default:"NO-MANUFACTURER" )
                        ( device_info.product_string
                        |> Option.unopt ~default:"NO-PRODUCT" )
                        device_info.path
                    in
                    pp_open_vbox ppf 0 ;
                    fprintf ppf "## Ledger `%a`@," Ledger_id.pp ledger_id ;
                    pp_open_hovbox ppf 0 ;
                    pp_print_text ppf intro ;
                    pp_close_box ppf () ;
                    pp_print_cut ppf () ;
                    pp_print_cut ppf () ;
                    pp_open_hovbox ppf 0 ;
                    pp_print_text
                      ppf
                      "To use keys at BIP32 path m/44'/1729'/0'/0' (default \
                       Tezos key path), use one of:" ;
                    pp_close_box ppf () ;
                    pp_print_cut ppf () ;
                    List.iter
                      (fun curve ->
                        fprintf
                          ppf
                          "  tezos-client import secret key ledger_%s \
                           \"ledger://%a/%a/0h/0h\""
                          ( Sys.getenv_opt "USER"
                          |> Option.unopt ~default:"user" )
                          Ledger_id.pp
                          ledger_id
                          Ledgerwallet_tezos.pp_curve
                          curve ;
                        pp_print_cut ppf ())
                      (List.filter
                         (is_derivation_scheme_supported version)
                         [Bip32_ed25519; Ed25519; Secp256k1; Secp256r1]) ;
                    pp_close_box ppf () ;
                    pp_print_newline ppf ())
              >>= fun () -> return_none)
          >>=? fun _ -> return_unit);
      Clic.command
        ~group
        ~desc:"Display version/public-key/address information for a Ledger URI"
        (args1 (switch ~doc:"Test signing operation" ~long:"test-sign" ()))
        ( prefixes ["show"; "ledger"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun test_sign ledger_uri (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            (fun hidapi (version, git_commit) device_info _ledger_id ->
              cctxt#message
                "Found ledger corresponding to %a:"
                Ledger_uri.pp
                ledger_uri
              >>= fun () ->
              cctxt#message
                "* Manufacturer: %s"
                (Option.unopt device_info.manufacturer_string ~default:"NONE")
              >>= fun () ->
              cctxt#message
                "* Product: %s"
                (Option.unopt device_info.product_string ~default:"NONE")
              >>= fun () ->
              cctxt#message
                "* Application: %a (git-description: %S)"
                Ledgerwallet_tezos.Version.pp
                version
                git_commit
              >>= fun () ->
              ( match ledger_uri with
              | `Ledger_account {curve; path; _} -> (
                  cctxt#message
                    "* Curve: `%a`"
                    Ledgerwallet_tezos.pp_curve
                    curve
                  >>= fun () ->
                  let full_path = Bip32_path.tezos_root @ path in
                  cctxt#message
                    "* Path: `%s` [%s]"
                    (Bip32_path.string_of_path full_path)
                    (String.concat
                       "; "
                       (List.map (Printf.sprintf "0x%lX") full_path))
                  >>= fun () ->
                  Ledger_commands.public_key_hash hidapi curve path
                  >>=? fun (pkh, pk) ->
                  cctxt#message "* Public Key: %a" Signature.Public_key.pp pk
                  >>= fun () ->
                  cctxt#message
                    "* Public Key Hash: %a@\n"
                    Signature.Public_key_hash.pp
                    pkh
                  >>= fun () ->
                  match (test_sign, version.app_class) with
                  | (true, Tezos) -> (
                      let pkh_bytes = Signature.Public_key_hash.to_bytes pkh in
                      (* Signing requires validation on the device.  *)
                      cctxt#message
                        "@[Attempting a signature@ (of `%a`),@ please@ \
                         validate on@ the ledger.@]"
                        Hex.pp
                        (Hex.of_bytes pkh_bytes)
                      >>= fun () ->
                      Ledger_commands.sign
                        ~version
                        ~watermark:Generic_operation
                        hidapi
                        curve
                        path
                        pkh_bytes
                      >>=? fun signature ->
                      match
                        Signature.check
                          ~watermark:Generic_operation
                          pk
                          signature
                          pkh_bytes
                      with
                      | false ->
                          failwith
                            "Fatal: Ledger cannot sign with %a"
                            Signature.Public_key_hash.pp
                            pkh
                      | true ->
                          cctxt#message
                            "Tezos Wallet successfully signed:@ %a."
                            Signature.pp
                            signature
                          >>= fun () -> return_unit )
                  | (true, TezBake) ->
                      failwith
                        "Option --test-sign only works for the Tezos Wallet \
                         app."
                  | (false, _) ->
                      return_unit )
              | `Ledger _ when test_sign ->
                  failwith
                    "Option --test-sign only works with a full ledger \
                     URI/account (with curve/path)."
              | `Ledger _ ->
                  cctxt#message "* This is just a ledger URI."
                  >>= fun () -> return_unit )
              >>=? fun () -> return_some ())) ]

(** Commands specific to the Baking app minus the high-water-mark ones
    which get a specific treatment in {!high_water_mark_commands}. *)
let baking_commands group =
  Clic.
    [ Clic.command
        ~group
        ~desc:"Query the path of the authorized key"
        no_options
        ( prefixes ["get"; "ledger"; "authorized"; "path"; "for"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun () ledger_uri (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              Ledger_commands.get_authorized_path hidapi version
              >>=? fun authorized ->
              match authorized with
              | `Legacy_path p ->
                  cctxt#message
                    "@[<v 0>Authorized baking path (Legacy < 2.x.y): %a@]"
                    Bip32_path.pp_path
                    p
                  >>= fun () -> return_some ()
              | `No_baking_authorized ->
                  cctxt#message "No baking key authorized at all."
                  >>= fun () -> return_some ()
              | `Path_curve (ledger_path, ledger_curve) -> (
                  cctxt#message
                    "@[<v 0>Authorized baking path: %a@]"
                    Bip32_path.pp_path
                    ledger_path
                  >>= fun () ->
                  cctxt#message
                    "@[<v 0>Authorized baking curve: %a@]"
                    Ledgerwallet_tezos.pp_curve
                    ledger_curve
                  >>= fun () ->
                  match ledger_uri with
                  | `Ledger _ ->
                      return_some ()
                  | `Ledger_account {curve; path; _}
                    when curve = ledger_curve
                         && Bip32_path.tezos_root @ path = ledger_path ->
                      cctxt#message
                        "@[<v 0>Authorized baking URI: %a@]"
                        Ledger_uri.pp
                        ledger_uri
                      >>= fun () -> return_some ()
                  | `Ledger_account {curve; path; _} ->
                      failwith
                        "Path and curve do not match the ones specified in \
                         the command line: %a & %a"
                        Ledgerwallet_tezos.pp_curve
                        curve
                        Bip32_path.pp_path
                        (Bip32_path.tezos_root @ path) )));
      Clic.command
        ~group
        ~desc:
          "Authorize a Ledger to bake for a key (deprecated, use `setup \
           ledger ...` with recent versions of the Baking app)"
        no_options
        ( prefixes ["authorize"; "ledger"; "to"; "bake"; "for"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun () ledger_uri (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              ( match version with
              | {Ledgerwallet_tezos.Version.app_class = Tezos; _} ->
                  failwith
                    "This command (`authorize ledger ...`) only works with \
                     the Tezos Baking app"
              | {Ledgerwallet_tezos.Version.app_class = TezBake; major; _}
                when major >= 2 ->
                  failwith
                    "This command (`authorize ledger ...`) is@ not compatible \
                     with@ this version of the Ledger@ Baking app (%a >= \
                     2.0.0),@ please use the command@ `setup ledger to bake \
                     for ...`@ from now on."
                    Ledgerwallet_tezos.Version.pp
                    version
              | _ ->
                  cctxt#message
                    "This Ledger Baking app is outdated (%a)@ running@ in \
                     backwards@ compatibility mode."
                    Ledgerwallet_tezos.Version.pp
                    version
                  >>= fun () -> return_unit )
              >>=? fun () ->
              Ledger_uri.full_account ledger_uri
              >>=? fun {Ledger_account.curve; path; _} ->
              Ledger_commands.public_key_returning_instruction
                `Authorize_baking
                hidapi
                curve
                path
              >>=? fun pk ->
              let pkh = Signature.Public_key.hash pk in
              cctxt#message
                "@[<v 0>Authorized baking for address: %a@,\
                 Corresponding full public key: %a@]"
                Signature.Public_key_hash.pp
                pkh
                Signature.Public_key.pp
                pk
              >>= fun () -> return_some ()));
      Clic.command
        ~group
        ~desc:"Setup a Ledger to bake for a key"
        (let hwm_arg kind =
           let doc =
             Printf.sprintf
               "Use <HWM> as %s chain high watermark instead of asking the \
                ledger."
               kind
           in
           let long = kind ^ "-hwm" in
           default_arg
             ~doc
             ~long
             ~placeholder:"HWM"
             ~default:"ASK-LEDGER"
             (parameter (fun _ ->
                function
                | "ASK-LEDGER" ->
                    return_none
                | s -> (
                  try return_some (Int32.of_string s)
                  with _ ->
                    failwith "Parameter %S should be a 32-bits integer" s )))
         in
         args3
           (default_arg
              ~doc:"Use <ID> as main chain-id instead of asking the node."
              ~long:"main-chain-id"
              ~placeholder:"ID"
              ~default:"ASK-NODE"
              (parameter (fun _ ->
                 function
                 | "ASK-NODE" ->
                     return `Ask_node
                 | s -> (
                   try return (`Int32 (Int32.of_string s))
                   with _ -> (
                     try return (`Chain_id (Chain_id.of_b58check_exn s))
                     with _ ->
                       failwith
                         "Parameter %S should be a 32-bits integer or a \
                          Base58 chain-id"
                         s ) ))))
           (hwm_arg "main")
           (hwm_arg "test"))
        ( prefixes ["setup"; "ledger"; "to"; "bake"; "for"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun (chain_id_opt, main_hwm_opt, test_hwm_opt)
             ledger_uri
             (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              (let open Ledgerwallet_tezos.Version in
              match version with
              | {app_class = Tezos; _} ->
                  failwith
                    "This command (`setup ledger ...`) only works with the \
                     Tezos Baking app"
              | {app_class = TezBake; major; _} when major < 2 ->
                  failwith
                    "This command (`setup ledger ...`)@ is not@ compatible@ \
                     with this version@ of the Ledger Baking app@ (%a < \
                     2.0.0),@ please upgrade@ your ledger@ or use the \
                     command@ `authorize ledger to bake for ...`"
                    pp
                    version
              | _ ->
                  return_unit)
              >>=? fun () ->
              Ledger_uri.full_account ledger_uri
              >>=? fun {Ledger_account.curve; path; _} ->
              let chain_id_of_int32 i32 =
                let open Int32 in
                let byte n =
                  logand 0xFFl (shift_right i32 (n * 8))
                  |> Int32.to_int |> char_of_int
                in
                Chain_id.of_string_exn
                  (Stringext.of_array (Array.init 4 (fun i -> byte (3 - i))))
              in
              ( match chain_id_opt with
              | `Ask_node ->
                  Chain_services.chain_id cctxt ()
              | `Int32 s ->
                  return (chain_id_of_int32 s)
              | `Chain_id chid ->
                  return chid )
              >>=? fun main_chain_id ->
              Ledger_commands.wrap_ledger_cmd (fun pp ->
                  Ledgerwallet_tezos.get_all_high_watermarks ~pp hidapi)
              >>=? fun ( `Main_hwm current_mh,
                         `Test_hwm current_th,
                         `Chain_id current_ci ) ->
              let main_hwm = Option.unopt main_hwm_opt ~default:current_mh in
              let test_hwm = Option.unopt test_hwm_opt ~default:current_th in
              cctxt#message
                "Setting up the ledger:@.* Main chain ID: %a -> %a@.* Main \
                 chain High Watermark: %ld -> %ld@.* Test chain High \
                 Watermark: %ld -> %ld"
                pp_ledger_chain_id
                current_ci
                Chain_id.pp
                main_chain_id
                current_mh
                main_hwm
                current_th
                test_hwm
              >>= fun () ->
              Ledger_commands.public_key_returning_instruction
                (`Setup (Chain_id.to_string main_chain_id, main_hwm, test_hwm))
                hidapi
                curve
                path
              >>=? fun pk ->
              let pkh = Signature.Public_key.hash pk in
              cctxt#message
                "@[<v 0>Authorized baking for address: %a@,\
                 Corresponding full public key: %a@]"
                Signature.Public_key_hash.pp
                pkh
                Signature.Public_key.pp
                pk
              >>= fun () -> return_some ()));
      Clic.command
        ~group
        ~desc:"Deauthorize Ledger from baking"
        no_options
        ( prefixes ["deauthorize"; "ledger"; "baking"; "for"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun () ledger_uri (_cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (_version, _git_commit) _device_info _ledger_id ->
              Ledger_commands.wrap_ledger_cmd (fun pp ->
                  Ledgerwallet_tezos.deauthorize_baking ~pp hidapi)
              >>=? fun () -> return_some ())) ]

(** Commands for high water mark of the Baking app. The
    [watermark_spelling] argument is used to make 2 sets of commands: with
    the old/wrong spelling “watermark” for backwards compatibility and
    with the correct one “high water mark” (it's a mark of the highest
    water level). *)
let high_water_mark_commands group watermark_spelling =
  let make_desc desc =
    if List.length watermark_spelling = 1 then
      desc ^ " (legacy/deprecated spelling)"
    else desc
  in
  Clic.
    [ Clic.command
        ~group
        ~desc:(make_desc "Get high water mark of a Ledger")
        (args1
           (switch
              ~doc:
                "Prevent the fallback to the (deprecated) Ledger instructions \
                 (for 1.x.y versions of the Baking app)"
              ~long:"no-legacy-instructions"
              ()))
        ( prefixes (["get"; "ledger"; "high"] @ watermark_spelling @ ["for"])
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun no_legacy_apdu ledger_uri (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              match version.app_class with
              | Tezos ->
                  failwith
                    "Fatal: this operation is only valid with the Tezos \
                     Baking application"
              | TezBake when (not no_legacy_apdu) && version.major < 2 ->
                  Ledger_commands.wrap_ledger_cmd (fun pp ->
                      Ledgerwallet_tezos.get_high_watermark ~pp hidapi)
                  >>=? fun hwm ->
                  cctxt#message
                    "The high water mark for@ %a@ is %ld."
                    Ledger_uri.pp
                    ledger_uri
                    hwm
                  >>= fun () -> return_some ()
              | TezBake when no_legacy_apdu && version.major < 2 ->
                  failwith
                    "Cannot get the high water mark with@ \
                     `--no-legacy-instructions` and version %a"
                    Ledgerwallet_tezos.Version.pp
                    version
              | TezBake ->
                  Ledger_commands.wrap_ledger_cmd (fun pp ->
                      Ledgerwallet_tezos.get_all_high_watermarks ~pp hidapi)
                  >>=? fun (`Main_hwm mh, `Test_hwm th, `Chain_id ci) ->
                  cctxt#message
                    "The high water mark values for@ %a@ are@ %ld for the \
                     main-chain@ (%a)@ and@ %ld for the test-chain."
                    Ledger_uri.pp
                    ledger_uri
                    mh
                    pp_ledger_chain_id
                    ci
                    th
                  >>= fun () -> return_some ()));
      Clic.command
        ~group
        ~desc:(make_desc "Set high water mark of a Ledger")
        no_options
        ( prefixes (["set"; "ledger"; "high"] @ watermark_spelling @ ["for"])
        @@ Ledger_uri.ledger_uri_or_alias_param @@ prefix "to"
        @@ param
             ~name:"high watermark"
             ~desc:"High watermark"
             (parameter (fun _ctx s ->
                  try return (Int32.of_string s)
                  with _ -> failwith "%s is not an int32 value" s))
        @@ stop )
        (fun () ledger_uri hwm (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              match version.app_class with
              | Tezos ->
                  failwith "Fatal: this operation is only valid with TezBake"
              | TezBake ->
                  Ledger_commands.wrap_ledger_cmd (fun pp ->
                      Ledgerwallet_tezos.set_high_watermark ~pp hidapi hwm)
                  >>=? fun () ->
                  Ledger_commands.wrap_ledger_cmd (fun pp ->
                      Ledgerwallet_tezos.get_high_watermark ~pp hidapi)
                  >>=? fun new_hwm ->
                  cctxt#message
                    "@[<v 0>%a has now high water mark: %ld@]"
                    Ledger_uri.pp
                    ledger_uri
                    new_hwm
                  >>= fun () -> return_some ())) ]

let commands =
  let group =
    {
      Clic.name = "ledger";
      title = "Commands for managing the connected Ledger Nano devices";
    }
  in
  fun () ->
    generic_commands group @ baking_commands group
    @ high_water_mark_commands group ["water"; "mark"]
    @ high_water_mark_commands group ["watermark"]
src/lib_signer_backends/unix/ledger.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base.Client_keys.

Module Bip32_path.
  Definition hard : int32 -> int32 := Stdlib.Int32.logor (-2147483648).
  
  Definition unhard : int32 -> int32 := Stdlib.Int32.logand 2147483647.
  
  Definition is_hard (n : int32) : bool :=
    nequiv_decb (Stdlib.Int32.logand (-2147483648) n) 0.
  
  Definition tezos_root : list int32 := cons (hard 44) (cons (hard 1729) []).
  
  Definition node_of_string (str : string) : option int32 :=
    match Stdlib.Int32.of_string_opt str with
    | Some node => Some node
    | None =>
      match
        Stdlib.Int32.of_string_opt
          (Tezos_base__TzPervasives.String.sub str 0
            (Z.sub (Tezos_base__TzPervasives.String.length str) 1)) with
      | None => None
      | Some node => Some (hard node)
      end
    end.
  
  Definition node_of_string_exn (str : string) : int32 :=
    match node_of_string str with
    | None =>
      OCaml.Stdlib.invalid_arg
        (Stdlib.Printf.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "node_of_string_exn: got " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "node_of_string_exn: got %S" % string) str)
    | Some str => str
    end.
  
  Definition pp_node (ppf : Stdlib.Format.formatter) (node : int32) : unit :=
    match is_hard node with
    | true =>
      Fmt.pf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal "h" % char
              CamlinternalFormatBasics.End_of_format)) "%ldh" % string)
        (unhard node)
    | false =>
      Fmt.pf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format) "%ld" % string) node
    end.
  
  Definition string_of_node : int32 -> string := Fmt.to_to_string pp_node.
  
  Definition path_of_string_exn (s : string) : list int32 :=
    match Tezos_base__TzPervasives.String.split_on_char "/" % char s with
    | cons "" % string [] => []
    | nodes => Tezos_base__TzPervasives.List.map node_of_string_exn nodes
    end.
  
  Definition path_of_string (s : string) : option (list int32) := try.
  
  Definition pp_path : Fmt.t (list int32) :=
    Fmt.list (Some (Fmt.const Fmt.char "/" % char)) pp_node.
  
  Definition string_of_path : (list int32) -> string := Fmt.to_to_string pp_path.
End Bip32_path.

Definition error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding Ledgerwallet.Transport.error :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun e =>
      Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) Ledgerwallet.Transport.pp_error e)
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        OCaml.Stdlib.invalid_arg "Ledger error is not deserializable" % string
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj1
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "ledger-error" % string Tezos_base__TzPervasives.Data_encoding.string)).

Module Ledger_commands.
  Definition wrap_ledger_cmd {A : Type}
    (f : Stdlib.Format.formatter -> sum A Ledgerwallet.Transport.error)
    : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
    let buf := Stdlib.Buffer.create 100 in
    let pp :=
      Stdlib.Format.make_formatter
        (fun s =>
          fun ofs => fun lgth => Stdlib.Buffer.add_substring buf s ofs lgth)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format)) "%s%!" % string)
              (Stdlib.Buffer.contents buf);
            Stdlib.Buffer.clear buf
          end) in
    let res := f pp in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format)
          "%!" % string))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          match res with
          | inr err => Tezos_base__TzPervasives.fail (LedgerError err)
          | inl v => Tezos_base__TzPervasives._return v
          end
        end).
  
  Definition get_version (device_info : Hidapi.device_info) (h : Hidapi.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option (Ledgerwallet_tezos.Version.t * string))) :=
    let buf := Stdlib.Buffer.create 100 in
    let pp := Stdlib.Format.formatter_of_buffer buf in
    let version := Ledgerwallet_tezos.get_version (Some pp) None h in
    debug
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string)
      (Stdlib.Buffer.contents buf);
    match version with
    | inr e =>
      warn
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "WARNING:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String_literal
                "The device at [" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    "] is not a Tezos application" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)))))))
          "WARNING:@ The device at [%s] is not a Tezos application@ %a" % string)
        (Hidapi.path device_info) Ledgerwallet.Transport.pp_error e;
      Tezos_base__TzPervasives.return_none
    | inl version =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (if OCaml.Stdlib.lt ((major version), (minor version)) (1, 4) then
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Version " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " of the ledger apps is not supported by this client" %
                      string CamlinternalFormatBasics.End_of_format)))
              "Version %a of the ledger apps is not supported by this client" %
                string) Ledgerwallet_tezos.Version.pp version
        else
          Tezos_base__TzPervasives.return_unit)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (wrap_ledger_cmd
                (fun pp => Ledgerwallet_tezos.get_git_commit (Some pp) None h))
              (fun git_commit =>
                log_info
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "Found a " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " application at [" % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              "] (git-description: " % string
                              (CamlinternalFormatBasics.Caml_string
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Char_literal
                                  ")" % char
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "Found a %a application at [%s] (git-description: %S)" %
                      string) Ledgerwallet_tezos.Version.pp version
                  (path device_info) git_commit;
                let cleaned_up :=
                  if
                    equiv_decb
                      (Tezos_base__TzPervasives.String.get git_commit
                        (Z.sub
                          (Tezos_base__TzPervasives.String.length git_commit) 1))
                      "000" % char then
                    Tezos_base__TzPervasives.String.sub git_commit 0
                      (Z.sub (Tezos_base__TzPervasives.String.length git_commit)
                        1)
                  else
                    git_commit in
                Tezos_base__TzPervasives.return_some (version, cleaned_up))
          end)
    end.
  
  Definition secp256k1_ctx : Libsecp256k1.External.Context.t :=
    Libsecp256k1.External.Context.create (Some false) (Some false) tt.
  
  Definition public_key_returning_instruction
    (which : variant) (op_star_o_p_t_star : option bool)
    : Hidapi.t ->
      Ledgerwallet_tezos.curve ->
        (list int32) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_base__TzPervasives.Signature.Public_key.t) :=
    let prompt :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun hidapi =>
      fun curve =>
        fun path =>
          let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
          Tezos_base__TzPervasives.op_gt_gt_pipe_question
            match which with
            | Get_public_key =>
              wrap_ledger_cmd
                (fun pp =>
                  Ledgerwallet_tezos.get_public_key (Some prompt) (Some pp) None
                    hidapi curve path)
            | Authorize_baking =>
              wrap_ledger_cmd
                (fun pp =>
                  Ledgerwallet_tezos.authorize_baking (Some pp) None hidapi
                    curve path)
            | Setup (main_chain_id, main_hwm, test_hwm) =>
              wrap_ledger_cmd
                (fun pp =>
                  Ledgerwallet_tezos.setup_baking (Some pp) None hidapi
                    main_chain_id main_hwm test_hwm curve path)
            end
            (fun pk =>
              match curve with
              | Ed25519 | Bip32_ed25519 =>
                let pk := Cstruct.to_bytes pk in
                Tezos_stdlib.TzEndian.set_int8 pk 0 0;
                Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                  Tezos_base__TzPervasives.Signature.Public_key.encoding pk
              | Secp256k1 =>
                let buf :=
                  Bigstring.create
                    (Z.add Libsecp256k1.External.Key.compressed_pk_bytes 1) in
                let pk :=
                  Libsecp256k1.External.Key.read_pk_exn secp256k1_ctx
                    (Cstruct.to_bigarray pk) in
                EndianBigstring.BigEndian.(EndianBigstring.EndianBigstringSig.set_int8)
                  buf 0 1;
                let _nb_written :=
                  Libsecp256k1.External.Key.write None secp256k1_ctx (Some 1)
                    buf pk in
                Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                  Tezos_base__TzPervasives.Signature.Public_key.encoding
                  (Bigstring.to_bytes buf)
              | Secp256r1 =>
                let pklen := Uecc.compressed_size Uecc.secp256r1 in
                let buf := Bigstring.create (Z.add pklen 1) in
                match Uecc.pk_of_bytes Uecc.secp256r1 (Cstruct.to_bigarray pk)
                  with
                | None =>
                  Stdlib.Pervasives.failwith
                    "Impossible to read P256 public key from Ledger" % string
                | Some pk =>
                  EndianBigstring.BigEndian.(EndianBigstring.EndianBigstringSig.set_int8)
                    buf 0 2;
                  let _nb_written :=
                    Uecc.write_key (Some true) (Bigstring.sub buf 1 pklen) pk in
                  Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                    Tezos_base__TzPervasives.Signature.Public_key.encoding
                    (Bigstring.to_bytes buf)
                end
              end).
  
  Definition get_public_key
    : (option bool) ->
      Hidapi.t ->
        Ledgerwallet_tezos.curve ->
          (list int32) ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_base__TzPervasives.Signature.Public_key.t) :=
    public_key_returning_instruction variant.
  
  Definition pkh_of_pk
    : Tezos_base__TzPervasives.Signature.Public_key.t ->
      Tezos_crypto__Signature.Public_key_hash.t :=
    Tezos_base__TzPervasives.Signature.Public_key.hash.
  
  Definition public_key
    (first_import : option Tezos_client_base.Client_context.io_wallet)
    (hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_base__TzPervasives.Signature.Public_key.t) :=
    match first_import with
    | Some cctxt =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (get_public_key (Some false) hid curve path)
        (fun pk =>
          let pkh := pkh_of_pk pk in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Please validate" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal
                      "(and write down)" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.String_literal
                          "the public key hash" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "displayed" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "on the Ledger," % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "it should be equal" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.String_literal
                                          "to `" % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              "`:" % string
                                              CamlinternalFormatBasics.End_of_format)))))))))))))))
                "Please validate@ (and write down)@ the public key hash@ displayed@ on the Ledger,@ it should be equal@ to `%a`:"
                  % string)
              Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh)
            (fun function_parameter =>
              match function_parameter with
              | tt => get_public_key (Some true) hid curve path
              end))
    | None => get_public_key (Some false) hid curve path
    end.
  
  Definition public_key_hash
    (first_import : option Tezos_client_base.Client_context.io_wallet)
    (hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_crypto__Signature.Public_key_hash.t *
          Tezos_base__TzPervasives.Signature.Public_key.t)) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (public_key first_import hid curve path)
      (fun pk => Tezos_base__TzPervasives._return ((pkh_of_pk pk), pk)).
  
  Definition get_authorized_path
    (hid : Hidapi.t) (version : Ledgerwallet_tezos.Version.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult variant) :=
    if OCaml.Stdlib.lt (major version) 2 then
      Tezos_base__TzPervasives.op_gt_gt_pipe_question
        (wrap_ledger_cmd
          (fun pp => Ledgerwallet_tezos.get_authorized_key (Some pp) None hid))
        (fun path => variant)
    else
      Tezos_base__TzPervasives.op_gt_gt_eq
        (wrap_ledger_cmd
          (fun pp =>
            Ledgerwallet_tezos.get_authorized_path_and_curve (Some pp) None hid))
        (fun function_parameter =>
          match function_parameter with
          |
            inr
              (cons
                (LedgerError
                  (AppError {|
                    status := Ledgerwallet.Transport.Status.Referenced_data_not_found
                      |})) _) => Tezos_base__TzPervasives._return variant
          | (inr _) as e => Lwt._return e
          | inl (path, curve) => Tezos_base__TzPervasives._return variant
          end).
  
  Definition sign
    (watermark : option Tezos_base__TzPervasives.Signature.watermark)
    (version : Ledgerwallet_tezos.Version.t) (hid : Hidapi.t)
    (curve : Ledgerwallet_tezos.curve) (path : list int32)
    (base_msg : Stdlib.Bytes.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
    let msg :=
      Tezos_stdlib.Option.unopt_map
        (fun watermark =>
          String.append
            (Tezos_base__TzPervasives.Signature.bytes_of_watermark watermark)
            base_msg) base_msg watermark in
    let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (wrap_ledger_cmd
        (fun pp =>
          match version with
          | {|
            Ledgerwallet_tezos.Version.major := major;
              Ledgerwallet_tezos.Version.minor := minor;
              Ledgerwallet_tezos.Version.patch := patch
              |} =>
            if OCaml.Stdlib.le (major, minor, patch) (2, 0, 0) then
              Rresult.R.Infix.op_gt_gt_eq
                (Ledgerwallet_tezos.sign (Some pp) None None hid curve path
                  (Cstruct.of_bytes None None None msg))
                (fun s => inl (None, s))
            else
              Rresult.R.Infix.op_gt_gt_eq
                (Ledgerwallet_tezos.sign_and_hash (Some pp) None hid curve path
                  (Cstruct.of_bytes None None None msg))
                (fun function_parameter =>
                  match function_parameter with
                  | (h, s) => inl ((Some h), s)
                  end)
          end))
      (fun function_parameter =>
        match function_parameter with
        | (hash_opt, signature) =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            match hash_opt with
            | None => Tezos_base__TzPervasives.return_unit
            | Some hsh =>
              let hash_msg :=
                Tezos_base__TzPervasives.Blake2B.hash_bytes None (cons msg [])
                in
              let ledger_one :=
                Tezos_base__TzPervasives.Blake2B.of_bytes_exn
                  (Cstruct.to_bytes hsh) in
              if Tezos_base__TzPervasives.Blake2B.equal hash_msg ledger_one then
                Tezos_base__TzPervasives.return_unit
              else
                Tezos_base__TzPervasives.fail
                  (Ledger_signing_hash_mismatch
                    (Tezos_base__TzPervasives.Blake2B.to_string ledger_one)
                    (Tezos_base__TzPervasives.Blake2B.to_string hash_msg))
            end
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                match curve with
                | Ed25519 | Bip32_ed25519 =>
                  let signature :=
                    Tezos_base__TzPervasives.Ed25519.of_bytes_exn
                      (Cstruct.to_bytes signature) in
                  Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.Signature.of_ed25519 signature)
                | Secp256k1 =>
                  Cstruct.set_uint8 signature 0
                    (Z.land (Cstruct.get_uint8 signature 0) 254);
                  let signature := Cstruct.to_bigarray signature in
                  let signature :=
                    Libsecp256k1.External.Sign.read_der_exn secp256k1_ctx
                      signature in
                  let bytes :=
                    Libsecp256k1.External.Sign.to_bytes None secp256k1_ctx
                      signature in
                  let signature :=
                    Tezos_base__TzPervasives.Secp256k1.of_bytes_exn
                      (Bigstring.to_bytes string) in
                  Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.Signature.of_secp256k1 signature)
                | Secp256r1 =>
                  Cstruct.set_uint8 signature 0
                    (Z.land (Cstruct.get_uint8 signature 0) 254);
                  let signature := Cstruct.to_bigarray signature in
                  let signature :=
                    Libsecp256k1.External.Sign.read_der_exn secp256k1_ctx
                      signature in
                  let buf :=
                    Libsecp256k1.External.Sign.to_bytes None secp256k1_ctx
                      signature in
                  let signature :=
                    Tezos_base__TzPervasives.P256.of_bytes_exn
                      (Bigstring.to_bytes buf) in
                  Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.Signature.of_p256 signature)
                end
              end)
        end).
  
  Definition get_deterministic_nonce
    (hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
    (msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
    let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (wrap_ledger_cmd
        (fun pp =>
          Ledgerwallet_tezos.get_deterministic_nonce (Some pp) None hid curve
            path (Cstruct.of_bytes None None None msg)))
      (fun nonce =>
        Tezos_base__TzPervasives._return
          (Bigstring.of_bytes (Cstruct.to_bytes nonce))).
End Ledger_commands.

Module Ledger_id.
  Inductive t : Type :=
  | Animals : Tezos_signer_backends_unix.Ledger_names.t -> t
  | Pkh : Tezos_base__TzPervasives.Signature.public_key_hash -> t.
  
  Definition animals_of_pkh
    (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    : Tezos_signer_backends_unix.Ledger_names.t :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply pkh
        Tezos_base__TzPervasives.Signature.Public_key_hash.to_string)
      Tezos_signer_backends_unix.Ledger_names.crouching_tiger.
  
  Definition curve : Ledgerwallet_tezos.curve := Ledgerwallet_tezos.Ed25519.
  
  Definition get (hidapi : Hidapi.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Ledger_commands.get_public_key None hidapi curve [])
      (fun pk =>
        let pkh := Tezos_base__TzPervasives.Signature.Public_key.hash pk in
        let animals := animals_of_pkh pkh in
        Tezos_base__TzPervasives._return (Animals animals)).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Animals a => Tezos_signer_backends_unix.Ledger_names.pp ppf a
    | Pkh pkh => Tezos_base__TzPervasives.Signature.Public_key_hash.pp ppf pkh
    end.
  
  Definition to_animals (function_parameter : t)
    : Tezos_signer_backends_unix.Ledger_names.t :=
    match function_parameter with
    | Animals a => a
    | Pkh pkh => animals_of_pkh pkh
    end.
  
  Definition equal (a : t) (b : t) : bool :=
    equiv_decb (to_animals a) (to_animals b).
End Ledger_id.

Module Ledger_account.
  Record t := {
    ledger : Ledger_id.t;
    curve : Ledgerwallet_tezos.curve;
    path : list int32 }.
End Ledger_account.

Module Ledger_uri.
  Definition t := variant.
  
  Definition int32_of_path_element_exn (allow_weak : bool) (x : string)
    : int32 :=
    let failf {A B : Type} (ppf : Stdlib.format4 A unit string B) : A :=
      Stdlib.Printf.ksprintf Stdlib.Pervasives.failwith ppf in
    let len := Tezos_base__TzPervasives.String.length x in
    match Tezos_base__TzPervasives.String.get x (Z.sub len 1) with
    | "'" % char | "h" % char =>
      let intpart := Tezos_base__TzPervasives.String.sub x 0 (Z.sub len 1) in
      match Stdlib.Int32.of_string_opt intpart with
      | Some i => Bip32_path.hard i
      | None =>
        failf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Path is not an integer: " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Path is not an integer: %S" % string) intpart
      end
    | _ =>
      failf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Non-hardened paths are not allowed for this derivation scheme (" %
              string
            (CamlinternalFormatBasics.Caml_string
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))
          "Non-hardened paths are not allowed for this derivation scheme (%S)" %
            string) x
    end.
  
  Definition parse_animals (animals : string)
    : option Tezos_signer_backends_unix.Ledger_names.t :=
    match Tezos_base__TzPervasives.String.split "-" % char None None animals
      with
    | cons c (cons t (cons h (cons d []))) =>
      Some
        {| Ledger_names.c := c; Ledger_names.t := t; Ledger_names.h := h;
          Ledger_names.d := d |}
    | _ => None
    end.
  
  Definition derivation_supports_weak_paths
    (function_parameter : Ledgerwallet_tezos.curve) : bool :=
    match function_parameter with
    | Ledgerwallet_tezos.Ed25519 => false
    | Ledgerwallet_tezos.Secp256k1 => true
    | Ledgerwallet_tezos.Secp256r1 => true
    | Ledgerwallet_tezos.Bip32_ed25519 => true
    end.
  
  Definition parse (allow_weak : option bool) (uri : Uri.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    let host := Uri.host uri in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      match
        Tezos_stdlib.Option.apply
          Tezos_base__TzPervasives.Signature.Public_key_hash.of_b58check_opt
          host with
      | Some pkh => Tezos_base__TzPervasives._return (Ledger_id.Pkh pkh)
      | None =>
        match Tezos_stdlib.Option.apply parse_animals host with
        | Some animals =>
          Tezos_base__TzPervasives._return (Ledger_id.Animals animals)
        | None =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Cannot parse host of URI: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))
              "Cannot parse host of URI: %s" % string) (Uri.to_string uri)
        end
      end
      (fun ledger =>
        let components :=
          Tezos_base__TzPervasives.String.split "/" % char None None
            (Uri.path uri) in
        match components with
        | cons s tl =>
          match
            match Ledgerwallet_tezos.curve_of_string s with
            | Some curve => (curve, tl)
            | None => (Ledger_id.curve, (cons s tl))
            end with
          | (curve, more_path) =>
            let actually_allow_weak :=
              match allow_weak with
              | None => derivation_supports_weak_paths curve
              | Some x => x
              end in
            Tezos_base__TzPervasives.op_gt_gt_eq_question try
              (fun bip32 => Tezos_base__TzPervasives._return variant)
          end
        | [] => Tezos_base__TzPervasives._return variant
        end).
  
  Definition ledger_uri_or_alias_param {A C a : Type}
    (next :
      Tezos_base__TzPervasives.Clic.params A
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
          * C))
    : Tezos_base__TzPervasives.Clic.params (t -> A)
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
        * C) :=
    let name := "account-alias-or-ledger-uri" % string in
    let desc :=
      "An imported ledger alias or a ledger URI (e.g. ""ledger://animal/curve/path"")."
        % string in
    Tezos_base__TzPervasives.Clic.param name desc
      (Tezos_base__TzPervasives.Clic.parameter None
        (fun cctxt =>
          fun str =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_client_base.Client_keys.Public_key.find_opt cctxt str)
                (fun function_parameter =>
                  match function_parameter with
                  | Some (_ as x, _) => Tezos_base__TzPervasives._return x
                  | None => try
                  end)) (fun uri => parse None uri))) next.
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Ledger lid =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "ledger://" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "ledger://%a" % string)
        Ledger_id.pp lid
    |
      Ledger_account {|
        Ledger_account.ledger := ledger;
          Ledger_account.curve := curve;
          Ledger_account.path := path
          |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "ledger://" % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal "/" % char
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal "/" % char
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))))
          "ledger://%a/%a/%a" % string) Ledger_id.pp ledger
        Ledgerwallet_tezos.pp_curve curve Bip32_path.pp_path path
    end.
  
  Definition if_matches {A : Type}
    (meta_uri : t) (ledger_id : Ledger_id.t)
    (cont : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A)))
    : Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
    match meta_uri with
    | Ledger l =>
      if Ledger_id.equal l ledger_id then
        cont tt
      else
        Tezos_base__TzPervasives.return_none
    | Ledger_account {| Ledger_account.ledger := ledger |} =>
      if Ledger_id.equal ledger ledger_id then
        cont tt
      else
        Tezos_base__TzPervasives.return_none
    end.
  
  Definition full_account (ledger_uri : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Ledger_account.t) :=
    match ledger_uri with
    | Ledger_account acc => Tezos_base__TzPervasives._return acc
    | Ledger ledger_id =>
      Tezos_base__TzPervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Insufficient information: you need to provide a curve & BIP32 path ("
              % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal ")." % string
                CamlinternalFormatBasics.End_of_format)))
          "Insufficient information: you need to provide a curve & BIP32 path (%a)."
            % string) Ledger_id.pp ledger_id
    end.
End Ledger_uri.

Module Filter.
  Definition version_filter := (Ledgerwallet_tezos.Version.t * string) -> bool.
  
  Definition t := variant.
  
  Definition version_matches
    (t : t) (version_commit : Ledgerwallet_tezos.Version.t * string) : bool :=
    match t with
    | Version (_, f) => f version_commit
    | _ => true
    end.
  
  Definition is_app (msg : string) (app : Ledgerwallet_tezos.Version.app_class)
    : t := variant.
  
  Definition is_baking : t :=
    is_app "App = Baking" % string Ledgerwallet_tezos.Version.TezBake.
  
  Definition pp (ppf : Stdlib.Format.formatter) (f : t) : unit :=
    match f with
    | None =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "None" % string
            CamlinternalFormatBasics.End_of_format) "None" % string)
    | Hid_path s =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "HID-path: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)) "HID-path: %s" % string)
        s
    | Version (s, _) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) s
    end.
End Filter.

Definition vendor_id : Z := 11415.

Definition product_id_nano_s : Z := 1.

Definition product_id_nano_x : Z := 4.

Definition use_ledger {A : Type} (op_star_o_p_t_star : option Filter.t)
  : (Hidapi.t ->
    (Ledgerwallet_tezos.Version.t * string) ->
      Hidapi.device_info ->
        Ledger_id.t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A))) ->
    Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
  match
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end with
  | _ as filter =>
    fun f =>
      let ledgers :=
        OCaml.Stdlib.app
          (Hidapi.enumerate (Some vendor_id) (Some product_id_nano_s) tt)
          (Hidapi.enumerate (Some vendor_id) (Some product_id_nano_x) tt) in
      debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Found " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " Ledger(s) " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "Found %d Ledger(s) %s" % string)
        (Tezos_base__TzPervasives.List.length ledgers)
        (Tezos_base__TzPervasives.String.concat " -- " % string
          (Tezos_base__TzPervasives.List.map
            (fun l =>
              Stdlib.Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Char_literal "(" % char
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_x
                      (CamlinternalFormatBasics.Lit_padding
                        CamlinternalFormatBasics.Zeros 4)
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal ", " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_x
                          (CamlinternalFormatBasics.Lit_padding
                            CamlinternalFormatBasics.Zeros 4)
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))
                  "(%04x, %04x)" % string) (vendor_id l) (product_id l)) ledgers));
      let process_device {B : Type}
        (device_info : Hidapi.device_info) (f :
        Hidapi.t ->
          (Ledgerwallet_tezos.Version.t * string) ->
            Hidapi.device_info ->
              Ledger_id.t ->
                Lwt.t (Tezos_base__TzPervasives.tzresult (option B)))
        : Lwt.t (Tezos_base__TzPervasives.tzresult (option B)) :=
        log_info
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Processing Ledger at path [" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal "]" % char
                  CamlinternalFormatBasics.End_of_format)))
            "Processing Ledger at path [%s]" % string) (Hidapi.path device_info);
        if
          orb (equiv_decb (Hidapi.interface_number device_info) 0)
            (andb (equiv_decb (Hidapi.interface_number device_info) (-1))
              (equiv_decb (Hidapi.usage_page device_info) 65440)) then
          match filter with
          | _ =>
            match Hidapi.open_path (path device_info) with
            | None => Tezos_base__TzPervasives.return_none
            | Some h =>
              Lwt.finalize
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Ledger_commands.get_version device_info h)
                      (fun function_parameter =>
                        match function_parameter with
                        | Some version_git =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Ledger_id.get h)
                            (fun ledger_id =>
                              f h version_git device_info ledger_id)
                        | None | Some _ => Tezos_base__TzPervasives.return_none
                        end)
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Hidapi.close h;
                    Lwt.return_unit
                  end)
            end
          end
        else
          Tezos_base__TzPervasives.return_none in
      let fix go (function_parameter : list Hidapi.device_info)
        : Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
        match function_parameter with
        | [] => Tezos_base__TzPervasives.return_none
        | cons h t =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question (process_device h f)
            (fun function_parameter =>
              match function_parameter with
              | Some x => Tezos_base__TzPervasives.return_some x
              | None => go t
              end)
        end in
      go ledgers
  end.

Definition min_version_of_derivation_scheme
  (function_parameter : Ledgerwallet_tezos.curve) : Z * Z * Z :=
  match function_parameter with
  | Ledgerwallet_tezos.Ed25519 => (1, 3, 0)
  | Ledgerwallet_tezos.Secp256k1 => (1, 3, 0)
  | Ledgerwallet_tezos.Secp256r1 => (1, 3, 0)
  | Ledgerwallet_tezos.Bip32_ed25519 => (2, 1, 0)
  end.

Definition is_derivation_scheme_supported
  (version : Ledgerwallet_tezos.Version.t) (curve : Ledgerwallet_tezos.curve)
  : bool :=
  match version with
  | {| major := major; minor := minor; patch := patch |} =>
    OCaml.Stdlib.ge (major, minor, patch)
      (min_version_of_derivation_scheme curve)
  end.

Definition use_ledger_or_fail {A : Type}
  (ledger_uri : Ledger_uri.t) (filter : option Filter.t) (msg : option string)
  (f :
    Hidapi.t ->
      (Ledgerwallet_tezos.Version.t * string) ->
        Hidapi.device_info ->
          Ledger_id.t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A)))
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (use_ledger filter
      (fun hidapi =>
        fun function_parameter =>
          match function_parameter with
          | (version, git_commit) =>
            fun device_info =>
              fun ledger_id =>
                Ledger_uri.if_matches ledger_uri ledger_id
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      let go (function_parameter : unit)
                        : Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
                        match function_parameter with
                        | tt =>
                          f hidapi (version, git_commit) device_info ledger_id
                        end in
                      match ledger_uri with
                      | Ledger_account {| curve := curve |} =>
                        if is_derivation_scheme_supported version curve then
                          go tt
                        else
                          Tezos_base__TzPervasives.failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "To use derivation scheme " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " you need " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " or later but you're using " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Char_literal
                                            "." % char
                                            CamlinternalFormatBasics.End_of_format)))))))
                              "To use derivation scheme %a you need %a or later but you're using %a."
                                % string) Ledgerwallet_tezos.pp_curve curve
                            Ledgerwallet_tezos.Version.pp
                            match min_version_of_derivation_scheme curve with
                            | (a, b, c) => record
                            end Ledgerwallet_tezos.Version.pp version
                      | _ => go tt
                      end
                    end)
          end))
    (fun function_parameter =>
      match function_parameter with
      | Some o => Tezos_base__TzPervasives._return o
      | None =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                "Found no ledger corresponding to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Theta
                    (CamlinternalFormatBasics.Char_literal "." % char
                      CamlinternalFormatBasics.End_of_format)))))
            "%sFound no ledger corresponding to %a%t." % string)
          (Tezos_stdlib.Option.unopt_map
            (Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal ": " % string
                    CamlinternalFormatBasics.End_of_format)) "%s: " % string))
            "" % string msg) Ledger_uri.pp ledger_uri
          (fun ppf =>
            match filter with
            | Some f =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    " with filter """ % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal """" % char
                        CamlinternalFormatBasics.End_of_format)))
                  " with filter ""%a""" % string) Filter.pp f
            | None => tt
            end)
      end).

Module Global_cache.
  Definition _cache
    : Stdlib.Hashtbl.t Tezos_client_base.Client_keys.pk_uri
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        Tezos_base__TzPervasives.Signature.Public_key.t) :=
    Stdlib.Hashtbl.create None 13.
  
  Definition record
    (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    (pk : Tezos_base__TzPervasives.Signature.Public_key.t)
    (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t) : unit :=
    Stdlib.Hashtbl.replace _cache pk_uri (pkh, pk).
  
  Definition get (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    : option
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        Tezos_base__TzPervasives.Signature.Public_key.t) :=
    Stdlib.Hashtbl.find_opt _cache pk_uri.
End Global_cache.

Module Signer_implementation.
  Definition scheme : string := "ledger" % string.
  
  Definition title : string :=
    "Built-in signer using a Ledger Nano device." % string.
  
  Definition description : string :=
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Valid URIs are of the form
 - ledger://<animals>/<curve>[/<path>]
where:
 - <animals> is the identifier of the ledger of the form 'crouching-tiger-hidden-dragon' and can be obtained with the command `tezos-client list connected ledgers` (which also provides full examples).
- <curve> is the signing curve, e.g. `ed1551`
- <path> is a BIP32 path anchored at m/"
            % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal
              ". The ledger does not yet support non-hardened paths, so each node of the path must be hardened."
                % string CamlinternalFormatBasics.End_of_format)))
        "Valid URIs are of the form
 - ledger://<animals>/<curve>[/<path>]
where:
 - <animals> is the identifier of the ledger of the form 'crouching-tiger-hidden-dragon' and can be obtained with the command `tezos-client list connected ledgers` (which also provides full examples).
- <curve> is the signing curve, e.g. `ed1551`
- <path> is a BIP32 path anchored at m/%s. The ledger does not yet support non-hardened paths, so each node of the path must be hardened."
          % string) (Bip32_path.string_of_path Bip32_path.tezos_root).
  
  Definition neuterize (sk : Tezos_client_base.Client_keys.sk_uri)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.pk_uri) :=
    Tezos_base__TzPervasives._return
      (Tezos_client_base.Client_keys.make_pk_uri sk).
  
  Definition pkh_of_pk
    : Tezos_base__TzPervasives.Signature.Public_key.t ->
      Tezos_crypto__Signature.Public_key_hash.t :=
    Tezos_base__TzPervasives.Signature.Public_key.hash.
  
  Definition public_key_maybe_prompt
    (first_import : option Tezos_client_base.Client_context.io_wallet)
    (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_base__TzPervasives.Signature.public_key) :=
    match Global_cache.get pk_uri with
    | Some (_, pk) => Tezos_base__TzPervasives._return pk
    | None =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Ledger_uri.parse None pk_uri)
          (fun ledger_uri =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Ledger_uri.full_account ledger_uri)
              (fun function_parameter =>
                match function_parameter with
                | {| curve := curve; path := path |} =>
                  use_ledger_or_fail ledger_uri None None
                    (fun hidapi =>
                      fun function_parameter =>
                        match function_parameter with
                        | (_version, _git_commit) =>
                          fun _device_info =>
                            fun _ledger_id =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Ledger_commands.public_key first_import hidapi
                                  curve path)
                                (fun pk =>
                                  let pkh := pkh_of_pk pk in
                                  Global_cache.record pk_uri pk pkh;
                                  Tezos_base__TzPervasives.return_some pk)
                        end)
                end)))
        (fun function_parameter =>
          match function_parameter with
          | inr err =>
            Tezos_base__TzPervasives.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              Tezos_base__TzPervasives.pp_print_error err
          | inl v => Tezos_base__TzPervasives._return v
          end)
    end.
  
  Definition public_key_hash_maybe_prompt
    (first_import : option Tezos_client_base.Client_context.io_wallet)
    (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_base__TzPervasives.Signature.public_key_hash *
          (option Tezos_base__TzPervasives.Signature.public_key))) :=
    match Global_cache.get pk_uri with
    | Some (pkh, pk) => Tezos_base__TzPervasives._return (pkh, (Some pk))
    | None =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (public_key_maybe_prompt first_import pk_uri)
        (fun pk => Tezos_base__TzPervasives._return ((pkh_of_pk pk), (Some pk)))
    end.
  
  Definition public_key
    : Tezos_client_base.Client_keys.pk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Signature.public_key) :=
    public_key_maybe_prompt None.
  
  Definition public_key_hash
    : Tezos_client_base.Client_keys.pk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_base__TzPervasives.Signature.public_key_hash *
            (option Tezos_base__TzPervasives.Signature.public_key))) :=
    public_key_hash_maybe_prompt None.
  
  Definition import_secret_key
    (io : Tezos_client_base.Client_context.io_wallet)
    (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_base__TzPervasives.Signature.public_key_hash *
          (option Tezos_base__TzPervasives.Signature.public_key))) :=
    public_key_hash_maybe_prompt (Some io) pk_uri.
  
  Definition sign
    (watermark : option Tezos_base__TzPervasives.Signature.watermark)
    (sk_uri : Tezos_client_base.Client_keys.sk_uri) (msg : Stdlib.Bytes.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (Ledger_uri.parse None sk_uri)
      (fun ledger_uri =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Ledger_uri.full_account ledger_uri)
          (fun function_parameter =>
            match function_parameter with
            | {| curve := curve; path := path |} =>
              use_ledger_or_fail ledger_uri None None
                (fun hidapi =>
                  fun function_parameter =>
                    match function_parameter with
                    | (version, _git_commit) =>
                      fun _device_info =>
                        fun _ledger_id =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Ledger_commands.sign watermark version hidapi curve
                              path msg)
                            (fun bytes =>
                              Tezos_base__TzPervasives.return_some string)
                    end)
            end)).
  
  Definition deterministic_nonce
    (sk_uri : Tezos_client_base.Client_keys.sk_uri) (msg : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (Ledger_uri.parse None sk_uri)
      (fun ledger_uri =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Ledger_uri.full_account ledger_uri)
          (fun function_parameter =>
            match function_parameter with
            | {| curve := curve; path := path |} =>
              use_ledger_or_fail ledger_uri None None
                (fun hidapi =>
                  fun function_parameter =>
                    match function_parameter with
                    | (_version, _git_commit) =>
                      fun _device_info =>
                        fun _ledger_id =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Ledger_commands.get_deterministic_nonce hidapi
                              curve path msg)
                            (fun bytes =>
                              Tezos_base__TzPervasives.return_some string)
                    end)
            end)).
  
  Definition deterministic_nonce_hash
    (sk : Tezos_client_base.Client_keys.sk_uri) (msg : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (deterministic_nonce sk msg)
      (fun nonce =>
        Tezos_base__TzPervasives._return
          (Tezos_base__TzPervasives.Blake2B.to_bytes
            (Tezos_base__TzPervasives.Blake2B.hash_bytes None
              (cons (Bigstring.to_bytes nonce) [])))).
  
  Definition supports_deterministic_nonces {A : Type} (function_parameter : A)
    : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
    match function_parameter with
    | _ => Tezos_base__TzPervasives.return_true
    end.
End Signer_implementation.

Definition pp_ledger_chain_id (fmt : Stdlib.Format.formatter) (s : string)
  : unit :=
  match s with
  | "" % string =>
    Stdlib.Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "'Unspecified'" % string
          CamlinternalFormatBasics.End_of_format) "'Unspecified'" % string)
  | other =>
    Stdlib.Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Tezos_base__TzPervasives.Chain_id.pp
      (Tezos_base__TzPervasives.Chain_id.of_string_exn other)
  end.

Definition generic_commands (group : Tezos_base__TzPervasives.Clic.group)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  cons
    (Tezos_base__TzPervasives.Clic.command (Some group)
      "List supported Ledger Nano devices connected." % string
      Tezos_base__TzPervasives.Clic.no_options
      (Tezos_base__TzPervasives.Clic.fixed
        (cons "list" % string
          (cons "connected" % string (cons "ledgers" % string []))))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun cctxt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (use_ledger None
                (fun _hidapi =>
                  fun function_parameter =>
                    match function_parameter with
                    | (version, git_commit) =>
                      fun device_info =>
                        fun ledger_id =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Theta
                                  CamlinternalFormatBasics.End_of_format)
                                "%t" % string)
                              (fun ppf =>
                                let intro :=
                                  Stdlib.Format.asprintf
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Found a " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            " (git-description: " % string
                                            (CamlinternalFormatBasics.Caml_string
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.String_literal
                                                ") application running on " %
                                                  string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.Char_literal
                                                    " " % char
                                                    (CamlinternalFormatBasics.String
                                                      CamlinternalFormatBasics.No_padding
                                                      (CamlinternalFormatBasics.String_literal
                                                        " at [" % string
                                                        (CamlinternalFormatBasics.String
                                                          CamlinternalFormatBasics.No_padding
                                                          (CamlinternalFormatBasics.String_literal
                                                            "]." % string
                                                            CamlinternalFormatBasics.End_of_format)))))))))))
                                      "Found a %a (git-description: %S) application running on %s %s at [%s]."
                                        % string) Ledgerwallet_tezos.Version.pp
                                    version git_commit
                                    (OCaml.Stdlib.reverse_apply
                                      (manufacturer_string device_info)
                                      (Tezos_stdlib.Option.unopt
                                        "NO-MANUFACTURER" % string))
                                    (OCaml.Stdlib.reverse_apply
                                      (product_string device_info)
                                      (Tezos_stdlib.Option.unopt
                                        "NO-PRODUCT" % string))
                                    (path device_info) in
                                Stdlib.Format.pp_open_vbox ppf 0;
                                Stdlib.Format.fprintf ppf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "## Ledger `" % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "`" % char
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@," % string 0 0)
                                            CamlinternalFormatBasics.End_of_format))))
                                    "## Ledger `%a`@," % string) Ledger_id.pp
                                  ledger_id;
                                Stdlib.Format.pp_open_hovbox ppf 0;
                                Stdlib.Format.pp_print_text ppf intro;
                                Stdlib.Format.pp_close_box ppf tt;
                                Stdlib.Format.pp_print_cut ppf tt;
                                Stdlib.Format.pp_print_cut ppf tt;
                                Stdlib.Format.pp_open_hovbox ppf 0;
                                Stdlib.Format.pp_print_text ppf
                                  "To use keys at BIP32 path m/44'/1729'/0'/0' (default Tezos key path), use one of:"
                                    % string;
                                Stdlib.Format.pp_close_box ppf tt;
                                Stdlib.Format.pp_print_cut ppf tt;
                                Tezos_base__TzPervasives.List.iter
                                  (fun curve =>
                                    Stdlib.Format.fprintf ppf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "  tezos-client import secret key ledger_"
                                            % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              " ""ledger://" % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  "/" % char
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.String_literal
                                                      "/0h/0h""" % string
                                                      CamlinternalFormatBasics.End_of_format)))))))
                                        "  tezos-client import secret key ledger_%s ""ledger://%a/%a/0h/0h"""
                                          % string)
                                      (OCaml.Stdlib.reverse_apply
                                        (Stdlib.Sys.getenv_opt "USER" % string)
                                        (Tezos_stdlib.Option.unopt
                                          "user" % string)) Ledger_id.pp
                                      ledger_id Ledgerwallet_tezos.pp_curve
                                      curve;
                                    Stdlib.Format.pp_print_cut ppf tt)
                                  (Tezos_base__TzPervasives.List.filter
                                    (is_derivation_scheme_supported version)
                                    (cons Bip32_ed25519
                                      (cons Ed25519
                                        (cons Secp256k1 (cons Secp256r1 [])))));
                                Stdlib.Format.pp_close_box ppf tt;
                                Stdlib.Format.pp_print_newline ppf tt))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_none
                              end)
                    end))
              (fun function_parameter =>
                match function_parameter with
                | _ => Tezos_base__TzPervasives.return_unit
                end)
        end))
    (cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Display version/public-key/address information for a Ledger URI" %
          string
        (Tezos_base__TzPervasives.Clic.args1
          (Tezos_base__TzPervasives.Clic.switch
            "Test signing operation" % string None "test-sign" % string tt))
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "show" % string (cons "ledger" % string [])))
          (apply Ledger_uri.ledger_uri_or_alias_param
            Tezos_base__TzPervasives.Clic.stop))
        (fun test_sign =>
          fun ledger_uri =>
            fun cctxt =>
              use_ledger_or_fail ledger_uri None None
                (fun hidapi =>
                  fun function_parameter =>
                    match function_parameter with
                    | (version, git_commit) =>
                      fun device_info =>
                        fun _ledger_id =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Found ledger corresponding to " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      ":" % char
                                      CamlinternalFormatBasics.End_of_format)))
                                "Found ledger corresponding to %a:" % string)
                              Ledger_uri.pp ledger_uri)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "* Manufacturer: " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))
                                      "* Manufacturer: %s" % string)
                                    (Tezos_stdlib.Option.unopt "NONE" % string
                                      (manufacturer_string device_info)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "* Product: " % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.End_of_format))
                                            "* Product: %s" % string)
                                          (Tezos_stdlib.Option.unopt
                                            "NONE" % string
                                            (product_string device_info)))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "* Application: " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        " (git-description: " %
                                                          string
                                                        (CamlinternalFormatBasics.Caml_string
                                                          CamlinternalFormatBasics.No_padding
                                                          (CamlinternalFormatBasics.Char_literal
                                                            ")" % char
                                                            CamlinternalFormatBasics.End_of_format)))))
                                                  "* Application: %a (git-description: %S)"
                                                    % string)
                                                Ledgerwallet_tezos.Version.pp
                                                version git_commit)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    match ledger_uri with
                                                    |
                                                      Ledger_account {|
                                                        curve := curve;
                                                          path := path
                                                          |} =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "* Curve: `" %
                                                                string
                                                              (CamlinternalFormatBasics.Alpha
                                                                (CamlinternalFormatBasics.Char_literal
                                                                  "`" % char
                                                                  CamlinternalFormatBasics.End_of_format)))
                                                            "* Curve: `%a`" %
                                                              string)
                                                          Ledgerwallet_tezos.pp_curve
                                                          curve)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            let full_path :=
                                                              OCaml.Stdlib.app
                                                                Bip32_path.tezos_root
                                                                path in
                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                              (send
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "* Path: `"
                                                                      % string
                                                                    (CamlinternalFormatBasics.String
                                                                      CamlinternalFormatBasics.No_padding
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "` [" %
                                                                          string
                                                                        (CamlinternalFormatBasics.String
                                                                          CamlinternalFormatBasics.No_padding
                                                                          (CamlinternalFormatBasics.Char_literal
                                                                            "]"
                                                                              %
                                                                              char
                                                                            CamlinternalFormatBasics.End_of_format)))))
                                                                  "* Path: `%s` [%s]"
                                                                    % string)
                                                                (Bip32_path.string_of_path
                                                                  full_path)
                                                                (Tezos_base__TzPervasives.String.concat
                                                                  "; " % string
                                                                  (Tezos_base__TzPervasives.List.map
                                                                    (Stdlib.Printf.sprintf
                                                                      (CamlinternalFormatBasics.Format
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "0x" %
                                                                            string
                                                                          (CamlinternalFormatBasics.Int32
                                                                            CamlinternalFormatBasics.Int_X
                                                                            CamlinternalFormatBasics.No_padding
                                                                            CamlinternalFormatBasics.No_precision
                                                                            CamlinternalFormatBasics.End_of_format))
                                                                        "0x%lX"
                                                                          %
                                                                          string))
                                                                    full_path)))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                    (Ledger_commands.public_key_hash
                                                                      None
                                                                      hidapi
                                                                      curve path)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      |
                                                                        (pkh, pk)
                                                                        =>
                                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                                          (send
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "* Public Key: "
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Alpha
                                                                                  CamlinternalFormatBasics.End_of_format))
                                                                              "* Public Key: %a"
                                                                                %
                                                                                string)
                                                                            Tezos_base__TzPervasives.Signature.Public_key.pp
                                                                            pk)
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            | tt
                                                                              =>
                                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                (send
                                                                                  (CamlinternalFormatBasics.Format
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      "* Public Key Hash: "
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                                          CamlinternalFormatBasics.Force_newline
                                                                                          CamlinternalFormatBasics.End_of_format)))
                                                                                    "* Public Key Hash: %a@
"
                                                                                      %
                                                                                      string)
                                                                                  Tezos_base__TzPervasives.Signature.Public_key_hash.pp
                                                                                  pkh)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    tt
                                                                                    =>
                                                                                    match
                                                                                      (test_sign,
                                                                                        (app_class
                                                                                          version))
                                                                                      with
                                                                                    |
                                                                                      (true,
                                                                                        Tezos)
                                                                                      =>
                                                                                      let
                                                                                        pkh_bytes :=
                                                                                        Tezos_base__TzPervasives.Signature.Public_key_hash.to_bytes
                                                                                          pkh
                                                                                        in
                                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                        (send
                                                                                          (CamlinternalFormatBasics.Format
                                                                                            (CamlinternalFormatBasics.Formatting_gen
                                                                                              (CamlinternalFormatBasics.Open_box
                                                                                                (CamlinternalFormatBasics.Format
                                                                                                  CamlinternalFormatBasics.End_of_format
                                                                                                  ""
                                                                                                    %
                                                                                                    string))
                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                "Attempting a signature"
                                                                                                  %
                                                                                                  string
                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                  (CamlinternalFormatBasics.Break
                                                                                                    "@ "
                                                                                                      %
                                                                                                      string
                                                                                                    1
                                                                                                    0)
                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                    "(of `"
                                                                                                      %
                                                                                                      string
                                                                                                    (CamlinternalFormatBasics.Alpha
                                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                                        "`),"
                                                                                                          %
                                                                                                          string
                                                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                                                          (CamlinternalFormatBasics.Break
                                                                                                            "@ "
                                                                                                              %
                                                                                                              string
                                                                                                            1
                                                                                                            0)
                                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                                            "please"
                                                                                                              %
                                                                                                              string
                                                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                                                              (CamlinternalFormatBasics.Break
                                                                                                                "@ "
                                                                                                                  %
                                                                                                                  string
                                                                                                                1
                                                                                                                0)
                                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                                "validate on"
                                                                                                                  %
                                                                                                                  string
                                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                                  (CamlinternalFormatBasics.Break
                                                                                                                    "@ "
                                                                                                                      %
                                                                                                                      string
                                                                                                                    1
                                                                                                                    0)
                                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                                    "the ledger."
                                                                                                                      %
                                                                                                                      string
                                                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                                                      CamlinternalFormatBasics.Close_box
                                                                                                                      CamlinternalFormatBasics.End_of_format)))))))))))))
                                                                                            "@[Attempting a signature@ (of `%a`),@ please@ validate on@ the ledger.@]"
                                                                                              %
                                                                                              string)
                                                                                          Hex.pp
                                                                                          (Hex.of_bytes
                                                                                            None
                                                                                            pkh_bytes))
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            tt
                                                                                            =>
                                                                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                              (Ledger_commands.sign
                                                                                                (Some
                                                                                                  Generic_operation)
                                                                                                version
                                                                                                hidapi
                                                                                                curve
                                                                                                path
                                                                                                pkh_bytes)
                                                                                              (fun
                                                                                                signature
                                                                                                =>
                                                                                                match
                                                                                                  Tezos_base__TzPervasives.Signature.check
                                                                                                    (Some
                                                                                                      Generic_operation)
                                                                                                    pk
                                                                                                    signature
                                                                                                    pkh_bytes
                                                                                                  with
                                                                                                |
                                                                                                  false
                                                                                                  =>
                                                                                                  Tezos_base__TzPervasives.failwith
                                                                                                    (CamlinternalFormatBasics.Format
                                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                                        "Fatal: Ledger cannot sign with "
                                                                                                          %
                                                                                                          string
                                                                                                        (CamlinternalFormatBasics.Alpha
                                                                                                          CamlinternalFormatBasics.End_of_format))
                                                                                                      "Fatal: Ledger cannot sign with %a"
                                                                                                        %
                                                                                                        string)
                                                                                                    Tezos_base__TzPervasives.Signature.Public_key_hash.pp
                                                                                                    pkh
                                                                                                |
                                                                                                  true
                                                                                                  =>
                                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                                    (send
                                                                                                      (CamlinternalFormatBasics.Format
                                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                                          "Tezos Wallet successfully signed:"
                                                                                                            %
                                                                                                            string
                                                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                                                            (CamlinternalFormatBasics.Break
                                                                                                              "@ "
                                                                                                                %
                                                                                                                string
                                                                                                              1
                                                                                                              0)
                                                                                                            (CamlinternalFormatBasics.Alpha
                                                                                                              (CamlinternalFormatBasics.Char_literal
                                                                                                                "."
                                                                                                                  %
                                                                                                                  char
                                                                                                                CamlinternalFormatBasics.End_of_format))))
                                                                                                        "Tezos Wallet successfully signed:@ %a."
                                                                                                          %
                                                                                                          string)
                                                                                                      Tezos_base__TzPervasives.Signature.pp
                                                                                                      signature)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      match
                                                                                                        function_parameter
                                                                                                        with
                                                                                                      |
                                                                                                        tt
                                                                                                        =>
                                                                                                        Tezos_base__TzPervasives.return_unit
                                                                                                      end)
                                                                                                end)
                                                                                          end)
                                                                                    |
                                                                                      (true,
                                                                                        TezBake)
                                                                                      =>
                                                                                      Tezos_base__TzPervasives.failwith
                                                                                        (CamlinternalFormatBasics.Format
                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                            "Option --test-sign only works for the Tezos Wallet app."
                                                                                              %
                                                                                              string
                                                                                            CamlinternalFormatBasics.End_of_format)
                                                                                          "Option --test-sign only works for the Tezos Wallet app."
                                                                                            %
                                                                                            string)
                                                                                    |
                                                                                      (false,
                                                                                        _)
                                                                                      =>
                                                                                      Tezos_base__TzPervasives.return_unit
                                                                                    end
                                                                                  end)
                                                                            end)
                                                                      end)
                                                                end)
                                                          end)
                                                    | Ledger _ =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "* This is just a ledger URI."
                                                                % string
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "* This is just a ledger URI."
                                                              % string))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)
                                                    end
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_base__TzPervasives.return_some
                                                          tt
                                                      end)
                                                end)
                                          end)
                                    end)
                              end)
                    end))) []).

Definition baking_commands (group : Tezos_base__TzPervasives.Clic.group)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  cons
    (Tezos_base__TzPervasives.Clic.command (Some group)
      "Query the path of the authorized key" % string
      Tezos_base__TzPervasives.Clic.no_options
      (apply
        (Tezos_base__TzPervasives.Clic.prefixes
          (cons "get" % string
            (cons "ledger" % string
              (cons "authorized" % string
                (cons "path" % string (cons "for" % string []))))))
        (apply Ledger_uri.ledger_uri_or_alias_param
          Tezos_base__TzPervasives.Clic.stop))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun ledger_uri =>
            fun cctxt =>
              use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                (fun hidapi =>
                  fun function_parameter =>
                    match function_parameter with
                    | (version, _git_commit) =>
                      fun _device_info =>
                        fun _ledger_id =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Ledger_commands.get_authorized_path hidapi version)
                            (fun authorized =>
                              match authorized with
                              | Legacy_path p =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 0>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 0>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Authorized baking path (Legacy < 2.x.y): "
                                            % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format))))
                                      "@[<v 0>Authorized baking path (Legacy < 2.x.y): %a@]"
                                        % string) Bip32_path.pp_path p)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.return_some tt
                                    end)
                              | No_baking_authorized =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "No baking key authorized at all." %
                                          string
                                        CamlinternalFormatBasics.End_of_format)
                                      "No baking key authorized at all." %
                                        string))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.return_some tt
                                    end)
                              | Path_curve (ledger_path, ledger_curve) =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 0>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 0>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Authorized baking path: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format))))
                                      "@[<v 0>Authorized baking path: %a@]" %
                                        string) Bip32_path.pp_path ledger_path)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_box
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "<v 0>" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "<v 0>" % string))
                                              (CamlinternalFormatBasics.String_literal
                                                "Authorized baking curve: " %
                                                  string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    CamlinternalFormatBasics.End_of_format))))
                                            "@[<v 0>Authorized baking curve: %a@]"
                                              % string)
                                          Ledgerwallet_tezos.pp_curve
                                          ledger_curve)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            match ledger_uri with
                                            | Ledger _ =>
                                              Tezos_base__TzPervasives.return_some
                                                tt
                                            |
                                              Ledger_account {|
                                                curve := curve;
                                                  path := path
                                                  |} =>
                                              Tezos_base__TzPervasives.failwith
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Path and curve do not match the ones specified in the command line: "
                                                      % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        " & " % string
                                                        (CamlinternalFormatBasics.Alpha
                                                          CamlinternalFormatBasics.End_of_format))))
                                                  "Path and curve do not match the ones specified in the command line: %a & %a"
                                                    % string)
                                                Ledgerwallet_tezos.pp_curve
                                                curve Bip32_path.pp_path
                                                (OCaml.Stdlib.app
                                                  Bip32_path.tezos_root path)
                                            end
                                          end)
                                    end)
                              end)
                    end)
        end))
    (cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Authorize a Ledger to bake for a key (deprecated, use `setup ledger ...` with recent versions of the Baking app)"
          % string Tezos_base__TzPervasives.Clic.no_options
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "authorize" % string
              (cons "ledger" % string
                (cons "to" % string
                  (cons "bake" % string (cons "for" % string []))))))
          (apply Ledger_uri.ledger_uri_or_alias_param
            Tezos_base__TzPervasives.Clic.stop))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun ledger_uri =>
              fun cctxt =>
                use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                  (fun hidapi =>
                    fun function_parameter =>
                      match function_parameter with
                      | (version, _git_commit) =>
                        fun _device_info =>
                          fun _ledger_id =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              match version with
                              | {|
                                Ledgerwallet_tezos.Version.app_class := Tezos
                                  |} =>
                                Tezos_base__TzPervasives.failwith
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "This command (`authorize ledger ...`) only works with the Tezos Baking app"
                                        % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "This command (`authorize ledger ...`) only works with the Tezos Baking app"
                                      % string)
                              | _ =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "This Ledger Baking app is outdated (" %
                                          string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Char_literal
                                            ")" % char
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              (CamlinternalFormatBasics.String_literal
                                                "running" % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@ " % string 1 0)
                                                  (CamlinternalFormatBasics.String_literal
                                                    "in backwards" % string
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@ " % string 1 0)
                                                      (CamlinternalFormatBasics.String_literal
                                                        "compatibility mode." %
                                                          string
                                                        CamlinternalFormatBasics.End_of_format)))))))))
                                      "This Ledger Baking app is outdated (%a)@ running@ in backwards@ compatibility mode."
                                        % string) Ledgerwallet_tezos.Version.pp
                                    version)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end)
                              end
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Ledger_uri.full_account ledger_uri)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | {|
                                        Ledger_account.curve := curve;
                                          Ledger_account.path := path
                                          |} =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Ledger_commands.public_key_returning_instruction
                                            variant None hidapi curve path)
                                          (fun pk =>
                                            let pkh :=
                                              Tezos_base__TzPervasives.Signature.Public_key.hash
                                                pk in
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.Formatting_gen
                                                    (CamlinternalFormatBasics.Open_box
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "<v 0>" % string
                                                          CamlinternalFormatBasics.End_of_format)
                                                        "<v 0>" % string))
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Authorized baking for address: "
                                                        % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          (CamlinternalFormatBasics.Break
                                                            "@," % string 0 0)
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Corresponding full public key: "
                                                              % string
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                CamlinternalFormatBasics.Close_box
                                                                CamlinternalFormatBasics.End_of_format)))))))
                                                  "@[<v 0>Authorized baking for address: %a@,Corresponding full public key: %a@]"
                                                    % string)
                                                Tezos_base__TzPervasives.Signature.Public_key_hash.pp
                                                pkh
                                                Tezos_base__TzPervasives.Signature.Public_key.pp
                                                pk)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives.return_some
                                                    tt
                                                end))
                                      end)
                                end)
                      end)
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Setup a Ledger to bake for a key" % string
          (let hwm_arg {A : Type} (kind : string)
            : Tezos_base__TzPervasives.Clic.arg (option int32) A :=
            let doc :=
              Stdlib.Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Use <HWM> as " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        " chain high watermark instead of asking the ledger." %
                          string CamlinternalFormatBasics.End_of_format)))
                  "Use <HWM> as %s chain high watermark instead of asking the ledger."
                    % string) kind in
            let long := String.append kind "-hwm" % string in
            Tezos_base__TzPervasives.Clic.default_arg doc None long
              "HWM" % string "ASK-LEDGER" % string
              (Tezos_base__TzPervasives.Clic.parameter None
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    fun function_parameter =>
                      match function_parameter with
                      | "ASK-LEDGER" % string =>
                        Tezos_base__TzPervasives.return_none
                      | s => try
                      end
                  end)) in
          Tezos_base__TzPervasives.Clic.args3
            (Tezos_base__TzPervasives.Clic.default_arg
              "Use <ID> as main chain-id instead of asking the node." % string
              None "main-chain-id" % string "ID" % string "ASK-NODE" % string
              (Tezos_base__TzPervasives.Clic.parameter None
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    fun function_parameter =>
                      match function_parameter with
                      | "ASK-NODE" % string =>
                        Tezos_base__TzPervasives._return variant
                      | s => try
                      end
                  end))) (hwm_arg "main" % string) (hwm_arg "test" % string))
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "setup" % string
                (cons "ledger" % string
                  (cons "to" % string
                    (cons "bake" % string (cons "for" % string []))))))
            (apply Ledger_uri.ledger_uri_or_alias_param
              Tezos_base__TzPervasives.Clic.stop))
          (fun function_parameter =>
            match function_parameter with
            | (chain_id_opt, main_hwm_opt, test_hwm_opt) =>
              fun ledger_uri =>
                fun cctxt =>
                  use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                    (fun hidapi =>
                      fun function_parameter =>
                        match function_parameter with
                        | (version, _git_commit) =>
                          fun _device_info =>
                            fun _ledger_id =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                match version with
                                | {| app_class := Tezos |} =>
                                  Tezos_base__TzPervasives.failwith
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "This command (`setup ledger ...`) only works with the Tezos Baking app"
                                          % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "This command (`setup ledger ...`) only works with the Tezos Baking app"
                                        % string)
                                | _ => Tezos_base__TzPervasives.return_unit
                                end
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Ledger_uri.full_account ledger_uri)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | {|
                                          Ledger_account.curve := curve;
                                            Ledger_account.path := path
                                            |} =>
                                          let chain_id_of_int32 (i32 : int32)
                                            : Tezos_base__TzPervasives.Chain_id.t :=
                                            let byte (n : Z) : ascii :=
                                              OCaml.Stdlib.reverse_apply
                                                (OCaml.Stdlib.reverse_apply
                                                  (Stdlib.Int32.logand 255
                                                    (Stdlib.Int32.shift_right
                                                      i32 (Z.mul n 8)))
                                                  Stdlib.Int32.to_int)
                                                OCaml.Stdlib.char_of_int in
                                            Tezos_base__TzPervasives.Chain_id.of_string_exn
                                              (Stringext.of_array
                                                (Stdlib.Array.init 4
                                                  (fun i => byte (Z.sub 3 i))))
                                            in
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            match chain_id_opt with
                                            | Ask_node =>
                                              Tezos_shell_services.Chain_services.chain_id
                                                cctxt None tt
                                            | Int32 s =>
                                              Tezos_base__TzPervasives._return
                                                (chain_id_of_int32 s)
                                            | Chain_id chid =>
                                              Tezos_base__TzPervasives._return
                                                chid
                                            end
                                            (fun main_chain_id =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Ledger_commands.wrap_ledger_cmd
                                                  (fun pp =>
                                                    Ledgerwallet_tezos.get_all_high_watermarks
                                                      (Some pp) None hidapi))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  |
                                                    (Main_hwm current_mh,
                                                      Test_hwm current_th,
                                                      Chain_id current_ci) =>
                                                    let main_hwm :=
                                                      Tezos_stdlib.Option.unopt
                                                        current_mh main_hwm_opt
                                                      in
                                                    let test_hwm :=
                                                      Tezos_stdlib.Option.unopt
                                                        current_th test_hwm_opt
                                                      in
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (send
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Setting up the ledger:"
                                                              % string
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Flush_newline
                                                              (CamlinternalFormatBasics.String_literal
                                                                "* Main chain ID: "
                                                                  % string
                                                                (CamlinternalFormatBasics.Alpha
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    " -> " %
                                                                      string
                                                                    (CamlinternalFormatBasics.Alpha
                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                        CamlinternalFormatBasics.Flush_newline
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "* Main chain High Watermark: "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.Int32
                                                                            CamlinternalFormatBasics.Int_d
                                                                            CamlinternalFormatBasics.No_padding
                                                                            CamlinternalFormatBasics.No_precision
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              " -> "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Int32
                                                                                CamlinternalFormatBasics.Int_d
                                                                                CamlinternalFormatBasics.No_padding
                                                                                CamlinternalFormatBasics.No_precision
                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                  CamlinternalFormatBasics.Flush_newline
                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                    "* Test chain High Watermark: "
                                                                                      %
                                                                                      string
                                                                                    (CamlinternalFormatBasics.Int32
                                                                                      CamlinternalFormatBasics.Int_d
                                                                                      CamlinternalFormatBasics.No_padding
                                                                                      CamlinternalFormatBasics.No_precision
                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                        " -> "
                                                                                          %
                                                                                          string
                                                                                        (CamlinternalFormatBasics.Int32
                                                                                          CamlinternalFormatBasics.Int_d
                                                                                          CamlinternalFormatBasics.No_padding
                                                                                          CamlinternalFormatBasics.No_precision
                                                                                          CamlinternalFormatBasics.End_of_format))))))))))))))))
                                                          "Setting up the ledger:@.* Main chain ID: %a -> %a@.* Main chain High Watermark: %ld -> %ld@.* Test chain High Watermark: %ld -> %ld"
                                                            % string)
                                                        pp_ledger_chain_id
                                                        current_ci
                                                        Tezos_base__TzPervasives.Chain_id.pp
                                                        main_chain_id current_mh
                                                        main_hwm current_th
                                                        test_hwm)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                            (Ledger_commands.public_key_returning_instruction
                                                              variant None
                                                              hidapi curve path)
                                                            (fun pk =>
                                                              let pkh :=
                                                                Tezos_base__TzPervasives.Signature.Public_key.hash
                                                                  pk in
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (send
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.Formatting_gen
                                                                      (CamlinternalFormatBasics.Open_box
                                                                        (CamlinternalFormatBasics.Format
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "<v 0>"
                                                                              %
                                                                              string
                                                                            CamlinternalFormatBasics.End_of_format)
                                                                          "<v 0>"
                                                                            %
                                                                            string))
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "Authorized baking for address: "
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Alpha
                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                            (CamlinternalFormatBasics.Break
                                                                              "@,"
                                                                                %
                                                                                string
                                                                              0
                                                                              0)
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              "Corresponding full public key: "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Alpha
                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                  CamlinternalFormatBasics.Close_box
                                                                                  CamlinternalFormatBasics.End_of_format)))))))
                                                                    "@[<v 0>Authorized baking for address: %a@,Corresponding full public key: %a@]"
                                                                      % string)
                                                                  Tezos_base__TzPervasives.Signature.Public_key_hash.pp
                                                                  pkh
                                                                  Tezos_base__TzPervasives.Signature.Public_key.pp
                                                                  pk)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_base__TzPervasives.return_some
                                                                      tt
                                                                  end))
                                                        end)
                                                  end))
                                        end)
                                  end)
                        end)
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Deauthorize Ledger from baking" % string
            Tezos_base__TzPervasives.Clic.no_options
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "deauthorize" % string
                  (cons "ledger" % string
                    (cons "baking" % string (cons "for" % string [])))))
              (apply Ledger_uri.ledger_uri_or_alias_param
                Tezos_base__TzPervasives.Clic.stop))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun ledger_uri =>
                  fun _cctxt =>
                    use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                      (fun hidapi =>
                        fun function_parameter =>
                          match function_parameter with
                          | (_version, _git_commit) =>
                            fun _device_info =>
                              fun _ledger_id =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Ledger_commands.wrap_ledger_cmd
                                    (fun pp =>
                                      Ledgerwallet_tezos.deauthorize_baking
                                        (Some pp) None hidapi))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.return_some tt
                                    end)
                          end)
              end)) []))).

Definition high_water_mark_commands
  (group : Tezos_base__TzPervasives.Clic.group)
  (watermark_spelling : list string)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  let make_desc (desc : string) : string :=
    if equiv_decb (Tezos_base__TzPervasives.List.length watermark_spelling) 1
      then
      String.append desc " (legacy/deprecated spelling)" % string
    else
      desc in
  cons
    (Tezos_base__TzPervasives.Clic.command (Some group)
      (make_desc "Get high water mark of a Ledger" % string)
      (Tezos_base__TzPervasives.Clic.args1
        (Tezos_base__TzPervasives.Clic.switch
          "Prevent the fallback to the (deprecated) Ledger instructions (for 1.x.y versions of the Baking app)"
            % string None "no-legacy-instructions" % string tt))
      (apply
        (Tezos_base__TzPervasives.Clic.prefixes
          (OCaml.Stdlib.app
            (cons "get" % string
              (cons "ledger" % string (cons "high" % string [])))
            (OCaml.Stdlib.app watermark_spelling (cons "for" % string []))))
        (apply Ledger_uri.ledger_uri_or_alias_param
          Tezos_base__TzPervasives.Clic.stop))
      (fun no_legacy_apdu =>
        fun ledger_uri =>
          fun cctxt =>
            use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
              (fun hidapi =>
                fun function_parameter =>
                  match function_parameter with
                  | (version, _git_commit) =>
                    fun _device_info =>
                      fun _ledger_id =>
                        match app_class version with
                        | Tezos =>
                          Tezos_base__TzPervasives.failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Fatal: this operation is only valid with the Tezos Baking application"
                                  % string
                                CamlinternalFormatBasics.End_of_format)
                              "Fatal: this operation is only valid with the Tezos Baking application"
                                % string)
                        | TezBake =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Ledger_commands.wrap_ledger_cmd
                              (fun pp =>
                                Ledgerwallet_tezos.get_all_high_watermarks
                                  (Some pp) None hidapi))
                            (fun function_parameter =>
                              match function_parameter with
                              | (Main_hwm mh, Test_hwm th, Chain_id ci) =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "The high water mark values for" %
                                          string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@ " % string 1 0)
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              (CamlinternalFormatBasics.String_literal
                                                "are" % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@ " % string 1 0)
                                                  (CamlinternalFormatBasics.Int32
                                                    CamlinternalFormatBasics.Int_d
                                                    CamlinternalFormatBasics.No_padding
                                                    CamlinternalFormatBasics.No_precision
                                                    (CamlinternalFormatBasics.String_literal
                                                      " for the main-chain" %
                                                        string
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@ " % string 1 0)
                                                        (CamlinternalFormatBasics.Char_literal
                                                          "(" % char
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Char_literal
                                                              ")" % char
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                (CamlinternalFormatBasics.Break
                                                                  "@ " % string
                                                                  1 0)
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "and" % string
                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                    (CamlinternalFormatBasics.Break
                                                                      "@ " %
                                                                        string 1
                                                                      0)
                                                                    (CamlinternalFormatBasics.Int32
                                                                      CamlinternalFormatBasics.Int_d
                                                                      CamlinternalFormatBasics.No_padding
                                                                      CamlinternalFormatBasics.No_precision
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        " for the test-chain."
                                                                          %
                                                                          string
                                                                        CamlinternalFormatBasics.End_of_format)))))))))))))))))
                                      "The high water mark values for@ %a@ are@ %ld for the main-chain@ (%a)@ and@ %ld for the test-chain."
                                        % string) Ledger_uri.pp ledger_uri mh
                                    pp_ledger_chain_id ci th)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.return_some tt
                                    end)
                              end)
                        end
                  end)))
    (cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        (make_desc "Set high water mark of a Ledger" % string)
        Tezos_base__TzPervasives.Clic.no_options
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (OCaml.Stdlib.app
              (cons "set" % string
                (cons "ledger" % string (cons "high" % string [])))
              (OCaml.Stdlib.app watermark_spelling (cons "for" % string []))))
          (apply Ledger_uri.ledger_uri_or_alias_param
            (apply (Tezos_base__TzPervasives.Clic.prefix "to" % string)
              (apply
                (Tezos_base__TzPervasives.Clic.param "high watermark" % string
                  "High watermark" % string
                  (Tezos_base__TzPervasives.Clic.parameter None
                    (fun _ctx => fun s => try)))
                Tezos_base__TzPervasives.Clic.stop))))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun ledger_uri =>
              fun hwm =>
                fun cctxt =>
                  use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                    (fun hidapi =>
                      fun function_parameter =>
                        match function_parameter with
                        | (version, _git_commit) =>
                          fun _device_info =>
                            fun _ledger_id =>
                              match app_class version with
                              | Tezos =>
                                Tezos_base__TzPervasives.failwith
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Fatal: this operation is only valid with TezBake"
                                        % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "Fatal: this operation is only valid with TezBake"
                                      % string)
                              | TezBake =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Ledger_commands.wrap_ledger_cmd
                                    (fun pp =>
                                      Ledgerwallet_tezos.set_high_watermark
                                        (Some pp) None hidapi hwm))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Ledger_commands.wrap_ledger_cmd
                                          (fun pp =>
                                            Ledgerwallet_tezos.get_high_watermark
                                              (Some pp) None hidapi))
                                        (fun new_hwm =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "<v 0>" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "<v 0>" % string))
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.String_literal
                                                      " has now high water mark: "
                                                        % string
                                                      (CamlinternalFormatBasics.Int32
                                                        CamlinternalFormatBasics.Int_d
                                                        CamlinternalFormatBasics.No_padding
                                                        CamlinternalFormatBasics.No_precision
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Close_box
                                                          CamlinternalFormatBasics.End_of_format)))))
                                                "@[<v 0>%a has now high water mark: %ld@]"
                                                  % string) Ledger_uri.pp
                                              ledger_uri new_hwm)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.return_some
                                                  tt
                                              end))
                                    end)
                              end
                        end)
          end)) []).

Definition commands
  : unit ->
    list
      (Tezos_base__TzPervasives.Clic.command
        Tezos_client_base.Client_context.full) :=
  let group :=
    {| Clic.name := "ledger" % string;
      Clic.title :=
        "Commands for managing the connected Ledger Nano devices" % string |} in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      OCaml.Stdlib.app (generic_commands group)
        (OCaml.Stdlib.app (baking_commands group)
          (OCaml.Stdlib.app
            (high_water_mark_commands group
              (cons "water" % string (cons "mark" % string [])))
            (high_water_mark_commands group (cons "watermark" % string []))))
    end.
src/lib_signer_backends/unix/ledger.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Bip32_path : sig
  val node_of_string : string -> int32 option

  val node_of_string_exn : string -> int32

  val pp_node : int32 Fmt.t

  val string_of_node : int32 -> string

  val path_of_string : string -> int32 list option

  val path_of_string_exn : string -> int32 list

  val pp_path : int32 list Fmt.t

  val string_of_path : int32 list -> string
end

module Signer_implementation : Client_keys.SIGNER

val commands : unit -> Client_context.full Clic.command list
src/lib_signer_backends/unix/ledger.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Bip32_path.
  Parameter node_of_string : string -> option int32.
  
  Parameter node_of_string_exn : string -> int32.
  
  Parameter pp_node : Fmt.t int32.
  
  Parameter string_of_node : int32 -> string.
  
  Parameter path_of_string : string -> option (list int32).
  
  Parameter path_of_string_exn : string -> list int32.
  
  Parameter pp_path : Fmt.t (list int32).
  
  Parameter string_of_path : (list int32) -> string.
End Bip32_path.

unhandled_module

Parameter commands :
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full).
src/lib_signer_backends/unix/ledger_names.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let adjectives =
  [| "abandoned";
     "able";
     "absolute";
     "adorable";
     "adventurous";
     "academic";
     "acceptable";
     "acclaimed";
     "accomplished";
     "accurate";
     "aching";
     "acidic";
     "acrobatic";
     "active";
     "actual";
     "adept";
     "admirable";
     "admired";
     "adolescent";
     "adorable";
     "adored";
     "advanced";
     "afraid";
     "affectionate";
     "aged";
     "aggravating";
     "aggressive";
     "agile";
     "agitated";
     "agonizing";
     "agreeable";
     "ajar";
     "alarmed";
     "alarming";
     "alert";
     "alienated";
     "alive";
     "all";
     "altruistic";
     "amazing";
     "ambitious";
     "ample";
     "amused";
     "amusing";
     "anchored";
     "ancient";
     "angelic";
     "angry";
     "anguished";
     "animated";
     "annual";
     "another";
     "antique";
     "anxious";
     "any";
     "apprehensive";
     "appropriate";
     "apt";
     "arctic";
     "arid";
     "aromatic";
     "artistic";
     "ashamed";
     "assured";
     "astonishing";
     "athletic";
     "attached";
     "attentive";
     "attractive";
     "austere";
     "authentic";
     "authorized";
     "automatic";
     "avaricious";
     "average";
     "aware";
     "awesome";
     "awful";
     "awkward";
     "babyish";
     "bad";
     "back";
     "baggy";
     "bare";
     "barren";
     "basic";
     "beautiful";
     "belated";
     "beloved";
     "beneficial";
     "better";
     "best";
     "bewitched";
     "big";
     "biodegradable";
     "bitter";
     "black";
     "bland";
     "blank";
     "blaring";
     "bleak";
     "blind";
     "blissful";
     "blond";
     "blue";
     "blushing";
     "bogus";
     "boiling";
     "bold";
     "bony";
     "boring";
     "bossy";
     "both";
     "bouncy";
     "bountiful";
     "bowed";
     "brave";
     "breakable";
     "brief";
     "bright";
     "brilliant";
     "brisk";
     "broken";
     "bronze";
     "brown";
     "bruised";
     "bubbly";
     "bulky";
     "bumpy";
     "buoyant";
     "burdensome";
     "burly";
     "bustling";
     "busy";
     "buttery";
     "buzzing";
     "calculating";
     "calm";
     "candid";
     "canine";
     "capital";
     "carefree";
     "careful";
     "careless";
     "caring";
     "cautious";
     "cavernous";
     "celebrated";
     "charming";
     "cheap";
     "cheerful";
     "cheery";
     "chief";
     "chilly";
     "chubby";
     "circular";
     "classic";
     "clean";
     "clear";
     "clever";
     "close";
     "closed";
     "cloudy";
     "clueless";
     "clumsy";
     "cluttered";
     "coarse";
     "cold";
     "colorful";
     "colorless";
     "colossal";
     "comfortable";
     "common";
     "compassionate";
     "competent";
     "complete";
     "complex";
     "complicated";
     "composed";
     "concerned";
     "concrete";
     "confused";
     "conscious";
     "considerate";
     "constant";
     "content";
     "conventional";
     "cooked";
     "cool";
     "cooperative";
     "coordinated";
     "corny";
     "corrupt";
     "costly";
     "courageous";
     "courteous";
     "crafty";
     "crazy";
     "creamy";
     "creative";
     "creepy";
     "criminal";
     "crisp";
     "critical";
     "crooked";
     "crowded";
     "cruel";
     "crushing";
     "cuddly";
     "cultivated";
     "cultured";
     "cumbersome";
     "curly";
     "curvy";
     "cute";
     "cylindrical";
     "damaged";
     "damp";
     "dangerous";
     "dapper";
     "daring";
     "darling";
     "dark";
     "dazzling";
     "dead";
     "deadly";
     "deafening";
     "dear";
     "dearest";
     "decent";
     "decimal";
     "decisive";
     "deep";
     "defenseless";
     "defensive";
     "defiant";
     "deficient";
     "definite";
     "definitive";
     "delayed";
     "delectable";
     "delicious";
     "delightful";
     "delirious";
     "demanding";
     "dense";
     "dental";
     "dependable";
     "dependent";
     "descriptive";
     "deserted";
     "detailed";
     "determined";
     "devoted";
     "different";
     "difficult";
     "digital";
     "diligent";
     "dim";
     "dimpled";
     "dimwitted";
     "direct";
     "disastrous";
     "discrete";
     "disfigured";
     "disgusting";
     "disloyal";
     "dismal";
     "distant";
     "downright";
     "dreary";
     "dirty";
     "disguised";
     "dishonest";
     "dismal";
     "distant";
     "distinct";
     "distorted";
     "dizzy";
     "dopey";
     "doting";
     "double";
     "downright";
     "drab";
     "drafty";
     "dramatic";
     "dreary";
     "droopy";
     "dry";
     "dual";
     "dull";
     "dutiful";
     "eager";
     "earnest";
     "early";
     "easy";
     "ecstatic";
     "edible";
     "educated";
     "elaborate";
     "elastic";
     "elated";
     "elderly";
     "electric";
     "elegant";
     "elementary";
     "elliptical";
     "embarrassed";
     "embellished";
     "eminent";
     "emotional";
     "empty";
     "enchanted";
     "enchanting";
     "energetic";
     "enlightened";
     "enormous";
     "enraged";
     "entire";
     "envious";
     "equal";
     "equatorial";
     "essential";
     "esteemed";
     "ethical";
     "euphoric";
     "even";
     "evergreen";
     "everlasting";
     "every";
     "evil";
     "exalted";
     "excellent";
     "exemplary";
     "exhausted";
     "excitable";
     "excited";
     "exciting";
     "exotic";
     "expensive";
     "experienced";
     "expert";
     "extraneous";
     "extroverted";
     "fabulous";
     "failing";
     "faint";
     "fair";
     "faithful";
     "fake";
     "false";
     "familiar";
     "famous";
     "fancy";
     "fantastic";
     "far";
     "faraway";
     "fast";
     "fat";
     "fatal";
     "fatherly";
     "favorable";
     "favorite";
     "fearful";
     "fearless";
     "feisty";
     "feline";
     "female";
     "feminine";
     "few";
     "fickle";
     "filthy";
     "fine";
     "finished";
     "firm";
     "first";
     "firsthand";
     "fitting";
     "fixed";
     "flaky";
     "flamboyant";
     "flashy";
     "flat";
     "flawed";
     "flawless";
     "flickering";
     "flimsy";
     "flippant";
     "flowery";
     "fluffy";
     "fluid";
     "flustered";
     "focused";
     "fond";
     "foolhardy";
     "foolish";
     "forceful";
     "forked";
     "formal";
     "forsaken";
     "forthright";
     "fortunate";
     "fragrant";
     "frail";
     "frank";
     "frayed";
     "free";
     "french";
     "fresh";
     "frequent";
     "friendly";
     "frightened";
     "frightening";
     "frigid";
     "frilly";
     "frizzy";
     "frivolous";
     "front";
     "frosty";
     "frozen";
     "frugal";
     "fruitful";
     "full";
     "fumbling";
     "functional";
     "funny";
     "fussy";
     "fuzzy";
     "gargantuan";
     "gaseous";
     "general";
     "generous";
     "gentle";
     "genuine";
     "giant";
     "giddy";
     "gigantic";
     "gifted";
     "giving";
     "glamorous";
     "glaring";
     "glass";
     "gleaming";
     "gleeful";
     "glistening";
     "glittering";
     "gloomy";
     "glorious";
     "glossy";
     "glum";
     "golden";
     "good";
     "gorgeous";
     "graceful";
     "gracious";
     "grand";
     "grandiose";
     "granular";
     "grateful";
     "grave";
     "gray";
     "great";
     "greedy";
     "green";
     "gregarious";
     "grim";
     "grimy";
     "gripping";
     "grizzled";
     "gross";
     "grotesque";
     "grouchy";
     "grounded";
     "growing";
     "growling";
     "grown";
     "grubby";
     "gruesome";
     "grumpy";
     "guilty";
     "gullible";
     "gummy";
     "hairy";
     "half";
     "handmade";
     "handsome";
     "handy";
     "happy";
     "hard";
     "harmful";
     "harmless";
     "harmonious";
     "harsh";
     "hasty";
     "hateful";
     "haunting";
     "healthy";
     "heartfelt";
     "hearty";
     "heavenly";
     "heavy";
     "hefty";
     "helpful";
     "helpless";
     "hidden";
     "hideous";
     "high";
     "hilarious";
     "hoarse";
     "hollow";
     "homely";
     "honest";
     "honorable";
     "honored";
     "hopeful";
     "horrible";
     "hospitable";
     "hot";
     "huge";
     "humble";
     "humiliating";
     "humming";
     "humongous";
     "hungry";
     "hurtful";
     "husky";
     "icky";
     "icy";
     "ideal";
     "idealistic";
     "identical";
     "idle";
     "idiotic";
     "idolized";
     "ignorant";
     "ill";
     "illegal";
     "illiterate";
     "illustrious";
     "imaginary";
     "imaginative";
     "immaculate";
     "immaterial";
     "immediate";
     "immense";
     "impassioned";
     "impeccable";
     "impartial";
     "imperfect";
     "imperturbable";
     "impish";
     "impolite";
     "important";
     "impossible";
     "impractical";
     "impressionable";
     "impressive";
     "improbable";
     "impure";
     "inborn";
     "incomparable";
     "incompatible";
     "incomplete";
     "inconsequential";
     "incredible";
     "indelible";
     "inexperienced";
     "indolent";
     "infamous";
     "infantile";
     "infatuated";
     "inferior";
     "infinite";
     "informal";
     "innocent";
     "insecure";
     "insidious";
     "insignificant";
     "insistent";
     "instructive";
     "insubstantial";
     "intelligent";
     "intent";
     "intentional";
     "interesting";
     "internal";
     "international";
     "intrepid";
     "ironclad";
     "irresponsible";
     "irritating";
     "itchy";
     "jaded";
     "jagged";
     "jaunty";
     "jealous";
     "jittery";
     "joint";
     "jolly";
     "jovial";
     "joyful";
     "joyous";
     "jubilant";
     "judicious";
     "juicy";
     "jumbo";
     "junior";
     "jumpy";
     "juvenile";
     "kaleidoscopic";
     "keen";
     "key";
     "kind";
     "kindhearted";
     "kindly";
     "klutzy";
     "knobby";
     "knotty";
     "knowledgeable";
     "knowing";
     "known";
     "kooky";
     "lame";
     "lanky";
     "large";
     "last";
     "lasting";
     "late";
     "lavish";
     "lawful";
     "lazy";
     "leading";
     "lean";
     "leafy";
     "left";
     "legal";
     "legitimate";
     "light";
     "lighthearted";
     "likable";
     "likely";
     "limited";
     "limp";
     "limping";
     "linear";
     "lined";
     "liquid";
     "little";
     "live";
     "lively";
     "livid";
     "loathsome";
     "lone";
     "lonely";
     "long";
     "loose";
     "lopsided";
     "lost";
     "loud";
     "lovable";
     "lovely";
     "loving";
     "low";
     "loyal";
     "lucky";
     "lumbering";
     "luminous";
     "lumpy";
     "lustrous";
     "luxurious";
     "mad";
     "magnificent";
     "majestic";
     "major";
     "male";
     "mammoth";
     "married";
     "marvelous";
     "masculine";
     "massive";
     "mature";
     "meager";
     "mealy";
     "mean";
     "measly";
     "meaty";
     "medical";
     "mediocre";
     "medium";
     "meek";
     "mellow";
     "melodic";
     "memorable";
     "menacing";
     "merry";
     "messy";
     "metallic";
     "mild";
     "milky";
     "mindless";
     "miniature";
     "minor";
     "minty";
     "miserable";
     "miserly";
     "misguided";
     "misty";
     "mixed";
     "modern";
     "modest";
     "moist";
     "monstrous";
     "monthly";
     "monumental";
     "moral";
     "mortified";
     "motherly";
     "motionless";
     "mountainous";
     "muddy";
     "muffled";
     "multicolored";
     "mundane";
     "murky";
     "mushy";
     "musty";
     "muted";
     "mysterious";
     "naive";
     "narrow";
     "nasty";
     "natural";
     "naughty";
     "nautical";
     "near";
     "neat";
     "necessary";
     "needy";
     "negative";
     "neglected";
     "negligible";
     "neighboring";
     "nervous";
     "new";
     "nice";
     "nifty";
     "nimble";
     "nippy";
     "nocturnal";
     "noisy";
     "nonstop";
     "normal";
     "notable";
     "noted";
     "noteworthy";
     "novel";
     "noxious";
     "numb";
     "nutritious";
     "nutty";
     "obedient";
     "obese";
     "oblong";
     "oily";
     "oblong";
     "obvious";
     "occasional";
     "odd";
     "oddball";
     "offbeat";
     "offensive";
     "official";
     "old";
     "only";
     "open";
     "optimal";
     "optimistic";
     "opulent";
     "orange";
     "orderly";
     "organic";
     "ornate";
     "ornery";
     "ordinary";
     "original";
     "other";
     "our";
     "outlying";
     "outgoing";
     "outlandish";
     "outrageous";
     "outstanding";
     "oval";
     "overcooked";
     "overdue";
     "overjoyed";
     "overlooked";
     "palatable";
     "pale";
     "paltry";
     "parallel";
     "parched";
     "partial";
     "passionate";
     "past";
     "pastel";
     "peaceful";
     "peppery";
     "perfect";
     "perfumed";
     "periodic";
     "perky";
     "personal";
     "pertinent";
     "pesky";
     "pessimistic";
     "petty";
     "phony";
     "physical";
     "piercing";
     "pink";
     "pitiful";
     "plain";
     "plaintive";
     "plastic";
     "playful";
     "pleasant";
     "pleased";
     "pleasing";
     "plump";
     "plush";
     "polished";
     "polite";
     "political";
     "pointed";
     "pointless";
     "poised";
     "poor";
     "popular";
     "portly";
     "posh";
     "positive";
     "possible";
     "potable";
     "powerful";
     "powerless";
     "practical";
     "precious";
     "present";
     "prestigious";
     "pretty";
     "precious";
     "previous";
     "pricey";
     "prickly";
     "primary";
     "prime";
     "pristine";
     "private";
     "prize";
     "probable";
     "productive";
     "profitable";
     "profuse";
     "proper";
     "proud";
     "prudent";
     "punctual";
     "pungent";
     "puny";
     "pure";
     "purple";
     "pushy";
     "putrid";
     "puzzled";
     "puzzling";
     "quaint";
     "qualified";
     "quarrelsome";
     "quarterly";
     "queasy";
     "querulous";
     "questionable";
     "quick";
     "quiet";
     "quintessential";
     "quirky";
     "quixotic";
     "quizzical";
     "radiant";
     "ragged";
     "rapid";
     "rare";
     "rash";
     "raw";
     "recent";
     "reckless";
     "rectangular";
     "ready";
     "real";
     "realistic";
     "reasonable";
     "red";
     "reflecting";
     "regal";
     "regular";
     "reliable";
     "relieved";
     "remarkable";
     "remorseful";
     "remote";
     "repentant";
     "required";
     "respectful";
     "responsible";
     "repulsive";
     "revolving";
     "rewarding";
     "rich";
     "rigid";
     "right";
     "ringed";
     "ripe";
     "roasted";
     "robust";
     "rosy";
     "rotating";
     "rotten";
     "rough";
     "round";
     "rowdy";
     "royal";
     "rubbery";
     "rundown";
     "ruddy";
     "rude";
     "runny";
     "rural";
     "rusty";
     "sad";
     "safe";
     "salty";
     "same";
     "sandy";
     "sane";
     "sarcastic";
     "sardonic";
     "satisfied";
     "scaly";
     "scarce";
     "scared";
     "scary";
     "scented";
     "scholarly";
     "scientific";
     "scornful";
     "scratchy";
     "scrawny";
     "second";
     "secondary";
     "secret";
     "selfish";
     "sentimental";
     "separate";
     "serene";
     "serious";
     "serpentine";
     "several";
     "severe";
     "shabby";
     "shadowy";
     "shady";
     "shallow";
     "shameful";
     "shameless";
     "sharp";
     "shimmering";
     "shiny";
     "shocked";
     "shocking";
     "shoddy";
     "short";
     "showy";
     "shrill";
     "shy";
     "sick";
     "silent";
     "silky";
     "silly";
     "silver";
     "similar";
     "simple";
     "simplistic";
     "sinful";
     "single";
     "sizzling";
     "skeletal";
     "skinny";
     "sleepy";
     "slight";
     "slim";
     "slimy";
     "slippery";
     "slow";
     "slushy";
     "small";
     "smart";
     "smoggy";
     "smooth";
     "smug";
     "snappy";
     "snarling";
     "sneaky";
     "sniveling";
     "snoopy";
     "sociable";
     "soft";
     "soggy";
     "solid";
     "somber";
     "some";
     "spherical";
     "sophisticated";
     "sore";
     "sorrowful";
     "soulful";
     "soupy";
     "sour";
     "spanish";
     "sparkling";
     "sparse";
     "specific";
     "spectacular";
     "speedy";
     "spicy";
     "spiffy";
     "spirited";
     "spiteful";
     "splendid";
     "spotless";
     "spotted";
     "spry";
     "square";
     "squeaky";
     "squiggly";
     "stable";
     "staid";
     "stained";
     "stale";
     "standard";
     "starchy";
     "stark";
     "starry";
     "steep";
     "sticky";
     "stiff";
     "stimulating";
     "stingy";
     "stormy";
     "straight";
     "strange";
     "steel";
     "strict";
     "strident";
     "striking";
     "striped";
     "strong";
     "studious";
     "stunning";
     "stupendous";
     "stupid";
     "sturdy";
     "stylish";
     "subdued";
     "submissive";
     "substantial";
     "subtle";
     "suburban";
     "sudden";
     "sugary";
     "sunny";
     "super";
     "superb";
     "superficial";
     "superior";
     "supportive";
     "surprised";
     "suspicious";
     "svelte";
     "sweaty";
     "sweet";
     "sweltering";
     "swift";
     "sympathetic";
     "tall";
     "talkative";
     "tame";
     "tan";
     "tangible";
     "tart";
     "tasty";
     "tattered";
     "taut";
     "tedious";
     "teeming";
     "tempting";
     "tender";
     "tense";
     "tepid";
     "terrible";
     "terrific";
     "testy";
     "thankful";
     "that";
     "these";
     "thick";
     "thin";
     "third";
     "thirsty";
     "this";
     "thorough";
     "thorny";
     "those";
     "thoughtful";
     "threadbare";
     "thrifty";
     "thunderous";
     "tidy";
     "tight";
     "timely";
     "tinted";
     "tiny";
     "tired";
     "torn";
     "total";
     "tough";
     "traumatic";
     "treasured";
     "tremendous";
     "tragic";
     "trained";
     "tremendous";
     "triangular";
     "tricky";
     "trifling";
     "trim";
     "trivial";
     "troubled";
     "true";
     "trusting";
     "trustworthy";
     "trusty";
     "truthful";
     "tubby";
     "turbulent";
     "twin";
     "ugly";
     "ultimate";
     "unacceptable";
     "unaware";
     "uncomfortable";
     "uncommon";
     "unconscious";
     "understated";
     "unequaled";
     "uneven";
     "unfinished";
     "unfit";
     "unfolded";
     "unfortunate";
     "unhappy";
     "unhealthy";
     "uniform";
     "unimportant";
     "unique";
     "united";
     "unkempt";
     "unknown";
     "unlawful";
     "unlined";
     "unlucky";
     "unnatural";
     "unpleasant";
     "unrealistic";
     "unripe";
     "unruly";
     "unselfish";
     "unsightly";
     "unsteady";
     "unsung";
     "untidy";
     "untimely";
     "untried";
     "untrue";
     "unused";
     "unusual";
     "unwelcome";
     "unwieldy";
     "unwilling";
     "unwitting";
     "unwritten";
     "upbeat";
     "upright";
     "upset";
     "urban";
     "usable";
     "used";
     "useful";
     "useless";
     "utilized";
     "utter";
     "vacant";
     "vague";
     "vain";
     "valid";
     "valuable";
     "vapid";
     "variable";
     "vast";
     "velvety";
     "venerated";
     "vengeful";
     "verifiable";
     "vibrant";
     "vicious";
     "victorious";
     "vigilant";
     "vigorous";
     "villainous";
     "violet";
     "violent";
     "virtual";
     "virtuous";
     "visible";
     "vital";
     "vivacious";
     "vivid";
     "voluminous";
     "warlike";
     "warm";
     "warmhearted";
     "warped";
     "wary";
     "wasteful";
     "watchful";
     "waterlogged";
     "watery";
     "wavy";
     "wealthy";
     "weak";
     "weary";
     "webbed";
     "wee";
     "weekly";
     "weepy";
     "weighty";
     "weird";
     "welcome";
     "wet";
     "which";
     "whimsical";
     "whirlwind";
     "whispered";
     "white";
     "whole";
     "whopping";
     "wicked";
     "wide";
     "wiggly";
     "wild";
     "willing";
     "wilted";
     "winding";
     "windy";
     "winged";
     "wiry";
     "wise";
     "witty";
     "wobbly";
     "woeful";
     "wonderful";
     "wooden";
     "woozy";
     "wordy";
     "worldly";
     "worn";
     "worried";
     "worrisome";
     "worse";
     "worst";
     "worthless";
     "worthwhile";
     "worthy";
     "wrathful";
     "wretched";
     "writhing";
     "wrong";
     "wry";
     "yawning";
     "yearly";
     "yellow";
     "yellowish";
     "young";
     "youthful";
     "yummy";
     "zany";
     "zealous";
     "zesty" |]

let animals =
  [| "aardvark";
     "abyssinian";
     "affenpinscher";
     "akbash";
     "akita";
     "albatross";
     "alligator";
     "angelfish";
     "ant";
     "anteater";
     "antelope";
     "armadillo";
     "avocet";
     "axolotl";
     "baboon";
     "badger";
     "balinese";
     "bandicoot";
     "barb";
     "barnacle";
     "barracuda";
     "bat";
     "beagle";
     "bear";
     "beaver";
     "beetle";
     "binturong";
     "birman";
     "bison";
     "bloodhound";
     "bobcat";
     "bombay";
     "bongo";
     "bonobo";
     "booby";
     "budgerigar";
     "buffalo";
     "bulldog";
     "bullfrog";
     "burmese";
     "butterfly";
     "caiman";
     "camel";
     "capybara";
     "caracal";
     "cassowary";
     "cat";
     "caterpillar";
     "catfish";
     "centipede";
     "chameleon";
     "chamois";
     "cheetah";
     "chicken";
     "chihuahua";
     "chimpanzee";
     "chinchilla";
     "chinook";
     "chipmunk";
     "cichlid";
     "coati";
     "cockroach";
     "collie";
     "coral";
     "cougar";
     "cow";
     "coyote";
     "crab";
     "crane";
     "crocodile";
     "cuscus";
     "cuttlefish";
     "dachshund";
     "dalmatian";
     "deer";
     "dhole";
     "dingo";
     "discus";
     "dodo";
     "dog";
     "dolphin";
     "donkey";
     "dormouse";
     "dragonfly";
     "drever";
     "duck";
     "dugong";
     "dunker";
     "eagle";
     "earwig";
     "echidna";
     "elephant";
     "emu";
     "falcon";
     "fennec";
     "ferret";
     "fish";
     "flamingo";
     "flounder";
     "fly";
     "fossa";
     "fox";
     "frigatebird";
     "frog";
     "gar";
     "gecko";
     "gerbil";
     "gharial";
     "gibbon";
     "giraffe";
     "goat";
     "goose";
     "gopher";
     "gorilla";
     "grasshopper";
     "greyhound";
     "grouse";
     "guppy";
     "hamster";
     "hare";
     "harrier";
     "havanese";
     "hedgehog";
     "heron";
     "himalayan";
     "hippopotamus";
     "horse";
     "human";
     "hummingbird";
     "hyena";
     "ibis";
     "iguana";
     "impala";
     "indri";
     "insect";
     "jackal";
     "jaguar";
     "javanese";
     "jellyfish";
     "kakapo";
     "kangaroo";
     "kingfisher";
     "kiwi";
     "koala";
     "kudu";
     "labradoodle";
     "ladybird";
     "lemming";
     "lemur";
     "leopard";
     "liger";
     "lion";
     "lionfish";
     "lizard";
     "llama";
     "lobster";
     "lynx";
     "macaw";
     "magpie";
     "maltese";
     "manatee";
     "mandrill";
     "markhor";
     "mastiff";
     "mayfly";
     "meerkat";
     "millipede";
     "mole";
     "molly";
     "mongoose";
     "mongrel";
     "monkey";
     "moorhen";
     "moose";
     "moth";
     "mouse";
     "mule";
     "neanderthal";
     "newfoundland";
     "newt";
     "nightingale";
     "numbat";
     "ocelot";
     "octopus";
     "okapi";
     "olm";
     "opossum";
     "ostrich";
     "otter";
     "oyster";
     "pademelon";
     "panther";
     "parrot";
     "peacock";
     "pekingese";
     "pelican";
     "penguin";
     "persian";
     "pheasant";
     "pig";
     "pika";
     "pike";
     "piranha";
     "platypus";
     "pointer";
     "poodle";
     "porcupine";
     "possum";
     "prawn";
     "puffin";
     "pug";
     "puma";
     "quail";
     "quetzal";
     "quokka";
     "quoll";
     "rabbit";
     "raccoon";
     "ragdoll";
     "rat";
     "rattlesnake";
     "reindeer";
     "rhinoceros";
     "robin";
     "rottweiler";
     "salamander";
     "saola";
     "scorpion";
     "seahorse";
     "seal";
     "serval";
     "sheep";
     "shrimp";
     "siamese";
     "siberian";
     "skunk";
     "sloth";
     "snail";
     "snake";
     "snowshoe";
     "somali";
     "sparrow";
     "sponge";
     "squid";
     "squirrel";
     "starfish";
     "stingray";
     "stoat";
     "swan";
     "tang";
     "tapir";
     "tarsier";
     "termite";
     "tetra";
     "tiffany";
     "tiger";
     "tortoise";
     "toucan";
     "tropicbird";
     "tuatara";
     "turkey";
     "uakari";
     "uguisu";
     "umbrellabird";
     "vulture";
     "wallaby";
     "walrus";
     "warthog";
     "wasp";
     "weasel";
     "whippet";
     "wildebeest";
     "wolf";
     "wolverine";
     "wombat";
     "woodlouse";
     "woodpecker";
     "wrasse";
     "yak";
     "zebra";
     "zebu";
     "zonkey";
     "zorse" |]

let pick a z = a.(Z.rem z (Array.length a |> Z.of_int) |> Z.to_int)

let hash a = Blake2B.hash_string [a] |> Blake2B.to_string

type t = {c : string; t : string; h : string; d : string}

let pp ppf {c; t; h; d} = Format.fprintf ppf "%s-%s-%s-%s" c t h d

let crouching_tiger string =
  let c = pick adjectives (string |> hash |> Z.of_bits) in
  let t = pick animals (string |> hash |> hash |> Z.of_bits) in
  let h = pick adjectives (string |> hash |> hash |> hash |> Z.of_bits) in
  let d = pick animals (string |> hash |> hash |> hash |> hash |> Z.of_bits) in
  {c; t; h; d}
src/lib_signer_backends/unix/ledger_names.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition adjectives : array string :=
  ("abandoned" % string, "able" % string, "absolute" % string,
    "adorable" % string, "adventurous" % string, "academic" % string,
    "acceptable" % string, "acclaimed" % string, "accomplished" % string,
    "accurate" % string, "aching" % string, "acidic" % string,
    "acrobatic" % string, "active" % string, "actual" % string,
    "adept" % string, "admirable" % string, "admired" % string,
    "adolescent" % string, "adorable" % string, "adored" % string,
    "advanced" % string, "afraid" % string, "affectionate" % string,
    "aged" % string, "aggravating" % string, "aggressive" % string,
    "agile" % string, "agitated" % string, "agonizing" % string,
    "agreeable" % string, "ajar" % string, "alarmed" % string,
    "alarming" % string, "alert" % string, "alienated" % string,
    "alive" % string, "all" % string, "altruistic" % string, "amazing" % string,
    "ambitious" % string, "ample" % string, "amused" % string,
    "amusing" % string, "anchored" % string, "ancient" % string,
    "angelic" % string, "angry" % string, "anguished" % string,
    "animated" % string, "annual" % string, "another" % string,
    "antique" % string, "anxious" % string, "any" % string,
    "apprehensive" % string, "appropriate" % string, "apt" % string,
    "arctic" % string, "arid" % string, "aromatic" % string,
    "artistic" % string, "ashamed" % string, "assured" % string,
    "astonishing" % string, "athletic" % string, "attached" % string,
    "attentive" % string, "attractive" % string, "austere" % string,
    "authentic" % string, "authorized" % string, "automatic" % string,
    "avaricious" % string, "average" % string, "aware" % string,
    "awesome" % string, "awful" % string, "awkward" % string,
    "babyish" % string, "bad" % string, "back" % string, "baggy" % string,
    "bare" % string, "barren" % string, "basic" % string, "beautiful" % string,
    "belated" % string, "beloved" % string, "beneficial" % string,
    "better" % string, "best" % string, "bewitched" % string, "big" % string,
    "biodegradable" % string, "bitter" % string, "black" % string,
    "bland" % string, "blank" % string, "blaring" % string, "bleak" % string,
    "blind" % string, "blissful" % string, "blond" % string, "blue" % string,
    "blushing" % string, "bogus" % string, "boiling" % string, "bold" % string,
    "bony" % string, "boring" % string, "bossy" % string, "both" % string,
    "bouncy" % string, "bountiful" % string, "bowed" % string, "brave" % string,
    "breakable" % string, "brief" % string, "bright" % string,
    "brilliant" % string, "brisk" % string, "broken" % string,
    "bronze" % string, "brown" % string, "bruised" % string, "bubbly" % string,
    "bulky" % string, "bumpy" % string, "buoyant" % string,
    "burdensome" % string, "burly" % string, "bustling" % string,
    "busy" % string, "buttery" % string, "buzzing" % string,
    "calculating" % string, "calm" % string, "candid" % string,
    "canine" % string, "capital" % string, "carefree" % string,
    "careful" % string, "careless" % string, "caring" % string,
    "cautious" % string, "cavernous" % string, "celebrated" % string,
    "charming" % string, "cheap" % string, "cheerful" % string,
    "cheery" % string, "chief" % string, "chilly" % string, "chubby" % string,
    "circular" % string, "classic" % string, "clean" % string, "clear" % string,
    "clever" % string, "close" % string, "closed" % string, "cloudy" % string,
    "clueless" % string, "clumsy" % string, "cluttered" % string,
    "coarse" % string, "cold" % string, "colorful" % string,
    "colorless" % string, "colossal" % string, "comfortable" % string,
    "common" % string, "compassionate" % string, "competent" % string,
    "complete" % string, "complex" % string, "complicated" % string,
    "composed" % string, "concerned" % string, "concrete" % string,
    "confused" % string, "conscious" % string, "considerate" % string,
    "constant" % string, "content" % string, "conventional" % string,
    "cooked" % string, "cool" % string, "cooperative" % string,
    "coordinated" % string, "corny" % string, "corrupt" % string,
    "costly" % string, "courageous" % string, "courteous" % string,
    "crafty" % string, "crazy" % string, "creamy" % string, "creative" % string,
    "creepy" % string, "criminal" % string, "crisp" % string,
    "critical" % string, "crooked" % string, "crowded" % string,
    "cruel" % string, "crushing" % string, "cuddly" % string,
    "cultivated" % string, "cultured" % string, "cumbersome" % string,
    "curly" % string, "curvy" % string, "cute" % string, "cylindrical" % string,
    "damaged" % string, "damp" % string, "dangerous" % string,
    "dapper" % string, "daring" % string, "darling" % string, "dark" % string,
    "dazzling" % string, "dead" % string, "deadly" % string,
    "deafening" % string, "dear" % string, "dearest" % string,
    "decent" % string, "decimal" % string, "decisive" % string, "deep" % string,
    "defenseless" % string, "defensive" % string, "defiant" % string,
    "deficient" % string, "definite" % string, "definitive" % string,
    "delayed" % string, "delectable" % string, "delicious" % string,
    "delightful" % string, "delirious" % string, "demanding" % string,
    "dense" % string, "dental" % string, "dependable" % string,
    "dependent" % string, "descriptive" % string, "deserted" % string,
    "detailed" % string, "determined" % string, "devoted" % string,
    "different" % string, "difficult" % string, "digital" % string,
    "diligent" % string, "dim" % string, "dimpled" % string,
    "dimwitted" % string, "direct" % string, "disastrous" % string,
    "discrete" % string, "disfigured" % string, "disgusting" % string,
    "disloyal" % string, "dismal" % string, "distant" % string,
    "downright" % string, "dreary" % string, "dirty" % string,
    "disguised" % string, "dishonest" % string, "dismal" % string,
    "distant" % string, "distinct" % string, "distorted" % string,
    "dizzy" % string, "dopey" % string, "doting" % string, "double" % string,
    "downright" % string, "drab" % string, "drafty" % string,
    "dramatic" % string, "dreary" % string, "droopy" % string, "dry" % string,
    "dual" % string, "dull" % string, "dutiful" % string, "eager" % string,
    "earnest" % string, "early" % string, "easy" % string, "ecstatic" % string,
    "edible" % string, "educated" % string, "elaborate" % string,
    "elastic" % string, "elated" % string, "elderly" % string,
    "electric" % string, "elegant" % string, "elementary" % string,
    "elliptical" % string, "embarrassed" % string, "embellished" % string,
    "eminent" % string, "emotional" % string, "empty" % string,
    "enchanted" % string, "enchanting" % string, "energetic" % string,
    "enlightened" % string, "enormous" % string, "enraged" % string,
    "entire" % string, "envious" % string, "equal" % string,
    "equatorial" % string, "essential" % string, "esteemed" % string,
    "ethical" % string, "euphoric" % string, "even" % string,
    "evergreen" % string, "everlasting" % string, "every" % string,
    "evil" % string, "exalted" % string, "excellent" % string,
    "exemplary" % string, "exhausted" % string, "excitable" % string,
    "excited" % string, "exciting" % string, "exotic" % string,
    "expensive" % string, "experienced" % string, "expert" % string,
    "extraneous" % string, "extroverted" % string, "fabulous" % string,
    "failing" % string, "faint" % string, "fair" % string, "faithful" % string,
    "fake" % string, "false" % string, "familiar" % string, "famous" % string,
    "fancy" % string, "fantastic" % string, "far" % string, "faraway" % string,
    "fast" % string, "fat" % string, "fatal" % string, "fatherly" % string,
    "favorable" % string, "favorite" % string, "fearful" % string,
    "fearless" % string, "feisty" % string, "feline" % string,
    "female" % string, "feminine" % string, "few" % string, "fickle" % string,
    "filthy" % string, "fine" % string, "finished" % string, "firm" % string,
    "first" % string, "firsthand" % string, "fitting" % string,
    "fixed" % string, "flaky" % string, "flamboyant" % string,
    "flashy" % string, "flat" % string, "flawed" % string, "flawless" % string,
    "flickering" % string, "flimsy" % string, "flippant" % string,
    "flowery" % string, "fluffy" % string, "fluid" % string,
    "flustered" % string, "focused" % string, "fond" % string,
    "foolhardy" % string, "foolish" % string, "forceful" % string,
    "forked" % string, "formal" % string, "forsaken" % string,
    "forthright" % string, "fortunate" % string, "fragrant" % string,
    "frail" % string, "frank" % string, "frayed" % string, "free" % string,
    "french" % string, "fresh" % string, "frequent" % string,
    "friendly" % string, "frightened" % string, "frightening" % string,
    "frigid" % string, "frilly" % string, "frizzy" % string,
    "frivolous" % string, "front" % string, "frosty" % string,
    "frozen" % string, "frugal" % string, "fruitful" % string, "full" % string,
    "fumbling" % string, "functional" % string, "funny" % string,
    "fussy" % string, "fuzzy" % string, "gargantuan" % string,
    "gaseous" % string, "general" % string, "generous" % string,
    "gentle" % string, "genuine" % string, "giant" % string, "giddy" % string,
    "gigantic" % string, "gifted" % string, "giving" % string,
    "glamorous" % string, "glaring" % string, "glass" % string,
    "gleaming" % string, "gleeful" % string, "glistening" % string,
    "glittering" % string, "gloomy" % string, "glorious" % string,
    "glossy" % string, "glum" % string, "golden" % string, "good" % string,
    "gorgeous" % string, "graceful" % string, "gracious" % string,
    "grand" % string, "grandiose" % string, "granular" % string,
    "grateful" % string, "grave" % string, "gray" % string, "great" % string,
    "greedy" % string, "green" % string, "gregarious" % string, "grim" % string,
    "grimy" % string, "gripping" % string, "grizzled" % string,
    "gross" % string, "grotesque" % string, "grouchy" % string,
    "grounded" % string, "growing" % string, "growling" % string,
    "grown" % string, "grubby" % string, "gruesome" % string, "grumpy" % string,
    "guilty" % string, "gullible" % string, "gummy" % string, "hairy" % string,
    "half" % string, "handmade" % string, "handsome" % string, "handy" % string,
    "happy" % string, "hard" % string, "harmful" % string, "harmless" % string,
    "harmonious" % string, "harsh" % string, "hasty" % string,
    "hateful" % string, "haunting" % string, "healthy" % string,
    "heartfelt" % string, "hearty" % string, "heavenly" % string,
    "heavy" % string, "hefty" % string, "helpful" % string, "helpless" % string,
    "hidden" % string, "hideous" % string, "high" % string,
    "hilarious" % string, "hoarse" % string, "hollow" % string,
    "homely" % string, "honest" % string, "honorable" % string,
    "honored" % string, "hopeful" % string, "horrible" % string,
    "hospitable" % string, "hot" % string, "huge" % string, "humble" % string,
    "humiliating" % string, "humming" % string, "humongous" % string,
    "hungry" % string, "hurtful" % string, "husky" % string, "icky" % string,
    "icy" % string, "ideal" % string, "idealistic" % string,
    "identical" % string, "idle" % string, "idiotic" % string,
    "idolized" % string, "ignorant" % string, "ill" % string,
    "illegal" % string, "illiterate" % string, "illustrious" % string,
    "imaginary" % string, "imaginative" % string, "immaculate" % string,
    "immaterial" % string, "immediate" % string, "immense" % string,
    "impassioned" % string, "impeccable" % string, "impartial" % string,
    "imperfect" % string, "imperturbable" % string, "impish" % string,
    "impolite" % string, "important" % string, "impossible" % string,
    "impractical" % string, "impressionable" % string, "impressive" % string,
    "improbable" % string, "impure" % string, "inborn" % string,
    "incomparable" % string, "incompatible" % string, "incomplete" % string,
    "inconsequential" % string, "incredible" % string, "indelible" % string,
    "inexperienced" % string, "indolent" % string, "infamous" % string,
    "infantile" % string, "infatuated" % string, "inferior" % string,
    "infinite" % string, "informal" % string, "innocent" % string,
    "insecure" % string, "insidious" % string, "insignificant" % string,
    "insistent" % string, "instructive" % string, "insubstantial" % string,
    "intelligent" % string, "intent" % string, "intentional" % string,
    "interesting" % string, "internal" % string, "international" % string,
    "intrepid" % string, "ironclad" % string, "irresponsible" % string,
    "irritating" % string, "itchy" % string, "jaded" % string,
    "jagged" % string, "jaunty" % string, "jealous" % string,
    "jittery" % string, "joint" % string, "jolly" % string, "jovial" % string,
    "joyful" % string, "joyous" % string, "jubilant" % string,
    "judicious" % string, "juicy" % string, "jumbo" % string, "junior" % string,
    "jumpy" % string, "juvenile" % string, "kaleidoscopic" % string,
    "keen" % string, "key" % string, "kind" % string, "kindhearted" % string,
    "kindly" % string, "klutzy" % string, "knobby" % string, "knotty" % string,
    "knowledgeable" % string, "knowing" % string, "known" % string,
    "kooky" % string, "lame" % string, "lanky" % string, "large" % string,
    "last" % string, "lasting" % string, "late" % string, "lavish" % string,
    "lawful" % string, "lazy" % string, "leading" % string, "lean" % string,
    "leafy" % string, "left" % string, "legal" % string, "legitimate" % string,
    "light" % string, "lighthearted" % string, "likable" % string,
    "likely" % string, "limited" % string, "limp" % string, "limping" % string,
    "linear" % string, "lined" % string, "liquid" % string, "little" % string,
    "live" % string, "lively" % string, "livid" % string, "loathsome" % string,
    "lone" % string, "lonely" % string, "long" % string, "loose" % string,
    "lopsided" % string, "lost" % string, "loud" % string, "lovable" % string,
    "lovely" % string, "loving" % string, "low" % string, "loyal" % string,
    "lucky" % string, "lumbering" % string, "luminous" % string,
    "lumpy" % string, "lustrous" % string, "luxurious" % string, "mad" % string,
    "magnificent" % string, "majestic" % string, "major" % string,
    "male" % string, "mammoth" % string, "married" % string,
    "marvelous" % string, "masculine" % string, "massive" % string,
    "mature" % string, "meager" % string, "mealy" % string, "mean" % string,
    "measly" % string, "meaty" % string, "medical" % string,
    "mediocre" % string, "medium" % string, "meek" % string, "mellow" % string,
    "melodic" % string, "memorable" % string, "menacing" % string,
    "merry" % string, "messy" % string, "metallic" % string, "mild" % string,
    "milky" % string, "mindless" % string, "miniature" % string,
    "minor" % string, "minty" % string, "miserable" % string,
    "miserly" % string, "misguided" % string, "misty" % string,
    "mixed" % string, "modern" % string, "modest" % string, "moist" % string,
    "monstrous" % string, "monthly" % string, "monumental" % string,
    "moral" % string, "mortified" % string, "motherly" % string,
    "motionless" % string, "mountainous" % string, "muddy" % string,
    "muffled" % string, "multicolored" % string, "mundane" % string,
    "murky" % string, "mushy" % string, "musty" % string, "muted" % string,
    "mysterious" % string, "naive" % string, "narrow" % string,
    "nasty" % string, "natural" % string, "naughty" % string,
    "nautical" % string, "near" % string, "neat" % string, "necessary" % string,
    "needy" % string, "negative" % string, "neglected" % string,
    "negligible" % string, "neighboring" % string, "nervous" % string,
    "new" % string, "nice" % string, "nifty" % string, "nimble" % string,
    "nippy" % string, "nocturnal" % string, "noisy" % string,
    "nonstop" % string, "normal" % string, "notable" % string, "noted" % string,
    "noteworthy" % string, "novel" % string, "noxious" % string,
    "numb" % string, "nutritious" % string, "nutty" % string,
    "obedient" % string, "obese" % string, "oblong" % string, "oily" % string,
    "oblong" % string, "obvious" % string, "occasional" % string,
    "odd" % string, "oddball" % string, "offbeat" % string,
    "offensive" % string, "official" % string, "old" % string, "only" % string,
    "open" % string, "optimal" % string, "optimistic" % string,
    "opulent" % string, "orange" % string, "orderly" % string,
    "organic" % string, "ornate" % string, "ornery" % string,
    "ordinary" % string, "original" % string, "other" % string, "our" % string,
    "outlying" % string, "outgoing" % string, "outlandish" % string,
    "outrageous" % string, "outstanding" % string, "oval" % string,
    "overcooked" % string, "overdue" % string, "overjoyed" % string,
    "overlooked" % string, "palatable" % string, "pale" % string,
    "paltry" % string, "parallel" % string, "parched" % string,
    "partial" % string, "passionate" % string, "past" % string,
    "pastel" % string, "peaceful" % string, "peppery" % string,
    "perfect" % string, "perfumed" % string, "periodic" % string,
    "perky" % string, "personal" % string, "pertinent" % string,
    "pesky" % string, "pessimistic" % string, "petty" % string,
    "phony" % string, "physical" % string, "piercing" % string, "pink" % string,
    "pitiful" % string, "plain" % string, "plaintive" % string,
    "plastic" % string, "playful" % string, "pleasant" % string,
    "pleased" % string, "pleasing" % string, "plump" % string, "plush" % string,
    "polished" % string, "polite" % string, "political" % string,
    "pointed" % string, "pointless" % string, "poised" % string,
    "poor" % string, "popular" % string, "portly" % string, "posh" % string,
    "positive" % string, "possible" % string, "potable" % string,
    "powerful" % string, "powerless" % string, "practical" % string,
    "precious" % string, "present" % string, "prestigious" % string,
    "pretty" % string, "precious" % string, "previous" % string,
    "pricey" % string, "prickly" % string, "primary" % string, "prime" % string,
    "pristine" % string, "private" % string, "prize" % string,
    "probable" % string, "productive" % string, "profitable" % string,
    "profuse" % string, "proper" % string, "proud" % string, "prudent" % string,
    "punctual" % string, "pungent" % string, "puny" % string, "pure" % string,
    "purple" % string, "pushy" % string, "putrid" % string, "puzzled" % string,
    "puzzling" % string, "quaint" % string, "qualified" % string,
    "quarrelsome" % string, "quarterly" % string, "queasy" % string,
    "querulous" % string, "questionable" % string, "quick" % string,
    "quiet" % string, "quintessential" % string, "quirky" % string,
    "quixotic" % string, "quizzical" % string, "radiant" % string,
    "ragged" % string, "rapid" % string, "rare" % string, "rash" % string,
    "raw" % string, "recent" % string, "reckless" % string,
    "rectangular" % string, "ready" % string, "real" % string,
    "realistic" % string, "reasonable" % string, "red" % string,
    "reflecting" % string, "regal" % string, "regular" % string,
    "reliable" % string, "relieved" % string, "remarkable" % string,
    "remorseful" % string, "remote" % string, "repentant" % string,
    "required" % string, "respectful" % string, "responsible" % string,
    "repulsive" % string, "revolving" % string, "rewarding" % string,
    "rich" % string, "rigid" % string, "right" % string, "ringed" % string,
    "ripe" % string, "roasted" % string, "robust" % string, "rosy" % string,
    "rotating" % string, "rotten" % string, "rough" % string, "round" % string,
    "rowdy" % string, "royal" % string, "rubbery" % string, "rundown" % string,
    "ruddy" % string, "rude" % string, "runny" % string, "rural" % string,
    "rusty" % string, "sad" % string, "safe" % string, "salty" % string,
    "same" % string, "sandy" % string, "sane" % string, "sarcastic" % string,
    "sardonic" % string, "satisfied" % string, "scaly" % string,
    "scarce" % string, "scared" % string, "scary" % string, "scented" % string,
    "scholarly" % string, "scientific" % string, "scornful" % string,
    "scratchy" % string, "scrawny" % string, "second" % string,
    "secondary" % string, "secret" % string, "selfish" % string,
    "sentimental" % string, "separate" % string, "serene" % string,
    "serious" % string, "serpentine" % string, "several" % string,
    "severe" % string, "shabby" % string, "shadowy" % string, "shady" % string,
    "shallow" % string, "shameful" % string, "shameless" % string,
    "sharp" % string, "shimmering" % string, "shiny" % string,
    "shocked" % string, "shocking" % string, "shoddy" % string,
    "short" % string, "showy" % string, "shrill" % string, "shy" % string,
    "sick" % string, "silent" % string, "silky" % string, "silly" % string,
    "silver" % string, "similar" % string, "simple" % string,
    "simplistic" % string, "sinful" % string, "single" % string,
    "sizzling" % string, "skeletal" % string, "skinny" % string,
    "sleepy" % string, "slight" % string, "slim" % string, "slimy" % string,
    "slippery" % string, "slow" % string, "slushy" % string, "small" % string,
    "smart" % string, "smoggy" % string, "smooth" % string, "smug" % string,
    "snappy" % string, "snarling" % string, "sneaky" % string,
    "sniveling" % string, "snoopy" % string, "sociable" % string,
    "soft" % string, "soggy" % string, "solid" % string, "somber" % string,
    "some" % string, "spherical" % string, "sophisticated" % string,
    "sore" % string, "sorrowful" % string, "soulful" % string, "soupy" % string,
    "sour" % string, "spanish" % string, "sparkling" % string,
    "sparse" % string, "specific" % string, "spectacular" % string,
    "speedy" % string, "spicy" % string, "spiffy" % string, "spirited" % string,
    "spiteful" % string, "splendid" % string, "spotless" % string,
    "spotted" % string, "spry" % string, "square" % string, "squeaky" % string,
    "squiggly" % string, "stable" % string, "staid" % string,
    "stained" % string, "stale" % string, "standard" % string,
    "starchy" % string, "stark" % string, "starry" % string, "steep" % string,
    "sticky" % string, "stiff" % string, "stimulating" % string,
    "stingy" % string, "stormy" % string, "straight" % string,
    "strange" % string, "steel" % string, "strict" % string,
    "strident" % string, "striking" % string, "striped" % string,
    "strong" % string, "studious" % string, "stunning" % string,
    "stupendous" % string, "stupid" % string, "sturdy" % string,
    "stylish" % string, "subdued" % string, "submissive" % string,
    "substantial" % string, "subtle" % string, "suburban" % string,
    "sudden" % string, "sugary" % string, "sunny" % string, "super" % string,
    "superb" % string, "superficial" % string, "superior" % string,
    "supportive" % string, "surprised" % string, "suspicious" % string,
    "svelte" % string, "sweaty" % string, "sweet" % string,
    "sweltering" % string, "swift" % string, "sympathetic" % string,
    "tall" % string, "talkative" % string, "tame" % string, "tan" % string,
    "tangible" % string, "tart" % string, "tasty" % string, "tattered" % string,
    "taut" % string, "tedious" % string, "teeming" % string,
    "tempting" % string, "tender" % string, "tense" % string, "tepid" % string,
    "terrible" % string, "terrific" % string, "testy" % string,
    "thankful" % string, "that" % string, "these" % string, "thick" % string,
    "thin" % string, "third" % string, "thirsty" % string, "this" % string,
    "thorough" % string, "thorny" % string, "those" % string,
    "thoughtful" % string, "threadbare" % string, "thrifty" % string,
    "thunderous" % string, "tidy" % string, "tight" % string, "timely" % string,
    "tinted" % string, "tiny" % string, "tired" % string, "torn" % string,
    "total" % string, "tough" % string, "traumatic" % string,
    "treasured" % string, "tremendous" % string, "tragic" % string,
    "trained" % string, "tremendous" % string, "triangular" % string,
    "tricky" % string, "trifling" % string, "trim" % string, "trivial" % string,
    "troubled" % string, "true" % string, "trusting" % string,
    "trustworthy" % string, "trusty" % string, "truthful" % string,
    "tubby" % string, "turbulent" % string, "twin" % string, "ugly" % string,
    "ultimate" % string, "unacceptable" % string, "unaware" % string,
    "uncomfortable" % string, "uncommon" % string, "unconscious" % string,
    "understated" % string, "unequaled" % string, "uneven" % string,
    "unfinished" % string, "unfit" % string, "unfolded" % string,
    "unfortunate" % string, "unhappy" % string, "unhealthy" % string,
    "uniform" % string, "unimportant" % string, "unique" % string,
    "united" % string, "unkempt" % string, "unknown" % string,
    "unlawful" % string, "unlined" % string, "unlucky" % string,
    "unnatural" % string, "unpleasant" % string, "unrealistic" % string,
    "unripe" % string, "unruly" % string, "unselfish" % string,
    "unsightly" % string, "unsteady" % string, "unsung" % string,
    "untidy" % string, "untimely" % string, "untried" % string,
    "untrue" % string, "unused" % string, "unusual" % string,
    "unwelcome" % string, "unwieldy" % string, "unwilling" % string,
    "unwitting" % string, "unwritten" % string, "upbeat" % string,
    "upright" % string, "upset" % string, "urban" % string, "usable" % string,
    "used" % string, "useful" % string, "useless" % string, "utilized" % string,
    "utter" % string, "vacant" % string, "vague" % string, "vain" % string,
    "valid" % string, "valuable" % string, "vapid" % string,
    "variable" % string, "vast" % string, "velvety" % string,
    "venerated" % string, "vengeful" % string, "verifiable" % string,
    "vibrant" % string, "vicious" % string, "victorious" % string,
    "vigilant" % string, "vigorous" % string, "villainous" % string,
    "violet" % string, "violent" % string, "virtual" % string,
    "virtuous" % string, "visible" % string, "vital" % string,
    "vivacious" % string, "vivid" % string, "voluminous" % string,
    "warlike" % string, "warm" % string, "warmhearted" % string,
    "warped" % string, "wary" % string, "wasteful" % string,
    "watchful" % string, "waterlogged" % string, "watery" % string,
    "wavy" % string, "wealthy" % string, "weak" % string, "weary" % string,
    "webbed" % string, "wee" % string, "weekly" % string, "weepy" % string,
    "weighty" % string, "weird" % string, "welcome" % string, "wet" % string,
    "which" % string, "whimsical" % string, "whirlwind" % string,
    "whispered" % string, "white" % string, "whole" % string,
    "whopping" % string, "wicked" % string, "wide" % string, "wiggly" % string,
    "wild" % string, "willing" % string, "wilted" % string, "winding" % string,
    "windy" % string, "winged" % string, "wiry" % string, "wise" % string,
    "witty" % string, "wobbly" % string, "woeful" % string,
    "wonderful" % string, "wooden" % string, "woozy" % string, "wordy" % string,
    "worldly" % string, "worn" % string, "worried" % string,
    "worrisome" % string, "worse" % string, "worst" % string,
    "worthless" % string, "worthwhile" % string, "worthy" % string,
    "wrathful" % string, "wretched" % string, "writhing" % string,
    "wrong" % string, "wry" % string, "yawning" % string, "yearly" % string,
    "yellow" % string, "yellowish" % string, "young" % string,
    "youthful" % string, "yummy" % string, "zany" % string, "zealous" % string,
    "zesty" % string).

Definition animals : array string :=
  ("aardvark" % string, "abyssinian" % string, "affenpinscher" % string,
    "akbash" % string, "akita" % string, "albatross" % string,
    "alligator" % string, "angelfish" % string, "ant" % string,
    "anteater" % string, "antelope" % string, "armadillo" % string,
    "avocet" % string, "axolotl" % string, "baboon" % string, "badger" % string,
    "balinese" % string, "bandicoot" % string, "barb" % string,
    "barnacle" % string, "barracuda" % string, "bat" % string,
    "beagle" % string, "bear" % string, "beaver" % string, "beetle" % string,
    "binturong" % string, "birman" % string, "bison" % string,
    "bloodhound" % string, "bobcat" % string, "bombay" % string,
    "bongo" % string, "bonobo" % string, "booby" % string,
    "budgerigar" % string, "buffalo" % string, "bulldog" % string,
    "bullfrog" % string, "burmese" % string, "butterfly" % string,
    "caiman" % string, "camel" % string, "capybara" % string,
    "caracal" % string, "cassowary" % string, "cat" % string,
    "caterpillar" % string, "catfish" % string, "centipede" % string,
    "chameleon" % string, "chamois" % string, "cheetah" % string,
    "chicken" % string, "chihuahua" % string, "chimpanzee" % string,
    "chinchilla" % string, "chinook" % string, "chipmunk" % string,
    "cichlid" % string, "coati" % string, "cockroach" % string,
    "collie" % string, "coral" % string, "cougar" % string, "cow" % string,
    "coyote" % string, "crab" % string, "crane" % string, "crocodile" % string,
    "cuscus" % string, "cuttlefish" % string, "dachshund" % string,
    "dalmatian" % string, "deer" % string, "dhole" % string, "dingo" % string,
    "discus" % string, "dodo" % string, "dog" % string, "dolphin" % string,
    "donkey" % string, "dormouse" % string, "dragonfly" % string,
    "drever" % string, "duck" % string, "dugong" % string, "dunker" % string,
    "eagle" % string, "earwig" % string, "echidna" % string,
    "elephant" % string, "emu" % string, "falcon" % string, "fennec" % string,
    "ferret" % string, "fish" % string, "flamingo" % string,
    "flounder" % string, "fly" % string, "fossa" % string, "fox" % string,
    "frigatebird" % string, "frog" % string, "gar" % string, "gecko" % string,
    "gerbil" % string, "gharial" % string, "gibbon" % string,
    "giraffe" % string, "goat" % string, "goose" % string, "gopher" % string,
    "gorilla" % string, "grasshopper" % string, "greyhound" % string,
    "grouse" % string, "guppy" % string, "hamster" % string, "hare" % string,
    "harrier" % string, "havanese" % string, "hedgehog" % string,
    "heron" % string, "himalayan" % string, "hippopotamus" % string,
    "horse" % string, "human" % string, "hummingbird" % string,
    "hyena" % string, "ibis" % string, "iguana" % string, "impala" % string,
    "indri" % string, "insect" % string, "jackal" % string, "jaguar" % string,
    "javanese" % string, "jellyfish" % string, "kakapo" % string,
    "kangaroo" % string, "kingfisher" % string, "kiwi" % string,
    "koala" % string, "kudu" % string, "labradoodle" % string,
    "ladybird" % string, "lemming" % string, "lemur" % string,
    "leopard" % string, "liger" % string, "lion" % string, "lionfish" % string,
    "lizard" % string, "llama" % string, "lobster" % string, "lynx" % string,
    "macaw" % string, "magpie" % string, "maltese" % string, "manatee" % string,
    "mandrill" % string, "markhor" % string, "mastiff" % string,
    "mayfly" % string, "meerkat" % string, "millipede" % string,
    "mole" % string, "molly" % string, "mongoose" % string, "mongrel" % string,
    "monkey" % string, "moorhen" % string, "moose" % string, "moth" % string,
    "mouse" % string, "mule" % string, "neanderthal" % string,
    "newfoundland" % string, "newt" % string, "nightingale" % string,
    "numbat" % string, "ocelot" % string, "octopus" % string, "okapi" % string,
    "olm" % string, "opossum" % string, "ostrich" % string, "otter" % string,
    "oyster" % string, "pademelon" % string, "panther" % string,
    "parrot" % string, "peacock" % string, "pekingese" % string,
    "pelican" % string, "penguin" % string, "persian" % string,
    "pheasant" % string, "pig" % string, "pika" % string, "pike" % string,
    "piranha" % string, "platypus" % string, "pointer" % string,
    "poodle" % string, "porcupine" % string, "possum" % string,
    "prawn" % string, "puffin" % string, "pug" % string, "puma" % string,
    "quail" % string, "quetzal" % string, "quokka" % string, "quoll" % string,
    "rabbit" % string, "raccoon" % string, "ragdoll" % string, "rat" % string,
    "rattlesnake" % string, "reindeer" % string, "rhinoceros" % string,
    "robin" % string, "rottweiler" % string, "salamander" % string,
    "saola" % string, "scorpion" % string, "seahorse" % string, "seal" % string,
    "serval" % string, "sheep" % string, "shrimp" % string, "siamese" % string,
    "siberian" % string, "skunk" % string, "sloth" % string, "snail" % string,
    "snake" % string, "snowshoe" % string, "somali" % string,
    "sparrow" % string, "sponge" % string, "squid" % string,
    "squirrel" % string, "starfish" % string, "stingray" % string,
    "stoat" % string, "swan" % string, "tang" % string, "tapir" % string,
    "tarsier" % string, "termite" % string, "tetra" % string,
    "tiffany" % string, "tiger" % string, "tortoise" % string,
    "toucan" % string, "tropicbird" % string, "tuatara" % string,
    "turkey" % string, "uakari" % string, "uguisu" % string,
    "umbrellabird" % string, "vulture" % string, "wallaby" % string,
    "walrus" % string, "warthog" % string, "wasp" % string, "weasel" % string,
    "whippet" % string, "wildebeest" % string, "wolf" % string,
    "wolverine" % string, "wombat" % string, "woodlouse" % string,
    "woodpecker" % string, "wrasse" % string, "yak" % string, "zebra" % string,
    "zebu" % string, "zonkey" % string, "zorse" % string).

Definition pick {A : Type} (a : array A) (z : Z.t) : A :=
  Stdlib.Array.get a
    (OCaml.Stdlib.reverse_apply
      (Z.rem z (OCaml.Stdlib.reverse_apply (Stdlib.Array.length a) Z.of_int))
      Z.to_int).

Definition hash (a : string) : string :=
  OCaml.Stdlib.reverse_apply
    (Tezos_base__TzPervasives.Blake2B.hash_string None (cons a []))
    Tezos_base__TzPervasives.Blake2B.to_string.

Record t := {
  c : string;
  t : string;
  h : string;
  d : string }.

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | {| c := c; t := t; h := h; d := d |} =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "-" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "-" % char
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal "-" % char
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format)))))))
        "%s-%s-%s-%s" % string) c t h d
  end.

Definition crouching_tiger (string : string) : t :=
  let c :=
    pick adjectives
      (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
        Z.of_bits) in
  let t :=
    pick animals
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
          hash) Z.of_bits) in
  let h :=
    pick adjectives
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
            hash) hash) Z.of_bits) in
  let d :=
    pick animals
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
              hash) hash) hash) Z.of_bits) in
  {| c := c; t := t; h := h; d := d |}.
src/lib_signer_backends/unix/ledger_names.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {c : string; t : string; h : string; d : string}

val pp : Format.formatter -> t -> unit

(** [crouching_tiger str] is a sentence derived deterministically from
    [str] with the form adjective-animal-adjective-animal.
    E.g. crouching-tiger-hidden-dragon *)
val crouching_tiger : string -> t
src/lib_signer_backends/unix/ledger_names.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  c : string;
  t : string;
  h : string;
  d : string }.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Parameter crouching_tiger : string -> t.
src/lib_signer_backends/unix/remote.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys

let scheme = "remote"

module Make
    (RPC_client : RPC_client.S) (S : sig
      val default : Uri.t

      val authenticate :
        Signature.Public_key_hash.t list ->
        Bytes.t ->
        Signature.t tzresult Lwt.t

      val logger : RPC_client.logger
    end) =
struct
  let scheme = scheme

  let title = "Built-in tezos-signer using remote wallet."

  let description =
    "Valid locators are of the form\n\
    \ - remote://tz1...\n\
     The key will be queried to current remote signer, which can be \
     configured with the `--remote-signer` or `-R` options, or by defining \
     the following environment variables:\n\
    \ - $TEZOS_SIGNER_UNIX_PATH,\n\
    \ - $TEZOS_SIGNER_TCP_HOST and $TEZOS_SIGNER_TCP_PORT (default: 7732),\n\
    \ - $TEZOS_SIGNER_HTTP_HOST and $TEZOS_SIGNER_HTTP_PORT (default: 6732),\n\
    \ - $TEZOS_SIGNER_HTTPS_HOST and $TEZOS_SIGNER_HTTPS_PORT (default: 443)."

  module Socket = Socket.Make (S)
  module Http = Http.Make (RPC_client) (S)
  module Https = Https.Make (RPC_client) (S)

  let get_remote () =
    match Uri.scheme S.default with
    | Some "unix" ->
        (module Socket.Unix : SIGNER)
    | Some "tcp" ->
        (module Socket.Tcp : SIGNER)
    | Some "http" ->
        (module Http : SIGNER)
    | Some "https" ->
        (module Https : SIGNER)
    | _ ->
        assert false

  module Remote = (val get_remote () : SIGNER)

  let key =
    match Uri.scheme S.default with
    | Some "unix" ->
        fun uri ->
          let key = Uri.path uri in
          Uri.add_query_param' S.default ("pkh", key)
    | Some "tcp" ->
        fun uri ->
          let key = Uri.path uri in
          Uri.with_path S.default key
    | Some ("https" | "http") -> (
        fun uri ->
          let key = Uri.path uri in
          match Uri.path S.default with
          | "" ->
              Uri.with_path S.default key
          | path ->
              Uri.with_path S.default (path ^ "/" ^ key) )
    | _ ->
        assert false

  let public_key pk_uri =
    Remote.public_key
      (Client_keys.make_pk_uri (key (pk_uri : pk_uri :> Uri.t)))

  let public_key_hash pk_uri =
    Remote.public_key_hash
      (Client_keys.make_pk_uri (key (pk_uri : pk_uri :> Uri.t)))

  let import_secret_key ~io:_ = public_key_hash

  let neuterize sk_uri =
    return (Client_keys.make_pk_uri (sk_uri : sk_uri :> Uri.t))

  let sign ?watermark sk_uri msg =
    Remote.sign
      ?watermark
      (Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
      msg

  let deterministic_nonce sk_uri msg =
    Remote.deterministic_nonce
      (Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
      msg

  let deterministic_nonce_hash sk_uri msg =
    Remote.deterministic_nonce_hash
      (Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
      msg

  let supports_deterministic_nonces sk_uri =
    Remote.supports_deterministic_nonces
      (Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
end

let make_sk sk =
  Client_keys.make_sk_uri
    (Uri.make ~scheme ~path:(Signature.Secret_key.to_b58check sk) ())

let make_pk pk =
  Client_keys.make_pk_uri
    (Uri.make ~scheme ~path:(Signature.Public_key.to_b58check pk) ())

let read_base_uri_from_env () =
  match
    ( Sys.getenv_opt "TEZOS_SIGNER_UNIX_PATH",
      Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST",
      Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST",
      Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" )
  with
  | (None, None, None, None) ->
      return_none
  | (Some path, None, None, None) ->
      return_some (Socket.make_unix_base path)
  | (None, Some host, None, None) -> (
    try
      let port =
        match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" with
        | None ->
            7732
        | Some port ->
            int_of_string port
      in
      return_some (Socket.make_tcp_base host port)
    with Invalid_argument _ ->
      failwith "Failed to parse TEZOS_SIGNER_TCP_PORT.@." )
  | (None, None, Some host, None) -> (
    try
      let port =
        match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" with
        | None ->
            6732
        | Some port ->
            int_of_string port
      in
      return_some (Http.make_base host port)
    with Invalid_argument _ ->
      failwith "Failed to parse TEZOS_SIGNER_HTTP_PORT.@." )
  | (None, None, None, Some host) -> (
    try
      let port =
        match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" with
        | None ->
            443
        | Some port ->
            int_of_string port
      in
      return_some (Https.make_base host port)
    with Invalid_argument _ ->
      failwith "Failed to parse TEZOS_SIGNER_HTTPS_PORT.@." )
  | (_, _, _, _) ->
      failwith
        "Only one the following environment variable must be defined: \
         TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, \
         TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST@."

type error += Invalid_remote_signer of string

let () =
  register_error_kind
    `Branch
    ~id:"invalid_remote_signer"
    ~title:"Unexpected URI fot remote signer"
    ~description:"The provided remote signer is invalid."
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "@[<v 0>Value '%s' is not a valid URI for a remote signer.@,\
         Supported URIs for remote signers are of the form:@,\
        \ - unix:///path/to/socket/file@,\
        \ - tcp://host:port@,\
        \ - http://host[:port][/prefix]@,\
        \ - https://host[:port][/prefix]@]"
        s)
    Data_encoding.(obj1 (req "uri" string))
    (function Invalid_remote_signer s -> Some s | _ -> None)
    (fun s -> Invalid_remote_signer s)

let parse_base_uri s =
  trace (Invalid_remote_signer s)
  @@
  try
    let uri = Uri.of_string s in
    match Uri.scheme uri with
    | Some "http" ->
        return uri
    | Some "https" ->
        return uri
    | Some "tcp" ->
        return uri
    | Some "unix" ->
        return uri
    | Some scheme ->
        failwith "Unknown scheme: %s" scheme
    | None ->
        failwith "Unknown scheme: <empty>"
  with Invalid_argument msg -> failwith "Malformed URI: %s" msg
src/lib_signer_backends/unix/remote.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base.Client_keys.

Definition scheme : string := "remote" % string.

Definition make_sk (sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
  : Tezos_client_base.Client_keys.sk_uri :=
  Tezos_client_base.Client_keys.make_sk_uri
    (Uri.make (Some scheme) None None None
      (Some (Tezos_base__TzPervasives.Signature.Secret_key.to_b58check sk)) None
      None tt).

Definition make_pk (pk : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Tezos_client_base.Client_keys.pk_uri :=
  Tezos_client_base.Client_keys.make_pk_uri
    (Uri.make (Some scheme) None None None
      (Some (Tezos_base__TzPervasives.Signature.Public_key.to_b58check pk)) None
      None tt).

Definition read_base_uri_from_env (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (option Uri.t)) :=
  match function_parameter with
  | tt =>
    match
      ((Stdlib.Sys.getenv_opt "TEZOS_SIGNER_UNIX_PATH" % string),
        (Stdlib.Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" % string),
        (Stdlib.Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" % string),
        (Stdlib.Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" % string)) with
    | (None, None, None, None) => Tezos_base__TzPervasives.return_none
    | (Some path, None, None, None) =>
      Tezos_base__TzPervasives.return_some
        (Tezos_signer_backends_unix.Socket.make_unix_base path)
    | (None, Some host, None, None) => try
    | (None, None, Some host, None) => try
    | (None, None, None, Some host) => try
    | (_, _, _, _) =>
      Tezos_base__TzPervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Only one the following environment variable must be defined: TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST"
              % string
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Flush_newline
              CamlinternalFormatBasics.End_of_format))
          "Only one the following environment variable must be defined: TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST@."
            % string)
    end
  end.

Definition parse_base_uri (s : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Uri.t) :=
  apply (Tezos_base__TzPervasives.trace (Invalid_remote_signer s)) try.
src/lib_signer_backends/unix/remote.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make
    (RPC_client : RPC_client.S) (S : sig
      val default : Uri.t

      val authenticate :
        Signature.Public_key_hash.t list ->
        Bytes.t ->
        Signature.t tzresult Lwt.t

      val logger : RPC_client.logger
    end) : Client_keys.SIGNER

val make_pk : Signature.public_key -> Client_keys.pk_uri

val make_sk : Signature.secret_key -> Client_keys.sk_uri

val read_base_uri_from_env : unit -> Uri.t option tzresult Lwt.t

val parse_base_uri : string -> Uri.t tzresult Lwt.t
src/lib_signer_backends/unix/remote.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

Parameter make_pk :
Tezos_base__TzPervasives.Signature.public_key ->
  Tezos_client_base.Client_keys.pk_uri.

Parameter make_sk :
Tezos_base__TzPervasives.Signature.secret_key ->
  Tezos_client_base.Client_keys.sk_uri.

Parameter read_base_uri_from_env :
unit -> Lwt.t (Tezos_base__TzPervasives.tzresult (option Uri.t)).

Parameter parse_base_uri :
string -> Lwt.t (Tezos_base__TzPervasives.tzresult Uri.t).
src/lib_signer_backends/unix/socket.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys
open Signer_messages

let tcp_scheme = "tcp"

let unix_scheme = "unix"

module Make (P : sig
  val authenticate :
    Signature.Public_key_hash.t list -> Bytes.t -> Signature.t tzresult Lwt.t
end) =
struct
  type request_type =
    | Sign_request
    | Deterministic_nonce_request
    | Deterministic_nonce_hash_request

  let build_request pkh data signature = function
    | Sign_request ->
        Request.Sign {Sign.Request.pkh; data; signature}
    | Deterministic_nonce_request ->
        Request.Deterministic_nonce
          {Deterministic_nonce.Request.pkh; data; signature}
    | Deterministic_nonce_hash_request ->
        Request.Deterministic_nonce_hash
          {Deterministic_nonce_hash.Request.pkh; data; signature}

  let signer_operation path pkh msg request_type =
    Lwt_utils_unix.Socket.connect path
    >>=? (fun conn ->
           Lwt_utils_unix.Socket.send
             conn
             Request.encoding
             Request.Authorized_keys
           >>=? fun () ->
           Lwt_utils_unix.Socket.recv
             conn
             (result_encoding Authorized_keys.Response.encoding)
           >>=? fun authorized_keys ->
           Lwt.return authorized_keys
           >>=? fun authorized_keys ->
           Lwt_unix.close conn
           >>= fun () ->
           match authorized_keys with
           | No_authentication ->
               return_none
           | Authorized_keys authorized_keys ->
               P.authenticate
                 authorized_keys
                 (Sign.Request.to_sign ~pkh ~data:msg)
               >>=? fun signature -> return_some signature)
    >>=? fun signature ->
    Lwt_utils_unix.Socket.connect path
    >>=? fun conn ->
    let req = build_request pkh msg signature request_type in
    Lwt_utils_unix.Socket.send conn Request.encoding req
    >>=? fun () -> return conn

  let sign ?watermark path pkh msg =
    let msg =
      match watermark with
      | None ->
          msg
      | Some watermark ->
          Bytes.cat (Signature.bytes_of_watermark watermark) msg
    in
    signer_operation path pkh msg Sign_request
    >>=? fun conn ->
    Lwt_utils_unix.Socket.recv conn (result_encoding Sign.Response.encoding)
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  let deterministic_nonce path pkh msg =
    signer_operation path pkh msg Deterministic_nonce_request
    >>=? fun conn ->
    Lwt_utils_unix.Socket.recv
      conn
      (result_encoding Deterministic_nonce.Response.encoding)
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  let deterministic_nonce_hash path pkh msg =
    signer_operation path pkh msg Deterministic_nonce_hash_request
    >>=? fun conn ->
    Lwt_utils_unix.Socket.recv
      conn
      (result_encoding Deterministic_nonce_hash.Response.encoding)
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  let supports_deterministic_nonces path pkh =
    Lwt_utils_unix.Socket.connect path
    >>=? fun conn ->
    Lwt_utils_unix.Socket.send
      conn
      Request.encoding
      (Request.Supports_deterministic_nonces pkh)
    >>=? fun () ->
    Lwt_utils_unix.Socket.recv
      conn
      (result_encoding Supports_deterministic_nonces.Response.encoding)
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  let public_key path pkh =
    Lwt_utils_unix.Socket.connect path
    >>=? fun conn ->
    Lwt_utils_unix.Socket.send conn Request.encoding (Request.Public_key pkh)
    >>=? fun () ->
    let encoding = result_encoding Public_key.Response.encoding in
    Lwt_utils_unix.Socket.recv conn encoding
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  module Unix = struct
    let scheme = unix_scheme

    let title =
      "Built-in tezos-signer using remote signer through hardcoded unix socket."

    let description =
      "Valid locators are of the form\n - unix:/path/to/socket?pkh=tz1..."

    let parse uri =
      assert (Uri.scheme uri = Some scheme) ;
      trace (Invalid_uri uri)
      @@
      match Uri.get_query_param uri "pkh" with
      | None ->
          failwith "Missing the query parameter: 'pkh=tz1...'"
      | Some key ->
          Lwt.return (Signature.Public_key_hash.of_b58check key)
          >>=? fun key ->
          return (Lwt_utils_unix.Socket.Unix (Uri.path uri), key)

    let public_key uri =
      parse (uri : pk_uri :> Uri.t) >>=? fun (path, pkh) -> public_key path pkh

    let neuterize uri =
      return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))

    let public_key_hash uri =
      public_key uri
      >>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)

    let import_secret_key ~io:_ = public_key_hash

    let sign ?watermark uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> sign ?watermark path pkh msg

    let deterministic_nonce uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> deterministic_nonce path pkh msg

    let deterministic_nonce_hash uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> deterministic_nonce_hash path pkh msg

    let supports_deterministic_nonces uri =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> supports_deterministic_nonces path pkh
  end

  module Tcp = struct
    let scheme = tcp_scheme

    let title =
      "Built-in tezos-signer using remote signer through hardcoded tcp socket."

    let description =
      "Valid locators are of the form\n - tcp://host:port/tz1..."

    let parse uri =
      assert (Uri.scheme uri = Some scheme) ;
      trace (Invalid_uri uri)
      @@
      match (Uri.host uri, Uri.port uri) with
      | (None, _) ->
          failwith "Missing host address"
      | (_, None) ->
          failwith "Missing host port"
      | (Some path, Some port) ->
          let pkh = Uri.path uri in
          let pkh = try String.(sub pkh 1 (length pkh - 1)) with _ -> "" in
          Lwt.return (Signature.Public_key_hash.of_b58check pkh)
          >>=? fun pkh ->
          return
            ( Lwt_utils_unix.Socket.Tcp
                (path, string_of_int port, [Lwt_unix.AI_SOCKTYPE SOCK_STREAM]),
              pkh )

    let public_key uri =
      parse (uri : pk_uri :> Uri.t) >>=? fun (path, pkh) -> public_key path pkh

    let neuterize uri =
      return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))

    let public_key_hash uri =
      public_key uri
      >>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)

    let import_secret_key ~io:_ = public_key_hash

    let sign ?watermark uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> sign ?watermark path pkh msg

    let deterministic_nonce uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> deterministic_nonce path pkh msg

    let deterministic_nonce_hash uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> deterministic_nonce_hash path pkh msg

    let supports_deterministic_nonces uri =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> supports_deterministic_nonces path pkh
  end
end

let make_unix_base path = Uri.make ~scheme:unix_scheme ~path ()

let make_tcp_base host port = Uri.make ~scheme:tcp_scheme ~host ~port ()
src/lib_signer_backends/unix/socket.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_base.Client_keys.

Import Tezos_signer_services.Signer_messages.

Definition tcp_scheme : string := "tcp" % string.

Definition unix_scheme : string := "unix" % string.

Definition make_unix_base (path : string) : Uri.t :=
  Uri.make (Some unix_scheme) None None None (Some path) None None tt.

Definition make_tcp_base (host : string) (port : Z) : Uri.t :=
  Uri.make (Some tcp_scheme) None (Some host) (Some port) None None None tt.
src/lib_signer_backends/unix/socket.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make (P : sig
  val authenticate :
    Signature.Public_key_hash.t list -> Bytes.t -> Signature.t tzresult Lwt.t
end) : sig
  module Unix : Client_keys.SIGNER

  module Tcp : Client_keys.SIGNER
end

val make_unix_base : string -> Uri.t

val make_tcp_base : string -> int -> Uri.t
src/lib_signer_backends/unix/socket.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

Parameter make_unix_base : string -> Uri.t.

Parameter make_tcp_base : string -> Z -> Uri.t.
src/lib_signer_backends/unix/test/test_crouching.ml 
let test_example () =
  let name = Ledger_names.crouching_tiger "12345" in
  assert (
    name = {c = "calculating"; t = "meerkat"; h = "straight"; d = "beetle"} )

let tests = [Alcotest.test_case "print_example" `Quick test_example]

let () = Alcotest.run "tezos-signed-backends" [("ledger-names", tests)]
src/lib_signer_backends/unix/test/test_crouching.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_example (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    let name :=
      Tezos_signer_backends_unix.Ledger_names.crouching_tiger "12345" % string
      in
    equiv_decb name
      {| c := "calculating" % string; t := "meerkat" % string;
        h := "straight" % string; d := "beetle" % string |}
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "print_example" % string variant
      test_example) [].
src/lib_signer_services/signer_messages.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type Authenticated_request = sig
  type t = {
    pkh : Signature.Public_key_hash.t;
    data : Bytes.t;
    signature : Signature.t option;
  }

  val to_sign : pkh:Signature.Public_key_hash.t -> data:Bytes.t -> Bytes.t

  val encoding : t Data_encoding.t
end

module type Tag = sig
  val tag : int
end

module Make_authenticated_request (T : Tag) : Authenticated_request = struct
  type t = {
    pkh : Signature.Public_key_hash.t;
    data : Bytes.t;
    signature : Signature.t option;
  }

  let to_sign ~pkh ~data =
    let tag = Bytes.make 1 '0' in
    TzEndian.set_int8 tag 0 T.tag ;
    Bytes.concat
      (Bytes.of_string "")
      [ Bytes.of_string "\x04";
        tag;
        Signature.Public_key_hash.to_bytes pkh;
        data ]

  let encoding =
    let open Data_encoding in
    conv
      (fun {pkh; data; signature} -> (pkh, data, signature))
      (fun (pkh, data, signature) -> {pkh; data; signature})
      (obj3
         (req "pkh" Signature.Public_key_hash.encoding)
         (req "data" bytes)
         (opt "signature" Signature.encoding))
end

module Sign = struct
  module Request = Make_authenticated_request (struct
    let tag = 1
  end)

  module Response = struct
    type t = Signature.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.sign.response"
      @@ obj1 (req "signature" Signature.encoding)
  end
end

module Deterministic_nonce = struct
  module Request = Make_authenticated_request (struct
    let tag = 2
  end)

  module Response = struct
    type t = Bigstring.t

    let bigstring =
      let open Data_encoding in
      conv Bigstring.to_bytes Bigstring.of_bytes bytes

    let encoding =
      let open Data_encoding in
      def "signer_messages.deterministic_nonce.response"
      @@ obj1 (req "deterministic_nonce" bigstring)
  end
end

module Deterministic_nonce_hash = struct
  module Request = Make_authenticated_request (struct
    let tag = 3
  end)

  module Response = struct
    type t = Bytes.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.deterministic_nonce_hash.response"
      @@ obj1 (req "deterministic_nonce_hash" bytes)
  end
end

module Supports_deterministic_nonces = struct
  module Request = struct
    type t = Signature.Public_key_hash.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.supports_deterministic_nonces.request"
      @@ obj1 (req "pkh" Signature.Public_key_hash.encoding)
  end

  module Response = struct
    type t = bool

    let encoding =
      let open Data_encoding in
      def "signer_messages.supports_deterministic_nonces.response"
      @@ obj1 (req "bool" bool)
  end
end

module Public_key = struct
  module Request = struct
    type t = Signature.Public_key_hash.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.public_key.request"
      @@ obj1 (req "pkh" Signature.Public_key_hash.encoding)
  end

  module Response = struct
    type t = Signature.Public_key.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.public_key.response"
      @@ obj1 (req "pubkey" Signature.Public_key.encoding)
  end
end

module Authorized_keys = struct
  module Response = struct
    type t =
      | No_authentication
      | Authorized_keys of Signature.Public_key_hash.t list

    let encoding =
      let open Data_encoding in
      union
        [ case
            (Tag 0)
            ~title:"No_authentication"
            (constant "no_authentication_required")
            (function No_authentication -> Some () | _ -> None)
            (fun () -> No_authentication);
          case
            (Tag 1)
            ~title:"Authorized_keys"
            (list Signature.Public_key_hash.encoding)
            (function Authorized_keys l -> Some l | _ -> None)
            (fun l -> Authorized_keys l) ]
  end
end

module Request = struct
  type t =
    | Sign of Sign.Request.t
    | Public_key of Public_key.Request.t
    | Authorized_keys
    | Deterministic_nonce of Deterministic_nonce.Request.t
    | Deterministic_nonce_hash of Deterministic_nonce_hash.Request.t
    | Supports_deterministic_nonces of Supports_deterministic_nonces.Request.t

  let encoding =
    let open Data_encoding in
    def "signer_messages.request"
    @@ union
         [ case
             (Tag 0)
             ~title:"Sign"
             (merge_objs
                (obj1 (req "kind" (constant "sign")))
                Sign.Request.encoding)
             (function Sign req -> Some ((), req) | _ -> None)
             (fun ((), req) -> Sign req);
           case
             (Tag 1)
             ~title:"Public_key"
             (merge_objs
                (obj1 (req "kind" (constant "public_key")))
                Public_key.Request.encoding)
             (function Public_key req -> Some ((), req) | _ -> None)
             (fun ((), req) -> Public_key req);
           case
             (Tag 2)
             ~title:"Authorized_keys"
             (obj1 (req "kind" (constant "authorized_keys")))
             (function Authorized_keys -> Some () | _ -> None)
             (fun () -> Authorized_keys);
           case
             (Tag 3)
             ~title:"Deterministic_nonce"
             (merge_objs
                (obj1 (req "kind" (constant "deterministic_nonce")))
                Deterministic_nonce.Request.encoding)
             (function Deterministic_nonce req -> Some ((), req) | _ -> None)
             (fun ((), req) -> Deterministic_nonce req);
           case
             (Tag 4)
             ~title:"Deterministic_nonce_hash"
             (merge_objs
                (obj1 (req "kind" (constant "deterministic_nonce_hash")))
                Deterministic_nonce_hash.Request.encoding)
             (function
               | Deterministic_nonce_hash req -> Some ((), req) | _ -> None)
             (fun ((), req) -> Deterministic_nonce_hash req);
           case
             (Tag 5)
             ~title:"Supports_deterministic_nonces"
             (merge_objs
                (obj1 (req "kind" (constant "supports_deterministic_nonces")))
                Supports_deterministic_nonces.Request.encoding)
             (function
               | Supports_deterministic_nonces req ->
                   Some ((), req)
               | _ ->
                   None)
             (fun ((), req) -> Supports_deterministic_nonces req) ]
end

let () =
  let open Tezos_data_encoding in
  Data_encoding.Registration.register Request.encoding ;
  Data_encoding.Registration.register Sign.Response.encoding ;
  Data_encoding.Registration.register Deterministic_nonce.Response.encoding ;
  Data_encoding.Registration.register
    Deterministic_nonce_hash.Response.encoding ;
  Data_encoding.Registration.register
    Supports_deterministic_nonces.Response.encoding ;
  Data_encoding.Registration.register Public_key.Response.encoding
src/lib_signer_services/signer_messages.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Authenticated_request.
  Record signature {t : Type} := {
    t := t;
    to_sign : Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
      Stdlib.Bytes.t -> Stdlib.Bytes.t;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End Authenticated_request.

Module Tag.
  Record signature := {
    tag : Z;
  }.
End Tag.

Module Sign.
  Module Response.
    Definition t := Tezos_base__TzPervasives.Signature.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding
        Tezos_base__TzPervasives.Signature.t :=
      apply
        (let arg :=
          Tezos_base__TzPervasives.Data_encoding.def
            "signer_messages.sign.response" % string in
        fun eta => arg None None eta)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "signature" % string Tezos_base__TzPervasives.Signature.encoding)).
  End Response.
End Sign.

Module Deterministic_nonce.
  Module Response.
    Definition t := Bigstring.t.
    
    Definition bigstring
      : Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
      Tezos_base__TzPervasives.Data_encoding.conv Bigstring.to_bytes
        Bigstring.of_bytes None Tezos_base__TzPervasives.Data_encoding.bytes.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
      apply
        (let arg :=
          Tezos_base__TzPervasives.Data_encoding.def
            "signer_messages.deterministic_nonce.response" % string in
        fun eta => arg None None eta)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "deterministic_nonce" % string bigstring)).
  End Response.
End Deterministic_nonce.

Module Deterministic_nonce_hash.
  Module Response.
    Definition t := Stdlib.Bytes.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
      apply
        (let arg :=
          Tezos_base__TzPervasives.Data_encoding.def
            "signer_messages.deterministic_nonce_hash.response" % string in
        fun eta => arg None None eta)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "deterministic_nonce_hash" % string
            Tezos_base__TzPervasives.Data_encoding.bytes)).
  End Response.
End Deterministic_nonce_hash.

Module Supports_deterministic_nonces.
  Module Request.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key_hash.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding
        Tezos_base__TzPervasives.Signature.Public_key_hash.t :=
      apply
        (let arg :=
          Tezos_base__TzPervasives.Data_encoding.def
            "signer_messages.supports_deterministic_nonces.request" % string in
        fun eta => arg None None eta)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None "pkh" % string
            Tezos_base__TzPervasives.Signature.Public_key_hash.encoding)).
  End Request.
  
  Module Response.
    Definition t := bool.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding bool :=
      apply
        (let arg :=
          Tezos_base__TzPervasives.Data_encoding.def
            "signer_messages.supports_deterministic_nonces.response" % string in
        fun eta => arg None None eta)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None "bool" % string
            Tezos_base__TzPervasives.Data_encoding.bool)).
  End Response.
End Supports_deterministic_nonces.

Module Public_key.
  Module Request.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key_hash.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding
        Tezos_base__TzPervasives.Signature.Public_key_hash.t :=
      apply
        (let arg :=
          Tezos_base__TzPervasives.Data_encoding.def
            "signer_messages.public_key.request" % string in
        fun eta => arg None None eta)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None "pkh" % string
            Tezos_base__TzPervasives.Signature.Public_key_hash.encoding)).
  End Request.
  
  Module Response.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding
        Tezos_base__TzPervasives.Signature.Public_key.t :=
      apply
        (let arg :=
          Tezos_base__TzPervasives.Data_encoding.def
            "signer_messages.public_key.response" % string in
        fun eta => arg None None eta)
        (Tezos_base__TzPervasives.Data_encoding.obj1
          (Tezos_base__TzPervasives.Data_encoding.req None None
            "pubkey" % string
            Tezos_base__TzPervasives.Signature.Public_key.encoding)).
  End Response.
End Public_key.

Module Authorized_keys.
  Module Response.
    Inductive t : Type :=
    | No_authentication : t
    | Authorized_keys :
      (list Tezos_base__TzPervasives.Signature.Public_key_hash.t) -> t.
    
    Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
      Tezos_base__TzPervasives.Data_encoding.union None
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case
            "No_authentication" % string None (Tag 0)
            (Tezos_base__TzPervasives.Data_encoding.constant
              "no_authentication_required" % string)
            (fun function_parameter =>
              match function_parameter with
              | No_authentication => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => No_authentication
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case
              "Authorized_keys" % string None (Tag 1)
              (Tezos_base__TzPervasives.Data_encoding.list None
                Tezos_base__TzPervasives.Signature.Public_key_hash.encoding)
              (fun function_parameter =>
                match function_parameter with
                | Authorized_keys l => Some l
                | _ => None
                end) (fun l => Authorized_keys l)) [])).
  End Response.
End Authorized_keys.

Module Request.
  Inductive t : Type :=
  | Sign : Sign.Request.(Authenticated_request.t) -> t
  | Public_key : Public_key.Request.t -> t
  | Authorized_keys : t
  | Deterministic_nonce : Deterministic_nonce.Request.(Authenticated_request.t)
    -> t
  | Deterministic_nonce_hash :
    Deterministic_nonce_hash.Request.(Authenticated_request.t) -> t
  | Supports_deterministic_nonces : Supports_deterministic_nonces.Request.t -> t.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    apply
      (let arg :=
        Tezos_base__TzPervasives.Data_encoding.def
          "signer_messages.request" % string in
      fun eta => arg None None eta)
      (Tezos_base__TzPervasives.Data_encoding.union None
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Sign" % string None
            (Tag 0)
            (Tezos_base__TzPervasives.Data_encoding.merge_objs
              (Tezos_base__TzPervasives.Data_encoding.obj1
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "kind" % string
                  (Tezos_base__TzPervasives.Data_encoding.constant
                    "sign" % string)))
              Sign.Request.(Authenticated_request.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Sign req => Some (tt, req)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tt, req) => Sign req
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case "Public_key" % string
              None (Tag 1)
              (Tezos_base__TzPervasives.Data_encoding.merge_objs
                (Tezos_base__TzPervasives.Data_encoding.obj1
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "kind" % string
                    (Tezos_base__TzPervasives.Data_encoding.constant
                      "public_key" % string))) Public_key.Request.encoding)
              (fun function_parameter =>
                match function_parameter with
                | Public_key req => Some (tt, req)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (tt, req) => Public_key req
                end))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case
                "Authorized_keys" % string None (Tag 2)
                (Tezos_base__TzPervasives.Data_encoding.obj1
                  (Tezos_base__TzPervasives.Data_encoding.req None None
                    "kind" % string
                    (Tezos_base__TzPervasives.Data_encoding.constant
                      "authorized_keys" % string)))
                (fun function_parameter =>
                  match function_parameter with
                  | Authorized_keys => Some tt
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Authorized_keys
                  end))
              (cons
                (Tezos_base__TzPervasives.Data_encoding.case
                  "Deterministic_nonce" % string None (Tag 3)
                  (Tezos_base__TzPervasives.Data_encoding.merge_objs
                    (Tezos_base__TzPervasives.Data_encoding.obj1
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "kind" % string
                        (Tezos_base__TzPervasives.Data_encoding.constant
                          "deterministic_nonce" % string)))
                    Deterministic_nonce.Request.(Authenticated_request.encoding))
                  (fun function_parameter =>
                    match function_parameter with
                    | Deterministic_nonce req => Some (tt, req)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | (tt, req) => Deterministic_nonce req
                    end))
                (cons
                  (Tezos_base__TzPervasives.Data_encoding.case
                    "Deterministic_nonce_hash" % string None (Tag 4)
                    (Tezos_base__TzPervasives.Data_encoding.merge_objs
                      (Tezos_base__TzPervasives.Data_encoding.obj1
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "kind" % string
                          (Tezos_base__TzPervasives.Data_encoding.constant
                            "deterministic_nonce_hash" % string)))
                      Deterministic_nonce_hash.Request.(Authenticated_request.encoding))
                    (fun function_parameter =>
                      match function_parameter with
                      | Deterministic_nonce_hash req => Some (tt, req)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | (tt, req) => Deterministic_nonce_hash req
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Data_encoding.case
                      "Supports_deterministic_nonces" % string None (Tag 5)
                      (Tezos_base__TzPervasives.Data_encoding.merge_objs
                        (Tezos_base__TzPervasives.Data_encoding.obj1
                          (Tezos_base__TzPervasives.Data_encoding.req None None
                            "kind" % string
                            (Tezos_base__TzPervasives.Data_encoding.constant
                              "supports_deterministic_nonces" % string)))
                        Supports_deterministic_nonces.Request.encoding)
                      (fun function_parameter =>
                        match function_parameter with
                        | Supports_deterministic_nonces req => Some (tt, req)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | (tt, req) => Supports_deterministic_nonces req
                        end)) []))))))).
End Request.
src/lib_signer_services/signer_messages.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type Authenticated_request = sig
  type t = {
    pkh : Signature.Public_key_hash.t;
    data : Bytes.t;
    signature : Signature.t option;
  }

  val to_sign : pkh:Signature.Public_key_hash.t -> data:Bytes.t -> Bytes.t

  val encoding : t Data_encoding.t
end

module Sign : sig
  module Request : Authenticated_request

  module Response : sig
    type t = Signature.t

    val encoding : t Data_encoding.t
  end
end

module Deterministic_nonce : sig
  module Request : Authenticated_request

  module Response : sig
    type t = Bigstring.t

    val encoding : t Data_encoding.t
  end
end

module Deterministic_nonce_hash : sig
  module Request : Authenticated_request

  module Response : sig
    type t = Bytes.t

    val encoding : t Data_encoding.t
  end
end

module Supports_deterministic_nonces : sig
  module Request : sig
    type t = Signature.Public_key_hash.t

    val encoding : t Data_encoding.t
  end

  module Response : sig
    type t = bool

    val encoding : t Data_encoding.t
  end
end

module Public_key : sig
  module Request : sig
    type t = Signature.Public_key_hash.t

    val encoding : t Data_encoding.t
  end

  module Response : sig
    type t = Signature.Public_key.t

    val encoding : t Data_encoding.t
  end
end

module Authorized_keys : sig
  module Response : sig
    type t =
      | No_authentication
      | Authorized_keys of Signature.Public_key_hash.t list

    val encoding : t Data_encoding.t
  end
end

module Request : sig
  type t =
    | Sign of Sign.Request.t
    | Public_key of Public_key.Request.t
    | Authorized_keys
    | Deterministic_nonce of Deterministic_nonce.Request.t
    | Deterministic_nonce_hash of Deterministic_nonce_hash.Request.t
    | Supports_deterministic_nonces of Supports_deterministic_nonces.Request.t

  val encoding : t Data_encoding.t
end
src/lib_signer_services/signer_messages.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

Module Sign.
  unhandled_module
  
  Module Response.
    Definition t := Tezos_base__TzPervasives.Signature.t.
    
    Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  End Response.
End Sign.

Module Deterministic_nonce.
  unhandled_module
  
  Module Response.
    Definition t := Bigstring.t.
    
    Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  End Response.
End Deterministic_nonce.

Module Deterministic_nonce_hash.
  unhandled_module
  
  Module Response.
    Definition t := Stdlib.Bytes.t.
    
    Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  End Response.
End Deterministic_nonce_hash.

Module Supports_deterministic_nonces.
  Module Request.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key_hash.t.
    
    Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  End Request.
  
  Module Response.
    Definition t := bool.
    
    Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  End Response.
End Supports_deterministic_nonces.

Module Public_key.
  Module Request.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key_hash.t.
    
    Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  End Request.
  
  Module Response.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key.t.
    
    Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  End Response.
End Public_key.

Module Authorized_keys.
  Module Response.
    Inductive t : Type :=
    | No_authentication : t
    | Authorized_keys :
      (list Tezos_base__TzPervasives.Signature.Public_key_hash.t) -> t.
    
    Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  End Response.
End Authorized_keys.

Module Request.
  Inductive t : Type :=
  | Sign : Sign.Request.(Authenticated_request.t) -> t
  | Public_key : Public_key.Request.t -> t
  | Authorized_keys : t
  | Deterministic_nonce : Deterministic_nonce.Request.(Authenticated_request.t)
    -> t
  | Deterministic_nonce_hash :
    Deterministic_nonce_hash.Request.(Authenticated_request.t) -> t
  | Supports_deterministic_nonces : Supports_deterministic_nonces.Request.t -> t.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
End Request.
src/lib_signer_services/signer_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let query =
  let open RPC_query in
  query (fun signature -> signature)
  |+ opt_field
       ~descr:
         "Must be provided if the signer requires authentication. In this \
          case, it must be the signature of the public key hash and message \
          concatenated, by one of the keys authorized by the signer."
       "authentication"
       Signature.rpc_arg
       (fun signature -> signature)
  |> seal

let sign =
  RPC_service.post_service
    ~description:"Sign a piece of data with a given remote key"
    ~query
    ~input:Data_encoding.bytes
    ~output:Data_encoding.(obj1 (req "signature" Signature.encoding))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let bigstring =
  let open Data_encoding in
  conv Bigstring.to_bytes Bigstring.of_bytes bytes

let deterministic_nonce =
  RPC_service.post_service
    ~description:
      "Obtain some random data generated deterministically from some piece of \
       data with a given remote key"
    ~query
    ~input:Data_encoding.bytes
    ~output:Data_encoding.(obj1 (req "deterministic_nonce" bigstring))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let deterministic_nonce_hash =
  RPC_service.post_service
    ~description:
      "Obtain the hash of some random data generated deterministically from \
       some piece of data with a given remote key"
    ~query
    ~input:Data_encoding.bytes
    ~output:Data_encoding.(obj1 (req "deterministic_nonce_hash" bytes))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let supports_deterministic_nonces =
  RPC_service.get_service
    ~description:
      "Obtain whether the signing service suppports the determinstic nonces \
       functionality"
    ~query:RPC_query.empty
    ~output:Data_encoding.(obj1 (req "supports_deterministic_nonces" bool))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let public_key =
  RPC_service.get_service
    ~description:"Retrieve the public key of a given remote key"
    ~query:RPC_query.empty
    ~output:
      Data_encoding.(obj1 (req "public_key" Signature.Public_key.encoding))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let authorized_keys =
  RPC_service.get_service
    ~description:
      "Retrieve the public keys that can be used to authenticate signing \
       commands.\n\
       If the empty object is returned, the signer has been set to accept \
       unsigned commands."
    ~query:RPC_query.empty
    ~output:
      Data_encoding.(
        obj1 (opt "authorized_keys" (list Signature.Public_key_hash.encoding)))
    RPC_path.(root / "authorized_keys")
src/lib_signer_services/signer_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition query
  : Tezos_rpc.RPC_query.t (option Tezos_base__TzPervasives.Signature.t) :=
  OCaml.Stdlib.reverse_apply
    (Tezos_rpc.RPC_query.op_pipe_plus
      (Tezos_rpc.RPC_query.query (fun signature => signature))
      (Tezos_rpc.RPC_query.opt_field
        (Some
          "Must be provided if the signer requires authentication. In this case, it must be the signature of the public key hash and message concatenated, by one of the keys authorized by the signer."
            % string) "authentication" % string
        Tezos_base__TzPervasives.Signature.rpc_arg (fun signature => signature)))
    Tezos_rpc.RPC_query.seal.

Definition sign
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t
    Tezos_base__TzPervasives.Signature.t :=
  Tezos_rpc.RPC_service.post_service
    (Some "Sign a piece of data with a given remote key" % string) query
    Tezos_base__TzPervasives.Data_encoding.bytes
    (Tezos_base__TzPervasives.Data_encoding.obj1
      (Tezos_base__TzPervasives.Data_encoding.req None None "signature" % string
        Tezos_base__TzPervasives.Signature.encoding))
    (Tezos_rpc.RPC_path.op_div_colon
      (Tezos_rpc.RPC_path.op_div Tezos_rpc.RPC_path.root "keys" % string)
      Tezos_base__TzPervasives.Signature.Public_key_hash.rpc_arg).

Definition bigstring
  : Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
  Tezos_base__TzPervasives.Data_encoding.conv Bigstring.to_bytes
    Bigstring.of_bytes None Tezos_base__TzPervasives.Data_encoding.bytes.

Definition deterministic_nonce
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t Bigstring.t :=
  Tezos_rpc.RPC_service.post_service
    (Some
      "Obtain some random data generated deterministically from some piece of data with a given remote key"
        % string) query Tezos_base__TzPervasives.Data_encoding.bytes
    (Tezos_base__TzPervasives.Data_encoding.obj1
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "deterministic_nonce" % string bigstring))
    (Tezos_rpc.RPC_path.op_div_colon
      (Tezos_rpc.RPC_path.op_div Tezos_rpc.RPC_path.root "keys" % string)
      Tezos_base__TzPervasives.Signature.Public_key_hash.rpc_arg).

Definition deterministic_nonce_hash
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t Stdlib.Bytes.t :=
  Tezos_rpc.RPC_service.post_service
    (Some
      "Obtain the hash of some random data generated deterministically from some piece of data with a given remote key"
        % string) query Tezos_base__TzPervasives.Data_encoding.bytes
    (Tezos_base__TzPervasives.Data_encoding.obj1
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "deterministic_nonce_hash" % string
        Tezos_base__TzPervasives.Data_encoding.bytes))
    (Tezos_rpc.RPC_path.op_div_colon
      (Tezos_rpc.RPC_path.op_div Tezos_rpc.RPC_path.root "keys" % string)
      Tezos_base__TzPervasives.Signature.Public_key_hash.rpc_arg).

Definition supports_deterministic_nonces
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t) unit unit bool :=
  Tezos_rpc.RPC_service.get_service
    (Some
      "Obtain whether the signing service suppports the determinstic nonces functionality"
        % string) Tezos_rpc.RPC_query.empty
    (Tezos_base__TzPervasives.Data_encoding.obj1
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "supports_deterministic_nonces" % string
        Tezos_base__TzPervasives.Data_encoding.bool))
    (Tezos_rpc.RPC_path.op_div_colon
      (Tezos_rpc.RPC_path.op_div Tezos_rpc.RPC_path.root "keys" % string)
      Tezos_base__TzPervasives.Signature.Public_key_hash.rpc_arg).

Definition public_key
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t) unit unit
    Tezos_base__TzPervasives.Signature.Public_key.t :=
  Tezos_rpc.RPC_service.get_service
    (Some "Retrieve the public key of a given remote key" % string)
    Tezos_rpc.RPC_query.empty
    (Tezos_base__TzPervasives.Data_encoding.obj1
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "public_key" % string
        Tezos_base__TzPervasives.Signature.Public_key.encoding))
    (Tezos_rpc.RPC_path.op_div_colon
      (Tezos_rpc.RPC_path.op_div Tezos_rpc.RPC_path.root "keys" % string)
      Tezos_base__TzPervasives.Signature.Public_key_hash.rpc_arg).

Definition authorized_keys
  : Tezos_rpc.RPC_service.service variant unit unit unit unit
    (option (list Tezos_base__TzPervasives.Signature.Public_key_hash.t)) :=
  Tezos_rpc.RPC_service.get_service
    (Some
      "Retrieve the public keys that can be used to authenticate signing commands.
If the empty object is returned, the signer has been set to accept unsigned commands."
        % string) Tezos_rpc.RPC_query.empty
    (Tezos_base__TzPervasives.Data_encoding.obj1
      (Tezos_base__TzPervasives.Data_encoding.opt None None
        "authorized_keys" % string
        (Tezos_base__TzPervasives.Data_encoding.list None
          Tezos_base__TzPervasives.Signature.Public_key_hash.encoding)))
    (Tezos_rpc.RPC_path.op_div Tezos_rpc.RPC_path.root
      "authorized_keys" % string).
src/lib_signer_services/signer_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val sign :
  ( [`POST],
    unit,
    unit * Signature.Public_key_hash.t,
    Signature.t option,
    Bytes.t,
    Signature.t )
  RPC_service.t

val deterministic_nonce :
  ( [`POST],
    unit,
    unit * Signature.Public_key_hash.t,
    Signature.t option,
    Bytes.t,
    Bigstring.t )
  RPC_service.t

val deterministic_nonce_hash :
  ( [`POST],
    unit,
    unit * Signature.Public_key_hash.t,
    Signature.t option,
    Bytes.t,
    Bytes.t )
  RPC_service.t

val supports_deterministic_nonces :
  ( [`GET],
    unit,
    unit * Signature.Public_key_hash.t,
    unit,
    unit,
    bool )
  RPC_service.t

val public_key :
  ( [`GET],
    unit,
    unit * Signature.Public_key_hash.t,
    unit,
    unit,
    Signature.Public_key.t )
  RPC_service.t

val authorized_keys :
  ( [`GET],
    unit,
    unit,
    unit,
    unit,
    Signature.Public_key_hash.t list option )
  RPC_service.t
src/lib_signer_services/signer_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter sign : forall {variant : Type},
Tezos_rpc.RPC_service.t variant unit
  (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t
  Tezos_base__TzPervasives.Signature.t.

Parameter deterministic_nonce : forall {variant : Type},
Tezos_rpc.RPC_service.t variant unit
  (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t Bigstring.t.

Parameter deterministic_nonce_hash : forall {variant : Type},
Tezos_rpc.RPC_service.t variant unit
  (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t Stdlib.Bytes.t.

Parameter supports_deterministic_nonces : forall {variant : Type},
Tezos_rpc.RPC_service.t variant unit
  (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t) unit unit bool.

Parameter public_key : forall {variant : Type},
Tezos_rpc.RPC_service.t variant unit
  (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t) unit unit
  Tezos_base__TzPervasives.Signature.Public_key.t.

Parameter authorized_keys : forall {variant : Type},
Tezos_rpc.RPC_service.t variant unit unit unit unit
  (option (list Tezos_base__TzPervasives.Signature.Public_key_hash.t)).
src/lib_stdlib/bytes_encodings.ml 
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* this module is a temporary fix waiting for ocaml 4.08 *)

(** {1 Binary encoding/decoding of integers} *)

external get_uint8 : bytes -> int -> int = "%bytes_safe_get"

external get_uint16_ne : bytes -> int -> int = "%caml_bytes_get16"

external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"

external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64"

external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"

external set_int16_ne : bytes -> int -> int -> unit = "%caml_bytes_set16"

external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32"

external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_bytes_set64"

external swap16 : int -> int = "%bswap16"

external swap32 : int32 -> int32 = "%bswap_int32"

external swap64 : int64 -> int64 = "%bswap_int64"

let get_int8 b i = (get_uint8 b i lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)

let get_uint16_le b i =
  if Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i

let get_uint16_be b i =
  if not Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i

let get_int16_ne b i =
  (get_uint16_ne b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_le b i =
  (get_uint16_le b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_be b i =
  (get_uint16_be b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int32_le b i =
  if Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i

let get_int32_be b i =
  if not Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i

let get_int64_le b i =
  if Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i

let get_int64_be b i =
  if not Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i

let set_int16_le b i x =
  if Sys.big_endian then set_int16_ne b i (swap16 x) else set_int16_ne b i x

let set_int16_be b i x =
  if not Sys.big_endian then set_int16_ne b i (swap16 x)
  else set_int16_ne b i x

let set_int32_le b i x =
  if Sys.big_endian then set_int32_ne b i (swap32 x) else set_int32_ne b i x

let set_int32_be b i x =
  if not Sys.big_endian then set_int32_ne b i (swap32 x)
  else set_int32_ne b i x

let set_int64_le b i x =
  if Sys.big_endian then set_int64_ne b i (swap64 x) else set_int64_ne b i x

let set_int64_be b i x =
  if not Sys.big_endian then set_int64_ne b i (swap64 x)
  else set_int64_ne b i x

let set_uint8 = set_int8

let set_uint16_ne = set_int16_ne

let set_uint16_be = set_int16_be

let set_uint16_le = set_int16_le

module type S = sig
  (** {1 Binary encoding/decoding of integers} *)

  (** The functions in this section binary encode and decode integers to
      and from byte sequences.
      All following functions raise [Invalid_argument] if the space
      needed at index [i] to decode or encode the integer is not
      available.
      Little-endian (resp. big-endian) encoding means that least
      (resp. most) significant bytes are stored first.  Big-endian is
      also known as network byte order.  Native-endian encoding is
      either little-endian or big-endian depending on {!Sys.big_endian}.
      32-bit and 64-bit integers are represented by the [int32] and
      [int64] types, which can be interpreted either as signed or
      unsigned numbers.
      8-bit and 16-bit integers are represented by the [int] type,
      which has more bits than the binary encoding.  These extra bits
      are handled as follows:
        {ul
          {- Functions that decode signed (resp. unsigned) 8-bit or 16-bit
          integers represented by [int] values sign-extend
          (resp. zero-extend) their result.}
          {- Functions that encode 8-bit or 16-bit integers represented by
          [int] values truncate their input to their least significant
          bytes.}
        }
  *)

  (** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at byte index [i].
      @since 4.08
  *)
  val get_uint8 : bytes -> int -> int

  (** [get_int8 b i] is [b]'s signed 8-bit integer starting at byte index [i].
      @since 4.08
  *)
  val get_int8 : bytes -> int -> int

  (** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_ne : bytes -> int -> int

  (** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_be : bytes -> int -> int

  (** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_le : bytes -> int -> int

  (** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_ne : bytes -> int -> int

  (** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_be : bytes -> int -> int

  (** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_le : bytes -> int -> int

  (** [get_int32_ne b i] is [b]'s native-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_ne : bytes -> int -> int32

  (** [get_int32_be b i] is [b]'s big-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_be : bytes -> int -> int32

  (** [get_int32_le b i] is [b]'s little-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_le : bytes -> int -> int32

  (** [get_int64_ne b i] is [b]'s native-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_ne : bytes -> int -> int64

  (** [get_int64_be b i] is [b]'s big-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_be : bytes -> int -> int64

  (** [get_int64_le b i] is [b]'s little-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_le : bytes -> int -> int64

  (** [set_uint8 b i v] sets [b]'s unsigned 8-bit integer starting at byte index
      [i] to [v].
      @since 4.08
  *)
  val set_uint8 : bytes -> int -> int -> unit

  (** [set_int8 b i v] sets [b]'s signed 8-bit integer starting at byte index
      [i] to [v].
      @since 4.08
  *)
  val set_int8 : bytes -> int -> int -> unit

  (** [set_uint16_ne b i v] sets [b]'s native-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_ne : bytes -> int -> int -> unit

  (** [set_uint16_be b i v] sets [b]'s big-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_be : bytes -> int -> int -> unit

  (** [set_uint16_le b i v] sets [b]'s little-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_le : bytes -> int -> int -> unit

  (** [set_int16_ne b i v] sets [b]'s native-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_ne : bytes -> int -> int -> unit

  (** [set_int16_be b i v] sets [b]'s big-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_be : bytes -> int -> int -> unit

  (** [set_int16_le b i v] sets [b]'s little-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_le : bytes -> int -> int -> unit

  (** [set_int32_ne b i v] sets [b]'s native-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_ne : bytes -> int -> int32 -> unit

  (** [set_int32_be b i v] sets [b]'s big-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_be : bytes -> int -> int32 -> unit

  (** [set_int32_le b i v] sets [b]'s little-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_le : bytes -> int -> int32 -> unit

  (** [set_int64_ne b i v] sets [b]'s native-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_ne : bytes -> int -> int64 -> unit

  (** [set_int64_be b i v] sets [b]'s big-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_be : bytes -> int -> int64 -> unit

  (** [set_int64_le b i v] sets [b]'s little-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_le : bytes -> int -> int64 -> unit
end
src/lib_stdlib/bytes_encodings.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_uint8 : string -> Z -> Z.

Parameter get_uint16_ne : string -> Z -> Z.

Parameter get_int32_ne : string -> Z -> int32.

Parameter get_int64_ne : string -> Z -> int64.

Parameter set_int8 : string -> Z -> Z -> unit.

Parameter set_int16_ne : string -> Z -> Z -> unit.

Parameter set_int32_ne : string -> Z -> int32 -> unit.

Parameter set_int64_ne : string -> Z -> int64 -> unit.

Parameter swap16 : Z -> Z.

Parameter swap32 : int32 -> int32.

Parameter swap64 : int64 -> int64.

Definition get_int8 (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint8 b i) (Z.sub Stdlib.Sys.int_size 8))
    (Z.sub Stdlib.Sys.int_size 8).

Definition get_uint16_le (b : string) (i : Z) : Z :=
  if Stdlib.Sys.big_endian then
    swap16 (get_uint16_ne b i)
  else
    get_uint16_ne b i.

Definition get_uint16_be (b : string) (i : Z) : Z :=
  if negb Stdlib.Sys.big_endian then
    swap16 (get_uint16_ne b i)
  else
    get_uint16_ne b i.

Definition get_int16_ne (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_ne b i) (Z.sub Stdlib.Sys.int_size 16))
    (Z.sub Stdlib.Sys.int_size 16).

Definition get_int16_le (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_le b i) (Z.sub Stdlib.Sys.int_size 16))
    (Z.sub Stdlib.Sys.int_size 16).

Definition get_int16_be (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_be b i) (Z.sub Stdlib.Sys.int_size 16))
    (Z.sub Stdlib.Sys.int_size 16).

Definition get_int32_le (b : string) (i : Z) : int32 :=
  if Stdlib.Sys.big_endian then
    swap32 (get_int32_ne b i)
  else
    get_int32_ne b i.

Definition get_int32_be (b : string) (i : Z) : int32 :=
  if negb Stdlib.Sys.big_endian then
    swap32 (get_int32_ne b i)
  else
    get_int32_ne b i.

Definition get_int64_le (b : string) (i : Z) : int64 :=
  if Stdlib.Sys.big_endian then
    swap64 (get_int64_ne b i)
  else
    get_int64_ne b i.

Definition get_int64_be (b : string) (i : Z) : int64 :=
  if negb Stdlib.Sys.big_endian then
    swap64 (get_int64_ne b i)
  else
    get_int64_ne b i.

Definition set_int16_le (b : string) (i : Z) (x : Z) : unit :=
  if Stdlib.Sys.big_endian then
    set_int16_ne b i (swap16 x)
  else
    set_int16_ne b i x.

Definition set_int16_be (b : string) (i : Z) (x : Z) : unit :=
  if negb Stdlib.Sys.big_endian then
    set_int16_ne b i (swap16 x)
  else
    set_int16_ne b i x.

Definition set_int32_le (b : string) (i : Z) (x : int32) : unit :=
  if Stdlib.Sys.big_endian then
    set_int32_ne b i (swap32 x)
  else
    set_int32_ne b i x.

Definition set_int32_be (b : string) (i : Z) (x : int32) : unit :=
  if negb Stdlib.Sys.big_endian then
    set_int32_ne b i (swap32 x)
  else
    set_int32_ne b i x.

Definition set_int64_le (b : string) (i : Z) (x : int64) : unit :=
  if Stdlib.Sys.big_endian then
    set_int64_ne b i (swap64 x)
  else
    set_int64_ne b i x.

Definition set_int64_be (b : string) (i : Z) (x : int64) : unit :=
  if negb Stdlib.Sys.big_endian then
    set_int64_ne b i (swap64 x)
  else
    set_int64_ne b i x.

Definition set_uint8 : string -> Z -> Z -> unit := set_int8.

Definition set_uint16_ne : string -> Z -> Z -> unit := set_int16_ne.

Definition set_uint16_be : string -> Z -> Z -> unit := set_int16_be.

Definition set_uint16_le : string -> Z -> Z -> unit := set_int16_le.

Module S.
  Record signature := {
    get_uint8 : string -> Z -> Z;
    get_int8 : string -> Z -> Z;
    get_uint16_ne : string -> Z -> Z;
    get_uint16_be : string -> Z -> Z;
    get_uint16_le : string -> Z -> Z;
    get_int16_ne : string -> Z -> Z;
    get_int16_be : string -> Z -> Z;
    get_int16_le : string -> Z -> Z;
    get_int32_ne : string -> Z -> int32;
    get_int32_be : string -> Z -> int32;
    get_int32_le : string -> Z -> int32;
    get_int64_ne : string -> Z -> int64;
    get_int64_be : string -> Z -> int64;
    get_int64_le : string -> Z -> int64;
    set_uint8 : string -> Z -> Z -> unit;
    set_int8 : string -> Z -> Z -> unit;
    set_uint16_ne : string -> Z -> Z -> unit;
    set_uint16_be : string -> Z -> Z -> unit;
    set_uint16_le : string -> Z -> Z -> unit;
    set_int16_ne : string -> Z -> Z -> unit;
    set_int16_be : string -> Z -> Z -> unit;
    set_int16_le : string -> Z -> Z -> unit;
    set_int32_ne : string -> Z -> int32 -> unit;
    set_int32_be : string -> Z -> int32 -> unit;
    set_int32_le : string -> Z -> int32 -> unit;
    set_int64_ne : string -> Z -> int64 -> unit;
    set_int64_be : string -> Z -> int64 -> unit;
    set_int64_le : string -> Z -> int64 -> unit;
  }.
End S.
src/lib_stdlib/compare.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type COMPARABLE = sig
  type t

  val compare : t -> t -> int
end

module type S = sig
  type t

  val ( = ) : t -> t -> bool

  val ( <> ) : t -> t -> bool

  val ( < ) : t -> t -> bool

  val ( <= ) : t -> t -> bool

  val ( >= ) : t -> t -> bool

  val ( > ) : t -> t -> bool

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val max : t -> t -> t

  val min : t -> t -> t
end

module Make (P : COMPARABLE) = struct
  include P

  let compare = compare

  let ( = ) a b = compare a b = 0

  let ( <> ) a b = compare a b <> 0

  let ( < ) a b = compare a b < 0

  let ( <= ) a b = compare a b <= 0

  let ( >= ) a b = compare a b >= 0

  let ( > ) a b = compare a b > 0

  let equal = ( = )

  let max x y = if x >= y then x else y

  let min x y = if x <= y then x else y
end

module List (P : COMPARABLE) = struct
  type t = P.t list

  let rec compare xs ys =
    match (xs, ys) with
    | ([], []) ->
        0
    | ([], _) ->
        -1
    | (_, []) ->
        1
    | (x :: xs, y :: ys) ->
        let hd = P.compare x y in
        if hd <> 0 then hd else compare xs ys

  let ( = ) xs ys = compare xs ys = 0

  let ( <> ) xs ys = compare xs ys <> 0

  let ( < ) xs ys = compare xs ys < 0

  let ( <= ) xs ys = compare xs ys <= 0

  let ( >= ) xs ys = compare xs ys >= 0

  let ( > ) xs ys = compare xs ys > 0

  let equal = ( = )

  let max x y = if x >= y then x else y

  let min x y = if x <= y then x else y
end

module Option (P : COMPARABLE) = struct
  type t = P.t option

  let compare xs ys =
    match (xs, ys) with
    | (None, None) ->
        0
    | (None, _) ->
        -1
    | (_, None) ->
        1
    | (Some x, Some y) ->
        P.compare x y

  let ( = ) xs ys = compare xs ys = 0

  let ( <> ) xs ys = compare xs ys <> 0

  let ( < ) xs ys = compare xs ys < 0

  let ( <= ) xs ys = compare xs ys <= 0

  let ( >= ) xs ys = compare xs ys >= 0

  let ( > ) xs ys = compare xs ys > 0

  let equal = ( = )

  let max x y = if x >= y then x else y

  let min x y = if x <= y then x else y
end

module Char = Make (Char)

module Bool = Make (struct
  type t = bool

  let compare = Pervasives.compare
end)

module Int = Make (struct
  type t = int

  let compare = Pervasives.compare
end)

module Int32 = Make (Int32)
module Int64 = Make (Int64)

module MakeUnsigned
    (Int : S) (Z : sig
      val zero : Int.t
    end) =
struct
  type t = Int.t

  let compare va vb =
    Int.(
      if va >= Z.zero then if vb >= Z.zero then compare va vb else -1
      else if vb >= Z.zero then 1
      else compare va vb)

  let ( = ) = (( = ) : t -> t -> bool)

  let ( <> ) = (( <> ) : t -> t -> bool)

  let ( < ) a b =
    Int.(if Z.zero <= a then a < b || b < Z.zero else b < Z.zero && a < b)

  let ( <= ) a b =
    Int.(if Z.zero <= a then a <= b || b < Z.zero else b < Z.zero && a <= b)

  let ( >= ) a b = b <= a

  let ( > ) a b = b < a

  let equal = ( = )

  let max x y = if x >= y then x else y

  let min x y = if x <= y then x else y
end

module Uint32 =
  MakeUnsigned
    (Int32)
    (struct
      let zero = 0l
    end)

module Uint64 =
  MakeUnsigned
    (Int64)
    (struct
      let zero = 0L
    end)

module Float = Make (struct
  type t = float

  let compare = Pervasives.compare
end)

module String = Make (String)
module Z = Make (Z)
src/lib_stdlib/compare.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module COMPARABLE.
  Record signature {t : Type} := {
    t := t;
    compare : t -> t -> Z;
  }.
  Arguments signature : clear implicits.
End COMPARABLE.

Module S.
  Record signature {t : Type} := {
    t := t;
    op_eq : t -> t -> bool;
    op_lt_gt : t -> t -> bool;
    op_lt : t -> t -> bool;
    op_lt_eq : t -> t -> bool;
    op_gt_eq : t -> t -> bool;
    op_gt : t -> t -> bool;
    compare : t -> t -> Z;
    equal : t -> t -> bool;
    max : t -> t -> t;
    min : t -> t -> t;
  }.
  Arguments signature : clear implicits.
End S.
src/lib_stdlib/compare.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type COMPARABLE = sig
  type t

  val compare : t -> t -> int
end

module type S = sig
  type t

  val ( = ) : t -> t -> bool

  val ( <> ) : t -> t -> bool

  val ( < ) : t -> t -> bool

  val ( <= ) : t -> t -> bool

  val ( >= ) : t -> t -> bool

  val ( > ) : t -> t -> bool

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val max : t -> t -> t

  val min : t -> t -> t
end

module Make (P : COMPARABLE) : S with type t := P.t

module Char : S with type t = char

module Bool : S with type t = bool

module Int : S with type t = int

module Int32 : S with type t = int32

module Uint32 : S with type t = int32

module Int64 : S with type t = int64

module Uint64 : S with type t = int64

module Float : S with type t = float

module String : S with type t = string

module Z : S with type t = Z.t

module List (P : COMPARABLE) : S with type t = P.t list

module Option (P : COMPARABLE) : S with type t = P.t option
src/lib_stdlib/compare.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module
src/lib_stdlib/hashPtree.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Ptree_sig = struct
  module type Value = sig
    type t

    val equal : t -> t -> bool

    val hash : t -> int
  end

  type prefix_order = Equal | Shorter | Longer | Different

  module type Prefix = sig
    type key (* bit sequence *)

    type prefix (* prefix of a bit sequence *)

    type mask (* integer length of a bit sequence *)

    val equal_key : key -> key -> bool

    val equal_mask : mask -> mask -> bool

    val equal_prefix : prefix -> prefix -> bool

    val hash_key : key -> int

    val hash_mask : mask -> int

    val hash_prefix : prefix -> int

    val full_length_mask : mask

    val strictly_shorter_mask : mask -> mask -> bool

    val key_prefix : key -> prefix

    (* Full length prefix *)
    val prefix_key : prefix -> mask -> key

    (* Some key matching the prefix with the given mask *)

    val match_prefix : key:key -> prefix:prefix -> mask:mask -> bool

    (* Does the prefix of length [mask] of [key] equals to [prefix] *)

    val select_bit : prefix:prefix -> mask:mask -> bool

    (* Get the bit of [prefix] at position [mask] assumes that [mask] is
       less than the length of prefix *)

    val common_mask : prefix -> prefix -> mask

    (* The length of the common part of given prefixes *)

    val apply_mask : prefix -> mask -> prefix

    (* Cut the prefix to the given length *)

    val compare_prefix : mask -> prefix -> mask -> prefix -> prefix_order

    (* [compare_prefix m1 p1 m2 p2]:
       let p1' (resp p2') be the sub-prefix of length m1 of p1 (resp m2 of p2)
       The result is
         Equal if p1' equal p2'
         Shorter if p1' is a prefix of p2'
         Longer if p2' is a prefix of p1'
         Different if those not ordered
    *)
  end

  module type S = sig
    type key

    type prefix

    type mask

    type value

    type not_empty = TNot_empty

    type empty = TEmpty

    type _ t = private
      | Leaf : {
          mutable id : int;
          (* Mutable to get a good sharing semantics *)
          mask : mask;
          key : key;
          value : value;
        }
          -> not_empty t
      | Node : {
          mutable id : int;
          mask : mask;
          prefix : prefix;
          true_ : not_empty t;
          false_ : not_empty t;
        }
          -> not_empty t
      | Empty : empty t

    val leaf : key:key -> mask:mask -> value -> not_empty t

    val node :
      prefix:prefix ->
      mask:mask ->
      true_:not_empty t ->
      false_:not_empty t ->
      not_empty t

    val empty : empty t

    val equal : not_empty t -> not_empty t -> bool

    val fast_partial_equal : not_empty t -> not_empty t -> bool

    (* if [fast_partial_equal x y] is true, then [equal x y] is true,
       but if fast_partial_equal returns false, nothing can be
       asserted. *)

    val id : not_empty t -> int
  end
end

module Shared_tree : sig
  module Hash_consed_tree (P : Ptree_sig.Prefix) (V : Ptree_sig.Value) :
    Ptree_sig.S
      with type value = V.t
       and type key = P.key
       and type prefix = P.prefix
       and type mask = P.mask

  module Simple_tree
      (P : Ptree_sig.Prefix) (V : sig
        type t

        val equal : t -> t -> bool
      end) :
    Ptree_sig.S
      with type value = V.t
       and type key = P.key
       and type prefix = P.prefix
       and type mask = P.mask
end = struct
  open Ptree_sig

  (*
  type int2 = { mutable i1 : int; mutable i2 : int }
  let h2 = { i1 = 0; i2 = 0 }
  let hash2int x1 x2 =
    h2.i1 <- x1; h2.i2 <- x2;
    Hashtbl.hash h2
*)
  type int3 = {mutable i1 : int; mutable i2 : int; mutable i3 : int}

  let h3 = {i1 = 0; i2 = 0; i3 = 0}

  let hash3int x1 x2 x3 =
    h3.i1 <- x1 ;
    h3.i2 <- x2 ;
    h3.i3 <- x3 ;
    Hashtbl.hash h3

  type int4 = {
    mutable i1 : int;
    mutable i2 : int;
    mutable i3 : int;
    mutable i4 : int;
  }

  let h4 = {i1 = 0; i2 = 0; i3 = 0; i4 = 0}

  let hash4int x1 x2 x3 x4 =
    h4.i1 <- x1 ;
    h4.i2 <- x2 ;
    h4.i3 <- x3 ;
    h4.i4 <- x4 ;
    Hashtbl.hash h4

  module Hash_consed_tree (P : Prefix) (V : Value) :
    S
      with type value = V.t
       and type key = P.key
       and type prefix = P.prefix
       and type mask = P.mask = struct
    type key = P.key

    type mask = P.mask

    type prefix = P.prefix

    type value = V.t

    type not_empty = TNot_empty

    type empty = TEmpty

    type _ t =
      | Leaf : {
          mutable id : int;
          (* Mutable to get a good sharing semantics *)
          mask : mask;
          key : key;
          value : value;
        }
          -> not_empty t
      | Node : {
          mutable id : int;
          mask : mask;
          prefix : prefix;
          true_ : not_empty t;
          false_ : not_empty t;
        }
          -> not_empty t
      | Empty : empty t

    let id : not_empty t -> int = function
      | Leaf {id; _} ->
          id
      | Node {id; _} ->
          id

    let set_id (n : not_empty t) id =
      match n with Leaf r -> r.id <- id | Node r -> r.id <- id

    (*let mask : not_empty t -> mask = function
      | Leaf { mask ; _ } -> mask
      | Node { mask ; _ } -> mask
    *)
    (* let prefix_table = WeakPrefixTbl.create 20 *)

    module Tree : Hashtbl.HashedType with type t = not_empty t = struct
      type nonrec t = not_empty t

      let equal (t1 : t) (t2 : t) =
        match (t1, t2) with
        | (Leaf _, Node _) | (Node _, Leaf _) ->
            false
        | ( Leaf {key = p1; value = v1; mask = m1; _},
            Leaf {key = p2; value = v2; mask = m2; _} ) ->
            P.equal_key p1 p2 && P.equal_mask m1 m2 && V.equal v1 v2
        | ( Node {prefix = p1; mask = m1; true_ = t1; false_ = f1; _},
            Node {prefix = p2; mask = m2; true_ = t2; false_ = f2; _} ) ->
            (* Assumes that only the head can be unshared: this means
               that structural equality implies physical one on children *)
            P.equal_prefix p1 p2 && P.equal_mask m1 m2 && t1 == t2 && f1 == f2

      let hash : t -> int = function
        | Leaf {key; value; mask; _} ->
            hash3int (P.hash_key key) (V.hash value) (P.hash_mask mask)
        | Node {mask; prefix; true_; false_; _} ->
            hash4int
              (P.hash_mask mask)
              (P.hash_prefix prefix)
              (id true_)
              (id false_)
    end

    module WeakTreeTbl = Weak.Make (Tree)

    (* Or move that to a state ? *)
    let weak_tree_tbl = WeakTreeTbl.create 10

    let next =
      let r = ref 0 in
      fun () -> incr r ; !r

    let leaf ~key ~mask value =
      let l = Leaf {id = 0; key; value; mask} in
      match WeakTreeTbl.find_opt weak_tree_tbl l with
      | None ->
          set_id l (next ()) ;
          WeakTreeTbl.add weak_tree_tbl l ;
          l
      | Some l ->
          l

    let node ~prefix ~mask ~true_ ~false_ =
      let l = Node {id = 0; mask; prefix; true_; false_} in
      match WeakTreeTbl.find_opt weak_tree_tbl l with
      | None ->
          set_id l (next ()) ;
          WeakTreeTbl.add weak_tree_tbl l ;
          l
      | Some l ->
          l

    let empty = Empty

    let equal (x : not_empty t) (y : not_empty t) = x == y

    let fast_partial_equal = equal
  end
  [@@inline]

  module Simple_tree
      (P : Ptree_sig.Prefix) (V : sig
        type t

        val equal : t -> t -> bool
      end) :
    S
      with type value = V.t
       and type key = P.key
       and type prefix = P.prefix
       and type mask = P.mask = struct
    type key = P.key

    type mask = P.mask

    type prefix = P.prefix

    type value = V.t

    type not_empty = TNot_empty

    type empty = TEmpty

    type _ t =
      | Leaf : {
          mutable id : int;
          (* Mutable to get a good sharing semantics *)
          mask : mask;
          key : key;
          value : value;
        }
          -> not_empty t
      | Node : {
          mutable id : int;
          mask : mask;
          prefix : prefix;
          true_ : not_empty t;
          false_ : not_empty t;
        }
          -> not_empty t
      | Empty : empty t

    let id : not_empty t -> int = function
      | Leaf {id; _} ->
          id
      | Node {id; _} ->
          id

    (*let set_id (n : not_empty t) id = match n with
      | Leaf r -> r.id <- id
      | Node r -> r.id <- id

      let mask : not_empty t -> mask = function
      | Leaf { mask ; _ } -> mask
      | Node { mask ; _ } -> mask
    *)
    let leaf ~key ~mask value = Leaf {id = 0; key; value; mask}

    let node ~prefix ~mask ~true_ ~false_ =
      Node {id = 0; mask; prefix; true_; false_}

    let empty = Empty

    let rec equal_not_empty (x : not_empty t) (y : not_empty t) =
      x == y
      ||
      match (x, y) with
      | (Leaf l1, Leaf l2) ->
          P.equal_key l1.key l2.key && V.equal l1.value l2.value
      | (Node n1, Node n2) ->
          P.equal_prefix n1.prefix n2.prefix
          && P.equal_mask n1.mask n2.mask
          && equal_not_empty n1.true_ n2.true_
          && equal_not_empty n1.false_ n2.false_
      | (Node _, Leaf _) | (Leaf _, Node _) ->
          false

    let equal : type a b. a t -> b t -> bool =
     fun x y ->
      match (x, y) with
      | (Empty, Empty) ->
          true
      | (Leaf _, Leaf _) ->
          equal_not_empty x y
      | (Node _, Node _) ->
          equal_not_empty x y
      | (_, _) ->
          false

    let fast_partial_equal (x : not_empty t) (y : not_empty t) = x == y
  end
  [@@inline]
end

module type Value = sig
  type t

  val equal : t -> t -> bool

  val hash : t -> int
end

module type Bits = sig
  type t

  val lnot : t -> t

  val ( land ) : t -> t -> t

  val ( lxor ) : t -> t -> t

  val ( lor ) : t -> t -> t

  val ( lsr ) : t -> int -> t

  val ( lsl ) : t -> int -> t

  val pred : t -> t

  val less_than : t -> t -> bool

  val highest_bit : t -> t

  val equal : t -> t -> bool

  val hash : t -> int

  val zero : t

  val one : t

  val size : int
end

module type Size = sig
  val size : int
end

module Bits (S : Size) = struct
  type t = Z.t

  let size = S.size

  let higher_bit = Z.shift_left Z.one size

  let mask = Z.pred higher_bit

  let mark n = Z.logor higher_bit n

  let unmark n = Z.logxor higher_bit n

  let one = mark Z.one

  let zero = higher_bit

  let hash = Z.hash

  let equal = Z.equal

  let less_than = Z.lt

  let highest_bit_unmarked n =
    if Z.equal Z.zero n then Z.zero
    else Z.(Z.one lsl Pervasives.pred (numbits n))

  let highest_bit n = mark (highest_bit_unmarked (unmark n))

  let lnot x = Z.logor (Z.lognot x) higher_bit

  let ( land ) = Z.logand

  let ( lxor ) a b = Z.logor (Z.logxor a b) higher_bit

  let ( lor ) = Z.logor

  let ( lsr ) a n =
    Z.logor (Z.shift_right_trunc (Z.logxor a higher_bit) n) higher_bit

  let ( lsl ) a n = Z.logor (Z.logand (Z.shift_left a n) mask) higher_bit

  let pred = Z.pred

  let of_z n = mark n

  let to_z n = unmark n
end

module BE_gen_prefix (Bits : Bits) :
  Ptree_sig.Prefix
    with type key = Bits.t
     and type prefix = Bits.t
     and type mask = Bits.t = struct
  type key = Bits.t

  type mask = Bits.t (* Only a single bit set *)

  type prefix = Bits.t

  let equal_key = Bits.equal

  let equal_mask = Bits.equal

  let equal_prefix = Bits.equal

  let hash_key x = Bits.hash x

  let hash_mask x = Bits.hash x

  let hash_prefix x = Bits.hash x

  open Bits

  let full_length_mask = Bits.one

  let strictly_shorter_mask (m1 : mask) m2 = Bits.less_than m2 m1

  let select_bit ~prefix ~mask = not (Bits.equal (prefix land mask) Bits.zero)

  let apply_mask prefix mask = prefix land lnot (pred mask)

  let match_prefix ~key ~prefix ~mask =
    equal_prefix (apply_mask key mask) prefix

  let common_mask p0 p1 = Bits.highest_bit (* [@inlined] *) (p0 lxor p1)

  let key_prefix x = x

  let prefix_key p _m = p

  let smaller_set_mask m1 m2 = lnot (pred m1) land lnot (pred m2)

  let compare_prefix m1 p1 m2 p2 =
    let min_mask = smaller_set_mask m1 m2 in
    let applied_p1 = p1 land min_mask in
    let applied_p2 = p2 land min_mask in
    if applied_p1 = applied_p2 then
      if m1 > m2 then Ptree_sig.Shorter
      else if m1 < m2 then Ptree_sig.Longer
      else Ptree_sig.Equal
    else Ptree_sig.Different
end

module LE_prefix :
  Ptree_sig.Prefix
    with type key = int
     and type prefix = int
     and type mask = int = struct
  type key = int

  type mask = int (* Only a single bit set *)

  type prefix = int

  let equal_key = ( == )

  let equal_mask = ( == )

  let equal_prefix = ( == )

  let hash_key x = x

  let hash_mask x = x

  let hash_prefix x = x

  let full_length_mask = -1 lxor (-1 lsr 1)

  let strictly_shorter_mask (m1 : mask) m2 = m1 < m2

  let select_bit ~prefix ~mask = prefix land mask != 0

  let apply_mask prefix mask = prefix land (mask - 1)

  let match_prefix ~key ~prefix ~mask = apply_mask key mask == prefix

  let lowest_bit x = x land -x

  let common_mask p0 p1 = lowest_bit (p0 lxor p1)

  let key_prefix x = x

  let prefix_key p _m = p

  let smaller_set_mask m1 m2 = (m1 - 1) land (m2 - 1)

  let compare_prefix m1 p1 m2 p2 =
    let min_mask = smaller_set_mask m1 m2 in
    let applied_p1 = p1 land min_mask in
    let applied_p2 = p2 land min_mask in
    if applied_p1 = applied_p2 then
      if m1 < m2 then Ptree_sig.Shorter
      else if m1 > m2 then Ptree_sig.Longer
      else Ptree_sig.Equal
    else Ptree_sig.Different
end

module BE_prefix :
  Ptree_sig.Prefix
    with type key = int
     and type prefix = int
     and type mask = int = struct
  type key = int

  type mask = int (* Only a single bit set *)

  type prefix = int

  let equal_key = ( == )

  let equal_mask = ( == )

  let equal_prefix = ( == )

  let hash_key x = x

  let hash_mask x = x

  let hash_prefix x = x

  let full_length_mask = 1

  let strictly_shorter_mask (m1 : mask) m2 = m1 > m2

  let select_bit ~prefix ~mask = prefix land mask != 0

  module Nativeint_infix = struct
    let ( lor ) = Nativeint.logor

    (*let (lsl) = Nativeint.shift_left*)
    let ( lsr ) = Nativeint.shift_right_logical

    (*let (asr) = Nativeint.shift_right*)
    let ( land ) = Nativeint.logand

    let lnot = Nativeint.lognot

    let ( lxor ) = Nativeint.logxor

    let ( - ) = Nativeint.sub
  end

  let apply_mask prefix mask =
    let open Nativeint_infix in
    let prefix = Nativeint.of_int prefix in
    let mask = Nativeint.of_int mask in
    Nativeint.to_int (prefix land lnot (mask - 1n))

  let match_prefix ~key ~prefix ~mask = apply_mask key mask == prefix

  let highest_bit x =
    Nativeint_infix.(
      let x = x lor (x lsr 1) in
      let x = x lor (x lsr 2) in
      let x = x lor (x lsr 4) in
      let x = x lor (x lsr 8) in
      let x = x lor (x lsr 16) in
      let x = if Sys.word_size > 32 then x lor (x lsr 32) else x in
      Nativeint.to_int (x - (x lsr 1)))

  let common_mask p0 p1 =
    let open Nativeint_infix in
    let p0 = Nativeint.of_int p0 in
    let p1 = Nativeint.of_int p1 in
    highest_bit (p0 lxor p1)

  let key_prefix x = x

  let prefix_key p _m = p

  let smaller_set_mask m1 m2 =
    let open Nativeint_infix in
    lnot (m1 - 1n) land lnot (m2 - 1n)

  let compare_prefix m1 p1 m2 p2 =
    let open Nativeint_infix in
    let m1 = Nativeint.of_int m1 in
    let m2 = Nativeint.of_int m2 in
    let p1 = Nativeint.of_int p1 in
    let p2 = Nativeint.of_int p2 in
    let min_mask = smaller_set_mask m1 m2 in
    let applied_p1 = p1 land min_mask in
    let applied_p2 = p2 land min_mask in
    if applied_p1 = applied_p2 then
      if m1 > m2 then Ptree_sig.Shorter
      else if m1 < m2 then Ptree_sig.Longer
      else Ptree_sig.Equal
    else Ptree_sig.Different
end

module Make (P : Ptree_sig.Prefix) (V : Value) = struct
  module T = Shared_tree.Hash_consed_tree (P) (V)

  type t = E : 'a T.t -> t [@@ocaml.unboxed]

  type key = T.key

  type value = T.value

  type mask = T.mask

  (*
  let (=) = `Do_not_use_polymorphic_equality
  let (<=) = `Do_not_use_polymorphic_comparison
  let (>=) = `Do_not_use_polymorphic_comparison
  let (<) = `Do_not_use_polymorphic_comparison
  let (>) = `Do_not_use_polymorphic_comparison
  let compare = `Do_not_use_polymorphic_comparison
   *)
  let equal (E t1) (E t2) =
    match (t1, t2) with
    | (T.Empty, T.Empty) ->
        true
    | (T.Empty, T.Leaf _) ->
        false
    | (T.Empty, T.Node _) ->
        false
    | (T.Leaf _, T.Empty) ->
        false
    | (T.Node _, T.Empty) ->
        false
    | (T.Node _, T.Node _) ->
        T.equal t1 t2
    | (T.Node _, T.Leaf _) ->
        T.equal t1 t2
    | (T.Leaf _, T.Node _) ->
        T.equal t1 t2
    | (T.Leaf _, T.Leaf _) ->
        T.equal t1 t2

  let select_key_bit k m = P.select_bit ~prefix:(P.key_prefix k) ~mask:m

  let matching_key k1 k2 mask =
    let p1 = P.apply_mask (P.key_prefix k1) mask in
    let p2 = P.apply_mask (P.key_prefix k2) mask in
    P.equal_prefix p1 p2

  let rec mem : type k. key -> k T.t -> bool =
   fun k -> function
    | T.Empty ->
        false
    | T.Leaf {key; mask; _} ->
        matching_key key k mask
    | T.Node {prefix = _; mask; true_; false_; _} ->
        mem k (if select_key_bit k mask then true_ else false_)

  let rec mem_exact : type k. key -> k T.t -> bool =
   fun k -> function
    | T.Empty ->
        false
    | T.Leaf {key; mask; _} ->
        P.equal_key k key && P.equal_mask mask P.full_length_mask
    | T.Node {prefix = _; mask; true_; false_; _} ->
        mem_exact k (if select_key_bit k mask then true_ else false_)

  let rec find_ne k (t : T.not_empty T.t) =
    match t with
    | T.Leaf {key; value; mask; _} ->
        if matching_key key k mask then Some value else None
    | T.Node {prefix = _; mask; true_; false_; _} ->
        find_ne k (if select_key_bit k mask then true_ else false_)

  let find : type k. key -> k T.t -> value option =
   fun k -> function
    | T.Empty ->
        None
    | T.Leaf _ as t ->
        find_ne k t
    | T.Node _ as t ->
        find_ne k t

  let singleton ~key ~value ~mask = T.leaf ~key value ~mask

  let join ~mask p0 t0 p1 t1 =
    (* assumes p0 <> p1 *)
    let c_mask = P.common_mask p0 p1 in
    let mask = if P.strictly_shorter_mask c_mask mask then c_mask else mask in
    let prefix = P.apply_mask p1 mask in
    let (true_, false_) =
      if P.select_bit ~prefix:p0 ~mask then (t0, t1) else (t1, t0)
    in
    T.node ~prefix ~mask ~true_ ~false_

  let rebuild_ne_branch node prefix mask ~node_true ~node_false ~true_ ~false_
      =
    if
      T.fast_partial_equal node_true true_
      && T.fast_partial_equal node_false false_
    then node
    else T.node ~prefix ~mask ~true_ ~false_

  let rec add_ne combine ~key ~value ?(mask = P.full_length_mask) t =
    match t with
    | T.Leaf leaf ->
        if
          P.equal_key key leaf.key && P.equal_mask leaf.mask P.full_length_mask
        then
          if value == leaf.value then t
          else T.leaf ~key (combine value leaf.value) ~mask
        else if
          P.strictly_shorter_mask leaf.mask mask
          && P.match_prefix
               ~key
               ~prefix:(P.key_prefix leaf.key)
               ~mask:leaf.mask
        then (* The previous leaf shadows the new one: no modification *)
          t
        else if
          P.strictly_shorter_mask mask leaf.mask
          && P.match_prefix ~key:leaf.key ~prefix:(P.key_prefix key) ~mask
        then
          (* The new leaf shadows the previous one: replace *)
          T.leaf ~key (combine value leaf.value) ~mask
        else
          join
            ~mask
            (P.key_prefix key)
            (T.leaf ~key value ~mask)
            (P.key_prefix leaf.key)
            t
    | T.Node node ->
        if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
          let (true_, false_) =
            if select_key_bit key node.mask then
              (add_ne combine ~key ~value ~mask node.true_, node.false_)
            else (node.true_, add_ne combine ~key ~value ~mask node.false_)
          in
          rebuild_ne_branch
            t
            node.prefix
            node.mask
            ~node_false:node.false_
            ~node_true:node.true_
            ~true_
            ~false_
        else
          join ~mask (P.key_prefix key) (T.leaf ~key value ~mask) node.prefix t

  let add :
      type k.
      (value -> value -> value) ->
      key:key ->
      value:value ->
      ?mask:P.mask ->
      k T.t ->
      T.not_empty T.t =
   fun combine ~key ~value ?(mask = P.full_length_mask) -> function
    | T.Empty ->
        singleton ~key ~value ~mask
    (* Should be merged by matcher *)
    | T.Leaf _ as t ->
        add_ne combine ~key ~value ~mask t
    | T.Node _ as t ->
        add_ne combine ~key ~value ~mask t

  let empty = E T.empty

  let rebuild_branch node prefix mask ~node_true ~node_false ~true_:(E true_)
      ~false_:(E false_) =
    match (true_, false_) with
    | (T.Empty, T.Empty) ->
        empty
    | (T.Empty, t) ->
        E t
    | (t, T.Empty) ->
        E t
    | ((T.Leaf _ as true_), (T.Leaf _ as false_)) ->
        E
          (rebuild_ne_branch
             node
             prefix
             mask
             ~node_true
             ~node_false
             ~true_
             ~false_)
    | ((T.Leaf _ as true_), (T.Node _ as false_)) ->
        E
          (rebuild_ne_branch
             node
             prefix
             mask
             ~node_true
             ~node_false
             ~true_
             ~false_)
    | ((T.Node _ as true_), (T.Leaf _ as false_)) ->
        E
          (rebuild_ne_branch
             node
             prefix
             mask
             ~node_true
             ~node_false
             ~true_
             ~false_)
    | ((T.Node _ as true_), (T.Node _ as false_)) ->
        E
          (rebuild_ne_branch
             node
             prefix
             mask
             ~node_true
             ~node_false
             ~true_
             ~false_)

  let rec remove_ne : key -> T.not_empty T.t -> t =
   fun key t ->
    match t with
    | T.Leaf leaf ->
        if matching_key leaf.key key leaf.mask then E T.empty else E t
    | T.Node node ->
        if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
          let (true_, false_) =
            if select_key_bit key node.mask then
              (remove_ne key node.true_, E node.false_)
            else (E node.true_, remove_ne key node.false_)
          in
          rebuild_branch
            t
            node.prefix
            node.mask
            ~node_true:node.true_
            ~node_false:node.false_
            ~true_
            ~false_
        else E t

  let remove key (E t) =
    match t with
    | T.Empty ->
        empty
    | T.Leaf _ as t ->
        remove_ne key t
    | T.Node _ as t ->
        remove_ne key t

  let rec remove_prefix_ne : key -> mask -> T.not_empty T.t -> t =
   fun key mask t ->
    match t with
    | T.Leaf leaf ->
        if matching_key key leaf.key mask then E T.empty else E t
    | T.Node node -> (
      match P.compare_prefix mask (P.key_prefix key) node.mask node.prefix with
      | Different ->
          E t
      | Equal ->
          E T.empty
      | Shorter ->
          E T.empty
      | Longer ->
          let (true_, false_) =
            if select_key_bit key node.mask then
              (remove_prefix_ne key mask node.true_, E node.false_)
            else (E node.true_, remove_prefix_ne key mask node.false_)
          in
          rebuild_branch
            t
            node.prefix
            node.mask
            ~node_true:node.true_
            ~node_false:node.false_
            ~true_
            ~false_ )

  let remove_prefix key mask (E t) =
    match t with
    | T.Empty ->
        empty
    | T.Leaf _ as t ->
        remove_prefix_ne key mask t
    | T.Node _ as t ->
        remove_prefix_ne key mask t

  let rec remove_ne_exact : key -> T.not_empty T.t -> t =
   fun key t ->
    match t with
    | T.Leaf leaf ->
        if
          P.equal_key leaf.key key && P.equal_mask leaf.mask P.full_length_mask
        then E T.empty
        else E t
    | T.Node node ->
        if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
          let (true_, false_) =
            if select_key_bit key node.mask then
              (remove_ne_exact key node.true_, E node.false_)
            else (E node.true_, remove_ne_exact key node.false_)
          in
          rebuild_branch
            t
            node.prefix
            node.mask
            ~node_true:node.true_
            ~node_false:node.false_
            ~true_
            ~false_
        else E t

  let remove_exact key (E t) =
    match t with
    | T.Empty ->
        empty
    | T.Leaf _ as t ->
        remove_ne_exact key t
    | T.Node _ as t ->
        remove_ne_exact key t

  let rec replace_subtree_ne ~key ~id value t =
    match t with
    | T.Leaf leaf ->
        if leaf.id == id then T.leaf ~key:leaf.key ~mask:leaf.mask value else t
    | T.Node node ->
        if node.id == id then
          T.leaf
            ~key:(P.prefix_key node.prefix node.mask)
            ~mask:node.mask
            value
        else if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
          let (true_, false_) =
            if select_key_bit key node.mask then
              (replace_subtree_ne ~key ~id value node.true_, node.false_)
            else (node.true_, replace_subtree_ne ~key ~id value node.false_)
          in
          rebuild_ne_branch
            t
            node.prefix
            node.mask
            ~node_true:node.true_
            ~node_false:node.false_
            ~true_
            ~false_
        else t

  let replace_subtree ~replaced:(E replaced) value t =
    let replace_subtree_aux ~key ~id value (E t) =
      match t with
      | T.Empty ->
          empty
      | T.Leaf _ as t ->
          E (replace_subtree_ne ~key ~id value t)
      | T.Node _ as t ->
          E (replace_subtree_ne ~key ~id value t)
    in
    match replaced with
    | T.Empty ->
        t
    | T.Leaf leaf ->
        replace_subtree_aux ~key:leaf.key ~id:leaf.id value t
    | T.Node node ->
        replace_subtree_aux
          ~key:(P.prefix_key node.prefix node.mask)
          ~id:node.id
          value
          t

  let rec fold_ne :
      (key -> mask -> value -> 'a -> 'a) -> T.not_empty T.t -> 'a -> 'a =
   fun f t acc ->
    match t with
    | T.Leaf {key; mask; value; _} ->
        f key mask value acc
    | T.Node node ->
        let acc = fold_ne f node.false_ acc in
        fold_ne f node.true_ acc

  let fold f (E t) acc =
    match t with
    | T.Empty ->
        acc
    | T.Leaf _ as t ->
        fold_ne f t acc
    | T.Node _ as t ->
        fold_ne f t acc

  module T_id = struct
    type t = T.not_empty T.t

    let hash = T.id

    let equal t1 t2 = T.id t1 == T.id t2
  end

  module Map_cache = Ephemeron.K1.Make (T_id)

  module type Map_Reduce = sig
    type result

    val default : result

    val map : t -> key -> T.value -> result

    val reduce : t -> result -> result -> result
  end

  module Map_Reduce (M : Map_Reduce) = struct
    let cache : M.result Map_cache.t = Map_cache.create 10

    let rec map_reduce_ne t =
      match Map_cache.find_opt cache t with
      | Some v ->
          v
      | None ->
          let v =
            match t with
            | T.Leaf leaf ->
                M.map (E t) leaf.key leaf.value
            | T.Node node ->
                let v_true = map_reduce_ne node.true_ in
                let v_false = map_reduce_ne node.false_ in
                M.reduce (E t) v_true v_false
          in
          Map_cache.add cache t v ; v

    let run (E t) =
      match t with
      | T.Empty ->
          M.default
      | T.Leaf _ as t ->
          map_reduce_ne t
      | T.Node _ as t ->
          map_reduce_ne t

    let rec filter_ne f t =
      let result = map_reduce_ne t in
      if f result then E t
      else
        match t with
        | T.Leaf _ ->
            empty
        | T.Node node ->
            let true_ = filter_ne f node.true_ in
            let false_ = filter_ne f node.false_ in
            rebuild_branch
              t
              node.prefix
              node.mask
              ~node_true:node.true_
              ~node_false:node.false_
              ~true_
              ~false_

    let filter f (E t) =
      match t with
      | T.Empty ->
          empty
      | T.Leaf _ as t ->
          filter_ne f t
      | T.Node _ as t ->
          filter_ne f t
  end

  (* Packing in the existential *)

  let mem key (E t) = mem key t

  let mem_exact key (E t) = mem_exact key t

  let find key (E t) = find key t

  let singleton ~key ~value ~mask = E (singleton ~key ~value ~mask)

  let add combine ~key ~value ?mask (E t) = E (add combine ~key ~value ?mask t)
end
[@@inline]

module type S = sig
  type key

  type value

  type mask

  type t

  val equal : t -> t -> bool

  val empty : t

  val singleton : key:key -> value:value -> mask:mask -> t

  val add :
    (value -> value -> value) -> key:key -> value:value -> ?mask:mask -> t -> t

  val remove : key -> t -> t

  val remove_exact : key -> t -> t

  val remove_prefix : key -> mask -> t -> t

  val mem : key -> t -> bool

  val mem_exact : key -> t -> bool

  val find : key -> t -> value option

  val replace_subtree : replaced:t -> value -> t -> t

  val fold : (key -> mask -> value -> 'a -> 'a) -> t -> 'a -> 'a

  module type Map_Reduce = sig
    type result

    val default : result

    val map : t -> key -> value -> result

    val reduce : t -> result -> result -> result
  end

  module Map_Reduce (M : Map_Reduce) : sig
    val run : t -> M.result

    val filter : (M.result -> bool) -> t -> t
  end
end

module Make_LE (V : Value) = Make (LE_prefix) (V)
module Make_BE (V : Value) = Make (BE_prefix) (V)
module Make_BE_gen (V : Value) (B : Bits) = Make (BE_gen_prefix (B)) (V)
module Make_BE_sized (V : Value) (S : Size) =
  Make (BE_gen_prefix (Bits (S))) (V)
src/lib_stdlib/hashPtree.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Ptree_sig.
  Module Value.
    Record signature {t : Type} := {
      t := t;
      equal : t -> t -> bool;
      hash : t -> Z;
    }.
    Arguments signature : clear implicits.
  End Value.
  
  Inductive prefix_order : Type :=
  | Equal : prefix_order
  | Shorter : prefix_order
  | Longer : prefix_order
  | Different : prefix_order.
  
  Module Prefix.
    Record signature {key prefix mask : Type} := {
      key := key;
      prefix := prefix;
      mask := mask;
      equal_key : key -> key -> bool;
      equal_mask : mask -> mask -> bool;
      equal_prefix : prefix -> prefix -> bool;
      hash_key : key -> Z;
      hash_mask : mask -> Z;
      hash_prefix : prefix -> Z;
      full_length_mask : mask;
      strictly_shorter_mask : mask -> mask -> bool;
      key_prefix : key -> prefix;
      prefix_key : prefix -> mask -> key;
      match_prefix : key -> prefix -> mask -> bool;
      select_bit : prefix -> mask -> bool;
      common_mask : prefix -> prefix -> mask;
      apply_mask : prefix -> mask -> prefix;
      compare_prefix : mask -> prefix -> mask -> prefix -> prefix_order;
    }.
    Arguments signature : clear implicits.
  End Prefix.
  
  Module S.
    Record signature {key prefix mask value not_empty empty t : Type} := {
      key := key;
      prefix := prefix;
      mask := mask;
      value := value;
      not_empty := not_empty;
      empty := empty;
      polymorphic_abstract_type;
      leaf : key -> mask -> value -> t not_empty;
      node : prefix -> mask -> (t not_empty) -> (t not_empty) -> t not_empty;
      empty : t empty;
      equal : (t not_empty) -> (t not_empty) -> bool;
      fast_partial_equal : (t not_empty) -> (t not_empty) -> bool;
      id : (t not_empty) -> Z;
    }.
    Arguments signature : clear implicits.
  End S.
End Ptree_sig.

Module Shared_tree.
  Import Ptree_sig.
  
  Record int3 := {
    i1 : Z;
    i2 : Z;
    i3 : Z }.
  
  Definition h3 : int3 := {| i1 := 0; i2 := 0; i3 := 0 |}.
  
  Definition hash3int (x1 : Z) (x2 : Z) (x3 : Z) : Z :=
    set_field;
    set_field;
    set_field;
    Stdlib.Hashtbl.hash h3.
  
  Record int4 := {
    i1 : Z;
    i2 : Z;
    i3 : Z;
    i4 : Z }.
  
  Definition h4 : int4 := {| i1 := 0; i2 := 0; i3 := 0; i4 := 0 |}.
  
  Definition hash4int (x1 : Z) (x2 : Z) (x3 : Z) (x4 : Z) : Z :=
    set_field;
    set_field;
    set_field;
    set_field;
    Stdlib.Hashtbl.hash h4.
End Shared_tree.

Module Value.
  Record signature {t : Type} := {
    t := t;
    equal : t -> t -> bool;
    hash : t -> Z;
  }.
  Arguments signature : clear implicits.
End Value.

Module Bits.
  Record signature {t : Type} := {
    t := t;
    lnot : t -> t;
    land : t -> t -> t;
    lxor : t -> t -> t;
    lor : t -> t -> t;
    lsr : t -> Z -> t;
    lsl : t -> Z -> t;
    pred : t -> t;
    less_than : t -> t -> bool;
    highest_bit : t -> t;
    equal : t -> t -> bool;
    hash : t -> Z;
    zero : t;
    one : t;
    size : Z;
  }.
  Arguments signature : clear implicits.
End Bits.

Module Size.
  Record signature := {
    size : Z;
  }.
End Size.

Module LE_prefix.
  Definition key := Z.
  
  Definition mask := Z.
  
  Definition prefix := Z.
  
  Definition equal_key {A : Type} : A -> A -> bool := Stdlib.op_eq_eq.
  
  Definition equal_mask {A : Type} : A -> A -> bool := Stdlib.op_eq_eq.
  
  Definition equal_prefix {A : Type} : A -> A -> bool := Stdlib.op_eq_eq.
  
  Definition hash_key {A : Type} (x : A) : A := x.
  
  Definition hash_mask {A : Type} (x : A) : A := x.
  
  Definition hash_prefix {A : Type} (x : A) : A := x.
  
  Definition full_length_mask : Z := Z.lxor (-1) (Z.shiftr (-1) 1).
  
  Definition strictly_shorter_mask (m1 : mask) (m2 : mask) : bool :=
    OCaml.Stdlib.lt m1 m2.
  
  Definition select_bit (prefix : Z) (mask : Z) : bool :=
    Stdlib.op_exclamation_eq (Z.land prefix mask) 0.
  
  Definition apply_mask (prefix : Z) (mask : Z) : Z :=
    Z.land prefix (Z.sub mask 1).
  
  Definition match_prefix (key : Z) (prefix : Z) (mask : Z) : bool :=
    Stdlib.op_eq_eq (apply_mask key mask) prefix.
  
  Definition lowest_bit (x : Z) : Z := Z.land x (Z.opp x).
  
  Definition common_mask (p0 : Z) (p1 : Z) : Z := lowest_bit (Z.lxor p0 p1).
  
  Definition key_prefix {A : Type} (x : A) : A := x.
  
  Definition prefix_key {A B : Type} (p : A) (_m : B) : A := p.
  
  Definition smaller_set_mask (m1 : Z) (m2 : Z) : Z :=
    Z.land (Z.sub m1 1) (Z.sub m2 1).
  
  Definition compare_prefix (m1 : Z) (p1 : Z) (m2 : Z) (p2 : Z)
    : Ptree_sig.prefix_order :=
    let min_mask := smaller_set_mask m1 m2 in
    let applied_p1 := Z.land p1 min_mask in
    let applied_p2 := Z.land p2 min_mask in
    if equiv_decb applied_p1 applied_p2 then
      if OCaml.Stdlib.lt m1 m2 then
        Ptree_sig.Shorter
      else
        if OCaml.Stdlib.gt m1 m2 then
          Ptree_sig.Longer
        else
          Ptree_sig.Equal
    else
      Ptree_sig.Different.
End LE_prefix.

Module BE_prefix.
  Definition key := Z.
  
  Definition mask := Z.
  
  Definition prefix := Z.
  
  Definition equal_key {A : Type} : A -> A -> bool := Stdlib.op_eq_eq.
  
  Definition equal_mask {A : Type} : A -> A -> bool := Stdlib.op_eq_eq.
  
  Definition equal_prefix {A : Type} : A -> A -> bool := Stdlib.op_eq_eq.
  
  Definition hash_key {A : Type} (x : A) : A := x.
  
  Definition hash_mask {A : Type} (x : A) : A := x.
  
  Definition hash_prefix {A : Type} (x : A) : A := x.
  
  Definition full_length_mask : Z := 1.
  
  Definition strictly_shorter_mask (m1 : mask) (m2 : mask) : bool :=
    OCaml.Stdlib.gt m1 m2.
  
  Definition select_bit (prefix : Z) (mask : Z) : bool :=
    Stdlib.op_exclamation_eq (Z.land prefix mask) 0.
  
  Module Nativeint_infix.
    Definition lor : nativeint -> nativeint -> nativeint :=
      Stdlib.Nativeint.logor.
    
    Definition lsr : nativeint -> Z -> nativeint :=
      Stdlib.Nativeint.shift_right_logical.
    
    Definition land : nativeint -> nativeint -> nativeint :=
      Stdlib.Nativeint.logand.
    
    Definition lnot : nativeint -> nativeint := Stdlib.Nativeint.lognot.
    
    Definition lxor : nativeint -> nativeint -> nativeint :=
      Stdlib.Nativeint.logxor.
    
    Definition op_minus : nativeint -> nativeint -> nativeint :=
      Stdlib.Nativeint.sub.
  End Nativeint_infix.
  
  Definition apply_mask (prefix : Z) (mask : Z) : Z :=
    let prefix := Stdlib.Nativeint.of_int prefix in
    let mask := Stdlib.Nativeint.of_int mask in
    Stdlib.Nativeint.to_int
      (Nativeint_infix.land prefix
        (Nativeint_infix.lnot (Nativeint_infix.op_minus mask 1))).
  
  Definition match_prefix (key : Z) (prefix : Z) (mask : Z) : bool :=
    Stdlib.op_eq_eq (apply_mask key mask) prefix.
  
  Definition highest_bit (x : nativeint) : Z :=
    let x := Nativeint_infix.lor x (Nativeint_infix.lsr x 1) in
    let x := Nativeint_infix.lor x (Nativeint_infix.lsr x 2) in
    let x := Nativeint_infix.lor x (Nativeint_infix.lsr x 4) in
    let x := Nativeint_infix.lor x (Nativeint_infix.lsr x 8) in
    let x := Nativeint_infix.lor x (Nativeint_infix.lsr x 16) in
    let x :=
      if OCaml.Stdlib.gt Stdlib.Sys.word_size 32 then
        Nativeint_infix.lor x (Nativeint_infix.lsr x 32)
      else
        x in
    Stdlib.Nativeint.to_int
      (Nativeint_infix.op_minus x (Nativeint_infix.lsr x 1)).
  
  Definition common_mask (p0 : Z) (p1 : Z) : Z :=
    let p0 := Stdlib.Nativeint.of_int p0 in
    let p1 := Stdlib.Nativeint.of_int p1 in
    highest_bit (Nativeint_infix.lxor p0 p1).
  
  Definition key_prefix {A : Type} (x : A) : A := x.
  
  Definition prefix_key {A B : Type} (p : A) (_m : B) : A := p.
  
  Definition smaller_set_mask (m1 : nativeint) (m2 : nativeint) : nativeint :=
    Nativeint_infix.land (Nativeint_infix.lnot (Nativeint_infix.op_minus m1 1))
      (Nativeint_infix.lnot (Nativeint_infix.op_minus m2 1)).
  
  Definition compare_prefix (m1 : Z) (p1 : Z) (m2 : Z) (p2 : Z)
    : Ptree_sig.prefix_order :=
    let m1 := Stdlib.Nativeint.of_int m1 in
    let m2 := Stdlib.Nativeint.of_int m2 in
    let p1 := Stdlib.Nativeint.of_int p1 in
    let p2 := Stdlib.Nativeint.of_int p2 in
    let min_mask := smaller_set_mask m1 m2 in
    let applied_p1 := Nativeint_infix.land p1 min_mask in
    let applied_p2 := Nativeint_infix.land p2 min_mask in
    if equiv_decb applied_p1 applied_p2 then
      if OCaml.Stdlib.gt m1 m2 then
        Ptree_sig.Shorter
      else
        if OCaml.Stdlib.lt m1 m2 then
          Ptree_sig.Longer
        else
          Ptree_sig.Equal
    else
      Ptree_sig.Different.
End BE_prefix.

Module S.
  Record signature {key value mask t : Type} := {
    key := key;
    value := value;
    mask := mask;
    t := t;
    equal : t -> t -> bool;
    empty : t;
    singleton : key -> value -> mask -> t;
    add : (value -> value -> value) -> key -> value -> (option mask) -> t -> t;
    remove : key -> t -> t;
    remove_exact : key -> t -> t;
    remove_prefix : key -> mask -> t -> t;
    mem : key -> t -> bool;
    mem_exact : key -> t -> bool;
    find : key -> t -> option value;
    replace_subtree : t -> value -> t -> t;
    fold : forall {a : Type}, (key -> mask -> value -> a -> a) -> t -> a -> a;
    module_type;
    Map_Reduce : functor;
  }.
  Arguments signature : clear implicits.
End S.
src/lib_stdlib/hashPtree.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Hash Consed Patricia Trees *)

module type Value = sig
  type t

  val equal : t -> t -> bool

  val hash : t -> int
end

module type Bits = sig
  type t

  val lnot : t -> t

  val ( land ) : t -> t -> t

  val ( lxor ) : t -> t -> t

  val ( lor ) : t -> t -> t

  val ( lsr ) : t -> int -> t

  val ( lsl ) : t -> int -> t

  val pred : t -> t

  val less_than : t -> t -> bool

  val highest_bit : t -> t

  val equal : t -> t -> bool

  val hash : t -> int

  val zero : t

  val one : t

  val size : int
end

module type Size = sig
  val size : int
end

module Bits (S : Size) : sig
  include Bits

  val of_z : Z.t -> t

  val to_z : t -> Z.t
end

module type S = sig
  type key

  type value

  type mask

  type t

  val equal : t -> t -> bool

  val empty : t

  val singleton : key:key -> value:value -> mask:mask -> t

  (** [add combine ~key ~value ?mask t]
      Add a new key in the tree. If mask is specified, then we consider the whole
      subtree stemming from key.

      Assumes that forall x, [combine x x = x]
  *)
  val add :
    (value -> value -> value) -> key:key -> value:value -> ?mask:mask -> t -> t

  (** [remove key t] Remove the entire subtree speficied by the mask associated with
      key in the tree. Otherwise remove only the key *)
  val remove : key -> t -> t

  (** [remove_exact key t] Remove the largest subtree
      stemming from key. Otherwise remove only the key *)
  val remove_exact : key -> t -> t

  val remove_prefix : key -> mask -> t -> t

  (** [mem key t] return true if the entire subtree speficied by the mask associated with
      key is in the tree *)
  val mem : key -> t -> bool

  (** [mem_exact key t] return true if the largest subtree stemming from key is in the tree *)
  val mem_exact : key -> t -> bool

  val find : key -> t -> value option

  (** [let new_tree = replace_subtree ~replaced value tree]
      If replaced is a subtree of tree (for instance provided
      by Map_reduce.reduce)
      let n and m be the smallest integers such that for all
      keys part of replaced, n is smaller and n + 2^m is strictly larger.
      Then new_tree is the map such that for each key, n <= key < n + 2^m,
      [find key new_tree] is [Some value] *)
  val replace_subtree : replaced:t -> value -> t -> t

  val fold : (key -> mask -> value -> 'a -> 'a) -> t -> 'a -> 'a

  module type Map_Reduce = sig
    type result

    val default : result

    val map : t -> key -> value -> result

    val reduce : t -> result -> result -> result
  end

  module Map_Reduce (M : Map_Reduce) : sig
    (** run has a constant amortized complexity *)
    val run : t -> M.result

    (** [filter f t] assumes that the composition of [f] and [reduce]
        is monotonic i.e.
        for any [t], if [f (reduce t x y) = true] then [f x = true]
        and [f y = true].

        For efficiency reason, you should also ensure that
        if [f (reduce t x y) = false] then either [f x = false] or
        [f y = false].
        It is not required for correctness, but is needed to get a
        constant amortized complexity.
    *)
    val filter : (M.result -> bool) -> t -> t
  end
end

module Make_LE (V : Value) :
  S with type key = int and type value = V.t and type mask = int

module Make_BE (V : Value) :
  S with type key = int and type value = V.t and type mask = int

module Make_BE_gen (V : Value) (B : Bits) :
  S with type key = B.t and type value = V.t and type mask = B.t

module Make_BE_sized (V : Value) (S : Size) :
  S with type key = Bits(S).t and type value = V.t and type mask = Bits(S).t
src/lib_stdlib/hashPtree.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

module_type

module_type

unhandled_module

module_type

unhandled_module

unhandled_module

unhandled_module

unhandled_module
src/lib_stdlib/lwt_canceler.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type t = {
  cancellation : unit Lwt_condition.t;
  cancellation_complete : unit Lwt_condition.t;
  mutable cancel_hook : unit -> unit Lwt.t;
  mutable canceling : bool;
  mutable canceled : bool;
}

let create () =
  let cancellation = Lwt_condition.create () in
  let cancellation_complete = Lwt_condition.create () in
  {
    cancellation;
    cancellation_complete;
    cancel_hook = (fun () -> Lwt.return_unit);
    canceling = false;
    canceled = false;
  }

let cancel st =
  if st.canceled then Lwt.return_unit
  else if st.canceling then Lwt_condition.wait st.cancellation_complete
  else (
    st.canceling <- true ;
    Lwt_condition.broadcast st.cancellation () ;
    Lwt.finalize st.cancel_hook (fun () ->
        st.canceled <- true ;
        Lwt_condition.broadcast st.cancellation_complete () ;
        Lwt.return_unit) )

let on_cancel st cb =
  let hook = st.cancel_hook in
  st.cancel_hook <- (fun () -> hook () >>= cb)

let cancellation st =
  if st.canceling then Lwt.return_unit else Lwt_condition.wait st.cancellation

let canceled st = st.canceling
src/lib_stdlib/lwt_canceler.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Record t := {
  cancellation : Lwt_condition.t unit;
  cancellation_complete : Lwt_condition.t unit;
  cancel_hook : unit -> Lwt.t unit;
  canceling : bool;
  canceled : bool }.

Definition create (function_parameter : unit) : t :=
  match function_parameter with
  | tt =>
    let cancellation := Lwt_condition.create tt in
    let cancellation_complete := Lwt_condition.create tt in
    {| cancellation := cancellation;
      cancellation_complete := cancellation_complete;
      cancel_hook :=
        fun function_parameter =>
          match function_parameter with
          | tt => Lwt.return_unit
          end; canceling := false; canceled := false |}
  end.

Definition cancel (st : t) : Lwt.t unit :=
  if canceled st then
    Lwt.return_unit
  else
    if canceling st then
      Lwt_condition.wait None (cancellation_complete st)
    else
      set_field;
      Lwt_condition.broadcast (cancellation st) tt;
      Lwt.finalize (cancel_hook st)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            set_field;
            Lwt_condition.broadcast (cancellation_complete st) tt;
            Lwt.return_unit
          end).

Definition on_cancel (st : t) (cb : unit -> Lwt.t unit) : unit :=
  let hook := cancel_hook st in
  set_field.

Definition cancellation (st : t) : Lwt.t unit :=
  if canceling st then
    Lwt.return_unit
  else
    Lwt_condition.wait None (cancellation st).

Definition canceled (st : t) : bool := canceling st.
src/lib_stdlib/lwt_canceler.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A [Canceler.t] is a three-states synchronization object with transitions
    "waiting -> canceling -> canceled", starting in waiting state. A chain
    of hooks can be attached to the canceler. Hooks are triggered when
    switching to the canceling state. The canceler switches to canceled state
    when the hooks have completed. *)

type t

(** [create t] returns a canceler in waiting state. *)
val create : unit -> t

(** If [t] is in wait state, [cancel t] triggers the cancellation process:
    1. it switches to canceling state,
    2. it executes the hooks sequentially in separate Lwt threads,
    3. it waits for hooks execution to complete,
    4. it switches to cancel state.
    If [t] is in canceled state, [cancel t] is determined immediately.
    If [t] is in canceling state, [cancel t] is determined at the end of the
    cancellation process. *)
val cancel : t -> unit Lwt.t

(** [cancellation t] is determined when [t] is in canceling or canceled state. *)
val cancellation : t -> unit Lwt.t

(** [on_cancel t hook] adds [hook] to the end of the current chain. *)
val on_cancel : t -> (unit -> unit Lwt.t) -> unit

(** [canceled t] is [true] iff [t] is canceled or canceling. *)
val canceled : t -> bool
src/lib_stdlib/lwt_canceler.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create : unit -> t.

Parameter cancel : t -> Lwt.t unit.

Parameter cancellation : t -> Lwt.t unit.

Parameter on_cancel : t -> (unit -> Lwt.t unit) -> unit.

Parameter canceled : t -> bool.
src/lib_stdlib/lwt_dropbox.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

exception Closed

type 'a t = {
  mutable data : 'a option;
  mutable closed : bool;
  mutable put_waiter : (unit Lwt.t * unit Lwt.u) option;
}

let create () = {data = None; closed = false; put_waiter = None}

let notify_put dropbox =
  match dropbox.put_waiter with
  | None ->
      ()
  | Some (_waiter, wakener) ->
      dropbox.put_waiter <- None ;
      Lwt.wakeup_later wakener ()

let put dropbox elt =
  if dropbox.closed then raise Closed
  else (
    dropbox.data <- Some elt ;
    notify_put dropbox )

let peek dropbox = dropbox.data

let close dropbox =
  if not dropbox.closed then (
    dropbox.closed <- true ;
    notify_put dropbox )

let wait_put ~timeout dropbox =
  match dropbox.put_waiter with
  | Some (waiter, _wakener) ->
      Lwt.choose [timeout; Lwt.protected waiter]
  | None ->
      let (waiter, wakener) = Lwt.wait () in
      dropbox.put_waiter <- Some (waiter, wakener) ;
      Lwt.choose [timeout; Lwt.protected waiter]

let rec take dropbox =
  match dropbox.data with
  | Some elt ->
      dropbox.data <- None ;
      Lwt.return elt
  | None ->
      if dropbox.closed then Lwt.fail Closed
      else
        wait_put ~timeout:(Lwt_utils.never_ending ()) dropbox
        >>= fun () -> take dropbox

let rec take_with_timeout timeout dropbox =
  match dropbox.data with
  | Some elt ->
      Lwt.cancel timeout ;
      dropbox.data <- None ;
      Lwt.return_some elt
  | None ->
      if Lwt.is_sleeping timeout then
        if dropbox.closed then Lwt.fail Closed
        else
          wait_put ~timeout dropbox
          >>= fun () -> take_with_timeout timeout dropbox
      else Lwt.return_none
src/lib_stdlib/lwt_dropbox.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Record t {a : Type} := {
  data : option a;
  closed : bool;
  put_waiter : option ((Lwt.t unit) * (Lwt.u unit)) }.
Arguments t : clear implicits.

Definition create {A : Type} (function_parameter : unit) : t A :=
  match function_parameter with
  | tt => {| data := None; closed := false; put_waiter := None |}
  end.

Definition notify_put {A : Type} (dropbox : t A) : unit :=
  match put_waiter dropbox with
  | None => tt
  | Some (_waiter, wakener) =>
    set_field;
    Lwt.wakeup_later wakener tt
  end.

Definition put {A : Type} (dropbox : t A) (elt : A) : unit :=
  if closed dropbox then
    Stdlib.raise Closed
  else
    set_field;
    notify_put dropbox.

Definition peek {A : Type} (dropbox : t A) : option A := data dropbox.

Definition close {A : Type} (dropbox : t A) : unit :=
  if negb (closed dropbox) then
    set_field;
    notify_put dropbox
  else
    tt.

Definition wait_put {A : Type} (timeout : Lwt.t unit) (dropbox : t A)
  : Lwt.t unit :=
  match put_waiter dropbox with
  | Some (waiter, _wakener) =>
    Lwt.choose (cons timeout (cons (Lwt.protected waiter) []))
  | None =>
    match Lwt.wait tt with
    | (waiter, wakener) =>
      set_field;
      Lwt.choose (cons timeout (cons (Lwt.protected waiter) []))
    end
  end.

Fixpoint take {A : Type} (dropbox : t A) : Lwt.t A :=
  match data dropbox with
  | Some elt =>
    set_field;
    Lwt._return elt
  | None =>
    if closed dropbox then
      Lwt.fail Closed
    else
      Lwt.Infix.op_gt_gt_eq
        (wait_put (Tezos_stdlib.Lwt_utils.never_ending tt) dropbox)
        (fun function_parameter =>
          match function_parameter with
          | tt => take dropbox
          end)
  end.

Fixpoint take_with_timeout {A : Type} (timeout : Lwt.t unit) (dropbox : t A)
  : Lwt.t (option A) :=
  match data dropbox with
  | Some elt =>
    Lwt.cancel timeout;
    set_field;
    Lwt.return_some elt
  | None =>
    if Lwt.is_sleeping timeout then
      if closed dropbox then
        Lwt.fail Closed
      else
        Lwt.Infix.op_gt_gt_eq (wait_put timeout dropbox)
          (fun function_parameter =>
            match function_parameter with
            | tt => take_with_timeout timeout dropbox
            end)
    else
      Lwt.return_none
  end.
src/lib_stdlib/lwt_dropbox.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A 'dropbox' with a single element. *)

(** Type of dropbox holding a value of type ['a] *)
type 'a t

(** Create an empty dropbox. *)
val create : unit -> 'a t

(** Put an element inside the dropbox. If the dropbox was already
    containing an element, the old element is replaced by the new one.
    The function might return [Closed] if the dropbox has been closed
    with [close]. *)
val put : 'a t -> 'a -> unit

(** Wait until the dropbox contains an element, then returns the elements.
    The elements is removed from the dropbox. The function might return
    [Closed] if the dropbox is empty and closed. *)
val take : 'a t -> 'a Lwt.t

(** Like [take] except that it returns [None] after [timeout seconds]
    if the dropbox is still empty. *)
val take_with_timeout : unit Lwt.t -> 'a t -> 'a option Lwt.t

(** Read the current element of the dropbox without removing it. It
    immediately returns [None] if the dropbox is empty. *)
val peek : 'a t -> 'a option

(** The exception returned when trying to access a 'closed' dropbox. *)
exception Closed

(** Close the dropbox. It terminates all the waiting reader with the
    exception [Closed]. All further read or write will also immediately
    fail with [Closed], except if the dropbox is not empty when
    [close] is called. In that can, a single (and last) [take] will
    succeed. *)
val close : 'a t -> unit
src/lib_stdlib/lwt_dropbox.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (a : Type), Type.

Parameter create : forall {a : Type}, unit -> t a.

Parameter put : forall {a : Type}, (t a) -> a -> unit.

Parameter take : forall {a : Type}, (t a) -> Lwt.t a.

Parameter take_with_timeout : forall {a : Type},
(Lwt.t unit) -> (t a) -> Lwt.t (option a).

Parameter peek : forall {a : Type}, (t a) -> option a.

exception

Parameter close : forall {a : Type}, (t a) -> unit.
src/lib_stdlib/lwt_idle_waiter.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type t = {
  mutable pending_tasks : unit Lwt.u list;
  mutable pending_idle : (unit -> unit Lwt.t) list;
  mutable running_tasks : int;
  mutable running_idle : bool;
  mutable prevent_tasks : bool;
}

let create () =
  {
    pending_tasks = [];
    pending_idle = [];
    running_tasks = 0;
    running_idle = false;
    prevent_tasks = false;
  }

let rec may_run_idle_tasks w =
  if w.running_tasks = 0 && not w.running_idle then
    match w.pending_idle with
    | [] ->
        ()
    | pending_idle ->
        w.running_idle <- true ;
        w.prevent_tasks <- false ;
        w.pending_idle <- [] ;
        Lwt.async (fun () ->
            let pending_idle = List.rev pending_idle in
            Lwt_list.iter_s (fun f -> f ()) pending_idle
            >>= fun () ->
            w.running_idle <- false ;
            let pending_tasks = List.rev w.pending_tasks in
            w.pending_tasks <- [] ;
            List.iter (fun u -> Lwt.wakeup u ()) pending_tasks ;
            may_run_idle_tasks w ;
            Lwt.return_unit)

let wrap_error f =
  Lwt.catch
    (fun () -> f () >>= fun r -> Lwt.return_ok r)
    (fun exn -> Lwt.return_error exn)

let unwrap_error = function Ok r -> Lwt.return r | Error exn -> Lwt.fail exn

let wakeup_error u = function
  | Ok r ->
      Lwt.wakeup u r
  | Error exn ->
      Lwt.wakeup_exn u exn

let rec task w f =
  if w.running_idle || w.prevent_tasks then (
    let (t, u) = Lwt.task () in
    w.pending_tasks <- u :: w.pending_tasks ;
    t >>= fun () -> task w f )
  else (
    w.running_tasks <- w.running_tasks + 1 ;
    wrap_error f
    >>= fun res ->
    w.running_tasks <- w.running_tasks - 1 ;
    may_run_idle_tasks w ;
    unwrap_error res )

let when_idle w f =
  let (t, u) = Lwt.task () in
  let canceled = ref false in
  Lwt.on_cancel t (fun () -> canceled := true) ;
  let f () =
    if !canceled then Lwt.return_unit
    else wrap_error f >>= fun res -> wakeup_error u res ; Lwt.return_unit
  in
  w.pending_idle <- f :: w.pending_idle ;
  may_run_idle_tasks w ;
  t

let force_idle w f =
  w.prevent_tasks <- true ;
  when_idle w f
src/lib_stdlib/lwt_idle_waiter.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Record t := {
  pending_tasks : list (Lwt.u unit);
  pending_idle : list (unit -> Lwt.t unit);
  running_tasks : Z;
  running_idle : bool;
  prevent_tasks : bool }.

Definition create (function_parameter : unit) : t :=
  match function_parameter with
  | tt =>
    {| pending_tasks := []; pending_idle := []; running_tasks := 0;
      running_idle := false; prevent_tasks := false |}
  end.

Fixpoint may_run_idle_tasks (w : t) : unit :=
  if andb (equiv_decb (running_tasks w) 0) (negb (running_idle w)) then
    match pending_idle w with
    | [] => tt
    | pending_idle =>
      set_field;
      set_field;
      set_field;
      Lwt.async
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let pending_idle := List.rev pending_idle in
            Lwt.Infix.op_gt_gt_eq (Lwt_list.iter_s (fun f => f tt) pending_idle)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  set_field;
                  let pending_tasks := List.rev (pending_tasks w) in
                  set_field;
                  Stdlib.List.iter (fun u => Lwt.wakeup u tt) pending_tasks;
                  may_run_idle_tasks w;
                  Lwt.return_unit
                end)
          end)
    end
  else
    tt.

Definition wrap_error {A : Type} (f : unit -> Lwt.t A)
  : Lwt.t (Result.result A exn) :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt => Lwt.Infix.op_gt_gt_eq (f tt) (fun r => Lwt.return_ok r)
      end) (fun exn => Lwt.return_error exn).

Definition unwrap_error {A : Type} (function_parameter : sum A exn) : Lwt.t A :=
  match function_parameter with
  | inl r => Lwt._return r
  | inr exn => Lwt.fail exn
  end.

Definition wakeup_error {A : Type}
  (u : Lwt.u A) (function_parameter : sum A exn) : unit :=
  match function_parameter with
  | inl r => Lwt.wakeup u r
  | inr exn => Lwt.wakeup_exn u exn
  end.

Fixpoint task {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
  if orb (running_idle w) (prevent_tasks w) then
    match Lwt.task tt with
    | (t, u) =>
      set_field;
      Lwt.Infix.op_gt_gt_eq t
        (fun function_parameter =>
          match function_parameter with
          | tt => task w f
          end)
    end
  else
    set_field;
    Lwt.Infix.op_gt_gt_eq (wrap_error f)
      (fun res =>
        set_field;
        may_run_idle_tasks w;
        unwrap_error res).

Definition when_idle {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
  match Lwt.task tt with
  | (t, u) =>
    let canceled := Stdlib.ref false in
    Lwt.on_cancel t
      (fun function_parameter =>
        match function_parameter with
        | tt => Stdlib.op_colon_eq canceled true
        end);
    let f (function_parameter : unit) : Lwt.t unit :=
      match function_parameter with
      | tt =>
        if Stdlib.op_exclamation canceled then
          Lwt.return_unit
        else
          Lwt.Infix.op_gt_gt_eq (wrap_error f)
            (fun res =>
              wakeup_error u res;
              Lwt.return_unit)
      end in
    set_field;
    may_run_idle_tasks w;
    t
  end.

Definition force_idle {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
  set_field;
  when_idle w f.
src/lib_stdlib/lwt_idle_waiter.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A lightweight scheduler to run tasks concurrently as well as
    special callbacks that must be run in mutual exclusion with the
    tasks (and each other). *)
type t

(** Creates a new task / idle callback scheduler *)
val create : unit -> t

(** Schedule a task to be run as soon as no idle callbacks is
    running, or as soon as the next idle callback has been run if it
    was scheduled by {!force_idle}. *)
val task : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t

(** Runs a callback as soon as no task is running. Does not prevent
    new tasks from being scheduled, the calling code should ensure
    that some idle time will eventually come. Calling this function
    from inside the callback will result in a dead lock. *)
val when_idle : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t

(** Runs a callback as soon as possible. Lets all current tasks
    finish, but postpones all new tasks until the end of the
    callback. Calling this function from inside the callback will
    result in a dead lock. *)
val force_idle : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t
src/lib_stdlib/lwt_idle_waiter.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create : unit -> t.

Parameter task : forall {a : Type}, t -> (unit -> Lwt.t a) -> Lwt.t a.

Parameter when_idle : forall {a : Type}, t -> (unit -> Lwt.t a) -> Lwt.t a.

Parameter force_idle : forall {a : Type}, t -> (unit -> Lwt.t a) -> Lwt.t a.
src/lib_stdlib/lwt_pipe.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type 'a t = {
  queue : (int * 'a) Queue.t;
  mutable current_size : int;
  max_size : int;
  compute_size : 'a -> int;
  mutable closed : bool;
  mutable push_waiter : (unit Lwt.t * unit Lwt.u) option;
  mutable pop_waiter : (unit Lwt.t * unit Lwt.u) option;
  empty : unit Lwt_condition.t;
}

let push_overhead = 4 * (Sys.word_size / 8)

let create ?size () =
  let (max_size, compute_size) =
    match size with
    | None ->
        (max_int, fun _ -> 0)
    | Some (max_size, compute_size) ->
        (max_size, compute_size)
  in
  {
    queue = Queue.create ();
    current_size = 0;
    max_size;
    compute_size;
    closed = false;
    push_waiter = None;
    pop_waiter = None;
    empty = Lwt_condition.create ();
  }

let notify_push q =
  match q.push_waiter with
  | None ->
      ()
  | Some (_, w) ->
      q.push_waiter <- None ;
      Lwt.wakeup_later w ()

let notify_pop q =
  match q.pop_waiter with
  | None ->
      ()
  | Some (_, w) ->
      q.pop_waiter <- None ;
      Lwt.wakeup_later w ()

let wait_push q =
  match q.push_waiter with
  | Some (t, _) ->
      Lwt.protected t
  | None ->
      let (waiter, wakener) = Lwt.wait () in
      q.push_waiter <- Some (waiter, wakener) ;
      Lwt.protected waiter

let wait_pop q =
  match q.pop_waiter with
  | Some (t, _) ->
      Lwt.protected t
  | None ->
      let (waiter, wakener) = Lwt.wait () in
      q.pop_waiter <- Some (waiter, wakener) ;
      Lwt.protected waiter

let length {queue; _} = Queue.length queue

let is_empty {queue; _} = Queue.is_empty queue

let rec empty q =
  if is_empty q then Lwt.return_unit
  else Lwt_condition.wait q.empty >>= fun () -> empty q

exception Closed

let rec push ({closed; queue; current_size; max_size; compute_size; _} as q)
    elt =
  let elt_size = compute_size elt in
  if closed then Lwt.fail Closed
  else if current_size + elt_size < max_size || Queue.is_empty queue then (
    Queue.push (elt_size, elt) queue ;
    q.current_size <- current_size + elt_size ;
    notify_push q ;
    Lwt.return_unit )
  else wait_pop q >>= fun () -> push q elt

let push_now ({closed; queue; compute_size; current_size; max_size; _} as q)
    elt =
  if closed then raise Closed ;
  let elt_size = compute_size elt in
  (current_size + elt_size < max_size || Queue.is_empty queue)
  &&
  ( Queue.push (elt_size, elt) queue ;
    q.current_size <- current_size + elt_size ;
    notify_push q ;
    true )

exception Full

let push_now_exn q elt = if not (push_now q elt) then raise Full

let safe_push_now q elt = try push_now_exn q elt with _ -> ()

let rec pop ({closed; queue; empty; current_size; _} as q) =
  if not (Queue.is_empty queue) then (
    let (elt_size, elt) = Queue.pop queue in
    notify_pop q ;
    q.current_size <- current_size - elt_size ;
    if Queue.length queue = 0 then Lwt_condition.signal empty () ;
    Lwt.return elt )
  else if closed then Lwt.fail Closed
  else wait_push q >>= fun () -> pop q

let rec pop_with_timeout timeout q =
  if not (Queue.is_empty q.queue) then (
    Lwt.cancel timeout ;
    pop q >>= Lwt.return_some )
  else if Lwt.is_sleeping timeout then
    if q.closed then (Lwt.cancel timeout ; Lwt.fail Closed)
    else
      let waiter = wait_push q in
      Lwt.choose [timeout; Lwt.protected waiter]
      >>= fun () -> pop_with_timeout timeout q
  else Lwt.return_none

let rec peek ({closed; queue; _} as q) =
  if not (Queue.is_empty queue) then
    let (_elt_size, elt) = Queue.peek queue in
    Lwt.return elt
  else if closed then Lwt.fail Closed
  else wait_push q >>= fun () -> peek q

let peek_all {queue; closed; _} =
  if closed then []
  else List.rev (Queue.fold (fun acc (_, e) -> e :: acc) [] queue)

exception Empty

let pop_now_exn ({closed; queue; empty; current_size; _} as q) =
  if Queue.is_empty queue then if closed then raise Closed else raise Empty ;
  let (elt_size, elt) = Queue.pop queue in
  if Queue.length queue = 0 then Lwt_condition.signal empty () ;
  q.current_size <- current_size - elt_size ;
  notify_pop q ;
  elt

let pop_now q =
  match pop_now_exn q with exception Empty -> None | elt -> Some elt

let rec values_available q =
  if is_empty q then
    if q.closed then raise Closed
    else wait_push q >>= fun () -> values_available q
  else Lwt.return_unit

let rec pop_all_loop q acc =
  match pop_now_exn q with
  | exception Empty ->
      List.rev acc
  | e ->
      pop_all_loop q (e :: acc)

let pop_all q = pop q >>= fun e -> Lwt.return (pop_all_loop q [e])

let pop_all_now q = pop_all_loop q []

let close q =
  if not q.closed then (
    q.closed <- true ;
    notify_push q ;
    notify_pop q )

let rec iter q ~f =
  Lwt.catch
    (fun () -> pop q >>= fun elt -> f elt >>= fun () -> iter q ~f)
    (function Closed -> Lwt.return_unit | exn -> Lwt.fail exn)
src/lib_stdlib/lwt_pipe.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Record t {a : Type} := {
  queue : Stdlib.Queue.t (Z * a);
  current_size : Z;
  max_size : Z;
  compute_size : a -> Z;
  closed : bool;
  push_waiter : option ((Lwt.t unit) * (Lwt.u unit));
  pop_waiter : option ((Lwt.t unit) * (Lwt.u unit));
  empty : Lwt_condition.t unit }.
Arguments t : clear implicits.

Definition push_overhead : Z := Z.mul 4 (Z.div Stdlib.Sys.word_size 8).

Definition create {A : Type}
  (size : option (Z * (A -> Z))) (function_parameter : unit) : t A :=
  match function_parameter with
  | tt =>
    match
      match size with
      | None =>
        (Stdlib.max_int,
          (fun function_parameter =>
            match function_parameter with
            | _ => 0
            end))
      | Some (max_size, compute_size) => (max_size, compute_size)
      end with
    | (max_size, compute_size) =>
      {| queue := Stdlib.Queue.create tt; current_size := 0;
        max_size := max_size; compute_size := compute_size; closed := false;
        push_waiter := None; pop_waiter := None;
        empty := Lwt_condition.create tt |}
    end
  end.

Definition notify_push {A : Type} (q : t A) : unit :=
  match push_waiter q with
  | None => tt
  | Some (_, w) =>
    set_field;
    Lwt.wakeup_later w tt
  end.

Definition notify_pop {A : Type} (q : t A) : unit :=
  match pop_waiter q with
  | None => tt
  | Some (_, w) =>
    set_field;
    Lwt.wakeup_later w tt
  end.

Definition wait_push {A : Type} (q : t A) : Lwt.t unit :=
  match push_waiter q with
  | Some (t, _) => Lwt.protected t
  | None =>
    match Lwt.wait tt with
    | (waiter, wakener) =>
      set_field;
      Lwt.protected waiter
    end
  end.

Definition wait_pop {A : Type} (q : t A) : Lwt.t unit :=
  match pop_waiter q with
  | Some (t, _) => Lwt.protected t
  | None =>
    match Lwt.wait tt with
    | (waiter, wakener) =>
      set_field;
      Lwt.protected waiter
    end
  end.

Definition length {A : Type} (function_parameter : t A) : Z :=
  match function_parameter with
  | {| queue := queue |} => Stdlib.Queue.length queue
  end.

Definition is_empty {A : Type} (function_parameter : t A) : bool :=
  match function_parameter with
  | {| queue := queue |} => Stdlib.Queue.is_empty queue
  end.

Fixpoint empty {A : Type} (q : t A) : Lwt.t unit :=
  if is_empty q then
    Lwt.return_unit
  else
    Lwt.Infix.op_gt_gt_eq (Lwt_condition.wait None (empty q))
      (fun function_parameter =>
        match function_parameter with
        | tt => empty q
        end).

Fixpoint push {A : Type} (function_parameter : t A) : A -> Lwt.t unit :=
  match function_parameter with
  |
    {|
      queue := queue;
        current_size := current_size;
        max_size := max_size;
        compute_size := compute_size;
        closed := closed
        |} as q =>
    fun elt =>
      let elt_size := compute_size elt in
      if closed then
        Lwt.fail Closed
      else
        if
          orb (OCaml.Stdlib.lt (Z.add current_size elt_size) max_size)
            (Stdlib.Queue.is_empty queue) then
          Stdlib.Queue.push (elt_size, elt) queue;
          set_field;
          notify_push q;
          Lwt.return_unit
        else
          Lwt.Infix.op_gt_gt_eq (wait_pop q)
            (fun function_parameter =>
              match function_parameter with
              | tt => push q elt
              end)
  end.

Definition push_now {A : Type} (function_parameter : t A) : A -> bool :=
  match function_parameter with
  |
    {|
      queue := queue;
        current_size := current_size;
        max_size := max_size;
        compute_size := compute_size;
        closed := closed
        |} as q =>
    fun elt =>
      if closed then
        Stdlib.raise Closed
      else
        tt;
      let elt_size := compute_size elt in
      andb
        (orb (OCaml.Stdlib.lt (Z.add current_size elt_size) max_size)
          (Stdlib.Queue.is_empty queue))
        (Stdlib.Queue.push (elt_size, elt) queue;
        set_field;
        notify_push q;
        true)
  end.

Definition push_now_exn {A : Type} (q : t A) (elt : A) : unit :=
  if negb (push_now q elt) then
    Stdlib.raise Full
  else
    tt.

Definition safe_push_now {A : Type} (q : t A) (elt : A) : unit := try.

Fixpoint pop {A : Type} (function_parameter : t A) : Lwt.t A :=
  match function_parameter with
  |
    {|
      queue := queue;
        current_size := current_size;
        closed := closed;
        empty := empty
        |} as q =>
    if negb (Stdlib.Queue.is_empty queue) then
      match Stdlib.Queue.pop queue with
      | (elt_size, elt) =>
        notify_pop q;
        set_field;
        if equiv_decb (Stdlib.Queue.length queue) 0 then
          Lwt_condition.signal empty tt
        else
          tt;
        Lwt._return elt
      end
    else
      if closed then
        Lwt.fail Closed
      else
        Lwt.Infix.op_gt_gt_eq (wait_push q)
          (fun function_parameter =>
            match function_parameter with
            | tt => pop q
            end)
  end.

Fixpoint pop_with_timeout {A : Type} (timeout : Lwt.t unit) (q : t A)
  : Lwt.t (option A) :=
  if negb (Stdlib.Queue.is_empty (queue q)) then
    Lwt.cancel timeout;
    Lwt.Infix.op_gt_gt_eq (pop q) Lwt.return_some
  else
    if Lwt.is_sleeping timeout then
      if closed q then
        Lwt.cancel timeout;
        Lwt.fail Closed
      else
        let waiter := wait_push q in
        Lwt.Infix.op_gt_gt_eq
          (Lwt.choose (cons timeout (cons (Lwt.protected waiter) [])))
          (fun function_parameter =>
            match function_parameter with
            | tt => pop_with_timeout timeout q
            end)
    else
      Lwt.return_none.

Fixpoint peek {A : Type} (function_parameter : t A) : Lwt.t A :=
  match function_parameter with
  | {| queue := queue; closed := closed |} as q =>
    if negb (Stdlib.Queue.is_empty queue) then
      match Stdlib.Queue.peek queue with
      | (_elt_size, elt) => Lwt._return elt
      end
    else
      if closed then
        Lwt.fail Closed
      else
        Lwt.Infix.op_gt_gt_eq (wait_push q)
          (fun function_parameter =>
            match function_parameter with
            | tt => peek q
            end)
  end.

Definition peek_all {A : Type} (function_parameter : t A) : list A :=
  match function_parameter with
  | {| queue := queue; closed := closed |} =>
    if closed then
      []
    else
      List.rev
        (Stdlib.Queue.fold
          (fun acc =>
            fun function_parameter =>
              match function_parameter with
              | (_, e) => cons e acc
              end) [] queue)
  end.

Definition pop_now_exn {A : Type} (function_parameter : t A) : A :=
  match function_parameter with
  |
    {|
      queue := queue;
        current_size := current_size;
        closed := closed;
        empty := empty
        |} as q =>
    if Stdlib.Queue.is_empty queue then
      if closed then
        Stdlib.raise Closed
      else
        Stdlib.raise Empty
    else
      tt;
    match Stdlib.Queue.pop queue with
    | (elt_size, elt) =>
      if equiv_decb (Stdlib.Queue.length queue) 0 then
        Lwt_condition.signal empty tt
      else
        tt;
      set_field;
      notify_pop q;
      elt
    end
  end.

Definition pop_now {A : Type} (q : t A) : option A :=
  match pop_now_exn q with
  | elt => Some elt
  end.

Fixpoint values_available {A : Type} (q : t A) : Lwt.t unit :=
  if is_empty q then
    if closed q then
      Stdlib.raise Closed
    else
      Lwt.Infix.op_gt_gt_eq (wait_push q)
        (fun function_parameter =>
          match function_parameter with
          | tt => values_available q
          end)
  else
    Lwt.return_unit.

Fixpoint pop_all_loop {A : Type} (q : t A) (acc : list A) : list A :=
  match pop_now_exn q with
  | e => pop_all_loop q (cons e acc)
  end.

Definition pop_all {A : Type} (q : t A) : Lwt.t (list A) :=
  Lwt.Infix.op_gt_gt_eq (pop q)
    (fun e => Lwt._return (pop_all_loop q (cons e []))).

Definition pop_all_now {A : Type} (q : t A) : list A := pop_all_loop q [].

Definition close {A : Type} (q : t A) : unit :=
  if negb (closed q) then
    set_field;
    notify_push q;
    notify_pop q
  else
    tt.

Fixpoint iter {A : Type} (q : t A) (f : A -> Lwt.t unit) : Lwt.t unit :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Lwt.Infix.op_gt_gt_eq (pop q)
          (fun elt =>
            Lwt.Infix.op_gt_gt_eq (f elt)
              (fun function_parameter =>
                match function_parameter with
                | tt => iter q f
                end))
      end)
    (fun function_parameter =>
      match function_parameter with
      | Closed => Lwt.return_unit
      | exn => Lwt.fail exn
      end).
src/lib_stdlib/lwt_pipe.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Data queues similar to the [Pipe] module in Jane Street's [Async]
    library. They are implemented with [Queue]s, limited in size, and
    use lwt primitives for concurrent access. *)

(** Type of queues holding values of type ['a]. *)
type 'a t

(** [create ~size:(max_size, compute_size)] is an empty queue that can
    hold max [size] bytes of data, using [compute_size] to compute the
    size of a datum. If want to count allocated bytes precisely, you
    need to add [push_overhead] to the result of[compute_size].
    When no [size] argument is provided, the queue is unbounded. *)
val create : ?size:int * ('a -> int) -> unit -> 'a t

(** [push q v] is a thread that blocks while [q] contains more
    than [size] elements, then adds [v] at the end of [q]. *)
val push : 'a t -> 'a -> unit Lwt.t

(** [pop q] is a thread that blocks while [q] is empty, then
    removes and returns the first element in [q]. *)
val pop : 'a t -> 'a Lwt.t

(** [pop t q] is a thread that blocks while [q] is empty, then
    removes and returns the first element [v] in [q] and
    to return [Some v], unless no message could be popped
    in [t] seconds, in which case it returns [None].
    As concurrent readers are allowed, [None] does not
    necessarily mean that no value has been pushed. *)
val pop_with_timeout : unit Lwt.t -> 'a t -> 'a option Lwt.t

(** [pop_all q] is a thread that blocks while [q] is empty, then
    removes and returns all the element in [q] (in the order they
    were inserted). *)
val pop_all : 'a t -> 'a list Lwt.t

(** [pop_all_now q] returns all the element in [q] (in the order they
    were inserted), or [[]] if [q] is empty. *)
val pop_all_now : 'a t -> 'a list

(** [peek] is like [pop] except it does not removes the first
    element. *)
val peek : 'a t -> 'a Lwt.t

(** [peek_all q] returns the elements in the [q] (oldest first),
    or [[]] if empty. *)
val peek_all : 'a t -> 'a list

(** [values_available] is like [peek] but it ignores the value
    returned. *)
val values_available : 'a t -> unit Lwt.t

(** [push_now q v] adds [v] at the ends of [q] immediately and returns
    [false] if [q] is currently full, [true] otherwise. *)
val push_now : 'a t -> 'a -> bool

exception Full

(** [push_now q v] adds [v] at the ends of [q] immediately or
    raise [Full] if [q] is currently full. *)
val push_now_exn : 'a t -> 'a -> unit

(** [safe_push_now q v] may adds [v] at the ends of [q]. It does
    nothing if the queue is fulled or closed. *)
val safe_push_now : 'a t -> 'a -> unit

(** [pop_now q] maybe removes and returns the first element in [q] if
    [q] contains at least one element. *)
val pop_now : 'a t -> 'a option

exception Empty

(** [pop_now_exn q] removes and returns the first element in [q] if
    [q] contains at least one element, or raise [Empty] otherwise. *)
val pop_now_exn : 'a t -> 'a

(** [length q] is the number of elements in [q]. *)
val length : 'a t -> int

(** [is_empty q] is [true] if [q] is empty, [false] otherwise. *)
val is_empty : 'a t -> bool

(** [empty q] returns when [q] becomes empty. *)
val empty : 'a t -> unit Lwt.t

(** [iter q ~f] pops all elements of [q] and applies [f] on them. *)
val iter : 'a t -> f:('a -> unit Lwt.t) -> unit Lwt.t

exception Closed

(** [close q] the write end of [q]:

    * Future write attempts will fail with [Closed].
    * If there are reads blocked, they will unblock and fail with [Closed].
    * Future read attempts will drain the data until there is no data left.

    Thus, after a pipe has been closed, reads never block.
    Close is idempotent.
*)
val close : 'a t -> unit

(** The allocated size in bytes when pushing in the queue. *)
val push_overhead : int
src/lib_stdlib/lwt_pipe.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (a : Type), Type.

Parameter create : forall {a : Type}, (option (Z * (a -> Z))) -> unit -> t a.

Parameter push : forall {a : Type}, (t a) -> a -> Lwt.t unit.

Parameter pop : forall {a : Type}, (t a) -> Lwt.t a.

Parameter pop_with_timeout : forall {a : Type},
(Lwt.t unit) -> (t a) -> Lwt.t (option a).

Parameter pop_all : forall {a : Type}, (t a) -> Lwt.t (list a).

Parameter pop_all_now : forall {a : Type}, (t a) -> list a.

Parameter peek : forall {a : Type}, (t a) -> Lwt.t a.

Parameter peek_all : forall {a : Type}, (t a) -> list a.

Parameter values_available : forall {a : Type}, (t a) -> Lwt.t unit.

Parameter push_now : forall {a : Type}, (t a) -> a -> bool.

exception

Parameter push_now_exn : forall {a : Type}, (t a) -> a -> unit.

Parameter safe_push_now : forall {a : Type}, (t a) -> a -> unit.

Parameter pop_now : forall {a : Type}, (t a) -> option a.

exception

Parameter pop_now_exn : forall {a : Type}, (t a) -> a.

Parameter length : forall {a : Type}, (t a) -> Z.

Parameter is_empty : forall {a : Type}, (t a) -> bool.

Parameter empty : forall {a : Type}, (t a) -> Lwt.t unit.

Parameter iter : forall {a : Type}, (t a) -> (a -> Lwt.t unit) -> Lwt.t unit.

exception

Parameter close : forall {a : Type}, (t a) -> unit.

Parameter push_overhead : Z.
src/lib_stdlib/lwt_utils.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module LC = Lwt_condition
open Lwt.Infix

let may ~f = function None -> Lwt.return_unit | Some x -> f x

let never_ending () = fst (Lwt.wait ())

type trigger = Absent | Present | Waiting of unit Lwt.t * unit Lwt.u

let trigger () : (unit -> unit) * (unit -> unit Lwt.t) =
  let state = ref Absent in
  let trigger () =
    match !state with
    | Absent ->
        state := Present
    | Present ->
        ()
    | Waiting (_waiter, wakener) ->
        state := Absent ;
        Lwt.wakeup wakener ()
  in
  let wait () =
    match !state with
    | Absent ->
        let (waiter, wakener) = Lwt.wait () in
        state := Waiting (waiter, wakener) ;
        waiter
    | Present ->
        state := Absent ;
        Lwt.return_unit
    | Waiting (waiter, _wakener) ->
        waiter
  in
  (trigger, wait)

(* A worker launcher, takes a cancel callback to call upon *)
let worker name ~on_event ~run ~cancel =
  let stop = LC.create () in
  let fail e =
    on_event
      name
      (`Failed (Printf.sprintf "Exception: %s" (Printexc.to_string e)))
    >>= fun () -> cancel ()
  in
  let waiter = LC.wait stop in
  on_event name `Started
  >>= fun () ->
  Lwt.async (fun () ->
      Lwt.catch run fail >>= fun () -> LC.signal stop () ; Lwt.return_unit) ;
  waiter >>= fun () -> on_event name `Ended >>= fun () -> Lwt.return_unit

let rec chop k l =
  if k = 0 then l
  else match l with _ :: t -> chop (k - 1) t | _ -> assert false

let stable_sort cmp l =
  let rec rev_merge l1 l2 accu =
    match (l1, l2) with
    | ([], l2) ->
        Lwt.return (List.rev_append l2 accu)
    | (l1, []) ->
        Lwt.return (List.rev_append l1 accu)
    | (h1 :: t1, h2 :: t2) -> (
        cmp h1 h2
        >>= function
        | x when x <= 0 ->
            rev_merge t1 l2 (h1 :: accu)
        | _ ->
            rev_merge l1 t2 (h2 :: accu) )
  in
  let rec rev_merge_rev l1 l2 accu =
    match (l1, l2) with
    | ([], l2) ->
        Lwt.return (List.rev_append l2 accu)
    | (l1, []) ->
        Lwt.return (List.rev_append l1 accu)
    | (h1 :: t1, h2 :: t2) -> (
        cmp h1 h2
        >>= function
        | x when x > 0 ->
            rev_merge_rev t1 l2 (h1 :: accu)
        | _ ->
            rev_merge_rev l1 t2 (h2 :: accu) )
  in
  let rec sort n l =
    match (n, l) with
    | (2, x1 :: x2 :: _) -> (
        cmp x1 x2 >|= function x when x <= 0 -> [x1; x2] | _ -> [x2; x1] )
    | (3, x1 :: x2 :: x3 :: _) -> (
        cmp x1 x2
        >>= function
        | x when x <= 0 -> (
            cmp x2 x3
            >>= function
            | x when x <= 0 ->
                Lwt.return [x1; x2; x3]
            | _ -> (
                cmp x1 x3
                >|= function x when x <= 0 -> [x1; x3; x2] | _ -> [x3; x1; x2]
                ) )
        | _ -> (
            cmp x1 x3
            >>= function
            | x when x <= 0 ->
                Lwt.return [x2; x1; x3]
            | _ -> (
                cmp x2 x3
                >|= function x when x <= 0 -> [x2; x3; x1] | _ -> [x3; x2; x1]
                ) ) )
    | (n, l) ->
        let n1 = n asr 1 in
        let n2 = n - n1 in
        let l2 = chop n1 l in
        rev_sort n1 l
        >>= fun s1 -> rev_sort n2 l2 >>= fun s2 -> rev_merge_rev s1 s2 []
  and rev_sort n l =
    match (n, l) with
    | (2, x1 :: x2 :: _) -> (
        cmp x1 x2 >|= function x when x > 0 -> [x1; x2] | _ -> [x2; x1] )
    | (3, x1 :: x2 :: x3 :: _) -> (
        cmp x1 x2
        >>= function
        | x when x > 0 -> (
            cmp x2 x3
            >>= function
            | x when x > 0 ->
                Lwt.return [x1; x2; x3]
            | _ -> (
                cmp x1 x3
                >|= function x when x > 0 -> [x1; x3; x2] | _ -> [x3; x1; x2] )
            )
        | _ -> (
            cmp x1 x3
            >>= function
            | x when x > 0 ->
                Lwt.return [x2; x1; x3]
            | _ -> (
                cmp x2 x3
                >|= function x when x > 0 -> [x2; x3; x1] | _ -> [x3; x2; x1] )
            ) )
    | (n, l) ->
        let n1 = n asr 1 in
        let n2 = n - n1 in
        let l2 = chop n1 l in
        sort n1 l >>= fun s1 -> sort n2 l2 >>= fun s2 -> rev_merge s1 s2 []
  in
  let len = List.length l in
  if len < 2 then Lwt.return l else sort len l

let sort = stable_sort

let unless cond f = if cond then Lwt.return_unit else f ()

let rec fold_left_s_n ~n f acc l =
  if n = 0 then Lwt.return (acc, l)
  else
    match l with
    | [] ->
        Lwt.return (acc, [])
    | x :: l ->
        f acc x
        >>= fun acc -> (fold_left_s_n [@ocaml.tailcall]) f ~n:(n - 1) acc l
src/lib_stdlib/lwt_utils.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Definition may {A : Type} (f : A -> Lwt.t unit) (function_parameter : option A)
  : Lwt.t unit :=
  match function_parameter with
  | None => Lwt.return_unit
  | Some x => f x
  end.

Definition never_ending {A : Type} (function_parameter : unit) : Lwt.t A :=
  match function_parameter with
  | tt => fst (Lwt.wait tt)
  end.

Inductive trigger : Type :=
| Absent : trigger
| Present : trigger
| Waiting : (Lwt.t unit) -> (Lwt.u unit) -> trigger.

Definition trigger (function_parameter : unit)
  : (unit -> unit) * (unit -> Lwt.t unit) :=
  match function_parameter with
  | tt =>
    let state := Stdlib.ref Absent in
    let trigger (function_parameter : unit) : unit :=
      match function_parameter with
      | tt =>
        match Stdlib.op_exclamation state with
        | Absent => Stdlib.op_colon_eq state Present
        | Present => tt
        | Waiting _waiter wakener =>
          Stdlib.op_colon_eq state Absent;
          Lwt.wakeup wakener tt
        end
      end in
    let wait (function_parameter : unit) : Lwt.t unit :=
      match function_parameter with
      | tt =>
        match Stdlib.op_exclamation state with
        | Absent =>
          match Lwt.wait tt with
          | (waiter, wakener) =>
            Stdlib.op_colon_eq state (Waiting waiter wakener);
            waiter
          end
        | Present =>
          Stdlib.op_colon_eq state Absent;
          Lwt.return_unit
        | Waiting waiter _wakener => waiter
        end
      end in
    (trigger, wait)
  end.

Definition worker {A : Type}
  (name : A) (on_event : A -> variant -> Lwt.t unit) (run : unit -> Lwt.t unit)
  (cancel : unit -> Lwt.t unit) : Lwt.t unit :=
  let stop := LC.create tt in
  let fail (e : exn) : Lwt.t unit :=
    Lwt.Infix.op_gt_gt_eq (on_event name variant)
      (fun function_parameter =>
        match function_parameter with
        | tt => cancel tt
        end) in
  let waiter := LC.wait None stop in
  Lwt.Infix.op_gt_gt_eq (on_event name variant)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Lwt.async
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Lwt.Infix.op_gt_gt_eq (Lwt.catch run fail)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    LC.signal stop tt;
                    Lwt.return_unit
                  end)
            end);
        Lwt.Infix.op_gt_gt_eq waiter
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Lwt.Infix.op_gt_gt_eq (on_event name variant)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Lwt.return_unit
                  end)
            end)
      end).

Fixpoint chop {A : Type} (k : Z) (l : list A) : list A :=
  if equiv_decb k 0 then
    l
  else
    match l with
    | cons _ t => chop (Z.sub k 1) t
    | _ => false
    end.

Definition stable_sort {A : Type} (cmp : A -> A -> Lwt.t Z) (l : list A)
  : Lwt.t (list A) :=
  let fix rev_merge (l1 : list A) (l2 : list A) (accu : list A)
    : Lwt.t (list A) :=
    match (l1, l2) with
    | ([], l2) => Lwt._return (Stdlib.List.rev_append l2 accu)
    | (l1, []) => Lwt._return (Stdlib.List.rev_append l1 accu)
    | (cons h1 t1, cons h2 t2) =>
      Lwt.Infix.op_gt_gt_eq (cmp h1 h2)
        (fun function_parameter =>
          match function_parameter with
          | x => rev_merge t1 l2 (cons h1 accu)
          | _ => rev_merge l1 t2 (cons h2 accu)
          end)
    end in
  let fix rev_merge_rev (l1 : list A) (l2 : list A) (accu : list A)
    : Lwt.t (list A) :=
    match (l1, l2) with
    | ([], l2) => Lwt._return (Stdlib.List.rev_append l2 accu)
    | (l1, []) => Lwt._return (Stdlib.List.rev_append l1 accu)
    | (cons h1 t1, cons h2 t2) =>
      Lwt.Infix.op_gt_gt_eq (cmp h1 h2)
        (fun function_parameter =>
          match function_parameter with
          | x => rev_merge_rev t1 l2 (cons h1 accu)
          | _ => rev_merge_rev l1 t2 (cons h2 accu)
          end)
    end in
  let fix sort (n : Z) (l : list A) : Lwt.t (list A) :=
    match (n, l) with
    | (2, cons x1 (cons x2 _)) =>
      Lwt.Infix.op_gt_pipe_eq (cmp x1 x2)
        (fun function_parameter =>
          match function_parameter with
          | x => cons x1 (cons x2 [])
          | _ => cons x2 (cons x1 [])
          end)
    | (3, cons x1 (cons x2 (cons x3 _))) =>
      Lwt.Infix.op_gt_gt_eq (cmp x1 x2)
        (fun function_parameter =>
          match function_parameter with
          | x =>
            Lwt.Infix.op_gt_gt_eq (cmp x2 x3)
              (fun function_parameter =>
                match function_parameter with
                | x => Lwt._return (cons x1 (cons x2 (cons x3 [])))
                | _ =>
                  Lwt.Infix.op_gt_pipe_eq (cmp x1 x3)
                    (fun function_parameter =>
                      match function_parameter with
                      | x => cons x1 (cons x3 (cons x2 []))
                      | _ => cons x3 (cons x1 (cons x2 []))
                      end)
                end)
          | _ =>
            Lwt.Infix.op_gt_gt_eq (cmp x1 x3)
              (fun function_parameter =>
                match function_parameter with
                | x => Lwt._return (cons x2 (cons x1 (cons x3 [])))
                | _ =>
                  Lwt.Infix.op_gt_pipe_eq (cmp x2 x3)
                    (fun function_parameter =>
                      match function_parameter with
                      | x => cons x2 (cons x3 (cons x1 []))
                      | _ => cons x3 (cons x2 (cons x1 []))
                      end)
                end)
          end)
    | (n, l) =>
      let n1 := Stdlib.asr n 1 in
      let n2 := Z.sub n n1 in
      let l2 := chop n1 l in
      Lwt.Infix.op_gt_gt_eq (rev_sort n1 l)
        (fun s1 =>
          Lwt.Infix.op_gt_gt_eq (rev_sort n2 l2)
            (fun s2 => rev_merge_rev s1 s2 []))
    end
  with rev_sort (n : Z) (l : list A) : Lwt.t (list A) :=
    match (n, l) with
    | (2, cons x1 (cons x2 _)) =>
      Lwt.Infix.op_gt_pipe_eq (cmp x1 x2)
        (fun function_parameter =>
          match function_parameter with
          | x => cons x1 (cons x2 [])
          | _ => cons x2 (cons x1 [])
          end)
    | (3, cons x1 (cons x2 (cons x3 _))) =>
      Lwt.Infix.op_gt_gt_eq (cmp x1 x2)
        (fun function_parameter =>
          match function_parameter with
          | x =>
            Lwt.Infix.op_gt_gt_eq (cmp x2 x3)
              (fun function_parameter =>
                match function_parameter with
                | x => Lwt._return (cons x1 (cons x2 (cons x3 [])))
                | _ =>
                  Lwt.Infix.op_gt_pipe_eq (cmp x1 x3)
                    (fun function_parameter =>
                      match function_parameter with
                      | x => cons x1 (cons x3 (cons x2 []))
                      | _ => cons x3 (cons x1 (cons x2 []))
                      end)
                end)
          | _ =>
            Lwt.Infix.op_gt_gt_eq (cmp x1 x3)
              (fun function_parameter =>
                match function_parameter with
                | x => Lwt._return (cons x2 (cons x1 (cons x3 [])))
                | _ =>
                  Lwt.Infix.op_gt_pipe_eq (cmp x2 x3)
                    (fun function_parameter =>
                      match function_parameter with
                      | x => cons x2 (cons x3 (cons x1 []))
                      | _ => cons x3 (cons x2 (cons x1 []))
                      end)
                end)
          end)
    | (n, l) =>
      let n1 := Stdlib.asr n 1 in
      let n2 := Z.sub n n1 in
      let l2 := chop n1 l in
      Lwt.Infix.op_gt_gt_eq (sort n1 l)
        (fun s1 =>
          Lwt.Infix.op_gt_gt_eq (sort n2 l2) (fun s2 => rev_merge s1 s2 []))
    end in
  let len := OCaml.List.length l in
  if OCaml.Stdlib.lt len 2 then
    Lwt._return l
  else
    sort len l.

Definition sort {A : Type}
  : (A -> A -> Lwt.t Z) -> (list A) -> Lwt.t (list A) := stable_sort.

Definition unless (cond : bool) (f : unit -> Lwt.t unit) : Lwt.t unit :=
  if cond then
    Lwt.return_unit
  else
    f tt.

Fixpoint fold_left_s_n {A B : Type}
  (n : Z) (f : A -> B -> Lwt.t A) (acc : A) (l : list B)
  : Lwt.t (A * (list B)) :=
  if equiv_decb n 0 then
    Lwt._return (acc, l)
  else
    match l with
    | [] => Lwt._return (acc, [])
    | cons x l =>
      Lwt.Infix.op_gt_gt_eq (f acc x)
        (fun acc => fold_left_s_n (Z.sub n 1) f acc l)
    end.
src/lib_stdlib/lwt_utils.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val may : f:('a -> unit Lwt.t) -> 'a option -> unit Lwt.t

val never_ending : unit -> 'a Lwt.t

(** [worker name ~on_event ~run ~cancel] runs worker [run], and logs worker
    creation, ending or failure using [~on_event].
    [cancel] is called if worker fails. *)
val worker :
  string ->
  on_event:(string -> [`Ended | `Failed of string | `Started] -> unit Lwt.t) ->
  run:(unit -> unit Lwt.t) ->
  cancel:(unit -> unit Lwt.t) ->
  unit Lwt.t

val trigger : unit -> (unit -> unit) * (unit -> unit Lwt.t)

val sort : ('a -> 'a -> int Lwt.t) -> 'a list -> 'a list Lwt.t

val unless : bool -> (unit -> unit Lwt.t) -> unit Lwt.t

(** Evaluates fold_left_s on a batch of [n] elements and returns a pair
    containing the result of the first batch and the unprocessed elements *)
val fold_left_s_n :
  n:int -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> ('a * 'b list) Lwt.t
src/lib_stdlib/lwt_utils.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter may : forall {a : Type},
(a -> Lwt.t unit) -> (option a) -> Lwt.t unit.

Parameter never_ending : forall {a : Type}, unit -> Lwt.t a.

Parameter worker : forall {variant : Type},
string ->
  (string -> variant -> Lwt.t unit) ->
    (unit -> Lwt.t unit) -> (unit -> Lwt.t unit) -> Lwt.t unit.

Parameter trigger : unit -> (unit -> unit) * (unit -> Lwt.t unit).

Parameter sort : forall {a : Type},
(a -> a -> Lwt.t Z) -> (list a) -> Lwt.t (list a).

Parameter unless : bool -> (unit -> Lwt.t unit) -> Lwt.t unit.

Parameter fold_left_s_n : forall {a b : Type},
Z -> (a -> b -> Lwt.t a) -> a -> (list b) -> Lwt.t (a * (list b)).
src/lib_stdlib/lwt_watcher.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a inner_stopper = {
  id : int;
  push : 'a option -> unit;
  mutable active : bool;
  input : 'a input;
}

and 'a input = {mutable watchers : 'a inner_stopper list; mutable cpt : int}

type stopper = unit -> unit

let create_input () = {watchers = []; cpt = 0}

let shutdown_input input =
  let {watchers; _} = input in
  List.iter
    (fun w ->
      w.active <- false ;
      w.push None)
    watchers ;
  input.cpt <- 0 ;
  input.watchers <- []

let create_fake_stream () =
  let (str, push) = Lwt_stream.create () in
  (str, fun () -> push None)

let notify input info = List.iter (fun w -> w.push (Some info)) input.watchers

let shutdown_output output =
  if output.active then (
    output.active <- false ;
    output.push None ;
    output.input.watchers <-
      List.filter (fun w -> w.id <> output.id) output.input.watchers )

let create_stream input =
  input.cpt <- input.cpt + 1 ;
  let id = input.cpt in
  let (stream, push) = Lwt_stream.create () in
  let output = {id; push; input; active = true} in
  input.watchers <- output :: input.watchers ;
  (stream, fun () -> shutdown_output output)

let shutdown f = f ()
src/lib_stdlib/lwt_watcher.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

.

Definition stopper := unit -> unit.

Definition create_input {A : Type} (function_parameter : unit) : input A :=
  match function_parameter with
  | tt => {| watchers := []; cpt := 0 |}
  end.

Definition shutdown_input {A : Type} (input : input A) : unit :=
  match input with
  | {| watchers := watchers |} =>
    Stdlib.List.iter
      (fun w =>
        set_field;
        (push w) None) watchers;
    set_field;
    set_field
  end.

Definition create_fake_stream {A : Type} (function_parameter : unit)
  : (Lwt_stream.t A) * (unit -> unit) :=
  match function_parameter with
  | tt =>
    match Lwt_stream.create tt with
    | (str, push) =>
      (str,
        (fun function_parameter =>
          match function_parameter with
          | tt => push None
          end))
    end
  end.

Definition notify {A : Type} (input : input A) (info : A) : unit :=
  Stdlib.List.iter (fun w => (push w) (Some info)) (watchers input).

Definition shutdown_output {A : Type} (output : inner_stopper A) : unit :=
  if active output then
    set_field;
    (push output) None;
    set_field
  else
    tt.

Definition create_stream {A : Type} (input : input A)
  : (Lwt_stream.t A) * (unit -> unit) :=
  set_field;
  let id := cpt input in
  match Lwt_stream.create tt with
  | (stream, push) =>
    let output := {| id := id; push := push; active := true; input := input |}
      in
    set_field;
    (stream,
      (fun function_parameter =>
        match function_parameter with
        | tt => shutdown_output output
        end))
  end.

Definition shutdown {A : Type} (f : unit -> A) : A := f tt.
src/lib_stdlib/lwt_watcher.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This module implements a one-to-many publish/subscribe pattern.

    Clients can register/unregister to an [input]. Events notified to the input
    (through [notify]) are dispatched asynchronously to all registered clients
    through an [Lwt_stream]. A client receives only events sent after
    registration and before unregistration. *)

type 'a input

val create_input : unit -> 'a input

(** [notify t v] publishes value v to the input t *)
val notify : 'a input -> 'a -> unit

type stopper

(** [create_stream t] registers a new client which can read published
    values via a stream. A [stopper] is used to shutdown the client. *)
val create_stream : 'a input -> 'a Lwt_stream.t * stopper

(** A fake stream never receives any value. *)
val create_fake_stream : unit -> 'a Lwt_stream.t * stopper

(** [shutdown s] unregisters the client associated to [s]. [None] is pushed
    to the stream. *)
val shutdown : stopper -> unit

(** Shutdowns all the clients of this input *)
val shutdown_input : 'a input -> unit
src/lib_stdlib/lwt_watcher.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter input : forall (a : Type), Type.

Parameter create_input : forall {a : Type}, unit -> input a.

Parameter notify : forall {a : Type}, (input a) -> a -> unit.

Parameter stopper : Type.

Parameter create_stream : forall {a : Type},
(input a) -> (Lwt_stream.t a) * stopper.

Parameter create_fake_stream : forall {a : Type},
unit -> (Lwt_stream.t a) * stopper.

Parameter shutdown : stopper -> unit.

Parameter shutdown_input : forall {a : Type}, (input a) -> unit.
src/lib_stdlib/mBytes.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = bytes

let create = Bytes.create

let length = Bytes.length

let copy = Bytes.copy

let sub = Bytes.sub

let blit = Bytes.blit

let blit_of_string = Bytes.blit_string

let blit_to_bytes = Bytes.blit

let of_string = Bytes.of_string

let to_string = Bytes.to_string

let sub_string = Bytes.sub_string

let get_char = Bytes.get

let set_char = Bytes.set

include TzEndian

module LE = struct
  let get_uint16 = Bytes_encodings.get_uint16_le

  let get_int16 = Bytes_encodings.get_int16_le

  let get_int32 = Bytes_encodings.get_int32_le

  let get_int64 = Bytes_encodings.get_int64_le

  let set_int16 = Bytes_encodings.set_int16_le

  let set_int32 = Bytes_encodings.set_int32_le

  let set_int64 = Bytes_encodings.set_int64_le
end

let ( = ) = Pervasives.( = )

let ( <> ) = Pervasives.( <> )

let ( < ) = Pervasives.( < )

let ( <= ) = Pervasives.( <= )

let ( >= ) = Pervasives.( >= )

let ( > ) = Pervasives.( > )

let compare = Bytes.compare

let concat s bs = Bytes.concat (Bytes.of_string s) bs

let to_hex t = Hex.of_bytes t

let of_hex hex = Hex.to_bytes hex
src/lib_stdlib/mBytes.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := string.

Definition create : Z -> string := Stdlib.Bytes.create.

Definition length : string -> Z := String.length.

Definition copy : string -> string := Stdlib.Bytes.copy.

Definition sub : string -> Z -> Z -> string := String.sub.

Definition blit : string -> Z -> string -> Z -> Z -> unit := Stdlib.Bytes.blit.

Definition blit_of_string : string -> Z -> string -> Z -> Z -> unit :=
  Stdlib.Bytes.blit_string.

Definition blit_to_bytes : string -> Z -> string -> Z -> Z -> unit :=
  Stdlib.Bytes.blit.

Definition of_string : string -> string := Stdlib.Bytes.of_string.

Definition to_string : string -> string := Stdlib.Bytes.to_string.

Definition sub_string : string -> Z -> Z -> string := Stdlib.Bytes.sub_string.

Definition get_char : string -> Z -> ascii := Stdlib.Bytes.get.

Definition set_char : string -> Z -> ascii -> unit := Stdlib.Bytes.set.

Module LE.
  Definition get_uint16 : string -> Z -> Z :=
    Tezos_stdlib.Bytes_encodings.get_uint16_le.
  
  Definition get_int16 : string -> Z -> Z :=
    Tezos_stdlib.Bytes_encodings.get_int16_le.
  
  Definition get_int32 : string -> Z -> int32 :=
    Tezos_stdlib.Bytes_encodings.get_int32_le.
  
  Definition get_int64 : string -> Z -> int64 :=
    Tezos_stdlib.Bytes_encodings.get_int64_le.
  
  Definition set_int16 : string -> Z -> Z -> unit :=
    Tezos_stdlib.Bytes_encodings.set_int16_le.
  
  Definition set_int32 : string -> Z -> int32 -> unit :=
    Tezos_stdlib.Bytes_encodings.set_int32_le.
  
  Definition set_int64 : string -> Z -> int64 -> unit :=
    Tezos_stdlib.Bytes_encodings.set_int64_le.
End LE.

Definition op_eq {A : Type} : A -> A -> bool := Stdlib.Pervasives.op_eq.

Definition op_lt_gt {A : Type} : A -> A -> bool := Stdlib.Pervasives.op_lt_gt.

Definition op_lt {A : Type} : A -> A -> bool := Stdlib.Pervasives.op_lt.

Definition op_lt_eq {A : Type} : A -> A -> bool := Stdlib.Pervasives.op_lt_eq.

Definition op_gt_eq {A : Type} : A -> A -> bool := Stdlib.Pervasives.op_gt_eq.

Definition op_gt {A : Type} : A -> A -> bool := Stdlib.Pervasives.op_gt.

Definition compare : Stdlib.Bytes.t -> Stdlib.Bytes.t -> Z :=
  Stdlib.Bytes.compare.

Definition concat (s : string) (bs : list string) : string :=
  String.concat (Stdlib.Bytes.of_string s) bs.

Definition to_hex (t : string) : Hex.t := Hex.of_bytes None t.

Definition of_hex (hex : Hex.t) : string := Hex.to_bytes hex.
src/lib_stdlib/mBytes.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* NOTICE

   This module is kept because it is exported in the protocol environment.
   Changes to this here interface requires a protocol amendment.

   This file should not be used outside of the protocol environment. Use [Bytes]
   and [TzEndian] where needed.

*)

type t = bytes

val create : int -> t

val length : t -> int

val copy : t -> t

(** [sub src ofs len] extract a sub-array of [src] starting at [ofs]
    and of length [len]. No copying of elements is involved: the
    sub-array and the original array share the same storage space. *)
val sub : t -> int -> int -> t

(** [blit src ofs_src dst ofs_dst len] copy [len] bytes from [src]
    starting at [ofs_src] into [dst] starting at [ofs_dst]. *)
val blit : t -> int -> t -> int -> int -> unit

(** See [blit] *)
val blit_of_string : string -> int -> t -> int -> int -> unit

(** See [blit] *)
val blit_to_bytes : t -> int -> bytes -> int -> int -> unit

(** [of_string s] create an byte array filled with the same content than [s]. *)
val of_string : string -> t

(** [to_string b] dump the array content in a [string]. *)
val to_string : t -> string

(** [sub_string b ofs len] is equivalent to [to_string (sub b ofs len)]. *)
val sub_string : t -> int -> int -> string

(** Functions reading and writing bytes  *)

(** [get_char buff i] reads 1 byte at offset i as a char *)
val get_char : t -> int -> char

(** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
    bits. i.e. It returns a value between 0 and 2^8-1 *)
val get_uint8 : t -> int -> int

(** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
    bits. i.e. It returns a value between -2^7 and 2^7-1 *)
val get_int8 : t -> int -> int

(** [set_char buff i v] writes [v] to [buff] at offset [i] *)
val set_char : t -> int -> char -> unit

(** [set_int8 buff i v] writes the least significant 8 bits of [v]
    to [buff] at offset [i] *)
val set_int8 : t -> int -> int -> unit

(** Functions reading according to Big Endian byte order *)

(** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
      of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
val get_uint16 : t -> int -> int

(** [get_int16 buff i] reads 2 byte at offset i as a signed int of
      16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
val get_int16 : t -> int -> int

(** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
val get_int32 : t -> int -> int32

(** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
val get_int64 : t -> int -> int64

(** [set_int16 buff i v] writes the least significant 16 bits of [v]
      to [buff] at offset [i] *)
val set_int16 : t -> int -> int -> unit

(** [set_int32 buff i v] writes [v] to [buff] at offset [i] *)
val set_int32 : t -> int -> int32 -> unit

(** [set_int64 buff i v] writes [v] to [buff] at offset [i] *)
val set_int64 : t -> int -> int64 -> unit

module LE : sig
  (** Functions reading according to Little Endian byte order *)

  (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
      of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
  val get_uint16 : t -> int -> int

  (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
      16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
  val get_int16 : t -> int -> int

  (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
  val get_int32 : t -> int -> int32

  (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
  val get_int64 : t -> int -> int64

  (** [set_int16 buff i v] writes the least significant 16 bits of [v]
      to [buff] at offset [i] *)
  val set_int16 : t -> int -> int -> unit

  (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *)
  val set_int32 : t -> int -> int32 -> unit

  (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *)
  val set_int64 : t -> int -> int64 -> unit
end

val ( = ) : t -> t -> bool

val ( <> ) : t -> t -> bool

val ( < ) : t -> t -> bool

val ( <= ) : t -> t -> bool

val ( >= ) : t -> t -> bool

val ( > ) : t -> t -> bool

val compare : t -> t -> int

val concat : string -> t list -> t

val to_hex : t -> [`Hex of string]

val of_hex : [`Hex of string] -> t
src/lib_stdlib/mBytes.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := string.

Parameter create : Z -> t.

Parameter length : t -> Z.

Parameter copy : t -> t.

Parameter sub : t -> Z -> Z -> t.

Parameter blit : t -> Z -> t -> Z -> Z -> unit.

Parameter blit_of_string : string -> Z -> t -> Z -> Z -> unit.

Parameter blit_to_bytes : t -> Z -> string -> Z -> Z -> unit.

Parameter of_string : string -> t.

Parameter to_string : t -> string.

Parameter sub_string : t -> Z -> Z -> string.

Parameter get_char : t -> Z -> ascii.

Parameter get_uint8 : t -> Z -> Z.

Parameter get_int8 : t -> Z -> Z.

Parameter set_char : t -> Z -> ascii -> unit.

Parameter set_int8 : t -> Z -> Z -> unit.

Parameter get_uint16 : t -> Z -> Z.

Parameter get_int16 : t -> Z -> Z.

Parameter get_int32 : t -> Z -> int32.

Parameter get_int64 : t -> Z -> int64.

Parameter set_int16 : t -> Z -> Z -> unit.

Parameter set_int32 : t -> Z -> int32 -> unit.

Parameter set_int64 : t -> Z -> int64 -> unit.

Module LE.
  Parameter get_uint16 : t -> Z -> Z.
  
  Parameter get_int16 : t -> Z -> Z.
  
  Parameter get_int32 : t -> Z -> int32.
  
  Parameter get_int64 : t -> Z -> int64.
  
  Parameter set_int16 : t -> Z -> Z -> unit.
  
  Parameter set_int32 : t -> Z -> int32 -> unit.
  
  Parameter set_int64 : t -> Z -> int64 -> unit.
End LE.

Parameter op_eq : t -> t -> bool.

Parameter op_lt_gt : t -> t -> bool.

Parameter op_lt : t -> t -> bool.

Parameter op_lt_eq : t -> t -> bool.

Parameter op_gt_eq : t -> t -> bool.

Parameter op_gt : t -> t -> bool.

Parameter compare : t -> t -> Z.

Parameter concat : string -> (list t) -> t.

Parameter to_hex : forall {variant : Type}, t -> variant.

Parameter of_hex : forall {variant : Type}, variant -> t.
src/lib_stdlib/memory.ml 
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type proc_statm = {
  page_size : int;
  size : int64;
  resident : int64;
  shared : int64;
  text : int64;
  lib : int64;
  data : int64;
  dt : int64;
}

type ps_stats = {page_size : int; mem : float; resident : int64}

type mem_stats = Statm of proc_statm | Ps of ps_stats
src/lib_stdlib/memory.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record proc_statm := {
  page_size : Z;
  size : int64;
  resident : int64;
  shared : int64;
  text : int64;
  lib : int64;
  data : int64;
  dt : int64 }.

Record ps_stats := {
  page_size : Z;
  mem : float;
  resident : int64 }.

Inductive mem_stats : Type :=
| Statm : proc_statm -> mem_stats
| Ps : ps_stats -> mem_stats.
src/lib_stdlib/memory.mli 
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type proc_statm = {
  page_size : int;
  size : int64;
  resident : int64;
  shared : int64;
  text : int64;
  lib : int64;
  data : int64;
  dt : int64;
}

type ps_stats = {page_size : int; mem : float; resident : int64}

type mem_stats = Statm of proc_statm | Ps of ps_stats
src/lib_stdlib/memory.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record proc_statm := {
  page_size : Z;
  size : int64;
  resident : int64;
  shared : int64;
  text : int64;
  lib : int64;
  data : int64;
  dt : int64 }.

Record ps_stats := {
  page_size : Z;
  mem : float;
  resident : int64 }.

Inductive mem_stats : Type :=
| Statm : proc_statm -> mem_stats
| Ps : ps_stats -> mem_stats.
src/lib_stdlib/option.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let map ~f = function None -> None | Some x -> Some (f x)

let apply ~f = function None -> None | Some x -> f x

let ( >>= ) x f = apply ~f x

let ( >>| ) x f = map ~f x

let iter ~f = function None -> () | Some x -> f x

let unopt ~default = function None -> default | Some x -> x

let unopt_map ~f ~default = function None -> default | Some x -> f x

let unopt_exn err = function Some x -> x | _ -> raise err

let unopt_assert ~loc:(name, line, pos, _) = function
  | Some v ->
      v
  | None ->
      raise (Assert_failure (name, line, pos))

let first_some a b =
  match (a, b) with
  | (None, None) ->
      None
  | (None, Some v) ->
      Some v
  | (Some v, _) ->
      Some v

let try_with f = try Some (f ()) with _ -> None

let some x = Some x

let pp ?(default = "None") pp fmt = function
  | Some value ->
      pp fmt value
  | None ->
      Format.pp_print_text fmt default
src/lib_stdlib/option.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition map {A B : Type} (f : A -> B) (function_parameter : option A)
  : option B :=
  match function_parameter with
  | None => None
  | Some x => Some (f x)
  end.

Definition apply {A B : Type}
  (f : A -> option B) (function_parameter : option A) : option B :=
  match function_parameter with
  | None => None
  | Some x => f x
  end.

Definition op_gt_gt_eq {A B : Type} (x : option A) (f : A -> option B)
  : option B := apply f x.

Definition op_gt_gt_pipe {A B : Type} (x : option A) (f : A -> B) : option B :=
  map f x.

Definition iter {A : Type} (f : A -> unit) (function_parameter : option A)
  : unit :=
  match function_parameter with
  | None => tt
  | Some x => f x
  end.

Definition unopt {A : Type} (default : A) (function_parameter : option A) : A :=
  match function_parameter with
  | None => default
  | Some x => x
  end.

Definition unopt_map {A B : Type}
  (f : A -> B) (default : B) (function_parameter : option A) : B :=
  match function_parameter with
  | None => default
  | Some x => f x
  end.

Definition unopt_exn {A : Type} (err : exn) (function_parameter : option A)
  : A :=
  match function_parameter with
  | Some x => x
  | _ => Stdlib.raise err
  end.

Definition unopt_assert {A B : Type} (function_parameter : string * Z * Z * A)
  : (option B) -> B :=
  match function_parameter with
  | (name, line, pos, _) =>
    fun function_parameter =>
      match function_parameter with
      | Some v => v
      | None => Stdlib.raise (OCaml.Assert_failure (name, line, pos))
      end
  end.

Definition first_some {A : Type} (a : option A) (b : option A) : option A :=
  match (a, b) with
  | (None, None) => None
  | (None, Some v) => Some v
  | (Some v, _) => Some v
  end.

Definition try_with {A : Type} (f : unit -> A) : option A := try.

Definition some {A : Type} (x : A) : option A := Some x.

Definition pp {A : Type} (op_star_o_p_t_star : option string)
  : (Stdlib.Format.formatter -> A -> unit) ->
    Stdlib.Format.formatter -> (option A) -> unit :=
  let default :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "None" % string
    end in
  fun pp =>
    fun fmt =>
      fun function_parameter =>
        match function_parameter with
        | Some value => pp fmt value
        | None => Stdlib.Format.pp_print_text fmt default
        end.
src/lib_stdlib/option.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** [Some (f x)] if input is [Some x], or [None] if it's [None] *)
val map : f:('a -> 'b) -> 'a option -> 'b option

(** [(f x)] if input is [Some x], or [None] if it's [None] *)
val apply : f:('a -> 'b option) -> 'a option -> 'b option

(** [x >>= f] is an infix notation for [apply ~f x] *)
val ( >>= ) : 'a option -> ('a -> 'b option) -> 'b option

(** [x >>| f] is an infix notation for [map ~f x] *)
val ( >>| ) : 'a option -> ('a -> 'b) -> 'b option

(** Call [(f x)] if input is [Some x], noop if it's [None] *)
val iter : f:('a -> unit) -> 'a option -> unit

(** [x] if input is [Some x], [default] if it's [None] *)
val unopt : default:'a -> 'a option -> 'a

(** [unopt_map ~f ~default x] is [f y] if [x] is [Some y], [default] if [x] is [None] *)
val unopt_map : f:('a -> 'b) -> default:'b -> 'a option -> 'b

(** [unopt_exn exn x] is [y] if [x] is [Some y], or raises [exn] if [x] is [None] *)
val unopt_exn : exn -> 'a option -> 'a

(** [unopt_assert ~loc x] is [y] if [x] is [Some y], or raises [Assert_failure loc] if [x] is [None] *)
val unopt_assert : loc:string * int * int * 'a -> 'b option -> 'b

(** First input of form [Some x], or [None] if both are [None] *)
val first_some : 'a option -> 'a option -> 'a option

(** [Some (f ())] if [f] does not raise, [None] otherwise *)
val try_with : (unit -> 'a) -> 'a option

(** Make an option of a value *)
val some : 'a -> 'a option

(** [pp ~default pp fmt x] pretty-print value [x] using [pp]
    or [default] (["None"] by default) string if there is no value. *)
val pp :
  ?default:string ->
  (Format.formatter -> 'a -> unit) ->
  Format.formatter ->
  'a option ->
  unit
src/lib_stdlib/option.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter map : forall {a b : Type}, (a -> b) -> (option a) -> option b.

Parameter apply : forall {a b : Type},
(a -> option b) -> (option a) -> option b.

Parameter op_gt_gt_eq : forall {a b : Type},
(option a) -> (a -> option b) -> option b.

Parameter op_gt_gt_pipe : forall {a b : Type},
(option a) -> (a -> b) -> option b.

Parameter iter : forall {a : Type}, (a -> unit) -> (option a) -> unit.

Parameter unopt : forall {a : Type}, a -> (option a) -> a.

Parameter unopt_map : forall {a b : Type}, (a -> b) -> b -> (option a) -> b.

Parameter unopt_exn : forall {a : Type}, exn -> (option a) -> a.

Parameter unopt_assert : forall {a b : Type},
(string * Z * Z * a) -> (option b) -> b.

Parameter first_some : forall {a : Type}, (option a) -> (option a) -> option a.

Parameter try_with : forall {a : Type}, (unit -> a) -> option a.

Parameter some : forall {a : Type}, a -> option a.

Parameter pp : forall {a : Type},
(option string) ->
  (Stdlib.Format.formatter -> a -> unit) ->
    Stdlib.Format.formatter -> (option a) -> unit.
src/lib_stdlib/registry.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type S = sig
  type k

  type v

  val register : k -> v -> unit

  val alter : k -> (v -> v) -> unit

  val remove : k -> unit

  val query : k -> v option

  val iter_p : (k -> v -> unit Lwt.t) -> unit Lwt.t

  val fold : (k -> v -> 'a -> 'a) -> 'a -> 'a
end

module Make (M : sig
  type v

  include Map.OrderedType
end) : S with type k = M.t and type v = M.v = struct
  module Reg = Map.Make (M)

  type v = M.v

  type k = Reg.key

  let registry : v Reg.t ref = ref Reg.empty

  let register k v = registry := Reg.add k v !registry

  let alter k f =
    match Reg.find_opt k !registry with
    | None ->
        ()
    | Some v ->
        registry := Reg.add k (f v) !registry

  let remove k = registry := Reg.remove k !registry

  let query k = Reg.find_opt k !registry

  let iter_p f = Lwt.join (Reg.fold (fun k v acc -> f k v :: acc) !registry [])

  let fold f a = Reg.fold f !registry a
end
src/lib_stdlib/registry.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Record signature {k v : Type} := {
    k := k;
    v := v;
    register : k -> v -> unit;
    alter : k -> (v -> v) -> unit;
    remove : k -> unit;
    query : k -> option v;
    iter_p : (k -> v -> Lwt.t unit) -> Lwt.t unit;
    fold : forall {a : Type}, (k -> v -> a -> a) -> a -> a;
  }.
  Arguments signature : clear implicits.
End S.
src/lib_stdlib/registry.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A simple imperative map *)

module type S = sig
  type k

  type v

  val register : k -> v -> unit

  val alter : k -> (v -> v) -> unit

  val remove : k -> unit

  val query : k -> v option

  val iter_p : (k -> v -> unit Lwt.t) -> unit Lwt.t

  val fold : (k -> v -> 'a -> 'a) -> 'a -> 'a
end

module Make (M : sig
  type v

  include Map.OrderedType
end) : S with type k = M.t and type v = M.v
src/lib_stdlib/registry.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

unhandled_module
src/lib_stdlib/ring.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Ring = struct
  type 'a raw = Empty of int | Inited of {data : 'a array; mutable pos : int}

  type 'a t = 'a raw ref

  let create size =
    if size <= 0 then invalid_arg "Ring.create: size must be positive"
    else ref (Empty size)

  let add r v =
    match !r with
    | Empty size ->
        r := Inited {data = Array.make size v; pos = 0}
    | Inited s ->
        s.pos <-
          ( if s.pos = (2 * Array.length s.data) - 1 then Array.length s.data
          else s.pos + 1 ) ;
        s.data.(s.pos mod Array.length s.data) <- v

  let add_and_return_erased r v =
    let replaced =
      match !r with
      | Empty _ ->
          None
      | Inited s ->
          if s.pos >= Array.length s.data - 1 then
            Some s.data.((s.pos + 1) mod Array.length s.data)
          else None
    in
    add r v ; replaced

  let clear r =
    match !r with
    | Empty _ ->
        ()
    | Inited {data; _} ->
        r := Empty (Array.length data)

  let add_list r l = List.iter (add r) l

  let last r =
    match !r with
    | Empty _ ->
        None
    | Inited {data; pos} ->
        Some data.(pos mod Array.length data)

  let fold r ~init ~f =
    match !r with
    | Empty _ ->
        init
    | Inited {data; pos} ->
        let size = Array.length data in
        let acc = ref init in
        for i = 0 to min pos (size - 1) do
          acc := f !acc data.((pos - i) mod size)
        done ;
        !acc

  let elements t = fold t ~init:[] ~f:(fun acc elt -> elt :: acc)

  exception Empty

  let last_exn r = match last r with None -> raise Empty | Some d -> d
end

include Ring

(** Ring Buffer Table *)
module type TABLE = sig
  type t

  type v

  val create : int -> t

  val add : t -> v -> unit

  val add_and_return_erased : t -> v -> v option

  val mem : t -> v -> bool

  val remove : t -> v -> unit

  val clear : t -> unit

  val elements : t -> v list
end

(* fixed size set of Peers id. If the set exceed the maximal allowed capacity, the
   element that was added first is removed when a new one is added *)
module MakeTable (V : Hashtbl.HashedType) = struct
  module Table = Hashtbl.Make (V)

  type raw = {size : int; ring : V.t Ring.t; table : unit Table.t}

  type t = raw ref

  type v = V.t

  let create size =
    ref {size; ring = Ring.create size; table = Table.create size}

  let add {contents = t} v =
    Option.iter (Ring.add_and_return_erased t.ring v) ~f:(Table.remove t.table) ;
    Table.add t.table v ()

  let add_and_return_erased {contents = t} v =
    match Ring.add_and_return_erased t.ring v with
    | None ->
        Table.add t.table v () ; None
    | Some erased ->
        Table.remove t.table erased ;
        Table.add t.table v () ;
        Some erased

  let mem {contents = t} v = Table.mem t.table v

  let remove {contents = t} v = Table.remove t.table v

  let clear ({contents = t} as tt) =
    tt := {t with ring = Ring.create t.size; table = Table.create t.size}

  let elements {contents = t} = Table.fold (fun k _ acc -> k :: acc) t.table []
end
src/lib_stdlib/ring.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Ring.
  Inductive raw (a : Type) : Type :=
  | Empty : Z -> raw a
  | Inited : (array a) -> Z -> raw a.
  
  Arguments Empty {_}.
  Arguments Inited {_}.
  
  Definition t (a : Type) := Stdlib.ref (raw a).
  
  Definition create {A : Type} (size : Z) : Stdlib.ref (raw A) :=
    if OCaml.Stdlib.le size 0 then
      OCaml.Stdlib.invalid_arg "Ring.create: size must be positive" % string
    else
      Stdlib.ref (Empty size).
  
  Definition add {A : Type} (r : Stdlib.ref (raw A)) (v : A) : unit :=
    match Stdlib.op_exclamation r with
    | Empty size =>
      Stdlib.op_colon_eq r
        (Inited {| data := Stdlib.Array.make size v; pos := 0 |})
    | Inited s =>
      set_field;
      Stdlib.Array.set (data s)
        (Z.modulo (pos s) (Stdlib.Array.length (data s))) v
    end.
  
  Definition add_and_return_erased {A : Type} (r : Stdlib.ref (raw A)) (v : A)
    : option A :=
    let replaced :=
      match Stdlib.op_exclamation r with
      | Empty _ => None
      | Inited s =>
        if OCaml.Stdlib.ge (pos s) (Z.sub (Stdlib.Array.length (data s)) 1) then
          Some
            (Stdlib.Array.get (data s)
              (Z.modulo (Z.add (pos s) 1) (Stdlib.Array.length (data s))))
        else
          None
      end in
    add r v;
    replaced.
  
  Definition clear {A : Type} (r : Stdlib.ref (raw A)) : unit :=
    match Stdlib.op_exclamation r with
    | Empty _ => tt
    | Inited {| data := data |} =>
      Stdlib.op_colon_eq r (Empty (Stdlib.Array.length data))
    end.
  
  Definition add_list {A : Type} (r : Stdlib.ref (raw A)) (l : list A) : unit :=
    Stdlib.List.iter (add r) l.
  
  Definition last {A : Type} (r : Stdlib.ref (raw A)) : option A :=
    match Stdlib.op_exclamation r with
    | Empty _ => None
    | Inited {| data := data; pos := pos |} =>
      Some (Stdlib.Array.get data (Z.modulo pos (Stdlib.Array.length data)))
    end.
  
  Definition fold {A B : Type}
    (r : Stdlib.ref (raw A)) (init : B) (f : B -> A -> B) : B :=
    match Stdlib.op_exclamation r with
    | Empty _ => init
    | Inited {| data := data; pos := pos |} =>
      let size := Stdlib.Array.length data in
      let acc := Stdlib.ref init in
      for;
      Stdlib.op_exclamation acc
    end.
  
  Definition elements {A : Type} (t : Stdlib.ref (raw A)) : list A :=
    fold t [] (fun acc => fun elt => cons elt acc).
  
  Definition last_exn {A : Type} (r : Stdlib.ref (raw A)) : A :=
    match last r with
    | None => Stdlib.raise Empty
    | Some d => d
    end.
End Ring.

Module TABLE.
  Record signature {t v : Type} := {
    t := t;
    v := v;
    create : Z -> t;
    add : t -> v -> unit;
    add_and_return_erased : t -> v -> option v;
    mem : t -> v -> bool;
    remove : t -> v -> unit;
    clear : t -> unit;
    elements : t -> list v;
  }.
  Arguments signature : clear implicits.
End TABLE.
src/lib_stdlib/ring.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Imperative Ring Buffer *)

(** An imperative ring buffer: a mutable structure that holds at most
    a fixed number of values of a same type. Values are never removed,
    once the limit is reached, adding a value replaces the oldest one
    in the ring buffer.  *)
exception Empty

type 'a t

(** Allocates a ring buffer for a given number of values. *)
val create : int -> 'a t

(** Adds a value, dropping the oldest present one if full. *)
val add : 'a t -> 'a -> unit

(** Same as {!add}, but returns the dropped value if any. *)
val add_and_return_erased : 'a t -> 'a -> 'a option

(** Adds the values of a list, in order. *)
val add_list : 'a t -> 'a list -> unit

(** Removes all values in the ring buffer. *)
val clear : 'a t -> unit

(** Retrieves the most recent value, or [None] when empty. *)
val last : 'a t -> 'a option

(** Same as {!last}, but raises {!Empty} when empty. *)
val last_exn : 'a t -> 'a

(** Iterates over the elements, oldest to newest. *)
val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b

(** Retrieves the elements as a list, oldest first.. *)
val elements : 'a t -> 'a list

(** Ring Buffer Table *)
module type TABLE = sig
  type t

  type v

  (** [create size] inizialize an empty ring *)
  val create : int -> t

  (** [add t v] add a value to the ring. If the ring already contains size elements,
      the first element is removed and [v] is added. *)
  val add : t -> v -> unit

  val add_and_return_erased : t -> v -> v option

  (** [mem t v] check if v is in the ring. O(1) *)
  val mem : t -> v -> bool

  (** [remove t v] remove one element from the table *)
  val remove : t -> v -> unit

  (** [retest t] remore all bindings from the current ring *)
  val clear : t -> unit

  (** [elements t] return the list of elements currently in the ring *)
  val elements : t -> v list
end

module MakeTable (V : Hashtbl.HashedType) : TABLE with type v = V.t
src/lib_stdlib/ring.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

exception

Parameter t : forall (a : Type), Type.

Parameter create : forall {a : Type}, Z -> t a.

Parameter add : forall {a : Type}, (t a) -> a -> unit.

Parameter add_and_return_erased : forall {a : Type}, (t a) -> a -> option a.

Parameter add_list : forall {a : Type}, (t a) -> (list a) -> unit.

Parameter clear : forall {a : Type}, (t a) -> unit.

Parameter last : forall {a : Type}, (t a) -> option a.

Parameter last_exn : forall {a : Type}, (t a) -> a.

Parameter fold : forall {a b : Type}, (t a) -> b -> (b -> a -> b) -> b.

Parameter elements : forall {a : Type}, (t a) -> list a.

module_type

unhandled_module
src/lib_stdlib/tag.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type _ selector = ..

module type DEF_ARG = sig
  val name : string

  type t

  val doc : string

  val pp : Format.formatter -> t -> unit
end

module type DEF = sig
  include DEF_ARG

  type id

  val id : id

  type _ selector += Me : t selector

  val uid : int
end

module Def (X : DEF_ARG) : DEF with type t = X.t = struct
  include X

  type id = Id

  let id = Id

  type _ selector += Me : t selector

  let uid = Obj.(extension_id @@ extension_constructor @@ Me)
end

type 'a def = (module DEF with type t = 'a)

let def (type a) ?(doc = "undocumented") name pp =
  ( module Def (struct
    let name = name

    type t = a

    let doc = doc

    let pp = pp
  end) : DEF
    with type t = a )

type (_, _) eq = Refl : ('a, 'a) eq

let maybe_eq : type a b. a def -> b def -> (a, b) eq option =
 fun s t ->
  let module S = (val s) in
  let module T = (val t) in
  match S.Me with T.Me -> Some Refl | _ -> None

let selector_of : type a. a def -> a selector =
 fun d ->
  let module D = (val d) in
  D.Me

let name : type a. a def -> string =
 fun d ->
  let module D = (val d) in
  D.name

let doc : type a. a def -> string =
 fun d ->
  let module D = (val d) in
  D.doc

let printer : type a. a def -> Format.formatter -> a -> unit =
 fun d ->
  let module D = (val d) in
  D.pp

let pp_def ppf d = Format.fprintf ppf "tag:%s" (name d)

module Key = struct
  type t = V : 'a def -> t

  type s = S : 'a selector -> s

  let compare (V k0) (V k1) = compare (S (selector_of k0)) (S (selector_of k1))
end

module TagSet = Map.Make (Key)

type t = V : 'a def * 'a -> t

type binding = t

type set = binding TagSet.t

let pp ppf (V (tag, v)) =
  Format.fprintf ppf "@[<1>(%a@ @[%a@])@]" pp_def tag (printer tag) v

let option_map f = function None -> None | Some v -> Some (f v)

let option_bind f = function None -> None | Some v -> f v

let reveal2 : type a b. a def -> b def -> b -> a option =
 fun t u v -> match maybe_eq t u with None -> None | Some Refl -> Some v

let reveal : 'a. 'a def -> binding -> 'a option =
 fun tag -> function V (another, v) -> reveal2 tag another v

let unveil : 'a. 'a def -> binding option -> 'a option =
 fun tag -> option_bind @@ reveal tag

let conceal : 'a. 'a def -> 'a -> binding = fun tag v -> V (tag, v)

let veil : 'a. 'a def -> 'a option -> binding option =
 fun tag -> option_map @@ conceal tag

let empty = TagSet.empty

let is_empty = TagSet.is_empty

let mem tag = TagSet.mem (Key.V tag)

let add tag v = TagSet.add (Key.V tag) (V (tag, v))

let update tag f =
  TagSet.update (Key.V tag) (fun b -> veil tag @@ f @@ unveil tag b)

let singleton tag v = TagSet.singleton (Key.V tag) (V (tag, v))

let remove tag = TagSet.remove (Key.V tag)

let rem = remove

type merger = {merger : 'a. 'a def -> 'a option -> 'a option -> 'a option}

let merge f =
  TagSet.merge
  @@ function
  | Key.V tag ->
      fun a b -> veil tag @@ f.merger tag (unveil tag a) (unveil tag b)

type unioner = {unioner : 'a. 'a def -> 'a -> 'a -> 'a}

let union f =
  merge
    {
      merger =
        (fun tag a b ->
          match (a, b) with
          | (Some aa, Some bb) ->
              Some (f.unioner tag aa bb)
          | (Some _, None) ->
              a
          | (None, _) ->
              b);
    }

(* no compare and equal, compare especially makes little sense *)
let iter f = TagSet.iter (fun _ -> f)

let fold f = TagSet.fold (fun _ -> f)

let for_all p = TagSet.for_all (fun _ -> p)

let exists p = TagSet.exists (fun _ -> p)

let filter p = TagSet.filter (fun _ -> p)

let partition p = TagSet.partition (fun _ -> p)

let cardinal = TagSet.cardinal

let bindings s = List.map snd @@ TagSet.bindings s

let min_binding s = snd @@ TagSet.min_binding s

let min_binding_opt s = option_map snd @@ TagSet.min_binding_opt s

let max_binding s = snd @@ TagSet.max_binding s

let max_binding_opt s = option_map snd @@ TagSet.max_binding_opt s

let choose s = snd @@ TagSet.choose s

let choose_opt s = option_map snd @@ TagSet.choose_opt s

let split tag s =
  (fun (l, m, r) -> (l, unveil tag m, r)) @@ TagSet.split (Key.V tag) s

(* In order to match the usual interface for maps, `find` should be different from
   `find_opt` but `Logs` has `find_opt` called `find` so we favor that. *)
let find tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s

let find_opt tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s

(* This would usually be called `find` but `Logs` has it with this name.  We can't
   have it at both named because `Logs` has `find_opt` as `find`. *)
let get tag s =
  find_opt tag s
  |> function
  | None ->
      invalid_arg (Format.asprintf "tag named %s not found in set" (name tag))
  | Some v ->
      v

let find_first p s = snd @@ TagSet.find_first p s

let find_first_opt p s = option_map snd @@ TagSet.find_first_opt p s

let find_last p s = snd @@ TagSet.find_last p s

let find_last_opt p s = option_map snd @@ TagSet.find_last_opt p s

let map = TagSet.map

let mapi = TagSet.map

let pp_set ppf s =
  Format.(
    fprintf ppf "@[<1>{" ;
    pp_print_list pp ppf (bindings s) ;
    Format.fprintf ppf "}@]")

module DSL = struct
  type (_, _, _, _) arg =
    | A : ('x def * 'x) -> (('b -> 'x -> 'c) -> 'x -> 'd, 'b, 'c, 'd) arg
    | S : ('x def * 'x) -> ('x -> 'd, 'b, 'c, 'd) arg
    | T : ('x def * 'x) -> ('d, 'b, 'c, 'd) arg

  let a tag v = A (tag, v)

  let s tag v = S (tag, v)

  let t tag v = T (tag, v)

  let pp_of_def (type a) tag =
    let module Tg = (val tag : DEF with type t = a) in
    Tg.pp

  let ( -% ) :
      type a d.
      (?tags:set -> a) -> (a, Format.formatter, unit, d) arg -> ?tags:set -> d
      =
   fun f -> function
    | A (tag, v) ->
        fun [@warning "-16"] ?(tags = empty) ->
          f ~tags:(add tag v tags) (pp_of_def tag) v
    | S (tag, v) ->
        fun [@warning "-16"] ?(tags = empty) -> f ~tags:(add tag v tags) v
    | T (tag, v) ->
        fun [@warning "-16"] ?(tags = empty) -> f ~tags:(add tag v tags)
end
src/lib_stdlib/tag.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition selector := False.

Module DEF_ARG.
  Record signature {t : Type} := {
    name : string;
    t := t;
    doc : string;
    pp : Stdlib.Format.formatter -> t -> unit;
  }.
  Arguments signature : clear implicits.
End DEF_ARG.

Module DEF.
  Record signature {t id : Type} := {
    include;
    id := id;
    id : id;
    extensible_type;
    uid : Z;
  }.
  Arguments signature : clear implicits.
End DEF.

Definition def (a : Type) := {id : _ & DEF.signature a id}.

Definition def {A : Type} (op_star_o_p_t_star : option string)
  : string ->
    (Stdlib.Format.formatter -> A -> unit) -> {id : _ & DEF.signature A id} :=
  let doc :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "undocumented" % string
    end in
  fun name => fun pp => unsupported_functor_application.

Inductive eq : forall (_ _ : Type), Type :=
| Refl : forall {a : Type}, eq a a.

Definition maybe_eq {a b : Type} (s : def a) (t : def b) : option (eq a b) :=
  let S := projT2 s in
  let T := projT2 t in
  match S.Me with
  | T.Me => Some Refl
  | _ => None
  end.

Definition selector_of {a : Type} (d : def a) : selector a :=
  let D := projT2 d in
  D.Me.

Definition name {a : Type} (d : def a) : string :=
  let D := projT2 d in
  D.(DEF.name).

Definition doc {a : Type} (d : def a) : string :=
  let D := projT2 d in
  D.(DEF.doc).

Definition printer {a : Type} (d : def a)
  : Stdlib.Format.formatter -> a -> unit :=
  let D := projT2 d in
  D.(DEF.pp).

Definition pp_def {A : Type} (ppf : Stdlib.Format.formatter) (d : def A)
  : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "tag:" % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format)) "tag:%s" % string) (name d).

Module Key.
  Inductive t : Type :=
  | V : forall {a : Type}, (def a) -> t.
  
  Inductive s : Type :=
  | S : forall {a : Type}, (selector a) -> s.
  
  Definition compare (function_parameter : t) : t -> Z :=
    match function_parameter with
    | V k0 =>
      fun function_parameter =>
        match function_parameter with
        | V k1 => OCaml.Stdlib.compare (S (selector_of k0)) (S (selector_of k1))
        end
    end.
End Key.

Inductive t : Type :=
| V : forall {a : Type}, (def a) -> a -> t.

Definition binding := t.

Definition set := TagSet.t binding.

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | V tag v =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<1>" % string
                CamlinternalFormatBasics.End_of_format) "<1>" % string))
          (CamlinternalFormatBasics.Char_literal "(" % char
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))))))
        "@[<1>(%a@ @[%a@])@]" % string) pp_def tag (printer tag) v
  end.

Definition option_map {A B : Type} (f : A -> B) (function_parameter : option A)
  : option B :=
  match function_parameter with
  | None => None
  | Some v => Some (f v)
  end.

Definition option_bind {A B : Type}
  (f : A -> option B) (function_parameter : option A) : option B :=
  match function_parameter with
  | None => None
  | Some v => f v
  end.

Definition reveal2 {a b : Type} (t : def a) (u : def b) (v : b) : option a :=
  match maybe_eq t u with
  | None => None
  | Some Refl => Some v
  end.

Definition reveal {a : Type} (tag : def a) (function_parameter : binding)
  : option a :=
  match function_parameter with
  | V another v => reveal2 tag another v
  end.

Definition unveil {a : Type} (tag : def a) : (option binding) -> option a :=
  apply option_bind (reveal tag).

Definition conceal {a : Type} (tag : def a) (v : a) : binding := V tag v.

Definition veil {a : Type} (tag : def a) : (option a) -> option binding :=
  apply option_map (conceal tag).

Definition empty {A : Type} : TagSet.t A := TagSet.empty.

Definition is_empty {A : Type} : (TagSet.t A) -> bool := TagSet.is_empty.

Definition mem {A B : Type} (tag : def A) : (TagSet.t B) -> bool :=
  TagSet.mem (Key.V tag).

Definition add {A : Type} (tag : def A) (v : A) : (TagSet.t t) -> TagSet.t t :=
  TagSet.add (Key.V tag) (V tag v).

Definition update {A : Type} (tag : def A) (f : (option A) -> option A)
  : (TagSet.t binding) -> TagSet.t binding :=
  TagSet.update (Key.V tag) (fun b => apply (veil tag) (apply f (unveil tag b))).

Definition singleton {A : Type} (tag : def A) (v : A) : TagSet.t t :=
  TagSet.singleton (Key.V tag) (V tag v).

Definition remove {A B : Type} (tag : def A) : (TagSet.t B) -> TagSet.t B :=
  TagSet.remove (Key.V tag).

Definition rem {A B : Type} : (def A) -> (TagSet.t B) -> TagSet.t B := remove.

Record merger := {
  merger : ((def a) -> (option a) -> (option a) -> option a) * (a) }.

Definition merge (f : merger)
  : (TagSet.t binding) -> (TagSet.t binding) -> TagSet.t binding :=
  apply TagSet.merge
    (fun function_parameter =>
      match function_parameter with
      | Key.V tag =>
        fun a =>
          fun b =>
            apply (veil tag) ((merger f) tag (unveil tag a) (unveil tag b))
      end).

Record unioner := {
  unioner : ((def a) -> a -> a -> a) * (a) }.

Definition union (f : unioner)
  : (TagSet.t binding) -> (TagSet.t binding) -> TagSet.t binding :=
  merge
    {|
      merger :=
        fun tag =>
          fun a =>
            fun b =>
              match (a, b) with
              | (Some aa, Some bb) => Some ((unioner f) tag aa bb)
              | (Some _, None) => a
              | (None, _) => b
              end |}.

Definition iter {A : Type} (f : A -> unit) : (TagSet.t A) -> unit :=
  TagSet.iter
    (fun function_parameter =>
      match function_parameter with
      | _ => f
      end).

Definition fold {A B : Type} (f : A -> B -> B) : (TagSet.t A) -> B -> B :=
  TagSet.fold
    (fun function_parameter =>
      match function_parameter with
      | _ => f
      end).

Definition for_all {A : Type} (p : A -> bool) : (TagSet.t A) -> bool :=
  TagSet.for_all
    (fun function_parameter =>
      match function_parameter with
      | _ => p
      end).

Definition _exists {A : Type} (p : A -> bool) : (TagSet.t A) -> bool :=
  TagSet._exists
    (fun function_parameter =>
      match function_parameter with
      | _ => p
      end).

Definition filter {A : Type} (p : A -> bool) : (TagSet.t A) -> TagSet.t A :=
  TagSet.filter
    (fun function_parameter =>
      match function_parameter with
      | _ => p
      end).

Definition partition {A : Type} (p : A -> bool)
  : (TagSet.t A) -> (TagSet.t A) * (TagSet.t A) :=
  TagSet.partition
    (fun function_parameter =>
      match function_parameter with
      | _ => p
      end).

Definition cardinal {A : Type} : (TagSet.t A) -> Z := TagSet.cardinal.

Definition bindings {A : Type} (s : TagSet.t A) : list A :=
  apply (List.map snd) (TagSet.bindings s).

Definition min_binding {A : Type} (s : TagSet.t A) : A :=
  apply snd (TagSet.min_binding s).

Definition min_binding_opt {A : Type} (s : TagSet.t A) : option A :=
  apply (option_map snd) (TagSet.min_binding_opt s).

Definition max_binding {A : Type} (s : TagSet.t A) : A :=
  apply snd (TagSet.max_binding s).

Definition max_binding_opt {A : Type} (s : TagSet.t A) : option A :=
  apply (option_map snd) (TagSet.max_binding_opt s).

Definition choose {A : Type} (s : TagSet.t A) : A := apply snd (TagSet.choose s).

Definition choose_opt {A : Type} (s : TagSet.t A) : option A :=
  apply (option_map snd) (TagSet.choose_opt s).

Definition split {A : Type} (tag : def A) (s : TagSet.t binding)
  : (TagSet.t binding) * (option A) * (TagSet.t binding) :=
  apply
    (fun function_parameter =>
      match function_parameter with
      | (l, m, r) => (l, (unveil tag m), r)
      end) (TagSet.split (Key.V tag) s).

Definition find {A : Type} (tag : def A) (s : TagSet.t binding) : option A :=
  apply (option_bind (reveal tag)) (TagSet.find_opt (Key.V tag) s).

Definition find_opt {A : Type} (tag : def A) (s : TagSet.t binding)
  : option A := apply (option_bind (reveal tag)) (TagSet.find_opt (Key.V tag) s).

Definition get {A : Type} (tag : def A) (s : TagSet.t binding) : A :=
  OCaml.Stdlib.reverse_apply (find_opt tag s)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        OCaml.Stdlib.invalid_arg
          (Stdlib.Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "tag named " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " not found in set" % string
                    CamlinternalFormatBasics.End_of_format)))
              "tag named %s not found in set" % string) (name tag))
      | Some v => v
      end).

Definition find_first {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
  : A := apply snd (TagSet.find_first p s).

Definition find_first_opt {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
  : option A := apply (option_map snd) (TagSet.find_first_opt p s).

Definition find_last {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A) : A :=
  apply snd (TagSet.find_last p s).

Definition find_last_opt {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
  : option A := apply (option_map snd) (TagSet.find_last_opt p s).

Definition map {A B : Type} : (A -> B) -> (TagSet.t A) -> TagSet.t B :=
  TagSet.map.

Definition mapi {A B : Type} : (A -> B) -> (TagSet.t A) -> TagSet.t B :=
  TagSet.map.

Definition pp_set (ppf : Stdlib.Format.formatter) (s : TagSet.t t) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<1>" % string
              CamlinternalFormatBasics.End_of_format) "<1>" % string))
        (CamlinternalFormatBasics.Char_literal "{" % char
          CamlinternalFormatBasics.End_of_format)) "@[<1>{" % string);
  Stdlib.Format.pp_print_list None pp ppf (bindings s);
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "}" % char
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          CamlinternalFormatBasics.End_of_format)) "}@]" % string).

Module DSL.
  Inductive arg : forall (_ _ _ _ : Type), Type :=
  | A : forall {b c d x : Type}, ((def x) * x) ->
    arg ((b -> x -> c) -> x -> d) b c d
  | S : forall {b c d x : Type}, ((def x) * x) -> arg (x -> d) b c d
  | T : forall {b c d x : Type}, ((def x) * x) -> arg d b c d.
  
  Definition a {A B C D : Type} (tag : def A) (v : A)
    : arg ((B -> A -> C) -> A -> D) B C D := A (tag, v).
  
  Definition s {A B C D : Type} (tag : def A) (v : A) : arg (A -> B) C D B :=
    S (tag, v).
  
  Definition t {A B C D : Type} (tag : def A) (v : A) : arg B C D B :=
    T (tag, v).
  
  Definition pp_of_def {A : Type} (tag : {id : _ & DEF.signature A id})
    : Stdlib.Format.formatter -> A -> unit :=
    let Tg := projT2 tag in
    Tg.(DEF.pp).
  
  Definition op_minus_percent {a d : Type}
    (f : (option set) -> a)
    (function_parameter : arg a Stdlib.Format.formatter unit d)
    : (option set) -> d :=
    match function_parameter with
    | A (tag, v) =>
      fun op_star_o_p_t_star =>
        let tags :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => empty
          end in
        f (Some (add tag v tags)) (pp_of_def tag) v
    | S (tag, v) =>
      fun op_star_o_p_t_star =>
        let tags :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => empty
          end in
        f (Some (add tag v tags)) v
    | T (tag, v) =>
      fun op_star_o_p_t_star =>
        let tags :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => empty
          end in
        f (Some (add tag v tags))
    end.
End DSL.
src/lib_stdlib/tag.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tags and tag sets.  Tags are basically similar to a plain extensible
    variant type, but wrapped with metadata that enables them to be printed
    generically and combined into tag sets where each tag is either not
    present or associated with a specific value.

    They are primarily intended for use with the `Logging` module but it
    would probably be reasonable to use them for other purposes. *)

(** Type of tag definitions.  Analogous to a constructor of an extensible
    variant type, but first-class. *)
type _ def

(** Define a new tag with a name, printer, and optional documentation string.
    This is generative, not applicative, so tag definitions created with
    identical names and printers at different times or places will be
    different tags!  You probably do not want to define a tag in a local
    scope unless you have something really tricky in mind.  Basically all
    the caveats you would have if you wrote [type t +=] apply. *)
val def : ?doc:string -> string -> (Format.formatter -> 'a -> unit) -> 'a def

val name : 'a def -> string

val doc : 'a def -> string

val printer : 'a def -> Format.formatter -> 'a -> unit

(** Print the name of a tag definition. *)
val pp_def : Format.formatter -> 'a def -> unit

(** A binding consisting of a tag and value.  If a `def` is a constructor
    of an extensible variant type, a `t` is a value of that type. *)
type t = V : 'a def * 'a -> t

val pp : Format.formatter -> t -> unit

module Key : sig
  type t = V : 'a def -> t
end

(** Tag sets.  If `t` is an extensible variant type, `set` is a set of `t`s
    no two of which have the same constructor.  Most ordinary set and map
    operations familiar from the OCaml standard library are provided.
    `equal` and `compare` are purposely not provided as there is no
    meaningful ordering on tags and their arguments may not even have a
    meaningful notion of equality. *)
type set

val empty : set

val is_empty : set -> bool

val mem : 'a def -> set -> bool

val add : 'a def -> 'a -> set -> set

val update : 'a def -> ('a option -> 'a option) -> set -> set

val singleton : 'a def -> 'a -> set

val remove : 'a def -> set -> set

val rem : 'a def -> set -> set

type merger = {merger : 'a. 'a def -> 'a option -> 'a option -> 'a option}

val merge : merger -> set -> set -> set

type unioner = {unioner : 'a. 'a def -> 'a -> 'a -> 'a}

val union : unioner -> set -> set -> set

val iter : (t -> unit) -> set -> unit

val fold : (t -> 'b -> 'b) -> set -> 'b -> 'b

val for_all : (t -> bool) -> set -> bool

val exists : (t -> bool) -> set -> bool

val filter : (t -> bool) -> set -> set

val partition : (t -> bool) -> set -> set * set

val cardinal : set -> int

val min_binding : set -> t

val min_binding_opt : set -> t option

val max_binding : set -> t

val max_binding_opt : set -> t option

val choose : set -> t

val choose_opt : set -> t option

val split : 'a def -> set -> set * 'a option * set

val find_opt : 'a def -> set -> 'a option

val find : 'a def -> set -> 'a option

val get : 'a def -> set -> 'a

val find_first : (Key.t -> bool) -> set -> t

val find_first_opt : (Key.t -> bool) -> set -> t option

val find_last : (Key.t -> bool) -> set -> t

val find_last_opt : (Key.t -> bool) -> set -> t option

val map : (t -> t) -> set -> set

val mapi : (t -> t) -> set -> set

val pp_set : Format.formatter -> set -> unit

(** DSL for logging messages.  Opening this locally makes it easy to supply a number
    of semantic tags for a log event while using their values in the human-readable
    text.  For example:

    {[
      lwt_log_info Tag.DSL.(fun f ->
          f "request for operations %a:%d from peer %a timed out."
          -% t event "request_operations_timeout"
          -% a Block_hash.Logging.tag bh
          -% s operations_index_tag n
          -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
    ]} *)
module DSL : sig
  type (_, _, _, _) arg

  (** Use a semantic tag with a `%a` format, supplying the pretty printer from the tag. *)
  val a : 'v def -> 'v -> (('b -> 'v -> 'c) -> 'v -> 'd, 'b, 'c, 'd) arg

  (** Use a semantic tag with ordinary formats such as `%s`, `%d`, and `%f`. *)
  val s : 'v def -> 'v -> ('v -> 'd, 'b, 'c, 'd) arg

  (** Supply a semantic tag without formatting it. *)
  val t : 'v def -> 'v -> ('d, 'b, 'c, 'd) arg

  (** Perform the actual application of a tag to a format. *)
  val ( -% ) :
    (?tags:set -> 'a) ->
    ('a, Format.formatter, unit, 'd) arg ->
    ?tags:set ->
    'd
end
src/lib_stdlib/tag.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter def : forall (_ : Type), Type.

Parameter def : forall {a : Type},
(option string) -> string -> (Stdlib.Format.formatter -> a -> unit) -> def a.

Parameter name : forall {a : Type}, (def a) -> string.

Parameter doc : forall {a : Type}, (def a) -> string.

Parameter printer : forall {a : Type},
(def a) -> Stdlib.Format.formatter -> a -> unit.

Parameter pp_def : forall {a : Type},
Stdlib.Format.formatter -> (def a) -> unit.

Inductive t : Type :=
| V : forall {a : Type}, (def a) -> a -> t.

Parameter pp : Stdlib.Format.formatter -> t -> unit.

Module Key.
  Inductive t : Type :=
  | V : forall {a : Type}, (def a) -> t.
End Key.

Parameter set : Type.

Parameter empty : set.

Parameter is_empty : set -> bool.

Parameter mem : forall {a : Type}, (def a) -> set -> bool.

Parameter add : forall {a : Type}, (def a) -> a -> set -> set.

Parameter update : forall {a : Type},
(def a) -> ((option a) -> option a) -> set -> set.

Parameter singleton : forall {a : Type}, (def a) -> a -> set.

Parameter remove : forall {a : Type}, (def a) -> set -> set.

Parameter rem : forall {a : Type}, (def a) -> set -> set.

Record merger := {
  merger : ((def a) -> (option a) -> (option a) -> option a) * (a) }.

Parameter merge : merger -> set -> set -> set.

Record unioner := {
  unioner : ((def a) -> a -> a -> a) * (a) }.

Parameter union : unioner -> set -> set -> set.

Parameter iter : (t -> unit) -> set -> unit.

Parameter fold : forall {b : Type}, (t -> b -> b) -> set -> b -> b.

Parameter for_all : (t -> bool) -> set -> bool.

Parameter _exists : (t -> bool) -> set -> bool.

Parameter filter : (t -> bool) -> set -> set.

Parameter partition : (t -> bool) -> set -> set * set.

Parameter cardinal : set -> Z.

Parameter min_binding : set -> t.

Parameter min_binding_opt : set -> option t.

Parameter max_binding : set -> t.

Parameter max_binding_opt : set -> option t.

Parameter choose : set -> t.

Parameter choose_opt : set -> option t.

Parameter split : forall {a : Type}, (def a) -> set -> set * (option a) * set.

Parameter find_opt : forall {a : Type}, (def a) -> set -> option a.

Parameter find : forall {a : Type}, (def a) -> set -> option a.

Parameter get : forall {a : Type}, (def a) -> set -> a.

Parameter find_first : (Key.t -> bool) -> set -> t.

Parameter find_first_opt : (Key.t -> bool) -> set -> option t.

Parameter find_last : (Key.t -> bool) -> set -> t.

Parameter find_last_opt : (Key.t -> bool) -> set -> option t.

Parameter map : (t -> t) -> set -> set.

Parameter mapi : (t -> t) -> set -> set.

Parameter pp_set : Stdlib.Format.formatter -> set -> unit.

Module DSL.
  Parameter arg : forall (_ _ _ _ : Type), Type.
  
  Parameter a : forall {b c d v : Type}, (def v) ->
    v -> arg ((b -> v -> c) -> v -> d) b c d.
  
  Parameter s : forall {b c d v : Type}, (def v) -> v -> arg (v -> d) b c d.
  
  Parameter t : forall {b c d v : Type}, (def v) -> v -> arg d b c d.
  
  Parameter op_minus_percent : forall {a d : Type}, ((option set) -> a) ->
    (arg a Stdlib.Format.formatter unit d) -> (option set) -> d.
End DSL.
src/lib_stdlib/test/assert.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf failwith "@[%s@ expected: %s@ got: %s@]" msg expected given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg
src/lib_stdlib/test/assert.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Stdlib.Format.kasprintf OCaml.Stdlib.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Stdlib.Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  match function_parameter with
  | _ => "" % string
  end.

Definition equal {A : Type} (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun op_star_o_p_t_star =>
    let prn :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.
src/lib_stdlib/test/test_lwt_pipe.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

let rec producer queue = function
  | 0 ->
      Format.eprintf "Done producing." ;
      Lwt.return_unit
  | n ->
      Lwt_pipe.push queue () >>= fun () -> producer queue (pred n)

let rec consumer queue = function
  | 0 ->
      Format.eprintf "Done consuming." ;
      Lwt.return_unit
  | n ->
      Lwt_pipe.pop queue >>= fun _ -> consumer queue (pred n)

let rec gen acc f = function 0 -> acc | n -> gen (f () :: acc) f (pred n)

let run qsize nbp nbc p c =
  let q = Lwt_pipe.create ~size:(qsize, fun () -> qsize) () in
  let producers = gen [] (fun () -> producer q p) nbp in
  let consumers = gen [] (fun () -> consumer q c) nbc in
  Lwt.join producers <&> Lwt.join consumers

let main () =
  let qsize = ref 10 in
  let nb_producers = ref 10 in
  let nb_consumers = ref 10 in
  let produced_per_producer = ref 10 in
  let consumed_per_consumer = ref 10 in
  let spec =
    Arg.
      [ ("-qsize", Set_int qsize, "<int> Size of the pipe");
        ("-nc", Set_int nb_consumers, "<int> Number of consumers");
        ("-np", Set_int nb_producers, "<int> Number of producers");
        ( "-n",
          Set_int consumed_per_consumer,
          "<int> Number of consumed items per consumers" );
        ( "-p",
          Set_int produced_per_producer,
          "<int> Number of produced items per producers" );
        ( "-v",
          Unit (fun () -> Lwt_log_core.(add_rule "*" Info)),
          " Log up to info msgs" );
        ( "-vv",
          Unit (fun () -> Lwt_log_core.(add_rule "*" Debug)),
          " Log up to debug msgs" ) ]
  in
  let anon_fun _ = () in
  let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
  Arg.parse spec anon_fun usage_msg ;
  run
    !qsize
    !nb_producers
    !nb_consumers
    !produced_per_producer
    !consumed_per_consumer

let () = Lwt_main.run @@ main ()
src/lib_stdlib/test/test_lwt_pipe.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Fixpoint producer
  (queue : Tezos_stdlib.Lwt_pipe.t unit) (function_parameter : Z)
  : Lwt.t unit :=
  match function_parameter with
  | 0 =>
    Stdlib.Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Done producing." % string
          CamlinternalFormatBasics.End_of_format) "Done producing." % string);
    Lwt.return_unit
  | n =>
    Lwt.Infix.op_gt_gt_eq (Tezos_stdlib.Lwt_pipe.push queue tt)
      (fun function_parameter =>
        match function_parameter with
        | tt => producer queue (Z.pred n)
        end)
  end.

Fixpoint consumer {A : Type}
  (queue : Tezos_stdlib.Lwt_pipe.t A) (function_parameter : Z) : Lwt.t unit :=
  match function_parameter with
  | 0 =>
    Stdlib.Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Done consuming." % string
          CamlinternalFormatBasics.End_of_format) "Done consuming." % string);
    Lwt.return_unit
  | n =>
    Lwt.Infix.op_gt_gt_eq (Tezos_stdlib.Lwt_pipe.pop queue)
      (fun function_parameter =>
        match function_parameter with
        | _ => consumer queue (Z.pred n)
        end)
  end.

Fixpoint gen {A : Type} (acc : list A) (f : unit -> A) (function_parameter : Z)
  : list A :=
  match function_parameter with
  | 0 => acc
  | n => gen (cons (f tt) acc) f (Z.pred n)
  end.

Definition run (qsize : Z) (nbp : Z) (nbc : Z) (p : Z) (c : Z) : Lwt.t unit :=
  let q :=
    Tezos_stdlib.Lwt_pipe.create
      (Some
        (qsize,
          (fun function_parameter =>
            match function_parameter with
            | tt => qsize
            end))) tt in
  let producers :=
    gen []
      (fun function_parameter =>
        match function_parameter with
        | tt => producer q p
        end) nbp in
  let consumers :=
    gen []
      (fun function_parameter =>
        match function_parameter with
        | tt => consumer q c
        end) nbc in
  Lwt.Infix.op_lt_and_gt (Lwt.join producers) (Lwt.join consumers).

Definition main (function_parameter : unit) : Lwt.t unit :=
  match function_parameter with
  | tt =>
    let qsize := Stdlib.ref 10 in
    let nb_producers := Stdlib.ref 10 in
    let nb_consumers := Stdlib.ref 10 in
    let produced_per_producer := Stdlib.ref 10 in
    let consumed_per_consumer := Stdlib.ref 10 in
    let spec :=
      cons
        ("-qsize" % string, (Set_int qsize), "<int> Size of the pipe" % string)
        (cons
          ("-nc" % string, (Set_int nb_consumers),
            "<int> Number of consumers" % string)
          (cons
            ("-np" % string, (Set_int nb_producers),
              "<int> Number of producers" % string)
            (cons
              ("-n" % string, (Set_int consumed_per_consumer),
                "<int> Number of consumed items per consumers" % string)
              (cons
                ("-p" % string, (Set_int produced_per_producer),
                  "<int> Number of produced items per producers" % string)
                (cons
                  ("-v" % string,
                    (Unit
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
                        end)), " Log up to info msgs" % string)
                  (cons
                    ("-vv" % string,
                      (Unit
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
                          end)), " Log up to debug msgs" % string) [])))))) in
    let anon_fun {A : Type} (function_parameter : A) : unit :=
      match function_parameter with
      | _ => tt
      end in
    let usage_msg := "Usage: %s <num_peers>.
Arguments are:" % string in
    Stdlib.Arg.parse spec anon_fun usage_msg;
    run (Stdlib.op_exclamation qsize) (Stdlib.op_exclamation nb_producers)
      (Stdlib.op_exclamation nb_consumers)
      (Stdlib.op_exclamation produced_per_producer)
      (Stdlib.op_exclamation consumed_per_consumer)
  end.
src/lib_stdlib/test/test_tzList.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let rec permut = function
  | [] ->
      [[]]
  | x :: xs ->
      let insert xs =
        let rec loop acc left right =
          match right with
          | [] ->
              List.rev (x :: left) :: acc
          | y :: ys ->
              loop (List.rev_append left (x :: right) :: acc) (y :: left) ys
        in
        loop [] [] xs
      in
      List.concat (List.map insert (permut xs))

let test_take_n _ =
  ListLabels.iter
    (permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
    ~f:(fun xs -> Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 1 xs) [9]) ;
  ListLabels.iter
    (permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
    ~f:(fun xs ->
      Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 3 xs) [7; 8; 9]) ;
  let inv_compare x y = compare y x in
  ListLabels.iter
    (permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
    ~f:(fun xs ->
      Assert.equal
        ~msg:__LOC__
        (TzList.take_n ~compare:inv_compare 3 xs)
        [3; 2; 1]) ;
  (* less elements than the bound. *)
  ListLabels.iter
    (permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
    ~f:(fun xs ->
      Assert.equal
        ~msg:__LOC__
        (TzList.take_n ~compare 12 xs)
        [1; 2; 3; 4; 5; 6; 7; 8; 9]) ;
  (* with duplicates. *)
  ListLabels.iter
    (permut [1; 2; 3; 3; 4; 5; 5; 5; 6])
    ~f:(fun xs ->
      Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 3 xs) [5; 5; 6]) ;
  ListLabels.iter
    (permut [1; 2; 3; 3; 4; 5; 5; 5; 6])
    ~f:(fun xs ->
      Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 5 xs) [4; 5; 5; 5; 6])

let tests = [("take_n", `Quick, test_take_n)]

let () = Alcotest.run "stdlib" [("tzList", tests)]
src/lib_stdlib/test/test_tzList.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Fixpoint permut {A : Type} (function_parameter : list A) : list (list A) :=
  match function_parameter with
  | [] => cons [] []
  | cons x xs =>
    let insert (xs : list A) : list (list A) :=
      let fix loop (acc : list (list A)) (left : list A) (right : list A)
        : list (list A) :=
        match right with
        | [] => cons (List.rev (cons x left)) acc
        | cons y ys =>
          loop (cons (Stdlib.List.rev_append left (cons x right)) acc)
            (cons y left) ys
        end in
      loop [] [] xs in
    Stdlib.List.concat (List.map insert (permut xs))
  end.

Definition test_take_n {A : Type} (function_parameter : A) : unit :=
  match function_parameter with
  | _ =>
    Stdlib.ListLabels.iter
      (fun xs =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
          (Tezos_stdlib.TzList.take_n (Some OCaml.Stdlib.compare) 1 xs)
          (cons 9 []))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))));
    Stdlib.ListLabels.iter
      (fun xs =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
          (Tezos_stdlib.TzList.take_n (Some OCaml.Stdlib.compare) 3 xs)
          (cons 7 (cons 8 (cons 9 []))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))));
    let inv_compare {B : Type} (x : B) (y : B) : Z :=
      OCaml.Stdlib.compare y x in
    Stdlib.ListLabels.iter
      (fun xs =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
          (Tezos_stdlib.TzList.take_n (Some inv_compare) 3 xs)
          (cons 3 (cons 2 (cons 1 []))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))));
    Stdlib.ListLabels.iter
      (fun xs =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
          (Tezos_stdlib.TzList.take_n (Some OCaml.Stdlib.compare) 12 xs)
          (cons 1
            (cons 2
              (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))));
    Stdlib.ListLabels.iter
      (fun xs =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
          (Tezos_stdlib.TzList.take_n (Some OCaml.Stdlib.compare) 3 xs)
          (cons 5 (cons 5 (cons 6 []))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 3 (cons 4 (cons 5 (cons 5 (cons 5 (cons 6 []))))))))));
    Stdlib.ListLabels.iter
      (fun xs =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
          (Tezos_stdlib.TzList.take_n (Some OCaml.Stdlib.compare) 5 xs)
          (cons 4 (cons 5 (cons 5 (cons 5 (cons 6 []))))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 3 (cons 4 (cons 5 (cons 5 (cons 5 (cons 6 []))))))))))
  end.

Definition tests {A : Type} : list (string * variant * (A -> unit)) :=
  cons ("take_n" % string, variant, test_take_n) [].
src/lib_stdlib/tzEndian.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Bytes_encodings

let set_int32 = set_int32_be

let get_int32 = get_int32_be

let set_int8 = set_int8

let get_int8 = get_int8

let set_int16 = set_int16_be

let get_int16 = get_int16_be

let set_int64 = set_int64_be

let get_int64 = get_int64_be

let get_uint8 = get_uint8

let get_uint16 = get_uint16_be

let get_double buff i = Int64.float_of_bits (get_int64_be buff i)

let set_double buff i v = set_int64_be buff i (Int64.bits_of_float v)
src/lib_stdlib/tzEndian.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_stdlib.Bytes_encodings.

Definition set_int32 : string -> Z -> int32 -> unit :=
  Tezos_stdlib.Bytes_encodings.set_int32_be.

Definition get_int32 : string -> Z -> int32 :=
  Tezos_stdlib.Bytes_encodings.get_int32_be.

Definition set_int8 : string -> Z -> Z -> unit :=
  Tezos_stdlib.Bytes_encodings.set_int8.

Definition get_int8 : string -> Z -> Z := Tezos_stdlib.Bytes_encodings.get_int8.

Definition set_int16 : string -> Z -> Z -> unit :=
  Tezos_stdlib.Bytes_encodings.set_int16_be.

Definition get_int16 : string -> Z -> Z :=
  Tezos_stdlib.Bytes_encodings.get_int16_be.

Definition set_int64 : string -> Z -> int64 -> unit :=
  Tezos_stdlib.Bytes_encodings.set_int64_be.

Definition get_int64 : string -> Z -> int64 :=
  Tezos_stdlib.Bytes_encodings.get_int64_be.

Definition get_uint8 : string -> Z -> Z :=
  Tezos_stdlib.Bytes_encodings.get_uint8.

Definition get_uint16 : string -> Z -> Z :=
  Tezos_stdlib.Bytes_encodings.get_uint16_be.

Definition get_double (buff : string) (i : Z) : float :=
  Stdlib.Int64.float_of_bits (Tezos_stdlib.Bytes_encodings.get_int64_be buff i).

Definition set_double (buff : string) (i : Z) (v : float) : unit :=
  Tezos_stdlib.Bytes_encodings.set_int64_be buff i
    (Stdlib.Int64.bits_of_float v).
src/lib_stdlib/tzEndian.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val get_int32 : bytes -> int -> int32

val set_int32 : bytes -> int -> int32 -> unit

val set_int8 : bytes -> int -> int -> unit

val get_int8 : bytes -> int -> int

val set_int16 : bytes -> int -> int -> unit

val get_int16 : bytes -> int -> int

val set_int64 : bytes -> int -> int64 -> unit

val get_int64 : bytes -> int -> int64

val get_uint8 : bytes -> int -> int

val get_uint16 : bytes -> int -> int

val set_double : bytes -> int -> float -> unit

val get_double : bytes -> int -> float
src/lib_stdlib/tzEndian.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_int32 : string -> Z -> int32.

Parameter set_int32 : string -> Z -> int32 -> unit.

Parameter set_int8 : string -> Z -> Z -> unit.

Parameter get_int8 : string -> Z -> Z.

Parameter set_int16 : string -> Z -> Z -> unit.

Parameter get_int16 : string -> Z -> Z.

Parameter set_int64 : string -> Z -> int64 -> unit.

Parameter get_int64 : string -> Z -> int64.

Parameter get_uint8 : string -> Z -> Z.

Parameter get_uint16 : string -> Z -> Z.

Parameter set_double : string -> Z -> float -> unit.

Parameter get_double : string -> Z -> float.
src/lib_stdlib/tzList.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let may_cons xs x = match x with None -> xs | Some x -> x :: xs

let filter_map f l =
  List.rev @@ List.fold_left (fun acc x -> may_cons acc (f x)) [] l

let rev_sub l n =
  if n < 0 then invalid_arg "Utils.rev_sub: `n` must be non-negative." ;
  let rec append_rev_sub acc l = function
    | 0 ->
        acc
    | n -> (
      match l with
      | [] ->
          acc
      | hd :: tl ->
          append_rev_sub (hd :: acc) tl (n - 1) )
  in
  append_rev_sub [] l n

let sub l n = rev_sub l n |> List.rev

let hd_opt = function [] -> None | h :: _ -> Some h

let rec last_exn = function
  | [] ->
      raise Not_found
  | [x] ->
      x
  | _ :: xs ->
      last_exn xs

let merge_filter2 ?(finalize = List.rev) ?(compare = compare)
    ?(f = Option.first_some) l1 l2 =
  let sort = List.sort compare in
  let rec merge_aux acc = function
    | ([], []) ->
        finalize acc
    | (r1, []) ->
        finalize acc @ filter_map (fun x1 -> f (Some x1) None) r1
    | ([], r2) ->
        finalize acc @ filter_map (fun x2 -> f None (Some x2)) r2
    | ((h1 :: t1 as r1), (h2 :: t2 as r2)) ->
        if compare h1 h2 > 0 then
          merge_aux (may_cons acc (f None (Some h2))) (r1, t2)
        else if compare h1 h2 < 0 then
          merge_aux (may_cons acc (f (Some h1) None)) (t1, r2)
        else
          (* m1 = m2 *)
          merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2)
  in
  merge_aux [] (sort l1, sort l2)

let merge2 ?finalize ?compare ?(f = fun x1 _x1 -> x1) l1 l2 =
  merge_filter2
    ?finalize
    ?compare
    ~f:(fun x1 x2 ->
      match (x1, x2) with
      | (None, None) ->
          assert false
      | (Some x1, None) ->
          Some x1
      | (None, Some x2) ->
          Some x2
      | (Some x1, Some x2) ->
          Some (f x1 x2))
    l1
    l2

let rec remove nb = function
  | [] ->
      []
  | l when nb <= 0 ->
      l
  | _ :: tl ->
      remove (nb - 1) tl

let rec repeat n x = if n <= 0 then [] else x :: repeat (pred n) x

let split_n n l =
  let rec loop acc n = function
    | [] ->
        (l, [])
    | rem when n <= 0 ->
        (List.rev acc, rem)
    | x :: xs ->
        loop (x :: acc) (pred n) xs
  in
  loop [] n l

let take_n_unsorted n l = fst (split_n n l)

module Bounded (E : Set.OrderedType) : sig
  type t

  val create : int -> t

  val insert : E.t -> t -> unit

  val get : t -> E.t list
end = struct
  (* TODO one day replace the list by an heap array *)

  type t = {bound : int; mutable size : int; mutable data : E.t list}

  let create bound =
    if bound <= 0 then invalid_arg "Utils.Bounded(_).create" ;
    {bound; size = 0; data = []}

  let rec push x = function
    | [] ->
        [x]
    | y :: xs as ys ->
        if E.compare x y <= 0 then x :: ys else y :: push x xs

  let insert x t =
    if t.size < t.bound then (
      t.size <- t.size + 1 ;
      t.data <- push x t.data )
    else
      match t.data with
      | [] ->
          assert false
      | hd :: tl ->
          if E.compare hd x < 0 then t.data <- push x tl

  let get {data; _} = data
end

let take_n_sorted (type a) compare n l =
  let module B = Bounded (struct
    type t = a

    let compare = compare
  end) in
  let t = B.create n in
  List.iter (fun x -> B.insert x t) l ;
  B.get t

let take_n ?compare n l =
  match compare with
  | None ->
      take_n_unsorted n l
  | Some compare ->
      take_n_sorted compare n l

let select n l =
  let rec loop n acc = function
    | [] ->
        invalid_arg "Utils.select"
    | x :: xs when n <= 0 ->
        (x, List.rev_append acc xs)
    | x :: xs ->
        loop (pred n) (x :: acc) xs
  in
  loop n [] l

let shift = function [] -> [] | hd :: tl -> tl @ [hd]

let rec product a b =
  match a with
  | [] ->
      []
  | hd :: tl ->
      List.map (fun x -> (hd, x)) b @ product tl b

let shuffle l =
  l
  |> List.map (fun d -> (Random.bits (), d))
  |> List.sort (fun (x, _) (y, _) -> compare x y)
  |> List.map snd
src/lib_stdlib/tzList.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition may_cons {A : Type} (xs : list A) (x : option A) : list A :=
  match x with
  | None => xs
  | Some x => cons x xs
  end.

Definition filter_map {A B : Type} (f : A -> option B) (l : list A) : list B :=
  apply List.rev
    (Stdlib.List.fold_left (fun acc => fun x => may_cons acc (f x)) [] l).

Definition rev_sub {A : Type} (l : list A) (n : Z) : list A :=
  if OCaml.Stdlib.lt n 0 then
    OCaml.Stdlib.invalid_arg "Utils.rev_sub: `n` must be non-negative." % string
  else
    tt;
  let fix append_rev_sub {B : Type}
    (acc : list B) (l : list B) (function_parameter : Z) : list B :=
    match function_parameter with
    | 0 => acc
    | n =>
      match l with
      | [] => acc
      | cons hd tl => append_rev_sub (cons hd acc) tl (Z.sub n 1)
      end
    end in
  append_rev_sub [] l n.

Definition sub {A : Type} (l : list A) (n : Z) : list A :=
  OCaml.Stdlib.reverse_apply (rev_sub l n) List.rev.

Definition hd_opt {A : Type} (function_parameter : list A) : option A :=
  match function_parameter with
  | [] => None
  | cons h _ => Some h
  end.

Fixpoint last_exn {A : Type} (function_parameter : list A) : A :=
  match function_parameter with
  | [] => Stdlib.raise OCaml.Not_found
  | cons x [] => x
  | cons _ xs => last_exn xs
  end.

Definition merge_filter2 {A : Type}
  (op_star_o_p_t_star : option ((list A) -> list A))
  : (option (A -> A -> Z)) ->
    (option ((option A) -> (option A) -> option A)) ->
      (list A) -> (list A) -> list A :=
  let finalize :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => List.rev
    end in
  fun op_star_o_p_t_star =>
    let compare :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => OCaml.Stdlib.compare
      end in
    fun op_star_o_p_t_star =>
      let f :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => Tezos_stdlib.Option.first_some
        end in
      fun l1 =>
        fun l2 =>
          let sort := Stdlib.List.sort compare in
          let fix merge_aux
            (acc : list A) (function_parameter : (list A) * (list A))
            : list A :=
            match function_parameter with
            | ([], []) => finalize acc
            | (r1, []) =>
              OCaml.Stdlib.app (finalize acc)
                (filter_map (fun x1 => f (Some x1) None) r1)
            | ([], r2) =>
              OCaml.Stdlib.app (finalize acc)
                (filter_map (fun x2 => f None (Some x2)) r2)
            | ((cons h1 t1) as r1, (cons h2 t2) as r2) =>
              if OCaml.Stdlib.gt (compare h1 h2) 0 then
                merge_aux (may_cons acc (f None (Some h2))) (r1, t2)
              else
                if OCaml.Stdlib.lt (compare h1 h2) 0 then
                  merge_aux (may_cons acc (f (Some h1) None)) (t1, r2)
                else
                  merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2)
            end in
          merge_aux [] ((sort l1), (sort l2)).

Definition merge2 {A : Type}
  (finalize : option ((list A) -> list A)) (compare : option (A -> A -> Z))
  (op_star_o_p_t_star : option (A -> A -> A))
  : (list A) -> (list A) -> list A :=
  let f :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => fun x1 => fun _x1 => x1
    end in
  fun l1 =>
    fun l2 =>
      merge_filter2 finalize compare
        (Some
          (fun x1 =>
            fun x2 =>
              match (x1, x2) with
              | (None, None) => false
              | (Some x1, None) => Some x1
              | (None, Some x2) => Some x2
              | (Some x1, Some x2) => Some (f x1 x2)
              end)) l1 l2.

Fixpoint remove {A : Type} (nb : Z) (function_parameter : list A) : list A :=
  match function_parameter with
  | [] => []
  | l => l
  | cons _ tl => remove (Z.sub nb 1) tl
  end.

Fixpoint repeat {A : Type} (n : Z) (x : A) : list A :=
  if OCaml.Stdlib.le n 0 then
    []
  else
    cons x (repeat (Z.pred n) x).

Definition split_n {A : Type} (n : Z) (l : list A) : (list A) * (list A) :=
  let fix loop (acc : list A) (n : Z) (function_parameter : list A)
    : (list A) * (list A) :=
    match function_parameter with
    | [] => (l, [])
    | rem => ((List.rev acc), rem)
    | cons x xs => loop (cons x acc) (Z.pred n) xs
    end in
  loop [] n l.

Definition take_n_unsorted {A : Type} (n : Z) (l : list A) : list A :=
  fst (split_n n l).

Definition take_n_sorted {A : Type} (compare : A -> A -> Z) (n : Z) (l : list A)
  : list A :=
  let B := unsupported_functor_application in
  let t := B.create n in
  Stdlib.List.iter (fun x => B.insert x t) l;
  B.get t.

Definition take_n {A : Type}
  (compare : option (A -> A -> Z)) (n : Z) (l : list A) : list A :=
  match compare with
  | None => take_n_unsorted n l
  | Some compare => take_n_sorted compare n l
  end.

Definition select {A : Type} (n : Z) (l : list A) : A * (list A) :=
  let fix loop {B : Type} (n : Z) (acc : list B) (function_parameter : list B)
    : B * (list B) :=
    match function_parameter with
    | [] => OCaml.Stdlib.invalid_arg "Utils.select" % string
    | cons x xs => (x, (Stdlib.List.rev_append acc xs))
    | cons x xs => loop (Z.pred n) (cons x acc) xs
    end in
  loop n [] l.

Definition shift {A : Type} (function_parameter : list A) : list A :=
  match function_parameter with
  | [] => []
  | cons hd tl => OCaml.Stdlib.app tl (cons hd [])
  end.

Fixpoint product {A B : Type} (a : list A) (b : list B) : list (A * B) :=
  match a with
  | [] => []
  | cons hd tl =>
    OCaml.Stdlib.app (List.map (fun x => (hd, x)) b) (product tl b)
  end.

Definition shuffle {A : Type} (l : list A) : list A :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply l
        (List.map (fun d => ((Stdlib.Random.bits tt), d))))
      (Stdlib.List.sort
        (fun function_parameter =>
          match function_parameter with
          | (x, _) =>
            fun function_parameter =>
              match function_parameter with
              | (y, _) => OCaml.Stdlib.compare x y
              end
          end))) (List.map snd).
src/lib_stdlib/tzList.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** [remove nb list] remove the first [nb] elements from the list [list]. *)
val remove : int -> 'a list -> 'a list

(** [repeat n x] is a list of [n] [x]'s *)
val repeat : int -> 'a -> 'a list

(** [shift (hd :: tl)] computes [tl @ [hd]] *)
val shift : 'a list -> 'a list

(** [product a b] computes the Cartesian product of two lists [a] and [b]. *)
val product : 'a list -> 'b list -> ('a * 'b) list

(** [take_n n l] returns the [n] first elements of [l]. When [compare]
    is provided, it returns the [n] greatest element of [l]. *)
val take_n : ?compare:('a -> 'a -> int) -> int -> 'a list -> 'a list

(** [split_n n l] is a pair of lists [(j, k)] where [j] contains the [n] first
    elements of [l] and [k] the remainder elements. If [l] has less than or
    exactly [n] elements, [j] is [l] and [k] is [[]]. *)
val split_n : int -> 'a list -> 'a list * 'a list

(** Bounded sequence: keep only the [n] greatest elements. *)
module Bounded (E : Set.OrderedType) : sig
  type t

  val create : int -> t

  val insert : E.t -> t -> unit

  val get : t -> E.t list
end

(** [select n l] is ([n]th element of [l], [l] without that element) *)
val select : int -> 'a list -> 'a * 'a list

(** [filter_map f l] is [[y for x in l where (f x) = Some y]] *)
val filter_map : ('a -> 'b option) -> 'a list -> 'b list

(** [rev_sub l n] is [List.rev l] capped to max [n] elements *)
val rev_sub : 'a list -> int -> 'a list

(** [sub l n] is [l] capped to max [n] elements *)
val sub : 'a list -> int -> 'a list

(** Like [List.hd], but [Some hd] or [None] if empty *)
val hd_opt : 'a list -> 'a option

(** Last elt of list, or raise Not_found if empty *)
val last_exn : 'a list -> 'a

(** [merge_filter2 ~compare ~f l1 l2] merges two lists ordered by [compare]
    and whose items can be merged with [f]. Item is discarded or kept whether
    [f] returns [Some] or [None] *)
val merge_filter2 :
  ?finalize:('a list -> 'a list) ->
  ?compare:('a -> 'a -> int) ->
  ?f:('a option -> 'a option -> 'a option) ->
  'a list ->
  'a list ->
  'a list

(** [merge2 ~compare ~f l1 l2] merges two lists ordered by [compare] and
    whose items can be merged with [f] *)
val merge2 :
  ?finalize:('a list -> 'a list) ->
  ?compare:('a -> 'a -> int) ->
  ?f:('a -> 'a -> 'a) ->
  'a list ->
  'a list ->
  'a list

(** [shuffle l] is a list that contains the same elements as [l] but in a random
    order. *)
val shuffle : 'a list -> 'a list
src/lib_stdlib/tzList.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter remove : forall {a : Type}, Z -> (list a) -> list a.

Parameter repeat : forall {a : Type}, Z -> a -> list a.

Parameter shift : forall {a : Type}, (list a) -> list a.

Parameter product : forall {a b : Type}, (list a) -> (list b) -> list (a * b).

Parameter take_n : forall {a : Type},
(option (a -> a -> Z)) -> Z -> (list a) -> list a.

Parameter split_n : forall {a : Type}, Z -> (list a) -> (list a) * (list a).

unhandled_module

Parameter select : forall {a : Type}, Z -> (list a) -> a * (list a).

Parameter filter_map : forall {a b : Type},
(a -> option b) -> (list a) -> list b.

Parameter rev_sub : forall {a : Type}, (list a) -> Z -> list a.

Parameter sub : forall {a : Type}, (list a) -> Z -> list a.

Parameter hd_opt : forall {a : Type}, (list a) -> option a.

Parameter last_exn : forall {a : Type}, (list a) -> a.

Parameter merge_filter2 : forall {a : Type},
(option ((list a) -> list a)) ->
  (option (a -> a -> Z)) ->
    (option ((option a) -> (option a) -> option a)) ->
      (list a) -> (list a) -> list a.

Parameter merge2 : forall {a : Type},
(option ((list a) -> list a)) ->
  (option (a -> a -> Z)) ->
    (option (a -> a -> a)) -> (list a) -> (list a) -> list a.

Parameter shuffle : forall {a : Type}, (list a) -> list a.
src/lib_stdlib/tzString.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Set = Set.Make (String)
module Map = Map.Make (String)

let split delim ?(dup = true) ?(limit = max_int) path =
  let l = String.length path in
  let rec do_slashes acc limit i =
    if i >= l then List.rev acc
    else if path.[i] = delim then
      if dup then do_slashes acc limit (i + 1) else do_split acc limit (i + 1)
    else do_split acc limit i
  and do_split acc limit i =
    if limit <= 0 then
      if i = l then List.rev acc
      else List.rev (String.sub path i (l - i) :: acc)
    else do_component acc (pred limit) i i
  and do_component acc limit i j =
    if j >= l then
      if i = j then List.rev acc
      else List.rev (String.sub path i (j - i) :: acc)
    else if path.[j] = delim then
      do_slashes (String.sub path i (j - i) :: acc) limit j
    else do_component acc limit i (j + 1)
  in
  if limit > 0 then do_slashes [] limit 0 else [path]

let split_path path = split '/' path

let has_prefix ~prefix s =
  let x = String.length prefix in
  let n = String.length s in
  n >= x && String.sub s 0 x = prefix

let remove_prefix ~prefix s =
  let x = String.length prefix in
  let n = String.length s in
  if n >= x && String.sub s 0 x = prefix then Some (String.sub s x (n - x))
  else None

let common_prefix s1 s2 =
  let last = min (String.length s1) (String.length s2) in
  let rec loop i =
    if last <= i then last else if s1.[i] = s2.[i] then loop (i + 1) else i
  in
  loop 0

let mem_char s c = String.index_opt s c <> None

let fold_left f init s =
  let acc = ref init in
  String.iter (fun c -> acc := f !acc c) s ;
  !acc

let is_hex s =
  let len = String.length s in
  len mod 2 = 0
  &&
  try
    for i = 0 to len - 1 do
      match s.[i] with
      | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' ->
          ()
      | _ ->
          raise Exit
    done ;
    true
  with Exit -> false
src/lib_stdlib/tzString.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition split (delim : ascii) (op_star_o_p_t_star : option bool)
  : (option Z) -> string -> list string :=
  let dup :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun op_star_o_p_t_star =>
    let limit :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => Stdlib.max_int
      end in
    fun path =>
      let l := OCaml.String.length path in
      let fix do_slashes (acc : list string) (limit : Z) (i : Z)
        : list string :=
        if OCaml.Stdlib.ge i l then
          List.rev acc
        else
          if equiv_decb (Stdlib.String.get path i) delim then
            if dup then
              do_slashes acc limit (Z.add i 1)
            else
              do_split acc limit (Z.add i 1)
          else
            do_split acc limit i
      with do_split (acc : list string) (limit : Z) (i : Z) : list string :=
        if OCaml.Stdlib.le limit 0 then
          if equiv_decb i l then
            List.rev acc
          else
            List.rev (cons (Stdlib.String.sub path i (Z.sub l i)) acc)
        else
          do_component acc (Z.pred limit) i i
      with do_component (acc : list string) (limit : Z) (i : Z) (j : Z)
        : list string :=
        if OCaml.Stdlib.ge j l then
          if equiv_decb i j then
            List.rev acc
          else
            List.rev (cons (Stdlib.String.sub path i (Z.sub j i)) acc)
        else
          if equiv_decb (Stdlib.String.get path j) delim then
            do_slashes (cons (Stdlib.String.sub path i (Z.sub j i)) acc) limit j
          else
            do_component acc limit i (Z.add j 1) in
      if OCaml.Stdlib.gt limit 0 then
        do_slashes [] limit 0
      else
        cons path [].

Definition split_path (path : string) : list string :=
  split "/" % char None None path.

Definition has_prefix (prefix : string) (s : string) : bool :=
  let x := OCaml.String.length prefix in
  let n := OCaml.String.length s in
  andb (OCaml.Stdlib.ge n x) (equiv_decb (Stdlib.String.sub s 0 x) prefix).

Definition remove_prefix (prefix : string) (s : string) : option string :=
  let x := OCaml.String.length prefix in
  let n := OCaml.String.length s in
  if andb (OCaml.Stdlib.ge n x) (equiv_decb (Stdlib.String.sub s 0 x) prefix)
    then
    Some (Stdlib.String.sub s x (Z.sub n x))
  else
    None.

Definition common_prefix (s1 : string) (s2 : string) : Z :=
  let last := OCaml.Stdlib.min (OCaml.String.length s1) (OCaml.String.length s2)
    in
  let fix loop (i : Z) : Z :=
    if OCaml.Stdlib.le last i then
      last
    else
      if equiv_decb (Stdlib.String.get s1 i) (Stdlib.String.get s2 i) then
        loop (Z.add i 1)
      else
        i in
  loop 0.

Definition mem_char (s : string) (c : ascii) : bool :=
  nequiv_decb (Stdlib.String.index_opt s c) None.

Definition fold_left {A : Type} (f : A -> ascii -> A) (init : A) (s : string)
  : A :=
  let acc := Stdlib.ref init in
  Stdlib.String.iter
    (fun c => Stdlib.op_colon_eq acc (f (Stdlib.op_exclamation acc) c)) s;
  Stdlib.op_exclamation acc.

Definition is_hex (s : string) : bool :=
  let len := OCaml.String.length s in
  andb (equiv_decb (Z.modulo len 2) 0) try.
src/lib_stdlib/tzString.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Set : Set.S with type elt = string

module Map : Map.S with type key = string

(** Splits a string on slashes, grouping multiple slashes, and
    ignoring slashes at the beginning and end of string. *)
val split_path : string -> string list

(** Splits a string on a delimiter character, grouping multiple
    delimiters, and ignoring delimiters at the beginning and end of
    string, if [limit] is passed, stops after [limit] split(s). *)
val split : char -> ?dup:bool -> ?limit:int -> string -> string list

(** [true] if input has prefix *)
val has_prefix : prefix:string -> string -> bool

(** Some (input with [prefix] removed), if string has [prefix], else [None] *)
val remove_prefix : prefix:string -> string -> string option

(** Length of common prefix of input strings *)
val common_prefix : string -> string -> int

(** Test whether a string contains a given character *)
val mem_char : string -> char -> bool

(** Functional iteration over the characters of a string from first to last *)
val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a

(** Test whether a string is a valid hexadecimal value *)
val is_hex : string -> bool
src/lib_stdlib/tzString.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

unhandled_module

Parameter split_path : string -> list string.

Parameter split : ascii -> (option bool) -> (option Z) -> string -> list string.

Parameter has_prefix : string -> string -> bool.

Parameter remove_prefix : string -> string -> option string.

Parameter common_prefix : string -> string -> Z.

Parameter mem_char : string -> ascii -> bool.

Parameter fold_left : forall {a : Type}, (a -> ascii -> a) -> a -> string -> a.

Parameter is_hex : string -> bool.
src/lib_stdlib/utils.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Infix = struct
  let ( -- ) i j = List.init (j - i + 1) (fun x -> x + i)
end

let cut ?(copy = false) sz bytes =
  let length = Bytes.length bytes in
  if length <= sz then [bytes] (* if the result fits in the given sz *)
  else
    let may_copy = if copy then Bytes.copy else fun t -> t in
    let nb_full = length / sz in
    (* nb of blocks of size sz *)
    let sz_full = nb_full * sz in
    (* size of the full part *)
    let acc =
      (* eventually init acc with a non-full block *)
      if sz_full = length then []
      else [may_copy (Bytes.sub bytes sz_full (length - sz_full))]
    in
    let rec split_full_blocks curr_upper_limit acc =
      let start = curr_upper_limit - sz in
      assert (start >= 0) ;
      (* copy the block [ start, curr_upper_limit [ of size sz *)
      let acc = may_copy (Bytes.sub bytes start sz) :: acc in
      if start = 0 then acc else split_full_blocks start acc
    in
    split_full_blocks sz_full acc

let nbsp = Re.(compile (str "\xC2\xA0"))

let display_paragraph ppf description =
  Format.fprintf
    ppf
    "@[%a@]"
    (Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun ppf line ->
         Format.pp_print_list
           ~pp_sep:Format.pp_print_space
           (fun ppf w ->
             (* replace &nbsp; by real spaces... *)
             Format.fprintf
               ppf
               "%s@ "
               (Re.replace ~all:true nbsp ~f:(fun _ -> " ") w))
           ppf
           (TzString.split ' ' line)))
    (TzString.split ~dup:false '\n' description)

let finalize f g =
  try
    let res = f () in
    g () ; res
  with exn -> g () ; raise exn
src/lib_stdlib/utils.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Infix.
  Definition op_minus_minus (i : Z) (j : Z) : list Z :=
    Stdlib.List.init (Z.add (Z.sub j i) 1) (fun x => Z.add x i).
End Infix.

Definition cut (op_star_o_p_t_star : option bool)
  : Z -> string -> list string :=
  let copy :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun sz =>
    fun bytes =>
      let length := String.length string in
      if OCaml.Stdlib.le length sz then
        cons string []
      else
        let may_copy :=
          if copy then
            Stdlib.Bytes.copy
          else
            fun t => t in
        let nb_full := Z.div length sz in
        let sz_full := Z.mul nb_full sz in
        let acc :=
          if equiv_decb sz_full length then
            []
          else
            cons (may_copy (String.sub string sz_full (Z.sub length sz_full)))
              [] in
        let fix split_full_blocks (curr_upper_limit : Z) (acc : list string)
          : list string :=
          let start := Z.sub curr_upper_limit sz in
          OCaml.Stdlib.ge start 0;
          let acc := cons (may_copy (String.sub string start sz)) acc in
          if equiv_decb start 0 then
            acc
          else
            split_full_blocks start acc in
        split_full_blocks sz_full acc.

Definition nbsp : Re.re := Re.compile (Re.str " " % string).

Definition display_paragraph
  (ppf : Stdlib.Format.formatter) (description : string) : unit :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format))) "@[%a@]" % string)
    (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_newline)
      (fun ppf =>
        fun line =>
          Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space)
            (fun ppf =>
              fun w =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        CamlinternalFormatBasics.End_of_format)) "%s@ " % string)
                  (Re.replace None None (Some true) nbsp
                    (fun function_parameter =>
                      match function_parameter with
                      | _ => " " % string
                      end) w)) ppf
            (Tezos_stdlib.TzString.split " " % char None None line)))
    (Tezos_stdlib.TzString.split "010" % char (Some false) None description).

Definition finalize {A : Type} (f : unit -> A) (g : unit -> unit) : A := try.
src/lib_stdlib/utils.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Infix : sig
  (** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *)
  val ( -- ) : int -> int -> int list
end

(** [cut ?copy size bytes] cut [bytes] the in a list of successive
    chunks of length [size] at most.

    If [copy] is false (default), the blocks of the list
    can be garbage-collected only when all the blocks are
    unreachable (because of the 'optimized' implementation of
    [sub] used internally. *)
val cut : ?copy:bool -> int -> Bytes.t -> Bytes.t list

(** Print a paragraph in a box *)
val display_paragraph : Format.formatter -> string -> unit

(** [finalize f g ] ensures g() called after f(), even if exception raised *)
val finalize : (unit -> 'a) -> (unit -> unit) -> 'a
src/lib_stdlib/utils.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Infix.
  Parameter op_minus_minus : Z -> Z -> list Z.
End Infix.

Parameter cut : (option bool) -> Z -> Stdlib.Bytes.t -> list Stdlib.Bytes.t.

Parameter display_paragraph : Stdlib.Format.formatter -> string -> unit.

Parameter finalize : forall {a : Type}, (unit -> a) -> (unit -> unit) -> a.
src/lib_stdlib/weakRingTable.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, Inc. <contact@nomadic-labs.com>          *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)
module type S = sig
  type 'a t

  type key

  val create : int -> 'a t

  val add : 'a t -> key -> 'a -> unit

  val add_and_return_erased : 'a t -> key -> 'a -> key option

  val iter : (key -> 'a -> unit) -> 'a t -> unit

  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val find_opt : 'a t -> key -> 'a option

  val remove : 'a t -> key -> unit

  val length : 'a t -> int
end

module Make (M : Hashtbl.HashedType) = struct
  module Table = Ephemeron.K1.Make (struct
    type t = int

    let hash a = a

    let equal = ( = )
  end)

  module Ring = Ring.MakeTable (struct
    type t = int * M.t

    let hash (i, _) = i

    let equal = ( = )
  end)

  type key = M.t

  module Visit_tracking = Set.Make (struct
    type t = int

    let compare = Pervasives.compare
  end)

  type 'a t = {table : 'a Table.t; ring : Ring.t}

  let create n = {table = Table.create n; ring = Ring.create n}

  let add {ring; table} k v =
    let i = M.hash k in
    Ring.add ring (i, k) ;
    Table.replace table i v

  let add_and_return_erased {ring; table} k v =
    let i = M.hash k in
    let erased = Option.map ~f:snd (Ring.add_and_return_erased ring (i, k)) in
    Table.replace table i v ; erased

  let find_opt {table; _} k =
    let i = M.hash k in
    Table.find_opt table i

  let fold f {table; ring} acc =
    let elts = Ring.elements ring in
    let (res, _) =
      List.fold_left
        (fun (acc, visited) (i, k) ->
          if Visit_tracking.mem i visited then (acc, visited)
          else
            match Table.find_opt table i with
            | None ->
                (acc, visited)
            | Some elt ->
                (f k elt acc, Visit_tracking.add i visited))
        (acc, Visit_tracking.empty)
        elts
    in
    res

  let iter f t = fold (fun k v () -> f k v) t ()

  let remove t k =
    let i = M.hash k in
    Table.remove t.table i

  let length {table; _} = Table.length table
end
src/lib_stdlib/weakRingTable.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Record signature {t key : Type} := {
    polymorphic_abstract_type;
    key := key;
    create : forall {a : Type}, Z -> t a;
    add : forall {a : Type}, (t a) -> key -> a -> unit;
    add_and_return_erased : forall {a : Type}, (t a) -> key -> a -> option key;
    iter : forall {a : Type}, (key -> a -> unit) -> (t a) -> unit;
    fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
    find_opt : forall {a : Type}, (t a) -> key -> option a;
    remove : forall {a : Type}, (t a) -> key -> unit;
    length : forall {a : Type}, (t a) -> Z;
  }.
  Arguments signature : clear implicits.
End S.
src/lib_stdlib/weakRingTable.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, Inc. <contact@nomadic-labs.com>          *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)
module type S = sig
  type 'a t

  type key

  (** [create n] is a table with at most [n] elements except when it has more. *)
  val create : int -> 'a t

  (** [add t k v] adds a mapping from key [k] to value [v] in the table.
      NOTE: when n values are bound to the same key, it may count as up to n
      elements.
      However, NOTE: when n values are bound to the same key, only the last
      binding can be found with [find_opt] or traversed with [fold]. *)
  val add : 'a t -> key -> 'a -> unit

  val add_and_return_erased : 'a t -> key -> 'a -> key option

  val iter : (key -> 'a -> unit) -> 'a t -> unit

  (** [fold f t acc] folds the function [f] and value [acc] through the recently
      added elements of [t]. It never folds over more elements than the size
      bound of the table, even if the table temporarily holds more elements. *)
  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  (** [find_opt t k] is [Some v] if [k] is bound to [v] in [t] and [None]
      otherwise. A key [k] is bound to a value [v] in [t] if [add t k v] has been
      called and not too many other bindings have been added since then. *)
  val find_opt : 'a t -> key -> 'a option

  (** [remove t k] removes the binding from [key] to the associated element in
      [t]. Note that you may still be able to find the element using [find_opt]
      for some time. *)
  val remove : 'a t -> key -> unit

  (** [length t] is the number of elements currently in [t], including those
      that may be garbage collected. *)
  val length : 'a t -> int
end

(** A bounded table which optimistically cheats on the bound and sometimes
    counts wrong.
    Specifically, the table retains a bounded number of elements. It will also
    retain more if given more than that, but it will always drop back to the
    bound if the garbage collector intervenes. *)
module Make (K : Hashtbl.HashedType) : S with type key = K.t
src/lib_stdlib/weakRingTable.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

unhandled_module
src/lib_stdlib_unix/animation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let animation =
  [| "|.....|";
     "|o....|";
     "|oo...|";
     "|ooo..|";
     "|.ooo.|";
     "|..ooo|";
     "|...oo|";
     "|....o|";
     "|.....|";
     "|.....|";
     "|.....|";
     "|.....|" |]

let init = String.make (String.length animation.(0)) ' '

let clean = String.make (String.length animation.(0)) '\b'

let animation = Array.map (fun x -> clean ^ x) animation

let number_of_frames = Array.length animation

let make_with_animation ppf ~make ~on_retry seed =
  Format.fprintf ppf "%s%!" init ;
  let rec loop n seed =
    let start = Mtime_clock.counter () in
    Format.fprintf ppf "%s%!" animation.(n mod number_of_frames) ;
    match make seed with
    | Ok v ->
        v
    | Error r ->
        let time = Mtime_clock.count start in
        let v = on_retry time r in
        loop (n + 1) v
  in
  let result = loop 0 seed in
  Format.fprintf ppf "%s%s\n%!" clean init ;
  result
src/lib_stdlib_unix/animation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition animation : array string :=
  ("|.....|" % string, "|o....|" % string, "|oo...|" % string,
    "|ooo..|" % string, "|.ooo.|" % string, "|..ooo|" % string,
    "|...oo|" % string, "|....o|" % string, "|.....|" % string,
    "|.....|" % string, "|.....|" % string, "|.....|" % string).

Definition init : string :=
  Stdlib.String.make (OCaml.String.length (Stdlib.Array.get animation 0))
    " " % char.

Definition clean : string :=
  Stdlib.String.make (OCaml.String.length (Stdlib.Array.get animation 0))
    "008" % char.

Definition animation : array string :=
  Stdlib.Array.map (fun x => String.append clean x) animation.

Definition number_of_frames : Z := Stdlib.Array.length animation.

Definition make_with_animation {A B C : Type}
  (ppf : Stdlib.Format.formatter) (make : A -> sum B C)
  (on_retry : Mtime.span -> C -> A) (seed : A) : B :=
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
      "%s%!" % string) init;
  let fix loop (n : Z) (seed : A) : B :=
    let start := Mtime_clock.counter tt in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
        "%s%!" % string)
      (Stdlib.Array.get animation (Z.modulo n number_of_frames));
    match make seed with
    | inl v => v
    | inr r =>
      let time := Mtime_clock.count start in
      let v := on_retry time r in
      loop (Z.add n 1) v
    end in
  let result := loop 0 seed in
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "010" % char
            (CamlinternalFormatBasics.Flush
              CamlinternalFormatBasics.End_of_format)))) "%s%s
%!" % string)
    clean init;
  result.
src/lib_stdlib_unix/animation.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** [make_with_animation] is meant to be used to execute time consuming
    functions that can be interrupted. Typically proof-of-work tasks. Whilst
    doing so, it displays a progress animation on the provided formatter
    (assumes support for '\b`). The animations leave the terminal clean.

    [make_with_animation ppf ~make ~on_retry seed] behaves as follows:
    (a) if [make seed] is [Ok v] (completion of the task), then it returns [v]
    (b) if [make seed] is [Error r] (task is incomplete), then
    (b.1) [on_retry t r] is evaluated where [t] is the time elapsed during the
    call to [make], and then
    (b.2) the result is used to attempt the task again. *)
val make_with_animation :
  Format.formatter ->
  make:('seed -> ('result, 'failure) result) ->
  on_retry:(Mtime.Span.t -> 'failure -> 'seed) ->
  'seed ->
  'result

(** The number of steps that the animation cycles through. *)
val number_of_frames : int
src/lib_stdlib_unix/animation.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter make_with_animation : forall {failure result seed : Type},
Stdlib.Format.formatter ->
  (seed -> sum result failure) ->
    (Mtime.Span.t -> failure -> seed) -> seed -> result.

Parameter number_of_frames : Z.
src/lib_stdlib_unix/file_descriptor_sink.ml 
(******************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

type t = {
  output : Lwt_unix.file_descr;
  format : [`One_per_line | `Netstring];
  (* Hopefully temporary hack to handle event which are emitted with
     the non-cooperative log functions in `Legacy_logging`: *)
  lwt_bad_citizen_hack : Data_encoding.json list ref;
  level_at_least : Internal_event.Level.t;
}

type 'event wrapped = {
  time_stamp : float;
  section : Internal_event.Section.t;
  event : 'event;
}

let wrap time_stamp section event = {time_stamp; section; event}

let wrapped_encoding event_encoding =
  let open Data_encoding in
  let v0 =
    conv
      (fun {time_stamp; section; event} -> (time_stamp, section, event))
      (fun (time_stamp, section, event) -> {time_stamp; section; event})
      (obj3
         (req "time_stamp" float)
         (req "section" Internal_event.Section.encoding)
         (req "event" event_encoding))
  in
  With_version.(encoding ~name:"fd-sink-item" (first_version v0))

module Make_sink (K : sig
  val kind : [`Path | `Stdout | `Stderr]
end) : Internal_event.SINK with type t = t = struct
  type nonrec t = t

  let uri_scheme =
    match K.kind with
    | `Path ->
        "file-descriptor-path"
    | `Stdout ->
        "file-descriptor-stdout"
    | `Stderr ->
        "file-descriptor-stderr"

  let configure uri =
    let level_at_least =
      Option.(
        Uri.get_query_param uri "level-at-least"
        >>= Internal_event.Level.of_string)
      |> Option.unopt ~default:Internal_event.Level.default
    in
    let fail_parsing fmt =
      Format.kasprintf (failwith "Parsing URI: %s: %s" (Uri.to_string uri)) fmt
    in
    ( match Uri.get_query_param uri "format" with
    | Some "netstring" ->
        return `Netstring
    | None | Some "one-per-line" ->
        return `One_per_line
    | Some other ->
        fail_parsing "Unknown format: %S" other )
    >>=? fun format ->
    ( match K.kind with
    | `Path -> (
        let flag name =
          match Uri.get_query_param uri name with
          | Some "true" ->
              true
          | _ ->
              false
        in
        let with_pid = flag "with-pid" in
        let fresh = flag "fresh" in
        ( match Uri.get_query_param uri "chmod" with
        | Some n -> (
          try return (int_of_string n)
          with _ ->
            fail_parsing "Access-rights parameter should be an integer: %S" n )
        | None ->
            return 0o600 )
        >>=? fun rights ->
        match Uri.path uri with
        | "" | "/" ->
            fail_parsing "Missing path configuration."
        | path ->
            let fixed_path =
              if with_pid then
                let ext = Filename.extension path in
                let chopped =
                  if ext = "" then path else Filename.chop_extension path
                in
                Fmt.strf "%s-%d%s" chopped (Unix.getpid ()) ext
              else path
            in
            protect (fun () ->
                Lwt_unix.(
                  let flags =
                    [O_WRONLY; O_CREAT]
                    @ if fresh then [O_TRUNC] else [O_APPEND]
                  in
                  openfile fixed_path flags rights)
                >>= fun fd -> return fd) )
    | `Stdout ->
        return Lwt_unix.stdout
    | `Stderr ->
        return Lwt_unix.stderr )
    >>=? fun output ->
    let t = {output; lwt_bad_citizen_hack = ref []; level_at_least; format} in
    return t

  let output_one output format event_json =
    let to_write =
      match format with
      | `One_per_line ->
          Ezjsonm.value_to_string ~minify:true event_json ^ "\n"
      | `Netstring ->
          let bytes = Ezjsonm.value_to_string ~minify:true event_json in
          Fmt.str "%d:%s," (String.length bytes) bytes
    in
    protect (fun () ->
        (* 
           If the write does happen at once (i.e. returns the same number of bytes),
           POSIX (and Linux >= 3.14) ensure this is atomic.
           Cf. http://man7.org/linux/man-pages/man2/write.2.html#BUGS
           and `https://github.com/ocsigen/lwt/blob/master/src/unix/unix_c/unix_write.c` *)
        Lwt_utils_unix.write_string output to_write >>= fun () -> return_unit)

  let handle (type a) {output; lwt_bad_citizen_hack; level_at_least; format; _}
      m ?(section = Internal_event.Section.empty) (v : unit -> a) =
    let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in
    let now = Unix.gettimeofday () in
    let forced_event = v () in
    let level = M.level forced_event in
    if Internal_event.Level.compare level level_at_least >= 0 then (
      let wrapped_event = wrap now section forced_event in
      let event_json =
        Data_encoding.Json.construct
          (wrapped_encoding M.encoding)
          wrapped_event
      in
      lwt_bad_citizen_hack := event_json :: !lwt_bad_citizen_hack ;
      output_one output format event_json
      >>=? fun () ->
      lwt_bad_citizen_hack :=
        List.filter (( = ) event_json) !lwt_bad_citizen_hack ;
      return_unit )
    else return_unit

  let close {lwt_bad_citizen_hack; output; format; _} =
    iter_s
      (fun event_json -> output_one output format event_json)
      !lwt_bad_citizen_hack
    >>=? fun () -> Lwt_unix.close output >>= fun () -> return_unit
end

module Sink_implementation_path = Make_sink (struct
  let kind = `Path
end)

module Sink_implementation_stdout = Make_sink (struct
  let kind = `Stdout
end)

module Sink_implementation_stderr = Make_sink (struct
  let kind = `Stderr
end)

let () = Internal_event.All_sinks.register (module Sink_implementation_path)

let () = Internal_event.All_sinks.register (module Sink_implementation_stdout)

let () = Internal_event.All_sinks.register (module Sink_implementation_stderr)
src/lib_stdlib_unix/file_descriptor_sink.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Record t := {
  output : Lwt_unix.file_descr;
  format : variant;
  lwt_bad_citizen_hack :
    Stdlib.ref (list Tezos_data_encoding.Data_encoding.json);
  level_at_least : Tezos_event_logging.Internal_event.Level.t }.

Record wrapped {event : Type} := {
  time_stamp : float;
  section : Tezos_event_logging.Internal_event.Section.t;
  event : event }.
Arguments wrapped : clear implicits.

Definition wrap {A : Type}
  (time_stamp : float) (section : Tezos_event_logging.Internal_event.Section.t)
  (event : A) : wrapped A :=
  {| time_stamp := time_stamp; section := section; event := event |}.

Definition wrapped_encoding {A : Type}
  (event_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding__Data_encoding.encoding (wrapped A) :=
  let v0 :=
    Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| time_stamp := time_stamp; section := section; event := event |} =>
          (time_stamp, section, event)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (time_stamp, section, event) =>
          {| time_stamp := time_stamp; section := section; event := event |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj3
        (Tezos_data_encoding.Data_encoding.req None None "time_stamp" % string
          Tezos_data_encoding.Data_encoding.float)
        (Tezos_data_encoding.Data_encoding.req None None "section" % string
          Tezos_event_logging.Internal_event.Section.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "event" % string
          event_encoding)) in
  Tezos_data_encoding.Data_encoding.With_version.encoding
    "fd-sink-item" % string
    (Tezos_data_encoding.Data_encoding.With_version.first_version v0).
src/lib_stdlib_unix/file_descriptor_sink.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** An implementation of {!Tezos_base.Internal_event.SINK} which
    writes the events as JSON into a single file-descriptor.

    It is registered with the URI scheme ["file-descriptor-path"] to
    output to a file or
    ["file-descriptor-stdout"]/["file-descriptor-stderr"] for [stdout]
    and [stderr] respectively.

    Available options are

    - ["level-at-least"] the minimal log-level that the sink will
      output (see {!Tezos_event_logging.Internal_event.level}).
    - ["format"] the output format used to separate JSON records:
      acceptable values are ["one-per-line"] (the default), and
      ["netstring"] (see {{:https://en.wikipedia.org/wiki/Netstring}The
      Netstring format}).

    Options available only for ["file-descriptor-path://"]:

    - ["with-pid=true"] adds the current process id to the file path provided.
    - ["fresh=true"] smashes the content of the file if it already
      exists instead of appending to it.
    - ["chmod=<INT>"] sets the access-rights of the file at creation
      time (default is [0o600], provided
      {{:https://en.wikipedia.org/wiki/Umask}[umask]} allows it).

    Examples:

    - ["export TEZOS_EVENTS_CONFIG=file-descriptor-path:///the/path/to/write.log?format=one-per-line&level-at-least=notice&with-pid=true&chmod=0o640"]:
      Executables will write all log events of level at least [Notice]
      to a file ["/the/path/to/write-XXXX.log"] where ["XXXX"] is the
      process ID, the file will be also readable by the user's group ([0o640]).
    - ["export TEZOS_EVENTS_CONFIG=file-descriptor-stderr://?format=netstring"]
      Executables will write to [stderr].
    - ["export TEZOS_EVENTS_CONFIG=file-descriptor-path:///dev/fd/4?format=netstring"]
      Executables will write to the [4] file-descriptor likely opened
      by a parent monitoring process (non-standard feature available
      on mainstream UNIX hosts, e.g. Linux and MacOSX).

*)

type t

module Sink_implementation_path : Internal_event.SINK with type t = t

module Sink_implementation_stdout : Internal_event.SINK with type t = t

module Sink_implementation_stderr : Internal_event.SINK with type t = t
src/lib_stdlib_unix/file_descriptor_sink.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

unhandled_module

unhandled_module

unhandled_module
src/lib_stdlib_unix/file_event_sink.ml 
(******************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module Micro_seconds : sig
  (** Module with time-stamps with “at least micro-seconds” precision. *)
  type t = private float

  val now : unit -> t

  val of_float : float -> t

  val encoding : t Data_encoding.t

  val date_string : t -> string * string
end = struct
  (* Time.t is in seconds, we want more precision. *)
  type t = float

  let now () = Unix.gettimeofday ()

  let of_float f = f

  let encoding =
    let open Data_encoding in
    conv (* Cf. https://github.com/OCamlPro/ocplib-json-typed/issues/25 *)
      (fun f -> f *. 1_000_000. |> Int64.of_float)
      (fun i64 -> Int64.to_float i64 /. 1_000_000.)
      int64

  let date_string time_value =
    let open Unix in
    let open Printf in
    let tm = gmtime time_value in
    ( sprintf "%04d%02d%02d" (1900 + tm.tm_year) (tm.tm_mon + 1) tm.tm_mday,
      sprintf
        "%02d%02d%02d-%06d"
        tm.tm_hour
        tm.tm_min
        tm.tm_sec
        ((time_value -. floor time_value) *. 1_000_000. |> int_of_float) )
end

module Event_filter = struct
  type t =
    | True
    | False
    | Or of t list
    | And of t list
    | Name of string
    | Name_matches of Re.re
    | Level_in of Internal_event.level list
    | Section_in of Internal_event.Section.t list

  let rec run ~section ~level ~name filter =
    let continue = run ~section ~level ~name in
    match filter with
    | True ->
        true
    | False ->
        false
    | Or l ->
        List.exists continue l
    | And l ->
        List.for_all continue l
    | Name s ->
        String.equal s name
    | Name_matches re ->
        Re.execp re name
    | Level_in l ->
        List.mem level l
    | Section_in l ->
        List.mem section l

  let rec pp fmt filter =
    let open Format in
    match filter with
    | True ->
        pp_print_string fmt "true"
    | False ->
        pp_print_string fmt "false"
    | Or l ->
        fprintf
          fmt
          "(or@ @[<2>%a@]"
          (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ") pp)
          l
    | And l ->
        fprintf
          fmt
          "(and@ @[<2>%a@]"
          (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ") pp)
          l
    | Name s ->
        fprintf fmt "(name-is@ %S)" s
    | Name_matches re ->
        fprintf fmt "(name-matches@ %a)" Re.pp_re re
    | Level_in l ->
        fprintf
          fmt
          "(level-in@ [%s])"
          (String.concat "," (List.map Internal_event.Level.to_string l))
    | Section_in l ->
        fprintf
          fmt
          "(section-in@ [%a])"
          (pp_print_list
             ~pp_sep:(fun fmt () -> fprintf fmt ",@ ")
             (fun fmt s ->
               fprintf
                 fmt
                 "(Some %s)"
                 (String.concat "," (Internal_event.Section.to_string_list s))))
          l
    [@@warning "-32"]

  (* -> The "unused value" warning. *)

  let t = True

  let f = False [@@warning "-32"]

  (* -> The "unused value" warning. *)

  let any l = Or l

  let all l = And l [@@warning "-32"]

  (* -> The "unused value" warning. *)

  let name_is s = Name s

  let name_matches s = Name_matches s

  let name_matches_posix s = name_matches (Re.Posix.compile_pat s)

  let level_in l = Level_in l

  let section_in l = Section_in l

  let levels_in_order =
    Internal_event.[Debug; Info; Notice; Warning; Error; Fatal]

  let level_at_least lvl =
    List.fold_left
      (function
        | None -> (
            function l when l = lvl -> Some [l] | _ -> None )
        | Some s ->
            fun l -> Some (l :: s))
      None
      levels_in_order
    |> Option.unopt_exn (Failure "level_at_least not found")
    |> level_in
end

type t = {
  path : string;
  (* Hopefully temporary hack to handle event which are emitted with
     the non-cooperative log functions in `Legacy_logging`: *)
  lwt_bad_citizen_hack : (string * Data_encoding.json) list ref;
  event_filter : Event_filter.t;
}

type 'event wrapped = {
  time_stamp : Micro_seconds.t;
  section : Internal_event.Section.t;
  event : 'event;
}

let wrap time_stamp section event = {time_stamp; section; event}

let wrapped_encoding event_encoding =
  let open Data_encoding in
  let v0 =
    conv
      (fun {time_stamp; section; event} -> (time_stamp, section, event))
      (fun (time_stamp, section, event) -> {time_stamp; section; event})
      (obj3
         (req "time_stamp" Micro_seconds.encoding)
         (req "section" Internal_event.Section.encoding)
         (req "event" event_encoding))
  in
  With_version.(encoding ~name:"file-event-sink-item" (first_version v0))

module Section_dir = struct
  let of_section (section : Internal_event.Section.t) =
    String.concat "." (Internal_event.Section.to_string_list section)

  let section_name = function
    | "no-section" ->
        Ok None
    | other -> (
      match TzString.remove_prefix ~prefix:"section-" other with
      | None ->
          Error "wrong-dir-name"
      | Some s ->
          Ok (Some s) )
end

module Sink_implementation : Internal_event.SINK with type t = t = struct
  type nonrec t = t

  let uri_scheme = "unix-files"

  let configure uri =
    let event_filter =
      let name_res =
        Uri.get_query_param' uri "name-matches" |> Option.unopt ~default:[]
      in
      let names =
        Uri.get_query_param' uri "name" |> Option.unopt ~default:[]
      in
      let levels =
        Option.(
          Uri.get_query_param uri "level-at-least"
          >>= Internal_event.Level.of_string
          >>= fun l ->
          (* some (fun all more -> all [Event_filter.level_at_least l ; more ]) *)
          some [Event_filter.level_at_least l])
        |> Option.unopt ~default:[]
      in
      let sections =
        let somes =
          Uri.get_query_param' uri "section"
          |> Option.unopt ~default:[]
          |> List.map (fun s ->
                 Internal_event.Section.make_sanitized
                   (String.split_on_char '.' s))
        in
        let none =
          match Uri.get_query_param uri "no-section" with
          | Some "true" ->
              [Internal_event.Section.empty]
          | _ ->
              []
        in
        match somes @ none with
        | [] ->
            []
        | more ->
            [Event_filter.section_in more]
      in
      Event_filter.(
        match
          levels @ sections
          @ List.map name_matches_posix name_res
          @ List.map name_is names
        with
        | [] ->
            t
        | more ->
            any more)
    in
    let t =
      {path = Uri.path uri; lwt_bad_citizen_hack = ref []; event_filter}
    in
    return t

  let output_json ~pp file_path event_json =
    Lwt.catch
      (fun () ->
        Lwt_utils_unix.create_dir ~perm:0o700 (Filename.dirname file_path)
        >>= fun () ->
        Lwt_utils_unix.Json.write_file file_path event_json
        >>= function
        | Ok () ->
            return_unit
        | Error el ->
            failwith
              "ERROR while Handling %a,@ cannot write JSON to %s:@ %a\n%!"
              pp
              ()
              file_path
              Error_monad.pp_print_error
              el)
      (function
        | e ->
            failwith
              "ERROR while Handling %a: %a\n%!"
              pp
              ()
              Error_monad.pp_exn
              e)

  let handle (type a) {path; lwt_bad_citizen_hack; event_filter} m
      ?(section = Internal_event.Section.empty) (v : unit -> a) =
    let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in
    let now = Micro_seconds.now () in
    let (date, time) = Micro_seconds.date_string now in
    let forced = v () in
    let level = M.level forced in
    match Event_filter.run ~section ~level ~name:M.name event_filter with
    | true ->
        let event_json =
          Data_encoding.Json.construct
            (wrapped_encoding M.encoding)
            (wrap now section forced)
        in
        let tag =
          let hash =
            Marshal.to_string event_json [] |> Digest.string |> Digest.to_hex
          in
          String.sub hash 0 8
        in
        let section_dir = Section_dir.of_section section in
        let dir_path =
          List.fold_left Filename.concat path [section_dir; M.name; date; time]
        in
        let file_path =
          Filename.concat
            dir_path
            (Printf.sprintf "%s_%s_%s.json" date time tag)
        in
        lwt_bad_citizen_hack :=
          (file_path, event_json) :: !lwt_bad_citizen_hack ;
        output_json file_path event_json ~pp:(fun fmt () -> M.pp fmt forced)
        >>=? fun () ->
        lwt_bad_citizen_hack :=
          List.filter (fun (f, _) -> f <> file_path) !lwt_bad_citizen_hack ;
        return_unit
    | false ->
        return_unit

  let close {lwt_bad_citizen_hack; _} =
    iter_s
      (fun (f, j) ->
        output_json f j ~pp:(fun fmt () ->
            Format.fprintf fmt "Destacking: %s" f))
      !lwt_bad_citizen_hack
    >>=? fun () -> return_unit
end

let () = Internal_event.All_sinks.register (module Sink_implementation)

open Sink_implementation

module Query = struct
  let with_file_kind dir p =
    protect (fun () ->
        Lwt_unix.stat (Filename.concat dir p)
        >>= fun {Lwt_unix.st_kind; _} -> return st_kind)
    >>=? function
    | Unix.S_DIR ->
        return (`Directory p)
    | Unix.S_REG ->
        return (`Regular_file p)
    | (Unix.S_CHR | Unix.S_BLK | Unix.S_LNK | Unix.S_FIFO | Unix.S_SOCK) as k
      ->
        return (`Special (k, p))

  let fold_directory path ~init ~f =
    protect (fun () ->
        Lwt_unix.opendir path >>= fun dirhandle -> return dirhandle)
    >>=? fun dirhandle ->
    let rec iter prev =
      protect (fun () ->
          Lwt.catch
            (fun () ->
              Lwt_unix.readdir dirhandle
              >>= fun d -> with_file_kind path d >>=? fun wk -> return_some wk)
            (function
              | End_of_file ->
                  Lwt_unix.closedir dirhandle >>= fun () -> return_none
              | (e : exn) ->
                  failwith
                    "ERROR while folding %s: %s"
                    path
                    (Printexc.to_string e)))
      >>=? fun opt ->
      prev
      >>=? fun p ->
      match opt with Some more -> iter (f p more) | None -> prev
    in
    iter init

  let ( // ) = Filename.concat

  module Time_constraint = struct
    type op = [`Lt | `Le | `Ge | `Gt]

    type t =
      [ `Date of op * float
      | `Time of op * float
      | `And of t * t
      | `Or of t * t
      | `All ]

    let rec check_logic check_terminal (t : t) string =
      let continue = check_logic check_terminal in
      match t with
      | `All ->
          true
      | `And (a, b) ->
          continue a string && continue b string
      | `Or (a, b) ->
          continue a string || continue b string
      | (`Date _ | `Time _) as term ->
          check_terminal term

    let op_with_string = function
      | `Lt ->
          fun a b -> String.compare a b > 0
      | `Gt ->
          fun a b -> String.compare a b < 0
      | `Le ->
          fun a b -> String.compare a b >= 0
      | `Ge ->
          fun a b -> String.compare a b <= 0

    let check_date (t : t) date_string =
      check_logic
        (function
          | `Date (op, f) ->
              let s = Micro_seconds.(date_string (of_float f) |> fst) in
              op_with_string op s date_string
          | `Time _ ->
              true)
        t
        date_string

    let check_time (t : t) string =
      check_logic
        (function
          | `Time (op, f) ->
              let s = Micro_seconds.(date_string (of_float f) |> snd) in
              op_with_string op s string
          | `Date _ ->
              true)
        t
        Micro_seconds.date_string
  end

  module Report = struct
    type item =
      [ `Error of
        [ `Parsing_event of
          [`Encoding of string * exn | `Json of string * error list]
        | `Cannot_recognize_section of string ]
      | `Warning of
        [ `Expecting_regular_file_at of string
        | `Expecting_directory_at of string
        | `Unknown_event_name_at of string * string ] ]

    let pp fmt (x : item) =
      let open Format in
      let error fmt = function
        | `Parsing_event e -> (
          match e with
          | `Encoding (path, exn) ->
              fprintf
                fmt
                "@[Parse error:@ wrong encoding for %S: %a@]"
                path
                pp_exn
                exn
          | `Json (path, el) ->
              fprintf
                fmt
                "@[Parse error:@ wrong JSON for %S: %a@]"
                path
                pp_print_error
                el )
        | `Cannot_recognize_section sec ->
            fprintf
              fmt
              "@[Directory error:@ cannot recognize section directory@ %S@]"
              sec
      in
      let warning fmt = function
        | `Expecting_regular_file_at path ->
            fprintf fmt "%S@ is not a regular file" path
        | `Expecting_directory_at path ->
            fprintf fmt "%S@ is not a directory" path
        | `Unknown_event_name_at (name, path) ->
            fprintf fmt "Unknown event name@ %S@ at@ %S" name path
      in
      match x with
      | `Error e ->
          fprintf fmt "@[Error:@ %a@]" error e
      | `Warning e ->
          fprintf fmt "@[Warning:@ %a@]" warning e

    let make_return m ((prev : item list), value) warning =
      return (m warning :: prev, value)

    let return_with_warning v e = make_return (fun e -> `Warning e) v e

    let return_with_error v e = make_return (fun e -> `Error e) v e
  end

  open Report

  let fold_event_kind_directory ~time_query path ~init ~f =
    fold_directory path ~init:(return init) ~f:(fun previous ->
      function
      | `Directory "." | `Directory ".." ->
          return previous
      | `Directory date when Time_constraint.check_date time_query date ->
          fold_directory
            (path // date)
            ~init:(return previous)
            ~f:(fun previous ->
            function
            | `Directory "." | `Directory ".." ->
                return previous
            | `Directory time when Time_constraint.check_time time_query time
              ->
                fold_directory
                  (path // date // time)
                  ~init:(return previous)
                  ~f:(fun previous -> function
                    | `Directory "." | `Directory ".." -> return previous
                    | `Regular_file file ->
                        f previous (path // date // time // file)
                    | `Directory p | `Special (_, p) ->
                        return_with_warning
                          previous
                          (`Expecting_regular_file_at
                            (path // date // time // p)))
            | `Directory _ (* filtered out *) ->
                return previous
            | `Regular_file p | `Special (_, p) ->
                return_with_warning
                  previous
                  (`Expecting_directory_at (path // date // p)))
      | `Directory _ (* filtered out *) ->
          return previous
      | `Regular_file p | `Special (_, p) ->
          return_with_warning previous (`Expecting_directory_at (path // p)))

  let handle_event_kind_directory (type a) ~time_query ~section_path ~init ~f
      ev =
    let module Event = ( val ev : Internal_event.EVENT_DEFINITION
                           with type t = a )
    in
    let handle_event_file previous path =
      Lwt_utils_unix.Json.read_file path
      >>= function
      | Ok json -> (
        try
          let {time_stamp; event; _} =
            Data_encoding.Json.destruct (wrapped_encoding Event.encoding) json
          in
          f
            (snd previous)
            ~time_stamp:(time_stamp :> float)
            (Internal_event.Generic.Event (Event.name, ev, event))
          >>=? fun user_return -> return (fst previous, user_return)
        with e ->
          return_with_error previous (`Parsing_event (`Encoding (path, e))) )
      | Error el ->
          return_with_error previous (`Parsing_event (`Json (path, el)))
    in
    fold_event_kind_directory
      ~time_query
      (section_path // Event.name)
      ~init
      ~f:(fun prev file -> handle_event_file prev file)

  let fold ?on_unknown ?only_sections ?only_names ?(time_query = `All) uri
      ~init ~f =
    let name_matches =
      match only_names with
      | None ->
          fun _ -> true
      | Some l ->
          fun name -> List.mem name l
    in
    let section_matches =
      match only_sections with
      | None ->
          fun _ -> true
      | Some l ->
          fun name -> List.mem name l
    in
    configure uri
    >>=? fun {path = sink_path; _} ->
    fold_directory
      sink_path
      ~init:(return ([], init))
      ~f:(fun previous -> function `Directory ("." | "..") -> return previous
        | `Directory dir -> (
          match Section_dir.section_name dir with
          | Ok sec when section_matches sec ->
              fold_directory
                (sink_path // dir)
                ~init:(return ([], init))
                ~f:(fun previous -> function `Directory ("." | "..") ->
                      return previous
                  | `Directory event_name when name_matches event_name -> (
                      let open Internal_event in
                      match All_definitions.find (( = ) event_name) with
                      | Some (Generic.Definition (_, ev)) ->
                          handle_event_kind_directory
                            ~time_query
                            ev
                            ~section_path:(sink_path // dir)
                            ~init:previous
                            ~f
                      | None -> (
                        match on_unknown with
                        | None ->
                            return_with_warning
                              previous
                              (`Unknown_event_name_at
                                (event_name, sink_path // dir))
                        | Some f ->
                            fold_event_kind_directory
                              ~time_query
                              (sink_path // dir // event_name)
                              ~init:previous
                              ~f:(fun prev file ->
                                f file >>=? fun () -> return prev) ) )
                  | `Directory _ (* filtered out *) -> return previous
                  | `Regular_file p | `Special (_, p) ->
                      return_with_warning
                        previous
                        (`Expecting_directory_at (sink_path // p)))
          | Ok _ (* section does not match *) ->
              return previous
          | Error _ ->
              return_with_error previous (`Cannot_recognize_section dir) )
        | `Regular_file p | `Special (_, p) ->
            return_with_warning
              previous
              (`Expecting_directory_at (sink_path // p)))
end
src/lib_stdlib_unix/file_event_sink.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Module Micro_seconds.
  Definition t := float.
  
  Definition now (function_parameter : unit) : float :=
    match function_parameter with
    | tt => Unix.gettimeofday tt
    end.
  
  Definition of_float {A : Type} (f : A) : A := f.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding float :=
    Tezos_data_encoding.Data_encoding.conv
      (fun f =>
        OCaml.Stdlib.reverse_apply (Stdlib.op_star_point f 1000000)
          Stdlib.Int64.of_float)
      (fun i64 => Stdlib.op_div_point (Stdlib.Int64.to_float i64) 1000000) None
      Tezos_data_encoding.Data_encoding.int64.
  
  Definition date_string (time_value : float) : string * string :=
    let tm := Unix.gmtime time_value in
    ((Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros 4)
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros
              2) CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              (CamlinternalFormatBasics.Lit_padding
                CamlinternalFormatBasics.Zeros 2)
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%04d%02d%02d" % string)
      (Z.add 1900 (tm_year tm)) (Z.add (tm_mon tm) 1) (tm_mday tm)),
      (Stdlib.Printf.sprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros
              2) CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              (CamlinternalFormatBasics.Lit_padding
                CamlinternalFormatBasics.Zeros 2)
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                (CamlinternalFormatBasics.Lit_padding
                  CamlinternalFormatBasics.Zeros 2)
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal "-" % char
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    (CamlinternalFormatBasics.Lit_padding
                      CamlinternalFormatBasics.Zeros 6)
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format)))))
          "%02d%02d%02d-%06d" % string) (tm_hour tm) (tm_min tm) (tm_sec tm)
        (OCaml.Stdlib.reverse_apply
          (Stdlib.op_star_point
            (Stdlib.op_minus_point time_value (Stdlib.floor time_value)) 1000000)
          Stdlib.int_of_float))).
End Micro_seconds.

Module Event_filter.
  Inductive t : Type :=
  | True : t
  | False : t
  | Or : (list t) -> t
  | And : (list t) -> t
  | Name : string -> t
  | Name_matches : Re.re -> t
  | Level_in : (list Tezos_event_logging.Internal_event.level) -> t
  | Section_in : (list Tezos_event_logging.Internal_event.Section.t) -> t.
  
  Fixpoint run
    (section : Tezos_event_logging.Internal_event.Section.t)
    (level : Tezos_event_logging.Internal_event.level) (name : Stdlib.String.t)
    (filter : t) : bool :=
    let continue := run section level name in
    match filter with
    | True => true
    | False => false
    | Or l => OCaml.List._exists continue l
    | And l => Stdlib.List.for_all continue l
    | Name s => Stdlib.String.equal s name
    | Name_matches re => Re.execp None None re name
    | Level_in l => Stdlib.List.mem level l
    | Section_in l => Stdlib.List.mem section l
    end.
  
  Fixpoint pp (fmt : Stdlib.Format.formatter) (filter : t) : unit :=
    match filter with
    | True => Stdlib.Format.pp_print_string fmt "true" % string
    | False => Stdlib.Format.pp_print_string fmt "false" % string
    | Or l =>
      Stdlib.Format.fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(or" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<2>" % string
                      CamlinternalFormatBasics.End_of_format) "<2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "(or@ @[<2>%a@]" % string)
        (Stdlib.Format.pp_print_list
          (Some
            (fun fmt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Stdlib.Format.fprintf fmt
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        CamlinternalFormatBasics.End_of_format) "@ " % string)
                end)) pp) l
    | And l =>
      Stdlib.Format.fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(and" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<2>" % string
                      CamlinternalFormatBasics.End_of_format) "<2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "(and@ @[<2>%a@]" % string)
        (Stdlib.Format.pp_print_list
          (Some
            (fun fmt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Stdlib.Format.fprintf fmt
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        CamlinternalFormatBasics.End_of_format) "@ " % string)
                end)) pp) l
    | Name s =>
      Stdlib.Format.fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(name-is" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))
          "(name-is@ %S)" % string) s
    | Name_matches re =>
      Stdlib.Format.fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(name-matches" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))
          "(name-matches@ %a)" % string) Re.pp_re re
    | Level_in l =>
      Stdlib.Format.fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(level-in" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Char_literal "[" % char
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal "])" % string
                    CamlinternalFormatBasics.End_of_format)))))
          "(level-in@ [%s])" % string)
        (Stdlib.String.concat "," % string
          (List.map Tezos_event_logging.Internal_event.Level.to_string l))
    | Section_in l =>
      Stdlib.Format.fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(section-in" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Char_literal "[" % char
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "])" % string
                    CamlinternalFormatBasics.End_of_format)))))
          "(section-in@ [%a])" % string)
        (Stdlib.Format.pp_print_list
          (Some
            (fun fmt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Stdlib.Format.fprintf fmt
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Char_literal "," % char
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          CamlinternalFormatBasics.End_of_format))
                      ",@ " % string)
                end))
          (fun fmt =>
            fun s =>
              Stdlib.Format.fprintf fmt
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "(Some " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))
                  "(Some %s)" % string)
                (Stdlib.String.concat "," % string
                  (Tezos_event_logging.Internal_event.Section.to_string_list s))))
        l
    end.
  
  Definition t : t := True.
  
  Definition f : t := False.
  
  Definition any (l : list t) : t := Or l.
  
  Definition all (l : list t) : t := And l.
  
  Definition name_is (s : string) : t := Name s.
  
  Definition name_matches (s : Re.re) : t := Name_matches s.
  
  Definition name_matches_posix (s : string) : t :=
    name_matches (Re.Posix.compile_pat None s).
  
  Definition level_in (l : list Tezos_event_logging.Internal_event.level) : t :=
    Level_in l.
  
  Definition section_in (l : list Tezos_event_logging.Internal_event.Section.t)
    : t := Section_in l.
  
  Definition levels_in_order : list Tezos_event_logging.Internal_event.level :=
    cons Debug
      (cons Info (cons Notice (cons Warning (cons inr (cons Fatal []))))).
  
  Definition level_at_least (lvl : Tezos_event_logging.Internal_event.level)
    : t :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (Stdlib.List.fold_left
          (fun function_parameter =>
            match function_parameter with
            | None =>
              fun function_parameter =>
                match function_parameter with
                | l => Some (cons l [])
                | _ => None
                end
            | Some s => fun l => Some (cons l s)
            end) None levels_in_order)
        (Tezos_stdlib.Option.unopt_exn
          (OCaml.Failure "level_at_least not found" % string))) level_in.
End Event_filter.

Record t := {
  path : string;
  lwt_bad_citizen_hack :
    Stdlib.ref (list (string * Tezos_data_encoding.Data_encoding.json));
  event_filter : Event_filter.t }.

Record wrapped {event : Type} := {
  time_stamp : Micro_seconds.t;
  section : Tezos_event_logging.Internal_event.Section.t;
  event : event }.
Arguments wrapped : clear implicits.

Definition wrap {A : Type}
  (time_stamp : Micro_seconds.t)
  (section : Tezos_event_logging.Internal_event.Section.t) (event : A)
  : wrapped A :=
  {| time_stamp := time_stamp; section := section; event := event |}.

Definition wrapped_encoding {A : Type}
  (event_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding__Data_encoding.encoding (wrapped A) :=
  let v0 :=
    Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| time_stamp := time_stamp; section := section; event := event |} =>
          (time_stamp, section, event)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (time_stamp, section, event) =>
          {| time_stamp := time_stamp; section := section; event := event |}
        end) None
      (Tezos_data_encoding.Data_encoding.obj3
        (Tezos_data_encoding.Data_encoding.req None None "time_stamp" % string
          Micro_seconds.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "section" % string
          Tezos_event_logging.Internal_event.Section.encoding)
        (Tezos_data_encoding.Data_encoding.req None None "event" % string
          event_encoding)) in
  Tezos_data_encoding.Data_encoding.With_version.encoding
    "file-event-sink-item" % string
    (Tezos_data_encoding.Data_encoding.With_version.first_version v0).

Module Section_dir.
  Definition of_section (section : Tezos_event_logging.Internal_event.Section.t)
    : string :=
    Stdlib.String.concat "." % string
      (Tezos_event_logging.Internal_event.Section.to_string_list section).
  
  Definition section_name (function_parameter : string)
    : sum (option string) string :=
    match function_parameter with
    | "no-section" % string => inl None
    | other =>
      match Tezos_stdlib.TzString.remove_prefix "section-" % string other with
      | None => inr "wrong-dir-name" % string
      | Some s => inl (Some s)
      end
    end.
End Section_dir.

Module Sink_implementation.
  Definition t := t.
  
  Definition uri_scheme : string := "unix-files" % string.
  
  Definition configure (uri : Uri.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult t) :=
    let event_filter :=
      let name_res :=
        OCaml.Stdlib.reverse_apply
          (Uri.get_query_param' uri "name-matches" % string)
          (Tezos_stdlib.Option.unopt []) in
      let names :=
        OCaml.Stdlib.reverse_apply (Uri.get_query_param' uri "name" % string)
          (Tezos_stdlib.Option.unopt []) in
      let levels :=
        OCaml.Stdlib.reverse_apply
          (Tezos_stdlib.Option.op_gt_gt_eq
            (Tezos_stdlib.Option.op_gt_gt_eq
              (Uri.get_query_param uri "level-at-least" % string)
              Tezos_event_logging.Internal_event.Level.of_string)
            (fun l =>
              Tezos_stdlib.Option.some (cons (Event_filter.level_at_least l) [])))
          (Tezos_stdlib.Option.unopt []) in
      let sections :=
        let somes :=
          OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (Uri.get_query_param' uri "section" % string)
              (Tezos_stdlib.Option.unopt []))
            (List.map
              (fun s =>
                Tezos_event_logging.Internal_event.Section.make_sanitized
                  (Stdlib.String.split_on_char "." % char s))) in
        let none :=
          match Uri.get_query_param uri "no-section" % string with
          | Some "true" % string =>
            cons Tezos_event_logging.Internal_event.Section.empty []
          | _ => []
          end in
        match OCaml.Stdlib.app somes none with
        | [] => []
        | more => cons (Event_filter.section_in more) []
        end in
      match
        OCaml.Stdlib.app levels
          (OCaml.Stdlib.app sections
            (OCaml.Stdlib.app
              (List.map Event_filter.name_matches_posix name_res)
              (List.map Event_filter.name_is names))) with
      | [] => Event_filter.t
      | more => Event_filter.any more
      end in
    let t :=
      {| path := Uri.path uri; lwt_bad_citizen_hack := Stdlib.ref [];
        event_filter := event_filter |} in
    Tezos_error_monad.Error_monad._return t.
  
  Definition output_json
    (pp : Stdlib.Format.formatter -> unit -> unit) (file_path : string)
    (event_json : Tezos_data_encoding.Data_encoding.json)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Lwt.catch
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_error_monad.Error_monad.op_gt_gt_eq
            (Tezos_stdlib_unix.Lwt_utils_unix.create_dir (Some 448)
              (Stdlib.Filename.dirname file_path))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_error_monad.Error_monad.op_gt_gt_eq
                  (Tezos_stdlib_unix.Lwt_utils_unix.Json.write_file file_path
                    event_json)
                  (fun function_parameter =>
                    match function_parameter with
                    | inl tt => Tezos_error_monad.Error_monad.return_unit
                    | inr el =>
                      Tezos_error_monad.Error_monad.failwith
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "ERROR while Handling " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal "," % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "cannot write JSON to " % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Char_literal
                                        ":" % char
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@ " % string 1 0)
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Char_literal
                                              "010" % char
                                              (CamlinternalFormatBasics.Flush
                                                CamlinternalFormatBasics.End_of_format)))))))))))
                          "ERROR while Handling %a,@ cannot write JSON to %s:@ %a
%!"
                            % string) pp tt file_path
                        Tezos_error_monad.Error_monad.pp_print_error el
                    end)
              end)
        end)
      (fun e =>
        Tezos_error_monad.Error_monad.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "ERROR while Handling " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal ": " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal "010" % char
                      (CamlinternalFormatBasics.Flush
                        CamlinternalFormatBasics.End_of_format))))))
            "ERROR while Handling %a: %a
%!" % string) pp tt
          Tezos_error_monad.Error_monad.pp_exn e).
  
  Definition handle {A : Type} (function_parameter : t)
    : {_ : unit &
      Tezos_event_logging.Internal_event.EVENT_DEFINITION.signature A} ->
      (option Tezos_event_logging.Internal_event.Section.t) ->
        (unit -> A) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    match function_parameter with
    | {|
      path := path;
        lwt_bad_citizen_hack := lwt_bad_citizen_hack;
        event_filter := event_filter
        |} =>
      fun m =>
        fun op_star_o_p_t_star =>
          let section :=
            match op_star_o_p_t_star with
            | Some op_star_s_t_h_star => op_star_s_t_h_star
            | None => Tezos_event_logging.Internal_event.Section.empty
            end in
          fun v =>
            let M := projT2 m in
            let now := Micro_seconds.now tt in
            match Micro_seconds.date_string now with
            | (date, time) =>
              let forced := v tt in
              let level :=
                M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.level)
                  forced in
              match
                Event_filter.run section level
                  M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
                  event_filter with
              | true =>
                let event_json :=
                  Tezos_data_encoding.Data_encoding.Json.construct
                    (wrapped_encoding
                      M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.encoding))
                    (wrap now section forced) in
                let tag :=
                  let hash :=
                    OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply
                        (Stdlib.Marshal.to_string event_json [])
                        Stdlib.Digest.string) Stdlib.Digest.to_hex in
                  Stdlib.String.sub hash 0 8 in
                let section_dir := Section_dir.of_section section in
                let dir_path :=
                  Stdlib.List.fold_left Stdlib.Filename.concat path
                    (cons section_dir
                      (cons
                        M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
                        (cons date (cons time [])))) in
                let file_path :=
                  Stdlib.Filename.concat dir_path
                    (Stdlib.Printf.sprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal "_" % char
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.Char_literal "_" % char
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    ".json" % string
                                    CamlinternalFormatBasics.End_of_format))))))
                        "%s_%s_%s.json" % string) date time tag) in
                Stdlib.op_colon_eq lwt_bad_citizen_hack
                  (cons (file_path, event_json)
                    (Stdlib.op_exclamation lwt_bad_citizen_hack));
                Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                  (output_json
                    (fun fmt =>
                      fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.pp)
                            fmt forced
                        end) file_path event_json)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Stdlib.op_colon_eq lwt_bad_citizen_hack
                        (Stdlib.List.filter
                          (fun function_parameter =>
                            match function_parameter with
                            | (f, _) => nequiv_decb f file_path
                            end) (Stdlib.op_exclamation lwt_bad_citizen_hack));
                      Tezos_error_monad.Error_monad.return_unit
                    end)
              | false => Tezos_error_monad.Error_monad.return_unit
              end
            end
    end.
  
  Definition close (function_parameter : t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    match function_parameter with
    | {| lwt_bad_citizen_hack := lwt_bad_citizen_hack |} =>
      Tezos_error_monad.Error_monad.op_gt_gt_eq_question
        (Tezos_error_monad.Error_monad.iter_s
          (fun function_parameter =>
            match function_parameter with
            | (f, j) =>
              output_json
                (fun fmt =>
                  fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Stdlib.Format.fprintf fmt
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Destacking: " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))
                          "Destacking: %s" % string) f
                    end) f j
            end) (Stdlib.op_exclamation lwt_bad_citizen_hack))
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_error_monad.Error_monad.return_unit
          end)
    end.
End Sink_implementation.

Import Sink_implementation.

Module Query.
  Definition with_file_kind (dir : string) (p : string)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult variant) :=
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
      (Tezos_error_monad.Error_monad.protect None None
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_error_monad.Error_monad.op_gt_gt_eq
              (Lwt_unix.stat (Stdlib.Filename.concat dir p))
              (fun function_parameter =>
                match function_parameter with
                | {| Lwt_unix.st_kind := st_kind |} =>
                  Tezos_error_monad.Error_monad._return st_kind
                end)
          end))
      (fun function_parameter =>
        match function_parameter with
        | Unix.S_DIR => Tezos_error_monad.Error_monad._return variant
        | Unix.S_REG => Tezos_error_monad.Error_monad._return variant
        |
          (Unix.S_CHR | Unix.S_BLK | Unix.S_LNK | Unix.S_FIFO | Unix.S_SOCK) as
            k => Tezos_error_monad.Error_monad._return variant
        end).
  
  Definition fold_directory {A : Type}
    (path : string) (init : Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
    (f : A -> variant -> Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
      (Tezos_error_monad.Error_monad.protect None None
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_error_monad.Error_monad.op_gt_gt_eq (Lwt_unix.opendir path)
              (fun dirhandle => Tezos_error_monad.Error_monad._return dirhandle)
          end))
      (fun dirhandle =>
        let fix iter (prev : Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
          : Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
          Tezos_error_monad.Error_monad.op_gt_gt_eq_question
            (Tezos_error_monad.Error_monad.protect None None
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Lwt.catch
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_error_monad.Error_monad.op_gt_gt_eq
                          (Lwt_unix.readdir dirhandle)
                          (fun d =>
                            Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                              (with_file_kind path d)
                              (fun wk =>
                                Tezos_error_monad.Error_monad.return_some wk))
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | OCaml.End_of_file =>
                        Tezos_error_monad.Error_monad.op_gt_gt_eq
                          (Lwt_unix.closedir dirhandle)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_error_monad.Error_monad.return_none
                            end)
                      | _ as e =>
                        Tezos_error_monad.Error_monad.failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "ERROR while folding " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  ": " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.End_of_format))))
                            "ERROR while folding %s: %s" % string) path
                          (Stdlib.Printexc.to_string e)
                      end)
                end))
            (fun opt =>
              Tezos_error_monad.Error_monad.op_gt_gt_eq_question prev
                (fun p =>
                  match opt with
                  | Some more => iter (f p more)
                  | None => prev
                  end)) in
        iter init).
  
  Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.
  
  Module Time_constraint.
    Definition op := variant.
    
    Definition t := variant.
    
    Fixpoint check_logic {A : Type}
      (check_terminal : variant -> bool) (t : t) (string : A) : bool :=
      let continue := check_logic check_terminal in
      match t with
      | All => true
      | And (a, b) => andb (continue a string) (continue b string)
      | Or (a, b) => orb (continue a string) (continue b string)
      | (Date _ | Time _) as term => check_terminal term
      end.
    
    Definition op_with_string (function_parameter : variant)
      : Stdlib.String.t -> Stdlib.String.t -> bool :=
      match function_parameter with
      | Lt => fun a => fun b => OCaml.Stdlib.gt (Stdlib.String.compare a b) 0
      | Gt => fun a => fun b => OCaml.Stdlib.lt (Stdlib.String.compare a b) 0
      | Le => fun a => fun b => OCaml.Stdlib.ge (Stdlib.String.compare a b) 0
      | Ge => fun a => fun b => OCaml.Stdlib.le (Stdlib.String.compare a b) 0
      end.
    
    Definition check_date (t : t) (date_string : Stdlib.String.t) : bool :=
      check_logic
        (fun function_parameter =>
          match function_parameter with
          | Date (op, f) =>
            let s :=
              OCaml.Stdlib.reverse_apply
                (Micro_seconds.date_string (Micro_seconds.of_float f)) fst in
            op_with_string op s date_string
          | Time _ => true
          end) t date_string.
    
    Definition check_time (t : t) (string : Stdlib.String.t) : bool :=
      check_logic
        (fun function_parameter =>
          match function_parameter with
          | Time (op, f) =>
            let s :=
              OCaml.Stdlib.reverse_apply
                (Micro_seconds.date_string (Micro_seconds.of_float f)) snd in
            op_with_string op s string
          | Date _ => true
          end) t Micro_seconds.date_string.
  End Time_constraint.
  
  Module Report.
    Definition item := variant.
    
    Definition pp (fmt : Stdlib.Format.formatter) (x : item) : unit :=
      let error (fmt : Stdlib.Format.formatter) (function_parameter : variant)
        : unit :=
        match function_parameter with
        | Parsing_event e =>
          match e with
          | Encoding (path, exn) =>
            Stdlib.Format.fprintf fmt
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Parse error:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "wrong encoding for " % string
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal ": " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))))
                "@[Parse error:@ wrong encoding for %S: %a@]" % string) path
              Tezos_error_monad.Error_monad.pp_exn exn
          | Json (path, el) =>
            Stdlib.Format.fprintf fmt
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Parse error:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "wrong JSON for " % string
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal ": " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))))
                "@[Parse error:@ wrong JSON for %S: %a@]" % string) path
              Tezos_error_monad.Error_monad.pp_print_error el
          end
        | Cannot_recognize_section sec =>
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.String_literal
                  "Directory error:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal
                      "cannot recognize section directory" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))))
              "@[Directory error:@ cannot recognize section directory@ %S@]" %
                string) sec
        end in
      let warning (fmt : Stdlib.Format.formatter) (function_parameter : variant)
        : unit :=
        match function_parameter with
        | Expecting_regular_file_at path =>
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal
                    "is not a regular file" % string
                    CamlinternalFormatBasics.End_of_format)))
              "%S@ is not a regular file" % string) path
        | Expecting_directory_at path =>
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal
                    "is not a directory" % string
                    CamlinternalFormatBasics.End_of_format)))
              "%S@ is not a directory" % string) path
        | Unknown_event_name_at (name, path) =>
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Unknown event name" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal "at" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Caml_string
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.End_of_format)))))))
              "Unknown event name@ %S@ at@ %S" % string) name path
        end in
      match x with
      | Error e =>
        Stdlib.Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (CamlinternalFormatBasics.String_literal "Error:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[Error:@ %a@]" % string) error e
      | Warning e =>
        Stdlib.Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (CamlinternalFormatBasics.String_literal "Warning:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[Warning:@ %a@]" % string) warning e
      end.
    
    Definition make_return {A B : Type}
      (m : A -> item) (function_parameter : (list item) * B)
      : A -> Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * B)) :=
      match function_parameter with
      | (_ as prev, value) =>
        fun warning =>
          Tezos_error_monad.Error_monad._return ((cons (m warning) prev), value)
      end.
    
    Definition return_with_warning {A : Type}
      (v : (list item) * A) (e : variant)
      : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * A)) :=
      make_return (fun e => variant) v e.
    
    Definition return_with_error {A : Type} (v : (list item) * A) (e : variant)
      : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * A)) :=
      make_return (fun e => variant) v e.
  End Report.
  
  Import Report.
  
  Definition fold_event_kind_directory {A : Type}
    (time_query : Time_constraint.t) (path : string)
    (init : (list Report.item) * A)
    (f :
      ((list Report.item) * A) ->
        string ->
          Lwt.t
            (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)))
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
    fold_directory path (Tezos_error_monad.Error_monad._return init)
      (fun previous =>
        fun function_parameter =>
          match function_parameter with
          | Directory "." % string | Directory ".." % string =>
            Tezos_error_monad.Error_monad._return previous
          | Directory date =>
            fold_directory (op_div_div path date)
              (Tezos_error_monad.Error_monad._return previous)
              (fun previous =>
                fun function_parameter =>
                  match function_parameter with
                  | Directory "." % string | Directory ".." % string =>
                    Tezos_error_monad.Error_monad._return previous
                  | Directory time =>
                    fold_directory (op_div_div (op_div_div path date) time)
                      (Tezos_error_monad.Error_monad._return previous)
                      (fun previous =>
                        fun function_parameter =>
                          match function_parameter with
                          | Directory "." % string | Directory ".." % string =>
                            Tezos_error_monad.Error_monad._return previous
                          | Regular_file file =>
                            f previous
                              (op_div_div
                                (op_div_div (op_div_div path date) time) file)
                          | Directory p | Special (_, p) =>
                            Report.return_with_warning previous variant
                          end)
                  | Directory _ =>
                    Tezos_error_monad.Error_monad._return previous
                  | Regular_file p | Special (_, p) =>
                    Report.return_with_warning previous variant
                  end)
          | Directory _ => Tezos_error_monad.Error_monad._return previous
          | Regular_file p | Special (_, p) =>
            Report.return_with_warning previous variant
          end).
  
  Definition handle_event_kind_directory {A B : Type}
    (time_query : Time_constraint.t) (section_path : string)
    (init : (list Report.item) * A)
    (f :
      A ->
        float ->
          Tezos_event_logging.Internal_event.Generic.event ->
            Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
    (ev :
      {_ : unit &
        Tezos_event_logging.Internal_event.EVENT_DEFINITION.signature B})
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
    let Event := projT2 ev in
    let handle_event_file (previous : (list Report.item) * A) (path : string)
      : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
      Tezos_error_monad.Error_monad.op_gt_gt_eq
        (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file path)
        (fun function_parameter =>
          match function_parameter with
          | inl json => try
          | inr el => Report.return_with_error previous variant
          end) in
    fold_event_kind_directory time_query
      (op_div_div section_path
        Event.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)) init
      (fun prev => fun file => handle_event_file prev file).
  
  Definition fold {A : Type}
    (on_unknown :
      option (string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)))
    (only_sections : option (list (option string)))
    (only_names : option (list string)) (op_star_o_p_t_star : option variant)
    : Uri.t ->
      A ->
        (A ->
          float ->
            Tezos_event_logging.Internal_event.Generic.event ->
              Lwt.t (Tezos_error_monad.Error_monad.tzresult A)) ->
          Lwt.t
            (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
    let time_query :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => variant
      end in
    fun uri =>
      fun init =>
        fun f =>
          let name_matches :=
            match only_names with
            | None =>
              fun function_parameter =>
                match function_parameter with
                | _ => true
                end
            | Some l => fun name => Stdlib.List.mem name l
            end in
          let section_matches :=
            match only_sections with
            | None =>
              fun function_parameter =>
                match function_parameter with
                | _ => true
                end
            | Some l => fun name => Stdlib.List.mem name l
            end in
          Tezos_error_monad.Error_monad.op_gt_gt_eq_question
            (Sink_implementation.(Tezos_event_logging__Internal_event.SINK.configure)
              uri)
            (fun function_parameter =>
              match function_parameter with
              | {| path := sink_path |} =>
                fold_directory sink_path
                  (Tezos_error_monad.Error_monad._return ([], init))
                  (fun previous =>
                    fun function_parameter =>
                      match function_parameter with
                      | Directory ("." % string | ".." % string) =>
                        Tezos_error_monad.Error_monad._return previous
                      | Directory dir =>
                        match Section_dir.section_name dir with
                        | inl _ =>
                          Tezos_error_monad.Error_monad._return previous
                        | inr _ => Report.return_with_error previous variant
                        end
                      | Regular_file p | Special (_, p) =>
                        Report.return_with_warning previous variant
                      end)
              end).
End Query.
src/lib_stdlib_unix/file_event_sink.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** An implementation of {!Tezos_base.Internal_event.SINK} which
    writes the events as JSON files in a given directory structure.

    It is registered with the URI scheme ["unix-files"], one can activate it
    with an URI containing the top-level directory in which the JSON
    files will be written, e.g.
    ["export TEZOS_EVENTS_CONFIG=unix-files:///the/path/to/write"]
    (the path should be inexistent or already a directory).

    The directory structure is as follows:
    ["<section-dirname>/<event-name>/<YYYYMMDD-string>/<HHMMSS-MMMMMM>/<YYYYMMDD-HHMMSS-MMMMMM-xxxx.json>"]
    where ["<section-dirname>"] is either ["no-section"] or
    ["section-<section-name>"].
*)

open Error_monad

type t

module Sink_implementation : Internal_event.SINK with type t = t

(** The module {!Query} provides a {!fold} function over the events
    stored by a given instantiation of the [SINK.t]. *)
module Query : sig
  module Time_constraint : sig
    type op = [`Lt | `Le | `Ge | `Gt]

    type t =
      [ `All
      | `And of t * t
      | `Or of t * t
      | `Date of op * float
      | `Time of op * float ]
  end

  (** The {!fold} function returns a list of non-fatal errors and
      warnings that happened during the scan, those are defined in
      {!Report.item}. *)
  module Report : sig
    type item =
      [ `Error of
        [ `Parsing_event of
          [`Encoding of string * exn | `Json of string * error list]
        | `Cannot_recognize_section of string ]
      | `Warning of
        [ `Expecting_regular_file_at of string
        | `Expecting_directory_at of string
        | `Unknown_event_name_at of string * string ] ]

    val pp : Format.formatter -> item -> unit
  end

  (** Scan a folder for events.

      - [?on_unknown] is a function which takes a path to a JSON file.
      - [?only_sections] is an optional filter on the sections in which the
        events have been emitted ({!Internal_event.Section.t}).
      - [?only_names] is an optional filter on the event names.
      - [?time_query] is a filter restricting the allowed events'
        emission dates (cf. {!Time_constraint}).

      See also an example of use in {!Client_event_logging_commands}
      (command ["tezos-client-admin query events from
      unix-files:///..."]).
  *)
  val fold :
    ?on_unknown:(string -> unit tzresult Lwt.t) ->
    ?only_sections:string option list ->
    ?only_names:string list ->
    ?time_query:Time_constraint.t ->
    Uri.t ->
    init:'a ->
    f:('a ->
      time_stamp:float ->
      Internal_event.Generic.event ->
      'a tzresult Lwt.t) ->
    (Report.item list * 'a) tzresult Lwt.t
end
src/lib_stdlib_unix/file_event_sink.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

unhandled_module

Module Query.
  Module Time_constraint.
    Definition op := variant.
    
    Definition t := variant.
  End Time_constraint.
  
  Module Report.
    Definition item := variant.
    
    Parameter pp : Stdlib.Format.formatter -> item -> unit.
  End Report.
  
  Parameter fold : forall {a : Type}, (option
    (string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))) ->
    (option (list (option string))) ->
      (option (list string)) ->
        (option Time_constraint.t) ->
          Uri.t ->
            a ->
              (a ->
                float ->
                  Tezos_event_logging.Internal_event.Generic.event ->
                    Lwt.t (Tezos_error_monad.Error_monad.tzresult a)) ->
                Lwt.t
                  (Tezos_error_monad.Error_monad.tzresult
                    ((list Report.item) * a)).
End Query.
src/lib_stdlib_unix/internal_event_unix.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module Configuration = struct
  type t = {activate : Uri.t list}

  let default =
    {activate = [Uri.make ~scheme:Internal_event.Lwt_log_sink.uri_scheme ()]}

  let encoding =
    let open Data_encoding in
    conv
      (fun {activate} -> List.map Uri.to_string activate)
      (fun activate -> {activate = List.map Uri.of_string activate})
      (obj1
         (dft
            "activate"
            ~description:"List of URIs to activate/configure sinks."
            (list string)
            []))

  let of_file path =
    Lwt_utils_unix.Json.read_file path
    >>=? fun json ->
    protect (fun () -> return (Data_encoding.Json.destruct encoding json))

  let apply {activate} =
    List.fold_left
      (fun prev uri ->
        prev >>=? fun () -> Internal_event.All_sinks.activate uri)
      return_unit
      activate
end

let env_var_name = "TEZOS_EVENTS_CONFIG"

let init ?lwt_log_sink ?(configuration = Configuration.default) () =
  let _ =
    (* This is just here to force the linking (and hence
       initialization) of all these modules: *)
    [ File_descriptor_sink.Sink_implementation_path.uri_scheme;
      File_event_sink.Sink_implementation.uri_scheme ]
  in
  Lwt_log_sink_unix.initialize ?cfg:lwt_log_sink ()
  >>= fun () ->
  ( match Sys.(getenv_opt env_var_name) with
  | None ->
      return_unit
  | Some s ->
      let uris =
        TzString.split ' ' s
        |> List.map (TzString.split '\n')
        |> List.concat
        |> List.map (TzString.split '\t')
        |> List.concat
        |> List.filter (( <> ) "")
        |> List.map Uri.of_string
      in
      List.fold_left
        (fun prev uri ->
          prev
          >>=? fun () ->
          match Uri.scheme uri with
          | None ->
              Configuration.of_file (Uri.path uri)
              >>=? fun cfg -> Configuration.apply cfg
          | Some _ ->
              Internal_event.All_sinks.activate uri)
        return_unit
        uris
      >>=? fun () ->
      Internal_event.Debug_event.(
        emit
          (make
             "Loaded URIs from environment"
             ~attach:
               (`O [("variable", `String env_var_name); ("value", `String s)])))
  )
  >>=? (fun () -> Configuration.apply configuration)
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error el ->
      Format.kasprintf
        Lwt.fail_with
        "ERROR@ Initializing Internal_event_unix:@ %a\n%!"
        Error_monad.pp_print_error
        el

let close () =
  Internal_event.All_sinks.close ()
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error el ->
      Format.kasprintf
        Lwt.fail_with
        "ERROR@ closing Internal_event_unix:@ %a\n%!"
        Error_monad.pp_print_error
        el
src/lib_stdlib_unix/internal_event_unix.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Module Configuration.
  Record t := {
    activate : list Uri.t }.
  
  Definition default : t :=
    {|
      activate :=
        cons
          (Uri.make
            (Some Tezos_event_logging.Internal_event.Lwt_log_sink.uri_scheme)
            None None None None None None tt) [] |}.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    Tezos_data_encoding.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| activate := activate |} => List.map Uri.to_string activate
        end) (fun activate => {| activate := List.map Uri.of_string activate |})
      None
      (Tezos_data_encoding.Data_encoding.obj1
        (Tezos_data_encoding.Data_encoding.dft None
          (Some "List of URIs to activate/configure sinks." % string)
          "activate" % string
          (Tezos_data_encoding.Data_encoding.list None
            Tezos_data_encoding.Data_encoding.string) [])).
  
  Definition of_file (path : string)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult t) :=
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
      (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file path)
      (fun json =>
        Tezos_error_monad.Error_monad.protect None None
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_error_monad.Error_monad._return
                (Tezos_data_encoding.Data_encoding.Json.destruct encoding json)
            end)).
  
  Definition apply (function_parameter : t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    match function_parameter with
    | {| activate := activate |} =>
      Stdlib.List.fold_left
        (fun prev =>
          fun uri =>
            Tezos_error_monad.Error_monad.op_gt_gt_eq_question prev
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_event_logging.Internal_event.All_sinks.activate uri
                end)) Tezos_error_monad.Error_monad.return_unit activate
    end.
End Configuration.

Definition env_var_name : string := "TEZOS_EVENTS_CONFIG" % string.

Definition init
  (lwt_log_sink : option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg)
  (op_star_o_p_t_star : option Configuration.t) : unit -> Lwt.t unit :=
  let configuration :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Configuration.default
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      match
        cons
          Tezos_stdlib_unix.File_descriptor_sink.Sink_implementation_path.uri_scheme
          (cons Tezos_stdlib_unix.File_event_sink.Sink_implementation.uri_scheme
            []) with
      | _ =>
        Tezos_error_monad.Error_monad.op_gt_gt_eq
          (Tezos_stdlib_unix.Lwt_log_sink_unix.initialize lwt_log_sink tt)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_error_monad.Error_monad.op_gt_gt_eq
                (Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                  match Stdlib.Sys.getenv_opt env_var_name with
                  | None => Tezos_error_monad.Error_monad.return_unit
                  | Some s =>
                    let uris :=
                      OCaml.Stdlib.reverse_apply
                        (OCaml.Stdlib.reverse_apply
                          (OCaml.Stdlib.reverse_apply
                            (OCaml.Stdlib.reverse_apply
                              (OCaml.Stdlib.reverse_apply
                                (OCaml.Stdlib.reverse_apply
                                  (Tezos_stdlib.TzString.split " " % char None
                                    None s)
                                  (List.map
                                    (let arg :=
                                      Tezos_stdlib.TzString.split "010" % char
                                      in
                                    fun eta => arg None None eta)))
                                Stdlib.List.concat)
                              (List.map
                                (let arg :=
                                  Tezos_stdlib.TzString.split "009" % char in
                                fun eta => arg None None eta)))
                            Stdlib.List.concat)
                          (Stdlib.List.filter (nequiv_decb "" % string)))
                        (List.map Uri.of_string) in
                    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                      (Stdlib.List.fold_left
                        (fun prev =>
                          fun uri =>
                            Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                              prev
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  match Uri.scheme uri with
                                  | None =>
                                    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
                                      (Configuration.of_file (Uri.path uri))
                                      (fun cfg => Configuration.apply cfg)
                                  | Some _ =>
                                    Tezos_event_logging.Internal_event.All_sinks.activate
                                      uri
                                  end
                                end)) Tezos_error_monad.Error_monad.return_unit
                        uris)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_event_logging.Internal_event.Debug_event.emit
                            None
                            (Tezos_event_logging.Internal_event.Debug_event.make
                              (Some variant)
                              "Loaded URIs from environment" % string)
                        end)
                  end
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Configuration.apply configuration
                    end))
                (fun function_parameter =>
                  match function_parameter with
                  | inl tt => Lwt.return_unit
                  | inr el =>
                    Stdlib.Format.kasprintf Lwt.fail_with
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "ERROR" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "Initializing Internal_event_unix:" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    "010" % char
                                    (CamlinternalFormatBasics.Flush
                                      CamlinternalFormatBasics.End_of_format)))))))
                        "ERROR@ Initializing Internal_event_unix:@ %a
%!" %
                          string) Tezos_error_monad.Error_monad.pp_print_error
                      el
                  end)
            end)
      end
    end.

Definition close (function_parameter : unit) : Lwt.t unit :=
  match function_parameter with
  | tt =>
    Tezos_error_monad.Error_monad.op_gt_gt_eq
      (Tezos_event_logging.Internal_event.All_sinks.close tt)
      (fun function_parameter =>
        match function_parameter with
        | inl tt => Lwt.return_unit
        | inr el =>
          Stdlib.Format.kasprintf Lwt.fail_with
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "ERROR" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal
                    "closing Internal_event_unix:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Flush
                            CamlinternalFormatBasics.End_of_format)))))))
              "ERROR@ closing Internal_event_unix:@ %a
%!" % string)
            Tezos_error_monad.Error_monad.pp_print_error el
        end)
  end.
src/lib_stdlib_unix/internal_event_unix.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Configure the event-logging framework for UNIx-based applications. *)

(** The JSON-file-friendly definition of the configuration of the
    internal-events framework. It allows one to activate registered
    event sinks.  *)

open Error_monad

module Configuration : sig
  type t

  (** The default configuration is empty (it doesn't activate any sink). *)
  val default : t

  (** The serialization format. *)
  val encoding : t RPC_encoding.t

  (** Parse a json file at [path] into a configuration. *)
  val of_file : string -> t tzresult Lwt.t

  (** Run {!Tezos_base.Internal_event.All_sinks.activate} for every
      URI in the configuration. *)
  val apply : t -> unit tzresult Lwt.t
end

(** Initialize the internal-event sinks by looking at the
    [?configuration] argument and then at the (whitespace separated) list
    of URIs in the ["TEZOS_EVENTS_CONFIG"] environment variable, if an URI
    does not have a scheme it is expected to be a path to a configuration
    JSON file (cf. {!Configuration.of_file}), e.g.:
    [export TEZOS_EVENTS_CONFIG="unix-files:///tmp/events-unix debug://"], or
    [export TEZOS_EVENTS_CONFIG="debug://  /path/to/config.json"].

    The function also initializes the {!Lwt_log_sink_unix} module
    (corresponding to the ["TEZOS_LOG"] environment variable).
*)
val init :
  ?lwt_log_sink:Lwt_log_sink_unix.cfg ->
  ?configuration:Configuration.t ->
  unit ->
  unit Lwt.t

(** Call [close] on all the sinks. *)
val close : unit -> unit Lwt.t
src/lib_stdlib_unix/internal_event_unix.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Configuration.
  Parameter t : Type.
  
  Parameter default : t.
  
  Parameter encoding : Tezos_rpc.RPC_encoding.t t.
  
  Parameter of_file : string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult t).
  
  Parameter apply : t -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).
End Configuration.

Parameter init :
(option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg) ->
  (option Configuration.t) -> unit -> Lwt.t unit.

Parameter close : unit -> Lwt.t unit.
src/lib_stdlib_unix/lwt_exit.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

exception Exit

let (termination_thread, exit_wakener) = Lwt.wait ()

let exit x = Lwt.wakeup exit_wakener x ; raise Exit

let () =
  Lwt.async_exception_hook :=
    function
    | Exit ->
        ()
    | e ->
        let backtrace = Printexc.get_backtrace () in
        let pp_exn_trace ppf backtrace =
          if String.length backtrace <> 0 then
            Format.fprintf
              ppf
              "@,Backtrace:@,  @[<h>%a@]"
              Format.pp_print_text
              backtrace
        in
        (* TODO Improve this *)
        Format.eprintf
          "@[<v 2>@[Uncaught (asynchronous) exception (%d):@ %s@]%a@]@.%!"
          (Unix.getpid ())
          (Printexc.to_string e)
          pp_exn_trace
          backtrace ;
        Lwt.wakeup exit_wakener 1

let signals =
  let open Sys in
  [ (sigabrt, "ABRT");
    (sigalrm, "ALRM");
    (sigfpe, "FPE");
    (sighup, "HUP");
    (sigill, "ILL");
    (sigint, "INT");
    (sigkill, "KILL");
    (sigpipe, "PIPE");
    (sigquit, "QUIT");
    (sigsegv, "SEGV");
    (sigterm, "TERM");
    (sigusr1, "USR1");
    (sigusr2, "USR2");
    (sigchld, "CHLD");
    (sigcont, "CONT");
    (sigstop, "STOP");
    (sigtstp, "TSTP");
    (sigttin, "TTIN");
    (sigttou, "TTOU");
    (sigvtalrm, "VTALRM");
    (sigprof, "PROF");
    (sigbus, "BUS");
    (sigpoll, "POLL");
    (sigsys, "SYS");
    (sigtrap, "TRAP");
    (sigurg, "URG");
    (sigxcpu, "XCPU");
    (sigxfsz, "XFSZ") ]

let set_exit_handler ?(log = Format.eprintf "%s\n%!") signal =
  match List.assoc_opt signal signals with
  | None ->
      Format.kasprintf
        invalid_arg
        "Killable.set_exit_handler: unknown signal %d"
        signal
  | Some name ->
      let handler signal =
        try
          Format.kasprintf
            log
            "Received the %s signal, triggering shutdown."
            name ;
          exit signal
        with _ -> ()
      in
      ignore (Lwt_unix.on_signal signal handler : Lwt_unix.signal_handler_id)

(* Which signals is the program meant to exit on *)
let signals_to_exit_on = ref []

let exit_on ?log signal =
  if List.mem signal !signals_to_exit_on then
    Format.kasprintf
      Pervasives.failwith
      "Killable.exit_on: already registered signal %d"
      signal
  else (
    signals_to_exit_on := signal :: !signals_to_exit_on ;
    set_exit_handler ?log signal )

type outcome = Resolved of int | Exited of int

let retcode_of_unit_result_lwt p =
  let open Lwt.Infix in
  p
  >>= function
  | Error e ->
      (* TODO: print *) ignore e ; Lwt.return 1
  | Ok () ->
      Lwt.return 0

let wrap_promise (p : int Lwt.t) =
  let open Lwt.Infix in
  Lwt.choose
    [(p >|= fun v -> Resolved v); (termination_thread >|= fun s -> Exited s)]
  >>= function
  | Resolved r ->
      Lwt.return r
  | Exited s ->
      (*TODO: what are the correct expected behaviour here?*)
      if List.mem s !signals_to_exit_on then (
        (* Exit because of signal *)
        Lwt.cancel p ;
        Lwt.return 2 )
      else (* Other exit *)
        Pervasives.exit 3
src/lib_stdlib_unix/lwt_exit.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition exit {A : Type} (x : Z) : A :=
  Lwt.wakeup exit_wakener x;
  Stdlib.raise Exit.

Definition signals : list (Z * string) :=
  cons (Stdlib.Sys.sigabrt, "ABRT" % string)
    (cons (Stdlib.Sys.sigalrm, "ALRM" % string)
      (cons (Stdlib.Sys.sigfpe, "FPE" % string)
        (cons (Stdlib.Sys.sighup, "HUP" % string)
          (cons (Stdlib.Sys.sigill, "ILL" % string)
            (cons (Stdlib.Sys.sigint, "INT" % string)
              (cons (Stdlib.Sys.sigkill, "KILL" % string)
                (cons (Stdlib.Sys.sigpipe, "PIPE" % string)
                  (cons (Stdlib.Sys.sigquit, "QUIT" % string)
                    (cons (Stdlib.Sys.sigsegv, "SEGV" % string)
                      (cons (Stdlib.Sys.sigterm, "TERM" % string)
                        (cons (Stdlib.Sys.sigusr1, "USR1" % string)
                          (cons (Stdlib.Sys.sigusr2, "USR2" % string)
                            (cons (Stdlib.Sys.sigchld, "CHLD" % string)
                              (cons (Stdlib.Sys.sigcont, "CONT" % string)
                                (cons (Stdlib.Sys.sigstop, "STOP" % string)
                                  (cons (Stdlib.Sys.sigtstp, "TSTP" % string)
                                    (cons (Stdlib.Sys.sigttin, "TTIN" % string)
                                      (cons
                                        (Stdlib.Sys.sigttou, "TTOU" % string)
                                        (cons
                                          (Stdlib.Sys.sigvtalrm,
                                            "VTALRM" % string)
                                          (cons
                                            (Stdlib.Sys.sigprof, "PROF" % string)
                                            (cons
                                              (Stdlib.Sys.sigbus, "BUS" % string)
                                              (cons
                                                (Stdlib.Sys.sigpoll,
                                                  "POLL" % string)
                                                (cons
                                                  (Stdlib.Sys.sigsys,
                                                    "SYS" % string)
                                                  (cons
                                                    (Stdlib.Sys.sigtrap,
                                                      "TRAP" % string)
                                                    (cons
                                                      (Stdlib.Sys.sigurg,
                                                        "URG" % string)
                                                      (cons
                                                        (Stdlib.Sys.sigxcpu,
                                                          "XCPU" % string)
                                                        (cons
                                                          (Stdlib.Sys.sigxfsz,
                                                            "XFSZ" % string) []))))))))))))))))))))))))))).

Definition set_exit_handler (op_star_o_p_t_star : option (string -> unit))
  : Z -> unit :=
  let log :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      Stdlib.Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              (CamlinternalFormatBasics.Flush
                CamlinternalFormatBasics.End_of_format))) "%s
%!" % string)
    end in
  fun signal =>
    match Stdlib.List.assoc_opt signal signals with
    | None =>
      Stdlib.Format.kasprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Killable.set_exit_handler: unknown signal " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))
          "Killable.set_exit_handler: unknown signal %d" % string) signal
    | Some name =>
      let handler (signal : Z) : unit :=
        try in
      OCaml.Stdlib.ignore (Lwt_unix.on_signal signal handler)
    end.

Definition signals_to_exit_on : Stdlib.ref (list Z) := Stdlib.ref [].

Definition exit_on (log : option (string -> unit)) (signal : Z) : unit :=
  if Stdlib.List.mem signal (Stdlib.op_exclamation signals_to_exit_on) then
    Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Killable.exit_on: already registered signal " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format))
        "Killable.exit_on: already registered signal %d" % string) signal
  else
    Stdlib.op_colon_eq signals_to_exit_on
      (cons signal (Stdlib.op_exclamation signals_to_exit_on));
    set_exit_handler log signal.

Inductive outcome : Type :=
| Resolved : Z -> outcome
| Exited : Z -> outcome.

Definition retcode_of_unit_result_lwt {A : Type} (p : Lwt.t (sum unit A))
  : Lwt.t Z :=
  Lwt.Infix.op_gt_gt_eq p
    (fun function_parameter =>
      match function_parameter with
      | inr e =>
        OCaml.Stdlib.ignore e;
        Lwt._return 1
      | inl tt => Lwt._return 0
      end).

Definition wrap_promise (p : Lwt.t Z) : Lwt.t Z :=
  Lwt.Infix.op_gt_gt_eq
    (Lwt.choose
      (cons (Lwt.Infix.op_gt_pipe_eq p (fun v => Resolved v))
        (cons (Lwt.Infix.op_gt_pipe_eq termination_thread (fun s => Exited s))
          [])))
    (fun function_parameter =>
      match function_parameter with
      | Resolved r => Lwt._return r
      | Exited s =>
        if Stdlib.List.mem s (Stdlib.op_exclamation signals_to_exit_on) then
          Lwt.cancel p;
          Lwt._return 2
        else
          Stdlib.Pervasives.exit 3
      end).
src/lib_stdlib_unix/lwt_exit.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A global thread that resumes the first time {!exit} is called
    anywhere in the program. Called by the main to wait for any other
    thread in the system to call {!exit}. *)
val termination_thread : int Lwt.t

(** Awakens the {!termination_thread} with the given return value, and
    raises an exception that cannot be caught, except by a
    catch-all. Should only be called once. *)
val exit : int -> 'a

(** [exit_on signal] sets a signal handler for [signal] that exits cleanly using
    the [exit] function above. *)
val exit_on : ?log:(string -> unit) -> int -> unit

val retcode_of_unit_result_lwt : (unit, 'a) Result.result Lwt.t -> int Lwt.t

(** [wrap_promise p] is a promise [w] that resolves when either [p] resolves, or
    when [termination_thread] resolves. In the latter case, [p] is canceled,
    giving it a chance to clean up resources. *)
val wrap_promise : int Lwt.t -> int Lwt.t
src/lib_stdlib_unix/lwt_exit.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter termination_thread : Lwt.t Z.

Parameter exit : forall {a : Type}, Z -> a.

Parameter exit_on : (option (string -> unit)) -> Z -> unit.

Parameter retcode_of_unit_result_lwt : forall {a : Type},
(Lwt.t (Result.result unit a)) -> Lwt.t Z.

Parameter wrap_promise : (Lwt.t Z) -> Lwt.t Z.
src/lib_stdlib_unix/lwt_lock_file.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

let create_inner lock_command ?(close_on_exec = true) ?(unlink_on_exit = false)
    fn =
  protect (fun () ->
      Lwt_unix.openfile fn Unix.[O_CREAT; O_WRONLY; O_TRUNC] 0o644
      >>= fun fd ->
      if close_on_exec then Lwt_unix.set_close_on_exec fd ;
      Lwt_unix.lockf fd lock_command 0
      >>= fun () ->
      if unlink_on_exit then Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ;
      let pid_str = string_of_int @@ Unix.getpid () in
      Lwt_unix.write_string fd pid_str 0 (String.length pid_str)
      >>= fun _ -> return_unit)

let create = create_inner Unix.F_TLOCK

let blocking_create ?timeout ?(close_on_exec = true) ?(unlink_on_exit = false)
    fn =
  let create () = create_inner Unix.F_LOCK ~close_on_exec ~unlink_on_exit fn in
  match timeout with
  | None ->
      create ()
  | Some duration ->
      with_timeout (Lwt_unix.sleep duration) (fun _ -> create ())

let is_locked fn =
  if not @@ Sys.file_exists fn then return_false
  else
    protect (fun () ->
        Lwt_unix.openfile fn [Unix.O_RDONLY] 0o644
        >>= fun fd ->
        Lwt.finalize
          (fun () ->
            Lwt.try_bind
              (fun () -> Lwt_unix.(lockf fd F_TEST 0))
              (fun () -> return_false)
              (fun _ -> return_true))
          (fun () -> Lwt_unix.close fd))

let get_pid fn =
  let open Lwt_io in
  protect (fun () ->
      with_file ~mode:Input fn (fun ic ->
          read ic >>= fun content -> return (int_of_string content)))
src/lib_stdlib_unix/lwt_lock_file.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Definition create_inner
  (lock_command : Lwt_unix.lock_command) (op_star_o_p_t_star : option bool)
  : (option bool) ->
    string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let close_on_exec :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun op_star_o_p_t_star =>
    let unlink_on_exit :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun fn =>
      Tezos_error_monad.Error_monad.protect None None
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_error_monad.Error_monad.op_gt_gt_eq
              (Lwt_unix.openfile fn
                (cons O_CREAT (cons O_WRONLY (cons O_TRUNC []))) 420)
              (fun fd =>
                if close_on_exec then
                  Lwt_unix.set_close_on_exec fd
                else
                  tt;
                Tezos_error_monad.Error_monad.op_gt_gt_eq
                  (Lwt_unix.lockf fd lock_command 0)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      if unlink_on_exit then
                        Lwt_main.at_exit
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Lwt_unix.unlink fn
                            end)
                      else
                        tt;
                      let pid_str :=
                        apply OCaml.Stdlib.string_of_int (Unix.getpid tt) in
                      Tezos_error_monad.Error_monad.op_gt_gt_eq
                        (Lwt_unix.write_string fd pid_str 0
                          (OCaml.String.length pid_str))
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => Tezos_error_monad.Error_monad.return_unit
                          end)
                    end))
          end).

Definition create
  : (option bool) ->
    (option bool) ->
      string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  create_inner Unix.F_TLOCK.

Definition blocking_create
  (timeout : option float) (op_star_o_p_t_star : option bool)
  : (option bool) ->
    string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let close_on_exec :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun op_star_o_p_t_star =>
    let unlink_on_exit :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun fn =>
      let create (function_parameter : unit)
        : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
        match function_parameter with
        | tt =>
          create_inner Unix.F_LOCK (Some close_on_exec) (Some unlink_on_exit) fn
        end in
      match timeout with
      | None => create tt
      | Some duration =>
        Tezos_error_monad.Error_monad.with_timeout None
          (Lwt_unix.sleep duration)
          (fun function_parameter =>
            match function_parameter with
            | _ => create tt
            end)
      end.

Definition is_locked (fn : string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
  if apply negb (Stdlib.Sys.file_exists fn) then
    Tezos_error_monad.Error_monad.return_false
  else
    Tezos_error_monad.Error_monad.protect None None
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_error_monad.Error_monad.op_gt_gt_eq
            (Lwt_unix.openfile fn (cons Unix.O_RDONLY []) 420)
            (fun fd =>
              Lwt.finalize
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Lwt.try_bind
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Lwt_unix.lockf fd F_TEST 0
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_error_monad.Error_monad.return_false
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | _ => Tezos_error_monad.Error_monad.return_true
                        end)
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Lwt_unix.close fd
                  end))
        end).

Definition get_pid (fn : Lwt_io.file_name)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult Z) :=
  Tezos_error_monad.Error_monad.protect None None
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Lwt_io.with_file None None None Input fn
          (fun ic =>
            Tezos_error_monad.Error_monad.op_gt_gt_eq (Lwt_io.read None ic)
              (fun content =>
                Tezos_error_monad.Error_monad._return
                  (OCaml.Stdlib.int_of_string content)))
      end).
src/lib_stdlib_unix/lwt_lock_file.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

val create :
  ?close_on_exec:bool -> ?unlink_on_exit:bool -> string -> unit tzresult Lwt.t

val blocking_create :
  ?timeout:float ->
  ?close_on_exec:bool ->
  ?unlink_on_exit:bool ->
  string ->
  unit tzresult Lwt.t

val is_locked : string -> bool tzresult Lwt.t

val get_pid : string -> int tzresult Lwt.t
src/lib_stdlib_unix/lwt_lock_file.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter create :
(option bool) ->
  (option bool) -> string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).

Parameter blocking_create :
(option float) ->
  (option bool) ->
    (option bool) ->
      string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).

Parameter is_locked :
string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult bool).

Parameter get_pid : string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult Z).
src/lib_stdlib_unix/lwt_log_sink_unix.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

module Output = struct
  type t =
    | Null
    | Stdout
    | Stderr
    | File of string
    | Syslog of Lwt_log.syslog_facility

  let to_string : t -> string = function
    | Null ->
        "/dev/null"
    | Stdout ->
        "stdout"
    | Stderr ->
        "stderr"
    | File fp ->
        fp
    | Syslog `Auth ->
        "syslog:auth"
    | Syslog `Authpriv ->
        "syslog:authpriv"
    | Syslog `Cron ->
        "syslog:cron"
    | Syslog `Daemon ->
        "syslog:daemon"
    | Syslog `FTP ->
        "syslog:ftp"
    | Syslog `Kernel ->
        "syslog:kernel"
    | Syslog `Local0 ->
        "syslog:local0"
    | Syslog `Local1 ->
        "syslog:local1"
    | Syslog `Local2 ->
        "syslog:local2"
    | Syslog `Local3 ->
        "syslog:local3"
    | Syslog `Local4 ->
        "syslog:local4"
    | Syslog `Local5 ->
        "syslog:local5"
    | Syslog `Local6 ->
        "syslog:local6"
    | Syslog `Local7 ->
        "syslog:local7"
    | Syslog `LPR ->
        "syslog:lpr"
    | Syslog `Mail ->
        "syslog:mail"
    | Syslog `News ->
        "syslog:news"
    | Syslog `Syslog ->
        "syslog:syslog"
    | Syslog `User ->
        "syslog:user"
    | Syslog `UUCP ->
        "syslog:uucp"
    | Syslog `NTP ->
        "syslog:ntp"
    | Syslog `Security ->
        "syslog:security"
    | Syslog `Console ->
        "syslog:console"

  let of_string : string -> t = function
    | "/dev/null" | "null" ->
        Null
    | "stdout" ->
        Stdout
    | "stderr" ->
        Stderr
    | "syslog:auth" ->
        Syslog `Auth
    | "syslog:authpriv" ->
        Syslog `Authpriv
    | "syslog:cron" ->
        Syslog `Cron
    | "syslog:daemon" ->
        Syslog `Daemon
    | "syslog:ftp" ->
        Syslog `FTP
    | "syslog:kernel" ->
        Syslog `Kernel
    | "syslog:local0" ->
        Syslog `Local0
    | "syslog:local1" ->
        Syslog `Local1
    | "syslog:local2" ->
        Syslog `Local2
    | "syslog:local3" ->
        Syslog `Local3
    | "syslog:local4" ->
        Syslog `Local4
    | "syslog:local5" ->
        Syslog `Local5
    | "syslog:local6" ->
        Syslog `Local6
    | "syslog:local7" ->
        Syslog `Local7
    | "syslog:lpr" ->
        Syslog `LPR
    | "syslog:mail" ->
        Syslog `Mail
    | "syslog:news" ->
        Syslog `News
    | "syslog:syslog" ->
        Syslog `Syslog
    | "syslog:user" ->
        Syslog `User
    | "syslog:uucp" ->
        Syslog `UUCP
    | "syslog:ntp" ->
        Syslog `NTP
    | "syslog:security" ->
        Syslog `Security
    | "syslog:console" ->
        Syslog `Console
    (* | s when start_with "syslog:" FIXME error or warning. *)
    | fp ->
        (* TODO check absolute path *)
        File fp

  let encoding =
    let open Data_encoding in
    conv to_string of_string string

  let of_string str =
    try Some (Data_encoding.Json.destruct encoding (`String str))
    with _ -> None

  let to_string output =
    match Data_encoding.Json.construct encoding output with
    | `String res ->
        res
    | #Data_encoding.json ->
        assert false

  let pp fmt output = Format.fprintf fmt "%s" (to_string output)
end

let default_template = "$(date) - $(section): $(message)"

type cfg = {
  output : Output.t;
  default_level : Internal_event.level;
  rules : string option;
  template : Lwt_log_core.template;
}

let create_cfg ?(output = Output.Stderr)
    ?(default_level = Internal_event.Notice) ?rules
    ?(template = default_template) () =
  {output; default_level; rules; template}

let default_cfg = create_cfg ()

let cfg_encoding =
  let open Data_encoding in
  conv
    (fun {output; default_level; rules; template} ->
      (output, default_level, rules, template))
    (fun (output, default_level, rules, template) ->
      {output; default_level; rules; template})
    (obj4
       (dft
          "output"
          ~description:
            "Output for the logging function. Either 'stdout', 'stderr' or \
             the name of a log file ."
          Output.encoding
          default_cfg.output)
       (dft
          "level"
          ~description:
            "Verbosity level: one of 'fatal', 'error', 'warn','notice', \
             'info', 'debug'."
          Internal_event.Level.encoding
          default_cfg.default_level)
       (opt
          "rules"
          ~description:
            "Fine-grained logging instructions. Same format as described in \
             `tezos-node run --help`, DEBUG section. In the example below, \
             sections 'p2p' and all sections starting by 'client' will have \
             their messages logged up to the debug level, whereas the rest of \
             log sections will be logged up to the notice level."
          string)
       (dft
          "template"
          ~description:
            "Format for the log file, see \
             http://ocsigen.org/lwt/dev/api/Lwt_log_core#2_Logtemplates."
          string
          default_cfg.template))

let init ?(template = default_template) output =
  let open Output in
  ( match output with
  | Stderr ->
      Lwt.return
      @@ Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
  | Stdout ->
      Lwt.return
      @@ Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout ()
  | File file_name ->
      Lwt_log.file ~file_name ~template ()
  | Null ->
      Lwt.return @@ Lwt_log.null
  | Syslog facility ->
      Lwt.return @@ Lwt_log.syslog ~template ~facility () )
  >>= fun logger ->
  Lwt_log.default := logger ;
  Lwt.return_unit

let find_log_rules default =
  match Sys.(getenv_opt "TEZOS_LOG", getenv_opt "LWT_LOG") with
  | (Some rules, None) ->
      ("environment variable TEZOS_LOG", Some rules)
  | (None, Some rules) ->
      ("environment variable LWT_LOG", Some rules)
  | (None, None) ->
      ("configuration file", default)
  | (Some rules, Some _) ->
      Format.eprintf
        "@[<v 2>@{<warning>@{<title>Warning@}@} Both environment variables \
         TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG.@]@\n\
         @." ;
      ("environment varible TEZOS_LOG", Some rules)

let initialize ?(cfg = default_cfg) () =
  Lwt_log_core.add_rule "*" (Internal_event.Level.to_lwt_log cfg.default_level) ;
  let (origin, rules) = find_log_rules cfg.rules in
  ( match rules with
  | None ->
      Lwt.return_unit
  | Some rules -> (
    try
      Lwt_log_core.load_rules rules ~fail_on_error:true ;
      Lwt.return_unit
    with _ ->
      Printf.ksprintf Lwt.fail_with "Incorrect log rules defined in %s" origin
    ) )
  >>= fun () -> init ~template:cfg.template cfg.output
src/lib_stdlib_unix/lwt_log_sink_unix.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Module Output.
  Inductive t : Type :=
  | Null : t
  | Stdout : t
  | Stderr : t
  | File : string -> t
  | Syslog : Lwt_log.syslog_facility -> t.
  
  Definition to_string (function_parameter : t) : string :=
    match function_parameter with
    | Null => "/dev/null" % string
    | Stdout => "stdout" % string
    | Stderr => "stderr" % string
    | File fp => fp
    | Syslog Auth => "syslog:auth" % string
    | Syslog Authpriv => "syslog:authpriv" % string
    | Syslog Cron => "syslog:cron" % string
    | Syslog Daemon => "syslog:daemon" % string
    | Syslog FTP => "syslog:ftp" % string
    | Syslog Kernel => "syslog:kernel" % string
    | Syslog Local0 => "syslog:local0" % string
    | Syslog Local1 => "syslog:local1" % string
    | Syslog Local2 => "syslog:local2" % string
    | Syslog Local3 => "syslog:local3" % string
    | Syslog Local4 => "syslog:local4" % string
    | Syslog Local5 => "syslog:local5" % string
    | Syslog Local6 => "syslog:local6" % string
    | Syslog Local7 => "syslog:local7" % string
    | Syslog LPR => "syslog:lpr" % string
    | Syslog Mail => "syslog:mail" % string
    | Syslog News => "syslog:news" % string
    | Syslog Syslog => "syslog:syslog" % string
    | Syslog User => "syslog:user" % string
    | Syslog UUCP => "syslog:uucp" % string
    | Syslog NTP => "syslog:ntp" % string
    | Syslog Security => "syslog:security" % string
    | Syslog Console => "syslog:console" % string
    end.
  
  Definition of_string (function_parameter : string) : t :=
    match function_parameter with
    | "/dev/null" % string | "null" % string => Null
    | "stdout" % string => Stdout
    | "stderr" % string => Stderr
    | "syslog:auth" % string => Syslog variant
    | "syslog:authpriv" % string => Syslog variant
    | "syslog:cron" % string => Syslog variant
    | "syslog:daemon" % string => Syslog variant
    | "syslog:ftp" % string => Syslog variant
    | "syslog:kernel" % string => Syslog variant
    | "syslog:local0" % string => Syslog variant
    | "syslog:local1" % string => Syslog variant
    | "syslog:local2" % string => Syslog variant
    | "syslog:local3" % string => Syslog variant
    | "syslog:local4" % string => Syslog variant
    | "syslog:local5" % string => Syslog variant
    | "syslog:local6" % string => Syslog variant
    | "syslog:local7" % string => Syslog variant
    | "syslog:lpr" % string => Syslog variant
    | "syslog:mail" % string => Syslog variant
    | "syslog:news" % string => Syslog variant
    | "syslog:syslog" % string => Syslog variant
    | "syslog:user" % string => Syslog variant
    | "syslog:uucp" % string => Syslog variant
    | "syslog:ntp" % string => Syslog variant
    | "syslog:security" % string => Syslog variant
    | "syslog:console" % string => Syslog variant
    | fp => File fp
    end.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    Tezos_data_encoding.Data_encoding.conv to_string of_string None
      Tezos_data_encoding.Data_encoding.string.
  
  Definition of_string (str : string) : option t := try.
  
  Definition to_string (output : t) : string :=
    match Tezos_data_encoding.Data_encoding.Json.construct encoding output with
    | String res => res
    | Bool _ | Null | O _ | Float _ | String _ | A _ => false
    end.
  
  Definition pp (fmt : Stdlib.Format.formatter) (output : t) : unit :=
    Stdlib.Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string)
      (to_string output).
End Output.

Definition default_template : string :=
  "$(date) - $(section): $(message)" % string.

Record cfg := {
  output : Output.t;
  default_level : Tezos_event_logging.Internal_event.level;
  rules : option string;
  template : Lwt_log_core.template }.

Definition create_cfg (op_star_o_p_t_star : option Output.t)
  : (option Tezos_event_logging.Internal_event.level) ->
    (option string) -> (option string) -> unit -> cfg :=
  let output :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Output.Stderr
    end in
  fun op_star_o_p_t_star =>
    let default_level :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => Internal_event.Notice
      end in
    fun rules =>
      fun op_star_o_p_t_star =>
        let template :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => default_template
          end in
        fun function_parameter =>
          match function_parameter with
          | tt =>
            {| output := output; default_level := default_level; rules := rules;
              template := template |}
          end.

Definition default_cfg : cfg := create_cfg None None None None tt.

Definition cfg_encoding : Tezos_data_encoding.Data_encoding.encoding cfg :=
  Tezos_data_encoding.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        output := output;
          default_level := default_level;
          rules := rules;
          template := template
          |} => (output, default_level, rules, template)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (output, default_level, rules, template) =>
        {| output := output; default_level := default_level; rules := rules;
          template := template |}
      end) None
    (Tezos_data_encoding.Data_encoding.obj4
      (Tezos_data_encoding.Data_encoding.dft None
        (Some
          "Output for the logging function. Either 'stdout', 'stderr' or the name of a log file ."
            % string) "output" % string Output.encoding (output default_cfg))
      (Tezos_data_encoding.Data_encoding.dft None
        (Some
          "Verbosity level: one of 'fatal', 'error', 'warn','notice', 'info', 'debug'."
            % string) "level" % string
        Tezos_event_logging.Internal_event.Level.encoding
        (default_level default_cfg))
      (Tezos_data_encoding.Data_encoding.opt None
        (Some
          "Fine-grained logging instructions. Same format as described in `tezos-node run --help`, DEBUG section. In the example below, sections 'p2p' and all sections starting by 'client' will have their messages logged up to the debug level, whereas the rest of log sections will be logged up to the notice level."
            % string) "rules" % string Tezos_data_encoding.Data_encoding.string)
      (Tezos_data_encoding.Data_encoding.dft None
        (Some
          "Format for the log file, see http://ocsigen.org/lwt/dev/api/Lwt_log_core#2_Logtemplates."
            % string) "template" % string
        Tezos_data_encoding.Data_encoding.string (template default_cfg))).

Definition init (op_star_o_p_t_star : option string) : Output.t -> Lwt.t unit :=
  let template :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => default_template
    end in
  fun output =>
    Lwt.Infix.op_gt_gt_eq
      match output with
      | Stderr =>
        apply Lwt._return
          (Lwt_log.channel (Some template) variant Lwt_io.stderr tt)
      | Stdout =>
        apply Lwt._return
          (Lwt_log.channel (Some template) variant Lwt_io.stdout tt)
      | File file_name => Lwt_log.file (Some template) None None file_name tt
      | Null => apply Lwt._return Lwt_log.null
      | Syslog facility =>
        apply Lwt._return (Lwt_log.syslog (Some template) None facility tt)
      end
      (fun logger =>
        Stdlib.op_colon_eq Lwt_log.default logger;
        Lwt.return_unit).

Definition find_log_rules (default : option string)
  : string * (option string) :=
  match
    ((Stdlib.Sys.getenv_opt "TEZOS_LOG" % string),
      (Stdlib.Sys.getenv_opt "LWT_LOG" % string)) with
  | (Some rules, None) =>
    ("environment variable TEZOS_LOG" % string, (Some rules))
  | (None, Some rules) =>
    ("environment variable LWT_LOG" % string, (Some rules))
  | (None, None) => ("configuration file" % string, default)
  | (Some rules, Some _) =>
    Stdlib.Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<warning>" % string
                  CamlinternalFormatBasics.End_of_format) "<warning>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<title>" % string
                    CamlinternalFormatBasics.End_of_format) "<title>" % string))
              (CamlinternalFormatBasics.String_literal "Warning" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.String_literal
                      " Both environment variables TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG."
                        % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))))))))
        "@[<v 2>@{<warning>@{<title>Warning@}@} Both environment variables TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG.@]@
@."
          % string);
    ("environment varible TEZOS_LOG" % string, (Some rules))
  end.

Definition initialize (op_star_o_p_t_star : option cfg) : unit -> Lwt.t unit :=
  let cfg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => default_cfg
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      Lwt_log_core.add_rule "*" % string
        (Tezos_event_logging.Internal_event.Level.to_lwt_log (default_level cfg));
      match find_log_rules (rules cfg) with
      | (origin, rules) =>
        Lwt.Infix.op_gt_gt_eq
          match rules with
          | None => Lwt.return_unit
          | Some rules => try
          end
          (fun function_parameter =>
            match function_parameter with
            | tt => init (Some (template cfg)) (output cfg)
            end)
      end
    end.
src/lib_stdlib_unix/lwt_log_sink_unix.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Output : sig
  type t =
    | Null
    | Stdout
    | Stderr
    | File of string
    | Syslog of Lwt_log.syslog_facility

  val encoding : t Data_encoding.t

  val of_string : string -> t option

  val to_string : t -> string

  val pp : Format.formatter -> t -> unit
end

type cfg = {
  output : Output.t;
  default_level : Internal_event.level;
  rules : string option;
  template : Lwt_log_core.template;
}

val default_cfg : cfg

val create_cfg :
  ?output:Output.t ->
  ?default_level:Internal_event.level ->
  ?rules:string ->
  ?template:Lwt_log_core.template ->
  unit ->
  cfg

val cfg_encoding : cfg Data_encoding.t

(** Configure the event-logging sink defined in
    {!Internal_event.Lwt_log_sink} by merging the contents of [?cfg]
    (default: {!default_cfg}) and the value of the ["TEZOS_LOG"]
    environment variable. *)
val initialize : ?cfg:cfg -> unit -> unit Lwt.t
src/lib_stdlib_unix/lwt_log_sink_unix.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Output.
  Inductive t : Type :=
  | Null : t
  | Stdout : t
  | Stderr : t
  | File : string -> t
  | Syslog : Lwt_log.syslog_facility -> t.
  
  Parameter encoding : Tezos_data_encoding.Data_encoding.t t.
  
  Parameter of_string : string -> option t.
  
  Parameter to_string : t -> string.
  
  Parameter pp : Stdlib.Format.formatter -> t -> unit.
End Output.

Record cfg := {
  output : Output.t;
  default_level : Tezos_event_logging.Internal_event.level;
  rules : option string;
  template : Lwt_log_core.template }.

Parameter default_cfg : cfg.

Parameter create_cfg :
(option Output.t) ->
  (option Tezos_event_logging.Internal_event.level) ->
    (option string) -> (option Lwt_log_core.template) -> unit -> cfg.

Parameter cfg_encoding : Tezos_data_encoding.Data_encoding.t cfg.

Parameter initialize : (option cfg) -> unit -> Lwt.t unit.
src/lib_stdlib_unix/lwt_utils_unix.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

let () =
  register_error_kind
    `Temporary
    ~id:"unix_error"
    ~title:"Unix error"
    ~description:"An unhandled unix exception"
    ~pp:Format.pp_print_string
    Data_encoding.(obj1 (req "msg" string))
    (function
      | Exn (Unix.Unix_error (err, fn, _)) ->
          Some ("Unix error in " ^ fn ^ ": " ^ Unix.error_message err)
      | _ ->
          None)
    (fun msg -> Exn (Failure msg))

let read_bytes ?(pos = 0) ?len fd buf =
  let len = match len with None -> Bytes.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.read fd buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_read ->
          inner (pos + nb_read) (len - nb_read)
  in
  inner pos len

let read_string ~len fd =
  let b = Bytes.create len in
  read_bytes fd b >>= fun () -> Lwt.return @@ Bytes.to_string b

let read_mbytes ?(pos = 0) ?len fd buf =
  let len = match len with None -> Bytes.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.read fd buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_read ->
          inner (pos + nb_read) (len - nb_read)
  in
  inner pos len

let write_mbytes ?(pos = 0) ?len descr buf =
  let len = match len with None -> Bytes.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.write descr buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_written ->
          inner (pos + nb_written) (len - nb_written)
  in
  inner pos len

let write_bytes ?(pos = 0) ?len descr buf =
  let len = match len with None -> Bytes.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.write descr buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_written ->
          inner (pos + nb_written) (len - nb_written)
  in
  inner pos len

let write_string ?(pos = 0) ?len descr buf =
  let len = match len with None -> String.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.write_string descr buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_written ->
          inner (pos + nb_written) (len - nb_written)
  in
  inner pos len

let ( >>= ) = Lwt.bind

let remove_dir dir =
  let rec remove dir =
    let files = Lwt_unix.files_of_directory dir in
    Lwt_stream.iter_s
      (fun file ->
        if file = "." || file = ".." then Lwt.return_unit
        else
          let file = Filename.concat dir file in
          if Sys.is_directory file then remove file else Lwt_unix.unlink file)
      files
    >>= fun () -> Lwt_unix.rmdir dir
  in
  if Sys.file_exists dir && Sys.is_directory dir then remove dir
  else Lwt.return_unit

let rec create_dir ?(perm = 0o755) dir =
  Lwt_unix.file_exists dir
  >>= function
  | false ->
      create_dir (Filename.dirname dir)
      >>= fun () ->
      Lwt.catch
        (fun () -> Lwt_unix.mkdir dir perm)
        (function
          | Unix.Unix_error (Unix.EEXIST, _, _) ->
              (* This is the case where the directory has been created
                 by another Lwt.t, after the call to Lwt_unix.file_exists. *)
              Lwt.return_unit
          | e ->
              Lwt.fail e)
  | true -> (
      Lwt_unix.stat dir
      >>= function
      | {st_kind = S_DIR; _} ->
          Lwt.return_unit
      | _ ->
          Pervasives.failwith "Not a directory" )

let create_file ?(perm = 0o644) name content =
  Lwt_unix.openfile name Unix.[O_TRUNC; O_CREAT; O_WRONLY] perm
  >>= fun fd ->
  Lwt_unix.write_string fd content 0 (String.length content)
  >>= fun _ -> Lwt_unix.close fd

let read_file fn = Lwt_io.with_file fn ~mode:Input (fun ch -> Lwt_io.read ch)

let safe_close fd =
  Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)

let of_sockaddr = function
  | Unix.ADDR_UNIX _ ->
      None
  | Unix.ADDR_INET (addr, port) -> (
    match Ipaddr_unix.of_inet_addr addr with
    | V4 addr ->
        Some (Ipaddr.v6_of_v4 addr, port)
    | V6 addr ->
        Some (addr, port) )

let getaddrinfo ~passive ~node ~service =
  let open Lwt_unix in
  getaddrinfo
    node
    service
    (AI_SOCKTYPE SOCK_STREAM :: (if passive then [AI_PASSIVE] else []))
  >>= fun addr ->
  let points =
    TzList.filter_map (fun {ai_addr; _} -> of_sockaddr ai_addr) addr
  in
  Lwt.return points

let getpass () =
  let open Unix in
  (* Turn echoing off and fail if we can't. *)
  let tio = tcgetattr stdin in
  let old_echo = tio.c_echo in
  let old_echonl = tio.c_echonl in
  tio.c_echo <- false ;
  tio.c_echonl <- true ;
  tcsetattr stdin TCSAFLUSH tio ;
  (* Read the passwd. *)
  let passwd = read_line () in
  (* Restore terminal. *)
  tio.c_echo <- old_echo ;
  tio.c_echonl <- old_echonl ;
  tcsetattr stdin TCSAFLUSH tio ;
  passwd

module Json = struct
  let to_root = function
    | `O ctns ->
        `O ctns
    | `A ctns ->
        `A ctns
    | `Null ->
        `O []
    | oth ->
        `A [oth]

  let write_file file json =
    let json = to_root json in
    protect (fun () ->
        Lwt_io.with_file ~mode:Output file (fun chan ->
            let str = Data_encoding.Json.to_string ~minify:false json in
            Lwt_io.write chan str >>= fun _ -> return_unit))

  let read_file file =
    protect (fun () ->
        Lwt_io.with_file ~mode:Input file (fun chan ->
            Lwt_io.read chan
            >>= fun str ->
            return (Ezjsonm.from_string str :> Data_encoding.json)))
end

let with_tempdir name f =
  let base_dir = Filename.temp_file name "" in
  Lwt_unix.unlink base_dir
  >>= fun () ->
  Lwt_unix.mkdir base_dir 0o700
  >>= fun () ->
  Lwt.finalize (fun () -> f base_dir) (fun () -> remove_dir base_dir)

module Socket = struct
  type addr =
    | Unix of string
    | Tcp of string * string * Unix.getaddrinfo_option list

  let handle_litteral_ipv6 host =
    (* To strip '[' and ']' when a litteral IPv6 is provided *)
    match Ipaddr.of_string host with
    | Error (`Msg _) ->
        host
    | Ok ipaddr ->
        Ipaddr.to_string ipaddr

  let connect ?(timeout = 5.) = function
    | Unix path ->
        let addr = Lwt_unix.ADDR_UNIX path in
        let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
        Lwt_unix.connect sock addr >>= fun () -> return sock
    | Tcp (host, service, opts) -> (
        let host = handle_litteral_ipv6 host in
        Lwt_unix.getaddrinfo host service opts
        >>= function
        | [] ->
            failwith "could not resolve host '%s'" host
        | addrs ->
            let rec try_connect acc = function
              | [] ->
                  Lwt.return
                    (Error
                       ( failure "could not connect to '%s'" host
                       :: List.rev acc ))
              | {Unix.ai_family; ai_socktype; ai_protocol; ai_addr; _} :: addrs
                -> (
                  let sock =
                    Lwt_unix.socket ai_family ai_socktype ai_protocol
                  in
                  protect
                    ~on_error:(fun e ->
                      Lwt_unix.close sock >>= fun () -> Lwt.return_error e)
                    (fun () ->
                      with_timeout (Lwt_unix.sleep timeout) (fun _c ->
                          Lwt_unix.connect sock ai_addr
                          >>= fun () -> return sock))
                  >>= function
                  | Ok sock ->
                      return sock
                  | Error e ->
                      try_connect (e @ acc) addrs )
            in
            try_connect [] addrs )

  let bind ?(backlog = 10) = function
    | Unix path ->
        let addr = Lwt_unix.ADDR_UNIX path in
        let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
        Lwt_unix.bind sock addr
        >>= fun () ->
        Lwt_unix.listen sock backlog ;
        return [sock]
    | Tcp (host, service, opts) -> (
        Lwt_unix.getaddrinfo
          (handle_litteral_ipv6 host)
          service
          (AI_PASSIVE :: opts)
        >>= function
        | [] ->
            failwith "could not resolve host '%s'" host
        | addrs ->
            let do_bind {Unix.ai_family; ai_socktype; ai_protocol; ai_addr; _}
                =
              let sock = Lwt_unix.socket ai_family ai_socktype ai_protocol in
              Lwt_unix.setsockopt sock SO_REUSEADDR true ;
              Lwt_unix.bind sock ai_addr
              >>= fun () ->
              Lwt_unix.listen sock backlog ;
              return sock
            in
            map_s do_bind addrs )

  type error += Encoding_error | Decoding_error

  let () =
    register_error_kind
      `Permanent
      ~id:"signer.encoding_error"
      ~title:"Encoding_error"
      ~description:"Error while encoding a remote signer message"
      ~pp:(fun ppf () ->
        Format.fprintf ppf "Could not encode a remote signer message")
      Data_encoding.empty
      (function Encoding_error -> Some () | _ -> None)
      (fun () -> Encoding_error) ;
    register_error_kind
      `Permanent
      ~id:"signer.decoding_error"
      ~title:"Decoding_error"
      ~description:"Error while decoding a remote signer message"
      ~pp:(fun ppf () ->
        Format.fprintf ppf "Could not decode a remote signer message")
      Data_encoding.empty
      (function Decoding_error -> Some () | _ -> None)
      (fun () -> Decoding_error)

  let message_len_size = 2

  let send fd encoding message =
    let encoded_message_len = Data_encoding.Binary.length encoding message in
    fail_unless
      (encoded_message_len < 1 lsl (message_len_size * 8))
      Encoding_error
    >>=? fun () ->
    (* len is the length of int16 plus the length of the message we want to send *)
    let len = message_len_size + encoded_message_len in
    let buf = Bytes.create len in
    match
      Data_encoding.Binary.write
        encoding
        message
        buf
        message_len_size
        encoded_message_len
    with
    | None ->
        fail Encoding_error
    | Some last ->
        fail_unless (last = len) Encoding_error
        >>=? fun () ->
        (* we set the beginning of the buf with the length of what is next *)
        TzEndian.set_int16 buf 0 encoded_message_len ;
        write_mbytes fd buf >>= fun () -> return_unit

  let recv fd encoding =
    let header_buf = Bytes.create message_len_size in
    read_mbytes ~len:message_len_size fd header_buf
    >>= fun () ->
    let len = TzEndian.get_uint16 header_buf 0 in
    let buf = Bytes.create len in
    read_mbytes ~len fd buf
    >>= fun () ->
    match Data_encoding.Binary.read encoding buf 0 len with
    | None ->
        fail Decoding_error
    | Some (read_len, message) ->
        if read_len <> len then fail Decoding_error else return message
end

let rec retry ?(log = fun _ -> Lwt.return_unit) ?(n = 5) ?(sleep = 1.) f =
  f ()
  >>= function
  | Ok r ->
      Lwt.return_ok r
  | Error error as x ->
      if n > 0 then
        log error
        >>= fun () ->
        Lwt_unix.sleep sleep >>= fun () -> retry ~log ~n:(n - 1) ~sleep f
      else Lwt.return x
src/lib_stdlib_unix/lwt_utils_unix.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_error_monad.Error_monad.

Definition read_bytes (op_star_o_p_t_star : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun len =>
    fun fd =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            Tezos_error_monad.Error_monad.op_gt_gt_eq
              (Lwt_unix.read fd buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_read => inner (Z.add pos nb_read) (Z.sub len nb_read)
                end) in
        inner pos len.

Definition read_string (len : Z) (fd : Lwt_unix.file_descr) : Lwt.t string :=
  let b := Stdlib.Bytes.create len in
  Tezos_error_monad.Error_monad.op_gt_gt_eq (read_bytes None None fd b)
    (fun function_parameter =>
      match function_parameter with
      | tt => apply Lwt._return (Stdlib.Bytes.to_string b)
      end).

Definition read_mbytes (op_star_o_p_t_star : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun len =>
    fun fd =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            Tezos_error_monad.Error_monad.op_gt_gt_eq
              (Lwt_unix.read fd buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_read => inner (Z.add pos nb_read) (Z.sub len nb_read)
                end) in
        inner pos len.

Definition write_mbytes (op_star_o_p_t_star : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun len =>
    fun descr =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            Tezos_error_monad.Error_monad.op_gt_gt_eq
              (Lwt_unix.write descr buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_written =>
                  inner (Z.add pos nb_written) (Z.sub len nb_written)
                end) in
        inner pos len.

Definition write_bytes (op_star_o_p_t_star : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun len =>
    fun descr =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            Tezos_error_monad.Error_monad.op_gt_gt_eq
              (Lwt_unix.write descr buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_written =>
                  inner (Z.add pos nb_written) (Z.sub len nb_written)
                end) in
        inner pos len.

Definition write_string (op_star_o_p_t_star : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun len =>
    fun descr =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (OCaml.String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            Tezos_error_monad.Error_monad.op_gt_gt_eq
              (Lwt_unix.write_string descr buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_written =>
                  inner (Z.add pos nb_written) (Z.sub len nb_written)
                end) in
        inner pos len.

Definition op_gt_gt_eq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.bind.

Definition remove_dir (dir : string) : Lwt.t unit :=
  let fix remove (dir : string) : Lwt.t unit :=
    let files := Lwt_unix.files_of_directory dir in
    op_gt_gt_eq
      (Lwt_stream.iter_s
        (fun file =>
          if orb (equiv_decb file "." % string) (equiv_decb file ".." % string)
            then
            Lwt.return_unit
          else
            let file := Stdlib.Filename.concat dir file in
            if Stdlib.Sys.is_directory file then
              remove file
            else
              Lwt_unix.unlink file) files)
      (fun function_parameter =>
        match function_parameter with
        | tt => Lwt_unix.rmdir dir
        end) in
  if andb (Stdlib.Sys.file_exists dir) (Stdlib.Sys.is_directory dir) then
    remove dir
  else
    Lwt.return_unit.

Fixpoint create_dir (op_star_o_p_t_star : option Z) : string -> Lwt.t unit :=
  let perm :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 493
    end in
  fun dir =>
    op_gt_gt_eq (Lwt_unix.file_exists dir)
      (fun function_parameter =>
        match function_parameter with
        | false =>
          op_gt_gt_eq (create_dir None (Stdlib.Filename.dirname dir))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Lwt.catch
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Lwt_unix.mkdir dir perm
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | Unix.Unix_error Unix.EEXIST _ _ => Lwt.return_unit
                    | e => Lwt.fail e
                    end)
              end)
        | true =>
          op_gt_gt_eq (Lwt_unix.stat dir)
            (fun function_parameter =>
              match function_parameter with
              | {| st_kind := S_DIR |} => Lwt.return_unit
              | _ => Stdlib.Pervasives.failwith "Not a directory" % string
              end)
        end).

Definition create_file (op_star_o_p_t_star : option Lwt_unix.file_perm)
  : string -> string -> Lwt.t unit :=
  let perm :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 420
    end in
  fun name =>
    fun content =>
      op_gt_gt_eq
        (Lwt_unix.openfile name (cons O_TRUNC (cons O_CREAT (cons O_WRONLY [])))
          perm)
        (fun fd =>
          op_gt_gt_eq
            (Lwt_unix.write_string fd content 0 (OCaml.String.length content))
            (fun function_parameter =>
              match function_parameter with
              | _ => Lwt_unix.close fd
              end)).

Definition read_file (fn : Lwt_io.file_name) : Lwt.t string :=
  Lwt_io.with_file None None None Input fn (fun ch => Lwt_io.read None ch).

Definition safe_close (fd : Lwt_unix.file_descr) : Lwt.t unit :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt => Lwt_unix.close fd
      end)
    (fun function_parameter =>
      match function_parameter with
      | _ => Lwt.return_unit
      end).

Definition of_sockaddr (function_parameter : Unix.sockaddr)
  : option (Ipaddr.V6.t * Z) :=
  match function_parameter with
  | Unix.ADDR_UNIX _ => None
  | Unix.ADDR_INET addr port =>
    match Ipaddr_unix.of_inet_addr addr with
    | V4 addr => Some ((Ipaddr.v6_of_v4 addr), port)
    | V6 addr => Some (addr, port)
    end
  end.

Definition getaddrinfo (passive : bool) (node : string) (service : string)
  : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  op_gt_gt_eq
    (Lwt_unix.getaddrinfo node service
      (cons (AI_SOCKTYPE SOCK_STREAM)
        (if passive then
          cons AI_PASSIVE []
        else
          [])))
    (fun addr =>
      let points :=
        Tezos_stdlib.TzList.filter_map
          (fun function_parameter =>
            match function_parameter with
            | {| ai_addr := ai_addr |} => of_sockaddr ai_addr
            end) addr in
      Lwt._return points).

Definition getpass (function_parameter : unit) : string :=
  match function_parameter with
  | tt =>
    let tio := Unix.tcgetattr Unix.stdin in
    let old_echo := c_echo tio in
    let old_echonl := c_echonl tio in
    set_field;
    set_field;
    Unix.tcsetattr Unix.stdin TCSAFLUSH tio;
    let passwd := OCaml.Stdlib.read_line tt in
    set_field;
    set_field;
    Unix.tcsetattr Unix.stdin TCSAFLUSH tio;
    passwd
  end.

Module Json.
  Definition to_root (function_parameter : variant) : variant :=
    match function_parameter with
    | O ctns => variant
    | A ctns => variant
    | Null => variant
    | oth => variant
    end.
  
  Definition write_file (file : Lwt_io.file_name) (json : variant)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let json := to_root json in
    Tezos_error_monad.Error_monad.protect None None
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Lwt_io.with_file None None None Output file
            (fun chan =>
              let str :=
                Tezos_data_encoding.Data_encoding.Json.to_string None
                  (Some false) json in
              op_gt_gt_eq (Lwt_io.write chan str)
                (fun function_parameter =>
                  match function_parameter with
                  | _ => Tezos_error_monad.Error_monad.return_unit
                  end))
        end).
  
  Definition read_file (file : Lwt_io.file_name)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_data_encoding.Data_encoding.json) :=
    Tezos_error_monad.Error_monad.protect None None
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Lwt_io.with_file None None None Input file
            (fun chan =>
              op_gt_gt_eq (Lwt_io.read None chan)
                (fun str =>
                  Tezos_error_monad.Error_monad._return
                    (Ezjsonm.from_string str)))
        end).
End Json.

Definition with_tempdir {A : Type} (name : string) (f : string -> Lwt.t A)
  : Lwt.t A :=
  let base_dir := Stdlib.Filename.temp_file None name "" % string in
  op_gt_gt_eq (Lwt_unix.unlink base_dir)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        op_gt_gt_eq (Lwt_unix.mkdir base_dir 448)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Lwt.finalize
                (fun function_parameter =>
                  match function_parameter with
                  | tt => f base_dir
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => remove_dir base_dir
                  end)
            end)
      end).

Module Socket.
  Inductive addr : Type :=
  | Unix : string -> addr
  | Tcp : string -> string -> (list Unix.getaddrinfo_option) -> addr.
  
  Definition handle_litteral_ipv6 (host : string) : string :=
    match Ipaddr.of_string host with
    | inr (Msg _) => host
    | inl ipaddr => Ipaddr.to_string ipaddr
    end.
  
  Definition connect (op_star_o_p_t_star : option float)
    : addr -> Lwt.t (Tezos_error_monad.Error_monad.tzresult Lwt_unix.file_descr) :=
    let timeout :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => 5
      end in
    fun function_parameter =>
      match function_parameter with
      | Unix path =>
        let addr := Lwt_unix.ADDR_UNIX path in
        let sock := Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
        op_gt_gt_eq (Lwt_unix.connect sock addr)
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_error_monad.Error_monad._return sock
            end)
      | Tcp host service opts =>
        let host := handle_litteral_ipv6 host in
        op_gt_gt_eq (Lwt_unix.getaddrinfo host service opts)
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              Tezos_error_monad.Error_monad.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "could not resolve host '" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "'" % char
                        CamlinternalFormatBasics.End_of_format)))
                  "could not resolve host '%s'" % string) host
            | addrs =>
              let fix try_connect
                (acc : list Tezos_error_monad.Error_monad.error)
                (function_parameter : list Unix.addr_info)
                : Lwt.t
                  (sum Lwt_unix.file_descr
                    (list Tezos_error_monad.Error_monad.error)) :=
                match function_parameter with
                | [] =>
                  Lwt._return
                    (inr
                      (cons
                        (Tezos_error_monad.Error_monad.failure
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "could not connect to '" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Char_literal
                                  "'" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "could not connect to '%s'" % string) host)
                        (List.rev acc)))
                |
                  cons {|
                    Unix.ai_family := ai_family;
                      Unix.ai_socktype := ai_socktype;
                      Unix.ai_protocol := ai_protocol;
                      Unix.ai_addr := ai_addr
                      |} addrs =>
                  let sock := Lwt_unix.socket ai_family ai_socktype ai_protocol
                    in
                  op_gt_gt_eq
                    (Tezos_error_monad.Error_monad.protect
                      (Some
                        (fun e =>
                          op_gt_gt_eq (Lwt_unix.close sock)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Lwt.return_error e
                              end))) None
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_error_monad.Error_monad.with_timeout None
                            (Lwt_unix.sleep timeout)
                            (fun _c =>
                              op_gt_gt_eq (Lwt_unix.connect sock ai_addr)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_error_monad.Error_monad._return sock
                                  end))
                        end))
                    (fun function_parameter =>
                      match function_parameter with
                      | inl sock => Tezos_error_monad.Error_monad._return sock
                      | inr e => try_connect (OCaml.Stdlib.app e acc) addrs
                      end)
                end in
              try_connect [] addrs
            end)
      end.
  
  Definition bind (op_star_o_p_t_star : option Z)
    : addr ->
      Lwt.t (Tezos_error_monad.Error_monad.tzresult (list Lwt_unix.file_descr)) :=
    let backlog :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => 10
      end in
    fun function_parameter =>
      match function_parameter with
      | Unix path =>
        let addr := Lwt_unix.ADDR_UNIX path in
        let sock := Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
        op_gt_gt_eq (Lwt_unix.bind sock addr)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Lwt_unix.listen sock backlog;
              Tezos_error_monad.Error_monad._return (cons sock [])
            end)
      | Tcp host service opts =>
        op_gt_gt_eq
          (Lwt_unix.getaddrinfo (handle_litteral_ipv6 host) service
            (cons AI_PASSIVE opts))
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              Tezos_error_monad.Error_monad.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "could not resolve host '" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "'" % char
                        CamlinternalFormatBasics.End_of_format)))
                  "could not resolve host '%s'" % string) host
            | addrs =>
              let do_bind (function_parameter : Unix.addr_info)
                : Lwt.t
                  (Tezos_error_monad.Error_monad.tzresult Lwt_unix.file_descr) :=
                match function_parameter with
                | {|
                  Unix.ai_family := ai_family;
                    Unix.ai_socktype := ai_socktype;
                    Unix.ai_protocol := ai_protocol;
                    Unix.ai_addr := ai_addr
                    |} =>
                  let sock := Lwt_unix.socket ai_family ai_socktype ai_protocol
                    in
                  Lwt_unix.setsockopt sock SO_REUSEADDR true;
                  op_gt_gt_eq (Lwt_unix.bind sock ai_addr)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Lwt_unix.listen sock backlog;
                        Tezos_error_monad.Error_monad._return sock
                      end)
                end in
              Tezos_error_monad.Error_monad.map_s do_bind addrs
            end)
      end.
  
  Definition message_len_size : Z := 2.
  
  Definition send {A : Type}
    (fd : Lwt_unix.file_descr)
    (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) (message : A)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let encoded_message_len :=
      Tezos_data_encoding.Data_encoding.Binary.length encoding message in
    Tezos_error_monad.Error_monad.op_gt_gt_eq_question
      (Tezos_error_monad.Error_monad.fail_unless
        (OCaml.Stdlib.lt encoded_message_len
          (Z.shiftl 1 (Z.mul message_len_size 8))) Encoding_error)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let len := Z.add message_len_size encoded_message_len in
          let buf := Stdlib.Bytes.create len in
          match
            Tezos_data_encoding.Data_encoding.Binary.write encoding message buf
              message_len_size encoded_message_len with
          | None => Tezos_error_monad.Error_monad.fail Encoding_error
          | Some last =>
            Tezos_error_monad.Error_monad.op_gt_gt_eq_question
              (Tezos_error_monad.Error_monad.fail_unless (equiv_decb last len)
                Encoding_error)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_data_encoding.TzEndian.set_int16 buf 0
                    encoded_message_len;
                  op_gt_gt_eq (write_mbytes None None fd buf)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_error_monad.Error_monad.return_unit
                      end)
                end)
          end
        end).
  
  Definition recv {A : Type}
    (fd : Lwt_unix.file_descr)
    (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
    let header_buf := Stdlib.Bytes.create message_len_size in
    op_gt_gt_eq (read_mbytes None (Some message_len_size) fd header_buf)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let len := Tezos_data_encoding.TzEndian.get_uint16 header_buf 0 in
          let buf := Stdlib.Bytes.create len in
          op_gt_gt_eq (read_mbytes None (Some len) fd buf)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                match
                  Tezos_data_encoding.Data_encoding.Binary.read encoding buf 0
                    len with
                | None => Tezos_error_monad.Error_monad.fail Decoding_error
                | Some (read_len, message) =>
                  if nequiv_decb read_len len then
                    Tezos_error_monad.Error_monad.fail Decoding_error
                  else
                    Tezos_error_monad.Error_monad._return message
                end
              end)
        end).
End Socket.

Fixpoint retry {A B : Type} (op_star_o_p_t_star : option (A -> Lwt.t unit))
  : (option Z) ->
    (option float) -> (unit -> Lwt.t (sum B A)) -> Lwt.t (Result.result B A) :=
  let log :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None =>
      fun function_parameter =>
        match function_parameter with
        | _ => Lwt.return_unit
        end
    end in
  fun op_star_o_p_t_star =>
    let n :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => 5
      end in
    fun op_star_o_p_t_star =>
      let sleep :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => 1
        end in
      fun f =>
        op_gt_gt_eq (f tt)
          (fun function_parameter =>
            match function_parameter with
            | inl r => Lwt.return_ok r
            | (inr error) as x =>
              if OCaml.Stdlib.gt n 0 then
                op_gt_gt_eq (log error)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_gt_gt_eq (Lwt_unix.sleep sleep)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            retry (Some log) (Some (Z.sub n 1)) (Some sleep) f
                          end)
                    end)
              else
                Lwt._return x
            end).
src/lib_stdlib_unix/lwt_utils_unix.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

val read_string : len:int -> Lwt_unix.file_descr -> string Lwt.t

val read_bytes :
  ?pos:int -> ?len:int -> Lwt_unix.file_descr -> bytes -> unit Lwt.t

val read_mbytes :
  ?pos:int -> ?len:int -> Lwt_unix.file_descr -> Bytes.t -> unit Lwt.t

val write_string :
  ?pos:int -> ?len:int -> Lwt_unix.file_descr -> string -> unit Lwt.t

val write_bytes :
  ?pos:int -> ?len:int -> Lwt_unix.file_descr -> bytes -> unit Lwt.t

val write_mbytes :
  ?pos:int -> ?len:int -> Lwt_unix.file_descr -> Bytes.t -> unit Lwt.t

val remove_dir : string -> unit Lwt.t

val create_dir : ?perm:int -> string -> unit Lwt.t

val read_file : string -> string Lwt.t

val create_file : ?perm:int -> string -> string -> unit Lwt.t

val with_tempdir : string -> (string -> 'a Lwt.t) -> 'a Lwt.t

val safe_close : Lwt_unix.file_descr -> unit Lwt.t

val getaddrinfo :
  passive:bool ->
  node:string ->
  service:string ->
  (Ipaddr.V6.t * int) list Lwt.t

(** [getpass ()] reads a password from stdio while setting-up the
    terminal to not display the password being typed. *)
val getpass : unit -> string

module Json : sig
  (** Loads a JSON file in memory *)
  val read_file : string -> Data_encoding.json tzresult Lwt.t

  (** (Over)write a JSON file from in memory data *)
  val write_file : string -> Data_encoding.json -> unit tzresult Lwt.t
end

module Socket : sig
  type addr =
    | Unix of string
    | Tcp of string * string * Unix.getaddrinfo_option list

  (** [connect ?timeout addr] tries connecting to [addr] and returns
      the resulting socket file descriptor on success. When using TCP,
      [Unix.getaddrinfo] is used to resolve the hostname and service
      (port). The different socket addresses returned by
      [Unix.getaddrinfo] are tried sequentially, and the [?timeout]
      argument (default: 5s) governs how long it waits to get a
      connection. If a connection is not obtained in less than
      [?timeout], the connection is canceled and and the next socket
      address (if it exists) is tried. *)
  val connect : ?timeout:float -> addr -> Lwt_unix.file_descr tzresult Lwt.t

  val bind : ?backlog:int -> addr -> Lwt_unix.file_descr list tzresult Lwt.t

  type error += Encoding_error | Decoding_error

  val send :
    Lwt_unix.file_descr -> 'a Data_encoding.t -> 'a -> unit tzresult Lwt.t

  val recv : Lwt_unix.file_descr -> 'a Data_encoding.t -> 'a tzresult Lwt.t
end

val retry :
  ?log:('error -> unit Lwt.t) ->
  ?n:int ->
  ?sleep:float ->
  (unit -> ('a, 'error) result Lwt.t) ->
  ('a, 'error) result Lwt.t
src/lib_stdlib_unix/lwt_utils_unix.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter read_string : Z -> Lwt_unix.file_descr -> Lwt.t string.

Parameter read_bytes :
(option Z) -> (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit.

Parameter read_mbytes :
(option Z) -> (option Z) -> Lwt_unix.file_descr -> Stdlib.Bytes.t -> Lwt.t unit.

Parameter write_string :
(option Z) -> (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit.

Parameter write_bytes :
(option Z) -> (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit.

Parameter write_mbytes :
(option Z) -> (option Z) -> Lwt_unix.file_descr -> Stdlib.Bytes.t -> Lwt.t unit.

Parameter remove_dir : string -> Lwt.t unit.

Parameter create_dir : (option Z) -> string -> Lwt.t unit.

Parameter read_file : string -> Lwt.t string.

Parameter create_file : (option Z) -> string -> string -> Lwt.t unit.

Parameter with_tempdir : forall {a : Type},
string -> (string -> Lwt.t a) -> Lwt.t a.

Parameter safe_close : Lwt_unix.file_descr -> Lwt.t unit.

Parameter getaddrinfo :
bool -> string -> string -> Lwt.t (list (Ipaddr.V6.t * Z)).

Parameter getpass : unit -> string.

Module Json.
  Parameter read_file : string ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_data_encoding.Data_encoding.json).
  
  Parameter write_file : string ->
    Tezos_data_encoding.Data_encoding.json ->
      Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).
End Json.

Module Socket.
  Inductive addr : Type :=
  | Unix : string -> addr
  | Tcp : string -> string -> (list Unix.getaddrinfo_option) -> addr.
  
  Parameter connect : (option float) ->
    addr -> Lwt.t (Tezos_error_monad.Error_monad.tzresult Lwt_unix.file_descr).
  
  Parameter bind : (option Z) ->
    addr ->
      Lwt.t (Tezos_error_monad.Error_monad.tzresult (list Lwt_unix.file_descr)).
  
  extensible_type
  
  Parameter send : forall {a : Type}, Lwt_unix.file_descr ->
    (Tezos_data_encoding.Data_encoding.t a) ->
      a -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit).
  
  Parameter recv : forall {a : Type}, Lwt_unix.file_descr ->
    (Tezos_data_encoding.Data_encoding.t a) ->
      Lwt.t (Tezos_error_monad.Error_monad.tzresult a).
End Socket.

Parameter retry : forall {a error : Type},
(option (error -> Lwt.t unit)) ->
  (option Z) ->
    (option float) -> (unit -> Lwt.t (sum a error)) -> Lwt.t (sum a error).
src/lib_stdlib_unix/moving_average.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

module Inttbl = Hashtbl.Make (struct
  type t = int

  let equal (x : int) (y : int) = x = y

  let hash = Hashtbl.hash
end)

type t = {
  id : int;
  alpha : int;
  mutable total : int64;
  mutable current : int;
  mutable average : int;
}

let counters = Inttbl.create 51

let updated = Lwt_condition.create ()

let update_hook = ref []

let on_update f = update_hook := f :: !update_hook

let worker_loop () =
  let prev = ref @@ Mtime_clock.elapsed () in
  let rec inner sleep =
    sleep
    >>= fun () ->
    let sleep = Lwt_unix.sleep 1. in
    let now = Mtime_clock.elapsed () in
    let elapsed = int_of_float Mtime.Span.(to_ms now -. to_ms !prev) in
    prev := now ;
    Inttbl.iter
      (fun _ c ->
        c.average <-
          (c.alpha * c.current / elapsed)
          + ((1000 - c.alpha) * c.average / 1000) ;
        c.current <- 0)
      counters ;
    List.iter (fun f -> f ()) !update_hook ;
    Lwt_condition.broadcast updated () ;
    inner sleep
  in
  inner (Lwt_unix.sleep 1.)

let worker =
  lazy
    (Lwt.async (fun () ->
         Lwt_utils.worker
           "counter"
           ~on_event:Internal_event.Lwt_worker_event.on_event
           ~run:worker_loop
           ~cancel:(fun _ -> Lwt.return_unit)))

let create =
  let cpt = ref 0 in
  fun ~init ~alpha ->
    Lazy.force worker ;
    let id = !cpt in
    incr cpt ;
    assert (0. < alpha && alpha <= 1.) ;
    let alpha = int_of_float (1000. *. alpha) in
    let c = {id; alpha; total = 0L; current = 0; average = init} in
    Inttbl.add counters id c ; c

let add c x =
  c.total <- Int64.(add c.total (of_int x)) ;
  c.current <- c.current + x

let destroy c = Inttbl.remove counters c.id

type stat = {total : int64; average : int}

let stat ({total; average; _} : t) : stat = {total; average}
src/lib_stdlib_unix/moving_average.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Record t := {
  id : Z;
  alpha : Z;
  total : int64;
  current : Z;
  average : Z }.

Definition counters : Inttbl.t t := Inttbl.create 51.

Definition updated : Lwt_condition.t unit := Lwt_condition.create tt.

Definition update_hook : Stdlib.ref (list (unit -> unit)) := Stdlib.ref [].

Definition on_update (f : unit -> unit) : unit :=
  Stdlib.op_colon_eq update_hook (cons f (Stdlib.op_exclamation update_hook)).

Definition worker_loop {A : Type} (function_parameter : unit) : Lwt.t A :=
  match function_parameter with
  | tt =>
    let prev := apply Stdlib.ref (Mtime_clock.elapsed tt) in
    let fix inner {B : Type} (sleep : Lwt.t unit) : Lwt.t B :=
      Lwt.Infix.op_gt_gt_eq sleep
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let sleep := Lwt_unix.sleep 1 in
            let now := Mtime_clock.elapsed tt in
            let elapsed :=
              Stdlib.int_of_float
                (Stdlib.op_minus_point (Mtime.Span.to_ms now)
                  (Mtime.Span.to_ms (Stdlib.op_exclamation prev))) in
            Stdlib.op_colon_eq prev now;
            Inttbl.iter
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  fun c =>
                    set_field;
                    set_field
                end) counters;
            Stdlib.List.iter (fun f => f tt) (Stdlib.op_exclamation update_hook);
            Lwt_condition.broadcast updated tt;
            inner sleep
          end) in
    inner (Lwt_unix.sleep 1)
  end.

Definition worker : lazy_t unit :=
  Lwt.async
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_stdlib.Lwt_utils.worker "counter" % string
          Tezos_event_logging.Internal_event.Lwt_worker_event.on_event
          worker_loop
          (fun function_parameter =>
            match function_parameter with
            | _ => Lwt.return_unit
            end)
      end).

Definition create : Z -> float -> t :=
  let cpt := Stdlib.ref 0 in
  fun init =>
    fun alpha =>
      Stdlib.Lazy.force worker;
      let id := Stdlib.op_exclamation cpt in
      Stdlib.incr cpt;
      andb (OCaml.Stdlib.lt 0 alpha) (OCaml.Stdlib.le alpha 1);
      let alpha := Stdlib.int_of_float (Stdlib.op_star_point 1000 alpha) in
      let c :=
        {| id := id; alpha := alpha; total := 0; current := 0; average := init
          |} in
      Inttbl.add counters id c;
      c.

Definition add (c : t) (x : Z) : unit :=
  set_field;
  set_field.

Definition destroy (c : t) : unit := Inttbl.remove counters (id c).

Record stat := {
  total : int64;
  average : Z }.

Definition stat (function_parameter : t) : stat :=
  match function_parameter with
  | {| total := total; average := average |} =>
    {| total := total; average := average |}
  end.
src/lib_stdlib_unix/moving_average.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Moving averages.

    This module implements bandwidth counters based on (cumulative)
    exponential moving average. Each counter is identified by an
    integer. They are stored in an internal hash table.

    See i.e.
    https://en.wikipedia.org/wiki/Moving_average#Exponential_moving_average
    for the algorithm.
*)

(** Type of one bandwidth counter. *)
type t

(** [create ~init ~alpha] is a counter with initial value [init] and
    factor [alpha]. *)
val create : init:int -> alpha:float -> t

(** [destroy t] removes counter [t] from the internal hash table. *)
val destroy : t -> unit

(** [add t id] adds [t] in the internal hash table under identifies
    [id]. *)
val add : t -> int -> unit

(** [of_update f] registers [f] to be called on each update of the
    internal worker (currently every 1s). *)
val on_update : (unit -> unit) -> unit

(** [updated] is a condition variable that gets signaled on each
    update of the internal worker (currently every 1s). *)
val updated : unit Lwt_condition.t

type stat = {total : int64; average : int}

(** [stat t] is a stat record reflecting the state of [t] at the time
    of the call. *)
val stat : t -> stat
src/lib_stdlib_unix/moving_average.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter create : Z -> float -> t.

Parameter destroy : t -> unit.

Parameter add : t -> Z -> unit.

Parameter on_update : (unit -> unit) -> unit.

Parameter updated : Lwt_condition.t unit.

Record stat := {
  total : int64;
  average : Z }.

Parameter stat : t -> stat.
src/lib_stdlib_unix/sys_info.ml 
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Memory
open Error_monad

type Error_monad.error += Unix_system_info_failure of string

let () =
  Error_monad.register_error_kind
    `Temporary
    ~id:"unix.system_info"
    ~title:"Unix System_info failure"
    ~description:"Unix System_info failure"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "@[<v 2>Unix system_info failure %s@]" s)
    Data_encoding.(obj1 (req "failure" string))
    (function Unix_system_info_failure s -> Some s | _ -> None)
    (fun s -> Unix_system_info_failure s)

let error_info process error =
  Unix_system_info_failure
    (Format.asprintf "Unix_system_info_failure (%s: %s)" process error)

type sysname = Linux | Darwin | Unknown of string

let uname =
  Lwt.catch
    (fun () ->
      Lwt_process.with_process_in
        ~env:[|"LC_ALL=C"|]
        ("uname", [|"uname"|])
        (fun pc -> Lwt_io.read_line pc#stdout)
      >>= function
      | "Linux" ->
          Lwt.return_ok Linux
      | "Darwin" ->
          Lwt.return_ok Darwin
      | os ->
          Lwt.return_ok (Unknown os))
    (function
      | exn -> Lwt.return_error (error_info "uname" (Printexc.to_string exn)))

let page_size () =
  let get_conf_process =
    uname
    >>= function
    | Ok Linux ->
        Lwt.return_ok ("getconf", [|"getconf"; "PAGE_SIZE"|])
    | Ok Darwin ->
        Lwt.return_ok ("pagesize", [|"pagesize"|])
    | Ok (Unknown _) ->
        Lwt.return_error (error_info "pagesize" "Unknown unix system")
    | Error (Unix_system_info_failure e) ->
        Lwt.return_error (error_info "pagesize" e)
    | Error e ->
        Lwt.return_error e
  in
  get_conf_process
  >>= function
  | Error e ->
      Lwt.return_error e
  | Ok process ->
      Lwt.catch
        (fun () ->
          Lwt_process.with_process_in process ~env:[|"LC_ALL=C"|] (fun pc ->
              Lwt_io.read_line pc#stdout
              >>= fun ps -> Lwt.return_ok (int_of_string ps)))
        (function
          | exn ->
              Lwt.return_error (error_info "pagesize" (Printexc.to_string exn)))

let linux_statm pid =
  Lwt.catch
    (fun () ->
      let fname = Format.asprintf "/proc/%d/statm" pid in
      Lwt_unix.file_exists fname
      >>= function
      | true ->
          Lwt_io.with_file ~mode:Input fname (fun ic ->
              Lwt_io.read_line ic
              >>= fun line ->
              match List.map Int64.of_string @@ TzString.split ' ' line with
              | size :: resident :: shared :: text :: lib :: data :: dt :: _
                -> (
                  page_size ()
                  >>= function
                  | Error e ->
                      Lwt.return_error e
                  | Ok page_size ->
                      Lwt.return_ok
                        (Statm
                           {
                             page_size;
                             size;
                             resident;
                             shared;
                             text;
                             lib;
                             data;
                             dt;
                           }) )
              | _ ->
                  Lwt.return_error
                    (error_info
                       "procfs statm"
                       "Unexpected proc/<pid>/statm format"))
      | false ->
          Lwt.return_error
            (error_info "procfs statm" (Format.asprintf "%s not found" fname)))
    (function
      | exn ->
          Lwt.return_error (error_info "procfs statm" (Printexc.to_string exn)))

let darwin_ps pid =
  Lwt.catch
    (fun () ->
      Lwt_process.with_process_in
        ~env:[|"LC_ALL=C"|]
        ("ps", [|"ps"; "-o"; "pid,%mem,rss"; "-p"; string_of_int pid|])
        (fun pc ->
          Lwt_io.read_line_opt pc#stdout
          >>= function
          | None ->
              Lwt.return_error
                (error_info "ps" "Unexpected ps answer (1st line)")
          | Some _ -> (
              (* first line is useless *)
              Lwt_io.read_line_opt pc#stdout
              >>= function
              | None ->
                  Lwt.return_error
                    (error_info "ps" "Unexpected ps answer (2nd line)")
              | Some ps_stats -> (
                match TzString.split ' ' ps_stats with
                | _pid :: mem :: resident :: _ -> (
                    page_size ()
                    >>= function
                    | Error e ->
                        Lwt.return_error e
                    | Ok page_size ->
                        Lwt.return_ok
                          (Ps
                             {
                               page_size;
                               mem = float_of_string mem;
                               resident = Int64.of_string resident;
                             }) )
                | _ ->
                    Lwt.return_error (error_info "ps" "Unexpected answer") ) )))
    (function
      | exn -> Lwt.return_error (error_info "ps" (Printexc.to_string exn)))

let memory_stats () =
  let pid = Unix.getpid () in
  uname
  >>= function
  | Error e ->
      Lwt.return_error e
  | Ok Linux ->
      linux_statm pid
  | Ok Darwin ->
      darwin_ps pid
  | _ ->
      Lwt.return_error (error_info "memory_stats" "Unknown unix system")
src/lib_stdlib_unix/sys_info.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_stdlib.Memory.

Import Tezos_error_monad.Error_monad.

Definition error_info (process : string) (error : string)
  : Tezos_error_monad.Error_monad.error :=
  Unix_system_info_failure
    (Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Unix_system_info_failure (" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal ": " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "Unix_system_info_failure (%s: %s)" % string) process error).

Inductive sysname : Type :=
| Linux : sysname
| Darwin : sysname
| Unknown : string -> sysname.

Definition uname
  : Lwt.t (Result.result sysname Tezos_error_monad.Error_monad.error) :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_error_monad.Error_monad.op_gt_gt_eq
          (Lwt_process.with_process_in None (Some ("LC_ALL=C" % string)) None
            None ("uname" % string, ("uname" % string))
            (fun pc => Lwt_io.read_line send))
          (fun function_parameter =>
            match function_parameter with
            | "Linux" % string => Lwt.return_ok Linux
            | "Darwin" % string => Lwt.return_ok Darwin
            | os => Lwt.return_ok (Unknown os)
            end)
      end)
    (fun exn =>
      Lwt.return_error
        (error_info "uname" % string (Stdlib.Printexc.to_string exn))).

Definition page_size (function_parameter : unit)
  : Lwt.t (Result.result Z Tezos_error_monad.Error_monad.error) :=
  match function_parameter with
  | tt =>
    let get_conf_process :=
      Tezos_error_monad.Error_monad.op_gt_gt_eq uname
        (fun function_parameter =>
          match function_parameter with
          | inl Linux =>
            Lwt.return_ok
              ("getconf" % string, ("getconf" % string, "PAGE_SIZE" % string))
          | inl Darwin =>
            Lwt.return_ok ("pagesize" % string, ("pagesize" % string))
          | inl (Unknown _) =>
            Lwt.return_error
              (error_info "pagesize" % string "Unknown unix system" % string)
          | inr (Unix_system_info_failure e) =>
            Lwt.return_error (error_info "pagesize" % string e)
          | inr e => Lwt.return_error e
          end) in
    Tezos_error_monad.Error_monad.op_gt_gt_eq get_conf_process
      (fun function_parameter =>
        match function_parameter with
        | inr e => Lwt.return_error e
        | inl process =>
          Lwt.catch
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Lwt_process.with_process_in None (Some ("LC_ALL=C" % string))
                  None None process
                  (fun pc =>
                    Tezos_error_monad.Error_monad.op_gt_gt_eq
                      (Lwt_io.read_line send)
                      (fun ps => Lwt.return_ok (OCaml.Stdlib.int_of_string ps)))
              end)
            (fun exn =>
              Lwt.return_error
                (error_info "pagesize" % string (Stdlib.Printexc.to_string exn)))
        end)
  end.

Definition linux_statm (pid : Z)
  : Lwt.t
    (Result.result Tezos_stdlib.Memory.mem_stats
      Tezos_error_monad.Error_monad.error) :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let fname :=
          Stdlib.Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "/proc/" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal "/statm" % string
                    CamlinternalFormatBasics.End_of_format)))
              "/proc/%d/statm" % string) pid in
        Tezos_error_monad.Error_monad.op_gt_gt_eq (Lwt_unix.file_exists fname)
          (fun function_parameter =>
            match function_parameter with
            | true =>
              Lwt_io.with_file None None None Input fname
                (fun ic =>
                  Tezos_error_monad.Error_monad.op_gt_gt_eq
                    (Lwt_io.read_line ic)
                    (fun line =>
                      match
                        apply (List.map Stdlib.Int64.of_string)
                          (Tezos_stdlib.TzString.split " " % char None None line)
                        with
                      |
                        cons size
                          (cons resident
                            (cons shared
                              (cons text (cons lib (cons data (cons dt _))))))
                        =>
                        Tezos_error_monad.Error_monad.op_gt_gt_eq (page_size tt)
                          (fun function_parameter =>
                            match function_parameter with
                            | inr e => Lwt.return_error e
                            | inl page_size =>
                              Lwt.return_ok
                                (Statm
                                  {| page_size := page_size; size := size;
                                    resident := resident; shared := shared;
                                    text := text; lib := lib; data := data;
                                    dt := dt |})
                            end)
                      | _ =>
                        Lwt.return_error
                          (error_info "procfs statm" % string
                            "Unexpected proc/<pid>/statm format" % string)
                      end))
            | false =>
              Lwt.return_error
                (error_info "procfs statm" % string
                  (Stdlib.Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          " not found" % string
                          CamlinternalFormatBasics.End_of_format))
                      "%s not found" % string) fname))
            end)
      end)
    (fun exn =>
      Lwt.return_error
        (error_info "procfs statm" % string (Stdlib.Printexc.to_string exn))).

Definition darwin_ps (pid : Z)
  : Lwt.t
    (Result.result Tezos_stdlib.Memory.mem_stats
      Tezos_error_monad.Error_monad.error) :=
  Lwt.catch
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Lwt_process.with_process_in None (Some ("LC_ALL=C" % string)) None None
          ("ps" % string,
            ("ps" % string, "-o" % string, "pid,%mem,rss" % string,
              "-p" % string, (OCaml.Stdlib.string_of_int pid)))
          (fun pc =>
            Tezos_error_monad.Error_monad.op_gt_gt_eq
              (Lwt_io.read_line_opt send)
              (fun function_parameter =>
                match function_parameter with
                | None =>
                  Lwt.return_error
                    (error_info "ps" % string
                      "Unexpected ps answer (1st line)" % string)
                | Some _ =>
                  Tezos_error_monad.Error_monad.op_gt_gt_eq
                    (Lwt_io.read_line_opt send)
                    (fun function_parameter =>
                      match function_parameter with
                      | None =>
                        Lwt.return_error
                          (error_info "ps" % string
                            "Unexpected ps answer (2nd line)" % string)
                      | Some ps_stats =>
                        match
                          Tezos_stdlib.TzString.split " " % char None None
                            ps_stats with
                        | cons _pid (cons mem (cons resident _)) =>
                          Tezos_error_monad.Error_monad.op_gt_gt_eq
                            (page_size tt)
                            (fun function_parameter =>
                              match function_parameter with
                              | inr e => Lwt.return_error e
                              | inl page_size =>
                                Lwt.return_ok
                                  (Ps
                                    {| page_size := page_size;
                                      mem := Stdlib.float_of_string mem;
                                      resident :=
                                        Stdlib.Int64.of_string resident |})
                              end)
                        | _ =>
                          Lwt.return_error
                            (error_info "ps" % string
                              "Unexpected answer" % string)
                        end
                      end)
                end))
      end)
    (fun exn =>
      Lwt.return_error
        (error_info "ps" % string (Stdlib.Printexc.to_string exn))).

Definition memory_stats (function_parameter : unit)
  : Lwt.t
    (Result.result Tezos_stdlib.Memory.mem_stats
      Tezos_error_monad.Error_monad.error) :=
  match function_parameter with
  | tt =>
    let pid := Unix.getpid tt in
    Tezos_error_monad.Error_monad.op_gt_gt_eq uname
      (fun function_parameter =>
        match function_parameter with
        | inr e => Lwt.return_error e
        | inl Linux => linux_statm pid
        | inl Darwin => darwin_ps pid
        | _ =>
          Lwt.return_error
            (error_info "memory_stats" % string "Unknown unix system" % string)
        end)
  end.
src/lib_stdlib_unix/sys_info.mli 
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

val memory_stats : unit -> (Memory.mem_stats, error) result Lwt.t
src/lib_stdlib_unix/sys_info.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter memory_stats :
unit ->
  Lwt.t (sum Tezos_stdlib.Memory.mem_stats Tezos_error_monad.Error_monad.error).
src/lib_stdlib_unix/systime_os.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let now () = Ptime_clock.now ()

let sleep s = Lwt_unix.sleep (Ptime.Span.to_float_s s)
src/lib_stdlib_unix/systime_os.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition now (function_parameter : unit) : Ptime.t :=
  match function_parameter with
  | tt => Ptime_clock.now tt
  end.

Definition sleep (s : Ptime.span) : Lwt.t unit :=
  Lwt_unix.sleep (Ptime.Span.to_float_s s).
src/lib_stdlib_unix/systime_os.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The current time according to the system clock *)
val now : unit -> Ptime.t

(** [sleep t] is an Lwt promise that resolves after [t] time has elapsed.
    If [t] is negative, [sleep t] is already resolved. *)
val sleep : Ptime.Span.t -> unit Lwt.t
src/lib_stdlib_unix/systime_os.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter now : unit -> Ptime.t.

Parameter sleep : Ptime.Span.t -> Lwt.t unit.
src/lib_stdlib_unix/utils.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let hide_progress_line s =
  let len = String.length s in
  if len > 0 then Printf.eprintf "\r%*s\r" len ""

let display_progress ?(refresh_rate = (1, 1)) fmt =
  let prnt s =
    if Unix.isatty Unix.stderr then
      let (index, rate) = refresh_rate in
      if index mod rate == 0 then (
        hide_progress_line s ; Format.eprintf "%s%!" s )
  in
  Format.kasprintf prnt fmt

let display_progress_end () =
  if Unix.isatty Unix.stderr then Format.eprintf "@."
src/lib_stdlib_unix/utils.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition hide_progress_line (s : string) : unit :=
  let len := OCaml.String.length s in
  if OCaml.Stdlib.gt len 0 then
    Stdlib.Printf.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "013" % char
          (CamlinternalFormatBasics.String
            (CamlinternalFormatBasics.Arg_padding CamlinternalFormatBasics.Right)
            (CamlinternalFormatBasics.Char_literal "013" % char
              CamlinternalFormatBasics.End_of_format))) "
%*s
" % string) len
      "" % string
  else
    tt.

Definition display_progress {A : Type} (op_star_o_p_t_star : option (Z * Z))
  : (Stdlib.format4 A Stdlib.Format.formatter unit unit) -> A :=
  let refresh_rate :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => (1, 1)
    end in
  fun fmt =>
    let prnt (s : string) : unit :=
      if Unix.isatty Unix.stderr then
        match refresh_rate with
        | (index, rate) =>
          if Stdlib.op_eq_eq (Z.modulo index rate) 0 then
            hide_progress_line s;
            Stdlib.Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format)) "%s%!" % string) s
          else
            tt
        end
      else
        tt in
    Stdlib.Format.kasprintf prnt fmt.

Definition display_progress_end (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    if Unix.isatty Unix.stderr then
      Stdlib.Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Flush_newline
            CamlinternalFormatBasics.End_of_format) "@." % string)
    else
      tt
  end.
src/lib_stdlib_unix/utils.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**  Print string over the current line *)
val display_progress :
  ?refresh_rate:int * int -> ('a, Format.formatter, unit, unit) format4 -> 'a

(** Finalizes progress display *)
val display_progress_end : unit -> unit
src/lib_stdlib_unix/utils.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter display_progress : forall {a : Type},
(option (Z * Z)) -> (Stdlib.format4 a Stdlib.Format.formatter unit unit) -> a.

Parameter display_progress_end : unit -> unit.
src/lib_storage/context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - Versioned (key x value) store (over Irmin) *)

module Path = Irmin.Path.String_list
module Metadata = Irmin.Metadata.None

let reporter () =
  let report src level ~over k msgf =
    let k _ = over () ; k () in
    let with_stamp h _tags k fmt =
      let dt = Mtime.Span.to_us (Mtime_clock.elapsed ()) in
      Fmt.kpf
        k
        Fmt.stderr
        ("%+04.0fus %a %a @[" ^^ fmt ^^ "@]@.")
        dt
        Fmt.(styled `Magenta string)
        (Logs.Src.name src)
        Logs_fmt.pp_header
        (level, h)
    in
    msgf @@ fun ?header ?tags fmt -> with_stamp header tags k fmt
  in
  {Logs.report}

let index_log_size = ref None

let () =
  let verbose () =
    Logs.set_level (Some Logs.Debug) ;
    Logs.set_reporter (reporter ())
  in
  let index_log_size n = index_log_size := Some (int_of_string n) in
  match Unix.getenv "TEZOS_STORAGE" with
  | exception Not_found ->
      ()
  | v ->
      let args = String.split ',' v in
      List.iter
        (function
          | "v" | "verbose" | "vv" ->
              verbose ()
          | v -> (
            match String.split '=' v with
            | ["index-log-size"; n] ->
                index_log_size n
            | _ ->
                () ))
        args

module Hash : sig
  include Irmin.Hash.S

  val to_context_hash : t -> Context_hash.t

  val of_context_hash : Context_hash.t -> t
end = struct
  module H = Digestif.Make_BLAKE2B (struct
    let digest_size = 32
  end)

  type t = H.t

  let of_context_hash s = H.of_raw_string (Context_hash.to_string s)

  let to_context_hash h = Context_hash.of_string_exn (H.to_raw_string h)

  let pp ppf t = Context_hash.pp ppf (to_context_hash t)

  let of_string x =
    match Context_hash.of_b58check x with
    | Ok x ->
        Ok (of_context_hash x)
    | Error err ->
        Error
          (`Msg
            (Format.asprintf
               "Failed to read b58check_encoding data: %a"
               Error_monad.pp_print_error
               err))

  let short_hash t = Irmin.Type.(short_hash string (H.to_raw_string t))

  let t : t Irmin.Type.t =
    Irmin.Type.map
      ~cli:(pp, of_string)
      Irmin.Type.(string_of (`Fixed H.digest_size))
      ~short_hash
      H.of_raw_string
      H.to_raw_string

  let hash_size = H.digest_size

  let hash = H.digesti_string
end

module Node = struct
  module M = Irmin.Private.Node.Make (Hash) (Path) (Metadata)

  module V1 = struct
    module Hash = Irmin.Hash.V1 (Hash)

    type kind = [`Node | `Contents of Metadata.t]

    type entry = {kind : kind; name : M.step; node : Hash.t}

    (* Irmin 1.4 uses int64 to store string lengths *)
    let step_t =
      let pre_hash = Irmin.Type.(pre_hash (string_of `Int64)) in
      Irmin.Type.like M.step_t ~pre_hash

    let metadata_t =
      let some = "\255\000\000\000\000\000\000\000" in
      let none = "\000\000\000\000\000\000\000\000" in
      Irmin.Type.(map (string_of (`Fixed 8)))
        (fun s ->
          match s.[0] with
          | '\255' ->
              None
          | '\000' ->
              Some ()
          | _ ->
              assert false)
        (function Some _ -> some | None -> none)

    (* Irmin 1.4 uses int64 to store list lengths *)
    let entry_t : entry Irmin.Type.t =
      let open Irmin.Type in
      record "Tree.entry" (fun kind name node ->
          let kind = match kind with None -> `Node | Some m -> `Contents m in
          {kind; name; node})
      |+ field "kind" metadata_t (function
             | {kind = `Node; _} ->
                 None
             | {kind = `Contents m; _} ->
                 Some m)
      |+ field "name" step_t (fun {name; _} -> name)
      |+ field "node" Hash.t (fun {node; _} -> node)
      |> sealr

    let entries_t : entry list Irmin.Type.t =
      Irmin.Type.(list ~len:`Int64 entry_t)

    let import_entry (s, v) =
      match v with
      | `Node h ->
          {name = s; kind = `Node; node = h}
      | `Contents (h, m) ->
          {name = s; kind = `Contents m; node = h}

    let import t = List.map import_entry (M.list t)

    let pre_hash entries = Irmin.Type.pre_hash entries_t entries
  end

  include M

  let pre_hash_v1 x = V1.pre_hash (V1.import x)

  let t = Irmin.Type.(like t ~pre_hash:pre_hash_v1)
end

module Commit = struct
  module M = Irmin.Private.Commit.Make (Hash)
  module V1 = Irmin.Private.Commit.V1 (M)
  include M

  let pre_hash_v1 t = Irmin.Type.pre_hash V1.t (V1.import t)

  let t = Irmin.Type.like t ~pre_hash:pre_hash_v1
end

module Contents = struct
  type t = string

  let pre_hash_v1 x =
    let ty = Irmin.Type.(pair (string_of `Int64) unit) in
    Irmin.Type.(pre_hash ty) (x, ())

  let t = Irmin.Type.(like ~pre_hash:pre_hash_v1 string)

  let merge = Irmin.Merge.(idempotent (Irmin.Type.option t))
end

module Conf = struct
  let entries = 32

  let stable_hash = 256
end

module Store =
  Irmin_pack.Make_ext (Conf) (Irmin.Metadata.None) (Contents)
    (Irmin.Path.String_list)
    (Irmin.Branch.String)
    (Hash)
    (Node)
    (Commit)
module P = Store.Private

type index = {
  path : string;
  repo : Store.Repo.t;
  patch_context : context -> context Lwt.t;
}

and context = {index : index; parents : Store.Commit.t list; tree : Store.tree}

type t = context

(*-- Version Access and Update -----------------------------------------------*)

let current_protocol_key = ["protocol"]

let current_test_chain_key = ["test_chain"]

let current_data_key = ["data"]

let exists index key =
  Store.Commit.of_hash index.repo (Hash.of_context_hash key)
  >|= function None -> false | Some _ -> true

let checkout index key =
  Store.Commit.of_hash index.repo (Hash.of_context_hash key)
  >>= function
  | None ->
      Lwt.return_none
  | Some commit ->
      let tree = Store.Commit.tree commit in
      let ctxt = {index; tree; parents = [commit]} in
      Lwt.return_some ctxt

let checkout_exn index key =
  checkout index key
  >>= function None -> Lwt.fail Not_found | Some p -> Lwt.return p

(* unshalow possible 1-st level objects from previous partial
   checkouts ; might be better to pass directly the list of shallow
   objects. *)
let unshallow context =
  Store.Tree.list context.tree []
  >>= fun childs ->
  P.Repo.batch context.index.repo (fun x y _ ->
      Lwt_list.iter_s
        (fun (s, k) ->
          match k with
          | `Contents ->
              Lwt.return ()
          | `Node ->
              Store.Tree.get_tree context.tree [s]
              >>= fun tree ->
              Store.save_tree ~clear:true context.index.repo x y tree
              >|= fun _ -> ())
        childs)

let raw_commit ~time ?(message = "") context =
  let info =
    Irmin.Info.v ~date:(Time.Protocol.to_seconds time) ~author:"Tezos" message
  in
  let parents = List.map Store.Commit.hash context.parents in
  unshallow context
  >>= fun () ->
  Store.Commit.v context.index.repo ~info ~parents context.tree
  >|= fun h ->
  Store.Tree.clear context.tree ;
  h

let hash ~time ?(message = "") context =
  let info =
    Irmin.Info.v ~date:(Time.Protocol.to_seconds time) ~author:"Tezos" message
  in
  let parents = List.map (fun c -> Store.Commit.hash c) context.parents in
  let node = Store.Tree.hash context.tree in
  let commit = P.Commit.Val.v ~parents ~node ~info in
  let x = P.Commit.Key.hash commit in
  Hash.to_context_hash x

let commit ~time ?message context =
  raw_commit ~time ?message context
  >|= fun commit -> Hash.to_context_hash (Store.Commit.hash commit)

(*-- Generic Store Primitives ------------------------------------------------*)

let data_key key = current_data_key @ key

type key = string list

type value = bytes

let mem ctxt key =
  Store.Tree.mem ctxt.tree (data_key key) >>= fun v -> Lwt.return v

let dir_mem ctxt key =
  Store.Tree.mem_tree ctxt.tree (data_key key) >>= fun v -> Lwt.return v

let raw_get ctxt key =
  Store.Tree.find ctxt.tree key >|= Option.map ~f:Bytes.of_string

let get t key = raw_get t (data_key key)

let raw_set ctxt key data =
  let data = Bytes.to_string data in
  Store.Tree.add ctxt.tree key data >>= fun tree -> Lwt.return {ctxt with tree}

let set t key data = raw_set t (data_key key) data

let raw_del ctxt key =
  Store.Tree.remove ctxt.tree key >>= fun tree -> Lwt.return {ctxt with tree}

let del t key = raw_del t (data_key key)

let remove_rec ctxt key =
  Store.Tree.remove ctxt.tree (data_key key)
  >>= fun tree -> Lwt.return {ctxt with tree}

let copy ctxt ~from ~to_ =
  Store.Tree.find_tree ctxt.tree (data_key from)
  >>= function
  | None ->
      Lwt.return_none
  | Some sub_tree ->
      Store.Tree.add_tree ctxt.tree (data_key to_) sub_tree
      >>= fun tree -> Lwt.return_some {ctxt with tree}

let fold ctxt key ~init ~f =
  Store.Tree.list ctxt.tree (data_key key)
  >>= fun keys ->
  Lwt_list.fold_left_s
    (fun acc (name, kind) ->
      let key =
        match kind with
        | `Contents ->
            `Key (key @ [name])
        | `Node ->
            `Dir (key @ [name])
      in
      f key acc)
    init
    keys

(*-- Predefined Fields -------------------------------------------------------*)

let get_protocol v =
  raw_get v current_protocol_key
  >>= function
  | None ->
      assert false
  | Some data ->
      Lwt.return (Protocol_hash.of_bytes_exn data)

let set_protocol v key =
  let key = Protocol_hash.to_bytes key in
  raw_set v current_protocol_key key

let get_test_chain v =
  raw_get v current_test_chain_key
  >>= function
  | None ->
      Lwt.fail (Failure "Unexpected error (Context.get_test_chain)")
  | Some data -> (
    match Data_encoding.Binary.of_bytes Test_chain_status.encoding data with
    | None ->
        Lwt.fail (Failure "Unexpected error (Context.get_test_chain)")
    | Some r ->
        Lwt.return r )

let set_test_chain v id =
  let id = Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding id in
  raw_set v current_test_chain_key id

let del_test_chain v = raw_del v current_test_chain_key

let fork_test_chain v ~protocol ~expiration =
  set_test_chain v (Forking {protocol; expiration})

(*-- Initialisation ----------------------------------------------------------*)

let init ?patch_context ?mapsize:_ ?readonly root =
  Store.Repo.v
    (Irmin_pack.config ?readonly ?index_log_size:!index_log_size root)
  >>= fun repo ->
  let v =
    {
      path = root;
      repo;
      patch_context =
        ( match patch_context with
        | None ->
            fun ctxt -> Lwt.return ctxt
        | Some patch_context ->
            patch_context );
    }
  in
  Gc.finalise (fun v -> Lwt.async (fun () -> Store.Repo.close v.repo)) v ;
  Lwt.return v

let get_branch chain_id = Format.asprintf "%a" Chain_id.pp chain_id

let commit_genesis index ~chain_id ~time ~protocol =
  let tree = Store.Tree.empty in
  let ctxt = {index; tree; parents = []} in
  index.patch_context ctxt
  >>= fun ctxt ->
  set_protocol ctxt protocol
  >>= fun ctxt ->
  set_test_chain ctxt Not_running
  >>= fun ctxt ->
  raw_commit ~time ~message:"Genesis" ctxt
  >>= fun commit ->
  Store.Branch.set index.repo (get_branch chain_id) commit
  >|= fun () -> Hash.to_context_hash (Store.Commit.hash commit)

let compute_testchain_chain_id genesis =
  let genesis_hash = Block_hash.hash_bytes [Block_hash.to_bytes genesis] in
  Chain_id.of_block_hash genesis_hash

let compute_testchain_genesis forked_block =
  let genesis = Block_hash.hash_bytes [Block_hash.to_bytes forked_block] in
  genesis

let commit_test_chain_genesis ctxt (forked_header : Block_header.t) =
  let message =
    Format.asprintf "Forking testchain at level %ld." forked_header.shell.level
  in
  raw_commit ~time:forked_header.shell.timestamp ~message ctxt
  >>= fun commit ->
  let faked_shell_header : Block_header.shell_header =
    {
      forked_header.shell with
      proto_level = succ forked_header.shell.proto_level;
      predecessor = Block_hash.zero;
      validation_passes = 0;
      operations_hash = Operation_list_list_hash.empty;
      context = Hash.to_context_hash (Store.Commit.hash commit);
    }
  in
  let forked_block = Block_header.hash forked_header in
  let genesis_hash = compute_testchain_genesis forked_block in
  let chain_id = compute_testchain_chain_id genesis_hash in
  let genesis_header : Block_header.t =
    {
      shell = {faked_shell_header with predecessor = genesis_hash};
      protocol_data = MBytes.create 0;
    }
  in
  let branch = get_branch chain_id in
  Store.Branch.set ctxt.index.repo branch commit
  >>= fun () -> Lwt.return genesis_header

let clear_test_chain index chain_id =
  (* TODO remove commits... ??? *)
  let branch = get_branch chain_id in
  Store.Branch.remove index.repo branch

let set_head index chain_id commit =
  let branch = get_branch chain_id in
  Store.Commit.of_hash index.repo (Hash.of_context_hash commit)
  >>= function
  | None ->
      assert false
  | Some commit ->
      Store.Branch.set index.repo branch commit

let set_master index commit =
  Store.Commit.of_hash index.repo (Hash.of_context_hash commit)
  >>= function
  | None ->
      assert false
  | Some commit ->
      Store.Branch.set index.repo Store.Branch.master commit

(* Context dumping *)

module Pruned_block = struct
  type t = {
    block_header : Block_header.t;
    operations : (int * Operation.t list) list;
    operation_hashes : (int * Operation_hash.t list) list;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {block_header; operations; operation_hashes} ->
        (operations, operation_hashes, block_header))
      (fun (operations, operation_hashes, block_header) ->
        {block_header; operations; operation_hashes})
      (obj3
         (req
            "operations"
            (list (tup2 int31 (list (dynamic_size Operation.encoding)))))
         (req
            "operation_hashes"
            (list (tup2 int31 (list (dynamic_size Operation_hash.encoding)))))
         (req "block_header" Block_header.encoding))

  let to_bytes pruned_block =
    Data_encoding.Binary.to_bytes_exn encoding pruned_block

  let of_bytes pruned_block =
    Data_encoding.Binary.of_bytes encoding pruned_block

  let header {block_header; _} = block_header
end

module Block_data = struct
  type t = {block_header : Block_header.t; operations : Operation.t list list}

  let header {block_header; _} = block_header

  let encoding =
    let open Data_encoding in
    conv
      (fun {block_header; operations} -> (operations, block_header))
      (fun (operations, block_header) -> {block_header; operations})
      (obj2
         (req "operations" (list (list (dynamic_size Operation.encoding))))
         (req "block_header" Block_header.encoding))

  let to_bytes = Data_encoding.Binary.to_bytes_exn encoding

  let of_bytes = Data_encoding.Binary.of_bytes encoding
end

module Protocol_data = struct
  type info = {author : string; message : string; timestamp : Time.Protocol.t}

  let info_encoding =
    let open Data_encoding in
    conv
      (fun {author; message; timestamp} -> (author, message, timestamp))
      (fun (author, message, timestamp) -> {author; message; timestamp})
      (obj3
         (req "author" string)
         (req "message" string)
         (req "timestamp" Time.Protocol.encoding))

  type data = {
    info : info;
    protocol_hash : Protocol_hash.t;
    test_chain_status : Test_chain_status.t;
    data_key : Context_hash.t;
    parents : Context_hash.t list;
  }

  let data_encoding =
    let open Data_encoding in
    conv
      (fun {info; protocol_hash; test_chain_status; data_key; parents} ->
        (info, protocol_hash, test_chain_status, data_key, parents))
      (fun (info, protocol_hash, test_chain_status, data_key, parents) ->
        {info; protocol_hash; test_chain_status; data_key; parents})
      (obj5
         (req "info" info_encoding)
         (req "protocol_hash" Protocol_hash.encoding)
         (req "test_chain_status" Test_chain_status.encoding)
         (req "data_key" Context_hash.encoding)
         (req "parents" (list Context_hash.encoding)))

  type t = Int32.t * data

  let encoding =
    let open Data_encoding in
    tup2 int32 data_encoding

  let to_bytes = Data_encoding.Binary.to_bytes_exn encoding

  let of_bytes = Data_encoding.Binary.of_bytes encoding
end

module Dumpable_context = struct
  type nonrec index = index

  type nonrec context = context

  type tree = Store.tree

  type hash = [`Blob of Store.hash | `Node of Store.hash]

  type step = string

  type key = step list

  type commit_info = Irmin.Info.t

  type batch =
    | Batch of
        Store.repo * [`Read | `Write] P.Contents.t * [`Read | `Write] P.Node.t

  let batch index f =
    P.Repo.batch index.repo (fun x y _ -> f (Batch (index.repo, x, y)))

  let commit_info_encoding =
    let open Data_encoding in
    conv
      (fun irmin_info ->
        let author = Irmin.Info.author irmin_info in
        let message = Irmin.Info.message irmin_info in
        let date = Irmin.Info.date irmin_info in
        (author, message, date))
      (fun (author, message, date) -> Irmin.Info.v ~author ~date message)
      (obj3 (req "author" string) (req "message" string) (req "date" int64))

  let hash_encoding : hash Data_encoding.t =
    let open Data_encoding in
    let kind_encoding = string_enum [("node", `Node); ("blob", `Blob)] in
    conv
      (function
        | `Blob h ->
            (`Blob, Context_hash.to_bytes (Hash.to_context_hash h))
        | `Node h ->
            (`Node, Context_hash.to_bytes (Hash.to_context_hash h)))
      (function
        | (`Blob, h) ->
            `Blob (Hash.of_context_hash (Context_hash.of_bytes_exn h))
        | (`Node, h) ->
            `Node (Hash.of_context_hash (Context_hash.of_bytes_exn h)))
      (obj2 (req "kind" kind_encoding) (req "value" bytes))

  let context_parents ctxt =
    match ctxt with
    | {parents = [commit]; _} ->
        let parents = Store.Commit.parents commit in
        let parents = List.map Hash.to_context_hash parents in
        List.sort Context_hash.compare parents
    | _ ->
        assert false

  let context_info = function
    | {parents = [c]; _} ->
        Store.Commit.info c
    | _ ->
        assert false

  let get_context idx bh = checkout idx bh.Block_header.shell.context

  let set_context ~info ~parents ctxt bh =
    let parents = List.sort Context_hash.compare parents in
    let parents = List.map Hash.of_context_hash parents in
    Store.Commit.v ctxt.index.repo ~info ~parents ctxt.tree
    >>= fun c ->
    let h = Store.Commit.hash c in
    if
      Context_hash.equal bh.Block_header.shell.context (Hash.to_context_hash h)
    then Lwt.return_some bh
    else Lwt.return_none

  let context_tree ctxt = ctxt.tree

  let tree_hash = function
    | `Node _ as tree ->
        `Node (Store.Tree.hash tree)
    | `Contents (b, _) ->
        `Blob (Store.Contents.hash b)

  let sub_tree tree key = Store.Tree.find_tree tree key

  let tree_list tree = Store.Tree.list tree []

  let tree_content tree = Store.Tree.find tree []

  let make_context index = {index; tree = Store.Tree.empty; parents = []}

  let update_context context tree = {context with tree}

  let add_blob_hash (Batch (repo, _, _)) tree key hash =
    Store.Contents.of_hash repo hash
    >>= function
    | None ->
        Lwt.return_none
    | Some v ->
        Store.Tree.add tree key v >>= Lwt.return_some

  let add_node_hash (Batch (repo, _, _)) tree key hash =
    Store.Tree.of_hash repo hash
    >>= function
    | None ->
        Lwt.return_none
    | Some t ->
        Store.Tree.add_tree tree key (t :> tree) >>= Lwt.return_some

  let add_string (Batch (_, t, _)) string =
    (* Save the contents in the store *)
    Store.save_contents t string >|= fun _ -> Store.Tree.of_contents string

  let add_dir batch l =
    let rec fold_list sub_tree = function
      | [] ->
          Lwt.return_some sub_tree
      | (step, hash) :: tl -> (
        match hash with
        | `Blob hash -> (
            add_blob_hash batch sub_tree [step] hash
            >>= function
            | None -> Lwt.return_none | Some sub_tree -> fold_list sub_tree tl
            )
        | `Node hash -> (
            add_node_hash batch sub_tree [step] hash
            >>= function
            | None -> Lwt.return_none | Some sub_tree -> fold_list sub_tree tl
            ) )
    in
    fold_list Store.Tree.empty l
    >>= function
    | None ->
        Lwt.return_none
    | Some tree ->
        let (Batch (repo, x, y)) = batch in
        (* Save the node in the store ... *)
        Store.save_tree ~clear:true repo x y tree >|= fun _ -> Some tree

  module Commit_hash = Context_hash
  module Block_header = Block_header
  module Block_data = Block_data
  module Pruned_block = Pruned_block
  module Protocol_data = Protocol_data
end

(* Protocol data *)

let data_node_hash context =
  Store.Tree.get_tree context.tree current_data_key
  >|= fun tree -> Hash.to_context_hash (Store.Tree.hash tree)

let get_protocol_data_from_header index block_header =
  checkout_exn index block_header.Block_header.shell.context
  >>= fun context ->
  let level = block_header.shell.level in
  let irmin_info = Dumpable_context.context_info context in
  let date = Irmin.Info.date irmin_info in
  let author = Irmin.Info.author irmin_info in
  let message = Irmin.Info.message irmin_info in
  let info =
    {Protocol_data.timestamp = Time.Protocol.of_seconds date; author; message}
  in
  let parents = Dumpable_context.context_parents context in
  get_protocol context
  >>= fun protocol_hash ->
  get_test_chain context
  >>= fun test_chain_status ->
  data_node_hash context
  >>= fun data_key ->
  Lwt.return
    ( level,
      {Protocol_data.parents; protocol_hash; test_chain_status; data_key; info}
    )

let validate_context_hash_consistency_and_commit ~data_hash
    ~expected_context_hash ~timestamp ~test_chain ~protocol_hash ~message
    ~author ~parents ~index =
  let data_hash = Hash.of_context_hash data_hash in
  let parents = List.map Hash.of_context_hash parents in
  let protocol_value = Protocol_hash.to_bytes protocol_hash in
  let test_chain_value =
    Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding test_chain
  in
  let tree = Store.Tree.empty in
  Store.Tree.add tree current_protocol_key (MBytes.to_string protocol_value)
  >>= fun tree ->
  Store.Tree.add
    tree
    current_test_chain_key
    (MBytes.to_string test_chain_value)
  >>= fun tree ->
  let info =
    Irmin.Info.v ~date:(Time.Protocol.to_seconds timestamp) ~author message
  in
  let data_tree = Store.Tree.shallow index.repo data_hash in
  Store.Tree.add_tree tree ["data"] data_tree
  >>= fun node ->
  let node = Store.Tree.hash node in
  let commit = P.Commit.Val.v ~parents ~node ~info in
  let computed_context_hash =
    Hash.to_context_hash (P.Commit.Key.hash commit)
  in
  if Context_hash.equal expected_context_hash computed_context_hash then
    let ctxt =
      let parent = Store.of_private_commit index.repo commit in
      {index; tree = Store.Tree.empty; parents = [parent]}
    in
    set_test_chain ctxt test_chain
    >>= fun ctxt ->
    set_protocol ctxt protocol_hash
    >>= fun ctxt ->
    let data_t = Store.Tree.shallow index.repo data_hash in
    Store.Tree.add_tree ctxt.tree current_data_key data_t
    >>= fun new_tree ->
    Store.Commit.v ctxt.index.repo ~info ~parents new_tree
    >|= fun commit ->
    let ctxt_h = Hash.to_context_hash (Store.Commit.hash commit) in
    Context_hash.equal ctxt_h expected_context_hash
  else Lwt.return_false

(* Context dumper *)

module Context_dumper = Context_dump.Make (Dumpable_context)
include Context_dumper

(* provides functions dump_contexts and restore_contexts *)

type error += Cannot_create_file of string

let () =
  register_error_kind
    `Permanent
    ~id:"context_dump.write.cannot_open"
    ~title:"Cannot open file for context dump"
    ~description:""
    ~pp:(fun ppf uerr ->
      Format.fprintf
        ppf
        "@[Error while opening file for context dumping: %s@]"
        uerr)
    Data_encoding.(obj1 (req "context_dump_cannot_open" string))
    (function Cannot_create_file e -> Some e | _ -> None)
    (fun e -> Cannot_create_file e)

type error += Cannot_open_file of string

let () =
  register_error_kind
    `Permanent
    ~id:"context_dump.read.cannot_open"
    ~title:"Cannot open file for context restoring"
    ~description:""
    ~pp:(fun ppf uerr ->
      Format.fprintf
        ppf
        "@[Error while opening file for context restoring: %s@]"
        uerr)
    Data_encoding.(obj1 (req "context_restore_cannot_open" string))
    (function Cannot_open_file e -> Some e | _ -> None)
    (fun e -> Cannot_open_file e)

type error += Suspicious_file of int

let () =
  register_error_kind
    `Permanent
    ~id:"context_dump.read.suspicious"
    ~title:"Suspicious file: data after end"
    ~description:""
    ~pp:(fun ppf uerr ->
      Format.fprintf
        ppf
        "@[Remaining bytes in file after context restoring: %d@]"
        uerr)
    Data_encoding.(obj1 (req "context_restore_suspicious" int31))
    (function Suspicious_file e -> Some e | _ -> None)
    (fun e -> Suspicious_file e)

let dump_contexts idx datas ~filename =
  let file_init () =
    Lwt_unix.openfile filename Lwt_unix.[O_WRONLY; O_CREAT; O_TRUNC] 0o666
    >>= return
  in
  Lwt.catch file_init (function
      | Unix.Unix_error (e, _, _) ->
          fail @@ Cannot_create_file (Unix.error_message e)
      | exc ->
          let msg =
            Printf.sprintf "unknown error: %s" (Printexc.to_string exc)
          in
          fail (Cannot_create_file msg))
  >>=? fun fd -> dump_contexts_fd idx datas ~fd

let restore_contexts idx ~filename k_store_pruned_block pipeline_validation =
  let file_init () =
    Lwt_unix.openfile filename Lwt_unix.[O_RDONLY] 0o600 >>= return
  in
  Lwt.catch file_init (function
      | Unix.Unix_error (e, _, _) ->
          fail @@ Cannot_open_file (Unix.error_message e)
      | exc ->
          let msg =
            Printf.sprintf "unknown error: %s" (Printexc.to_string exc)
          in
          fail (Cannot_open_file msg))
  >>=? fun fd ->
  Lwt.finalize
    (fun () ->
      restore_contexts_fd idx ~fd k_store_pruned_block pipeline_validation
      >>=? fun result ->
      Lwt_unix.lseek fd 0 Lwt_unix.SEEK_CUR
      >>= fun current ->
      Lwt_unix.fstat fd
      >>= fun stats ->
      let total = stats.Lwt_unix.st_size in
      if current = total then return result
      else fail @@ Suspicious_file (total - current))
    (fun () -> Lwt_unix.close fd)
src/lib_storage/context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition reporter (function_parameter : unit) : Logs.reporter :=
  match function_parameter with
  | tt =>
    let report {A B C D : Type}
      (src : Logs.src) (level : Logs.level) (over : unit -> unit) (k :
      unit -> A) (msgf :
      ((option string) ->
        (option B) ->
          (Stdlib.format6 C Stdlib.Format.formatter unit unit unit A) -> C) -> D)
      : D :=
      let k {E : Type} (function_parameter : E) : A :=
        match function_parameter with
        | _ =>
          over tt;
          k tt
        end in
      let with_stamp {E F G : Type}
        (h : option string) (_tags : E) (k : Stdlib.Format.formatter -> F) (fmt
        : Stdlib.format6 G Stdlib.Format.formatter unit unit unit F) : G :=
        let dt := Mtime.Span.to_us (Mtime_clock.elapsed tt) in
        Fmt.kpf k Fmt.stderr
          (Stdlib.op_caret_caret
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_pf
                (CamlinternalFormatBasics.Lit_padding
                  CamlinternalFormatBasics.Zeros 4)
                (CamlinternalFormatBasics.Lit_precision 0)
                (CamlinternalFormatBasics.String_literal "us " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal " " % char
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal " " % char
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_box
                              (CamlinternalFormatBasics.Format
                                CamlinternalFormatBasics.End_of_format
                                "" % string))
                            CamlinternalFormatBasics.End_of_format)))))))
              "%+04.0fus %a %a @[" % string)
            (Stdlib.op_caret_caret fmt
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Flush_newline
                    CamlinternalFormatBasics.End_of_format)) "@]@." % string)))
          dt (Fmt.styled variant Fmt.string) (Logs.Src.name src)
          Logs_fmt.pp_header (level, h) in
      apply msgf
        (fun header => fun tags => fun fmt => with_stamp header tags k fmt) in
    {| Logs.report := report |}
  end.

Definition index_log_size : Stdlib.ref (option Z) := Stdlib.ref None.

Module Hash.
  Definition t := H.t.
  
  Definition of_context_hash (s : Tezos_base__TzPervasives.Context_hash.t)
    : H.t := H.of_raw_string (Tezos_base__TzPervasives.Context_hash.to_string s).
  
  Definition to_context_hash (h : H.t)
    : Tezos_base__TzPervasives.Context_hash.t :=
    Tezos_base__TzPervasives.Context_hash.of_string_exn (H.to_raw_string h).
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : H.t) : unit :=
    Tezos_base__TzPervasives.Context_hash.pp ppf (to_context_hash t).
  
  Definition of_string (x : string) : sum H.t variant :=
    match Tezos_base__TzPervasives.Context_hash.of_b58check x with
    | inl x => inl (of_context_hash x)
    | inr err => inr variant
    end.
  
  Definition short_hash (t : H.t) : Z :=
    Irmin.Type.short_hash Irmin.Type.string None (H.to_raw_string t).
  
  Definition t : Irmin.Type.t t :=
    Irmin.Type.map (Some (pp, of_string)) None None None None (Some short_hash)
      None (Irmin.Type.string_of variant) H.of_raw_string H.to_raw_string.
  
  Definition hash_size : Z := H.digest_size.
  
  Definition hash : (Digestif.iter Stdlib.String.t) -> H.(Digestif.S.t) :=
    H.(Digestif.S.digesti_string).
End Hash.

Module Node.
  Module V1.
    Definition kind := variant.
    
    Record entry := {
      kind : kind;
      name : M.(Irmin.S.Node.Private.step);
      node : Hash.(Irmin.S.Hash.t) }.
    
    Definition step_t : Irmin.Type.t M.(Irmin.S.Node.Private.step) :=
      let pre_hash := Irmin.Type.pre_hash (Irmin.Type.string_of variant) in
      Irmin.Type.like None None None None None None (Some pre_hash)
        M.(Irmin.S.Node.Private.step_t).
    
    Definition metadata_t : Irmin.Type.t (option unit) :=
      let some := "ÿ" % string in
      let none := "" % string in
      (Irmin.Type.map None None None None None None None
        (Irmin.Type.string_of variant))
        (fun s =>
          match Tezos_base__TzPervasives.String.get s 0 with
          | "ÿ" % char => None
          | "000" % char => Some tt
          | _ => false
          end)
        (fun function_parameter =>
          match function_parameter with
          | Some _ => some
          | None => none
          end).
    
    Definition entry_t : Irmin.Type.t entry :=
      OCaml.Stdlib.reverse_apply
        (Irmin.Type.op_pipe_plus
          (Irmin.Type.op_pipe_plus
            (Irmin.Type.op_pipe_plus
              (Irmin.Type.record "Tree.entry" % string
                (fun kind =>
                  fun name =>
                    fun node =>
                      let kind :=
                        match kind with
                        | None => variant
                        | Some m => variant
                        end in
                      {| kind := kind; name := name; node := node |}))
              (Irmin.Type.field "kind" % string metadata_t
                (fun function_parameter =>
                  match function_parameter with
                  | {| kind := Node |} => None
                  | {| kind := Contents m |} => Some m
                  end)))
            (Irmin.Type.field "name" % string step_t
              (fun function_parameter =>
                match function_parameter with
                | {| name := name |} => name
                end)))
          (Irmin.Type.field "node" % string Hash.(Irmin.S.Hash.t)
            (fun function_parameter =>
              match function_parameter with
              | {| node := node |} => node
              end))) Irmin.Type.sealr.
    
    Definition entries_t : Irmin.Type.t (list entry) :=
      Irmin.Type.list (Some variant) entry_t.
    
    Definition import_entry
      (function_parameter : M.(Irmin.S.Node.Private.step) * variant) : entry :=
      match function_parameter with
      | (s, v) =>
        match v with
        | Node h => {| kind := variant; name := s; node := h |}
        | Contents (h, m) => {| kind := variant; name := s; node := h |}
        end
      end.
    
    Definition import (t : M.(Irmin.S.Node.Private.t)) : list entry :=
      Tezos_base__TzPervasives.List.map import_entry
        (M.(Irmin.S.Node.Private.list) t).
    
    Definition pre_hash (entries : list entry) : (string -> unit) -> unit :=
      Irmin.Type.pre_hash entries_t entries.
  End V1.
  
  Definition pre_hash_v1 (x : M.(Irmin.S.Node.Private.t))
    : (string -> unit) -> unit := V1.pre_hash (V1.import x).
  
  Definition t : Irmin.Type.t M.(Irmin.S.Node.Private.t) :=
    Irmin.Type.like None None None None None None (Some pre_hash_v1) t.
End Node.

Module Commit.
  Definition pre_hash_v1 (t : M.(Irmin.S.Commit.Private.t))
    : (string -> unit) -> unit := Irmin.Type.pre_hash V1.t (V1.import t).
  
  Definition t : Irmin.Type.t M.(Irmin.S.Commit.Private.t) :=
    Irmin.Type.like None None None None None None (Some pre_hash_v1) t.
End Commit.

Module Contents.
  Definition t := string.
  
  Definition pre_hash_v1 (x : string) : (string -> unit) -> unit :=
    let ty := Irmin.Type.pair (Irmin.Type.string_of variant) Irmin.Type.unit in
    (Irmin.Type.pre_hash ty) (x, tt).
  
  Definition t : Irmin.Type.t string :=
    Irmin.Type.like None None None None None None (Some pre_hash_v1)
      Irmin.Type.string.
  
  Definition merge : Irmin.Merge.t (option string) :=
    Irmin.Merge.idempotent (Irmin.Type.option t).
End Contents.

Module Conf.
  Definition entries : Z := 32.
  
  Definition stable_hash : Z := 256.
End Conf.

.

Definition t := context.

Definition current_protocol_key : list string := cons "protocol" % string [].

Definition current_test_chain_key : list string := cons "test_chain" % string [].

Definition current_data_key : list string := cons "data" % string [].

Definition _exists
  (index : index) (key : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t bool :=
  Tezos_base__TzPervasives.op_gt_pipe_eq
    (Store.Commit.of_hash (repo index) (Hash.of_context_hash key))
    (fun function_parameter =>
      match function_parameter with
      | None => false
      | Some _ => true
      end).

Definition checkout
  (index : index) (key : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t (option context) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Commit.of_hash (repo index) (Hash.of_context_hash key))
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.return_none
      | Some commit =>
        let tree := Store.Commit.tree commit in
        let ctxt :=
          {| index := index; parents := cons commit []; tree := tree |} in
        Lwt.return_some ctxt
      end).

Definition checkout_exn
  (index : index) (key : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t context :=
  Tezos_base__TzPervasives.op_gt_gt_eq (checkout index key)
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.fail OCaml.Not_found
      | Some p => Lwt._return p
      end).

Definition unshallow (context : context) : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Store.Tree.list (tree context) [])
    (fun childs =>
      P.Repo.batch (repo (index context))
        (fun x =>
          fun y =>
            fun function_parameter =>
              match function_parameter with
              | _ =>
                Lwt_list.iter_s
                  (fun function_parameter =>
                    match function_parameter with
                    | (s, k) =>
                      match k with
                      | Contents => Lwt._return tt
                      | Node =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Store.Tree.get_tree (tree context) (cons s []))
                          (fun tree =>
                            Tezos_base__TzPervasives.op_gt_pipe_eq
                              (Store.save_tree (Some true)
                                (repo (index context)) x y tree)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ => tt
                                end))
                      end
                    end) childs
              end)).

Definition raw_commit
  (time : Tezos_base__TzPervasives.Time.Protocol.t)
  (op_star_o_p_t_star : option string) : context -> Lwt.t Store.commit :=
  let message :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun context =>
    let info :=
      Irmin.Info.v (Tezos_base__TzPervasives.Time.Protocol.to_seconds time)
        "Tezos" % string message in
    let parents :=
      Tezos_base__TzPervasives.List.map Store.Commit.hash (parents context) in
    Tezos_base__TzPervasives.op_gt_gt_eq (unshallow context)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_pipe_eq
            (Store.Commit.v (repo (index context)) info parents (tree context))
            (fun h =>
              Store.Tree.clear None (tree context);
              h)
        end).

Definition hash
  (time : Tezos_base__TzPervasives.Time.Protocol.t)
  (op_star_o_p_t_star : option string)
  : context -> Tezos_base__TzPervasives.Context_hash.t :=
  let message :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun context =>
    let info :=
      Irmin.Info.v (Tezos_base__TzPervasives.Time.Protocol.to_seconds time)
        "Tezos" % string message in
    let parents :=
      Tezos_base__TzPervasives.List.map (fun c => Store.Commit.hash c)
        (parents context) in
    let node := Store.Tree.hash (tree context) in
    let commit := P.Commit.Val.v info node parents in
    let x := P.Commit.Key.hash commit in
    Hash.to_context_hash x.

Definition commit
  (time : Tezos_base__TzPervasives.Time.Protocol.t) (message : option string)
  (context : context) : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  Tezos_base__TzPervasives.op_gt_pipe_eq (raw_commit time message context)
    (fun commit => Hash.to_context_hash (Store.Commit.hash commit)).

Definition data_key (key : list string) : list string :=
  OCaml.Stdlib.app current_data_key key.

Definition key := list string.

Definition value := string.

Definition mem (ctxt : context) (key : list string) : Lwt.t bool :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Tree.mem (tree ctxt) (data_key key)) (fun v => Lwt._return v).

Definition dir_mem (ctxt : context) (key : list string) : Lwt.t bool :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Tree.mem_tree (tree ctxt) (data_key key)) (fun v => Lwt._return v).

Definition raw_get (ctxt : context) (key : Store.key) : Lwt.t (option string) :=
  Tezos_base__TzPervasives.op_gt_pipe_eq (Store.Tree.find (tree ctxt) key)
    (Tezos_stdlib.Option.map Stdlib.Bytes.of_string).

Definition get (t : context) (key : list string) : Lwt.t (option string) :=
  raw_get t (data_key key).

Definition raw_set (ctxt : context) (key : Store.key) (data : string)
  : Lwt.t context :=
  let data := Stdlib.Bytes.to_string data in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Tree.add (tree ctxt) key None data) (fun tree => Lwt._return record).

Definition set (t : context) (key : list string) (data : string)
  : Lwt.t context := raw_set t (data_key key) data.

Definition raw_del (ctxt : context) (key : Store.key) : Lwt.t context :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Store.Tree.remove (tree ctxt) key)
    (fun tree => Lwt._return record).

Definition del (t : context) (key : list string) : Lwt.t context :=
  raw_del t (data_key key).

Definition remove_rec (ctxt : context) (key : list string) : Lwt.t context :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Tree.remove (tree ctxt) (data_key key))
    (fun tree => Lwt._return record).

Definition copy (ctxt : context) (from : list string) (to_ : list string)
  : Lwt.t (option context) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Tree.find_tree (tree ctxt) (data_key from))
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.return_none
      | Some sub_tree =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Store.Tree.add_tree (tree ctxt) (data_key to_) sub_tree)
          (fun tree => Lwt.return_some record)
      end).

Definition fold {A : Type}
  (ctxt : context) (key : list Store.step) (init : A)
  (f : variant -> A -> Lwt.t A) : Lwt.t A :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Tree.list (tree ctxt) (data_key key))
    (fun keys =>
      Lwt_list.fold_left_s
        (fun acc =>
          fun function_parameter =>
            match function_parameter with
            | (name, kind) =>
              let key :=
                match kind with
                | Contents => variant
                | Node => variant
                end in
              f key acc
            end) init keys).

Definition get_protocol (v : context)
  : Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
  Tezos_base__TzPervasives.op_gt_gt_eq (raw_get v current_protocol_key)
    (fun function_parameter =>
      match function_parameter with
      | None => false
      | Some data =>
        Lwt._return (Tezos_base__TzPervasives.Protocol_hash.of_bytes_exn data)
      end).

Definition set_protocol
  (v : context) (key : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t context :=
  let key := Tezos_base__TzPervasives.Protocol_hash.to_bytes key in
  raw_set v current_protocol_key key.

Definition get_test_chain (v : context)
  : Lwt.t Tezos_base__TzPervasives.Test_chain_status.t :=
  Tezos_base__TzPervasives.op_gt_gt_eq (raw_get v current_test_chain_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Lwt.fail
          (OCaml.Failure "Unexpected error (Context.get_test_chain)" % string)
      | Some data =>
        match
          Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
            Tezos_base__TzPervasives.Test_chain_status.encoding data with
        | None =>
          Lwt.fail
            (OCaml.Failure "Unexpected error (Context.get_test_chain)" % string)
        | Some r => Lwt._return r
        end
      end).

Definition set_test_chain
  (v : context) (id : Tezos_base__TzPervasives.Test_chain_status.t)
  : Lwt.t context :=
  let id :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
      Tezos_base__TzPervasives.Test_chain_status.encoding id in
  raw_set v current_test_chain_key id.

Definition del_test_chain (v : context) : Lwt.t context :=
  raw_del v current_test_chain_key.

Definition fork_test_chain
  (v : context) (protocol : Tezos_crypto.Protocol_hash.t)
  (expiration : Tezos_base.Time.Protocol.t) : Lwt.t context :=
  set_test_chain v
    (Forking {| protocol := protocol; expiration := expiration |}).

Definition init {A : Type}
  (patch_context : option (context -> Lwt.t context))
  (function_parameter : option A) : (option bool) -> string -> Lwt.t index :=
  match function_parameter with
  | _ =>
    fun readonly =>
      fun root =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Store.Repo.v
            (Irmin_pack.config None readonly None
              (Stdlib.op_exclamation index_log_size) root))
          (fun repo =>
            let v :=
              {| path := root; repo := repo;
                patch_context :=
                  match patch_context with
                  | None => fun ctxt => Lwt._return ctxt
                  | Some patch_context => patch_context
                  end |} in
            Stdlib.Gc.finalise
              (fun v =>
                Lwt.async
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Store.Repo.close (repo v)
                    end)) v;
            Lwt._return v)
  end.

Definition get_branch (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  : string :=
  Stdlib.Format.asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
      "%a" % string) Tezos_base__TzPervasives.Chain_id.pp chain_id.

Definition commit_genesis
  (index : index) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (time : Tezos_base__TzPervasives.Time.Protocol.t)
  (protocol : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  let tree := Store.Tree.empty in
  let ctxt := {| index := index; parents := []; tree := tree |} in
  Tezos_base__TzPervasives.op_gt_gt_eq ((patch_context index) ctxt)
    (fun ctxt =>
      Tezos_base__TzPervasives.op_gt_gt_eq (set_protocol ctxt protocol)
        (fun ctxt =>
          Tezos_base__TzPervasives.op_gt_gt_eq (set_test_chain ctxt Not_running)
            (fun ctxt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (raw_commit time (Some "Genesis" % string) ctxt)
                (fun commit =>
                  Tezos_base__TzPervasives.op_gt_pipe_eq
                    (Store.Branch.set (repo index) (get_branch chain_id) commit)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Hash.to_context_hash (Store.Commit.hash commit)
                      end))))).

Definition compute_testchain_chain_id
  (genesis : Tezos_base__TzPervasives.Block_hash.t)
  : Tezos_base__TzPervasives.Chain_id.t :=
  let genesis_hash :=
    Tezos_base__TzPervasives.Block_hash.hash_bytes None
      (cons (Tezos_base__TzPervasives.Block_hash.to_bytes genesis) []) in
  Tezos_base__TzPervasives.Chain_id.of_block_hash genesis_hash.

Definition compute_testchain_genesis
  (forked_block : Tezos_base__TzPervasives.Block_hash.t)
  : Tezos_base__TzPervasives.Block_hash.t :=
  let genesis :=
    Tezos_base__TzPervasives.Block_hash.hash_bytes None
      (cons (Tezos_base__TzPervasives.Block_hash.to_bytes forked_block) []) in
  genesis.

Definition commit_test_chain_genesis
  (ctxt : context) (forked_header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t Tezos_base__TzPervasives.Block_header.t :=
  let message :=
    Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Forking testchain at level " % string
          (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal "." % char
              CamlinternalFormatBasics.End_of_format)))
        "Forking testchain at level %ld." % string)
      (level (shell forked_header)) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (raw_commit (timestamp (shell forked_header)) (Some message) ctxt)
    (fun commit =>
      let faked_shell_header := record in
      let forked_block :=
        Tezos_base__TzPervasives.Block_header.hash forked_header in
      let genesis_hash := compute_testchain_genesis forked_block in
      let chain_id := compute_testchain_chain_id genesis_hash in
      let genesis_header :=
        {| shell := record; protocol_data := Tezos_stdlib.MBytes.create 0 |} in
      let branch := get_branch chain_id in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Store.Branch.set (repo (index ctxt)) branch commit)
        (fun function_parameter =>
          match function_parameter with
          | tt => Lwt._return genesis_header
          end)).

Definition clear_test_chain
  (index : index) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  : Lwt.t unit :=
  let branch := get_branch chain_id in
  Store.Branch.remove (repo index) branch.

Definition set_head
  (index : index) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (commit : Tezos_base__TzPervasives.Context_hash.t) : Lwt.t unit :=
  let branch := get_branch chain_id in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Commit.of_hash (repo index) (Hash.of_context_hash commit))
    (fun function_parameter =>
      match function_parameter with
      | None => false
      | Some commit => Store.Branch.set (repo index) branch commit
      end).

Definition set_master
  (index : index) (commit : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Commit.of_hash (repo index) (Hash.of_context_hash commit))
    (fun function_parameter =>
      match function_parameter with
      | None => false
      | Some commit => Store.Branch.set (repo index) Store.Branch.master commit
      end).

Module Pruned_block.
  Record t := {
    block_header : Tezos_base__TzPervasives.Block_header.t;
    operations : list (Z * (list Tezos_base__TzPervasives.Operation.t));
    operation_hashes :
      list (Z * (list Tezos_base__TzPervasives.Operation_hash.t)) }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          block_header := block_header;
            operations := operations;
            operation_hashes := operation_hashes
            |} => (operations, operation_hashes, block_header)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (operations, operation_hashes, block_header) =>
          {| block_header := block_header; operations := operations;
            operation_hashes := operation_hashes |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj3
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "operations" % string
          (Tezos_base__TzPervasives.Data_encoding.list None
            (Tezos_base__TzPervasives.Data_encoding.tup2
              Tezos_base__TzPervasives.Data_encoding.int31
              (Tezos_base__TzPervasives.Data_encoding.list None
                (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                  Tezos_base__TzPervasives.Operation.encoding)))))
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "operation_hashes" % string
          (Tezos_base__TzPervasives.Data_encoding.list None
            (Tezos_base__TzPervasives.Data_encoding.tup2
              Tezos_base__TzPervasives.Data_encoding.int31
              (Tezos_base__TzPervasives.Data_encoding.list None
                (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                  Tezos_base__TzPervasives.Operation_hash.encoding)))))
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "block_header" % string Tezos_base__TzPervasives.Block_header.encoding)).
  
  Definition to_bytes (pruned_block : t) : Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn encoding
      pruned_block.
  
  Definition of_bytes (pruned_block : Stdlib.Bytes.t) : option t :=
    Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes encoding pruned_block.
  
  Definition header (function_parameter : t)
    : Tezos_base__TzPervasives.Block_header.t :=
    match function_parameter with
    | {| block_header := block_header |} => block_header
    end.
End Pruned_block.

Module Block_data.
  Record t := {
    block_header : Tezos_base__TzPervasives.Block_header.t;
    operations : list (list Tezos_base__TzPervasives.Operation.t) }.
  
  Definition header (function_parameter : t)
    : Tezos_base__TzPervasives.Block_header.t :=
    match function_parameter with
    | {| block_header := block_header |} => block_header
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| block_header := block_header; operations := operations |} =>
          (operations, block_header)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (operations, block_header) =>
          {| block_header := block_header; operations := operations |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "operations" % string
          (Tezos_base__TzPervasives.Data_encoding.list None
            (Tezos_base__TzPervasives.Data_encoding.list None
              (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                Tezos_base__TzPervasives.Operation.encoding))))
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "block_header" % string Tezos_base__TzPervasives.Block_header.encoding)).
  
  Definition to_bytes : t -> Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn encoding.
  
  Definition of_bytes : Stdlib.Bytes.t -> option t :=
    Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes encoding.
End Block_data.

Module Protocol_data.
  Record info := {
    author : string;
    message : string;
    timestamp : Tezos_base__TzPervasives.Time.Protocol.t }.
  
  Definition info_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding info :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| author := author; message := message; timestamp := timestamp |} =>
          (author, message, timestamp)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (author, message, timestamp) =>
          {| author := author; message := message; timestamp := timestamp |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj3
        (Tezos_base__TzPervasives.Data_encoding.req None None "author" % string
          Tezos_base__TzPervasives.Data_encoding.string)
        (Tezos_base__TzPervasives.Data_encoding.req None None "message" % string
          Tezos_base__TzPervasives.Data_encoding.string)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "timestamp" % string Tezos_base__TzPervasives.Time.Protocol.encoding)).
  
  Record data := {
    info : info;
    protocol_hash : Tezos_base__TzPervasives.Protocol_hash.t;
    test_chain_status : Tezos_base__TzPervasives.Test_chain_status.t;
    data_key : Tezos_base__TzPervasives.Context_hash.t;
    parents : list Tezos_base__TzPervasives.Context_hash.t }.
  
  Definition data_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding data :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          info := info;
            protocol_hash := protocol_hash;
            test_chain_status := test_chain_status;
            data_key := data_key;
            parents := parents
            |} => (info, protocol_hash, test_chain_status, data_key, parents)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (info, protocol_hash, test_chain_status, data_key, parents) =>
          {| info := info; protocol_hash := protocol_hash;
            test_chain_status := test_chain_status; data_key := data_key;
            parents := parents |}
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj5
        (Tezos_base__TzPervasives.Data_encoding.req None None "info" % string
          info_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "protocol_hash" % string
          Tezos_base__TzPervasives.Protocol_hash.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "test_chain_status" % string
          Tezos_base__TzPervasives.Test_chain_status.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None
          "data_key" % string Tezos_base__TzPervasives.Context_hash.encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "parents" % string
          (Tezos_base__TzPervasives.Data_encoding.list None
            Tezos_base__TzPervasives.Context_hash.encoding))).
  
  Definition t := Stdlib.Int32.t * data.
  
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding (int32 * data) :=
    Tezos_base__TzPervasives.Data_encoding.tup2
      Tezos_base__TzPervasives.Data_encoding.int32 data_encoding.
  
  Definition to_bytes : (int32 * data) -> Stdlib.Bytes.t :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn encoding.
  
  Definition of_bytes : Stdlib.Bytes.t -> option (int32 * data) :=
    Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes encoding.
End Protocol_data.

Module Dumpable_context.
  Definition index := index.
  
  Definition context := context.
  
  Definition tree := Store.tree.
  
  Definition hash := variant.
  
  Definition step := string.
  
  Definition key := list step.
  
  Definition commit_info := Irmin.Info.t.
  
  Inductive batch : Type :=
  | Batch : Store.repo -> (P.Contents.t variant) -> (P.Node.t variant) -> batch.
  
  Definition batch {A : Type} (index : index) (f : batch -> Lwt.t A)
    : Lwt.t A :=
    P.Repo.batch (repo index)
      (fun x =>
        fun y =>
          fun function_parameter =>
            match function_parameter with
            | _ => f (Batch (repo index) x y)
            end).
  
  Definition commit_info_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Irmin.Info.t :=
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun irmin_info =>
        let author := Irmin.Info.author irmin_info in
        let message := Irmin.Info.message irmin_info in
        let date := Irmin.Info.date irmin_info in
        (author, message, date))
      (fun function_parameter =>
        match function_parameter with
        | (author, message, date) => Irmin.Info.v date author message
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj3
        (Tezos_base__TzPervasives.Data_encoding.req None None "author" % string
          Tezos_base__TzPervasives.Data_encoding.string)
        (Tezos_base__TzPervasives.Data_encoding.req None None "message" % string
          Tezos_base__TzPervasives.Data_encoding.string)
        (Tezos_base__TzPervasives.Data_encoding.req None None "date" % string
          Tezos_base__TzPervasives.Data_encoding.int64)).
  
  Definition hash_encoding : Tezos_base__TzPervasives.Data_encoding.t hash :=
    let kind_encoding :=
      Tezos_base__TzPervasives.Data_encoding.string_enum
        (cons ("node" % string, variant) (cons ("blob" % string, variant) []))
      in
    Tezos_base__TzPervasives.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | Blob h =>
          (variant,
            (Tezos_base__TzPervasives.Context_hash.to_bytes
              (Hash.to_context_hash h)))
        | Node h =>
          (variant,
            (Tezos_base__TzPervasives.Context_hash.to_bytes
              (Hash.to_context_hash h)))
        end)
      (fun function_parameter =>
        match function_parameter with
        | (Blob, h) => variant
        | (Node, h) => variant
        end) None
      (Tezos_base__TzPervasives.Data_encoding.obj2
        (Tezos_base__TzPervasives.Data_encoding.req None None "kind" % string
          kind_encoding)
        (Tezos_base__TzPervasives.Data_encoding.req None None "value" % string
          Tezos_base__TzPervasives.Data_encoding.bytes)).
  
  Definition context_parents (ctxt : context)
    : list Tezos_base__TzPervasives.Context_hash.t :=
    match ctxt with
    | {| parents := cons commit [] |} =>
      let parents := Store.Commit.parents commit in
      let parents :=
        Tezos_base__TzPervasives.List.map Hash.to_context_hash parents in
      Tezos_base__TzPervasives.List.sort
        Tezos_base__TzPervasives.Context_hash.compare parents
    | _ => false
    end.
  
  Definition context_info (function_parameter : context) : Irmin.Info.t :=
    match function_parameter with
    | {| parents := cons c [] |} => Store.Commit.info c
    | _ => false
    end.
  
  Definition get_context
    (idx : index) (bh : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t (option context) := checkout idx (context (Block_header.shell bh)).
  
  Definition set_context
    (info : Irmin.Info.t)
    (parents : list Tezos_base__TzPervasives.Context_hash.t) (ctxt : context)
    (bh : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
    let parents :=
      Tezos_base__TzPervasives.List.sort
        Tezos_base__TzPervasives.Context_hash.compare parents in
    let parents :=
      Tezos_base__TzPervasives.List.map Hash.of_context_hash parents in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Store.Commit.v (repo (index ctxt)) info parents (tree ctxt))
      (fun c =>
        let h := Store.Commit.hash c in
        if
          Tezos_base__TzPervasives.Context_hash.equal
            (context (Block_header.shell bh)) (Hash.to_context_hash h) then
          Lwt.return_some bh
        else
          Lwt.return_none).
  
  Definition context_tree (ctxt : context) : Store.tree := tree ctxt.
  
  Definition tree_hash (function_parameter : variant) : variant :=
    match function_parameter with
    | (Node _) as tree => variant
    | Contents (b, _) => variant
    end.
  
  Definition sub_tree (tree : Store.tree) (key : Store.key)
    : Lwt.t (option Store.tree) := Store.Tree.find_tree tree key.
  
  Definition tree_list (tree : Store.tree)
    : Lwt.t (list (Store.step * variant)) := Store.Tree.list tree [].
  
  Definition tree_content (tree : Store.tree) : Lwt.t (option Store.contents) :=
    Store.Tree.find tree [].
  
  Definition make_context (index : index) : context :=
    {| index := index; parents := []; tree := Store.Tree.empty |}.
  
  Definition update_context (context : context) (tree : Store.tree) : context :=
    record.
  
  Definition add_blob_hash (function_parameter : batch)
    : Store.tree -> Store.key -> Store.hash -> Lwt.t (option Store.tree) :=
    match function_parameter with
    | Batch repo _ _ =>
      fun tree =>
        fun key =>
          fun hash =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Store.Contents.of_hash repo hash)
              (fun function_parameter =>
                match function_parameter with
                | None => Lwt.return_none
                | Some v =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Store.Tree.add tree key None v) Lwt.return_some
                end)
    end.
  
  Definition add_node_hash (function_parameter : batch)
    : Store.tree -> Store.key -> Store.hash -> Lwt.t (option Store.tree) :=
    match function_parameter with
    | Batch repo _ _ =>
      fun tree =>
        fun key =>
          fun hash =>
            Tezos_base__TzPervasives.op_gt_gt_eq (Store.Tree.of_hash repo hash)
              (fun function_parameter =>
                match function_parameter with
                | None => Lwt.return_none
                | Some t =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Store.Tree.add_tree tree key t) Lwt.return_some
                end)
    end.
  
  Definition add_string (function_parameter : batch)
    : Store.contents -> Lwt.t Store.tree :=
    match function_parameter with
    | Batch _ t _ =>
      fun string =>
        Tezos_base__TzPervasives.op_gt_pipe_eq (Store.save_contents t string)
          (fun function_parameter =>
            match function_parameter with
            | _ => Store.Tree.of_contents None string
            end)
    end.
  
  Definition add_dir (batch : batch) (l : list (string * variant))
    : Lwt.t (option Store.tree) :=
    let fix fold_list
      (sub_tree : Store.tree) (function_parameter : list (string * variant))
      : Lwt.t (option Store.tree) :=
      match function_parameter with
      | [] => Lwt.return_some sub_tree
      | cons (step, hash) tl =>
        match hash with
        | Blob hash =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (add_blob_hash batch sub_tree (cons step []) hash)
            (fun function_parameter =>
              match function_parameter with
              | None => Lwt.return_none
              | Some sub_tree => fold_list sub_tree tl
              end)
        | Node hash =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (add_node_hash batch sub_tree (cons step []) hash)
            (fun function_parameter =>
              match function_parameter with
              | None => Lwt.return_none
              | Some sub_tree => fold_list sub_tree tl
              end)
        end
      end in
    Tezos_base__TzPervasives.op_gt_gt_eq (fold_list Store.Tree.empty l)
      (fun function_parameter =>
        match function_parameter with
        | None => Lwt.return_none
        | Some tree =>
          match batch with
          | Batch repo x y =>
            Tezos_base__TzPervasives.op_gt_pipe_eq
              (Store.save_tree (Some true) repo x y tree)
              (fun function_parameter =>
                match function_parameter with
                | _ => Some tree
                end)
          end
        end).
End Dumpable_context.

Definition data_node_hash (context : context)
  : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  Tezos_base__TzPervasives.op_gt_pipe_eq
    (Store.Tree.get_tree (tree context) current_data_key)
    (fun tree => Hash.to_context_hash (Store.Tree.hash tree)).

Definition get_protocol_data_from_header
  (index : index) (block_header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Stdlib.Int32.t * Protocol_data.data) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (checkout_exn index (context (Block_header.shell block_header)))
    (fun context =>
      let level := level (shell block_header) in
      let irmin_info := Dumpable_context.context_info context in
      let date := Irmin.Info.date irmin_info in
      let author := Irmin.Info.author irmin_info in
      let message := Irmin.Info.message irmin_info in
      let info :=
        {| Protocol_data.author := author; Protocol_data.message := message;
          Protocol_data.timestamp :=
            Tezos_base__TzPervasives.Time.Protocol.of_seconds date |} in
      let parents := Dumpable_context.context_parents context in
      Tezos_base__TzPervasives.op_gt_gt_eq (get_protocol context)
        (fun protocol_hash =>
          Tezos_base__TzPervasives.op_gt_gt_eq (get_test_chain context)
            (fun test_chain_status =>
              Tezos_base__TzPervasives.op_gt_gt_eq (data_node_hash context)
                (fun data_key =>
                  Lwt._return
                    (level,
                      {| Protocol_data.info := info;
                        Protocol_data.protocol_hash := protocol_hash;
                        Protocol_data.test_chain_status := test_chain_status;
                        Protocol_data.data_key := data_key;
                        Protocol_data.parents := parents |}))))).

Definition validate_context_hash_consistency_and_commit
  (data_hash : Tezos_base__TzPervasives.Context_hash.t)
  (expected_context_hash : Tezos_base__TzPervasives.Context_hash.t)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  (test_chain : Tezos_base__TzPervasives.Test_chain_status.t)
  (protocol_hash : Tezos_base__TzPervasives.Protocol_hash.t) (message : string)
  (author : string) (parents : list Tezos_base__TzPervasives.Context_hash.t)
  (index : index) : Lwt.t bool :=
  let data_hash := Hash.of_context_hash data_hash in
  let parents := Tezos_base__TzPervasives.List.map Hash.of_context_hash parents
    in
  let protocol_value :=
    Tezos_base__TzPervasives.Protocol_hash.to_bytes protocol_hash in
  let test_chain_value :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
      Tezos_base__TzPervasives.Test_chain_status.encoding test_chain in
  let tree := Store.Tree.empty in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Store.Tree.add tree current_protocol_key None
      (Tezos_stdlib.MBytes.to_string protocol_value))
    (fun tree =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Store.Tree.add tree current_test_chain_key None
          (Tezos_stdlib.MBytes.to_string test_chain_value))
        (fun tree =>
          let info :=
            Irmin.Info.v
              (Tezos_base__TzPervasives.Time.Protocol.to_seconds timestamp)
              author message in
          let data_tree := Store.Tree.shallow (repo index) data_hash in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Store.Tree.add_tree tree (cons "data" % string []) data_tree)
            (fun node =>
              let node := Store.Tree.hash node in
              let commit := P.Commit.Val.v info node parents in
              let computed_context_hash :=
                Hash.to_context_hash (P.Commit.Key.hash commit) in
              if
                Tezos_base__TzPervasives.Context_hash.equal
                  expected_context_hash computed_context_hash then
                let ctxt :=
                  let parent := Store.of_private_commit (repo index) commit in
                  {| index := index; parents := cons parent [];
                    tree := Store.Tree.empty |} in
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (set_test_chain ctxt test_chain)
                  (fun ctxt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (set_protocol ctxt protocol_hash)
                      (fun ctxt =>
                        let data_t := Store.Tree.shallow (repo index) data_hash
                          in
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Store.Tree.add_tree (tree ctxt) current_data_key
                            data_t)
                          (fun new_tree =>
                            Tezos_base__TzPervasives.op_gt_pipe_eq
                              (Store.Commit.v (repo (index ctxt)) info parents
                                new_tree)
                              (fun commit =>
                                let ctxt_h :=
                                  Hash.to_context_hash
                                    (Store.Commit.hash commit) in
                                Tezos_base__TzPervasives.Context_hash.equal
                                  ctxt_h expected_context_hash))))
              else
                Lwt.return_false))).

Definition dump_contexts
  (idx : Dumpable_context.index)
  (datas :
    Dumpable_context.Block_header.t * Dumpable_context.Block_data.t *
      Tezos_shell_services.History_mode.t *
      (Dumpable_context.Block_header.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            ((option Dumpable_context.Pruned_block.t) *
              (option Dumpable_context.Protocol_data.t))))) (filename : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let file_init (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Lwt_unix.file_descr) :=
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt_unix.openfile filename
          (cons O_WRONLY (cons O_CREAT (cons O_TRUNC []))) 438)
        Tezos_base__TzPervasives._return
    end in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Lwt.catch file_init
      (fun function_parameter =>
        match function_parameter with
        | Unix.Unix_error e _ _ =>
          apply Tezos_base__TzPervasives.fail
            (Cannot_create_file (Unix.error_message e))
        | exc =>
          let msg :=
            Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "unknown error: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))
                "unknown error: %s" % string) (Stdlib.Printexc.to_string exc) in
          Tezos_base__TzPervasives.fail (Cannot_create_file msg)
        end)) (fun fd => dump_contexts_fd idx datas fd).

Definition restore_contexts
  (idx : Dumpable_context.index) (filename : string)
  (k_store_pruned_block :
    (list
      (Tezos_base__TzPervasives.Block_hash.t * Dumpable_context.Pruned_block.t))
      -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (pipeline_validation :
    (option Dumpable_context.Block_header.t) ->
      Tezos_base__TzPervasives.Block_hash.t ->
        Dumpable_context.Pruned_block.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Dumpable_context.Block_header.t * Dumpable_context.Block_data.t *
        Tezos_shell_services.History_mode.t *
        (option Tezos_base__TzPervasives.Block_header.t) *
        (list Tezos_base__TzPervasives.Block_hash.t) *
        (list Dumpable_context.Protocol_data.t))) :=
  let file_init (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Lwt_unix.file_descr) :=
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt_unix.openfile filename (cons O_RDONLY []) 384)
        Tezos_base__TzPervasives._return
    end in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Lwt.catch file_init
      (fun function_parameter =>
        match function_parameter with
        | Unix.Unix_error e _ _ =>
          apply Tezos_base__TzPervasives.fail
            (Cannot_open_file (Unix.error_message e))
        | exc =>
          let msg :=
            Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "unknown error: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))
                "unknown error: %s" % string) (Stdlib.Printexc.to_string exc) in
          Tezos_base__TzPervasives.fail (Cannot_open_file msg)
        end))
    (fun fd =>
      Lwt.finalize
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (restore_contexts_fd idx fd k_store_pruned_block
                pipeline_validation)
              (fun result =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (Lwt_unix.lseek fd 0 Lwt_unix.SEEK_CUR)
                  (fun current =>
                    Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_unix.fstat fd)
                      (fun stats =>
                        let total := Lwt_unix.st_size stats in
                        if equiv_decb current total then
                          Tezos_base__TzPervasives._return result
                        else
                          apply Tezos_base__TzPervasives.fail
                            (Suspicious_file (Z.sub total current)))))
          end)
        (fun function_parameter =>
          match function_parameter with
          | tt => Lwt_unix.close fd
          end)).
src/lib_storage/context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - Versioned, block indexed (key x value) store *)

(** A block-indexed (key x value) store directory.  *)
type index

(** A (key x value) store for a given block. *)
type t

type context = t

(** Open or initialize a versioned store at a given path. *)
val init :
  ?patch_context:(context -> context Lwt.t) ->
  ?mapsize:int64 ->
  ?readonly:bool ->
  string ->
  index Lwt.t

val compute_testchain_chain_id : Block_hash.t -> Chain_id.t

val compute_testchain_genesis : Block_hash.t -> Block_hash.t

val commit_genesis :
  index ->
  chain_id:Chain_id.t ->
  time:Time.Protocol.t ->
  protocol:Protocol_hash.t ->
  Context_hash.t Lwt.t

val commit_test_chain_genesis :
  context -> Block_header.t -> Block_header.t Lwt.t

(** {2 Generic interface} *)

(** [key] indicates a path in a context. *)
type key = string list

type value = bytes

val mem : context -> key -> bool Lwt.t

val dir_mem : context -> key -> bool Lwt.t

val get : context -> key -> value option Lwt.t

val set : context -> key -> value -> t Lwt.t

val del : context -> key -> t Lwt.t

val remove_rec : context -> key -> t Lwt.t

(** [copy] returns None if the [from] key is not bound *)
val copy : context -> from:key -> to_:key -> context option Lwt.t

(** [fold] iterates over elements under a path (not recursive). Iteration order
    is undeterministic. *)
val fold :
  context ->
  key ->
  init:'a ->
  f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
  'a Lwt.t

(** {2 Accessing and Updating Versions} *)

val exists : index -> Context_hash.t -> bool Lwt.t

val checkout : index -> Context_hash.t -> context option Lwt.t

val checkout_exn : index -> Context_hash.t -> context Lwt.t

val hash : time:Time.Protocol.t -> ?message:string -> t -> Context_hash.t

val commit :
  time:Time.Protocol.t -> ?message:string -> context -> Context_hash.t Lwt.t

val set_head : index -> Chain_id.t -> Context_hash.t -> unit Lwt.t

val set_master : index -> Context_hash.t -> unit Lwt.t

(** {2 Predefined Fields} *)

val get_protocol : context -> Protocol_hash.t Lwt.t

val set_protocol : context -> Protocol_hash.t -> context Lwt.t

val get_test_chain : context -> Test_chain_status.t Lwt.t

val set_test_chain : context -> Test_chain_status.t -> context Lwt.t

val del_test_chain : context -> context Lwt.t

val fork_test_chain :
  context ->
  protocol:Protocol_hash.t ->
  expiration:Time.Protocol.t ->
  context Lwt.t

val clear_test_chain : index -> Chain_id.t -> unit Lwt.t

(** {2 Context dumping} *)

module Pruned_block : sig
  type t = {
    block_header : Block_header.t;
    operations : (int * Operation.t list) list;
    operation_hashes : (int * Operation_hash.t list) list;
  }

  val encoding : t Data_encoding.t

  val to_bytes : t -> MBytes.t

  val of_bytes : MBytes.t -> t option
end

module Block_data : sig
  type t = {block_header : Block_header.t; operations : Operation.t list list}

  val to_bytes : t -> MBytes.t

  val of_bytes : MBytes.t -> t option

  val encoding : t Data_encoding.t
end

module Protocol_data : sig
  type t = Int32.t * data

  and info = {author : string; message : string; timestamp : Time.Protocol.t}

  and data = {
    info : info;
    protocol_hash : Protocol_hash.t;
    test_chain_status : Test_chain_status.t;
    data_key : Context_hash.t;
    parents : Context_hash.t list;
  }

  val to_bytes : t -> MBytes.t

  val of_bytes : MBytes.t -> t option

  val encoding : t Data_encoding.t
end

val get_protocol_data_from_header :
  index -> Block_header.t -> Protocol_data.t Lwt.t

val dump_contexts :
  index ->
  Block_header.t
  * Block_data.t
  * History_mode.t
  * (Block_header.t ->
    (Pruned_block.t option * Protocol_data.t option) tzresult Lwt.t) ->
  filename:string ->
  unit tzresult Lwt.t

val restore_contexts :
  index ->
  filename:string ->
  ((Block_hash.t * Pruned_block.t) list -> unit tzresult Lwt.t) ->
  (Block_header.t option ->
  Block_hash.t ->
  Pruned_block.t ->
  unit tzresult Lwt.t) ->
  ( Block_header.t
  * Block_data.t
  * History_mode.t
  * Block_header.t option
  * Block_hash.t list
  * Protocol_data.t list )
  tzresult
  Lwt.t

val validate_context_hash_consistency_and_commit :
  data_hash:Context_hash.t ->
  expected_context_hash:Context_hash.t ->
  timestamp:Time.Protocol.t ->
  test_chain:Test_chain_status.t ->
  protocol_hash:Protocol_hash.t ->
  message:string ->
  author:string ->
  parents:Context_hash.t list ->
  index:index ->
  bool Lwt.t
src/lib_storage/context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter index : Type.

Parameter t : Type.

Definition context := t.

Parameter init :
(option (context -> Lwt.t context)) ->
  (option int64) -> (option bool) -> string -> Lwt.t index.

Parameter compute_testchain_chain_id :
Tezos_base__TzPervasives.Block_hash.t -> Tezos_base__TzPervasives.Chain_id.t.

Parameter compute_testchain_genesis :
Tezos_base__TzPervasives.Block_hash.t -> Tezos_base__TzPervasives.Block_hash.t.

Parameter commit_genesis :
index ->
  Tezos_base__TzPervasives.Chain_id.t ->
    Tezos_base__TzPervasives.Time.Protocol.t ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t Tezos_base__TzPervasives.Context_hash.t.

Parameter commit_test_chain_genesis :
context ->
  Tezos_base__TzPervasives.Block_header.t ->
    Lwt.t Tezos_base__TzPervasives.Block_header.t.

Definition key := list string.

Definition value := string.

Parameter mem : context -> key -> Lwt.t bool.

Parameter dir_mem : context -> key -> Lwt.t bool.

Parameter get : context -> key -> Lwt.t (option value).

Parameter set : context -> key -> value -> Lwt.t t.

Parameter del : context -> key -> Lwt.t t.

Parameter remove_rec : context -> key -> Lwt.t t.

Parameter copy : context -> key -> key -> Lwt.t (option context).

Parameter fold : forall {a variant : Type},
context -> key -> a -> (variant -> a -> Lwt.t a) -> Lwt.t a.

Parameter _exists :
index -> Tezos_base__TzPervasives.Context_hash.t -> Lwt.t bool.

Parameter checkout :
index -> Tezos_base__TzPervasives.Context_hash.t -> Lwt.t (option context).

Parameter checkout_exn :
index -> Tezos_base__TzPervasives.Context_hash.t -> Lwt.t context.

Parameter hash :
Tezos_base__TzPervasives.Time.Protocol.t ->
  (option string) -> t -> Tezos_base__TzPervasives.Context_hash.t.

Parameter commit :
Tezos_base__TzPervasives.Time.Protocol.t ->
  (option string) -> context -> Lwt.t Tezos_base__TzPervasives.Context_hash.t.

Parameter set_head :
index ->
  Tezos_base__TzPervasives.Chain_id.t ->
    Tezos_base__TzPervasives.Context_hash.t -> Lwt.t unit.

Parameter set_master :
index -> Tezos_base__TzPervasives.Context_hash.t -> Lwt.t unit.

Parameter get_protocol :
context -> Lwt.t Tezos_base__TzPervasives.Protocol_hash.t.

Parameter set_protocol :
context -> Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t context.

Parameter get_test_chain :
context -> Lwt.t Tezos_base__TzPervasives.Test_chain_status.t.

Parameter set_test_chain :
context -> Tezos_base__TzPervasives.Test_chain_status.t -> Lwt.t context.

Parameter del_test_chain : context -> Lwt.t context.

Parameter fork_test_chain :
context ->
  Tezos_base__TzPervasives.Protocol_hash.t ->
    Tezos_base__TzPervasives.Time.Protocol.t -> Lwt.t context.

Parameter clear_test_chain :
index -> Tezos_base__TzPervasives.Chain_id.t -> Lwt.t unit.

Module Pruned_block.
  Record t := {
    block_header : Tezos_base__TzPervasives.Block_header.t;
    operations : list (Z * (list Tezos_base__TzPervasives.Operation.t));
    operation_hashes :
      list (Z * (list Tezos_base__TzPervasives.Operation_hash.t)) }.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
  
  Parameter to_bytes : t -> Tezos_stdlib.MBytes.t.
  
  Parameter of_bytes : Tezos_stdlib.MBytes.t -> option t.
End Pruned_block.

Module Block_data.
  Record t := {
    block_header : Tezos_base__TzPervasives.Block_header.t;
    operations : list (list Tezos_base__TzPervasives.Operation.t) }.
  
  Parameter to_bytes : t -> Tezos_stdlib.MBytes.t.
  
  Parameter of_bytes : Tezos_stdlib.MBytes.t -> option t.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
End Block_data.

Module Protocol_data.
  Reserved Notation "'t".
  
  
  
  where "'t" := ( Stdlib.Int32.t * data).
  
  Definition t := 't.
  
  Parameter to_bytes : t -> Tezos_stdlib.MBytes.t.
  
  Parameter of_bytes : Tezos_stdlib.MBytes.t -> option t.
  
  Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.
End Protocol_data.

Parameter get_protocol_data_from_header :
index -> Tezos_base__TzPervasives.Block_header.t -> Lwt.t Protocol_data.t.

Parameter dump_contexts :
index ->
  (Tezos_base__TzPervasives.Block_header.t * Block_data.t *
    Tezos_shell_services.History_mode.t *
    (Tezos_base__TzPervasives.Block_header.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          ((option Pruned_block.t) * (option Protocol_data.t))))) ->
    string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter restore_contexts :
index ->
  string ->
    ((list (Tezos_base__TzPervasives.Block_hash.t * Pruned_block.t)) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
      ((option Tezos_base__TzPervasives.Block_header.t) ->
        Tezos_base__TzPervasives.Block_hash.t ->
          Pruned_block.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Block_header.t * Block_data.t *
              Tezos_shell_services.History_mode.t *
              (option Tezos_base__TzPervasives.Block_header.t) *
              (list Tezos_base__TzPervasives.Block_hash.t) *
              (list Protocol_data.t))).

Parameter validate_context_hash_consistency_and_commit :
Tezos_base__TzPervasives.Context_hash.t ->
  Tezos_base__TzPervasives.Context_hash.t ->
    Tezos_base__TzPervasives.Time.Protocol.t ->
      Tezos_base__TzPervasives.Test_chain_status.t ->
        Tezos_base__TzPervasives.Protocol_hash.t ->
          string ->
            string ->
              (list Tezos_base__TzPervasives.Context_hash.t) ->
                index -> Lwt.t bool.
src/lib_storage/context_dump.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let current_version = "tezos-snapshot-1.0.0"

(*****************************************************************************)
module type Dump_interface = sig
  type index

  type context

  type tree

  type hash

  type step = string

  type key = step list

  type commit_info

  type batch

  val batch : index -> (batch -> 'a Lwt.t) -> 'a Lwt.t

  val commit_info_encoding : commit_info Data_encoding.t

  val hash_encoding : hash Data_encoding.t

  module Block_header : sig
    type t = Block_header.t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val equal : t -> t -> bool

    val encoding : t Data_encoding.t
  end

  module Pruned_block : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val header : t -> Block_header.t

    val encoding : t Data_encoding.t
  end

  module Block_data : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val header : t -> Block_header.t

    val encoding : t Data_encoding.t
  end

  module Protocol_data : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val encoding : t Data_encoding.t
  end

  module Commit_hash : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t tzresult

    val encoding : t Data_encoding.t
  end

  (* commit manipulation (for parents) *)
  val context_parents : context -> Commit_hash.t list

  (* Commit info *)
  val context_info : context -> commit_info

  (* block header manipulation *)
  val get_context : index -> Block_header.t -> context option Lwt.t

  val set_context :
    info:commit_info ->
    parents:Commit_hash.t list ->
    context ->
    Block_header.t ->
    Block_header.t option Lwt.t

  (* for dumping *)
  val context_tree : context -> tree

  val tree_hash : tree -> hash

  val sub_tree : tree -> key -> tree option Lwt.t

  val tree_list : tree -> (step * [`Contents | `Node]) list Lwt.t

  val tree_content : tree -> string option Lwt.t

  (* for restoring *)
  val make_context : index -> context

  val update_context : context -> tree -> context

  val add_string : batch -> string -> tree Lwt.t

  val add_dir : batch -> (step * hash) list -> tree option Lwt.t
end

module type S = sig
  type index

  type context

  type block_header

  type block_data

  type pruned_block

  type protocol_data

  val dump_contexts_fd :
    index ->
    block_header
    * block_data
    * History_mode.t
    * (block_header ->
      (pruned_block option * protocol_data option) tzresult Lwt.t) ->
    fd:Lwt_unix.file_descr ->
    unit tzresult Lwt.t

  val restore_contexts_fd :
    index ->
    fd:Lwt_unix.file_descr ->
    ((Block_hash.t * pruned_block) list -> unit tzresult Lwt.t) ->
    (block_header option ->
    Block_hash.t ->
    pruned_block ->
    unit tzresult Lwt.t) ->
    ( block_header
    * block_data
    * History_mode.t
    * Block_header.t option
    * Block_hash.t list
    * protocol_data list )
    tzresult
    Lwt.t
end

type error += System_write_error of string

type error += Bad_hash of string * Bytes.t * Bytes.t

type error += Context_not_found of Bytes.t

type error += System_read_error of string

type error += Inconsistent_snapshot_file

type error += Inconsistent_snapshot_data

type error += Missing_snapshot_data

type error += Invalid_snapshot_version of string * string

type error += Restore_context_failure

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"Writing_error"
    ~title:"Writing error"
    ~description:"Cannot write in file for context dump"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "Unable to write file for context dumping: %s" s)
    (obj1 (req "context_dump_no_space" string))
    (function System_write_error s -> Some s | _ -> None)
    (fun s -> System_write_error s) ;
  register_error_kind
    `Permanent
    ~id:"Bad_hash"
    ~title:"Bad hash"
    ~description:"Wrong hash given"
    ~pp:(fun ppf (ty, his, hshould) ->
      Format.fprintf
        ppf
        "Wrong hash [%s] given: %s, should be %s"
        ty
        (Bytes.to_string his)
        (Bytes.to_string hshould))
    (obj3
       (req "hash_ty" string)
       (req "hash_is" bytes)
       (req "hash_should" bytes))
    (function
      | Bad_hash (ty, his, hshould) -> Some (ty, his, hshould) | _ -> None)
    (fun (ty, his, hshould) -> Bad_hash (ty, his, hshould)) ;
  register_error_kind
    `Permanent
    ~id:"Context_not_found"
    ~title:"Context not found"
    ~description:"Cannot find context corresponding to hash"
    ~pp:(fun ppf mb ->
      Format.fprintf ppf "No context with hash: %s" (Bytes.to_string mb))
    (obj1 (req "context_not_found" bytes))
    (function Context_not_found mb -> Some mb | _ -> None)
    (fun mb -> Context_not_found mb) ;
  register_error_kind
    `Permanent
    ~id:"System_read_error"
    ~title:"System read error"
    ~description:"Failed to read file"
    ~pp:(fun ppf uerr ->
      Format.fprintf
        ppf
        "Error while reading file for context dumping: %s"
        uerr)
    (obj1 (req "system_read_error" string))
    (function System_read_error e -> Some e | _ -> None)
    (fun e -> System_read_error e) ;
  register_error_kind
    `Permanent
    ~id:"Inconsistent_snapshot_file"
    ~title:"Inconsistent snapshot file"
    ~description:"Error while opening snapshot file"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Failed to read snapshot file. The provided file is inconsistent.")
    empty
    (function Inconsistent_snapshot_file -> Some () | _ -> None)
    (fun () -> Inconsistent_snapshot_file) ;
  register_error_kind
    `Permanent
    ~id:"Inconsistent_snapshot_data"
    ~title:"Inconsistent snapshot data"
    ~description:"The data provided by the snapshot is inconsistent"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "The data provided by the snapshot file is inconsistent (context_hash \
         does not correspond for block).")
    empty
    (function Inconsistent_snapshot_data -> Some () | _ -> None)
    (fun () -> Inconsistent_snapshot_data) ;
  register_error_kind
    `Permanent
    ~id:"Missing_snapshot_data"
    ~title:"Missing data in imported snapshot"
    ~description:"Mandatory data missing while reaching end of snapshot file."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Mandatory data is missing is the provided snapshot file.")
    empty
    (function Missing_snapshot_data -> Some () | _ -> None)
    (fun () -> Missing_snapshot_data) ;
  register_error_kind
    `Permanent
    ~id:"Invalid_snapshot_version"
    ~title:"Invalid snapshot version"
    ~description:"The version of the snapshot to import is not valid"
    ~pp:(fun ppf (found, expected) ->
      Format.fprintf
        ppf
        "The snapshot to import has version \"%s\" but \"%s\" was expected."
        found
        expected)
    (obj2 (req "found" string) (req "expected" string))
    (function
      | Invalid_snapshot_version (found, expected) ->
          Some (found, expected)
      | _ ->
          None)
    (fun (found, expected) -> Invalid_snapshot_version (found, expected)) ;
  register_error_kind
    `Permanent
    ~id:"Restore_context_failure"
    ~title:"Failed to restore context"
    ~description:"Internal error while restoring the context"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Internal error while restoring the context.")
    empty
    (function Restore_context_failure -> Some () | _ -> None)
    (fun () -> Restore_context_failure)

module Make (I : Dump_interface) = struct
  type command =
    | Root of {
        block_header : I.Block_header.t;
        info : I.commit_info;
        parents : I.Commit_hash.t list;
        block_data : I.Block_data.t;
      }
    | Node of (string * I.hash) list
    | Blob of string
    | Proot of I.Pruned_block.t
    | Loot of I.Protocol_data.t
    | End

  (* Command encoding. *)

  let blob_encoding =
    let open Data_encoding in
    case
      ~title:"blob"
      (Tag (Char.code 'b'))
      string
      (function Blob string -> Some string | _ -> None)
      (function string -> Blob string)

  let node_encoding =
    let open Data_encoding in
    case
      ~title:"node"
      (Tag (Char.code 'd'))
      (list (obj2 (req "name" string) (req "hash" I.hash_encoding)))
      (function Node x -> Some x | _ -> None)
      (function x -> Node x)

  let end_encoding =
    let open Data_encoding in
    case
      ~title:"end"
      (Tag (Char.code 'e'))
      empty
      (function End -> Some () | _ -> None)
      (fun () -> End)

  let loot_encoding =
    let open Data_encoding in
    case
      ~title:"loot"
      (Tag (Char.code 'l'))
      I.Protocol_data.encoding
      (function Loot protocol_data -> Some protocol_data | _ -> None)
      (fun protocol_data -> Loot protocol_data)

  let proot_encoding =
    let open Data_encoding in
    case
      ~title:"proot"
      (Tag (Char.code 'p'))
      (obj1 (req "pruned_block" I.Pruned_block.encoding))
      (function Proot pruned_block -> Some pruned_block | _ -> None)
      (fun pruned_block -> Proot pruned_block)

  let root_encoding =
    let open Data_encoding in
    case
      ~title:"root"
      (Tag (Char.code 'r'))
      (obj4
         (req "block_header" (dynamic_size I.Block_header.encoding))
         (req "info" I.commit_info_encoding)
         (req "parents" (list I.Commit_hash.encoding))
         (req "block_data" I.Block_data.encoding))
      (function
        | Root {block_header; info; parents; block_data} ->
            Some (block_header, info, parents, block_data)
        | _ ->
            None)
      (fun (block_header, info, parents, block_data) ->
        Root {block_header; info; parents; block_data})

  let command_encoding =
    Data_encoding.union
      ~tag_size:`Uint8
      [ blob_encoding;
        node_encoding;
        end_encoding;
        loot_encoding;
        proot_encoding;
        root_encoding ]

  (* IO toolkit. *)

  let rec read_string rbuf ~len =
    let (fd, buf, ofs, total) = !rbuf in
    if Bytes.length buf - ofs < len then (
      let blen = Bytes.length buf - ofs in
      let neu = Bytes.create (blen + 1_000_000) in
      Bytes.blit buf ofs neu 0 blen ;
      Lwt_unix.read fd neu blen 1_000_000
      >>= fun bread ->
      total := !total + bread ;
      if bread = 0 then fail Inconsistent_snapshot_file
      else
        let neu =
          if bread <> 1_000_000 then Bytes.sub neu 0 (blen + bread) else neu
        in
        rbuf := (fd, neu, 0, total) ;
        read_string rbuf ~len )
    else
      let res = Bytes.sub_string buf ofs len in
      rbuf := (fd, buf, ofs + len, total) ;
      return res

  let read_mbytes rbuf b =
    read_string rbuf ~len:(Bytes.length b)
    >>=? fun string ->
    Bytes.blit_string string 0 b 0 (Bytes.length b) ;
    return ()

  let set_int64 buf i =
    let b = Bytes.create 8 in
    EndianBytes.BigEndian.set_int64 b 0 i ;
    Buffer.add_bytes buf b

  let get_int64 rbuf =
    read_string ~len:8 rbuf
    >>=? fun s -> return @@ EndianString.BigEndian.get_int64 s 0

  let set_mbytes buf b =
    set_int64 buf (Int64.of_int (Bytes.length b)) ;
    Buffer.add_bytes buf b

  let get_mbytes rbuf =
    get_int64 rbuf >>|? Int64.to_int
    >>=? fun l ->
    let b = Bytes.create l in
    read_mbytes rbuf b >>=? fun () -> return b

  (* Getter and setters *)

  let get_command rbuf =
    get_mbytes rbuf
    >>|? fun bytes -> Data_encoding.Binary.of_bytes_exn command_encoding bytes

  let set_root buf block_header info parents block_data =
    let root = Root {block_header; info; parents; block_data} in
    let bytes = Data_encoding.Binary.to_bytes_exn command_encoding root in
    set_mbytes buf bytes

  let set_node buf contents =
    let bytes =
      Data_encoding.Binary.to_bytes_exn command_encoding (Node contents)
    in
    set_mbytes buf bytes

  let set_blob buf data =
    let bytes =
      Data_encoding.Binary.to_bytes_exn command_encoding (Blob data)
    in
    set_mbytes buf bytes

  let set_proot buf pruned_block =
    let proot = Proot pruned_block in
    let bytes = Data_encoding.Binary.to_bytes_exn command_encoding proot in
    set_mbytes buf bytes

  let set_loot buf protocol_data =
    let loot = Loot protocol_data in
    let bytes = Data_encoding.Binary.to_bytes_exn command_encoding loot in
    set_mbytes buf bytes

  let set_end buf =
    let bytes = Data_encoding.Binary.to_bytes_exn command_encoding End in
    set_mbytes buf bytes

  (* Snapshot metadata *)

  (* TODO add more info (e.g. nb context item, nb blocks, etc.) *)
  type snapshot_metadata = {
    version : string;
    mode : Tezos_shell_services.History_mode.t;
  }

  let snapshot_metadata_encoding =
    let open Data_encoding in
    conv
      (fun {version; mode} -> (version, mode))
      (fun (version, mode) -> {version; mode})
      (obj2
         (req "version" string)
         (req "mode" Tezos_shell_services.History_mode.encoding))

  let write_snapshot_metadata ~mode buf =
    let version = {version = current_version; mode} in
    let bytes =
      Data_encoding.(Binary.to_bytes_exn snapshot_metadata_encoding version)
    in
    set_mbytes buf bytes

  let read_snapshot_metadata rbuf =
    get_mbytes rbuf
    >>|? fun bytes ->
    Data_encoding.(Binary.of_bytes_exn snapshot_metadata_encoding) bytes

  let check_version v =
    fail_when
      (v.version <> current_version)
      (Invalid_snapshot_version (v.version, current_version))

  let dump_contexts_fd idx data ~fd =
    (* Dumping *)
    let buf = Buffer.create 1_000_000 in
    let written = ref 0 in
    let flush () =
      let contents = Buffer.contents buf in
      Buffer.clear buf ;
      written := !written + String.length contents ;
      Lwt_utils_unix.write_string fd contents
    in
    let maybe_flush () =
      if Buffer.length buf > 1_000_000 then flush () else Lwt.return_unit
    in
    (* Noting the visited hashes *)
    let visited_hash = Hashtbl.create 1000 in
    let visited h = Hashtbl.mem visited_hash h in
    let set_visit h = Hashtbl.add visited_hash h () in
    (* Folding through a node *)
    let fold_tree_path ctxt tree =
      let cpt = ref 0 in
      let rec fold_tree_path ctxt tree =
        I.tree_list tree
        >>= fun keys ->
        let keys = List.sort (fun (a, _) (b, _) -> String.compare a b) keys in
        Lwt_list.map_s
          (fun (name, kind) ->
            I.sub_tree tree [name]
            >>= function
            | None ->
                assert false
            | Some sub_tree ->
                let hash = I.tree_hash sub_tree in
                ( if visited hash then Lwt.return_unit
                else (
                  Tezos_stdlib_unix.Utils.display_progress
                    ~refresh_rate:(!cpt, 1_000)
                    "Context: %dK elements, %dMiB written%!"
                    (!cpt / 1_000)
                    (!written / 1_048_576) ;
                  incr cpt ;
                  set_visit hash ;
                  (* There cannot be a cycle *)
                  match kind with
                  | `Node ->
                      fold_tree_path ctxt sub_tree
                  | `Contents -> (
                      I.tree_content sub_tree
                      >>= function
                      | None ->
                          assert false
                      | Some data ->
                          set_blob buf data ; maybe_flush () ) ) )
                >|= fun () -> (name, hash))
          keys
        >>= fun sub_keys -> set_node buf sub_keys ; maybe_flush ()
      in
      fold_tree_path ctxt tree
    in
    Lwt.catch
      (fun () ->
        let (bh, block_data, mode, pruned_iterator) = data in
        write_snapshot_metadata ~mode buf ;
        I.get_context idx bh
        >>= function
        | None ->
            fail @@ Context_not_found (I.Block_header.to_bytes bh)
        | Some ctxt ->
            let tree = I.context_tree ctxt in
            fold_tree_path ctxt tree
            >>= fun () ->
            Tezos_stdlib_unix.Utils.display_progress_end () ;
            let parents = I.context_parents ctxt in
            set_root buf bh (I.context_info ctxt) parents block_data ;
            (* Dump pruned blocks *)
            let dump_pruned cpt pruned =
              Tezos_stdlib_unix.Utils.display_progress
                ~refresh_rate:(cpt, 1_000)
                "History: %dK block, %dMiB written"
                (cpt / 1_000)
                (!written / 1_048_576) ;
              set_proot buf pruned ;
              maybe_flush ()
            in
            let rec aux cpt acc header =
              pruned_iterator header
              >>=? function
              | (None, None) ->
                  return acc (* assert false *)
              | (None, Some protocol_data) ->
                  return (protocol_data :: acc)
              | (Some pred_pruned, Some protocol_data) ->
                  dump_pruned cpt pred_pruned
                  >>= fun () ->
                  aux
                    (succ cpt)
                    (protocol_data :: acc)
                    (I.Pruned_block.header pred_pruned)
              | (Some pred_pruned, None) ->
                  dump_pruned cpt pred_pruned
                  >>= fun () ->
                  aux (succ cpt) acc (I.Pruned_block.header pred_pruned)
            in
            let starting_block_header = I.Block_data.header block_data in
            aux 0 [] starting_block_header
            >>=? fun protocol_datas ->
            (* Dump protocol data *)
            Lwt_list.iter_s
              (fun proto -> set_loot buf proto ; maybe_flush ())
              protocol_datas
            >>= fun () ->
            Tezos_stdlib_unix.Utils.display_progress_end () ;
            return_unit
            >>=? fun () ->
            set_end buf ;
            flush () >>= fun () -> return_unit)
      (function
        | Unix.Unix_error (e, _, _) ->
            fail @@ System_write_error (Unix.error_message e)
        | err ->
            Lwt.fail err)

  (* Restoring *)

  let restore_contexts_fd index ~fd k_store_pruned_blocks block_validation =
    let read = ref 0 in
    let rbuf = ref (fd, Bytes.empty, 0, read) in
    (* Editing the repository *)
    let add_blob t blob = I.add_string t blob >>= fun tree -> return tree in
    let add_dir t keys =
      I.add_dir t keys
      >>= function
      | None -> fail Restore_context_failure | Some tree -> return tree
    in
    let restore history_mode =
      let rec first_pass batch ctxt cpt =
        Tezos_stdlib_unix.Utils.display_progress
          ~refresh_rate:(cpt, 1_000)
          "Context: %dK elements, %dMiB read"
          (cpt / 1_000)
          (!read / 1_048_576) ;
        get_command rbuf
        >>=? function
        | Root {block_header; info; parents; block_data} -> (
            I.set_context ~info ~parents ctxt block_header
            >>= function
            | None ->
                fail Inconsistent_snapshot_data
            | Some block_header ->
                return (block_header, block_data) )
        | Node contents ->
            add_dir batch contents
            >>=? fun tree ->
            first_pass batch (I.update_context ctxt tree) (cpt + 1)
        | Blob data ->
            add_blob batch data
            >>=? fun tree ->
            first_pass batch (I.update_context ctxt tree) (cpt + 1)
        | _ ->
            fail Inconsistent_snapshot_data
      in
      let rec second_pass pred_header (rev_block_hashes, protocol_datas) todo
          cpt =
        Tezos_stdlib_unix.Utils.display_progress
          ~refresh_rate:(cpt, 1_000)
          "Store: %dK elements, %dMiB read"
          (cpt / 1_000)
          (!read / 1_048_576) ;
        get_command rbuf
        >>=? function
        | Proot pruned_block ->
            let header = I.Pruned_block.header pruned_block in
            let hash = Block_header.hash header in
            block_validation pred_header hash pruned_block
            >>=? fun () ->
            if (cpt + 1) mod 5_000 = 0 then
              k_store_pruned_blocks ((hash, pruned_block) :: todo)
              >>=? fun () ->
              second_pass
                (Some header)
                (hash :: rev_block_hashes, protocol_datas)
                []
                (cpt + 1)
            else
              second_pass
                (Some header)
                (hash :: rev_block_hashes, protocol_datas)
                ((hash, pruned_block) :: todo)
                (cpt + 1)
        | Loot protocol_data ->
            k_store_pruned_blocks todo
            >>=? fun () ->
            second_pass
              pred_header
              (rev_block_hashes, protocol_data :: protocol_datas)
              todo
              (cpt + 1)
        | End ->
            return (pred_header, rev_block_hashes, List.rev protocol_datas)
        | _ ->
            fail Inconsistent_snapshot_data
      in
      I.batch index (fun batch -> first_pass batch (I.make_context index) 0)
      >>=? fun (block_header, block_data) ->
      Tezos_stdlib_unix.Utils.display_progress_end () ;
      second_pass None ([], []) [] 0
      >>=? fun (oldest_header_opt, rev_block_hashes, protocol_datas) ->
      Tezos_stdlib_unix.Utils.display_progress_end () ;
      return
        ( block_header,
          block_data,
          history_mode,
          oldest_header_opt,
          rev_block_hashes,
          protocol_datas )
    in
    (* Check snapshot version *)
    read_snapshot_metadata rbuf
    >>=? fun version ->
    check_version version
    >>=? fun () ->
    Lwt.catch
      (fun () -> restore version.mode)
      (function
        | Unix.Unix_error (e, _, _) ->
            fail @@ System_read_error (Unix.error_message e)
        | err ->
            Lwt.fail err)
end
src/lib_storage/context_dump.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition current_version : string := "tezos-snapshot-1.0.0" % string.

Module Dump_interface.
  Record signature {index context tree hash commit_info batch Pruned_block_t
    Block_data_t Protocol_data_t Commit_hash_t : Type} := {
    index := index;
    context := context;
    tree := tree;
    hash := hash;
    step := string;
    key := list step;
    commit_info := commit_info;
    batch := batch;
    batch : forall {a : Type}, index -> (batch -> Lwt.t a) -> Lwt.t a;
    commit_info_encoding : Tezos_base__TzPervasives.Data_encoding.t commit_info;
    hash_encoding : Tezos_base__TzPervasives.Data_encoding.t hash;
    Block_header : signature;
    Pruned_block : signature;
    Block_data : signature;
    Protocol_data : signature;
    Commit_hash : signature;
    context_parents : context -> list Commit_hash.t;
    context_info : context -> commit_info;
    get_context : index -> Block_header.t -> Lwt.t (option context);
    set_context : commit_info ->
      (list Commit_hash.t) ->
        context -> Block_header.t -> Lwt.t (option Block_header.t);
    context_tree : context -> tree;
    tree_hash : tree -> hash;
    sub_tree : tree -> key -> Lwt.t (option tree);
    tree_list : forall {variant : Type}, tree -> Lwt.t (list (step * variant));
    tree_content : tree -> Lwt.t (option string);
    make_context : index -> context;
    update_context : context -> tree -> context;
    add_string : batch -> string -> Lwt.t tree;
    add_dir : batch -> (list (step * hash)) -> Lwt.t (option tree);
  }.
  Arguments signature : clear implicits.
End Dump_interface.

Module S.
  Record signature {index context block_header block_data pruned_block
    protocol_data : Type} := {
    index := index;
    context := context;
    block_header := block_header;
    block_data := block_data;
    pruned_block := pruned_block;
    protocol_data := protocol_data;
    dump_contexts_fd : index ->
      (block_header * block_data * Tezos_shell_services.History_mode.t *
        (block_header ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              ((option pruned_block) * (option protocol_data))))) ->
        Lwt_unix.file_descr -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    restore_contexts_fd : index ->
      Lwt_unix.file_descr ->
        ((list (Tezos_base__TzPervasives.Block_hash.t * pruned_block)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
          ((option block_header) ->
            Tezos_base__TzPervasives.Block_hash.t ->
              pruned_block -> Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                (block_header * block_data * Tezos_shell_services.History_mode.t
                  * (option Tezos_base__TzPervasives.Block_header.t) *
                  (list Tezos_base__TzPervasives.Block_hash.t) *
                  (list protocol_data)));
  }.
  Arguments signature : clear implicits.
End S.
src/lib_storage/context_dump.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += System_write_error of string

type error += Bad_hash of string * Bytes.t * Bytes.t

type error += Context_not_found of Bytes.t

type error += System_read_error of string

type error += Inconsistent_snapshot_file

type error += Inconsistent_snapshot_data

type error += Missing_snapshot_data

type error += Invalid_snapshot_version of string * string

type error += Restore_context_failure

module type Dump_interface = sig
  type index

  type context

  type tree

  type hash

  type step = string

  type key = step list

  type commit_info

  type batch

  val batch : index -> (batch -> 'a Lwt.t) -> 'a Lwt.t

  val commit_info_encoding : commit_info Data_encoding.t

  val hash_encoding : hash Data_encoding.t

  module Block_header : sig
    type t = Block_header.t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val equal : t -> t -> bool

    val encoding : t Data_encoding.t
  end

  module Pruned_block : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val header : t -> Block_header.t

    val encoding : t Data_encoding.t
  end

  module Block_data : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val header : t -> Block_header.t

    val encoding : t Data_encoding.t
  end

  module Protocol_data : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val encoding : t Data_encoding.t
  end

  module Commit_hash : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t tzresult

    val encoding : t Data_encoding.t
  end

  (* commit manipulation (for parents) *)
  val context_parents : context -> Commit_hash.t list

  (* Commit info *)
  val context_info : context -> commit_info

  (* block header manipulation *)
  val get_context : index -> Block_header.t -> context option Lwt.t

  val set_context :
    info:commit_info ->
    parents:Commit_hash.t list ->
    context ->
    Block_header.t ->
    Block_header.t option Lwt.t

  (* for dumping *)
  val context_tree : context -> tree

  val tree_hash : tree -> hash

  val sub_tree : tree -> key -> tree option Lwt.t

  val tree_list : tree -> (step * [`Contents | `Node]) list Lwt.t

  val tree_content : tree -> string option Lwt.t

  (* for restoring *)
  val make_context : index -> context

  val update_context : context -> tree -> context

  val add_string : batch -> string -> tree Lwt.t

  val add_dir : batch -> (step * hash) list -> tree option Lwt.t
end

module type S = sig
  type index

  type context

  type block_header

  type block_data

  type pruned_block

  type protocol_data

  val dump_contexts_fd :
    index ->
    block_header
    * block_data
    * History_mode.t
    * (block_header ->
      (pruned_block option * protocol_data option) tzresult Lwt.t) ->
    fd:Lwt_unix.file_descr ->
    unit tzresult Lwt.t

  val restore_contexts_fd :
    index ->
    fd:Lwt_unix.file_descr ->
    ((Block_hash.t * pruned_block) list -> unit tzresult Lwt.t) ->
    (block_header option ->
    Block_hash.t ->
    pruned_block ->
    unit tzresult Lwt.t) ->
    ( block_header
    * block_data
    * History_mode.t
    * Block_header.t option
    * Block_hash.t list
    * protocol_data list )
    tzresult
    Lwt.t
end

module Make (I : Dump_interface) :
  S
    with type index := I.index
     and type context := I.context
     and type block_header := I.Block_header.t
     and type block_data := I.Block_data.t
     and type pruned_block := I.Pruned_block.t
     and type protocol_data := I.Protocol_data.t
src/lib_storage/context_dump.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

module_type

module_type

unhandled_module
src/lib_storage/raw_store.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Rresult

type t = {
  dir : Lmdb.t;
  parent : (Lmdb.rw Lmdb.txn * Lmdb.db * Lmdb.rw Lmdb.cursor) Lwt.key;
}

type key = string list

type value = Bytes.t

type error += Unknown of string list

let () =
  Error_monad.register_error_kind
    `Permanent
    ~id:"raw_store.unknown"
    ~title:"Missing key in store"
    ~description:"Missing key in store"
    ~pp:(fun ppf keys ->
      Format.fprintf ppf "Missing key in store: %s" (String.concat "/" keys))
    Data_encoding.(obj1 (req "key" (list string)))
    (function Unknown keys -> Some keys | _ -> None)
    (fun keys -> Unknown keys)

let concat = String.concat "/"

let split = String.split_on_char '/'

let lwt_fail_error err = Lwt.fail_with (Lmdb.string_of_error err)

let of_result = function
  | Ok res ->
      Lwt.return res
  | Error err ->
      lwt_fail_error err

let ( >>=? ) v f = match v with Error err -> lwt_fail_error err | Ok v -> f v

let init ?(readonly = false) ?mapsize path =
  if not (Sys.file_exists path) then Unix.mkdir path 0o755 ;
  let sync_flag =
    match Sys.getenv_opt "TEZOS_STORE_SYNC" with
    | None ->
        []
    | Some s -> (
      match String.lowercase_ascii s with
      | "nosync" ->
          [Lmdb.NoSync]
      | "nometasync" ->
          [Lmdb.NoMetaSync]
      | _ ->
          Printf.eprintf
            "Unrecognized TEZOS_STORE_SYNC option : %s\n\
             allowed: nosync nometasync"
            s ;
          [] )
  in
  let readonly_flag = if readonly then [Lmdb.RdOnly] else [] in
  let file_flags = if readonly then 0o444 else 0o644 in
  match
    Lmdb.opendir
      ?mapsize
      ~flags:(sync_flag @ readonly_flag @ [NoTLS; NoMetaSync])
      path
      file_flags
  with
  | Ok dir ->
      return {dir; parent = Lwt.new_key ()}
  | Error err ->
      failwith "%a" Lmdb.pp_error err

let close {dir; _} = Lmdb.closedir dir

let known {dir; parent} key =
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.mem txn db (concat key)
  | None ->
      Lmdb.with_ro_db dir ~f:(fun txn db -> Lmdb.mem txn db (concat key)) )
  |> of_result

let read_opt {dir; parent} key =
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.get txn db (concat key) >>| Bigstring.to_bytes
  | None ->
      Lmdb.with_ro_db dir ~f:(fun txn db ->
          Lmdb.get txn db (concat key) >>| Bigstring.to_bytes) )
  |> function
  | Ok v ->
      Lwt.return_some v
  | Error KeyNotFound ->
      Lwt.return_none
  | Error err ->
      lwt_fail_error err

let read {dir; parent} key =
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.get txn db (concat key) >>| Bigstring.to_bytes
  | None ->
      Lmdb.with_ro_db dir ~f:(fun txn db ->
          Lmdb.get txn db (concat key) >>| Bigstring.to_bytes) )
  |> function Ok v -> return v | Error _err -> fail (Unknown key)

let store {dir; parent} k v =
  let v = Bigstring.of_bytes v in
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.put txn db (concat k) v
  | None ->
      Lmdb.with_rw_db dir ~f:(fun txn db -> Lmdb.put txn db (concat k) v) )
  |> of_result

let remove {dir; parent} k =
  let remove txn db =
    match Lmdb.del txn db (concat k) with
    | Ok () ->
        Ok ()
    | Error KeyNotFound ->
        Ok ()
    | Error err ->
        Error err
  in
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      remove txn db
  | None ->
      Lmdb.with_rw_db dir ~f:remove )
  |> of_result

let is_prefix s s' =
  String.(length s <= length s' && compare s (sub s' 0 (length s)) = 0)

let known_dir {dir; parent} k =
  let k = concat k in
  let cursor_fun cursor =
    Lmdb.cursor_at cursor k
    >>= fun () ->
    Lmdb.cursor_get cursor
    >>| fun (first_k, _v) -> is_prefix k (Bigstring.to_string first_k)
  in
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.with_cursor txn db ~f:cursor_fun
  | None ->
      Lmdb.with_ro_db dir ~f:(fun txn db ->
          Lmdb.with_cursor txn db ~f:cursor_fun) )
  |> of_result

let remove_dir {dir; parent} k =
  let k = concat k in
  let cursor_fun cursor =
    Lmdb.cursor_at cursor k
    >>= fun () ->
    Lmdb.cursor_iter cursor ~f:(fun (kk, _v) ->
        let kk_string = Bigstring.to_string kk in
        if is_prefix k kk_string then Lmdb.cursor_del cursor
        else Error KeyNotFound)
  in
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.with_cursor txn db ~f:cursor_fun
  | None ->
      Lmdb.with_rw_db dir ~f:(fun txn db ->
          Lmdb.with_cursor txn db ~f:cursor_fun) )
  |> function
  | Error KeyNotFound | Ok () ->
      Lwt.return_unit
  | Error err ->
      lwt_fail_error err

let list_equal l1 l2 len =
  if len < 0 || len > List.length l1 || len > List.length l2 then
    invalid_arg "list_compare: invalid len" ;
  let rec inner l1 l2 len =
    match (len, l1, l2) with
    | (0, _, _) ->
        true
    | (_, [], _) | (_, _, []) ->
        false
    | (_, h1 :: t1, h2 :: t2) ->
        if h1 <> h2 then false else inner t1 t2 (pred len)
  in
  inner l1 l2 len

let is_child ~parent ~child =
  let plen = List.length parent in
  let clen = List.length child in
  clen > plen && list_equal parent child plen

let list_sub l pos len =
  if len < 0 || pos < 0 || pos + len > List.length l then
    invalid_arg "list_sub" ;
  let rec inner (acc, n) = function
    | [] ->
        List.rev acc
    | h :: t ->
        if n = 0 then List.rev acc else inner (h :: acc, pred n) t
  in
  inner ([], len) l

let with_rw_cursor_lwt ?nosync ?nometasync ?flags ?name {dir; parent} ~f =
  let local_parent =
    match Lwt.get parent with
    | None ->
        None
    | Some (txn, _db, _cursor) ->
        Some txn
  in
  Lmdb.create_rw_txn ?nosync ?nometasync ?parent:local_parent dir
  >>=? fun txn ->
  Lmdb.opendb ?flags ?name txn
  >>=? fun db ->
  Lmdb.opencursor txn db
  >>=? fun cursor ->
  Lwt.with_value
    parent
    (Some (txn, db, cursor))
    (fun () ->
      Lwt.try_bind
        (fun () -> f cursor)
        (fun res ->
          Lmdb.cursor_close cursor ;
          Lmdb.commit_txn txn >>=? fun () -> Lwt.return res)
        (fun exn ->
          Lmdb.cursor_close cursor ; Lmdb.abort_txn txn ; Lwt.fail exn))

let cursor_next_lwt cursor acc f =
  match Lmdb.cursor_next cursor with
  | Error KeyNotFound ->
      acc
  | Error err ->
      lwt_fail_error err
  | Ok () ->
      Lwt.bind acc f

let cursor_at_lwt cursor k acc f =
  match Lmdb.cursor_at cursor (concat k) with
  | Error KeyNotFound ->
      acc
  | Error err ->
      lwt_fail_error err
  | Ok () ->
      Lwt.bind acc f

(* assumption: store path segments have only characters different than
   the separator '/', which immediately precedes '0' *)
let zero_char_str = String.make 1 (Char.chr (Char.code '/' + 1))

let next_key_after_subdirs = function
  | [] ->
      [zero_char_str]
  | _ :: _ as path ->
      List.sub path (List.length path - 1)
      @ [List.last_exn path ^ zero_char_str]

let fold t k ~init ~f =
  let base_len = List.length k in
  let rec inner ht cursor acc =
    Lmdb.cursor_get cursor
    >>=? fun (kk, _v) ->
    let kk = Bigstring.to_string kk in
    let kk_split = split kk in
    match is_child ~child:kk_split ~parent:k with
    | false ->
        Lwt.return acc
    | true ->
        let cur_len = List.length kk_split in
        if cur_len = succ base_len then
          cursor_next_lwt cursor (f (`Key kk_split) acc) (inner ht cursor)
        else
          let dir = list_sub kk_split 0 (succ base_len) in
          if Hashtbl.mem ht dir then
            cursor_at_lwt
              cursor
              (next_key_after_subdirs dir)
              (Lwt.return acc)
              (inner ht cursor)
          else (
            Hashtbl.add ht dir () ;
            cursor_next_lwt cursor (f (`Dir dir) acc) (inner ht cursor) )
  in
  with_rw_cursor_lwt t ~f:(fun cursor ->
      cursor_at_lwt cursor k (Lwt.return init) (fun acc ->
          let ht = Hashtbl.create 31 in
          inner ht cursor acc))

let fold_keys t k ~init ~f =
  with_rw_cursor_lwt t ~f:(fun cursor ->
      cursor_at_lwt
        cursor
        k
        (Lwt.return init)
        (let rec inner acc =
           Lmdb.cursor_get cursor
           >>=? fun (kk, _v) ->
           let kk = Bigstring.to_string kk in
           let kk_split = split kk in
           match is_child ~child:kk_split ~parent:k with
           | false ->
               Lwt.return acc
           | true ->
               cursor_next_lwt cursor (f kk_split acc) inner
         in
         inner))

let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

let open_with_atomic_rw ?mapsize path f =
  let open Error_monad in
  init ?mapsize path
  >>=? fun state ->
  with_rw_cursor_lwt state ~f:(fun _c -> f state)
  >>=? fun res -> close state ; return res

let with_atomic_rw state f = with_rw_cursor_lwt state ~f:(fun _c -> f ())
src/lib_storage/raw_store.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Rresult.

Record t := {
  dir : Lmdb.t;
  parent : Lwt.key ((Lmdb.txn Lmdb.rw) * Lmdb.db * (Lmdb.cursor Lmdb.rw)) }.

Definition key := list string.

Definition value := Stdlib.Bytes.t.

Definition concat : (list string) -> string :=
  Tezos_base__TzPervasives.String.concat "/" % string.

Definition split : string -> list string :=
  Tezos_base__TzPervasives.String.split_on_char "/" % char.

Definition lwt_fail_error {A : Type} (err : Lmdb.error) : Lwt.t A :=
  Lwt.fail_with (Lmdb.string_of_error err).

Definition of_result {A : Type}
  (function_parameter : Rresult.result A Lmdb.error) : Lwt.t A :=
  match function_parameter with
  | inl res => Lwt._return res
  | inr err => lwt_fail_error err
  end.

Definition op_gt_gt_eq_question {A B : Type}
  (v : Rresult.result A Lmdb.error) (f : A -> Lwt.t B) : Lwt.t B :=
  match v with
  | inr err => lwt_fail_error err
  | inl v => f v
  end.

Definition init (op_star_o_p_t_star : option bool)
  : (option int64) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let readonly :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun mapsize =>
    fun path =>
      if negb (Stdlib.Sys.file_exists path) then
        Unix.mkdir path 493
      else
        tt;
      let sync_flag :=
        match Stdlib.Sys.getenv_opt "TEZOS_STORE_SYNC" % string with
        | None => []
        | Some s =>
          match Tezos_base__TzPervasives.String.lowercase_ascii s with
          | "nosync" % string => cons Lmdb.NoSync []
          | "nometasync" % string => cons Lmdb.NoMetaSync []
          | _ =>
            Stdlib.Printf.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Unrecognized TEZOS_STORE_SYNC option : " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      "
allowed: nosync nometasync" % string
                      CamlinternalFormatBasics.End_of_format)))
                "Unrecognized TEZOS_STORE_SYNC option : %s
allowed: nosync nometasync"
                  % string) s;
            []
          end
        end in
      let readonly_flag :=
        if readonly then
          cons Lmdb.RdOnly []
        else
          [] in
      let file_flags :=
        if readonly then
          292
        else
          420 in
      match
        Lmdb.opendir None None mapsize
          (Some
            (OCaml.Stdlib.app sync_flag
              (OCaml.Stdlib.app readonly_flag (cons NoTLS (cons NoMetaSync [])))))
          path file_flags with
      | inl dir =>
        Tezos_base__TzPervasives._return
          {| dir := dir; parent := Lwt.new_key tt |}
      | inr err =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Lmdb.pp_error err
      end.

Definition close (function_parameter : t) : unit :=
  match function_parameter with
  | {| dir := dir |} => Lmdb.closedir dir
  end.

Definition known (function_parameter : t) : (list string) -> Lwt.t bool :=
  match function_parameter with
  | {| dir := dir; parent := parent |} =>
    fun key =>
      OCaml.Stdlib.reverse_apply
        match Lwt.get parent with
        | Some (txn, db, _cursor) => Lmdb.mem txn db (concat key)
        | None =>
          Lmdb.with_ro_db None None None None None dir
            (fun txn => fun db => Lmdb.mem txn db (concat key))
        end of_result
  end.

Definition read_opt (function_parameter : t)
  : (list string) -> Lwt.t (option Stdlib.Bytes.t) :=
  match function_parameter with
  | {| dir := dir; parent := parent |} =>
    fun key =>
      OCaml.Stdlib.reverse_apply
        match Lwt.get parent with
        | Some (txn, db, _cursor) =>
          Rresult.op_gt_gt_pipe (Lmdb.get txn db (concat key))
            Bigstring.to_bytes
        | None =>
          Lmdb.with_ro_db None None None None None dir
            (fun txn =>
              fun db =>
                Rresult.op_gt_gt_pipe (Lmdb.get txn db (concat key))
                  Bigstring.to_bytes)
        end
        (fun function_parameter =>
          match function_parameter with
          | inl v => Lwt.return_some v
          | inr KeyNotFound => Lwt.return_none
          | inr err => lwt_fail_error err
          end)
  end.

Definition read (function_parameter : t)
  : (list string) -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  match function_parameter with
  | {| dir := dir; parent := parent |} =>
    fun key =>
      OCaml.Stdlib.reverse_apply
        match Lwt.get parent with
        | Some (txn, db, _cursor) =>
          Rresult.op_gt_gt_pipe (Lmdb.get txn db (concat key))
            Bigstring.to_bytes
        | None =>
          Lmdb.with_ro_db None None None None None dir
            (fun txn =>
              fun db =>
                Rresult.op_gt_gt_pipe (Lmdb.get txn db (concat key))
                  Bigstring.to_bytes)
        end
        (fun function_parameter =>
          match function_parameter with
          | inl v => Tezos_base__TzPervasives._return v
          | inr _err => Tezos_base__TzPervasives.fail (Unknown key)
          end)
  end.

Definition store (function_parameter : t)
  : (list string) -> Stdlib.Bytes.t -> Lwt.t unit :=
  match function_parameter with
  | {| dir := dir; parent := parent |} =>
    fun k =>
      fun v =>
        let v := Bigstring.of_bytes v in
        OCaml.Stdlib.reverse_apply
          match Lwt.get parent with
          | Some (txn, db, _cursor) => Lmdb.put None txn db (concat k) v
          | None =>
            Lmdb.with_rw_db None None None None None dir
              (fun txn => fun db => Lmdb.put None txn db (concat k) v)
          end of_result
  end.

Definition remove (function_parameter : t) : (list string) -> Lwt.t unit :=
  match function_parameter with
  | {| dir := dir; parent := parent |} =>
    fun k =>
      let remove (txn : Lmdb.txn Lmdb.rw) (db : Lmdb.db)
        : Rresult.result unit Lmdb.error :=
        match Lmdb.del None txn db (concat k) with
        | inl tt => inl tt
        | inr KeyNotFound => inl tt
        | inr err => inr err
        end in
      OCaml.Stdlib.reverse_apply
        match Lwt.get parent with
        | Some (txn, db, _cursor) => remove txn db
        | None => Lmdb.with_rw_db None None None None None dir remove
        end of_result
  end.

Definition is_prefix (s : Tezos_base__TzPervasives.String.t) (s' : string)
  : bool :=
  andb
    (OCaml.Stdlib.le (Tezos_base__TzPervasives.String.length s)
      (Tezos_base__TzPervasives.String.length s'))
    (equiv_decb
      (Tezos_base__TzPervasives.String.compare s
        (Tezos_base__TzPervasives.String.sub s' 0
          (Tezos_base__TzPervasives.String.length s))) 0).

Definition known_dir (function_parameter : t) : (list string) -> Lwt.t bool :=
  match function_parameter with
  | {| dir := dir; parent := parent |} =>
    fun k =>
      let k := concat k in
      let cursor_fun {A : Type} (cursor : Lmdb.cursor A)
        : Result.result bool Lmdb.error :=
        Rresult.op_gt_gt_eq (Lmdb.cursor_at cursor k)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Rresult.op_gt_gt_pipe (Lmdb.cursor_get cursor)
                (fun function_parameter =>
                  match function_parameter with
                  | (first_k, _v) => is_prefix k (Bigstring.to_string first_k)
                  end)
            end) in
      OCaml.Stdlib.reverse_apply
        match Lwt.get parent with
        | Some (txn, db, _cursor) => Lmdb.with_cursor txn db cursor_fun
        | None =>
          Lmdb.with_ro_db None None None None None dir
            (fun txn => fun db => Lmdb.with_cursor txn db cursor_fun)
        end of_result
  end.

Definition remove_dir (function_parameter : t) : (list string) -> Lwt.t unit :=
  match function_parameter with
  | {| dir := dir; parent := parent |} =>
    fun k =>
      let k := concat k in
      let cursor_fun (cursor : Lmdb.cursor Lmdb.rw)
        : Result.result unit Lmdb.error :=
        Rresult.op_gt_gt_eq (Lmdb.cursor_at cursor k)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Lmdb.cursor_iter
                (fun function_parameter =>
                  match function_parameter with
                  | (kk, _v) =>
                    let kk_string := Bigstring.to_string kk in
                    if is_prefix k kk_string then
                      Lmdb.cursor_del None cursor
                    else
                      inr KeyNotFound
                  end) cursor
            end) in
      OCaml.Stdlib.reverse_apply
        match Lwt.get parent with
        | Some (txn, db, _cursor) => Lmdb.with_cursor txn db cursor_fun
        | None =>
          Lmdb.with_rw_db None None None None None dir
            (fun txn => fun db => Lmdb.with_cursor txn db cursor_fun)
        end
        (fun function_parameter =>
          match function_parameter with
          | inr KeyNotFound | inl tt => Lwt.return_unit
          | inr err => lwt_fail_error err
          end)
  end.

Definition list_equal {A : Type} (l1 : list A) (l2 : list A) (len : Z) : bool :=
  if
    orb (OCaml.Stdlib.lt len 0)
      (orb (OCaml.Stdlib.gt len (Tezos_base__TzPervasives.List.length l1))
        (OCaml.Stdlib.gt len (Tezos_base__TzPervasives.List.length l2))) then
    OCaml.Stdlib.invalid_arg "list_compare: invalid len" % string
  else
    tt;
  let fix inner {B : Type} (l1 : list B) (l2 : list B) (len : Z) : bool :=
    match (len, l1, l2) with
    | (0, _, _) => true
    | (_, [], _) | (_, _, []) => false
    | (_, cons h1 t1, cons h2 t2) =>
      if nequiv_decb h1 h2 then
        false
      else
        inner t1 t2 (Z.pred len)
    end in
  inner l1 l2 len.

Definition is_child {A : Type} (parent : list A) (child : list A) : bool :=
  let plen := Tezos_base__TzPervasives.List.length parent in
  let clen := Tezos_base__TzPervasives.List.length child in
  andb (OCaml.Stdlib.gt clen plen) (list_equal parent child plen).

Definition list_sub {A : Type} (l : list A) (pos : Z) (len : Z) : list A :=
  if
    orb (OCaml.Stdlib.lt len 0)
      (orb (OCaml.Stdlib.lt pos 0)
        (OCaml.Stdlib.gt (Z.add pos len)
          (Tezos_base__TzPervasives.List.length l))) then
    OCaml.Stdlib.invalid_arg "list_sub" % string
  else
    tt;
  let fix inner {B : Type} (function_parameter : (list B) * Z)
    : (list B) -> list B :=
    match function_parameter with
    | (acc, n) =>
      fun function_parameter =>
        match function_parameter with
        | [] => Tezos_base__TzPervasives.List.rev acc
        | cons h t =>
          if equiv_decb n 0 then
            Tezos_base__TzPervasives.List.rev acc
          else
            inner ((cons h acc), (Z.pred n)) t
        end
    end in
  inner ([], len) l.

Definition with_rw_cursor_lwt {A : Type}
  (nosync : option bool) (nometasync : option bool)
  (flags : option (list Lmdb.flag_open)) (name : option string)
  (function_parameter : t) : ((Lmdb.cursor Lmdb.rw) -> Lwt.t A) -> Lwt.t A :=
  match function_parameter with
  | {| dir := dir; parent := parent |} =>
    fun f =>
      let local_parent :=
        match Lwt.get parent with
        | None => None
        | Some (txn, _db, _cursor) => Some txn
        end in
      op_gt_gt_eq_question
        (Lmdb.create_rw_txn nosync nometasync local_parent dir)
        (fun txn =>
          op_gt_gt_eq_question (Lmdb.opendb flags name txn)
            (fun db =>
              op_gt_gt_eq_question (Lmdb.opencursor txn db)
                (fun cursor =>
                  Lwt.with_value parent (Some (txn, db, cursor))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Lwt.try_bind
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => f cursor
                            end)
                          (fun res =>
                            Lmdb.cursor_close cursor;
                            op_gt_gt_eq_question (Lmdb.commit_txn txn)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Lwt._return res
                                end))
                          (fun exn =>
                            Lmdb.cursor_close cursor;
                            Lmdb.abort_txn txn;
                            Lwt.fail exn)
                      end))))
  end.

Definition cursor_next_lwt {A B : Type}
  (cursor : Lmdb.cursor A) (acc : Lwt.t B) (f : B -> Lwt.t B) : Lwt.t B :=
  match Lmdb.cursor_next cursor with
  | inr KeyNotFound => acc
  | inr err => lwt_fail_error err
  | inl tt => Lwt.bind acc f
  end.

Definition cursor_at_lwt {A B : Type}
  (cursor : Lmdb.cursor A) (k : list string) (acc : Lwt.t B) (f : B -> Lwt.t B)
  : Lwt.t B :=
  match Lmdb.cursor_at cursor (concat k) with
  | inr KeyNotFound => acc
  | inr err => lwt_fail_error err
  | inl tt => Lwt.bind acc f
  end.

Definition zero_char_str : string :=
  Tezos_base__TzPervasives.String.make 1
    (Stdlib.Char.chr (Z.add (Stdlib.Char.code "/" % char) 1)).

Definition next_key_after_subdirs (function_parameter : list string)
  : list string :=
  match function_parameter with
  | [] => cons zero_char_str []
  | (cons _ _) as path =>
    OCaml.Stdlib.app
      (Tezos_base__TzPervasives.List.sub path
        (Z.sub (Tezos_base__TzPervasives.List.length path) 1))
      (cons
        (String.append (Tezos_base__TzPervasives.List.last_exn path)
          zero_char_str) [])
  end.

Definition fold {A : Type}
  (t : t) (k : list string) (init : A) (f : variant -> A -> Lwt.t A)
  : Lwt.t A :=
  let base_len := Tezos_base__TzPervasives.List.length k in
  let fix inner {B : Type}
    (ht : Stdlib.Hashtbl.t (list string) unit) (cursor : Lmdb.cursor B) (acc :
    A) : Lwt.t A :=
    op_gt_gt_eq_question (Lmdb.cursor_get cursor)
      (fun function_parameter =>
        match function_parameter with
        | (kk, _v) =>
          let kk := Bigstring.to_string kk in
          let kk_split := split kk in
          match is_child k kk_split with
          | false => Lwt._return acc
          | true =>
            let cur_len := Tezos_base__TzPervasives.List.length kk_split in
            if equiv_decb cur_len (Z.succ base_len) then
              cursor_next_lwt cursor (f variant acc) (inner ht cursor)
            else
              let dir := list_sub kk_split 0 (Z.succ base_len) in
              if Stdlib.Hashtbl.mem ht dir then
                cursor_at_lwt cursor (next_key_after_subdirs dir)
                  (Lwt._return acc) (inner ht cursor)
              else
                Stdlib.Hashtbl.add ht dir tt;
                cursor_next_lwt cursor (f variant acc) (inner ht cursor)
          end
        end) in
  with_rw_cursor_lwt None None None None t
    (fun cursor =>
      cursor_at_lwt cursor k (Lwt._return init)
        (fun acc =>
          let ht := Stdlib.Hashtbl.create None 31 in
          inner ht cursor acc)).

Definition fold_keys {A : Type}
  (t : t) (k : list string) (init : A) (f : (list string) -> A -> Lwt.t A)
  : Lwt.t A :=
  with_rw_cursor_lwt None None None None t
    (fun cursor =>
      cursor_at_lwt cursor k (Lwt._return init)
        (let fix inner (acc : A) : Lwt.t A :=
          op_gt_gt_eq_question (Lmdb.cursor_get cursor)
            (fun function_parameter =>
              match function_parameter with
              | (kk, _v) =>
                let kk := Bigstring.to_string kk in
                let kk_split := split kk in
                match is_child k kk_split with
                | false => Lwt._return acc
                | true => cursor_next_lwt cursor (f kk_split acc) inner
                end
              end) in
        inner)).

Definition keys (t : t) : (list string) -> Lwt.t (list (list string)) :=
  fold_keys t expected_argument []
    (fun k => fun acc => Lwt._return (cons k acc)).

Definition open_with_atomic_rw {A : Type}
  (mapsize : option int64) (path : string)
  (f : t -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A))
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A) :=
  Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq_question
    (init None mapsize path)
    (fun state =>
      Tezos_base__TzPervasives.Error_monad.op_gt_gt_eq_question
        (with_rw_cursor_lwt None None None None state (fun _c => f state))
        (fun res =>
          close state;
          Tezos_base__TzPervasives.Error_monad._return res)).

Definition with_atomic_rw {A : Type} (state : t) (f : unit -> Lwt.t A)
  : Lwt.t A := with_rw_cursor_lwt None None None None state (fun _c => f tt).
src/lib_storage/raw_store.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Store_sigs

include STORE

val init : ?readonly:bool -> ?mapsize:int64 -> string -> t tzresult Lwt.t

val close : t -> unit

val with_atomic_rw : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t

val open_with_atomic_rw :
  ?mapsize:int64 ->
  string ->
  (t -> 'a Error_monad.tzresult Lwt.t) ->
  'a tzresult Lwt.t
src/lib_storage/raw_store.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter init :
(option bool) ->
  (option int64) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter close : t -> unit.

Parameter with_atomic_rw : forall {a : Type}, t -> (unit -> Lwt.t a) -> Lwt.t a.

Parameter open_with_atomic_rw : forall {a : Type},
(option int64) ->
  string ->
    (t -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult a)) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult a).
src/lib_storage/store_helpers.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Store_sigs

module Make_value (V : ENCODED_VALUE) = struct
  type t = V.t

  let of_bytes b =
    match Data_encoding.Binary.of_bytes V.encoding b with
    | None ->
        generic_error "Cannot parse data" (* TODO personalize *)
    | Some v ->
        ok v

  let to_bytes v =
    try Data_encoding.Binary.to_bytes_exn V.encoding v
    with Data_encoding.Binary.Write_error error ->
      Store_logging.log_error
        "Exception while serializing value %a"
        Data_encoding.Binary.pp_write_error
        error ;
      Bytes.create 0
end

module Raw_value = struct
  type t = Bytes.t

  let of_bytes b = ok b

  let to_bytes b = b
end

module Make_single_store (S : STORE) (N : NAME) (V : VALUE) = struct
  type t = S.t

  type value = V.t

  let known t = S.known t N.name

  let read t = S.read t N.name >>=? fun b -> Lwt.return (V.of_bytes b)

  let read_opt t = read t >|= function Error _ -> None | Ok v -> Some v

  let store t v = S.store t N.name (V.to_bytes v)

  let remove t = S.remove t N.name
end

let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k)

module Make_substore (S : STORE) (N : NAME) : STORE with type t = S.t = struct
  type t = S.t

  type key = string list

  type value = Bytes.t

  let name_length = List.length N.name

  let to_key k = N.name @ k

  let of_key k = List.remove name_length k

  let known t k = S.known t (to_key k)

  let known_dir t k = S.known_dir t (to_key k)

  let read t k = S.read t (to_key k)

  let read_opt t k = S.read_opt t (to_key k)

  let store t k v = S.store t (to_key k) v

  let remove t k = S.remove t (to_key k)

  let fold t k ~init ~f =
    S.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

  let keys t k = S.keys t (to_key k) >|= fun keys -> List.map of_key keys

  let fold_keys t k ~init ~f =
    S.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc)

  let remove_dir t k = S.remove_dir t (to_key k)
end

module Make_indexed_substore (S : STORE) (I : INDEX) = struct
  type t = S.t

  type key = I.t

  module Store = struct
    type t = S.t * I.t

    type key = string list

    type value = Bytes.t

    let to_key i k =
      assert (List.length (I.to_path i []) = I.path_length) ;
      I.to_path i k

    let of_key k = List.remove I.path_length k

    let known (t, i) k = S.known t (to_key i k)

    let known_dir (t, i) k = S.known_dir t (to_key i k)

    let read (t, i) k = S.read t (to_key i k)

    let read_opt (t, i) k = S.read_opt t (to_key i k)

    let store (t, i) k v = S.store t (to_key i k) v

    let remove (t, i) k = S.remove t (to_key i k)

    let fold (t, i) k ~init ~f =
      S.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

    let keys (t, i) k =
      S.keys t (to_key i k) >|= fun keys -> List.map of_key keys

    let fold_keys (t, i) k ~init ~f =
      S.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)

    let remove_dir (t, i) k = S.remove_dir t (to_key i k)
  end

  let remove_all t i = Store.remove_dir (t, i) []

  let fold_indexes t ~init ~f =
    let rec dig i path acc =
      if i <= 0 then
        match I.of_path path with
        | None ->
            assert false
        | Some path ->
            f path acc
      else
        S.fold t path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let indexes t =
    fold_indexes t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))

  let list t k = S.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

  let resolve_index t prefix =
    let rec loop i prefix = function
      | [] when i = I.path_length -> (
        match I.of_path prefix with
        | None ->
            assert false
        | Some path ->
            Lwt.return [path] )
      | [] ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_p
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix [])
            prefixes
          >|= List.flatten
      | [d] when i = I.path_length - 1 ->
          if i >= I.path_length then invalid_arg "IO.resolve" ;
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_p
            (function
              | `Key prefix | `Dir prefix -> (
                match
                  String.remove_prefix ~prefix:d (List.hd (List.rev prefix))
                with
                | None ->
                    Lwt.return_nil
                | Some _ ->
                    loop (i + 1) prefix [] ))
            prefixes
          >|= List.flatten
      | "" :: ds ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_p
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds)
            prefixes
          >|= List.flatten
      | d :: ds -> (
          if i >= I.path_length then invalid_arg "IO.resolve" ;
          S.known_dir t (prefix @ [d])
          >>= function
          | true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil )
    in
    loop 0 [] prefix

  module Make_set (N : NAME) = struct
    type t = S.t

    type elt = I.t

    let inited = Bytes.of_string "inited"

    let known s i = Store.known (s, i) N.name

    let store s i = Store.store (s, i) N.name inited

    let remove s i = Store.remove (s, i) N.name

    let remove_all s = fold_indexes s ~init:() ~f:(fun i () -> remove s i)

    let fold s ~init ~f =
      fold_indexes s ~init ~f:(fun i acc ->
          known s i >>= function true -> f i acc | false -> Lwt.return acc)

    let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let iter s ~f = fold s ~init:() ~f:(fun p () -> f p)
  end

  module Make_buffered_set (N : NAME) (Set : Set.S with type elt = I.t) =
  struct
    include Make_set (N)
    module Set = Set

    let read_all s =
      fold s ~init:Set.empty ~f:(fun i set -> Lwt.return (Set.add i set))

    let store_all s new_set =
      read_all s
      >>= fun old_set ->
      Lwt_list.iter_p (remove s) Set.(elements (diff old_set new_set))
      >>= fun () ->
      Lwt_list.iter_p (store s) Set.(elements (diff new_set old_set))
  end

  module Make_map (N : NAME) (V : VALUE) = struct
    type t = S.t

    type key = I.t

    type value = V.t

    let known s i = Store.known (s, i) N.name

    let read s i =
      Store.read (s, i) N.name >>=? fun b -> Lwt.return (V.of_bytes b)

    let read_opt s i =
      read s i
      >>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v

    let store s i v = Store.store (s, i) N.name (V.to_bytes v)

    let remove s i = Store.remove (s, i) N.name

    let remove_all s = fold_indexes s ~init:() ~f:(fun i () -> remove s i)

    let fold s ~init ~f =
      fold_indexes s ~init ~f:(fun i acc ->
          read_opt s i
          >>= function None -> Lwt.return acc | Some v -> f i v acc)

    let bindings s =
      fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

    let iter s ~f = fold s ~init:() ~f:(fun p v () -> f p v)

    let fold_keys s ~init ~f =
      fold_indexes s ~init ~f:(fun i acc ->
          known s i >>= function false -> Lwt.return acc | true -> f i acc)

    let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let iter_keys s ~f = fold_keys s ~init:() ~f:(fun p () -> f p)
  end

  module Make_buffered_map
      (N : NAME)
      (V : VALUE)
      (Map : Map.S with type key = I.t) =
  struct
    include Make_map (N) (V)
    module Map = Map

    let read_all s =
      fold s ~init:Map.empty ~f:(fun i v set -> Lwt.return (Map.add i v set))

    let store_all s map =
      remove_all s
      >>= fun () ->
      Map.fold
        (fun k v acc ->
          let res = store s k v in
          acc >>= fun () -> res)
        map
        Lwt.return_unit
  end
end

module Make_set (S : STORE) (I : INDEX) = struct
  type t = S.t

  type elt = I.t

  let inited = Bytes.of_string "inited"

  let known s i = S.known s (I.to_path i [])

  let store s i = S.store s (I.to_path i []) inited

  let remove s i = S.remove s (I.to_path i [])

  let remove_all s = S.remove_dir s []

  let fold s ~init ~f =
    let rec dig i path acc =
      if i <= 1 then
        S.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match I.of_path file with
              | None ->
                  assert false
              | Some p ->
                  f p acc ))
      else
        S.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let iter s ~f = fold s ~init:() ~f:(fun p () -> f p)
end

module Make_buffered_set
    (S : STORE)
    (I : INDEX)
    (Set : Set.S with type elt = I.t) =
struct
  include Make_set (S) (I)
  module Set = Set

  let read_all s =
    fold s ~init:Set.empty ~f:(fun i set -> Lwt.return (Set.add i set))

  let store_all s new_set =
    read_all s
    >>= fun old_set ->
    Lwt_list.iter_p (remove s) Set.(elements (diff old_set new_set))
    >>= fun () ->
    Lwt_list.iter_p (store s) Set.(elements (diff new_set old_set))
end

module Make_map (S : STORE) (I : INDEX) (V : VALUE) = struct
  type t = S.t

  type key = I.t

  type value = V.t

  let known s i = S.known s (I.to_path i [])

  let read s i =
    S.read s (I.to_path i []) >>=? fun b -> Lwt.return (V.of_bytes b)

  let read_opt s i =
    read s i
    >>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v

  let store s i v = S.store s (I.to_path i []) (V.to_bytes v)

  let remove s i = S.remove s (I.to_path i [])

  let remove_all s = S.remove_dir s []

  let fold s ~init ~f =
    let rec dig i path acc =
      if i <= 1 then
        S.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
                S.read_opt s file
                >>= function
                | None ->
                    Lwt.return acc
                | Some b -> (
                  match V.of_bytes b with
                  | Error _ ->
                      (* Silently ignore unparsable data *)
                      Lwt.return acc
                  | Ok v -> (
                    match I.of_path file with
                    | None ->
                        assert false
                    | Some path ->
                        f path v acc ) ) ))
      else
        S.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let bindings s =
    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

  let iter s ~f = fold s ~init:() ~f:(fun p v () -> f p v)

  let fold_keys s ~init ~f =
    S.fold s [] ~init ~f:(fun p acc ->
        match p with
        | `Dir _ ->
            Lwt.return acc
        | `Key p -> (
          match I.of_path p with
          | None ->
              assert false
          | Some path ->
              f path acc ))

  let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let iter_keys s ~f = fold_keys s ~init:() ~f:(fun p () -> f p)
end

module Make_buffered_map
    (S : STORE)
    (I : INDEX)
    (V : VALUE)
    (Map : Map.S with type key = I.t) =
struct
  include Make_map (S) (I) (V)
  module Map = Map

  let read_all s =
    fold s ~init:Map.empty ~f:(fun i v set -> Lwt.return (Map.add i v set))

  let store_all s map =
    remove_all s
    >>= fun () ->
    Map.fold
      (fun k v acc ->
        let res = store s k v in
        acc >>= fun () -> res)
      map
      Lwt.return_unit
end

module Integer_index = struct
  type t = int

  let path_length = 1

  let to_path x l = string_of_int x :: l

  let of_path = function
    | [x] -> (
      try Some (int_of_string x) with _ -> None )
    | _ ->
        None
end
src/lib_storage/store_helpers.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_storage.Store_sigs.

Module Raw_value.
  Definition t := Stdlib.Bytes.t.
  
  Definition of_bytes {A : Type} (b : A)
    : Tezos_base__TzPervasives.tzresult A := Tezos_base__TzPervasives.ok b.
  
  Definition to_bytes {A : Type} (b : A) : A := b.
End Raw_value.

Definition map_key {A B : Type} (f : A -> B) (function_parameter : variant)
  : variant :=
  match function_parameter with
  | Key k => variant
  | Dir k => variant
  end.

Module Integer_index.
  Definition t := Z.
  
  Definition path_length : Z := 1.
  
  Definition to_path (x : Z) (l : list string) : list string :=
    cons (OCaml.Stdlib.string_of_int x) l.
  
  Definition of_path (function_parameter : list string) : option Z :=
    match function_parameter with
    | cons x [] => try
    | _ => None
    end.
End Integer_index.
src/lib_storage/store_helpers.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Store_sigs

module Make_value (V : ENCODED_VALUE) : VALUE with type t = V.t

module Raw_value : VALUE with type t = Bytes.t

module Make_single_store (S : STORE) (N : NAME) (V : VALUE) :
  SINGLE_STORE with type t = S.t and type value = V.t

module Make_substore (S : STORE) (N : NAME) : STORE with type t = S.t

module Make_set (S : STORE) (I : INDEX) :
  SET_STORE with type t = S.t and type elt = I.t

module Make_buffered_set
    (S : STORE)
    (I : INDEX)
    (Set : Set.S with type elt = I.t) :
  BUFFERED_SET_STORE with type t = S.t and type elt = I.t and module Set = Set

module Make_map (S : STORE) (I : INDEX) (V : VALUE) :
  MAP_STORE with type t = S.t and type key = I.t and type value = V.t

module Make_buffered_map
    (S : STORE)
    (I : INDEX)
    (V : VALUE)
    (Map : Map.S with type key = I.t) :
  BUFFERED_MAP_STORE
    with type t = S.t
     and type key = I.t
     and type value = V.t
     and module Map = Map

module Make_indexed_substore (S : STORE) (I : INDEX) :
  INDEXED_STORE with type t = S.t and type key = I.t

module Integer_index : INDEX with type t = int
src/lib_storage/store_helpers.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module
src/lib_storage/store_logging.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "db"
end)
src/lib_storage/store_logging.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_storage/store_logging.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.LOG
src/lib_storage/store_logging.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/lib_storage/store_sigs.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type NAME = sig
  val name : string list
end

module type VALUE = sig
  type t

  val of_bytes : Bytes.t -> t tzresult

  val to_bytes : t -> Bytes.t
end

module type ENCODED_VALUE = sig
  type t

  val encoding : t Data_encoding.t
end

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option
end

module type SINGLE_STORE = sig
  type t

  type value

  val known : t -> bool Lwt.t

  val read : t -> value tzresult Lwt.t

  val read_opt : t -> value option Lwt.t

  val store : t -> value -> unit Lwt.t

  val remove : t -> unit Lwt.t
end

module type STORE = sig
  type t

  type key = string list

  type value = Bytes.t

  val known : t -> key -> bool Lwt.t

  val read : t -> key -> value tzresult Lwt.t

  val read_opt : t -> key -> value option Lwt.t

  val store : t -> key -> value -> unit Lwt.t

  val remove : t -> key -> unit Lwt.t

  val known_dir : t -> key -> bool Lwt.t

  val remove_dir : t -> key -> unit Lwt.t

  val fold :
    t ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val keys : t -> key -> key list Lwt.t

  val fold_keys : t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type SET_STORE = sig
  type t

  type elt

  val known : t -> elt -> bool Lwt.t

  val store : t -> elt -> unit Lwt.t

  val remove : t -> elt -> unit Lwt.t

  val elements : t -> elt list Lwt.t

  val remove_all : t -> unit Lwt.t

  val iter : t -> f:(elt -> unit Lwt.t) -> unit Lwt.t

  val fold : t -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type BUFFERED_SET_STORE = sig
  include SET_STORE

  module Set : Set.S with type elt = elt

  val read_all : t -> Set.t Lwt.t

  val store_all : t -> Set.t -> unit Lwt.t
end

module type MAP_STORE = sig
  type t

  type key

  type value

  val known : t -> key -> bool Lwt.t

  val read : t -> key -> value tzresult Lwt.t

  val read_opt : t -> key -> value option Lwt.t

  val store : t -> key -> value -> unit Lwt.t

  val remove : t -> key -> unit Lwt.t

  val keys : t -> key list Lwt.t

  val bindings : t -> (key * value) list Lwt.t

  val remove_all : t -> unit Lwt.t

  val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t

  val iter_keys : t -> f:(key -> unit Lwt.t) -> unit Lwt.t

  val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val fold_keys : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type BUFFERED_MAP_STORE = sig
  include MAP_STORE

  module Map : Map.S with type key = key

  val read_all : t -> value Map.t Lwt.t

  val store_all : t -> value Map.t -> unit Lwt.t
end

module type INDEXED_STORE = sig
  type t

  type key

  module Store : STORE with type t = t * key

  val remove_all : t -> key -> unit Lwt.t

  val fold_indexes : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val indexes : t -> key list Lwt.t

  val resolve_index : t -> string list -> key list Lwt.t

  module Make_set (N : NAME) : SET_STORE with type t = t and type elt = key

  module Make_buffered_set (N : NAME) (Set : Set.S with type elt = key) :
    BUFFERED_SET_STORE with type t = t and type elt = key and module Set = Set

  module Make_map (N : NAME) (V : VALUE) :
    MAP_STORE with type t = t and type key = key and type value = V.t

  module Make_buffered_map
      (N : NAME)
      (V : VALUE)
      (Map : Map.S with type key = key) :
    BUFFERED_MAP_STORE
      with type t = t
       and type key = key
       and type value = V.t
       and module Map = Map
end
src/lib_storage/store_sigs.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module NAME.
  Record signature := {
    name : list string;
  }.
End NAME.

Module VALUE.
  Record signature {t : Type} := {
    t := t;
    of_bytes : Stdlib.Bytes.t -> Tezos_base__TzPervasives.tzresult t;
    to_bytes : t -> Stdlib.Bytes.t;
  }.
  Arguments signature : clear implicits.
End VALUE.

Module ENCODED_VALUE.
  Record signature {t : Type} := {
    t := t;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End ENCODED_VALUE.

Module INDEX.
  Record signature {t : Type} := {
    t := t;
    path_length : Z;
    to_path : t -> (list string) -> list string;
    of_path : (list string) -> option t;
  }.
  Arguments signature : clear implicits.
End INDEX.

Module SINGLE_STORE.
  Record signature {t value : Type} := {
    t := t;
    value := value;
    known : t -> Lwt.t bool;
    read : t -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : t -> Lwt.t (option value);
    store : t -> value -> Lwt.t unit;
    remove : t -> Lwt.t unit;
  }.
  Arguments signature : clear implicits.
End SINGLE_STORE.

Module STORE.
  Record signature {t : Type} := {
    t := t;
    key := list string;
    value := Stdlib.Bytes.t;
    known : t -> key -> Lwt.t bool;
    read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : t -> key -> Lwt.t (option value);
    store : t -> key -> value -> Lwt.t unit;
    remove : t -> key -> Lwt.t unit;
    known_dir : t -> key -> Lwt.t bool;
    remove_dir : t -> key -> Lwt.t unit;
    fold : forall {a variant : Type}, t ->
      key -> a -> (variant -> a -> Lwt.t a) -> Lwt.t a;
    keys : t -> key -> Lwt.t (list key);
    fold_keys : forall {a : Type}, t ->
      key -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
  }.
  Arguments signature : clear implicits.
End STORE.

Module SET_STORE.
  Record signature {t elt : Type} := {
    t := t;
    elt := elt;
    known : t -> elt -> Lwt.t bool;
    store : t -> elt -> Lwt.t unit;
    remove : t -> elt -> Lwt.t unit;
    elements : t -> Lwt.t (list elt);
    remove_all : t -> Lwt.t unit;
    iter : t -> (elt -> Lwt.t unit) -> Lwt.t unit;
    fold : forall {a : Type}, t -> a -> (elt -> a -> Lwt.t a) -> Lwt.t a;
  }.
  Arguments signature : clear implicits.
End SET_STORE.

Module BUFFERED_SET_STORE.
  Record signature {t elt Set_t : Type} := {
    include;
    Set : Set.S.signature elt Set_t;
    read_all : t -> Lwt.t Set.t;
    store_all : t -> Set.t -> Lwt.t unit;
  }.
  Arguments signature : clear implicits.
End BUFFERED_SET_STORE.

Module MAP_STORE.
  Record signature {t key value : Type} := {
    t := t;
    key := key;
    value := value;
    known : t -> key -> Lwt.t bool;
    read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : t -> key -> Lwt.t (option value);
    store : t -> key -> value -> Lwt.t unit;
    remove : t -> key -> Lwt.t unit;
    keys : t -> Lwt.t (list key);
    bindings : t -> Lwt.t (list (key * value));
    remove_all : t -> Lwt.t unit;
    iter : t -> (key -> value -> Lwt.t unit) -> Lwt.t unit;
    iter_keys : t -> (key -> Lwt.t unit) -> Lwt.t unit;
    fold : forall {a : Type}, t ->
      a -> (key -> value -> a -> Lwt.t a) -> Lwt.t a;
    fold_keys : forall {a : Type}, t -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
  }.
  Arguments signature : clear implicits.
End MAP_STORE.

Module BUFFERED_MAP_STORE.
  Record signature {t key value Map_t : Type} := {
    include;
    Map : Map.S.signature key Map_t;
    read_all : t -> Lwt.t (Map.t value);
    store_all : t -> (Map.t value) -> Lwt.t unit;
  }.
  Arguments signature : clear implicits.
End BUFFERED_MAP_STORE.

Module INDEXED_STORE.
  Record signature {t key : Type} := {
    t := t;
    key := key;
    Store : STORE.signature (t * key);
    remove_all : t -> key -> Lwt.t unit;
    fold_indexes : forall {a : Type}, t -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
    indexes : t -> Lwt.t (list key);
    resolve_index : t -> (list string) -> Lwt.t (list key);
    Make_set : functor;
    Make_buffered_set : functor;
    Make_map : functor;
    Make_buffered_map : functor;
  }.
  Arguments signature : clear implicits.
End INDEXED_STORE.
src/lib_storage/test/assert.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg

let equal_string ?msg s1 s2 = equal ?msg ~prn:(fun s -> s) s1 s2

let equal_string_option ?msg o1 o2 =
  let prn = function None -> "None" | Some s -> s in
  equal ?msg ~prn o1 o2

let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg

let make_equal_list eq prn ?(msg = "") x y =
  let rec iter i x y =
    match (x, y) with
    | (hd_x :: tl_x, hd_y :: tl_y) ->
        if eq hd_x hd_y then iter (succ i) tl_x tl_y
        else
          let fm = Printf.sprintf "%s (at index %d)" msg i in
          fail (prn hd_x) (prn hd_y) fm
    | (_ :: _, []) | ([], _ :: _) ->
        let fm = Printf.sprintf "%s (lists of different sizes)" msg in
        fail_msg "%s" fm
    | ([], []) ->
        ()
  in
  iter 0 x y

let equal_string_list ?msg l1 l2 =
  make_equal_list ?msg ( = ) (fun x -> x) l1 l2

let equal_string_list_list ?msg l1 l2 =
  let pr_persist l =
    let res =
      String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
    in
    Printf.sprintf "[%s]" res
  in
  make_equal_list ?msg ( = ) pr_persist l1 l2

let equal_key_dir_list ?msg l1 l2 =
  make_equal_list
    ?msg
    ( = )
    (function
      | `Key k ->
          "Key " ^ String.concat "/" k
      | `Dir k ->
          "Dir " ^ String.concat "/" k)
    l1
    l2

let equal_context_hash_list ?msg l1 l2 =
  let pr_persist hash = Printf.sprintf "[%s]" @@ Context_hash.to_string hash in
  make_equal_list ?msg Context_hash.( = ) pr_persist l1 l2
src/lib_storage/test/assert.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Stdlib.Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  match function_parameter with
  | _ => "" % string
  end.

Definition equal {A : Type} (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun op_star_o_p_t_star =>
    let prn :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

Definition equal_string (msg : option string) (s1 : string) (s2 : string)
  : unit := equal None (Some (fun s => s)) msg s1 s2.

Definition equal_string_option
  (msg : option string) (o1 : option string) (o2 : option string) : unit :=
  let prn (function_parameter : option string) : string :=
    match function_parameter with
    | None => "None" % string
    | Some s => s
    end in
  equal None (Some prn) msg o1 o2.

Definition is_none {A : Type} (op_star_o_p_t_star : option string)
  : (option A) -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    if nequiv_decb x None then
      fail "None" % string "Some _" % string msg
    else
      tt.

Definition make_equal_list {A : Type}
  (eq : A -> A -> bool) (prn : A -> string) (op_star_o_p_t_star : option string)
  : (list A) -> (list A) -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    fun y =>
      let fix iter (i : Z) (x : list A) (y : list A) : unit :=
        match (x, y) with
        | (cons hd_x tl_x, cons hd_y tl_y) =>
          if eq hd_x hd_y then
            iter (Z.succ i) tl_x tl_y
          else
            let fm :=
              Stdlib.Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " (at index " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format))))
                  "%s (at index %d)" % string) msg i in
            fail (prn hd_x) (prn hd_y) fm
        | (cons _ _, []) | ([], cons _ _) =>
          let fm :=
            Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " (lists of different sizes)" % string
                    CamlinternalFormatBasics.End_of_format))
                "%s (lists of different sizes)" % string) msg in
          fail_msg
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string) fm
        | ([], []) => tt
        end in
      iter 0 x y.

Definition equal_string_list
  (msg : option string) (l1 : list string) (l2 : list string) : unit :=
  make_equal_list equiv_decb (fun x => x) msg l1 l2.

Definition equal_string_list_list
  (msg : option string) (l1 : list (list string)) (l2 : list (list string))
  : unit :=
  let pr_persist (l : list string) : string :=
    let res :=
      Tezos_base__TzPervasives.String.concat ";" % string
        (Tezos_base__TzPervasives.List.map
          (fun s =>
            Stdlib.Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
      in
    Stdlib.Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "]" % char
              CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
  make_equal_list equiv_decb pr_persist msg l1 l2.

Definition equal_key_dir_list
  (msg : option string) (l1 : list variant) (l2 : list variant) : unit :=
  make_equal_list equiv_decb
    (fun function_parameter =>
      match function_parameter with
      | Key k =>
        String.append "Key " % string
          (Tezos_base__TzPervasives.String.concat "/" % string k)
      | Dir k =>
        String.append "Dir " % string
          (Tezos_base__TzPervasives.String.concat "/" % string k)
      end) msg l1 l2.

Definition equal_context_hash_list
  (msg : option string) (l1 : list Tezos_base__TzPervasives.Context_hash.t)
  (l2 : list Tezos_base__TzPervasives.Context_hash.t) : unit :=
  let pr_persist (hash : Tezos_base__TzPervasives.Context_hash.t) : string :=
    apply
      (Stdlib.Printf.sprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "[" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "]" % char
                CamlinternalFormatBasics.End_of_format))) "[%s]" % string))
      (Tezos_base__TzPervasives.Context_hash.to_string hash) in
  make_equal_list Tezos_base__TzPervasives.Context_hash.op_eq pr_persist msg l1
    l2.
src/lib_storage/test/test.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Alcotest.run
    "tezos-storage"
    [("context", Test_context.tests); ("raw_store", Test_raw_store.tests)]
src/lib_storage/test/test.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/lib_storage/test/test_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Context

let ( >>= ) = Lwt.bind

let ( >|= ) = Lwt.( >|= )

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

let chain_id = Chain_id.of_block_hash genesis_block

(** Context creation *)

let commit = commit ~time:Time.Protocol.epoch ~message:""

let block2 =
  Block_hash.of_hex_exn
    (`Hex "2222222222222222222222222222222222222222222222222222222222222222")

let create_block2 idx genesis_commit =
  checkout idx genesis_commit
  >>= function
  | None ->
      Assert.fail_msg "checkout genesis_block"
  | Some ctxt ->
      set ctxt ["a"; "b"] (Bytes.of_string "Novembre")
      >>= fun ctxt ->
      set ctxt ["a"; "c"] (Bytes.of_string "Juin")
      >>= fun ctxt ->
      set ctxt ["version"] (Bytes.of_string "0.0") >>= fun ctxt -> commit ctxt

let block3a =
  Block_hash.of_hex_exn
    (`Hex "3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a")

let create_block3a idx block2_commit =
  checkout idx block2_commit
  >>= function
  | None ->
      Assert.fail_msg "checkout block2"
  | Some ctxt ->
      del ctxt ["a"; "b"]
      >>= fun ctxt ->
      set ctxt ["a"; "d"] (Bytes.of_string "Mars") >>= fun ctxt -> commit ctxt

let block3b =
  Block_hash.of_hex_exn
    (`Hex "3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b")

let block3c =
  Block_hash.of_hex_exn
    (`Hex "3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c")

let create_block3b idx block2_commit =
  checkout idx block2_commit
  >>= function
  | None ->
      Assert.fail_msg "checkout block3b"
  | Some ctxt ->
      del ctxt ["a"; "c"]
      >>= fun ctxt ->
      set ctxt ["a"; "d"] (Bytes.of_string "Février")
      >>= fun ctxt -> commit ctxt

type t = {
  idx : Context.index;
  genesis : Context_hash.t;
  block2 : Context_hash.t;
  block3a : Context_hash.t;
  block3b : Context_hash.t;
}

let wrap_context_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "context" in
      Context.init ~mapsize:4_096_000L root
      >>= fun idx ->
      Context.commit_genesis
        idx
        ~chain_id
        ~time:genesis_time
        ~protocol:genesis_protocol
      >>= fun genesis ->
      create_block2 idx genesis
      >>= fun block2 ->
      create_block3a idx block2
      >>= fun block3a ->
      create_block3b idx block2
      >>= fun block3b ->
      f {idx; genesis; block2; block3a; block3b}
      >>= fun result -> Lwt.return result)

(** Simple test *)

let c = function None -> None | Some s -> Some (Bytes.to_string s)

let test_simple {idx; block2; _} =
  checkout idx block2
  >>= function
  | None ->
      Assert.fail_msg "checkout block2"
  | Some ctxt ->
      get ctxt ["version"]
      >>= fun version ->
      Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ;
      get ctxt ["a"; "b"]
      >>= fun novembre ->
      Assert.equal_string_option (Some "Novembre") (c novembre) ;
      get ctxt ["a"; "c"]
      >>= fun juin ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
      Lwt.return_unit

let test_continuation {idx; block3a; _} =
  checkout idx block3a
  >>= function
  | None ->
      Assert.fail_msg "checkout block3a"
  | Some ctxt ->
      get ctxt ["version"]
      >>= fun version ->
      Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
      get ctxt ["a"; "b"]
      >>= fun novembre ->
      Assert.is_none ~msg:__LOC__ (c novembre) ;
      get ctxt ["a"; "c"]
      >>= fun juin ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
      get ctxt ["a"; "d"]
      >>= fun mars ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
      Lwt.return_unit

let test_fork {idx; block3b; _} =
  checkout idx block3b
  >>= function
  | None ->
      Assert.fail_msg "checkout block3b"
  | Some ctxt ->
      get ctxt ["version"]
      >>= fun version ->
      Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
      get ctxt ["a"; "b"]
      >>= fun novembre ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
      get ctxt ["a"; "c"]
      >>= fun juin ->
      Assert.is_none ~msg:__LOC__ (c juin) ;
      get ctxt ["a"; "d"]
      >>= fun mars ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
      Lwt.return_unit

let test_replay {idx; genesis; _} =
  checkout idx genesis
  >>= function
  | None ->
      Assert.fail_msg "checkout genesis_block"
  | Some ctxt0 ->
      set ctxt0 ["version"] (Bytes.of_string "0.0")
      >>= fun ctxt1 ->
      set ctxt1 ["a"; "b"] (Bytes.of_string "Novembre")
      >>= fun ctxt2 ->
      set ctxt2 ["a"; "c"] (Bytes.of_string "Juin")
      >>= fun ctxt3 ->
      set ctxt3 ["a"; "d"] (Bytes.of_string "July")
      >>= fun ctxt4a ->
      set ctxt3 ["a"; "d"] (Bytes.of_string "Juillet")
      >>= fun ctxt4b ->
      set ctxt4a ["a"; "b"] (Bytes.of_string "November")
      >>= fun ctxt5a ->
      get ctxt4a ["a"; "b"]
      >>= fun novembre ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
      get ctxt5a ["a"; "b"]
      >>= fun november ->
      Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ;
      get ctxt5a ["a"; "d"]
      >>= fun july ->
      Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ;
      get ctxt4b ["a"; "b"]
      >>= fun novembre ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
      get ctxt4b ["a"; "d"]
      >>= fun juillet ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
      Lwt.return_unit

let fold_keys s k ~init ~f =
  let rec loop k acc =
    fold s k ~init:acc ~f:(fun file acc ->
        match file with `Key k -> f k acc | `Dir k -> loop k acc)
  in
  loop k init

let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

let test_fold {idx; genesis; _} =
  checkout idx genesis
  >>= function
  | None ->
      Assert.fail_msg "checkout genesis_block"
  | Some ctxt ->
      set ctxt ["a"; "b"] (Bytes.of_string "Novembre")
      >>= fun ctxt ->
      set ctxt ["a"; "c"] (Bytes.of_string "Juin")
      >>= fun ctxt ->
      set ctxt ["a"; "d"; "e"] (Bytes.of_string "Septembre")
      >>= fun ctxt ->
      set ctxt ["f"] (Bytes.of_string "Avril")
      >>= fun ctxt ->
      set ctxt ["g"; "h"] (Bytes.of_string "Avril")
      >>= fun ctxt ->
      keys ctxt []
      >>= fun l ->
      Assert.equal_string_list_list
        ~msg:__LOC__
        [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
        (List.sort compare l) ;
      keys ctxt ["a"]
      >>= fun l ->
      Assert.equal_string_list_list
        ~msg:__LOC__
        [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
        (List.sort compare l) ;
      keys ctxt ["f"]
      >>= fun l ->
      Assert.equal_string_list_list ~msg:__LOC__ [] l ;
      keys ctxt ["g"]
      >>= fun l ->
      Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] l ;
      keys ctxt ["i"]
      >>= fun l ->
      Assert.equal_string_list_list ~msg:__LOC__ [] l ;
      Lwt.return_unit

let test_dump {idx; block3b; _} =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir2 ->
      let dumpfile = base_dir2 // "dump" in
      let ctxt_hash = block3b in
      let history_mode = Tezos_shell_services.History_mode.Full in
      let empty_block_header context =
        Block_header.
          {
            protocol_data = Bytes.empty;
            shell =
              {
                level = 0l;
                proto_level = 0;
                predecessor = Block_hash.zero;
                timestamp = Time.Protocol.epoch;
                validation_passes = 0;
                operations_hash = Operation_list_list_hash.zero;
                fitness = [];
                context;
              };
          }
      in
      let _empty_pruned_block =
        ( {
            block_header = empty_block_header Context_hash.zero;
            operations = [];
            operation_hashes = [];
          }
          : Context.Pruned_block.t )
      in
      let empty =
        {
          Context.Block_data.block_header = empty_block_header Context_hash.zero;
          operations = [[]];
        }
      in
      let bhs =
        (fun context ->
          ( empty_block_header context,
            empty,
            history_mode,
            fun _ -> return (None, None) ))
          ctxt_hash
      in
      Context.dump_contexts idx bhs ~filename:dumpfile
      >>=? fun () ->
      let root = base_dir2 // "context" in
      Context.init ?patch_context:None root
      >>= fun idx2 ->
      Context.restore_contexts
        idx2
        ~filename:dumpfile
        (fun _ -> return_unit)
        (fun _ _ _ -> return_unit)
      >>=? fun imported ->
      let (bh, _, _, _, _, _) = imported in
      let expected_ctxt_hash = bh.Block_header.shell.context in
      assert (Context_hash.equal ctxt_hash expected_ctxt_hash) ;
      return ())
  >>= function
  | Error err ->
      Error_monad.pp_print_error Format.err_formatter err ;
      assert false
  | Ok () ->
      Lwt.return_unit

(******************************************************************************)

let tests : (string * (t -> unit Lwt.t)) list =
  [ ("simple", test_simple);
    ("continuation", test_continuation);
    ("fork", test_fork);
    ("replay", test_replay);
    ("fold", test_fold);
    ("dump", test_dump) ]

let tests =
  List.map
    (fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_context_init f))
    tests
src/lib_storage/test/test_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_storage.Context.

Definition op_gt_gt_eq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.bind.

Definition op_gt_pipe_eq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
  Lwt.op_gt_pipe_eq.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Tezos_base__TzPervasives.Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Tezos_base__TzPervasives.Time.Protocol.of_seconds 0.

Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
  Tezos_base__TzPervasives.Chain_id.of_block_hash genesis_block.

Definition commit
  : Tezos_storage.Context.context ->
    Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  Tezos_storage.Context.commit Tezos_base__TzPervasives.Time.Protocol.epoch
    (Some "" % string).

Definition block2 : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_hex_exn variant.

Definition create_block2
  (idx : Tezos_storage.Context.index)
  (genesis_commit : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  op_gt_gt_eq (Tezos_storage.Context.checkout idx genesis_commit)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star "checkout genesis_block" % string
      | Some ctxt =>
        op_gt_gt_eq
          (Tezos_storage.Context.set ctxt
            (cons "a" % string (cons "b" % string []))
            (Stdlib.Bytes.of_string "Novembre" % string))
          (fun ctxt =>
            op_gt_gt_eq
              (Tezos_storage.Context.set ctxt
                (cons "a" % string (cons "c" % string []))
                (Stdlib.Bytes.of_string "Juin" % string))
              (fun ctxt =>
                op_gt_gt_eq
                  (Tezos_storage.Context.set ctxt (cons "version" % string [])
                    (Stdlib.Bytes.of_string "0.0" % string))
                  (fun ctxt => commit ctxt)))
      end).

Definition block3a : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_hex_exn variant.

Definition create_block3a
  (idx : Tezos_storage.Context.index)
  (block2_commit : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  op_gt_gt_eq (Tezos_storage.Context.checkout idx block2_commit)
    (fun function_parameter =>
      match function_parameter with
      | None => op_star_t_y_p_e_minus_e_r_r_o_r_star "checkout block2" % string
      | Some ctxt =>
        op_gt_gt_eq
          (Tezos_storage.Context.del ctxt
            (cons "a" % string (cons "b" % string [])))
          (fun ctxt =>
            op_gt_gt_eq
              (Tezos_storage.Context.set ctxt
                (cons "a" % string (cons "d" % string []))
                (Stdlib.Bytes.of_string "Mars" % string))
              (fun ctxt => commit ctxt))
      end).

Definition block3b : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_hex_exn variant.

Definition block3c : Tezos_base__TzPervasives.Block_hash.t :=
  Tezos_base__TzPervasives.Block_hash.of_hex_exn variant.

Definition create_block3b
  (idx : Tezos_storage.Context.index)
  (block2_commit : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  op_gt_gt_eq (Tezos_storage.Context.checkout idx block2_commit)
    (fun function_parameter =>
      match function_parameter with
      | None => op_star_t_y_p_e_minus_e_r_r_o_r_star "checkout block3b" % string
      | Some ctxt =>
        op_gt_gt_eq
          (Tezos_storage.Context.del ctxt
            (cons "a" % string (cons "c" % string [])))
          (fun ctxt =>
            op_gt_gt_eq
              (Tezos_storage.Context.set ctxt
                (cons "a" % string (cons "d" % string []))
                (Stdlib.Bytes.of_string "Février" % string))
              (fun ctxt => commit ctxt))
      end).

Record t := {
  idx : Tezos_storage.Context.index;
  genesis : Tezos_base__TzPervasives.Context_hash.t;
  block2 : Tezos_base__TzPervasives.Context_hash.t;
  block3a : Tezos_base__TzPervasives.Context_hash.t;
  block3b : Tezos_base__TzPervasives.Context_hash.t }.

Definition wrap_context_init {A B : Type}
  (f : t -> Lwt.t A) (function_parameter : B) : unit -> Lwt.t A :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir "tezos_test_" % string
          (fun base_dir =>
            let root := op_div_div base_dir "context" % string in
            op_gt_gt_eq
              (Tezos_storage.Context.init None (Some 4096000) None root)
              (fun idx =>
                op_gt_gt_eq
                  (Tezos_storage.Context.commit_genesis idx chain_id
                    genesis_time genesis_protocol)
                  (fun genesis =>
                    op_gt_gt_eq (create_block2 idx genesis)
                      (fun block2 =>
                        op_gt_gt_eq (create_block3a idx block2)
                          (fun block3a =>
                            op_gt_gt_eq (create_block3b idx block2)
                              (fun block3b =>
                                op_gt_gt_eq
                                  (f
                                    {| idx := idx; genesis := genesis;
                                      block2 := block2; block3a := block3a;
                                      block3b := block3b |})
                                  (fun result => Lwt._return result)))))))
      end
  end.

Definition c (function_parameter : option string) : option string :=
  match function_parameter with
  | None => None
  | Some s => Some (Stdlib.Bytes.to_string s)
  end.

Definition test_simple (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | {| idx := idx; block2 := block2 |} =>
    op_gt_gt_eq (Tezos_storage.Context.checkout idx block2)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star "checkout block2" % string
        | Some ctxt =>
          op_gt_gt_eq
            (Tezos_storage.Context.get ctxt (cons "version" % string []))
            (fun version =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__ (c version)
                (Some "0.0" % string);
              op_gt_gt_eq
                (Tezos_storage.Context.get ctxt
                  (cons "a" % string (cons "b" % string [])))
                (fun novembre =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (Some "Novembre" % string) (c novembre);
                  op_gt_gt_eq
                    (Tezos_storage.Context.get ctxt
                      (cons "a" % string (cons "c" % string [])))
                    (fun juin =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                        (Some "Juin" % string) (c juin);
                      Lwt.return_unit)))
        end)
  end.

Definition test_continuation (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | {| idx := idx; block3a := block3a |} =>
    op_gt_gt_eq (Tezos_storage.Context.checkout idx block3a)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star "checkout block3a" % string
        | Some ctxt =>
          op_gt_gt_eq
            (Tezos_storage.Context.get ctxt (cons "version" % string []))
            (fun version =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                (Some "0.0" % string) (c version);
              op_gt_gt_eq
                (Tezos_storage.Context.get ctxt
                  (cons "a" % string (cons "b" % string [])))
                (fun novembre =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                    (c novembre);
                  op_gt_gt_eq
                    (Tezos_storage.Context.get ctxt
                      (cons "a" % string (cons "c" % string [])))
                    (fun juin =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                        (Some "Juin" % string) (c juin);
                      op_gt_gt_eq
                        (Tezos_storage.Context.get ctxt
                          (cons "a" % string (cons "d" % string [])))
                        (fun mars =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                            (Some "Mars" % string) (c mars);
                          Lwt.return_unit))))
        end)
  end.

Definition test_fork (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | {| idx := idx; block3b := block3b |} =>
    op_gt_gt_eq (Tezos_storage.Context.checkout idx block3b)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star "checkout block3b" % string
        | Some ctxt =>
          op_gt_gt_eq
            (Tezos_storage.Context.get ctxt (cons "version" % string []))
            (fun version =>
              op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                (Some "0.0" % string) (c version);
              op_gt_gt_eq
                (Tezos_storage.Context.get ctxt
                  (cons "a" % string (cons "b" % string [])))
                (fun novembre =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                    (Some "Novembre" % string) (c novembre);
                  op_gt_gt_eq
                    (Tezos_storage.Context.get ctxt
                      (cons "a" % string (cons "c" % string [])))
                    (fun juin =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                        (c juin);
                      op_gt_gt_eq
                        (Tezos_storage.Context.get ctxt
                          (cons "a" % string (cons "d" % string [])))
                        (fun mars =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star Stdlib.__LOC__
                            (Some "Février" % string) (c mars);
                          Lwt.return_unit))))
        end)
  end.

Definition test_replay (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | {| idx := idx; genesis := genesis |} =>
    op_gt_gt_eq (Tezos_storage.Context.checkout idx genesis)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star "checkout genesis_block" % string
        | Some ctxt0 =>
          op_gt_gt_eq
            (Tezos_storage.Context.set ctxt0 (cons "version" % string [])
              (Stdlib.Bytes.of_string "0.0" % string))
            (fun ctxt1 =>
              op_gt_gt_eq
                (Tezos_storage.Context.set ctxt1
                  (cons "a" % string (cons "b" % string []))
                  (Stdlib.Bytes.of_string "Novembre" % string))
                (fun ctxt2 =>
                  op_gt_gt_eq
                    (Tezos_storage.Context.set ctxt2
                      (cons "a" % string (cons "c" % string []))
                      (Stdlib.Bytes.of_string "Juin" % string))
                    (fun ctxt3 =>
                      op_gt_gt_eq
                        (Tezos_storage.Context.set ctxt3
                          (cons "a" % string (cons "d" % string []))
                          (Stdlib.Bytes.of_string "July" % string))
                        (fun ctxt4a =>
                          op_gt_gt_eq
                            (Tezos_storage.Context.set ctxt3
                              (cons "a" % string (cons "d" % string []))
                              (Stdlib.Bytes.of_string "Juillet" % string))
                            (fun ctxt4b =>
                              op_gt_gt_eq
                                (Tezos_storage.Context.set ctxt4a
                                  (cons "a" % string (cons "b" % string []))
                                  (Stdlib.Bytes.of_string "November" % string))
                                (fun ctxt5a =>
                                  op_gt_gt_eq
                                    (Tezos_storage.Context.get ctxt4a
                                      (cons "a" % string (cons "b" % string [])))
                                    (fun novembre =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Stdlib.__LOC__
                                        (Some "Novembre" % string) (c novembre);
                                      op_gt_gt_eq
                                        (Tezos_storage.Context.get ctxt5a
                                          (cons "a" % string
                                            (cons "b" % string [])))
                                        (fun november =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Stdlib.__LOC__
                                            (Some "November" % string)
                                            (c november);
                                          op_gt_gt_eq
                                            (Tezos_storage.Context.get ctxt5a
                                              (cons "a" % string
                                                (cons "d" % string [])))
                                            (fun july =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Stdlib.__LOC__
                                                (Some "July" % string) (c july);
                                              op_gt_gt_eq
                                                (Tezos_storage.Context.get
                                                  ctxt4b
                                                  (cons "a" % string
                                                    (cons "b" % string [])))
                                                (fun novembre =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Stdlib.__LOC__
                                                    (Some "Novembre" % string)
                                                    (c novembre);
                                                  op_gt_gt_eq
                                                    (Tezos_storage.Context.get
                                                      ctxt4b
                                                      (cons "a" % string
                                                        (cons "d" % string [])))
                                                    (fun juillet =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Stdlib.__LOC__
                                                        (Some "Juillet" % string)
                                                        (c juillet);
                                                      Lwt.return_unit)))))))))))
        end)
  end.

Definition fold_keys {A : Type}
  (s : Tezos_storage.Context.context) (k : Tezos_storage.Context.key) (init : A)
  (f : Tezos_storage.Context.key -> A -> Lwt.t A) : Lwt.t A :=
  let fix loop (k : Tezos_storage.Context.key) (acc : A) : Lwt.t A :=
    Tezos_storage.Context.fold s k acc
      (fun file =>
        fun acc =>
          match file with
          | Key k => f k acc
          | Dir k => loop k acc
          end) in
  loop k init.

Definition keys (t : Tezos_storage.Context.context)
  : Tezos_storage.Context.key -> Lwt.t (list Tezos_storage.Context.key) :=
  fold_keys t expected_argument []
    (fun k => fun acc => Lwt._return (cons k acc)).

Definition test_fold (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | {| idx := idx; genesis := genesis |} =>
    op_gt_gt_eq (Tezos_storage.Context.checkout idx genesis)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star "checkout genesis_block" % string
        | Some ctxt =>
          op_gt_gt_eq
            (Tezos_storage.Context.set ctxt
              (cons "a" % string (cons "b" % string []))
              (Stdlib.Bytes.of_string "Novembre" % string))
            (fun ctxt =>
              op_gt_gt_eq
                (Tezos_storage.Context.set ctxt
                  (cons "a" % string (cons "c" % string []))
                  (Stdlib.Bytes.of_string "Juin" % string))
                (fun ctxt =>
                  op_gt_gt_eq
                    (Tezos_storage.Context.set ctxt
                      (cons "a" % string
                        (cons "d" % string (cons "e" % string [])))
                      (Stdlib.Bytes.of_string "Septembre" % string))
                    (fun ctxt =>
                      op_gt_gt_eq
                        (Tezos_storage.Context.set ctxt (cons "f" % string [])
                          (Stdlib.Bytes.of_string "Avril" % string))
                        (fun ctxt =>
                          op_gt_gt_eq
                            (Tezos_storage.Context.set ctxt
                              (cons "g" % string (cons "h" % string []))
                              (Stdlib.Bytes.of_string "Avril" % string))
                            (fun ctxt =>
                              op_gt_gt_eq (keys ctxt [])
                                (fun l =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Stdlib.__LOC__
                                    (cons
                                      (cons "a" % string (cons "b" % string []))
                                      (cons
                                        (cons "a" % string
                                          (cons "c" % string []))
                                        (cons
                                          (cons "a" % string
                                            (cons "d" % string
                                              (cons "e" % string [])))
                                          (cons (cons "f" % string [])
                                            (cons
                                              (cons "g" % string
                                                (cons "h" % string [])) [])))))
                                    (Tezos_base__TzPervasives.List.sort
                                      OCaml.Stdlib.compare l);
                                  op_gt_gt_eq (keys ctxt (cons "a" % string []))
                                    (fun l =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Stdlib.__LOC__
                                        (cons
                                          (cons "a" % string
                                            (cons "b" % string []))
                                          (cons
                                            (cons "a" % string
                                              (cons "c" % string []))
                                            (cons
                                              (cons "a" % string
                                                (cons "d" % string
                                                  (cons "e" % string []))) [])))
                                        (Tezos_base__TzPervasives.List.sort
                                          OCaml.Stdlib.compare l);
                                      op_gt_gt_eq
                                        (keys ctxt (cons "f" % string []))
                                        (fun l =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Stdlib.__LOC__ [] l;
                                          op_gt_gt_eq
                                            (keys ctxt (cons "g" % string []))
                                            (fun l =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Stdlib.__LOC__
                                                (cons
                                                  (cons "g" % string
                                                    (cons "h" % string [])) [])
                                                l;
                                              op_gt_gt_eq
                                                (keys ctxt
                                                  (cons "i" % string []))
                                                (fun l =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Stdlib.__LOC__ [] l;
                                                  Lwt.return_unit))))))))))
        end)
  end.

Definition test_dump (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | {| idx := idx; block3b := block3b |} =>
    op_gt_gt_eq
      (Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir "tezos_test_" % string
        (fun base_dir2 =>
          let dumpfile := op_div_div base_dir2 "dump" % string in
          let ctxt_hash := block3b in
          let history_mode := Tezos_shell_services.History_mode.Full in
          let empty_block_header (context : Tezos_crypto.Context_hash.t)
            : Tezos_base__TzPervasives.Block_header.t :=
            {|
              shell :=
                {| level := 0; proto_level := 0;
                  predecessor := Tezos_base__TzPervasives.Block_hash.zero;
                  timestamp := Tezos_base__TzPervasives.Time.Protocol.epoch;
                  validation_passes := 0;
                  operations_hash :=
                    Tezos_base__TzPervasives.Operation_list_list_hash.zero;
                  fitness := []; context := context |};
              protocol_data := Stdlib.Bytes.empty |} in
          let _empty_pruned_block :=
            {|
              block_header :=
                empty_block_header Tezos_base__TzPervasives.Context_hash.zero;
              operations := []; operation_hashes := [] |} in
          let empty :=
            {|
              Context.Block_data.block_header :=
                empty_block_header Tezos_base__TzPervasives.Context_hash.zero;
              Context.Block_data.operations := cons [] [] |} in
          let bhs :=
            (fun context =>
              ((empty_block_header context), empty, history_mode,
                (fun function_parameter =>
                  match function_parameter with
                  | _ => Tezos_base__TzPervasives._return (None, None)
                  end))) ctxt_hash in
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_storage.Context.dump_contexts idx bhs dumpfile)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let root := op_div_div base_dir2 "context" % string in
                op_gt_gt_eq (Tezos_storage.Context.init None None None root)
                  (fun idx2 =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_storage.Context.restore_contexts idx2 dumpfile
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => Tezos_base__TzPervasives.return_unit
                          end)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            fun function_parameter =>
                              match function_parameter with
                              | _ =>
                                fun function_parameter =>
                                  match function_parameter with
                                  | _ => Tezos_base__TzPervasives.return_unit
                                  end
                              end
                          end))
                      (fun imported =>
                        match imported with
                        | (bh, _, _, _, _, _) =>
                          let expected_ctxt_hash :=
                            context (Block_header.shell bh) in
                          Tezos_base__TzPervasives.Context_hash.equal ctxt_hash
                            expected_ctxt_hash;
                          Tezos_base__TzPervasives._return tt
                        end))
              end)))
      (fun function_parameter =>
        match function_parameter with
        | inr err =>
          Tezos_base__TzPervasives.Error_monad.pp_print_error
            Stdlib.Format.err_formatter err;
          false
        | inl tt => Lwt.return_unit
        end)
  end.

Definition tests : list (string * (t -> Lwt.t unit)) :=
  cons ("simple" % string, test_simple)
    (cons ("continuation" % string, test_continuation)
      (cons ("fork" % string, test_fork)
        (cons ("replay" % string, test_replay)
          (cons ("fold" % string, test_fold)
            (cons ("dump" % string, test_dump) []))))).

Definition tests {A : Type} : list A :=
  Tezos_base__TzPervasives.List.map
    (fun function_parameter =>
      match function_parameter with
      | (s, f) =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star s variant (wrap_context_init f)
      end) tests.
src/lib_storage/test/test_raw_store.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Raw_store

let ( >>= ) = Lwt.bind

let ( >|= ) = Lwt.( >|= )

let ( // ) = Filename.concat

let wrap_store_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "store" in
      init ~mapsize:4_096_000L root
      >>= function
      | Error _ -> Assert.fail_msg "wrap_store_init" | Ok store -> f store)

let entries s k =
  fold s k ~init:[] ~f:(fun e acc -> Lwt.return (e :: acc)) >|= List.rev

let test_fold st =
  store st ["a"; "b"] (Bytes.of_string "Novembre")
  >>= fun _ ->
  store st ["a"; "c"] (Bytes.of_string "Juin")
  >>= fun _ ->
  store st ["a"; "d"; "e"] (Bytes.of_string "Septembre")
  >>= fun _ ->
  store st ["f"] (Bytes.of_string "Avril")
  >>= fun _ ->
  (* The code of '.' is just below the one of '/' ! *)
  store st ["g"; ".12"; "a"] (Bytes.of_string "Mai")
  >>= fun _ ->
  store st ["g"; ".12"; "b"] (Bytes.of_string "Février")
  >>= fun _ ->
  store st ["g"; "123"; "456"] (Bytes.of_string "Mars")
  >>= fun _ ->
  store st ["g"; "1230"] (Bytes.of_string "Janvier")
  >>= fun _ ->
  entries st []
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [`Dir ["a"]; `Key ["f"]; `Dir ["g"]] l ;
  entries st ["0"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  entries st ["0"; "1"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  entries st ["a"]
  >>= fun l ->
  Assert.equal_key_dir_list
    ~msg:__LOC__
    [`Key ["a"; "b"]; `Key ["a"; "c"]; `Dir ["a"; "d"]]
    l ;
  entries st ["a"; "d"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [`Key ["a"; "d"; "e"]] l ;
  entries st ["f"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  entries st ["f"; "z"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  entries st ["g"]
  >>= fun l ->
  Assert.equal_key_dir_list
    ~msg:__LOC__
    [`Dir ["g"; ".12"]; `Dir ["g"; "123"]; `Key ["g"; "1230"]]
    l ;
  entries st ["g"; "123"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [`Key ["g"; "123"; "456"]] l ;
  entries st ["z"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  Lwt.return_unit

let tests = [Alcotest_lwt.test_case "fold" `Quick (wrap_store_init test_fold)]
src/lib_storage/test/test_raw_store.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_storage.Raw_store.

Definition op_gt_gt_eq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.bind.

Definition op_gt_pipe_eq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
  Lwt.op_gt_pipe_eq.

Definition op_div_div : string -> string -> string := Stdlib.Filename.concat.

Definition wrap_store_init {A B : Type}
  (f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
  : unit -> Lwt.t A :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_stdlib_unix.Lwt_utils_unix.with_tempdir "tezos_test_" % string
          (fun base_dir =>
            let root := op_div_div base_dir "store" % string in
            op_gt_gt_eq (Tezos_storage.Raw_store.init None (Some 4096000) root)
              (fun function_parameter =>
                match function_parameter with
                | inr _ =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "wrap_store_init" % string
                | inl store => f store
                end))
      end
  end.

Definition entries
  (s : Tezos_storage.Raw_store.t) (k : Tezos_storage.Raw_store.key)
  : Lwt.t (list variant) :=
  op_gt_pipe_eq
    (Tezos_storage.Raw_store.fold s k []
      (fun e => fun acc => Lwt._return (cons e acc)))
    Tezos_base__TzPervasives.List.rev.

Definition test_fold (st : Tezos_storage.Raw_store.t) : Lwt.t unit :=
  op_gt_gt_eq
    (Tezos_storage.Raw_store.store st (cons "a" % string (cons "b" % string []))
      (Stdlib.Bytes.of_string "Novembre" % string))
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        op_gt_gt_eq
          (Tezos_storage.Raw_store.store st
            (cons "a" % string (cons "c" % string []))
            (Stdlib.Bytes.of_string "Juin" % string))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              op_gt_gt_eq
                (Tezos_storage.Raw_store.store st
                  (cons "a" % string (cons "d" % string (cons "e" % string [])))
                  (Stdlib.Bytes.of_string "Septembre" % string))
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    op_gt_gt_eq
                      (Tezos_storage.Raw_store.store st (cons "f" % string [])
                        (Stdlib.Bytes.of_string "Avril" % string))
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          op_gt_gt_eq
                            (Tezos_storage.Raw_store.store st
                              (cons "g" % string
                                (cons ".12" % string (cons "a" % string [])))
                              (Stdlib.Bytes.of_string "Mai" % string))
                            (fun function_parameter =>
                              match function_parameter with
                              | _ =>
                                op_gt_gt_eq
                                  (Tezos_storage.Raw_store.store st
                                    (cons "g" % string
                                      (cons ".12" % string
                                        (cons "b" % string [])))
                                    (Stdlib.Bytes.of_string "Février" % string))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ =>
                                      op_gt_gt_eq
                                        (Tezos_storage.Raw_store.store st
                                          (cons "g" % string
                                            (cons "123" % string
                                              (cons "456" % string [])))
                                          (Stdlib.Bytes.of_string
                                            "Mars" % string))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | _ =>
                                            op_gt_gt_eq
                                              (Tezos_storage.Raw_store.store st
                                                (cons "g" % string
                                                  (cons "1230" % string []))
                                                (Stdlib.Bytes.of_string
                                                  "Janvier" % string))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | _ =>
                                                  op_gt_gt_eq (entries st [])
                                                    (fun l =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Stdlib.__LOC__
                                                        (cons variant
                                                          (cons variant
                                                            (cons variant [])))
                                                        l;
                                                      op_gt_gt_eq
                                                        (entries st
                                                          (cons "0" % string []))
                                                        (fun l =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Stdlib.__LOC__ [] l;
                                                          op_gt_gt_eq
                                                            (entries st
                                                              (cons "0" % string
                                                                (cons
                                                                  "1" % string
                                                                  [])))
                                                            (fun l =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                Stdlib.__LOC__
                                                                [] l;
                                                              op_gt_gt_eq
                                                                (entries st
                                                                  (cons
                                                                    "a" % string
                                                                    []))
                                                                (fun l =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    Stdlib.__LOC__
                                                                    (cons
                                                                      variant
                                                                      (cons
                                                                        variant
                                                                        (cons
                                                                          variant
                                                                          [])))
                                                                    l;
                                                                  op_gt_gt_eq
                                                                    (entries st
                                                                      (cons
                                                                        "a" %
                                                                          string
                                                                        (cons
                                                                          "d" %
                                                                            string
                                                                          [])))
                                                                    (fun l =>
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        Stdlib.__LOC__
                                                                        (cons
                                                                          variant
                                                                          []) l;
                                                                      op_gt_gt_eq
                                                                        (entries
                                                                          st
                                                                          (cons
                                                                            "f"
                                                                              %
                                                                              string
                                                                            []))
                                                                        (fun l
                                                                          =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            Stdlib.__LOC__
                                                                            [] l;
                                                                          op_gt_gt_eq
                                                                            (entries
                                                                              st
                                                                              (cons
                                                                                "f"
                                                                                  %
                                                                                  string
                                                                                (cons
                                                                                  "z"
                                                                                    %
                                                                                    string
                                                                                  [])))
                                                                            (fun
                                                                              l
                                                                              =>
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                Stdlib.__LOC__
                                                                                []
                                                                                l;
                                                                              op_gt_gt_eq
                                                                                (entries
                                                                                  st
                                                                                  (cons
                                                                                    "g"
                                                                                      %
                                                                                      string
                                                                                    []))
                                                                                (fun
                                                                                  l
                                                                                  =>
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    Stdlib.__LOC__
                                                                                    (cons
                                                                                      variant
                                                                                      (cons
                                                                                        variant
                                                                                        (cons
                                                                                          variant
                                                                                          [])))
                                                                                    l;
                                                                                  op_gt_gt_eq
                                                                                    (entries
                                                                                      st
                                                                                      (cons
                                                                                        "g"
                                                                                          %
                                                                                          string
                                                                                        (cons
                                                                                          "123"
                                                                                            %
                                                                                            string
                                                                                          [])))
                                                                                    (fun
                                                                                      l
                                                                                      =>
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        Stdlib.__LOC__
                                                                                        (cons
                                                                                          variant
                                                                                          [])
                                                                                        l;
                                                                                      op_gt_gt_eq
                                                                                        (entries
                                                                                          st
                                                                                          (cons
                                                                                            "z"
                                                                                              %
                                                                                              string
                                                                                            []))
                                                                                        (fun
                                                                                          l
                                                                                          =>
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            Stdlib.__LOC__
                                                                                            []
                                                                                            l;
                                                                                          Lwt.return_unit))))))))))
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end).

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "fold" % string variant
      (wrap_store_init test_fold)) [].
src/lib_validation/block_validation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Block_validator_errors

type validation_store = {
  context_hash : Context_hash.t;
  message : string option;
  max_operations_ttl : int;
  last_allowed_fork_level : Int32.t;
}

let validation_store_encoding =
  let open Data_encoding in
  conv
    (fun {context_hash; message; max_operations_ttl; last_allowed_fork_level} ->
      (context_hash, message, max_operations_ttl, last_allowed_fork_level))
    (fun (context_hash, message, max_operations_ttl, last_allowed_fork_level) ->
      {context_hash; message; max_operations_ttl; last_allowed_fork_level})
    (obj4
       (req "context_hash" Context_hash.encoding)
       (req "message" (option string))
       (req "max_operations_ttl" int31)
       (req "last_allowed_fork_level" int32))

type result = {
  validation_store : validation_store;
  block_metadata : Bytes.t;
  ops_metadata : Bytes.t list list;
  forking_testchain : bool;
}

let update_testchain_status ctxt predecessor_header timestamp =
  Context.get_test_chain ctxt
  >>= function
  | Not_running ->
      return ctxt
  | Running {expiration; _} ->
      if Time.Protocol.(expiration <= timestamp) then
        Context.set_test_chain ctxt Not_running >>= fun ctxt -> return ctxt
      else return ctxt
  | Forking {protocol; expiration} ->
      let predecessor_hash = Block_header.hash predecessor_header in
      let genesis = Context.compute_testchain_genesis predecessor_hash in
      let chain_id = Chain_id.of_block_hash genesis in
      (* legacy semantics *)
      Context.set_test_chain
        ctxt
        (Running {chain_id; genesis; protocol; expiration})
      >>= fun ctxt -> return ctxt

let is_testchain_forking ctxt =
  Context.get_test_chain ctxt
  >>= function
  | Not_running | Running _ -> Lwt.return_false | Forking _ -> Lwt.return_true

let init_test_chain ctxt forked_header =
  Context.get_test_chain ctxt
  >>= function
  | Not_running | Running _ ->
      assert false
  | Forking {protocol; _} ->
      ( match Registered_protocol.get protocol with
      | Some proto ->
          return proto
      | None ->
          fail (Missing_test_protocol protocol) )
      >>=? fun (module Proto_test) ->
      let test_ctxt = Shell_context.wrap_disk_context ctxt in
      Proto_test.init test_ctxt forked_header.Block_header.shell
      >>=? fun {context = test_ctxt; _} ->
      let test_ctxt = Shell_context.unwrap_disk_context test_ctxt in
      Context.set_test_chain test_ctxt Not_running
      >>= fun test_ctxt ->
      Context.set_protocol test_ctxt protocol
      >>= fun test_ctxt ->
      Context.commit_test_chain_genesis test_ctxt forked_header
      >>= fun genesis_header -> return genesis_header

let result_encoding =
  let open Data_encoding in
  conv
    (fun {validation_store; block_metadata; ops_metadata; forking_testchain} ->
      (validation_store, block_metadata, ops_metadata, forking_testchain))
    (fun (validation_store, block_metadata, ops_metadata, forking_testchain) ->
      {validation_store; block_metadata; ops_metadata; forking_testchain})
    (obj4
       (req "validation_store" validation_store_encoding)
       (req "block_metadata" bytes)
       (req "ops_metadata" (list @@ list @@ bytes))
       (req "forking_testchain" bool))

let may_force_protocol_upgrade ~level
    (validation_result : Tezos_protocol_environment.validation_result) =
  match Block_header.get_forced_protocol_upgrade ~level with
  | None ->
      Lwt.return validation_result
  | Some hash ->
      let context =
        Shell_context.unwrap_disk_context validation_result.context
      in
      Context.set_protocol context hash
      >>= fun context ->
      let context = Shell_context.wrap_disk_context context in
      Lwt.return {validation_result with context}

(** Applies user activated updates based either on block level or on
    voted protocols *)
let may_patch_protocol ~level
    (validation_result : Tezos_protocol_environment.validation_result) =
  let context = Shell_context.unwrap_disk_context validation_result.context in
  Context.get_protocol context
  >>= fun protocol ->
  match Block_header.get_voted_protocol_overrides protocol with
  | None ->
      may_force_protocol_upgrade ~level validation_result
  | Some replacement_protocol ->
      Context.set_protocol context replacement_protocol
      >>= fun context ->
      let context = Shell_context.wrap_disk_context context in
      Lwt.return {validation_result with context}

module Make (Proto : Registered_protocol.T) = struct
  let check_block_header ~(predecessor_block_header : Block_header.t) hash
      (block_header : Block_header.t) =
    let validation_passes = List.length Proto.validation_passes in
    fail_unless
      ( Int32.succ predecessor_block_header.shell.level
      = block_header.shell.level )
      ( invalid_block hash
      @@ Invalid_level
           {
             expected = Int32.succ predecessor_block_header.shell.level;
             found = block_header.shell.level;
           } )
    >>=? fun () ->
    fail_unless
      Time.Protocol.(
        predecessor_block_header.shell.timestamp < block_header.shell.timestamp)
      (invalid_block hash Non_increasing_timestamp)
    >>=? fun () ->
    fail_unless
      Fitness.(
        predecessor_block_header.shell.fitness < block_header.shell.fitness)
      (invalid_block hash Non_increasing_fitness)
    >>=? fun () ->
    fail_unless
      (block_header.shell.validation_passes = validation_passes)
      (invalid_block
         hash
         (Unexpected_number_of_validation_passes
            block_header.shell.validation_passes))
    >>=? fun () -> return_unit

  let parse_block_header block_hash (block_header : Block_header.t) =
    match
      Data_encoding.Binary.of_bytes
        Proto.block_header_data_encoding
        block_header.protocol_data
    with
    | None ->
        fail (invalid_block block_hash Cannot_parse_block_header)
    | Some protocol_data ->
        return
          ({shell = block_header.shell; protocol_data} : Proto.block_header)

  let check_operation_quota block_hash operations =
    let invalid_block = invalid_block block_hash in
    iteri2_p
      (fun i ops quota ->
        fail_unless
          (Option.unopt_map
             ~default:true
             ~f:(fun max -> List.length ops <= max)
             quota.Tezos_protocol_environment.max_op)
          (let max = Option.unopt ~default:~-1 quota.max_op in
           invalid_block
             (Too_many_operations {pass = i + 1; found = List.length ops; max}))
        >>=? fun () ->
        iter_p
          (fun op ->
            let size = Data_encoding.Binary.length Operation.encoding op in
            fail_unless
              (size <= Proto.max_operation_data_length)
              (invalid_block
                 (Oversized_operation
                    {
                      operation = Operation.hash op;
                      size;
                      max = Proto.max_operation_data_length;
                    })))
          ops
        >>=? fun () -> return_unit)
      operations
      Proto.validation_passes

  let parse_operations block_hash operations =
    let invalid_block = invalid_block block_hash in
    mapi_s
      (fun pass ->
        map_s (fun op ->
            let op_hash = Operation.hash op in
            match
              Data_encoding.Binary.of_bytes
                Proto.operation_data_encoding
                op.Operation.proto
            with
            | None ->
                fail (invalid_block (Cannot_parse_operation op_hash))
            | Some protocol_data ->
                let op = {Proto.shell = op.shell; protocol_data} in
                let allowed_pass = Proto.acceptable_passes op in
                fail_unless
                  (List.mem pass allowed_pass)
                  (invalid_block
                     (Unallowed_pass {operation = op_hash; pass; allowed_pass}))
                >>=? fun () -> return op))
      operations

  let apply chain_id ~max_operations_ttl
      ~(predecessor_block_header : Block_header.t) ~predecessor_context
      ~(block_header : Block_header.t) operations =
    let block_hash = Block_header.hash block_header in
    let invalid_block = invalid_block block_hash in
    check_block_header ~predecessor_block_header block_hash block_header
    >>=? fun () ->
    parse_block_header block_hash block_header
    >>=? fun block_header ->
    check_operation_quota block_hash operations
    >>=? fun () ->
    update_testchain_status
      predecessor_context
      predecessor_block_header
      block_header.shell.timestamp
    >>=? fun context ->
    parse_operations block_hash operations
    >>=? fun operations ->
    let context = Shell_context.wrap_disk_context context in
    Proto.begin_application
      ~chain_id
      ~predecessor_context:context
      ~predecessor_timestamp:predecessor_block_header.shell.timestamp
      ~predecessor_fitness:predecessor_block_header.shell.fitness
      block_header
    >>=? (fun state ->
           fold_left_s
             (fun (state, acc) ops ->
               fold_left_s
                 (fun (state, acc) op ->
                   Proto.apply_operation state op
                   >>=? fun (state, op_metadata) ->
                   return (state, op_metadata :: acc))
                 (state, [])
                 ops
               >>=? fun (state, ops_metadata) ->
               return (state, List.rev ops_metadata :: acc))
             (state, [])
             operations
           >>=? fun (state, ops_metadata) ->
           let ops_metadata = List.rev ops_metadata in
           Proto.finalize_block state
           >>=? fun (validation_result, block_data) ->
           return (validation_result, block_data, ops_metadata))
    >>= (function
          | Error err ->
              fail (invalid_block (Economic_protocol_error err))
          | Ok o ->
              return o)
    >>=? fun (validation_result, block_data, ops_metadata) ->
    (* reset_test_chain
     *   validation_result.context
     *   current_block_header
     *   ~start_testchain >>=? fun forked_genesis_header -> *)
    let context =
      Shell_context.unwrap_disk_context validation_result.context
    in
    is_testchain_forking context
    >>= fun forking_testchain ->
    may_patch_protocol ~level:block_header.shell.level validation_result
    >>= fun validation_result ->
    let context =
      Shell_context.unwrap_disk_context validation_result.context
    in
    Context.get_protocol context
    >>= fun new_protocol ->
    let expected_proto_level =
      if Protocol_hash.equal new_protocol Proto.hash then
        predecessor_block_header.shell.proto_level
      else (predecessor_block_header.shell.proto_level + 1) mod 256
    in
    fail_when
      (block_header.shell.proto_level <> expected_proto_level)
      (invalid_block
         (Invalid_proto_level
            {
              found = block_header.shell.proto_level;
              expected = expected_proto_level;
            }))
    >>=? fun () ->
    fail_when
      Fitness.(validation_result.fitness <> block_header.shell.fitness)
      (invalid_block
         (Invalid_fitness
            {
              expected = block_header.shell.fitness;
              found = validation_result.fitness;
            }))
    >>=? fun () ->
    ( if Protocol_hash.equal new_protocol Proto.hash then
      return validation_result
    else
      match Registered_protocol.get new_protocol with
      | None ->
          fail
            (Unavailable_protocol {block = block_hash; protocol = new_protocol})
      | Some (module NewProto) ->
          NewProto.init validation_result.context block_header.shell )
    >>=? fun validation_result ->
    let max_operations_ttl =
      max 0 (min (max_operations_ttl + 1) validation_result.max_operations_ttl)
    in
    let validation_result = {validation_result with max_operations_ttl} in
    let block_metadata =
      Data_encoding.Binary.to_bytes_exn
        Proto.block_header_metadata_encoding
        block_data
    in
    let ops_metadata =
      List.map
        (List.map
           (Data_encoding.Binary.to_bytes_exn Proto.operation_receipt_encoding))
        ops_metadata
    in
    let context =
      Shell_context.unwrap_disk_context validation_result.context
    in
    Context.commit
      ~time:block_header.shell.timestamp
      ?message:validation_result.message
      context
    >>= fun context_hash ->
    let validation_store =
      {
        context_hash;
        message = validation_result.message;
        max_operations_ttl = validation_result.max_operations_ttl;
        last_allowed_fork_level = validation_result.last_allowed_fork_level;
      }
    in
    return {validation_store; block_metadata; ops_metadata; forking_testchain}
end

let assert_no_duplicate_operations block_hash live_operations operations =
  fold_left_s
    (fold_left_s (fun live_operations op ->
         let oph = Operation.hash op in
         fail_when
           (Operation_hash.Set.mem oph live_operations)
           (invalid_block block_hash @@ Replayed_operation oph)
         >>=? fun () -> return (Operation_hash.Set.add oph live_operations)))
    live_operations
    operations
  >>=? fun _ -> return_unit

let assert_operation_liveness block_hash live_blocks operations =
  iter_s
    (iter_s (fun op ->
         fail_unless
           (Block_hash.Set.mem op.Operation.shell.branch live_blocks)
           ( invalid_block block_hash
           @@ Outdated_operation
                {
                  operation = Operation.hash op;
                  originating_block = op.shell.branch;
                } )))
    operations

let check_liveness ~live_blocks ~live_operations block_hash operations =
  assert_no_duplicate_operations block_hash live_operations operations
  >>=? fun () ->
  assert_operation_liveness block_hash live_blocks operations
  >>=? fun () -> return_unit

let apply chain_id ~max_operations_ttl
    ~(predecessor_block_header : Block_header.t) ~predecessor_context
    ~(block_header : Block_header.t) operations =
  let block_hash = Block_header.hash block_header in
  Context.get_protocol predecessor_context
  >>= fun pred_protocol_hash ->
  ( match Registered_protocol.get pred_protocol_hash with
  | None ->
      fail
        (Unavailable_protocol
           {block = block_hash; protocol = pred_protocol_hash})
  | Some p ->
      return p )
  >>=? fun (module Proto) ->
  let module Block_validation = Make (Proto) in
  Block_validation.apply
    chain_id
    ~max_operations_ttl
    ~predecessor_block_header
    ~predecessor_context
    ~block_header
    operations
  >>= function
  | Error (Exn (Unix.Unix_error (errno, fn, msg)) :: _) ->
      fail (System_error {errno; fn; msg})
  | (Ok _ | Error _) as res ->
      Lwt.return res
src/lib_validation/block_validation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_shell_services.Block_validator_errors.

Record validation_store := {
  context_hash : Tezos_base__TzPervasives.Context_hash.t;
  message : option string;
  max_operations_ttl : Z;
  last_allowed_fork_level : Stdlib.Int32.t }.

Definition validation_store_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding validation_store :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        context_hash := context_hash;
          message := message;
          max_operations_ttl := max_operations_ttl;
          last_allowed_fork_level := last_allowed_fork_level
          |} =>
        (context_hash, message, max_operations_ttl, last_allowed_fork_level)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (context_hash, message, max_operations_ttl, last_allowed_fork_level) =>
        {| context_hash := context_hash; message := message;
          max_operations_ttl := max_operations_ttl;
          last_allowed_fork_level := last_allowed_fork_level |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj4
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "context_hash" % string Tezos_base__TzPervasives.Context_hash.encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None "message" % string
        (Tezos_base__TzPervasives.Data_encoding.option
          Tezos_base__TzPervasives.Data_encoding.string))
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "max_operations_ttl" % string
        Tezos_base__TzPervasives.Data_encoding.int31)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "last_allowed_fork_level" % string
        Tezos_base__TzPervasives.Data_encoding.int32)).

Record result := {
  validation_store : validation_store;
  block_metadata : Stdlib.Bytes.t;
  ops_metadata : list (list Stdlib.Bytes.t);
  forking_testchain : bool }.

Definition update_testchain_status
  (ctxt : Tezos_storage.Context.context)
  (predecessor_header : Tezos_base__TzPervasives.Block_header.t)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_storage.Context.get_test_chain ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Not_running => Tezos_base__TzPervasives._return ctxt
      | Running {| expiration := expiration |} =>
        if Tezos_base__TzPervasives.Time.Protocol.op_lt_eq expiration timestamp
          then
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_storage.Context.set_test_chain ctxt Not_running)
            (fun ctxt => Tezos_base__TzPervasives._return ctxt)
        else
          Tezos_base__TzPervasives._return ctxt
      | Forking {| protocol := protocol; expiration := expiration |} =>
        let predecessor_hash :=
          Tezos_base__TzPervasives.Block_header.hash predecessor_header in
        let genesis :=
          Tezos_storage.Context.compute_testchain_genesis predecessor_hash in
        let chain_id := Tezos_base__TzPervasives.Chain_id.of_block_hash genesis
          in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_storage.Context.set_test_chain ctxt
            (Running
              {| chain_id := chain_id; genesis := genesis; protocol := protocol;
                expiration := expiration |}))
          (fun ctxt => Tezos_base__TzPervasives._return ctxt)
      end).

Definition is_testchain_forking (ctxt : Tezos_storage.Context.context)
  : Lwt.t bool :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_storage.Context.get_test_chain ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Not_running | Running _ => Lwt.return_false
      | Forking _ => Lwt.return_true
      end).

Definition init_test_chain
  (ctxt : Tezos_storage.Context.context)
  (forked_header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_storage.Context.get_test_chain ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Not_running | Running _ => false
      | Forking {| protocol := protocol |} =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          match Tezos_protocol_updater.Registered_protocol.get protocol with
          | Some proto => Tezos_base__TzPervasives._return proto
          | None =>
            Tezos_base__TzPervasives.fail (Missing_test_protocol protocol)
          end
          (fun Proto_test =>
            let Proto_test := projT2 Proto_test in
            let test_ctxt :=
              Tezos_shell_context.Shell_context.wrap_disk_context ctxt in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Proto_test.(Tezos_protocol_updater__Registered_protocol.T.init)
                test_ctxt (Block_header.shell forked_header))
              (fun function_parameter =>
                match function_parameter with
                | {| context := test_ctxt |} =>
                  let test_ctxt :=
                    Tezos_shell_context.Shell_context.unwrap_disk_context
                      test_ctxt in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_storage.Context.set_test_chain test_ctxt Not_running)
                    (fun test_ctxt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Tezos_storage.Context.set_protocol test_ctxt protocol)
                        (fun test_ctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Tezos_storage.Context.commit_test_chain_genesis
                              test_ctxt forked_header)
                            (fun genesis_header =>
                              Tezos_base__TzPervasives._return genesis_header)))
                end))
      end).

Definition result_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding result :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        validation_store := validation_store;
          block_metadata := block_metadata;
          ops_metadata := ops_metadata;
          forking_testchain := forking_testchain
          |} =>
        (validation_store, block_metadata, ops_metadata, forking_testchain)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (validation_store, block_metadata, ops_metadata, forking_testchain) =>
        {| validation_store := validation_store;
          block_metadata := block_metadata; ops_metadata := ops_metadata;
          forking_testchain := forking_testchain |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj4
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "validation_store" % string validation_store_encoding)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "block_metadata" % string Tezos_base__TzPervasives.Data_encoding.bytes)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "ops_metadata" % string
        (apply
          (let arg := Tezos_base__TzPervasives.Data_encoding.list in
          fun eta => arg None eta)
          (apply
            (let arg := Tezos_base__TzPervasives.Data_encoding.list in
            fun eta => arg None eta)
            Tezos_base__TzPervasives.Data_encoding.bytes)))
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "forking_testchain" % string Tezos_base__TzPervasives.Data_encoding.bool)).

Definition may_force_protocol_upgrade
  (level : Stdlib.Int32.t)
  (validation_result : Tezos_protocol_environment.validation_result)
  : Lwt.t Tezos_protocol_environment.validation_result :=
  match Tezos_base__TzPervasives.Block_header.get_forced_protocol_upgrade level
    with
  | None => Lwt._return validation_result
  | Some hash =>
    let context :=
      Tezos_shell_context.Shell_context.unwrap_disk_context
        (context validation_result) in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_storage.Context.set_protocol context hash)
      (fun context =>
        let context :=
          Tezos_shell_context.Shell_context.wrap_disk_context context in
        Lwt._return record)
  end.

Definition may_patch_protocol
  (level : Stdlib.Int32.t)
  (validation_result : Tezos_protocol_environment.validation_result)
  : Lwt.t Tezos_protocol_environment.validation_result :=
  let context :=
    Tezos_shell_context.Shell_context.unwrap_disk_context
      (context validation_result) in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_storage.Context.get_protocol context)
    (fun protocol =>
      match
        Tezos_base__TzPervasives.Block_header.get_voted_protocol_overrides
          protocol with
      | None => may_force_protocol_upgrade level validation_result
      | Some replacement_protocol =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_storage.Context.set_protocol context replacement_protocol)
          (fun context =>
            let context :=
              Tezos_shell_context.Shell_context.wrap_disk_context context in
            Lwt._return record)
      end).

Definition assert_no_duplicate_operations
  (block_hash : Tezos_base__TzPervasives.Block_hash.t)
  (live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.fold_left_s
      (Tezos_base__TzPervasives.fold_left_s
        (fun live_operations =>
          fun op =>
            let oph := Tezos_base__TzPervasives.Operation.hash op in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.fail_when
                (Tezos_base__TzPervasives.Operation_hash.Set.mem oph
                  live_operations)
                (apply
                  (Tezos_shell_services.Block_validator_errors.invalid_block
                    block_hash) (Replayed_operation oph)))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.Operation_hash.Set.add oph
                      live_operations)
                end))) live_operations operations)
    (fun function_parameter =>
      match function_parameter with
      | _ => Tezos_base__TzPervasives.return_unit
      end).

Definition assert_operation_liveness
  (block_hash : Tezos_base__TzPervasives.Block_hash.t)
  (live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.iter_s
    (Tezos_base__TzPervasives.iter_s
      (fun op =>
        Tezos_base__TzPervasives.fail_unless
          (Tezos_base__TzPervasives.Block_hash.Set.mem
            (branch (Operation.shell op)) live_blocks)
          (apply
            (Tezos_shell_services.Block_validator_errors.invalid_block
              block_hash)
            (Outdated_operation
              {| operation := Tezos_base__TzPervasives.Operation.hash op;
                originating_block := branch (shell op) |})))) operations.

Definition check_liveness
  (live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
  (live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (assert_no_duplicate_operations block_hash live_operations operations)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (assert_operation_liveness block_hash live_blocks operations)
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition apply
  (chain_id : Tezos_base__TzPervasives.Chain_id.t) (max_operations_ttl : Z)
  (predecessor_block_header : Tezos_base__TzPervasives.Block_header.t)
  (predecessor_context : Tezos_storage.Context.context)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult result) :=
  let block_hash := Tezos_base__TzPervasives.Block_header.hash block_header in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_storage.Context.get_protocol predecessor_context)
    (fun pred_protocol_hash =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        match Tezos_protocol_updater.Registered_protocol.get pred_protocol_hash
          with
        | None =>
          Tezos_base__TzPervasives.fail
            (Unavailable_protocol
              {| block := block_hash; protocol := pred_protocol_hash |})
        | Some p => Tezos_base__TzPervasives._return p
        end
        (fun Proto =>
          let Proto := projT2 Proto in
          let Block_validation := unsupported_functor_application in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Block_validation.apply chain_id max_operations_ttl
              predecessor_block_header predecessor_context block_header
              operations)
            (fun function_parameter =>
              match function_parameter with
              | inr (cons (Exn (Unix.Unix_error errno fn msg)) _) =>
                Tezos_base__TzPervasives.fail
                  (System_error {| errno := errno; fn := fn; msg := msg |})
              | (inl _ | inr _) as res => Lwt._return res
              end))).
src/lib_validation/block_validation.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type validation_store = {
  context_hash : Context_hash.t;
  message : string option;
  max_operations_ttl : int;
  last_allowed_fork_level : Int32.t;
}

val may_patch_protocol :
  level:Int32.t ->
  Tezos_protocol_environment.validation_result ->
  Tezos_protocol_environment.validation_result Lwt.t

val update_testchain_status :
  Context.t -> Block_header.t -> Time.Protocol.t -> Context.t tzresult Lwt.t

(** [init_test_chain] must only be called on a forking block. *)
val init_test_chain :
  Context.t -> Block_header.t -> Block_header.t tzresult Lwt.t

val check_liveness :
  live_blocks:Block_hash.Set.t ->
  live_operations:Operation_hash.Set.t ->
  Block_hash.t ->
  Operation.t list list ->
  unit tzresult Lwt.t

type result = {
  validation_store : validation_store;
  block_metadata : Bytes.t;
  ops_metadata : Bytes.t list list;
  forking_testchain : bool;
}

val result_encoding : result Data_encoding.t

val apply :
  Chain_id.t ->
  max_operations_ttl:int ->
  predecessor_block_header:Block_header.t ->
  predecessor_context:Context.t ->
  block_header:Block_header.t ->
  Operation.t list list ->
  result tzresult Lwt.t
src/lib_validation/block_validation.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record validation_store := {
  context_hash : Tezos_base__TzPervasives.Context_hash.t;
  message : option string;
  max_operations_ttl : Z;
  last_allowed_fork_level : Stdlib.Int32.t }.

Parameter may_patch_protocol :
Stdlib.Int32.t ->
  Tezos_protocol_environment.validation_result ->
    Lwt.t Tezos_protocol_environment.validation_result.

Parameter update_testchain_status :
Tezos_storage.Context.t ->
  Tezos_base__TzPervasives.Block_header.t ->
    Tezos_base__TzPervasives.Time.Protocol.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.t).

Parameter init_test_chain :
Tezos_storage.Context.t ->
  Tezos_base__TzPervasives.Block_header.t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t).

Parameter check_liveness :
Tezos_base__TzPervasives.Block_hash.Set.t ->
  Tezos_base__TzPervasives.Operation_hash.Set.t ->
    Tezos_base__TzPervasives.Block_hash.t ->
      (list (list Tezos_base__TzPervasives.Operation.t)) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Record result := {
  validation_store : validation_store;
  block_metadata : Stdlib.Bytes.t;
  ops_metadata : list (list Stdlib.Bytes.t);
  forking_testchain : bool }.

Parameter result_encoding : Tezos_base__TzPervasives.Data_encoding.t result.

Parameter apply :
Tezos_base__TzPervasives.Chain_id.t ->
  Z ->
    Tezos_base__TzPervasives.Block_header.t ->
      Tezos_storage.Context.t ->
        Tezos_base__TzPervasives.Block_header.t ->
          (list (list Tezos_base__TzPervasives.Operation.t)) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult result).
src/lib_validation/external_validation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type parameters = {
  context_root : string;
  protocol_root : string;
  sandbox_parameters : Data_encoding.json option;
}

type request =
  | Init
  | Validate of {
      chain_id : Chain_id.t;
      block_header : Block_header.t;
      predecessor_block_header : Block_header.t;
      operations : Operation.t list list;
      max_operations_ttl : int;
    }
  | Commit_genesis of {
      chain_id : Chain_id.t;
      genesis_hash : Block_hash.t;
      time : Time.Protocol.t;
      protocol : Protocol_hash.t;
    }
  | Fork_test_chain of {
      context_hash : Context_hash.t;
      forked_header : Block_header.t;
    }
  | Terminate

let magic = Bytes.of_string "TEZOS_FORK_VALIDATOR_MAGIC_0"

let parameters_encoding =
  let open Data_encoding in
  conv
    (fun {context_root; protocol_root; sandbox_parameters} ->
      (context_root, protocol_root, sandbox_parameters))
    (fun (context_root, protocol_root, sandbox_parameters) ->
      {context_root; protocol_root; sandbox_parameters})
    (obj3
       (req "context_root" string)
       (req "protocol_root" string)
       (opt "sandbox_parameters" json))

let request_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"init"
        empty
        (function
          | Init ->
              Some ()
          | Commit_genesis _ | Validate _ | Fork_test_chain _ | Terminate ->
              None)
        (fun () -> Init);
      case
        (Tag 1)
        ~title:"validate"
        (obj5
           (req "chain_id" Chain_id.encoding)
           (req "block_header" (dynamic_size Block_header.encoding))
           (req "pred_header" (dynamic_size Block_header.encoding))
           (req "max_operations_ttl" int31)
           (req "operations" (list (list (dynamic_size Operation.encoding)))))
        (function
          | Validate
              { chain_id;
                block_header;
                predecessor_block_header;
                max_operations_ttl;
                operations } ->
              Some
                ( chain_id,
                  block_header,
                  predecessor_block_header,
                  max_operations_ttl,
                  operations )
          | Init | Commit_genesis _ | Fork_test_chain _ | Terminate ->
              None)
        (fun ( chain_id,
               block_header,
               predecessor_block_header,
               max_operations_ttl,
               operations ) ->
          Validate
            {
              chain_id;
              block_header;
              predecessor_block_header;
              max_operations_ttl;
              operations;
            });
      case
        (Tag 2)
        ~title:"commit_genesis"
        (obj4
           (req "chain_id" Chain_id.encoding)
           (req "time" Time.Protocol.encoding)
           (req "genesis_hash" Block_hash.encoding)
           (req "protocol" Protocol_hash.encoding))
        (function
          | Commit_genesis {chain_id; time; genesis_hash; protocol} ->
              Some (chain_id, time, genesis_hash, protocol)
          | Init | Validate _ | Fork_test_chain _ | Terminate ->
              None)
        (fun (chain_id, time, genesis_hash, protocol) ->
          Commit_genesis {chain_id; time; genesis_hash; protocol});
      case
        (Tag 3)
        ~title:"fork_test_chain"
        (obj2
           (req "context_hash" Context_hash.encoding)
           (req "forked_header" Block_header.encoding))
        (function
          | Fork_test_chain {context_hash; forked_header} ->
              Some (context_hash, forked_header)
          | Init | Validate _ | Commit_genesis _ | Terminate ->
              None)
        (fun (context_hash, forked_header) ->
          Fork_test_chain {context_hash; forked_header});
      case
        (Tag 4)
        ~title:"terminate"
        unit
        (function
          | Terminate ->
              Some ()
          | Init | Validate _ | Commit_genesis _ | Fork_test_chain _ ->
              None)
        (fun () -> Terminate) ]

let send pin encoding data =
  let msg = Data_encoding.Binary.to_bytes_exn encoding data in
  Lwt_io.write_int pin (Bytes.length msg)
  >>= fun () ->
  Lwt_io.write pin (Bytes.to_string msg) >>= fun () -> Lwt_io.flush pin

let recv_result pout encoding =
  Lwt_io.read_int pout
  >>= fun count ->
  let buf = Bytes.create count in
  Lwt_io.read_into_exactly pout buf 0 count
  >>= fun () ->
  Lwt.return
    (Data_encoding.Binary.of_bytes_exn
       (Error_monad.result_encoding encoding)
       buf)

let recv pout encoding =
  Lwt_io.read_int pout
  >>= fun count ->
  let buf = Bytes.create count in
  Lwt_io.read_into_exactly pout buf 0 count
  >>= fun () -> Lwt.return (Data_encoding.Binary.of_bytes_exn encoding buf)
src/lib_validation/external_validation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record parameters := {
  context_root : string;
  protocol_root : string;
  sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json }.

Inductive request : Type :=
| Init : request
| Validate : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_header.t ->
  Tezos_base__TzPervasives.Block_header.t ->
  (list (list Tezos_base__TzPervasives.Operation.t)) -> Z -> request
| Commit_genesis : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_hash.t ->
  Tezos_base__TzPervasives.Time.Protocol.t ->
  Tezos_base__TzPervasives.Protocol_hash.t -> request
| Fork_test_chain : Tezos_base__TzPervasives.Context_hash.t ->
  Tezos_base__TzPervasives.Block_header.t -> request
| Terminate : request.

Definition magic : string :=
  Stdlib.Bytes.of_string "TEZOS_FORK_VALIDATOR_MAGIC_0" % string.

Definition parameters_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding parameters :=
  Tezos_base__TzPervasives.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        context_root := context_root;
          protocol_root := protocol_root;
          sandbox_parameters := sandbox_parameters
          |} => (context_root, protocol_root, sandbox_parameters)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (context_root, protocol_root, sandbox_parameters) =>
        {| context_root := context_root; protocol_root := protocol_root;
          sandbox_parameters := sandbox_parameters |}
      end) None
    (Tezos_base__TzPervasives.Data_encoding.obj3
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "context_root" % string Tezos_base__TzPervasives.Data_encoding.string)
      (Tezos_base__TzPervasives.Data_encoding.req None None
        "protocol_root" % string Tezos_base__TzPervasives.Data_encoding.string)
      (Tezos_base__TzPervasives.Data_encoding.opt None None
        "sandbox_parameters" % string
        Tezos_base__TzPervasives.Data_encoding.json)).

Definition request_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding request :=
  Tezos_base__TzPervasives.Data_encoding.union None
    (cons
      (Tezos_base__TzPervasives.Data_encoding.case "init" % string None (Tag 0)
        Tezos_base__TzPervasives.Data_encoding.empty
        (fun function_parameter =>
          match function_parameter with
          | Init => Some tt
          | Commit_genesis _ | Validate _ | Fork_test_chain _ | Terminate =>
            None
          end)
        (fun function_parameter =>
          match function_parameter with
          | tt => Init
          end))
      (cons
        (Tezos_base__TzPervasives.Data_encoding.case "validate" % string None
          (Tag 1)
          (Tezos_base__TzPervasives.Data_encoding.obj5
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "block_header" % string
              (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                Tezos_base__TzPervasives.Block_header.encoding))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "pred_header" % string
              (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                Tezos_base__TzPervasives.Block_header.encoding))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "max_operations_ttl" % string
              Tezos_base__TzPervasives.Data_encoding.int31)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "operations" % string
              (Tezos_base__TzPervasives.Data_encoding.list None
                (Tezos_base__TzPervasives.Data_encoding.list None
                  (Tezos_base__TzPervasives.Data_encoding.dynamic_size None
                    Tezos_base__TzPervasives.Operation.encoding)))))
          (fun function_parameter =>
            match function_parameter with
            |
              Validate {|
                chain_id := chain_id;
                  block_header := block_header;
                  predecessor_block_header := predecessor_block_header;
                  operations := operations;
                  max_operations_ttl := max_operations_ttl
                  |} =>
              Some
                (chain_id, block_header, predecessor_block_header,
                  max_operations_ttl, operations)
            | Init | Commit_genesis _ | Fork_test_chain _ | Terminate => None
            end)
          (fun function_parameter =>
            match function_parameter with
            |
              (chain_id, block_header, predecessor_block_header,
                max_operations_ttl, operations) =>
              Validate
                {| chain_id := chain_id; block_header := block_header;
                  predecessor_block_header := predecessor_block_header;
                  operations := operations;
                  max_operations_ttl := max_operations_ttl |}
            end))
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "commit_genesis" % string
            None (Tag 2)
            (Tezos_base__TzPervasives.Data_encoding.obj4
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "chain_id" % string Tezos_base__TzPervasives.Chain_id.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "time" % string Tezos_base__TzPervasives.Time.Protocol.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "genesis_hash" % string
                Tezos_base__TzPervasives.Block_hash.encoding)
              (Tezos_base__TzPervasives.Data_encoding.req None None
                "protocol" % string
                Tezos_base__TzPervasives.Protocol_hash.encoding))
            (fun function_parameter =>
              match function_parameter with
              |
                Commit_genesis {|
                  chain_id := chain_id;
                    genesis_hash := genesis_hash;
                    time := time;
                    protocol := protocol
                    |} => Some (chain_id, time, genesis_hash, protocol)
              | Init | Validate _ | Fork_test_chain _ | Terminate => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (chain_id, time, genesis_hash, protocol) =>
                Commit_genesis
                  {| chain_id := chain_id; genesis_hash := genesis_hash;
                    time := time; protocol := protocol |}
              end))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case
              "fork_test_chain" % string None (Tag 3)
              (Tezos_base__TzPervasives.Data_encoding.obj2
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "context_hash" % string
                  Tezos_base__TzPervasives.Context_hash.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "forked_header" % string
                  Tezos_base__TzPervasives.Block_header.encoding))
              (fun function_parameter =>
                match function_parameter with
                |
                  Fork_test_chain {|
                    context_hash := context_hash;
                      forked_header := forked_header
                      |} => Some (context_hash, forked_header)
                | Init | Validate _ | Commit_genesis _ | Terminate => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (context_hash, forked_header) =>
                  Fork_test_chain
                    {| context_hash := context_hash;
                      forked_header := forked_header |}
                end))
            (cons
              (Tezos_base__TzPervasives.Data_encoding.case "terminate" % string
                None (Tag 4) Tezos_base__TzPervasives.Data_encoding.unit
                (fun function_parameter =>
                  match function_parameter with
                  | Terminate => Some tt
                  | Init | Validate _ | Commit_genesis _ | Fork_test_chain _ =>
                    None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Terminate
                  end)) []))))).

Definition send {A : Type}
  (pin : Lwt_io.output_channel)
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) (data : A)
  : Lwt.t unit :=
  let msg :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn encoding data in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Lwt_io.write_int pin (String.length msg))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Lwt_io.write pin (Stdlib.Bytes.to_string msg))
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt_io.flush pin
            end)
      end).

Definition recv_result {A : Type}
  (pout : Lwt_io.input_channel)
  (encoding : Tezos_data_encoding.Data_encoding.t A)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_io.read_int pout)
    (fun count =>
      let buf := Stdlib.Bytes.create count in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt_io.read_into_exactly pout buf 0 count)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Lwt._return
              (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                (Tezos_base__TzPervasives.Error_monad.result_encoding encoding)
                buf)
          end)).

Definition recv {A : Type}
  (pout : Lwt_io.input_channel)
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) : Lwt.t A :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_io.read_int pout)
    (fun count =>
      let buf := Stdlib.Bytes.create count in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt_io.read_into_exactly pout buf 0 count)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Lwt._return
              (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                encoding buf)
          end)).
src/lib_validation/external_validation.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type parameters = {
  context_root : string;
  protocol_root : string;
  sandbox_parameters : Data_encoding.json option;
}

type request =
  | Init
  | Validate of {
      chain_id : Chain_id.t;
      block_header : Block_header.t;
      predecessor_block_header : Block_header.t;
      operations : Operation.t list list;
      max_operations_ttl : int;
    }
  | Commit_genesis of {
      chain_id : Chain_id.t;
      genesis_hash : Block_hash.t;
      time : Time.Protocol.t;
      protocol : Protocol_hash.t;
    }
  | Fork_test_chain of {
      context_hash : Context_hash.t;
      forked_header : Block_header.t;
    }
  | Terminate

val magic : MBytes.t

val parameters_encoding : parameters Data_encoding.t

val request_encoding : request Data_encoding.t

val send : Lwt_io.output_channel -> 'a Data_encoding.t -> 'a -> unit Lwt.t

val recv : Lwt_io.input_channel -> 'a Data_encoding.t -> 'a Lwt.t

val recv_result :
  Lwt_io.input_channel -> 'a Data_encoding.t -> 'a tzresult Lwt.t
src/lib_validation/external_validation.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record parameters := {
  context_root : string;
  protocol_root : string;
  sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json }.

Inductive request : Type :=
| Init : request
| Validate : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_header.t ->
  Tezos_base__TzPervasives.Block_header.t ->
  (list (list Tezos_base__TzPervasives.Operation.t)) -> Z -> request
| Commit_genesis : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_hash.t ->
  Tezos_base__TzPervasives.Time.Protocol.t ->
  Tezos_base__TzPervasives.Protocol_hash.t -> request
| Fork_test_chain : Tezos_base__TzPervasives.Context_hash.t ->
  Tezos_base__TzPervasives.Block_header.t -> request
| Terminate : request.

Parameter magic : Tezos_base__TzPervasives.MBytes.t.

Parameter parameters_encoding :
Tezos_base__TzPervasives.Data_encoding.t parameters.

Parameter request_encoding : Tezos_base__TzPervasives.Data_encoding.t request.

Parameter send : forall {a : Type},
Lwt_io.output_channel ->
  (Tezos_base__TzPervasives.Data_encoding.t a) -> a -> Lwt.t unit.

Parameter recv : forall {a : Type},
Lwt_io.input_channel -> (Tezos_base__TzPervasives.Data_encoding.t a) -> Lwt.t a.

Parameter recv_result : forall {a : Type},
Lwt_io.input_channel ->
  (Tezos_base__TzPervasives.Data_encoding.t a) ->
    Lwt.t (Tezos_base__TzPervasives.tzresult a).
src/lib_version/current_git_info.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* When we (or the CI) run "git archive", git substitutes the dollar-format part
   because this file is marked as "export-subst" in ".gitattributes".

   To know whether we are in a Git repository or in an archive, we check whether
   the string was substituted. Thanks to this, we know whether we should get the
   hash from Generated_git_info (not available in archives) or not. *)

let raw_commit_hash = "$Format:%H$"

let commit_hash =
  if String.equal raw_commit_hash ("$Format" ^ ":%H$") then
    Generated_git_info.commit_hash
  else raw_commit_hash

let abbreviated_commit_hash =
  if String.length commit_hash >= 8 then String.sub commit_hash 0 8
  else commit_hash

let raw_committer_date = "$Format:%ci$"

let committer_date =
  if String.equal raw_committer_date ("$Format" ^ ":%ci$") then
    Generated_git_info.committer_date
  else raw_committer_date
src/lib_version/current_git_info.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition raw_commit_hash : string := "$Format:%H$" % string.

Definition commit_hash : string :=
  if
    Stdlib.String.equal raw_commit_hash
      (String.append "$Format" % string ":%H$" % string) then
    Tezos_version.Generated_git_info.commit_hash
  else
    raw_commit_hash.

Definition abbreviated_commit_hash : string :=
  if OCaml.Stdlib.ge (OCaml.String.length commit_hash) 8 then
    Stdlib.String.sub commit_hash 0 8
  else
    commit_hash.

Definition raw_committer_date : string := "$Format:%ci$" % string.

Definition committer_date : string :=
  if
    Stdlib.String.equal raw_committer_date
      (String.append "$Format" % string ":%ci$" % string) then
    Tezos_version.Generated_git_info.committer_date
  else
    raw_committer_date.
src/lib_version/current_git_info.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commit_hash : string

val abbreviated_commit_hash : string

val committer_date : string
src/lib_version/current_git_info.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commit_hash : string.

Parameter abbreviated_commit_hash : string.

Parameter committer_date : string.
src/proto_alpha/bin_accuser/main_accuser_alpha.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "accuser.main"
end)

let () =
  Client_commands.register Protocol.hash
  @@ fun _network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Delegate_commands.accuser_commands ()

let select_commands _ _ =
  return
    (List.map
       (Clic.map_command (new Protocol_client_context.wrap_full))
       (Delegate_commands.accuser_commands ()))

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/proto_alpha/bin_accuser/main_accuser_alpha.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition select_commands {A B : Type} (function_parameter : A)
  : B ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full))) :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        Tezos_base__TzPervasives._return
          (Tezos_base__TzPervasives.List.map
            (Tezos_base__TzPervasives.Clic.map_command new)
            (Tezos_baking_alpha_commands.Delegate_commands.accuser_commands tt))
      end
  end.
src/proto_alpha/bin_baker/main_baker_alpha.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "baker.main"
end)

let () =
  Client_commands.register Protocol.hash
  @@ fun _network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Delegate_commands.delegate_commands ()

let select_commands _ _ =
  return
    (List.map
       (Clic.map_command (new Protocol_client_context.wrap_full))
       (Delegate_commands.baker_commands ()))

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/proto_alpha/bin_baker/main_baker_alpha.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition select_commands {A B : Type} (function_parameter : A)
  : B ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full))) :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        Tezos_base__TzPervasives._return
          (Tezos_base__TzPervasives.List.map
            (Tezos_base__TzPervasives.Clic.map_command new)
            (Tezos_baking_alpha_commands.Delegate_commands.baker_commands tt))
      end
  end.
src/proto_alpha/bin_endorser/main_endorser_alpha.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "endorser.main"
end)

let () =
  Client_commands.register Protocol.hash
  @@ fun _network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Delegate_commands.delegate_commands ()

let select_commands _ _ =
  return
    (List.map
       (Clic.map_command (new Protocol_client_context.wrap_full))
       (Delegate_commands.endorser_commands ()))

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/proto_alpha/bin_endorser/main_endorser_alpha.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition select_commands {A B : Type} (function_parameter : A)
  : B ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full))) :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        Tezos_base__TzPervasives._return
          (Tezos_base__TzPervasives.List.map
            (Tezos_base__TzPervasives.Clic.map_command new)
            (Tezos_baking_alpha_commands.Delegate_commands.endorser_commands tt))
      end
  end.
src/proto_alpha/lib_client/client_proto_args.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context
open Clic

type error += Bad_tez_arg of string * string (* Arg_name * value *)

type error += Bad_max_priority of string

type error += Bad_minimal_fees of string

type error += Bad_max_waiting_time of string

type error += Bad_endorsement_delay of string

type error += Bad_preserved_levels of string

let () =
  register_error_kind
    `Permanent
    ~id:"badTezArg"
    ~title:"Bad Tez Arg"
    ~description:"Invalid \xEA\x9C\xA9 notation in parameter."
    ~pp:(fun ppf (arg_name, literal) ->
      Format.fprintf
        ppf
        "Invalid \xEA\x9C\xA9 notation in parameter %s: '%s'"
        arg_name
        literal)
    Data_encoding.(obj2 (req "parameter" string) (req "literal" string))
    (function
      | Bad_tez_arg (parameter, literal) ->
          Some (parameter, literal)
      | _ ->
          None)
    (fun (parameter, literal) -> Bad_tez_arg (parameter, literal)) ;
  register_error_kind
    `Permanent
    ~id:"badMaxPriorityArg"
    ~title:"Bad -max-priority arg"
    ~description:"invalid priority in -max-priority"
    ~pp:(fun ppf literal ->
      Format.fprintf ppf "invalid priority '%s' in -max-priority" literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_max_priority parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_max_priority parameter) ;
  register_error_kind
    `Permanent
    ~id:"badMinimalFeesArg"
    ~title:"Bad -minimal-fees arg"
    ~description:"invalid fee threshold in -fee-threshold"
    ~pp:(fun ppf literal ->
      Format.fprintf ppf "invalid minimal fees '%s'" literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_minimal_fees parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_minimal_fees parameter) ;
  register_error_kind
    `Permanent
    ~id:"badMaxWaitingTimeArg"
    ~title:"Bad -max-waiting-time arg"
    ~description:"invalid duration in -max-waiting-time"
    ~pp:(fun ppf literal ->
      Format.fprintf
        ppf
        "Bad argument value for -max-waiting-time. Expected an integer, but \
         given '%s'"
        literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_max_waiting_time parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_max_waiting_time parameter) ;
  register_error_kind
    `Permanent
    ~id:"badEndorsementDelayArg"
    ~title:"Bad -endorsement-delay arg"
    ~description:"invalid duration in -endorsement-delay"
    ~pp:(fun ppf literal ->
      Format.fprintf
        ppf
        "Bad argument value for -endorsement-delay. Expected an integer, but \
         given '%s'"
        literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_endorsement_delay parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_endorsement_delay parameter) ;
  register_error_kind
    `Permanent
    ~id:"badPreservedLevelsArg"
    ~title:"Bad -preserved-levels arg"
    ~description:"invalid number of levels in -preserved-levels"
    ~pp:(fun ppf literal ->
      Format.fprintf
        ppf
        "Bad argument value for -preserved_levels. Expected a positive \
         integer, but given '%s'"
        literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_preserved_levels parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_preserved_levels parameter)

let tez_sym = "\xEA\x9C\xA9"

let string_parameter = parameter (fun _ x -> return x)

let int_parameter =
  parameter (fun _ p ->
      try return (int_of_string p) with _ -> failwith "Cannot read int")

let bytes_parameter =
  parameter (fun _ s ->
      try
        if String.length s < 2 || s.[0] <> '0' || s.[1] <> 'x' then raise Exit
        else
          return (Hex.to_bytes (`Hex (String.sub s 2 (String.length s - 2))))
      with _ ->
        failwith
          "Invalid bytes, expecting hexadecimal notation (e.g. 0x1234abcd)")

let init_arg =
  default_arg
    ~long:"init"
    ~placeholder:"data"
    ~doc:"initial value of the contract's storage"
    ~default:"Unit"
    string_parameter

let arg_arg =
  arg
    ~long:"arg"
    ~placeholder:"data"
    ~doc:"argument passed to the contract's script, if needed"
    string_parameter

let delegate_arg =
  Client_keys.Public_key_hash.source_arg
    ~long:"delegate"
    ~placeholder:"address"
    ~doc:"delegate of the contract\nMust be a known address."
    ()

let source_arg =
  arg
    ~long:"source"
    ~placeholder:"address"
    ~doc:"source of the deposits to be paid\nMust be a known address."
    string_parameter

let entrypoint_arg =
  arg
    ~long:"entrypoint"
    ~placeholder:"name"
    ~doc:"entrypoint of the smart contract"
    string_parameter

let spendable_switch =
  switch
    ~long:"spendable"
    ~doc:"allow the manager to spend the contract's tokens"
    ()

let force_switch =
  switch
    ~long:"force"
    ~short:'f'
    ~doc:
      "disables the node's injection checks\n\
       Force the injection of branch-invalid operation or force  the \
       injection of block without a fitness greater than the  current head."
    ()

let minimal_timestamp_switch =
  switch
    ~long:"minimal-timestamp"
    ~doc:
      "Use the minimal timestamp instead of the current date as timestamp of \
       the baked block."
    ()

let delegatable_switch =
  switch ~long:"delegatable" ~doc:"allow future delegate change" ()

let tez_format =
  "Text format: `DDDDDDD.DDDDDD`.\n\
   Tez and mutez and separated by a period sign. Trailing and pending zeroes \
   are allowed."

let tez_parameter param =
  parameter (fun _ s ->
      match Tez.of_string s with
      | Some tez ->
          return tez
      | None ->
          fail (Bad_tez_arg (param, s)))

let tez_arg ~default ~parameter ~doc =
  default_arg
    ~long:parameter
    ~placeholder:"amount"
    ~doc
    ~default
    (tez_parameter ("--" ^ parameter))

let tez_param ~name ~desc next =
  Clic.param
    ~name
    ~desc:(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format)
    (tez_parameter name)
    next

let fee_arg =
  arg
    ~long:"fee"
    ~placeholder:"amount"
    ~doc:"fee in \xEA\x9C\xA9 to pay to the baker"
    (tez_parameter "--fee")

let gas_limit_arg =
  arg
    ~long:"gas-limit"
    ~short:'G'
    ~placeholder:"amount"
    ~doc:
      "Set the gas limit of the transaction instead of letting the client \
       decide based on a simulation"
    (parameter (fun _ s ->
         try
           let v = Z.of_string s in
           assert (Compare.Z.(v >= Z.zero)) ;
           return v
         with _ -> failwith "invalid gas limit (must be a positive number)"))

let storage_limit_arg =
  arg
    ~long:"storage-limit"
    ~short:'S'
    ~placeholder:"amount"
    ~doc:
      "Set the storage limit of the transaction instead of letting the client \
       decide based on a simulation"
    (parameter (fun _ s ->
         try
           let v = Z.of_string s in
           assert (Compare.Z.(v >= Z.zero)) ;
           return v
         with _ ->
           failwith
             "invalid storage limit (must be a positive number of bytes)"))

let counter_arg =
  arg
    ~long:"counter"
    ~short:'C'
    ~placeholder:"counter"
    ~doc:"Set the counter to be used by the transaction"
    (parameter (fun _ s ->
         try
           let v = Z.of_string s in
           assert (Compare.Z.(v >= Z.zero)) ;
           return v
         with _ ->
           failwith "invalid counter (must be a positive number of bytes)"))

let max_priority_arg =
  arg
    ~long:"max-priority"
    ~placeholder:"slot"
    ~doc:"maximum allowed baking slot"
    (parameter (fun _ s ->
         try return (int_of_string s) with _ -> fail (Bad_max_priority s)))

let default_minimal_fees =
  match Tez.of_mutez 100L with None -> assert false | Some t -> t

let default_minimal_nanotez_per_gas_unit = Z.of_int 100

let default_minimal_nanotez_per_byte = Z.of_int 1000

let minimal_fees_arg =
  default_arg
    ~long:"minimal-fees"
    ~placeholder:"amount"
    ~doc:"exclude operations with fees lower than this threshold (in tez)"
    ~default:(Tez.to_string default_minimal_fees)
    (parameter (fun _ s ->
         match Tez.of_string s with
         | Some t ->
             return t
         | None ->
             fail (Bad_minimal_fees s)))

let minimal_nanotez_per_gas_unit_arg =
  default_arg
    ~long:"minimal-nanotez-per-gas-unit"
    ~placeholder:"amount"
    ~doc:
      "exclude operations with fees per gas lower than this threshold (in \
       nanotez)"
    ~default:(Z.to_string default_minimal_nanotez_per_gas_unit)
    (parameter (fun _ s ->
         try return (Z.of_string s) with _ -> fail (Bad_minimal_fees s)))

let minimal_nanotez_per_byte_arg =
  default_arg
    ~long:"minimal-nanotez-per-byte"
    ~placeholder:"amount"
    ~default:(Z.to_string default_minimal_nanotez_per_byte)
    ~doc:
      "exclude operations with fees per byte lower than this threshold (in \
       nanotez)"
    (parameter (fun _ s ->
         try return (Z.of_string s) with _ -> fail (Bad_minimal_fees s)))

let force_low_fee_arg =
  switch
    ~long:"force-low-fee"
    ~doc:"Don't check that the fee is lower than the estimated default value"
    ()

let fee_cap_arg =
  default_arg
    ~long:"fee-cap"
    ~placeholder:"amount"
    ~default:"1.0"
    ~doc:"Set the fee cap"
    (parameter (fun _ s ->
         match Tez.of_string s with
         | Some t ->
             return t
         | None ->
             failwith "Bad fee cap"))

let burn_cap_arg =
  default_arg
    ~long:"burn-cap"
    ~placeholder:"amount"
    ~default:"0"
    ~doc:"Set the burn cap"
    (parameter (fun _ s ->
         match Tez.of_string s with
         | Some t ->
             return t
         | None ->
             failwith "Bad burn cap"))

let no_waiting_for_endorsements_arg =
  switch
    ~long:"no-waiting-for-late-endorsements"
    ~doc:"Disable waiting for late endorsements"
    ()

let await_endorsements_arg =
  switch
    ~long:"await-late-endorsements"
    ~doc:"Await late endorsements when baking a block"
    ()

let endorsement_delay_arg =
  default_arg
    ~long:"endorsement-delay"
    ~placeholder:"seconds"
    ~doc:
      "delay before endorsing blocks\n\
       Delay between notifications of new blocks from the node and production \
       of endorsements for these blocks."
    ~default:"5"
    (parameter (fun _ s ->
         try
           let i = int_of_string s in
           fail_when (i < 0) (Bad_endorsement_delay s)
           >>=? fun () -> return (int_of_string s)
         with _ -> fail (Bad_endorsement_delay s)))

let preserved_levels_arg =
  default_arg
    ~long:"preserved-levels"
    ~placeholder:"threshold"
    ~doc:"Number of effective levels kept in the accuser's memory"
    ~default:"4096"
    (parameter (fun _ s ->
         try
           let preserved_cycles = int_of_string s in
           if preserved_cycles < 0 then fail (Bad_preserved_levels s)
           else return preserved_cycles
         with _ -> fail (Bad_preserved_levels s)))

let no_print_source_flag =
  switch
    ~long:"no-print-source"
    ~short:'q'
    ~doc:
      "don't print the source code\n\
       If an error is encountered, the client will print the contract's \
       source code by default.\n\
       This option disables this behaviour."
    ()

let no_confirmation =
  switch
    ~long:"no-confirmation"
    ~doc:"don't print wait for the operation to be confirmed."
    ()

let signature_parameter =
  parameter (fun _cctxt s ->
      match Signature.of_b58check_opt s with
      | Some s ->
          return s
      | None ->
          failwith "Not given a valid signature")

module Daemon = struct
  let baking_switch =
    switch ~long:"baking" ~short:'B' ~doc:"run the baking daemon" ()

  let endorsement_switch =
    switch ~long:"endorsement" ~short:'E' ~doc:"run the endorsement daemon" ()

  let denunciation_switch =
    switch
      ~long:"denunciation"
      ~short:'D'
      ~doc:"run the denunciation daemon"
      ()
end
src/proto_alpha/lib_client/client_proto_args.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_base__TzPervasives.Clic.

Definition tez_sym : string := "ꜩ" % string.

Definition string_parameter {A : Type}
  : Tezos_base__TzPervasives.Clic.parameter string A :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ => fun x => Tezos_base__TzPervasives._return x
      end).

Definition int_parameter {A : Type}
  : Tezos_base__TzPervasives.Clic.parameter Z A :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ => fun p => try
      end).

Definition bytes_parameter {A : Type}
  : Tezos_base__TzPervasives.Clic.parameter string A :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ => fun s => try
      end).

Definition init_arg {A : Type} : Tezos_base__TzPervasives.Clic.arg string A :=
  Tezos_base__TzPervasives.Clic.default_arg
    "initial value of the contract's storage" % string None "init" % string
    "data" % string "Unit" % string string_parameter.

Definition arg_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  Tezos_base__TzPervasives.Clic.arg
    "argument passed to the contract's script, if needed" % string None
    "arg" % string "data" % string string_parameter.

Definition delegate_arg {B a : Type}
  : Tezos_base__TzPervasives.Clic.arg
    (option Tezos_client_base.Client_keys.Public_key_hash.t)
    (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) :=
  Tezos_client_base.Client_keys.Public_key_hash.source_arg
    (Some "delegate" % string) (Some "address" % string)
    (Some "delegate of the contract
Must be a known address." % string) tt.

Definition source_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  Tezos_base__TzPervasives.Clic.arg
    "source of the deposits to be paid
Must be a known address." % string None
    "source" % string "address" % string string_parameter.

Definition entrypoint_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  Tezos_base__TzPervasives.Clic.arg "entrypoint of the smart contract" % string
    None "entrypoint" % string "name" % string string_parameter.

Definition spendable_switch {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch
    "allow the manager to spend the contract's tokens" % string None
    "spendable" % string tt.

Definition force_switch {A : Type} : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch
    "disables the node's injection checks
Force the injection of branch-invalid operation or force  the injection of block without a fitness greater than the  current head."
      % string (Some "f" % char) "force" % string tt.

Definition minimal_timestamp_switch {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch
    "Use the minimal timestamp instead of the current date as timestamp of the baked block."
      % string None "minimal-timestamp" % string tt.

Definition delegatable_switch {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch "allow future delegate change" % string
    None "delegatable" % string tt.

Definition tez_format : string :=
  "Text format: `DDDDDDD.DDDDDD`.
Tez and mutez and separated by a period sign. Trailing and pending zeroes are allowed."
    % string.

Definition tez_parameter {A : Type} (param : string)
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun s =>
          match Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_string s with
          | Some tez => Tezos_base__TzPervasives._return tez
          | None => Tezos_base__TzPervasives.fail (Bad_tez_arg param s)
          end
      end).

Definition tez_arg {A : Type}
  (default : string) (parameter : string) (doc : string)
  : Tezos_base__TzPervasives.Clic.arg
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  Tezos_base__TzPervasives.Clic.default_arg doc None parameter "amount" % string
    default (tez_parameter (String.append "--" % string parameter)).

Definition tez_param {A B : Type}
  (name : string) (desc : string)
  (next : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez -> A) B :=
  Tezos_base__TzPervasives.Clic.param name
    (String.append desc (String.append " in ꜩ
" % string tez_format))
    (tez_parameter name) next.

Definition fee_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) A :=
  Tezos_base__TzPervasives.Clic.arg "fee in ꜩ to pay to the baker" % string
    None "fee" % string "amount" % string (tez_parameter "--fee" % string).

Definition gas_limit_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
  Tezos_base__TzPervasives.Clic.arg
    "Set the gas limit of the transaction instead of letting the client decide based on a simulation"
      % string (Some "G" % char) "gas-limit" % string "amount" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition storage_limit_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
  Tezos_base__TzPervasives.Clic.arg
    "Set the storage limit of the transaction instead of letting the client decide based on a simulation"
      % string (Some "S" % char) "storage-limit" % string "amount" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition counter_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
  Tezos_base__TzPervasives.Clic.arg
    "Set the counter to be used by the transaction" % string (Some "C" % char)
    "counter" % string "counter" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition max_priority_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option Z) A :=
  Tezos_base__TzPervasives.Clic.arg "maximum allowed baking slot" % string None
    "max-priority" % string "slot" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition default_minimal_fees
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
  match Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez 100 with
  | None => false
  | Some t => t
  end.

Definition default_minimal_nanotez_per_gas_unit : Z.t := Z.of_int 100.

Definition default_minimal_nanotez_per_byte : Z.t := Z.of_int 1000.

Definition minimal_fees_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  Tezos_base__TzPervasives.Clic.default_arg
    "exclude operations with fees lower than this threshold (in tez)" % string
    None "minimal-fees" % string "amount" % string
    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_string
      default_minimal_fees)
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun s =>
            match Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_string s
              with
            | Some t => Tezos_base__TzPervasives._return t
            | None => Tezos_base__TzPervasives.fail (Bad_minimal_fees s)
            end
        end)).

Definition minimal_nanotez_per_gas_unit_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg Z.t A :=
  Tezos_base__TzPervasives.Clic.default_arg
    "exclude operations with fees per gas lower than this threshold (in nanotez)"
      % string None "minimal-nanotez-per-gas-unit" % string "amount" % string
    (Z.to_string default_minimal_nanotez_per_gas_unit)
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition minimal_nanotez_per_byte_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg Z.t A :=
  Tezos_base__TzPervasives.Clic.default_arg
    "exclude operations with fees per byte lower than this threshold (in nanotez)"
      % string None "minimal-nanotez-per-byte" % string "amount" % string
    (Z.to_string default_minimal_nanotez_per_byte)
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition force_low_fee_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch
    "Don't check that the fee is lower than the estimated default value" %
      string None "force-low-fee" % string tt.

Definition fee_cap_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  Tezos_base__TzPervasives.Clic.default_arg "Set the fee cap" % string None
    "fee-cap" % string "amount" % string "1.0" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun s =>
            match Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_string s
              with
            | Some t => Tezos_base__TzPervasives._return t
            | None =>
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Bad fee cap" % string
                    CamlinternalFormatBasics.End_of_format)
                  "Bad fee cap" % string)
            end
        end)).

Definition burn_cap_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  Tezos_base__TzPervasives.Clic.default_arg "Set the burn cap" % string None
    "burn-cap" % string "amount" % string "0" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun s =>
            match Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_string s
              with
            | Some t => Tezos_base__TzPervasives._return t
            | None =>
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Bad burn cap" % string
                    CamlinternalFormatBasics.End_of_format)
                  "Bad burn cap" % string)
            end
        end)).

Definition no_waiting_for_endorsements_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch
    "Disable waiting for late endorsements" % string None
    "no-waiting-for-late-endorsements" % string tt.

Definition await_endorsements_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch
    "Await late endorsements when baking a block" % string None
    "await-late-endorsements" % string tt.

Definition endorsement_delay_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg Z A :=
  Tezos_base__TzPervasives.Clic.default_arg
    "delay before endorsing blocks
Delay between notifications of new blocks from the node and production of endorsements for these blocks."
      % string None "endorsement-delay" % string "seconds" % string "5" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition preserved_levels_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg Z A :=
  Tezos_base__TzPervasives.Clic.default_arg
    "Number of effective levels kept in the accuser's memory" % string None
    "preserved-levels" % string "threshold" % string "4096" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => try
        end)).

Definition no_print_source_flag {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch
    "don't print the source code
If an error is encountered, the client will print the contract's source code by default.
This option disables this behaviour."
      % string (Some "q" % char) "no-print-source" % string tt.

Definition no_confirmation {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  Tezos_base__TzPervasives.Clic.switch
    "don't print wait for the operation to be confirmed." % string None
    "no-confirmation" % string tt.

Definition signature_parameter {A : Type}
  : Tezos_base__TzPervasives.Clic.parameter Tezos_base__TzPervasives.Signature.t
    A :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun _cctxt =>
      fun s =>
        match Tezos_base__TzPervasives.Signature.of_b58check_opt s with
        | Some s => Tezos_base__TzPervasives._return s
        | None =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Not given a valid signature" % string
                CamlinternalFormatBasics.End_of_format)
              "Not given a valid signature" % string)
        end).

Module Daemon.
  Definition baking_switch {A : Type}
    : Tezos_base__TzPervasives.Clic.arg bool A :=
    Tezos_base__TzPervasives.Clic.switch "run the baking daemon" % string
      (Some "B" % char) "baking" % string tt.
  
  Definition endorsement_switch {A : Type}
    : Tezos_base__TzPervasives.Clic.arg bool A :=
    Tezos_base__TzPervasives.Clic.switch "run the endorsement daemon" % string
      (Some "E" % char) "endorsement" % string tt.
  
  Definition denunciation_switch {A : Type}
    : Tezos_base__TzPervasives.Clic.arg bool A :=
    Tezos_base__TzPervasives.Clic.switch "run the denunciation daemon" % string
      (Some "D" % char) "denunciation" % string tt.
End Daemon.
src/proto_alpha/lib_client/client_proto_args.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Protocol_client_context

val tez_sym : string

val init_arg : (string, full) Clic.arg

val fee_arg : (Tez.t option, full) Clic.arg

val counter_arg : (Z.t option, full) Clic.arg

val gas_limit_arg : (Z.t option, full) Clic.arg

val storage_limit_arg : (Z.t option, full) Clic.arg

val arg_arg : (string option, full) Clic.arg

val source_arg : (string option, full) Clic.arg

val entrypoint_arg : (string option, full) Clic.arg

val delegate_arg : (Signature.Public_key_hash.t option, full) Clic.arg

val delegatable_switch : (bool, full) Clic.arg

val spendable_switch : (bool, full) Clic.arg

val max_priority_arg : (int option, full) Clic.arg

val minimal_fees_arg : (Tez.tez, full) Clic.arg

val minimal_nanotez_per_gas_unit_arg : (Z.t, full) Clic.arg

val minimal_nanotez_per_byte_arg : (Z.t, full) Clic.arg

val force_low_fee_arg : (bool, full) Clic.arg

val fee_cap_arg : (Tez.t, full) Clic.arg

val burn_cap_arg : (Tez.t, full) Clic.arg

val no_waiting_for_endorsements_arg : (bool, full) Clic.arg

val await_endorsements_arg : (bool, full) Clic.arg

val force_switch : (bool, full) Clic.arg

val minimal_timestamp_switch : (bool, full) Clic.arg

val endorsement_delay_arg : (int, full) Clic.arg

val preserved_levels_arg : (int, full) Clic.arg

val no_print_source_flag : (bool, full) Clic.arg

val no_confirmation : (bool, full) Clic.arg

val tez_arg :
  default:string -> parameter:string -> doc:string -> (Tez.t, full) Clic.arg

val tez_param :
  name:string ->
  desc:string ->
  ('a, full) Clic.params ->
  (Tez.t -> 'a, full) Clic.params

val signature_parameter : (Signature.t, full) Clic.parameter

module Daemon : sig
  val baking_switch : (bool, full) Clic.arg

  val endorsement_switch : (bool, full) Clic.arg

  val denunciation_switch : (bool, full) Clic.arg
end

val int_parameter : (int, full) Clic.parameter

val string_parameter : (string, full) Clic.parameter

val bytes_parameter : (Bytes.t, full) Clic.parameter
src/proto_alpha/lib_client/client_proto_args.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter tez_sym : string.

Parameter init_arg :
Tezos_base__TzPervasives.Clic.arg string
  Tezos_client_alpha.Protocol_client_context.full.

Parameter fee_arg :
Tezos_base__TzPervasives.Clic.arg
  (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter counter_arg :
Tezos_base__TzPervasives.Clic.arg (option Z.t)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter gas_limit_arg :
Tezos_base__TzPervasives.Clic.arg (option Z.t)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter storage_limit_arg :
Tezos_base__TzPervasives.Clic.arg (option Z.t)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter arg_arg :
Tezos_base__TzPervasives.Clic.arg (option string)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter source_arg :
Tezos_base__TzPervasives.Clic.arg (option string)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter entrypoint_arg :
Tezos_base__TzPervasives.Clic.arg (option string)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter delegate_arg :
Tezos_base__TzPervasives.Clic.arg
  (option Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter delegatable_switch :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter spendable_switch :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter max_priority_arg :
Tezos_base__TzPervasives.Clic.arg (option Z)
  Tezos_client_alpha.Protocol_client_context.full.

Parameter minimal_fees_arg :
Tezos_base__TzPervasives.Clic.arg
  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez
  Tezos_client_alpha.Protocol_client_context.full.

Parameter minimal_nanotez_per_gas_unit_arg :
Tezos_base__TzPervasives.Clic.arg Z.t
  Tezos_client_alpha.Protocol_client_context.full.

Parameter minimal_nanotez_per_byte_arg :
Tezos_base__TzPervasives.Clic.arg Z.t
  Tezos_client_alpha.Protocol_client_context.full.

Parameter force_low_fee_arg :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter fee_cap_arg :
Tezos_base__TzPervasives.Clic.arg
  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t
  Tezos_client_alpha.Protocol_client_context.full.

Parameter burn_cap_arg :
Tezos_base__TzPervasives.Clic.arg
  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t
  Tezos_client_alpha.Protocol_client_context.full.

Parameter no_waiting_for_endorsements_arg :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter await_endorsements_arg :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter force_switch :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter minimal_timestamp_switch :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter endorsement_delay_arg :
Tezos_base__TzPervasives.Clic.arg Z
  Tezos_client_alpha.Protocol_client_context.full.

Parameter preserved_levels_arg :
Tezos_base__TzPervasives.Clic.arg Z
  Tezos_client_alpha.Protocol_client_context.full.

Parameter no_print_source_flag :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter no_confirmation :
Tezos_base__TzPervasives.Clic.arg bool
  Tezos_client_alpha.Protocol_client_context.full.

Parameter tez_arg :
string ->
  string ->
    string ->
      Tezos_base__TzPervasives.Clic.arg
        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t
        Tezos_client_alpha.Protocol_client_context.full.

Parameter tez_param : forall {a : Type},
string ->
  string ->
    (Tezos_base__TzPervasives.Clic.params a
      Tezos_client_alpha.Protocol_client_context.full) ->
      Tezos_base__TzPervasives.Clic.params
        (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t -> a)
        Tezos_client_alpha.Protocol_client_context.full.

Parameter signature_parameter :
Tezos_base__TzPervasives.Clic.parameter Tezos_base__TzPervasives.Signature.t
  Tezos_client_alpha.Protocol_client_context.full.

Module Daemon.
  Parameter baking_switch : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full.
  
  Parameter endorsement_switch : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full.
  
  Parameter denunciation_switch : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full.
End Daemon.

Parameter int_parameter :
Tezos_base__TzPervasives.Clic.parameter Z
  Tezos_client_alpha.Protocol_client_context.full.

Parameter string_parameter :
Tezos_base__TzPervasives.Clic.parameter string
  Tezos_client_alpha.Protocol_client_context.full.

Parameter bytes_parameter :
Tezos_base__TzPervasives.Clic.parameter Stdlib.Bytes.t
  Tezos_client_alpha.Protocol_client_context.full.
src/proto_alpha/lib_client/client_proto_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Protocol_client_context
open Tezos_micheline
open Client_proto_contracts
open Client_keys

let get_balance (rpc : #rpc_context) ~chain ~block contract =
  Alpha_services.Contract.balance rpc (chain, block) contract

let get_storage (rpc : #rpc_context) ~chain ~block contract =
  Alpha_services.Contract.storage_opt rpc (chain, block) contract

let get_big_map_value (rpc : #rpc_context) ~chain ~block id key =
  Alpha_services.Contract.big_map_get rpc (chain, block) id key

let get_contract_big_map_value (rpc : #rpc_context) ~chain ~block contract key
    =
  Alpha_services.Contract.contract_big_map_get_opt
    rpc
    (chain, block)
    contract
    key

let get_script (rpc : #rpc_context) ~chain ~block contract =
  Alpha_services.Contract.script_opt rpc (chain, block) contract

let parse_expression arg =
  Lwt.return
    (Micheline_parser.no_parsing_error
       (Michelson_v1_parser.parse_expression arg))

let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?branch ~source ~src_pk ~src_sk ~destination
    ?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit ?storage_limit
    ?counter ~fee_parameter () =
  ( match arg with
  | Some arg ->
      parse_expression arg >>=? fun {expanded = arg; _} -> return_some arg
  | None ->
      return_none )
  >>=? fun parameters ->
  let parameters =
    Option.unopt_map
      ~f:Script.lazy_expr
      ~default:Script.unit_parameter
      parameters
  in
  let contents = Transaction {amount; parameters; destination; entrypoint} in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~src_pk
    ~src_sk
    ~fee_parameter
    contents
  >>=? fun ((_oph, _op, result) as res) ->
  Lwt.return (Injection.originated_contracts (Single_result result))
  >>=? fun contracts -> return (res, contracts)

let reveal cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch
    ~source ~src_pk ~src_sk ?fee ~fee_parameter () =
  let (compute_fee, fee) =
    match fee with None -> (true, Tez.zero) | Some fee -> (false, fee)
  in
  Alpha_services.Contract.counter cctxt (chain, block) source
  >>=? fun pcounter ->
  let counter = Z.succ pcounter in
  Alpha_services.Contract.manager_key cctxt (chain, block) source
  >>=? fun key ->
  match key with
  | Some _ ->
      failwith "The manager key was previously revealed."
  | None -> (
      let contents =
        Single
          (Manager_operation
             {
               source;
               fee;
               counter;
               gas_limit = Z.of_int ~-1;
               storage_limit = Z.zero;
               operation = Reveal src_pk;
             })
      in
      Injection.inject_operation
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        ?verbose_signing
        ?branch
        ~src_sk
        ~compute_fee
        ~fee_parameter
        contents
      >>=? fun (oph, op, result) ->
      match Apply_results.pack_contents_list op result with
      | Apply_results.Single_and_result ((Manager_operation _ as op), result)
        ->
          return (oph, op, result) )

let delegate_contract cctxt ~chain ~block ?branch ?confirmations ?dry_run
    ?verbose_signing ~source ~src_pk ~src_sk ?fee ~fee_parameter delegate_opt =
  let operation = Delegation delegate_opt in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ~storage_limit:Z.zero
    ~src_pk
    ~src_sk
    ~fee_parameter
    operation
  >>=? fun res -> return res

let list_contract_labels cctxt ~chain ~block =
  Alpha_services.Contract.list cctxt (chain, block)
  >>=? fun contracts ->
  rev_map_s
    (fun h ->
      ( match Contract.is_implicit h with
      | Some m -> (
          Public_key_hash.rev_find cctxt m
          >>=? function
          | None ->
              return ""
          | Some nm -> (
              RawContractAlias.find_opt cctxt nm
              >>=? function
              | None ->
                  return (" (known as " ^ nm ^ ")")
              | Some _ ->
                  return (" (known as key:" ^ nm ^ ")") ) )
      | None -> (
          RawContractAlias.rev_find cctxt h
          >>=? function
          | None -> return "" | Some nm -> return (" (known as " ^ nm ^ ")") )
      )
      >>=? fun nm ->
      let kind =
        match Contract.is_implicit h with
        | Some _ ->
            " (implicit)"
        | None ->
            ""
      in
      let h_b58 = Contract.to_b58check h in
      return (nm, h_b58, kind))
    contracts
  >>|? List.rev

let message_added_contract (cctxt : #full) name =
  cctxt#message "Contract memorized as %s." name

let set_delegate cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing
    ?fee contract ~src_pk ~manager_sk ~fee_parameter opt_delegate =
  delegate_contract
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ~source:contract
    ~src_pk
    ~src_sk:manager_sk
    ?fee
    ~fee_parameter
    opt_delegate

let register_as_delegate cctxt ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?fee ~manager_sk ~fee_parameter src_pk =
  let source = Signature.Public_key.hash src_pk in
  delegate_contract
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ~source
    ~src_pk
    ~src_sk:manager_sk
    ?fee
    ~fee_parameter
    (Some source)

let save_contract ~force cctxt alias_name contract =
  RawContractAlias.add ~force cctxt alias_name contract
  >>=? fun () ->
  message_added_contract cctxt alias_name >>= fun () -> return_unit

let originate_contract (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?branch ?fee ?gas_limit ?storage_limit ~delegate
    ~initial_storage ~balance ~source ~src_pk ~src_sk ~code ~fee_parameter () =
  (* With the change of making implicit accounts delegatable, the following
     3 arguments are being defaulted before they can be safely removed. *)
  Lwt.return (Michelson_v1_parser.parse_expression initial_storage)
  >>= fun result ->
  Lwt.return (Micheline_parser.no_parsing_error result)
  >>=? fun {Michelson_v1_parser.expanded = storage; _} ->
  let code = Script.lazy_expr code and storage = Script.lazy_expr storage in
  let origination =
    Origination
      {
        delegate;
        script = {code; storage};
        credit = balance;
        preorigination = None;
      }
  in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ?gas_limit
    ?storage_limit
    ~src_pk
    ~src_sk
    ~fee_parameter
    origination
  >>=? fun ((_oph, _op, result) as res) ->
  Lwt.return (Injection.originated_contracts (Single_result result))
  >>=? function
  | [contract] ->
      return (res, contract)
  | contracts ->
      failwith
        "The origination introduced %d contracts instead of one."
        (List.length contracts)

type activation_key = {
  pkh : Ed25519.Public_key_hash.t;
  amount : Tez.t;
  activation_code : Blinded_public_key_hash.activation_code;
  mnemonic : string list;
  password : string;
  email : string;
}

let raw_activation_key_encoding =
  let open Data_encoding in
  obj6
    (req "pkh" Ed25519.Public_key_hash.encoding)
    (req "amount" Tez.encoding)
    (req "activation_code" Blinded_public_key_hash.activation_code_encoding)
    (req "mnemonic" (list string))
    (req "password" string)
    (req "email" string)

let activation_key_encoding =
  (* Hack: allow compatibility with older encoding *)
  let open Data_encoding in
  conv
    (fun {pkh; amount; activation_code; mnemonic; password; email} ->
      (pkh, amount, activation_code, mnemonic, password, email))
    (fun (pkh, amount, activation_code, mnemonic, password, email) ->
      {pkh; amount; activation_code; mnemonic; password; email})
  @@ splitted
       ~binary:raw_activation_key_encoding
       ~json:
         (union
            [ case
                ~title:"Activation"
                Json_only
                raw_activation_key_encoding
                (fun x -> Some x)
                (fun x -> x);
              case
                ~title:"Deprecated_activation"
                Json_only
                (obj6
                   (req "pkh" Ed25519.Public_key_hash.encoding)
                   (req "amount" Tez.encoding)
                   (req
                      "secret"
                      Blinded_public_key_hash.activation_code_encoding)
                   (req "mnemonic" (list string))
                   (req "password" string)
                   (req "email" string))
                (fun _ -> None)
                (fun x -> x) ])

let read_key key =
  match Bip39.of_words key.mnemonic with
  | None ->
      failwith ""
  | Some t ->
      (* TODO: unicode normalization (NFKD)... *)
      let passphrase =
        Bigstring.(concat "" [of_string key.email; of_string key.password])
      in
      let sk = Bip39.to_seed ~passphrase t in
      let sk = Bigstring.sub_bytes sk 0 32 in
      let sk : Signature.Secret_key.t =
        Ed25519
          (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
      in
      let pk = Signature.Secret_key.to_public_key sk in
      let pkh = Signature.Public_key.hash pk in
      return (pkh, pk, sk)

let inject_activate_operation cctxt ~chain ~block ?confirmations ?dry_run alias
    pkh activation_code =
  let contents = Single (Activate_account {id = pkh; activation_code}) in
  Injection.inject_operation
    cctxt
    ?confirmations
    ?dry_run
    ~chain
    ~block
    ~fee_parameter:Injection.dummy_fee_parameter
    contents
  >>=? fun (oph, op, result) ->
  ( match confirmations with
  | None ->
      return_unit
  | Some _confirmations ->
      Alpha_services.Contract.balance
        cctxt
        (chain, block)
        (Contract.implicit_contract (Ed25519 pkh))
      >>=? fun balance ->
      cctxt#message
        "Account %s (%a) activated with %s%a."
        alias
        Ed25519.Public_key_hash.pp
        pkh
        Client_proto_args.tez_sym
        Tez.pp
        balance
      >>= fun () -> return_unit )
  >>=? fun () ->
  match Apply_results.pack_contents_list op result with
  | Apply_results.Single_and_result ((Activate_account _ as op), result) ->
      return (oph, op, result)

let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?(encrypted = false) ?force key name =
  read_key key
  >>=? fun (pkh, pk, sk) ->
  fail_unless
    (Signature.Public_key_hash.equal pkh (Ed25519 key.pkh))
    (failure
       "@[<v 2>Inconsistent activation key:@ Computed pkh: %a@ Embedded pkh: \
        %a @]"
       Signature.Public_key_hash.pp
       pkh
       Ed25519.Public_key_hash.pp
       key.pkh)
  >>=? fun () ->
  let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
  ( if encrypted then Tezos_signer_backends.Encrypted.encrypt cctxt sk
  else return (Tezos_signer_backends.Unencrypted.make_sk sk) )
  >>=? fun sk_uri ->
  Client_keys.register_key cctxt ?force (pkh, pk_uri, sk_uri) name
  >>=? fun () ->
  inject_activate_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    name
    key.pkh
    key.activation_code

let activate_existing_account (cctxt : #full) ~chain ~block ?confirmations
    ?dry_run alias activation_code =
  Client_keys.alias_keys cctxt alias
  >>=? function
  | Some (Ed25519 pkh, _, _) ->
      inject_activate_operation
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        alias
        pkh
        activation_code
  | Some _ ->
      failwith "Only Ed25519 accounts can be activated"
  | None ->
      failwith "Unknown account"

type period_info = {
  current_period_kind : Voting_period.kind;
  position : Int32.t;
  remaining : Int32.t;
  current_proposal : Protocol_hash.t option;
}

type ballots_info = {
  current_quorum : Int32.t;
  participation : Int32.t;
  supermajority : Int32.t;
  ballots : Vote.ballots;
}

let get_ballots_info (cctxt : #full) ~chain ~block =
  (* Get the next level, not the current *)
  let cb = (chain, block) in
  Alpha_services.Voting.ballots cctxt cb
  >>=? fun ballots ->
  Alpha_services.Voting.current_quorum cctxt cb
  >>=? fun current_quorum ->
  Alpha_services.Voting.listings cctxt cb
  >>=? fun listings ->
  let max_participation =
    List.fold_left (fun acc (_, w) -> Int32.add w acc) 0l listings
  in
  let all_votes = Int32.(add (add ballots.yay ballots.nay) ballots.pass) in
  let participation = Int32.(div (mul all_votes 100_00l) max_participation) in
  let supermajority = Int32.(div (mul 8l (add ballots.yay ballots.nay)) 10l) in
  return {current_quorum; participation; supermajority; ballots}

let get_period_info (cctxt : #full) ~chain ~block =
  (* Get the next level, not the current *)
  let cb = (chain, block) in
  Alpha_services.Helpers.current_level cctxt ~offset:1l cb
  >>=? fun level ->
  Alpha_services.Constants.all cctxt cb
  >>=? fun constants ->
  Alpha_services.Voting.current_proposal cctxt cb
  >>=? fun current_proposal ->
  let position = level.voting_period_position in
  let remaining =
    Int32.(sub constants.parametric.blocks_per_voting_period position)
  in
  Alpha_services.Voting.current_period_kind cctxt cb
  >>=? fun current_period_kind ->
  return {current_period_kind; position; remaining; current_proposal}

let get_proposals (cctxt : #full) ~chain ~block =
  let cb = (chain, block) in
  Alpha_services.Voting.proposals cctxt cb

let submit_proposals ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block
    ?confirmations ~src_sk source proposals =
  (* We need the next level, not the current *)
  Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
  >>=? fun (level : Level.t) ->
  let period = level.voting_period in
  let contents = Single (Proposals {source; period; proposals}) in
  Injection.inject_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ~fee_parameter:Injection.dummy_fee_parameter
    ?dry_run
    ~src_sk
    contents
    ?verbose_signing

let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block
    ?confirmations ~src_sk source proposal ballot =
  (* The user must provide the proposal explicitly to make himself sure
     for what he is voting. *)
  Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
  >>=? fun (level : Level.t) ->
  let period = level.voting_period in
  let contents = Single (Ballot {source; period; proposal; ballot}) in
  Injection.inject_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ~fee_parameter:Injection.dummy_fee_parameter
    ?dry_run
    ~src_sk
    contents
    ?verbose_signing

let pp_operation formatter (a : Alpha_block_services.operation) =
  match (a.receipt, a.protocol_data) with
  | (Apply_results.Operation_metadata omd, Operation_data od) -> (
    match Apply_results.kind_equal_list od.contents omd.contents with
    | Some Apply_results.Eq ->
        Operation_result.pp_operation_result
          formatter
          (od.contents, omd.contents)
    | None ->
        Pervasives.failwith "Unexpected result." )
  | _ ->
      Pervasives.failwith "Unexpected result."

let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash
    =
  Client_confirmations.lookup_operation_in_previous_blocks
    cctxt
    ~chain
    ~predecessors
    operation_hash
  >>=? function
  | None ->
      return_none
  | Some (block, i, j) ->
      cctxt#message
        "Operation found in block: %a (pass: %d, offset: %d)"
        Block_hash.pp
        block
        i
        j
      >>= fun () ->
      Protocol_client_context.Alpha_block_services.Operations.operation
        cctxt
        ~chain
        ~block:(`Hash (block, 0))
        i
        j
      >>=? fun op' -> return_some op'

let display_receipt_for_operation (cctxt : #full) ~chain ?(predecessors = 10)
    operation_hash =
  get_operation_from_block cctxt ~chain predecessors operation_hash
  >>=? function
  | None ->
      failwith "Couldn't find operation"
  | Some op ->
      cctxt#message "%a" pp_operation op >>= fun () -> return_unit
src/proto_alpha/lib_client/client_proto_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_micheline.

Import Tezos_client_alpha.Client_proto_contracts.

Import Tezos_client_base.Client_keys.

Definition get_balance {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Contract.balance rpc
    (chain, block) contract.

Definition get_storage {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Contract.storage_opt rpc
    (chain, block) contract.

Definition get_big_map_value {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (id : Tezos_protocol_environment_alpha__Environment.Z.t)
  (key : Tezos_raw_protocol_alpha.Script_expr_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Contract.big_map_get rpc
    (chain, block) id key.

Definition get_contract_big_map_value {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (key :
    Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Contract.contract_big_map_get_opt
    rpc (chain, block) contract key.

Definition get_script {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.t)) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Contract.script_opt rpc
    (chain, block) contract.

Definition parse_expression (arg : string)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_client_alpha.Michelson_v1_parser.parsed) :=
  Lwt._return
    (Tezos_micheline.Micheline_parser.no_parsing_error
      (Tezos_client_alpha.Michelson_v1_parser.parse_expression None arg)).

Definition transfer {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (destination : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
  (op_star_o_p_t_star : option string)
  : (option string) ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
        (option Z.t) ->
          (option Z.t) ->
            (option Z.t) ->
              Tezos_client_alpha.Injection.fee_parameter ->
                unit ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      ((Tezos_base__TzPervasives.Operation_hash.t *
                        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
                        *
                        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)))
                        *
                        (list
                          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
  let entrypoint :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "default" % string
    end in
  fun arg =>
    fun amount =>
      fun fee =>
        fun gas_limit =>
          fun storage_limit =>
            fun counter =>
              fun fee_parameter =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      match arg with
                      | Some arg =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (parse_expression arg)
                          (fun function_parameter =>
                            match function_parameter with
                            | {| expanded := arg |} =>
                              Tezos_base__TzPervasives.return_some arg
                            end)
                      | None => Tezos_base__TzPervasives.return_none
                      end
                      (fun parameters =>
                        let parameters :=
                          Tezos_base__TzPervasives.Option.unopt_map
                            Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr
                            Tezos_protocol_alpha.Protocol.Alpha_context.Script.unit_parameter
                            parameters in
                        let contents :=
                          Transaction
                            {| amount := amount; parameters := parameters;
                              entrypoint := entrypoint;
                              destination := destination |} in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_alpha.Injection.inject_manager_operation
                            cctxt chain block branch confirmations dry_run
                            verbose_signing source src_pk src_sk fee gas_limit
                            storage_limit counter fee_parameter contents)
                          (fun function_parameter =>
                            match function_parameter with
                            | (_oph, _op, result) as res =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Lwt._return
                                  (Tezos_client_alpha.Injection.originated_contracts
                                    (Single_result result)))
                                (fun contracts =>
                                  Tezos_base__TzPervasives._return
                                    (res, contracts))
                            end))
                  end.

Definition reveal {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (Uri.t *
          (Tezos_shell_services.Shell_services.block *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
              (L * p * q * i * o)) *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                (o -> unit) ->
                  (unit -> unit) ->
                    p ->
                      q ->
                        i ->
                          Lwt.t
                            (Tezos_error_monad.Error_monad.tzresult
                              (unit -> unit))) * (M * p * q * i * o)) *
                (Tezos_shell_services.Shell_services.chain *
                  ((option Z) *
                    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                      (a * b)) *
                      ((Tezos_rpc.RPC_service.meth ->
                        (option Tezos_data_encoding.Data_encoding.json) ->
                          Uri.t ->
                            Lwt.t
                              (Tezos_rpc.RPC_context.rest_result
                                Tezos_data_encoding.Data_encoding.json
                                (option Tezos_data_encoding.Data_encoding.json)))
                        *
                        (((string ->
                          a ->
                            (Tezos_base__TzPervasives.Data_encoding.encoding a)
                              -> Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                          (a)) *
                          ((option (Lwt_stream.t string)) *
                            (((string ->
                              (Tezos_client_base.Client_context.lwt_format a
                                unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                unit) -> a) * (a)) *
                                ((unit -> Ptime.t) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((float -> Lwt.t unit) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * N)))))))))))))))))))))
      *
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block))
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Operation_hash.t *
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.reveal)) *
        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.reveal)))) :=
  match function_parameter with
  | tt =>
    match
      match fee with
      | None => (true, Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
      | Some fee => (false, fee)
      end with
    | (compute_fee, fee) =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_protocol_alpha.Protocol.Alpha_services.Contract.counter cctxt
          (chain, block) source)
        (fun pcounter =>
          let counter := Z.succ pcounter in
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_protocol_alpha.Protocol.Alpha_services.Contract.manager_key
              cctxt (chain, block) source)
            (fun key =>
              match key with
              | Some _ =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "The manager key was previously revealed." % string
                      CamlinternalFormatBasics.End_of_format)
                    "The manager key was previously revealed." % string)
              | None =>
                let contents :=
                  Single
                    (Manager_operation
                      {| source := source; fee := fee; counter := counter;
                        operation := Reveal src_pk;
                        gas_limit := Z.of_int (Z.opp 1); storage_limit := Z.zero
                        |}) in
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_client_alpha.Injection.inject_operation cctxt chain
                    block confirmations dry_run branch (Some src_sk)
                    verbose_signing fee_parameter (Some compute_fee) contents)
                  (fun function_parameter =>
                    match function_parameter with
                    | (oph, op, result) =>
                      match
                        Tezos_protocol_alpha.Protocol.Apply_results.pack_contents_list
                          op result with
                      |
                        Apply_results.Single_and_result
                          ((Manager_operation _) as op) result =>
                        Tezos_base__TzPervasives._return (oph, op, result)
                      end
                    end)
              end))
    end
  end.

Definition delegate_contract {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (branch : option Z)
  (confirmations : option Z) (dry_run : option bool)
  (verbose_signing : option bool)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (delegate_opt :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
  let operation := Delegation delegate_opt in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_alpha.Injection.inject_manager_operation cctxt chain block
      branch confirmations dry_run verbose_signing source src_pk src_sk fee None
      (Some Z.zero) None fee_parameter operation)
    (fun res => Tezos_base__TzPervasives._return res).

Definition list_contract_labels {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              ((option (Lwt_stream.t string)) *
                ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
                  ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                    (((string ->
                      a ->
                        (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                          Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
                      * M))))))))) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        ((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * M)))))
      * (D * E)) (chain : D) (block : E)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (list (string * string * string))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Contract.list cctxt
      (chain, block))
    (fun contracts =>
      Tezos_base__TzPervasives.op_gt_gt_pipe_question
        (Tezos_base__TzPervasives.rev_map_s
          (fun h =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              match
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                  h with
              | Some m =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_client_base.Client_keys.Public_key_hash.rev_find cctxt
                    m)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => Tezos_base__TzPervasives._return "" % string
                    | Some nm =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.find_opt
                          cctxt nm)
                        (fun function_parameter =>
                          match function_parameter with
                          | None =>
                            Tezos_base__TzPervasives._return
                              (String.append " (known as " % string
                                (String.append nm ")" % string))
                          | Some _ =>
                            Tezos_base__TzPervasives._return
                              (String.append " (known as key:" % string
                                (String.append nm ")" % string))
                          end)
                    end)
              | None =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.rev_find
                    cctxt h)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => Tezos_base__TzPervasives._return "" % string
                    | Some nm =>
                      Tezos_base__TzPervasives._return
                        (String.append " (known as " % string
                          (String.append nm ")" % string))
                    end)
              end
              (fun nm =>
                let kind :=
                  match
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                      h with
                  | Some _ => " (implicit)" % string
                  | None => "" % string
                  end in
                let h_b58 :=
                  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.to_b58check
                    h in
                Tezos_base__TzPervasives._return (nm, h_b58, kind))) contracts)
        Tezos_base__TzPervasives.List.rev).

Definition message_added_contract {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (name : string) : Lwt.t unit :=
  send
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "Contract memorized as " % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "." % char
            CamlinternalFormatBasics.End_of_format)))
      "Contract memorized as %s." % string) name.

Definition set_delegate {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (contract : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (manager_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (opt_delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
  delegate_contract cctxt chain block None confirmations dry_run verbose_signing
    contract src_pk manager_sk fee fee_parameter opt_delegate.

Definition register_as_delegate {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (manager_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (src_pk : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
  let source := Tezos_base__TzPervasives.Signature.Public_key.hash src_pk in
  delegate_contract cctxt chain block None confirmations dry_run verbose_signing
    source src_pk manager_sk fee fee_parameter (Some source).

Definition save_contract {E F H J L M N a b c i o p q : Type}
  (force : bool)
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                      variant
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q
                      i o) ->
                      (Tezos_shell_services.Shell_services.chain *
                        Tezos_shell_services.Shell_services.block) ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (E * q * i * o)) *
                      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                        variant
                        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          * a) q i o) ->
                        (Tezos_shell_services.Shell_services.chain *
                          Tezos_shell_services.Shell_services.block) ->
                          a ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (F * a * q * i * o)) *
                        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                          variant
                          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            * a) * b) q i o) ->
                          (Tezos_shell_services.Shell_services.chain *
                            Tezos_shell_services.Shell_services.block) ->
                            a ->
                              b ->
                                q ->
                                  i ->
                                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                        o)) * (H * a * b * q * i * o)) *
                          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                            variant
                            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                              * a) * b) * c) q i o) ->
                            (Tezos_shell_services.Shell_services.chain *
                              Tezos_shell_services.Shell_services.block) ->
                              a ->
                                b ->
                                  c ->
                                    q ->
                                      i ->
                                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                            o)) * (J * a * b * c * q * i * o)) *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (L * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (M * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((float -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (Uri.t *
          (Tezos_shell_services.Shell_services.block *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (E * q * i * o)) *
              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q
                i o) ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  a ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (F * a * q * i * o)) *
                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                  variant
                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                  ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                    * b) q i o) ->
                  (Tezos_shell_services.Shell_services.chain *
                    Tezos_shell_services.Shell_services.block) ->
                    a ->
                      b ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (H * a * b * q * i * o)) *
                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                    variant
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                    (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
                      a) * b) * c) q i o) ->
                    (Tezos_shell_services.Shell_services.chain *
                      Tezos_shell_services.Shell_services.block) ->
                      a ->
                        b ->
                          c ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (J * a * b * c * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) * N)))))))))))))))))))))
  (alias_name : string)
  (contract : Tezos_client_alpha.Client_proto_contracts.RawContractAlias.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.add force cctxt
      alias_name contract)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (message_added_contract cctxt alias_name)
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition originate_contract {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (gas_limit : option Z.t) (storage_limit : option Z.t)
  (delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (initial_storage : string)
  (balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (code : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_base__TzPervasives.Operation_hash.t *
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination)) *
        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination))) *
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Lwt._return
        (Tezos_client_alpha.Michelson_v1_parser.parse_expression None
          initial_storage))
      (fun result =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Lwt._return
            (Tezos_micheline.Micheline_parser.no_parsing_error result))
          (fun function_parameter =>
            match function_parameter with
            | {| Michelson_v1_parser.expanded := storage |} =>
              let code
                : Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr
                  code
              with storage
                : Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr
                  storage in
              let origination :=
                Origination
                  {| delegate := delegate;
                    script := {| code := code; storage := storage |};
                    credit := balance; preorigination := None |} in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_client_alpha.Injection.inject_manager_operation cctxt
                  chain block branch confirmations dry_run verbose_signing
                  source src_pk src_sk fee gas_limit storage_limit None
                  fee_parameter origination)
                (fun function_parameter =>
                  match function_parameter with
                  | (_oph, _op, result) as res =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Lwt._return
                        (Tezos_client_alpha.Injection.originated_contracts
                          (Single_result result)))
                      (fun function_parameter =>
                        match function_parameter with
                        | cons contract [] =>
                          Tezos_base__TzPervasives._return (res, contract)
                        | contracts =>
                          Tezos_base__TzPervasives.failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "The origination introduced " % string
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " contracts instead of one." % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "The origination introduced %d contracts instead of one."
                                % string)
                            (Tezos_base__TzPervasives.List.length contracts)
                        end)
                  end)
            end))
  end.

Record activation_key := {
  pkh : Tezos_base__TzPervasives.Ed25519.Public_key_hash.t;
  amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  activation_code :
    Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code;
  mnemonic : list string;
  password : string;
  email : string }.

Definition raw_activation_key_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    (Tezos_base__TzPervasives.Ed25519.Public_key_hash.t *
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t *
      Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code *
      (list string) * string * string) :=
  Tezos_base__TzPervasives.Data_encoding.obj6
    (Tezos_base__TzPervasives.Data_encoding.req None None "pkh" % string
      Tezos_base__TzPervasives.Ed25519.Public_key_hash.encoding)
    (Tezos_base__TzPervasives.Data_encoding.req None None "amount" % string
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.encoding)
    (Tezos_base__TzPervasives.Data_encoding.req None None
      "activation_code" % string
      Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code_encoding)
    (Tezos_base__TzPervasives.Data_encoding.req None None "mnemonic" % string
      (Tezos_base__TzPervasives.Data_encoding.list None
        Tezos_base__TzPervasives.Data_encoding.string))
    (Tezos_base__TzPervasives.Data_encoding.req None None "password" % string
      Tezos_base__TzPervasives.Data_encoding.string)
    (Tezos_base__TzPervasives.Data_encoding.req None None "email" % string
      Tezos_base__TzPervasives.Data_encoding.string).

Definition activation_key_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding activation_key :=
  apply
    (let arg :=
      Tezos_base__TzPervasives.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {|
            pkh := pkh;
              amount := amount;
              activation_code := activation_code;
              mnemonic := mnemonic;
              password := password;
              email := email
              |} => (pkh, amount, activation_code, mnemonic, password, email)
          end)
        (fun function_parameter =>
          match function_parameter with
          | (pkh, amount, activation_code, mnemonic, password, email) =>
            {| pkh := pkh; amount := amount; activation_code := activation_code;
              mnemonic := mnemonic; password := password; email := email |}
          end) in
    fun eta => arg None eta)
    (Tezos_base__TzPervasives.Data_encoding.splitted
      (Tezos_base__TzPervasives.Data_encoding.union None
        (cons
          (Tezos_base__TzPervasives.Data_encoding.case "Activation" % string
            None Json_only raw_activation_key_encoding (fun x => Some x)
            (fun x => x))
          (cons
            (Tezos_base__TzPervasives.Data_encoding.case
              "Deprecated_activation" % string None Json_only
              (Tezos_base__TzPervasives.Data_encoding.obj6
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "pkh" % string
                  Tezos_base__TzPervasives.Ed25519.Public_key_hash.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "amount" % string
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "secret" % string
                  Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code_encoding)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "mnemonic" % string
                  (Tezos_base__TzPervasives.Data_encoding.list None
                    Tezos_base__TzPervasives.Data_encoding.string))
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "password" % string
                  Tezos_base__TzPervasives.Data_encoding.string)
                (Tezos_base__TzPervasives.Data_encoding.req None None
                  "email" % string Tezos_base__TzPervasives.Data_encoding.string))
              (fun function_parameter =>
                match function_parameter with
                | _ => None
                end) (fun x => x)) []))) raw_activation_key_encoding).

Definition read_key (key : activation_key)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_crypto__Signature.Public_key_hash.t *
        Tezos_crypto__Signature.Public_key.t *
        Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
  match Bip39.of_words (mnemonic key) with
  | None =>
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
        "" % string)
  | Some t =>
    let passphrase :=
      Bigstring.concat "" % string
        (cons (Bigstring.of_string (email key))
          (cons (Bigstring.of_string (password key)) [])) in
    let sk := Bip39.to_seed (Some passphrase) t in
    let sk := Bigstring.sub_bytes sk 0 32 in
    let sk :=
      Ed25519
        (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
          Tezos_base__TzPervasives.Ed25519.Secret_key.encoding sk) in
    let pk := Tezos_base__TzPervasives.Signature.Secret_key.to_public_key sk in
    let pkh := Tezos_base__TzPervasives.Signature.Public_key.hash pk in
    Tezos_base__TzPervasives._return (pkh, pk, sk)
  end.

Definition inject_activate_operation {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (alias : string)
  (pkh : Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t)
  (activation_code :
    Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Operation_hash.t *
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account) *
        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
  let contents :=
    Single
      (Activate_account {| id := pkh; activation_code := activation_code |}) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_alpha.Injection.inject_operation cctxt chain block
      confirmations dry_run None None None
      Tezos_client_alpha.Injection.dummy_fee_parameter None contents)
    (fun function_parameter =>
      match function_parameter with
      | (oph, op, result) =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          match confirmations with
          | None => Tezos_base__TzPervasives.return_unit
          | Some _confirmations =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_protocol_alpha.Protocol.Alpha_services.Contract.balance
                cctxt (chain, block)
                (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  (Ed25519 pkh)))
              (fun balance =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Account " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal " (" % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                ") activated with " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      "." % char
                                      CamlinternalFormatBasics.End_of_format))))))))
                      "Account %s (%a) activated with %s%a." % string) alias
                    Tezos_base__TzPervasives.Ed25519.Public_key_hash.pp pkh
                    Tezos_client_alpha.Client_proto_args.tez_sym
                    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp balance)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives.return_unit
                    end))
          end
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              match
                Tezos_protocol_alpha.Protocol.Apply_results.pack_contents_list
                  op result with
              |
                Apply_results.Single_and_result ((Activate_account _) as op)
                  result => Tezos_base__TzPervasives._return (oph, op, result)
              end
            end)
      end).

Definition activate_account {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (op_star_o_p_t_star : option bool)
  : (option bool) ->
    activation_key ->
      string ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Operation_hash.t *
              (Tezos_protocol_alpha.Protocol.Alpha_context.contents
                Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account)
              *
              (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
                Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
  let encrypted :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun force =>
    fun key =>
      fun name =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question (read_key key)
          (fun function_parameter =>
            match function_parameter with
            | (pkh, pk, sk) =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives.fail_unless
                  (Tezos_base__TzPervasives.Signature.Public_key_hash.equal pkh
                    (Ed25519 (pkh key)))
                  (Tezos_base__TzPervasives.failure
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Inconsistent activation key:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "Computed pkh: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "Embedded pkh: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        " " % char
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))))))))
                      "@[<v 2>Inconsistent activation key:@ Computed pkh: %a@ Embedded pkh: %a @]"
                        % string)
                    Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh
                    Tezos_base__TzPervasives.Ed25519.Public_key_hash.pp
                    (pkh key)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk
                      in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (if encrypted then
                        Tezos_signer_backends.Encrypted.encrypt cctxt sk
                      else
                        Tezos_base__TzPervasives._return
                          (Tezos_signer_backends.Unencrypted.make_sk sk))
                      (fun sk_uri =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_base.Client_keys.register_key cctxt
                            force (pkh, pk_uri, sk_uri) None name)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              inject_activate_operation cctxt chain block
                                confirmations dry_run name (pkh key)
                                (activation_code key)
                            end))
                  end)
            end).

Definition activate_existing_account {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (alias : string)
  (activation_code :
    Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Operation_hash.t *
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account) *
        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_base.Client_keys.alias_keys cctxt alias)
    (fun function_parameter =>
      match function_parameter with
      | Some (Ed25519 pkh, _, _) =>
        inject_activate_operation cctxt chain block confirmations dry_run alias
          pkh activation_code
      | Some _ =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Only Ed25519 accounts can be activated" % string
              CamlinternalFormatBasics.End_of_format)
            "Only Ed25519 accounts can be activated" % string)
      | None =>
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Unknown account" % string
              CamlinternalFormatBasics.End_of_format) "Unknown account" % string)
      end).

Record period_info := {
  current_period_kind :
    Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.kind;
  position : Stdlib.Int32.t;
  remaining : Stdlib.Int32.t;
  current_proposal : option Tezos_base__TzPervasives.Protocol_hash.t }.

Record ballots_info := {
  current_quorum : Stdlib.Int32.t;
  participation : Stdlib.Int32.t;
  supermajority : Stdlib.Int32.t;
  ballots : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots }.

Definition get_ballots_info {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  : Lwt.t (Tezos_base__TzPervasives.tzresult ballots_info) :=
  let cb := (chain, block) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Voting.ballots cctxt cb)
    (fun ballots =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_protocol_alpha.Protocol.Alpha_services.Voting.current_quorum
          cctxt cb)
        (fun current_quorum =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_protocol_alpha.Protocol.Alpha_services.Voting.listings cctxt
              cb)
            (fun listings =>
              let max_participation :=
                Tezos_base__TzPervasives.List.fold_left
                  (fun acc =>
                    fun function_parameter =>
                      match function_parameter with
                      | (_, w) => Stdlib.Int32.add w acc
                      end) 0 listings in
              let all_votes :=
                Stdlib.Int32.add (Stdlib.Int32.add (yay ballots) (nay ballots))
                  (pass ballots) in
              let participation :=
                Stdlib.Int32.div (Stdlib.Int32.mul all_votes 10000)
                  max_participation in
              let supermajority :=
                Stdlib.Int32.div
                  (Stdlib.Int32.mul 8
                    (Stdlib.Int32.add (yay ballots) (nay ballots))) 10 in
              Tezos_base__TzPervasives._return
                {| current_quorum := current_quorum;
                  participation := participation;
                  supermajority := supermajority; ballots := ballots |}))).

Definition get_period_info {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  : Lwt.t (Tezos_base__TzPervasives.tzresult period_info) :=
  let cb := (chain, block) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level cctxt
      (Some 1) cb)
    (fun level =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all cctxt cb)
        (fun constants =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_protocol_alpha.Protocol.Alpha_services.Voting.current_proposal
              cctxt cb)
            (fun current_proposal =>
              let position := voting_period_position level in
              let remaining :=
                Stdlib.Int32.sub
                  (blocks_per_voting_period (parametric constants)) position in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_protocol_alpha.Protocol.Alpha_services.Voting.current_period_kind
                  cctxt cb)
                (fun current_period_kind =>
                  Tezos_base__TzPervasives._return
                    {| current_period_kind := current_period_kind;
                      position := position; remaining := remaining;
                      current_proposal := current_proposal |})))).

Definition get_proposals {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t
        Tezos_protocol_environment_alpha__Environment.Int32.t)) :=
  let cb := (chain, block) in
  Tezos_protocol_alpha.Protocol.Alpha_services.Voting.proposals cctxt cb.

Definition submit_proposals {D F H J L M N a b c i o p q : Type}
  (dry_run : option bool) (verbose_signing : option bool)
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (source :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (proposals :
    list
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result_list
        Tezos_protocol_alpha.Protocol.Alpha_context.Kind.proposals)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level cctxt
      (Some 1) (chain, block))
    (fun level =>
      let period := voting_period level in
      let contents :=
        Single
          (Proposals
            {| source := source; period := period; proposals := proposals |}) in
      Tezos_client_alpha.Injection.inject_operation cctxt chain block
        confirmations dry_run None (Some src_sk) verbose_signing
        Tezos_client_alpha.Injection.dummy_fee_parameter None contents).

Definition submit_ballot {D F H J L M N a b c i o p q : Type}
  (dry_run : option bool) (verbose_signing : option bool)
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (source :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (proposal :
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ballot : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result_list
        Tezos_protocol_alpha.Protocol.Alpha_context.Kind.ballot)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level cctxt
      (Some 1) (chain, block))
    (fun level =>
      let period := voting_period level in
      let contents :=
        Single
          (Ballot
            {| source := source; period := period; proposal := proposal;
              ballot := ballot |}) in
      Tezos_client_alpha.Injection.inject_operation cctxt chain block
        confirmations dry_run None (Some src_sk) verbose_signing
        Tezos_client_alpha.Injection.dummy_fee_parameter None contents).

Definition pp_operation
  (formatter : Stdlib.Format.formatter)
  (a : Tezos_client_alpha.Protocol_client_context.Alpha_block_services.operation)
  : unit :=
  match ((receipt a), (protocol_data a)) with
  | (Apply_results.Operation_metadata omd, Operation_data od) =>
    match
      Tezos_protocol_alpha.Protocol.Apply_results.kind_equal_list (contents od)
        (contents omd) with
    | Some Apply_results.Eq =>
      Tezos_client_alpha.Operation_result.pp_operation_result formatter
        ((contents od), (contents omd))
    | None => Stdlib.Pervasives.failwith "Unexpected result." % string
    end
  | _ => Stdlib.Pervasives.failwith "Unexpected result." % string
  end.

Definition get_operation_from_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Block_services.chain)
  (predecessors : Z)
  (operation_hash : Tezos_base__TzPervasives.Operation_list_hash.elt)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        Tezos_client_alpha__Protocol_client_context.Alpha_block_services.operation)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_base.Client_confirmations.lookup_operation_in_previous_blocks
      cctxt chain predecessors operation_hash)
    (fun function_parameter =>
      match function_parameter with
      | None => Tezos_base__TzPervasives.return_none
      | Some (block, i, j) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Operation found in block: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (pass: " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        ", offset: " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))))
              "Operation found in block: %a (pass: %d, offset: %d)" % string)
            Tezos_base__TzPervasives.Block_hash.pp block i j)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Operations.operation
                  cctxt (Some chain) (Some variant) i j)
                (fun op' => Tezos_base__TzPervasives.return_some op')
            end)
      end).

Definition display_receipt_for_operation {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Block_services.chain)
  (op_star_o_p_t_star : option Z)
  : Tezos_base__TzPervasives.Operation_list_hash.elt ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let predecessors :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 10
    end in
  fun operation_hash =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (get_operation_from_block cctxt chain predecessors operation_hash)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Couldn't find operation" % string
                CamlinternalFormatBasics.End_of_format)
              "Couldn't find operation" % string)
        | Some op =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              pp_operation op)
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end)
        end).
src/proto_alpha/lib_client/client_proto_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

val list_contract_labels :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  (string * string * string) list tzresult Lwt.t

val get_storage :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Contract.t ->
  Script.expr option tzresult Lwt.t

val get_contract_big_map_value :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Contract.t ->
  Script.expr * Script.expr ->
  Script.expr option tzresult Lwt.t

val get_big_map_value :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Z.t ->
  Script_expr_hash.t ->
  Script.expr tzresult Lwt.t

val get_script :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Contract.t ->
  Script.t option tzresult Lwt.t

val get_balance :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Contract.t ->
  Tez.t tzresult Lwt.t

val set_delegate :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  ?fee:Tez.tez ->
  public_key_hash ->
  src_pk:public_key ->
  manager_sk:Client_keys.sk_uri ->
  fee_parameter:Injection.fee_parameter ->
  public_key_hash option ->
  Kind.delegation Kind.manager Injection.result tzresult Lwt.t

val register_as_delegate :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  ?fee:Tez.tez ->
  manager_sk:Client_keys.sk_uri ->
  fee_parameter:Injection.fee_parameter ->
  public_key ->
  Kind.delegation Kind.manager Injection.result tzresult Lwt.t

val save_contract :
  force:bool ->
  #Protocol_client_context.full ->
  string ->
  Contract.t ->
  unit tzresult Lwt.t

val originate_contract :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  ?branch:int ->
  ?fee:Tez.t ->
  ?gas_limit:Z.t ->
  ?storage_limit:Z.t ->
  delegate:public_key_hash option ->
  initial_storage:string ->
  balance:Tez.t ->
  source:public_key_hash ->
  src_pk:public_key ->
  src_sk:Client_keys.sk_uri ->
  code:Script.expr ->
  fee_parameter:Injection.fee_parameter ->
  unit ->
  (Kind.origination Kind.manager Injection.result * Contract.t) tzresult Lwt.t

val transfer :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  ?branch:int ->
  source:public_key_hash ->
  src_pk:public_key ->
  src_sk:Client_keys.sk_uri ->
  destination:Contract.t ->
  ?entrypoint:string ->
  ?arg:string ->
  amount:Tez.t ->
  ?fee:Tez.t ->
  ?gas_limit:Z.t ->
  ?storage_limit:Z.t ->
  ?counter:Z.t ->
  fee_parameter:Injection.fee_parameter ->
  unit ->
  (Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult
  Lwt.t

val reveal :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  ?branch:int ->
  source:public_key_hash ->
  src_pk:public_key ->
  src_sk:Client_keys.sk_uri ->
  ?fee:Tez.t ->
  fee_parameter:Injection.fee_parameter ->
  unit ->
  Kind.reveal Kind.manager Injection.result tzresult Lwt.t

type activation_key = {
  pkh : Ed25519.Public_key_hash.t;
  amount : Tez.t;
  activation_code : Blinded_public_key_hash.activation_code;
  mnemonic : string list;
  password : string;
  email : string;
}

val activation_key_encoding : activation_key Data_encoding.t

val activate_account :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?encrypted:bool ->
  ?force:bool ->
  activation_key ->
  string ->
  Kind.activate_account Injection.result tzresult Lwt.t

val activate_existing_account :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  string ->
  Blinded_public_key_hash.activation_code ->
  Kind.activate_account Injection.result tzresult Lwt.t

type period_info = {
  current_period_kind : Voting_period.kind;
  position : Int32.t;
  remaining : Int32.t;
  current_proposal : Protocol_hash.t option;
}

type ballots_info = {
  current_quorum : Int32.t;
  participation : Int32.t;
  supermajority : Int32.t;
  ballots : Vote.ballots;
}

val get_period_info :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  period_info tzresult Lwt.t

val get_ballots_info :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ballots_info tzresult Lwt.t

val get_proposals :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Int32.t Environment.Protocol_hash.Map.t tzresult Lwt.t

val submit_proposals :
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  src_sk:Client_keys.sk_uri ->
  public_key_hash ->
  Protocol_hash.t list ->
  Kind.proposals Injection.result_list tzresult Lwt.t

val submit_ballot :
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  src_sk:Client_keys.sk_uri ->
  public_key_hash ->
  Protocol_hash.t ->
  Vote.ballot ->
  Kind.ballot Injection.result_list tzresult Lwt.t

(** lookup an operation in [predecessors] previous blocks, and print the
    receipt if found *)
val display_receipt_for_operation :
  #Protocol_client_context.full ->
  chain:Block_services.chain ->
  ?predecessors:int ->
  Operation_list_hash.elt ->
  unit tzresult Lwt.t
src/proto_alpha/lib_client/client_proto_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter list_contract_labels : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult (list (string * string * string))).

Parameter get_storage : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)).

Parameter get_contract_big_map_value : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        (Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr *
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)).

Parameter get_big_map_value : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Z.t ->
        Tezos_protocol_alpha.Protocol.Script_expr_hash.t ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr).

Parameter get_script : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.t)).

Parameter get_balance : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t).

Parameter set_delegate : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option bool) ->
            (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
              Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
                Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
                  Tezos_client_base.Client_keys.sk_uri ->
                    Tezos_client_alpha.Injection.fee_parameter ->
                      (option
                        Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
                        ->
                        Lwt.t
                          (Tezos_base__TzPervasives.tzresult
                            (Tezos_client_alpha.Injection.result
                              (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))).

Parameter register_as_delegate : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option bool) ->
            (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
              Tezos_client_base.Client_keys.sk_uri ->
                Tezos_client_alpha.Injection.fee_parameter ->
                  Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
                    Lwt.t
                      (Tezos_base__TzPervasives.tzresult
                        (Tezos_client_alpha.Injection.result
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))).

Parameter save_contract : forall {_ a b c i o p q variant : Type},
bool ->
  (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (_ * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (_ * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * _)))))))))))))))))))))))))
    * _) ->
    string ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter originate_contract : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option bool) ->
            (option Z) ->
              (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
                (option Z.t) ->
                  (option Z.t) ->
                    (option
                      Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
                      ->
                      string ->
                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
                          Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash
                            ->
                            Tezos_protocol_alpha.Protocol.Alpha_context.public_key
                              ->
                              Tezos_client_base.Client_keys.sk_uri ->
                                Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr
                                  ->
                                  Tezos_client_alpha.Injection.fee_parameter ->
                                    unit ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult
                                          ((Tezos_client_alpha.Injection.result
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination))
                                            *
                                            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)).

Parameter transfer : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option bool) ->
            (option Z) ->
              Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
                Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
                  Tezos_client_base.Client_keys.sk_uri ->
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
                      (option string) ->
                        (option string) ->
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
                            (option
                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
                              ->
                              (option Z.t) ->
                                (option Z.t) ->
                                  (option Z.t) ->
                                    Tezos_client_alpha.Injection.fee_parameter
                                      ->
                                      unit ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            ((Tezos_client_alpha.Injection.result
                                              (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
                                              *
                                              (list
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))).

Parameter reveal : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option bool) ->
            (option Z) ->
              Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
                Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
                  Tezos_client_base.Client_keys.sk_uri ->
                    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
                      ->
                      Tezos_client_alpha.Injection.fee_parameter ->
                        unit ->
                          Lwt.t
                            (Tezos_base__TzPervasives.tzresult
                              (Tezos_client_alpha.Injection.result
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Kind.reveal))).

Record activation_key := {
  pkh : Tezos_base__TzPervasives.Ed25519.Public_key_hash.t;
  amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  activation_code :
    Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code;
  mnemonic : list string;
  password : string;
  email : string }.

Parameter activation_key_encoding :
Tezos_base__TzPervasives.Data_encoding.t activation_key.

Parameter activate_account : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option bool) ->
            (option bool) ->
              activation_key ->
                string ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      (Tezos_client_alpha.Injection.result
                        Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account)).

Parameter activate_existing_account : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          string ->
            Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code
              ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  (Tezos_client_alpha.Injection.result
                    Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account)).

Record period_info := {
  current_period_kind :
    Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.kind;
  position : Stdlib.Int32.t;
  remaining : Stdlib.Int32.t;
  current_proposal : option Tezos_base__TzPervasives.Protocol_hash.t }.

Record ballots_info := {
  current_quorum : Stdlib.Int32.t;
  participation : Stdlib.Int32.t;
  supermajority : Stdlib.Int32.t;
  ballots : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots }.

Parameter get_period_info : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Lwt.t (Tezos_base__TzPervasives.tzresult period_info).

Parameter get_ballots_info : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Lwt.t (Tezos_base__TzPervasives.tzresult ballots_info).

Parameter get_proposals : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.t
            Stdlib.Int32.t)).

Parameter submit_proposals : forall {_ a b c i o p q variant : Type},
(option bool) ->
  (option bool) ->
    (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (_ * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (_ * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * _)))))))))))))))))))))))))
      * _) ->
      Tezos_shell_services.Shell_services.chain ->
        Tezos_shell_services.Shell_services.block ->
          (option Z) ->
            Tezos_client_base.Client_keys.sk_uri ->
              Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
                (list Tezos_base__TzPervasives.Protocol_hash.t) ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      (Tezos_client_alpha.Injection.result_list
                        Tezos_protocol_alpha.Protocol.Alpha_context.Kind.proposals)).

Parameter submit_ballot : forall {_ a b c i o p q variant : Type},
(option bool) ->
  (option bool) ->
    (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (_ * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (_ * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * _)))))))))))))))))))))))))
      * _) ->
      Tezos_shell_services.Shell_services.chain ->
        Tezos_shell_services.Shell_services.block ->
          (option Z) ->
            Tezos_client_base.Client_keys.sk_uri ->
              Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
                Tezos_base__TzPervasives.Protocol_hash.t ->
                  Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot ->
                    Lwt.t
                      (Tezos_base__TzPervasives.tzresult
                        (Tezos_client_alpha.Injection.result_list
                          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.ballot)).

Parameter display_receipt_for_operation : forall
{_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Block_services.chain ->
    (option Z) ->
      Tezos_base__TzPervasives.Operation_list_hash.elt ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_client/client_proto_contracts.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

module ContractEntity = struct
  type t = Contract.t

  let encoding = Contract.encoding

  let of_source s =
    match Contract.of_b58check s with
    | Error _ as err ->
        Lwt.return (Environment.wrap_error err)
        |> trace (failure "bad contract notation")
    | Ok s ->
        return s

  let to_source s = return (Contract.to_b58check s)

  let name = "contract"
end

module RawContractAlias = Client_aliases.Alias (ContractEntity)

module ContractAlias = struct
  let find cctxt s =
    RawContractAlias.find_opt cctxt s
    >>=? function
    | Some v ->
        return (s, v)
    | None -> (
        Client_keys.Public_key_hash.find_opt cctxt s
        >>=? function
        | Some v ->
            return (s, Contract.implicit_contract v)
        | None ->
            failwith "no contract or key named %s" s )

  let find_key cctxt name =
    Client_keys.Public_key_hash.find cctxt name
    >>=? fun v -> return (name, Contract.implicit_contract v)

  let rev_find cctxt c =
    match Contract.is_implicit c with
    | Some hash -> (
        Client_keys.Public_key_hash.rev_find cctxt hash
        >>=? function
        | Some name -> return_some ("key:" ^ name) | None -> return_none )
    | None ->
        RawContractAlias.rev_find cctxt c

  let get_contract cctxt s =
    match String.split ~limit:1 ':' s with
    | ["key"; key] ->
        find_key cctxt key
    | _ ->
        find cctxt s

  let autocomplete cctxt =
    Client_keys.Public_key_hash.autocomplete cctxt
    >>=? fun keys ->
    RawContractAlias.autocomplete cctxt
    >>=? fun contracts -> return (List.map (( ^ ) "key:") keys @ contracts)

  let alias_param ?(name = "name") ?(desc = "existing contract alias") next =
    let desc =
      desc ^ "\n"
      ^ "Can be a contract alias or a key alias (autodetected in order).\n\
         Use 'key:name' to force the later."
    in
    Clic.(
      param
        ~name
        ~desc
        (parameter ~autocomplete (fun cctxt p -> get_contract cctxt p))
        next)

  let destination_parameter () =
    Clic.parameter
      ~autocomplete:(fun cctxt ->
        autocomplete cctxt
        >>=? fun list1 ->
        Client_keys.Public_key_hash.autocomplete cctxt
        >>=? fun list2 -> return (list1 @ list2))
      (fun cctxt s ->
        match String.split ~limit:1 ':' s with
        | ["alias"; alias] ->
            find cctxt alias
        | ["key"; text] ->
            Client_keys.Public_key_hash.find cctxt text
            >>=? fun v -> return (s, Contract.implicit_contract v)
        | _ -> (
            find cctxt s
            >>= function
            | Ok v ->
                return v
            | Error k_errs -> (
                ContractEntity.of_source s
                >>= function
                | Ok v ->
                    return (s, v)
                | Error c_errs ->
                    Lwt.return_error (k_errs @ c_errs) ) ))

  let destination_param ?(name = "dst") ?(desc = "destination contract") next =
    let desc =
      String.concat
        "\n"
        [ desc;
          "Can be an alias, a key, or a literal (autodetected in order).\n\
           Use 'text:literal', 'alias:name', 'key:name' to force." ]
    in
    Clic.param ~name ~desc (destination_parameter ()) next

  let destination_arg ?(name = "dst") ?(doc = "destination contract") () =
    let doc =
      String.concat
        "\n"
        [ doc;
          "Can be an alias, a key, or a literal (autodetected in order).\n\
           Use 'text:literal', 'alias:name', 'key:name' to force." ]
    in
    Clic.arg ~long:name ~doc ~placeholder:name (destination_parameter ())

  let name cctxt contract =
    rev_find cctxt contract
    >>=? function
    | None -> return (Contract.to_b58check contract) | Some name -> return name
end

let list_contracts cctxt =
  RawContractAlias.load cctxt
  >>=? fun raw_contracts ->
  Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts
  >>= fun contracts ->
  Client_keys.Public_key_hash.load cctxt
  >>=? fun keys ->
  (* List accounts (implicit contracts of identities) *)
  map_s
    (fun (n, v) ->
      RawContractAlias.mem cctxt n
      >>=? fun mem ->
      let p = if mem then "key:" else "" in
      let v' = Contract.implicit_contract v in
      return (p, n, v'))
    keys
  >>=? fun accounts -> return (contracts @ accounts)

let get_delegate cctxt ~chain ~block source =
  Alpha_services.Contract.delegate_opt cctxt (chain, block) source
src/proto_alpha/lib_client/client_proto_contracts.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Module ContractEntity.
  Definition t := Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.encoding.
  
  Definition of_source (s : string)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) :=
    match Tezos_protocol_alpha.Protocol.Alpha_context.Contract.of_b58check s
      with
    | (inr _) as err =>
      OCaml.Stdlib.reverse_apply
        (Lwt._return (Tezos_protocol_alpha.Protocol.Environment.wrap_error err))
        (Tezos_base__TzPervasives.trace
          (Tezos_base__TzPervasives.failure
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "bad contract notation" % string
                CamlinternalFormatBasics.End_of_format)
              "bad contract notation" % string)))
    | inl s => Tezos_base__TzPervasives._return s
    end.
  
  Definition to_source
    (s : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    Tezos_base__TzPervasives._return
      (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.to_b58check s).
  
  Definition name : string := "contract" % string.
End ContractEntity.

Module ContractAlias.
  Definition find {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (s : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (string * RawContractAlias.t)) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (RawContractAlias.find_opt cctxt s)
      (fun function_parameter =>
        match function_parameter with
        | Some v => Tezos_base__TzPervasives._return (s, v)
        | None =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_client_base.Client_keys.Public_key_hash.find_opt cctxt s)
            (fun function_parameter =>
              match function_parameter with
              | Some v =>
                Tezos_base__TzPervasives._return
                  (s,
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                      v))
              | None =>
                Tezos_base__TzPervasives.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "no contract or key named " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "no contract or key named %s" % string) s
              end)
        end).
  
  Definition find_key {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (name : string)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_client_base.Client_keys.Public_key_hash.find cctxt name)
      (fun v =>
        Tezos_base__TzPervasives._return
          (name,
            (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
              v))).
  
  Definition rev_find {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (c : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (option string)) :=
    match Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit c
      with
    | Some hash =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_client_base.Client_keys.Public_key_hash.rev_find cctxt hash)
        (fun function_parameter =>
          match function_parameter with
          | Some name =>
            Tezos_base__TzPervasives.return_some
              (String.append "key:" % string name)
          | None => Tezos_base__TzPervasives.return_none
          end)
    | None => RawContractAlias.rev_find cctxt c
    end.
  
  Definition get_contract {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (s : string)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
    match Tezos_base__TzPervasives.String.split ":" % char None (Some 1) s with
    | cons "key" % string (cons key []) => find_key cctxt key
    | _ => find cctxt s
    end.
  
  Definition autocomplete {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) : Lwt.t (Tezos_base__TzPervasives.tzresult (list string)) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_client_base.Client_keys.Public_key_hash.autocomplete cctxt)
      (fun keys =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (RawContractAlias.autocomplete cctxt)
          (fun contracts =>
            Tezos_base__TzPervasives._return
              (OCaml.Stdlib.app
                (Tezos_base__TzPervasives.List.map
                  (String.append "key:" % string) keys) contracts))).
  
  Definition alias_param {A C a : Type} (op_star_o_p_t_star : option string)
    : (option string) ->
      (Tezos_base__TzPervasives.Clic.params A
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
          * C)) ->
        Tezos_base__TzPervasives.Clic.params
          ((string *
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) -> A)
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    C))))) * C) :=
    let name :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => "name" % string
      end in
    fun op_star_o_p_t_star =>
      let desc :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "existing contract alias" % string
        end in
      fun next =>
        let desc :=
          String.append desc
            (String.append "
" % string
              "Can be a contract alias or a key alias (autodetected in order).
Use 'key:name' to force the later."
                % string) in
        Tezos_base__TzPervasives.Clic.param name desc
          (Tezos_base__TzPervasives.Clic.parameter (Some autocomplete)
            (fun cctxt => fun p => get_contract cctxt p)) next.
  
  Definition destination_parameter {B a : Type} (function_parameter : unit)
    : Tezos_base__TzPervasives.Clic.parameter (string * RawContractAlias.t)
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) :=
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.Clic.parameter
        (Some
          (fun cctxt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question (autocomplete cctxt)
              (fun list1 =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_client_base.Client_keys.Public_key_hash.autocomplete
                    cctxt)
                  (fun list2 =>
                    Tezos_base__TzPervasives._return
                      (OCaml.Stdlib.app list1 list2)))))
        (fun cctxt =>
          fun s =>
            match
              Tezos_base__TzPervasives.String.split ":" % char None (Some 1) s
              with
            | cons "alias" % string (cons alias []) => find cctxt alias
            | cons "key" % string (cons text []) =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_client_base.Client_keys.Public_key_hash.find cctxt text)
                (fun v =>
                  Tezos_base__TzPervasives._return
                    (s,
                      (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                        v)))
            | _ =>
              Tezos_base__TzPervasives.op_gt_gt_eq (find cctxt s)
                (fun function_parameter =>
                  match function_parameter with
                  | inl v => Tezos_base__TzPervasives._return v
                  | inr k_errs =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (ContractEntity.of_source s)
                      (fun function_parameter =>
                        match function_parameter with
                        | inl v => Tezos_base__TzPervasives._return (s, v)
                        | inr c_errs =>
                          Lwt.return_error (OCaml.Stdlib.app k_errs c_errs)
                        end)
                  end)
            end)
    end.
  
  Definition destination_param {A C a : Type}
    (op_star_o_p_t_star : option string)
    : (option string) ->
      (Tezos_base__TzPervasives.Clic.params A
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
          * C)) ->
        Tezos_base__TzPervasives.Clic.params
          ((string * RawContractAlias.t) -> A)
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    C))))) * C) :=
    let name :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => "dst" % string
      end in
    fun op_star_o_p_t_star =>
      let desc :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "destination contract" % string
        end in
      fun next =>
        let desc :=
          Tezos_base__TzPervasives.String.concat "
" % string
            (cons desc
              (cons
                "Can be an alias, a key, or a literal (autodetected in order).
Use 'text:literal', 'alias:name', 'key:name' to force."
                  % string [])) in
        Tezos_base__TzPervasives.Clic.param name desc (destination_parameter tt)
          next.
  
  Definition destination_arg {B a : Type} (op_star_o_p_t_star : option string)
    : (option string) ->
      unit ->
        Tezos_base__TzPervasives.Clic.arg (option (string * RawContractAlias.t))
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    B))))) * B) :=
    let name :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => "dst" % string
      end in
    fun op_star_o_p_t_star =>
      let doc :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "destination contract" % string
        end in
      fun function_parameter =>
        match function_parameter with
        | tt =>
          let doc :=
            Tezos_base__TzPervasives.String.concat "
" % string
              (cons doc
                (cons
                  "Can be an alias, a key, or a literal (autodetected in order).
Use 'text:literal', 'alias:name', 'key:name' to force."
                    % string [])) in
          Tezos_base__TzPervasives.Clic.arg doc None name name
            (destination_parameter tt)
        end.
  
  Definition name {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B)
    (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question (rev_find cctxt contract)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_base__TzPervasives._return
            (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.to_b58check
              contract)
        | Some name => Tezos_base__TzPervasives._return name
        end).
End ContractAlias.

Definition list_contracts {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * string * RawContractAlias.t))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (RawContractAlias.load cctxt)
    (fun raw_contracts =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt_list.map_s
          (fun function_parameter =>
            match function_parameter with
            | (n, v) => Lwt._return ("" % string, n, v)
            end) raw_contracts)
        (fun contracts =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_client_base.Client_keys.Public_key_hash.load cctxt)
            (fun keys =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives.map_s
                  (fun function_parameter =>
                    match function_parameter with
                    | (n, v) =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (RawContractAlias.mem cctxt n)
                        (fun mem =>
                          let p :=
                            if mem then
                              "key:" % string
                            else
                              "" % string in
                          let v' :=
                            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                              v in
                          Tezos_base__TzPervasives._return (p, n, v'))
                    end) keys)
                (fun accounts =>
                  Tezos_base__TzPervasives._return
                    (OCaml.Stdlib.app contracts accounts))))).

Definition get_delegate {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Contract.delegate_opt cctxt
    (chain, block) source.
src/proto_alpha/lib_client/client_proto_contracts.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Clic

module RawContractAlias : Client_aliases.Alias with type t = Contract.t

module ContractAlias : sig
  val get_contract :
    #Client_context.wallet -> string -> (string * Contract.t) tzresult Lwt.t

  val alias_param :
    ?name:string ->
    ?desc:string ->
    ('a, (#Client_context.wallet as 'wallet)) params ->
    (string * Contract.t -> 'a, 'wallet) params

  val destination_param :
    ?name:string ->
    ?desc:string ->
    ('a, (#Client_context.wallet as 'wallet)) params ->
    (string * Contract.t -> 'a, 'wallet) params

  val destination_arg :
    ?name:string ->
    ?doc:string ->
    unit ->
    ((string * Contract.t) option, #Client_context.wallet) Clic.arg

  val rev_find :
    #Client_context.wallet -> Contract.t -> string option tzresult Lwt.t

  val name : #Client_context.wallet -> Contract.t -> string tzresult Lwt.t

  val autocomplete : #Client_context.wallet -> string list tzresult Lwt.t
end

val list_contracts :
  #Client_context.wallet ->
  (string * string * RawContractAlias.t) list tzresult Lwt.t

val get_delegate :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Contract.t ->
  public_key_hash option tzresult Lwt.t
src/proto_alpha/lib_client/client_proto_contracts.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

Module ContractAlias.
  Parameter get_contract : forall {_ a : Type}, (((option (Lwt_stream.t string))
    *
    ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
    * _) ->
    string ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)).
  
  Parameter alias_param : forall {a wallet : Type}, (option string) ->
    (option string) ->
      (Tezos_base__TzPervasives.Clic.params a
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                  wallet))))) * wallet)) ->
        Tezos_base__TzPervasives.Clic.params
          ((string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
            a)
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    wallet))))) * wallet).
  
  Parameter destination_param : forall {a wallet : Type}, (option string) ->
    (option string) ->
      (Tezos_base__TzPervasives.Clic.params a
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                  wallet))))) * wallet)) ->
        Tezos_base__TzPervasives.Clic.params
          ((string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
            a)
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    wallet))))) * wallet).
  
  Parameter destination_arg : forall {_ a : Type}, (option string) ->
    (option string) ->
      unit ->
        Tezos_base__TzPervasives.Clic.arg
          (option
            (string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    _))))) * _).
  
  Parameter rev_find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
    ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
    * _) ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult (option string)).
  
  Parameter name : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
    ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
    * _) ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult string).
  
  Parameter autocomplete : forall {_ a : Type}, (((option (Lwt_stream.t string))
    *
    ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
    * _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list string)).
End ContractAlias.

Parameter list_contracts : forall {_ a : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * string * RawContractAlias.t))).

Parameter get_delegate : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)).
src/proto_alpha/lib_client/client_proto_multisig.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context

type error += Contract_has_no_script of Contract.t

type error +=
  | Not_a_supported_multisig_contract of (Script_expr_hash.t * Script.expr)

type error += Contract_has_no_storage of Contract.t

type error += Contract_has_unexpected_storage of Contract.t

type error += Invalid_signature of signature

type error += Not_enough_signatures of int * int

type error += Action_deserialisation_error of Script.expr

type error += Bytes_deserialisation_error of Bytes.t

type error += Bad_deserialized_contract of (Contract.t * Contract.t)

type error += Bad_deserialized_counter of (counter * counter)

type error += Non_positive_threshold of int

type error += Threshold_too_high of int * int

let () =
  register_error_kind
    `Permanent
    ~id:"contractHasNoScript"
    ~title:
      "The given contract is not a multisig contract because it has no script"
    ~description:
      "A multisig command has referenced a scriptless smart contract instead \
       of a multisig smart contract."
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract has no script %a." Contract.pp contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_no_script c -> Some c | _ -> None)
    (fun c -> Contract_has_no_script c) ;
  register_error_kind
    `Permanent
    ~id:"notASupportedMultisigContract"
    ~title:"The given contract is not one of the supported contracts"
    ~description:
      "A multisig command has referenced a smart contract whose script is not \
       one of the known multisig contract scripts."
    ~pp:(fun ppf (hash, script) ->
      Format.fprintf
        ppf
        "Not a supported multisig contract %a.@\n\
         The hash of this script is 0x%a, it was not found among in the list \
         of known multisig script hashes."
        Michelson_v1_printer.print_expr
        script
        Hex.pp
        (Script_expr_hash.to_bytes hash |> Hex.of_bytes))
    Data_encoding.(
      obj2
        (req "hash" Script_expr_hash.encoding)
        (req "script" Script.expr_encoding))
    (function
      | Not_a_supported_multisig_contract (h, c) -> Some (h, c) | _ -> None)
    (fun (h, c) -> Not_a_supported_multisig_contract (h, c)) ;
  register_error_kind
    `Permanent
    ~id:"contractHasNoStorage"
    ~title:
      "The given contract is not a multisig contract because it has no storage"
    ~description:
      "A multisig command has referenced a smart contract without storage \
       instead of a multisig smart contract."
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract has no storage %a." Contract.pp contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_no_storage c -> Some c | _ -> None)
    (fun c -> Contract_has_no_storage c) ;
  register_error_kind
    `Permanent
    ~id:"contractHasUnexpectedStorage"
    ~title:
      "The storage of the given contract is not of the shape expected for a \
       multisig contract"
    ~description:
      "A multisig command has referenced a smart contract whose storage is of \
       a different shape than the expected one."
    ~pp:(fun ppf contract ->
      Format.fprintf
        ppf
        "Contract has unexpected storage %a."
        Contract.pp
        contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_unexpected_storage c -> Some c | _ -> None)
    (fun c -> Contract_has_unexpected_storage c) ;
  register_error_kind
    `Permanent
    ~id:"invalidSignature"
    ~title:
      "The following signature did not match a public key in the given \
       multisig contract"
    ~description:
      "A signature was given for a multisig contract that matched none of the \
       public keys of the contract signers"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "Invalid signature %s." (Signature.to_b58check s))
    Data_encoding.(obj1 (req "invalid_signature" Signature.encoding))
    (function Invalid_signature s -> Some s | _ -> None)
    (fun s -> Invalid_signature s) ;
  register_error_kind
    `Permanent
    ~id:"notEnoughSignatures"
    ~title:"Not enough signatures were provided for this multisig action"
    ~description:
      "To run an action on a multisig contract, you should provide at least \
       as many signatures as indicated by the threshold stored in the \
       multisig contract."
    ~pp:(fun ppf (threshold, nsigs) ->
      Format.fprintf
        ppf
        "Not enough signatures: only %d signatures were given but the \
         threshold is currently %d"
        nsigs
        threshold)
    Data_encoding.(obj1 (req "threshold_nsigs" (tup2 int31 int31)))
    (function
      | Not_enough_signatures (threshold, nsigs) ->
          Some (threshold, nsigs)
      | _ ->
          None)
    (fun (threshold, nsigs) -> Not_enough_signatures (threshold, nsigs)) ;
  register_error_kind
    `Permanent
    ~id:"actionDeserialisation"
    ~title:"The expression is not a valid multisig action"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an expression that does not correspond to a known multisig action"
    ~pp:(fun ppf e ->
      Format.fprintf
        ppf
        "Action deserialisation error %a."
        Michelson_v1_printer.print_expr
        e)
    Data_encoding.(obj1 (req "expr" Script.expr_encoding))
    (function Action_deserialisation_error e -> Some e | _ -> None)
    (fun e -> Action_deserialisation_error e) ;
  register_error_kind
    `Permanent
    ~id:"bytesDeserialisation"
    ~title:"The byte sequence is not a valid multisig action"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an error"
    ~pp:(fun ppf b ->
      Format.fprintf ppf "Bytes deserialisation error %s." (Bytes.to_string b))
    Data_encoding.(obj1 (req "expr" bytes))
    (function Bytes_deserialisation_error b -> Some b | _ -> None)
    (fun b -> Bytes_deserialisation_error b) ;
  register_error_kind
    `Permanent
    ~id:"badDeserializedContract"
    ~title:"The byte sequence is not for the given multisig contract"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an action for another multisig contract"
    ~pp:(fun ppf (recieved, expected) ->
      Format.fprintf
        ppf
        "Bad deserialized contract, recieved %a expected %a."
        Contract.pp
        recieved
        Contract.pp
        expected)
    Data_encoding.(
      obj1 (req "recieved_expected" (tup2 Contract.encoding Contract.encoding)))
    (function Bad_deserialized_contract b -> Some b | _ -> None)
    (fun b -> Bad_deserialized_contract b) ;
  register_error_kind
    `Permanent
    ~id:"Bad deserialized counter"
    ~title:"Deserialized counter does not match the stored one"
    ~description:
      "The byte sequence references a multisig counter that does not match \
       the one currently stored in the given multisig contract"
    ~pp:(fun ppf (recieved, expected) ->
      Format.fprintf
        ppf
        "Bad deserialized counter, recieved %d expected %d."
        recieved
        expected)
    Data_encoding.(obj1 (req "recieved_expected" (tup2 int31 int31)))
    (function
      | Bad_deserialized_counter (c1, c2) ->
          Some (Z.to_int c1, Z.to_int c2)
      | _ ->
          None)
    (fun (c1, c2) -> Bad_deserialized_counter (Z.of_int c1, Z.of_int c2)) ;
  register_error_kind
    `Permanent
    ~id:"thresholdTooHigh"
    ~title:"Given threshold is too high"
    ~description:
      "The given threshold is higher than the number of keys, this would lead \
       to a frozen multisig contract"
    ~pp:(fun ppf (threshold, nkeys) ->
      Format.fprintf
        ppf
        "Threshold too high: %d expected at most %d."
        threshold
        nkeys)
    Data_encoding.(obj1 (req "recieved_expected" (tup2 int31 int31)))
    (function Threshold_too_high (c1, c2) -> Some (c1, c2) | _ -> None)
    (fun (c1, c2) -> Threshold_too_high (c1, c2)) ;
  register_error_kind
    `Permanent
    ~id:"nonPositiveThreshold"
    ~title:"Given threshold is not positive"
    ~description:"A multisig threshold should be a positive number"
    ~pp:(fun ppf threshold ->
      Format.fprintf ppf "Multisig threshold %d should be positive." threshold)
    Data_encoding.(obj1 (req "threshold" int31))
    (function Non_positive_threshold t -> Some t | _ -> None)
    (fun t -> Non_positive_threshold t)

(* The multisig contract script written by Arthur Breitman
     https://github.com/murbard/smart-contracts/blob/master/multisig/michelson/multisig.tz *)
(* Updated to take the chain id into account *)
let multisig_script_string =
  "parameter (pair\n\
  \             (pair :payload\n\
  \                (nat %counter) # counter, used to prevent replay attacks\n\
  \                (or :action    # payload to sign, represents the requested \
   action\n\
  \                   (pair :transfer    # transfer tokens\n\
  \                      (mutez %amount) # amount to transfer\n\
  \                      (contract %dest unit)) # destination to transfer to\n\
  \                   (or\n\
  \                      (option %delegate key_hash) # change the delegate to \
   this address\n\
  \                      (pair %change_keys          # change the keys \
   controlling the multisig\n\
  \                         (nat %threshold)         # new threshold\n\
  \                         (list %keys key)))))     # new list of keys\n\
  \             (list %sigs (option signature)));    # signatures\n\n\
   storage (pair (nat %stored_counter) (pair (nat %threshold) (list %keys \
   key))) ;\n\n\
   code\n\
  \  {\n\
  \    UNPAIR ; SWAP ; DUP ; DIP { SWAP } ;\n\
  \    DIP\n\
  \      {\n\
  \        UNPAIR ;\n\
  \        # pair the payload with the current contract address, to ensure \
   signatures\n\
  \        # can't be replayed accross different contracts if a key is reused.\n\
  \        DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ;\n\
  \        PACK ; # form the binary payload that we expect to be signed\n\
  \        DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP\n\
  \      } ;\n\n\
  \    # Check that the counters match\n\
  \    UNPAIR @stored_counter; DIP { SWAP };\n\
  \    ASSERT_CMPEQ ;\n\n\
  \    # Compute the number of valid signatures\n\
  \    DIP { SWAP } ; UNPAIR @threshold @keys;\n\
  \    DIP\n\
  \      {\n\
  \        # Running count of valid signatures\n\
  \        PUSH @valid nat 0; SWAP ;\n\
  \        ITER\n\
  \          {\n\
  \            DIP { SWAP } ; SWAP ;\n\
  \            IF_CONS\n\
  \              {\n\
  \                IF_SOME\n\
  \                  { SWAP ;\n\
  \                    DIP\n\
  \                      {\n\
  \                        SWAP ; DIIP { DUUP } ;\n\
  \                        # Checks signatures, fails if invalid\n\
  \                        { DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} \
   {FAILWITH} };\n\
  \                        PUSH nat 1 ; ADD @valid } }\n\
  \                  { SWAP ; DROP }\n\
  \              }\n\
  \              {\n\
  \                # There were fewer signatures in the list\n\
  \                # than keys. Not all signatures must be present, but\n\
  \                # they should be marked as absent using the option type.\n\
  \                FAIL\n\
  \              } ;\n\
  \            SWAP\n\
  \          }\n\
  \      } ;\n\
  \    # Assert that the threshold is less than or equal to the\n\
  \    # number of valid signatures.\n\
  \    ASSERT_CMPLE ;\n\
  \    DROP ; DROP ;\n\n\
  \    # Increment counter and place in storage\n\
  \    DIP { UNPAIR ; PUSH nat 1 ; ADD @new_counter ; PAIR} ;\n\n\
  \    # We have now handled the signature verification part,\n\
  \    # produce the operation requested by the signers.\n\
  \    NIL operation ; SWAP ;\n\
  \    IF_LEFT\n\
  \      { # Transfer tokens\n\
  \        UNPAIR ; UNIT ; TRANSFER_TOKENS ; CONS }\n\
  \      { IF_LEFT {\n\
  \                  # Change delegate\n\
  \                  SET_DELEGATE ; CONS }\n\
  \                {\n\
  \                  # Change set of signatures\n\
  \                  DIP { SWAP ; CAR } ; SWAP ; PAIR ; SWAP }} ;\n\
  \    PAIR }\n"

(* Client_proto_context.originate expects the contract script as a Script.expr *)
let multisig_script : Script.expr tzresult =
  Tezos_micheline.Micheline_parser.no_parsing_error
  @@ Michelson_v1_parser.parse_toplevel
       ?check:(Some true)
       multisig_script_string
  >>? fun parsing_result -> ok parsing_result.Michelson_v1_parser.expanded

let multisig_script_hash =
  multisig_script
  >>? fun mcontract ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn Script.expr_encoding mcontract
  in
  let hash = Script_expr_hash.hash_bytes [bytes] in
  ok hash

(* The previous multisig script is the only one that the client can
   originate but the client knows how to interact with several
   versions of the multisig contract. For each version, the description
   indicates which features are available and how to interact with
   the contract. *)

type multisig_contract_description = {
  hash : Script_expr_hash.t;
  (* The hash of the contract script *)
  requires_chain_id : bool;
  (* The signatures should contain the chain identifier *)
  generic : bool;
      (* False means that the contract uses a custom action type, true
                       means that the contract expects the action as a (lambda unit
                       (list operation)). *)
}

let script_hash_of_hex_string s =
  Script_expr_hash.of_bytes_exn @@ MBytes.of_hex @@ `Hex s

(* List of known multisig contracts hashes with their kinds *)
let known_multisig_contracts : multisig_contract_description list tzresult =
  multisig_script_hash
  >>? fun hash ->
  ok
    [ {hash; requires_chain_id = true; generic = false};
      {
        hash =
          script_hash_of_hex_string
            "36cf0b376c2d0e21f0ed42b2974fedaafdcafb9b7f8eb9254ef811b37cb46d94";
        requires_chain_id = true;
        generic = false;
      };
      {
        hash =
          script_hash_of_hex_string
            "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31";
        requires_chain_id = false;
        generic = false;
      } ]

let known_multisig_hashes =
  known_multisig_contracts
  >>? fun l -> ok (List.map (fun descr -> descr.hash) l)

let check_multisig_script script : multisig_contract_description tzresult Lwt.t
    =
  let bytes = Data_encoding.force_bytes script in
  let hash = Script_expr_hash.hash_bytes [bytes] in
  Lwt.return known_multisig_contracts
  >>=? fun l ->
  fold_left_s
    (fun descr_opt d ->
      return
      @@
      match descr_opt with
      | Some descr ->
          Some descr
      | None ->
          if Script_expr_hash.(d.hash = hash) then Some d else None)
    None
    l
  >>=? function
  | None ->
      fail
        (Not_a_supported_multisig_contract
           ( hash,
             match Data_encoding.force_decode script with
             | Some s ->
                 s
             | None ->
                 assert false ))
  | Some d ->
      return d

(* Returns [Ok ()] if [~contract] is an originated contract whose code
   is [multisig_script] *)
let check_multisig_contract (cctxt : #Protocol_client_context.full) ~chain
    ~block contract =
  Client_proto_context.get_script cctxt ~chain ~block contract
  >>=? fun script_opt ->
  ( match script_opt with
  | Some script ->
      return script.code
  | None ->
      fail (Contract_has_no_script contract) )
  >>=? check_multisig_script

let seq ~loc l = Tezos_micheline.Micheline.Seq (loc, l)

let pair ~loc a b =
  Tezos_micheline.Micheline.Prim (loc, Script.D_Pair, [a; b], [])

let none ~loc () = Tezos_micheline.Micheline.Prim (loc, Script.D_None, [], [])

let some ~loc a = Tezos_micheline.Micheline.Prim (loc, Script.D_Some, [a], [])

let left ~loc a = Tezos_micheline.Micheline.Prim (loc, Script.D_Left, [a], [])

let right ~loc b = Tezos_micheline.Micheline.Prim (loc, Script.D_Right, [b], [])

let int ~loc i = Tezos_micheline.Micheline.Int (loc, i)

let bytes ~loc s = Tezos_micheline.Micheline.Bytes (loc, s)

(** * Actions *)

type multisig_action =
  | Transfer of Tez.t * Contract.t
  | Change_delegate of public_key_hash option
  | Change_keys of Z.t * public_key list

let action_to_expr ~loc = function
  | Transfer (amount, destination) ->
      left
        ~loc
        (pair
           ~loc
           (int ~loc (Z.of_int64 (Tez.to_mutez amount)))
           (bytes
              ~loc
              (Data_encoding.Binary.to_bytes_exn Contract.encoding destination)))
  | Change_delegate delegate_opt ->
      right
        ~loc
        (left
           ~loc
           ( match delegate_opt with
           | None ->
               none ~loc ()
           | Some delegate ->
               some
                 ~loc
                 (bytes
                    ~loc
                    (Data_encoding.Binary.to_bytes_exn
                       Signature.Public_key_hash.encoding
                       delegate)) ))
  | Change_keys (threshold, keys) ->
      right
        ~loc
        (right
           ~loc
           (pair
              ~loc
              (int ~loc threshold)
              (seq
                 ~loc
                 (List.map
                    (fun k ->
                      bytes
                        ~loc
                        (Data_encoding.Binary.to_bytes_exn
                           Signature.Public_key.encoding
                           k))
                    keys))))

let action_of_expr e =
  let fail () =
    Error_monad.fail
      (Action_deserialisation_error
         (Tezos_micheline.Micheline.strip_locations e))
  in
  match e with
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Left,
        [ Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Pair,
              [ Tezos_micheline.Micheline.Int (_, i);
                Tezos_micheline.Micheline.Bytes (_, s) ],
              [] ) ],
        [] ) -> (
    match Tez.of_mutez (Z.to_int64 i) with
    | None ->
        fail ()
    | Some amount ->
        return
        @@ Transfer
             (amount, Data_encoding.Binary.of_bytes_exn Contract.encoding s) )
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [ Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Left,
              [Tezos_micheline.Micheline.Prim (_, Script.D_None, [], [])],
              [] ) ],
        [] ) ->
      return @@ Change_delegate None
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [ Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Left,
              [ Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Some,
                    [Tezos_micheline.Micheline.Bytes (_, s)],
                    [] ) ],
              [] ) ],
        [] ) ->
      return
      @@ Change_delegate
           (Some
              (Data_encoding.Binary.of_bytes_exn
                 Signature.Public_key_hash.encoding
                 s))
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [ Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Right,
              [ Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Pair,
                    [ Tezos_micheline.Micheline.Int (_, threshold);
                      Tezos_micheline.Micheline.Seq (_, key_bytes) ],
                    [] ) ],
              [] ) ],
        [] ) ->
      map_s
        (function
          | Tezos_micheline.Micheline.Bytes (_, s) ->
              return
              @@ Data_encoding.Binary.of_bytes_exn
                   Signature.Public_key.encoding
                   s
          | _ ->
              fail ())
        key_bytes
      >>=? fun keys -> return @@ Change_keys (threshold, keys)
  | _ ->
      fail ()

type key_list = Signature.Public_key.t list

(* The relevant information that we can get about a multisig smart contract *)
type multisig_contract_information = {
  counter : Z.t;
  threshold : Z.t;
  keys : key_list;
}

let multisig_get_information (cctxt : #Protocol_client_context.full) ~chain
    ~block contract =
  let open Client_proto_context in
  let open Tezos_micheline.Micheline in
  get_storage cctxt ~chain ~block contract
  >>=? fun storage_opt ->
  match storage_opt with
  | None ->
      fail (Contract_has_no_storage contract)
  | Some storage -> (
    match root storage with
    | Prim
        ( _,
          D_Pair,
          [ Int (_, counter);
            Prim (_, D_Pair, [Int (_, threshold); Seq (_, key_nodes)], _) ],
          _ ) ->
        map_s
          (function
            | String (_, key_str) ->
                return @@ Signature.Public_key.of_b58check_exn key_str
            | _ ->
                fail (Contract_has_unexpected_storage contract))
          key_nodes
        >>=? fun keys -> return {counter; threshold; keys}
    | _ ->
        fail (Contract_has_unexpected_storage contract) )

let multisig_create_storage ~counter ~threshold ~keys () :
    Script.expr tzresult Lwt.t =
  let loc = Tezos_micheline.Micheline_parser.location_zero in
  let open Tezos_micheline.Micheline in
  map_s
    (fun key ->
      let key_str = Signature.Public_key.to_b58check key in
      return (String (loc, key_str)))
    keys
  >>=? fun l ->
  return @@ strip_locations
  @@ pair ~loc (int ~loc counter) (pair ~loc (int ~loc threshold) (seq ~loc l))

(* Client_proto_context.originate expects the initial storage as a string *)
let multisig_storage_string ~counter ~threshold ~keys () =
  multisig_create_storage ~counter ~threshold ~keys ()
  >>=? fun expr ->
  return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr

let multisig_create_param ~counter ~action ~optional_signatures () :
    Script.expr tzresult Lwt.t =
  let loc = Tezos_micheline.Micheline_parser.location_zero in
  let open Tezos_micheline.Micheline in
  map_s
    (fun sig_opt ->
      match sig_opt with
      | None ->
          return @@ none ~loc ()
      | Some signature ->
          return @@ some ~loc (String (loc, Signature.to_b58check signature)))
    optional_signatures
  >>=? fun l ->
  return @@ strip_locations
  @@ pair
       ~loc
       (pair ~loc (int ~loc counter) (action_to_expr ~loc action))
       (Seq (loc, l))

let mutlisig_param_string ~counter ~action ~optional_signatures () =
  multisig_create_param ~counter ~action ~optional_signatures ()
  >>=? fun expr ->
  return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr

let get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract =
  let address =
    bytes ~loc (Data_encoding.Binary.to_bytes_exn Contract.encoding contract)
  in
  if descr.requires_chain_id then
    let chain_id_bytes =
      bytes ~loc (Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id)
    in
    pair ~loc chain_id_bytes address
  else address

let multisig_bytes ~counter ~action ~contract ~chain_id ~descr () =
  let loc = Tezos_micheline.Micheline_parser.location_zero in
  let triple =
    pair
      ~loc
      (get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract)
      (pair ~loc (int ~loc counter) (action_to_expr ~loc action))
  in
  let bytes =
    Data_encoding.Binary.to_bytes_exn Script.expr_encoding
    @@ Tezos_micheline.Micheline.strip_locations @@ triple
  in
  return @@ Bytes.concat (Bytes.of_string "") [Bytes.of_string "\005"; bytes]

let check_threshold ~threshold ~keys () =
  let nkeys = List.length keys in
  let threshold = Z.to_int threshold in
  if Compare.Int.(List.length keys < threshold) then
    fail (Threshold_too_high (threshold, nkeys))
  else if Compare.Int.(threshold <= 0) then
    fail (Non_positive_threshold threshold)
  else return_unit

let originate_multisig (cctxt : #Protocol_client_context.full) ~chain ~block
    ?confirmations ?dry_run ?branch ?fee ?gas_limit ?storage_limit ~delegate
    ~threshold ~keys ~balance ~source ~src_pk ~src_sk ~fee_parameter () =
  Lwt.return multisig_script
  >>=? fun code ->
  multisig_storage_string ~counter:Z.zero ~threshold ~keys ()
  >>=? fun initial_storage ->
  check_threshold ~threshold ~keys ()
  >>=? fun () ->
  Client_proto_context.originate_contract
    cctxt
    ~chain
    ~block
    ?branch
    ?confirmations
    ?dry_run
    ?fee
    ?gas_limit
    ?storage_limit
    ~delegate
    ~initial_storage
    ~balance
    ~source
    ~src_pk
    ~src_sk
    ~code
    ~fee_parameter
    ()

type multisig_prepared_action = {
  bytes : Bytes.t;
  threshold : Z.t;
  keys : public_key list;
  counter : Z.t;
}

let check_action ~action () =
  match action with
  | Change_keys (threshold, keys) ->
      check_threshold ~threshold ~keys ()
  | _ ->
      return_unit

let prepare_multisig_transaction (cctxt : #Protocol_client_context.full) ~chain
    ~block ~multisig_contract ~action () =
  let contract = multisig_contract in
  check_multisig_contract cctxt ~chain ~block contract
  >>=? fun descr ->
  check_action ~action ()
  >>=? fun () ->
  multisig_get_information cctxt ~chain ~block contract
  >>=? fun {counter; threshold; keys} ->
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  multisig_bytes ~counter ~action ~contract ~descr ~chain_id ()
  >>=? fun bytes -> return {bytes; threshold; keys; counter}

let check_multisig_signatures ~bytes ~threshold ~keys signatures =
  let key_array = Array.of_list keys in
  let nkeys = Array.length key_array in
  let opt_sigs_arr = Array.make nkeys None in
  let matching_key_found = ref false in
  let check_signature_against_key_number signature i key =
    _when (Signature.check key signature bytes) (fun () ->
        return
        @@
        ( matching_key_found := true ;
          opt_sigs_arr.(i) <- Some signature ))
  in
  iter_p
    (fun signature ->
      return @@ (matching_key_found := false)
      >>=? fun () ->
      iteri_p (check_signature_against_key_number signature) keys
      >>=? fun () ->
      fail_unless !matching_key_found (Invalid_signature signature))
    signatures
  >>=? fun () ->
  let opt_sigs = Array.to_list opt_sigs_arr in
  let signature_count =
    List.fold_left
      (fun n sig_opt -> match sig_opt with Some _ -> n + 1 | None -> n)
      0
      opt_sigs
  in
  let threshold_int = Z.to_int threshold in
  if signature_count >= threshold_int then return opt_sigs
  else fail (Not_enough_signatures (threshold_int, signature_count))

let call_multisig (cctxt : #Protocol_client_context.full) ~chain ~block
    ?confirmations ?dry_run ?branch ~source ~src_pk ~src_sk ~multisig_contract
    ~action ~signatures ~amount ?fee ?gas_limit ?storage_limit ?counter
    ~fee_parameter () =
  prepare_multisig_transaction
    cctxt
    ~chain
    ~block
    ~multisig_contract
    ~action
    ()
  >>=? fun {bytes; threshold; keys; counter = stored_counter} ->
  check_multisig_signatures ~bytes ~threshold ~keys signatures
  >>=? fun optional_signatures ->
  mutlisig_param_string ~counter:stored_counter ~action ~optional_signatures ()
  >>=? fun arg ->
  Client_proto_context.transfer
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?branch
    ~source
    ~src_pk
    ~src_sk
    ~destination:multisig_contract
    ~arg
    ~amount
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~fee_parameter
    ()

let action_of_bytes ~multisig_contract ~stored_counter ~descr ~chain_id bytes =
  if
    Compare.Int.(Bytes.length bytes >= 1)
    && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05)
  then
    let nbytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in
    match Data_encoding.Binary.of_bytes Script.expr_encoding nbytes with
    | None ->
        fail (Bytes_deserialisation_error bytes)
    | Some e -> (
      match Tezos_micheline.Micheline.root e with
      | Tezos_micheline.Micheline.Prim
          ( _,
            Script.D_Pair,
            [ Tezos_micheline.Micheline.Bytes (_, contract_bytes);
              Tezos_micheline.Micheline.Prim
                ( _,
                  Script.D_Pair,
                  [Tezos_micheline.Micheline.Int (_, counter); e],
                  [] ) ],
            [] )
        when not descr.requires_chain_id ->
          let contract =
            Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes
          in
          if counter = stored_counter then
            if multisig_contract = contract then action_of_expr e
            else fail (Bad_deserialized_contract (contract, multisig_contract))
          else fail (Bad_deserialized_counter (counter, stored_counter))
      | Tezos_micheline.Micheline.Prim
          ( _,
            Script.D_Pair,
            [ Tezos_micheline.Micheline.Prim
                ( _,
                  Script.D_Pair,
                  [ Tezos_micheline.Micheline.Bytes (_, chain_id_bytes);
                    Tezos_micheline.Micheline.Bytes (_, contract_bytes) ],
                  [] );
              Tezos_micheline.Micheline.Prim
                ( _,
                  Script.D_Pair,
                  [Tezos_micheline.Micheline.Int (_, counter); e],
                  [] ) ],
            [] )
        when descr.requires_chain_id ->
          let contract =
            Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes
          in
          let cid =
            Data_encoding.Binary.of_bytes_exn Chain_id.encoding chain_id_bytes
          in
          if counter = stored_counter then
            if multisig_contract = contract && chain_id = cid then
              action_of_expr e
            else fail (Bad_deserialized_contract (contract, multisig_contract))
          else fail (Bad_deserialized_counter (counter, stored_counter))
      | _ ->
          fail (Bytes_deserialisation_error bytes) )
  else fail (Bytes_deserialisation_error bytes)

let call_multisig_on_bytes (cctxt : #Protocol_client_context.full) ~chain
    ~block ?confirmations ?dry_run ?branch ~source ~src_pk ~src_sk
    ~multisig_contract ~bytes ~signatures ~amount ?fee ?gas_limit
    ?storage_limit ?counter ~fee_parameter () =
  multisig_get_information cctxt ~chain ~block multisig_contract
  >>=? fun info ->
  check_multisig_contract cctxt ~chain ~block multisig_contract
  >>=? fun descr ->
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  action_of_bytes
    ~multisig_contract
    ~stored_counter:info.counter
    ~chain_id
    ~descr
    bytes
  >>=? fun action ->
  call_multisig
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?branch
    ~source
    ~src_pk
    ~src_sk
    ~multisig_contract
    ~action
    ~signatures
    ~amount
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~fee_parameter
    ()
src/proto_alpha/lib_client/client_proto_multisig.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition multisig_script_string : string :=
  "parameter (pair
             (pair :payload
                (nat %counter) # counter, used to prevent replay attacks
                (or :action    # payload to sign, represents the requested action
                   (pair :transfer    # transfer tokens
                      (mutez %amount) # amount to transfer
                      (contract %dest unit)) # destination to transfer to
                   (or
                      (option %delegate key_hash) # change the delegate to this address
                      (pair %change_keys          # change the keys controlling the multisig
                         (nat %threshold)         # new threshold
                         (list %keys key)))))     # new list of keys
             (list %sigs (option signature)));    # signatures

storage (pair (nat %stored_counter) (pair (nat %threshold) (list %keys key))) ;

code
  {
    UNPAIR ; SWAP ; DUP ; DIP { SWAP } ;
    DIP
      {
        UNPAIR ;
        # pair the payload with the current contract address, to ensure signatures
        # can't be replayed accross different contracts if a key is reused.
        DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ;
        PACK ; # form the binary payload that we expect to be signed
        DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP
      } ;

    # Check that the counters match
    UNPAIR @stored_counter; DIP { SWAP };
    ASSERT_CMPEQ ;

    # Compute the number of valid signatures
    DIP { SWAP } ; UNPAIR @threshold @keys;
    DIP
      {
        # Running count of valid signatures
        PUSH @valid nat 0; SWAP ;
        ITER
          {
            DIP { SWAP } ; SWAP ;
            IF_CONS
              {
                IF_SOME
                  { SWAP ;
                    DIP
                      {
                        SWAP ; DIIP { DUUP } ;
                        # Checks signatures, fails if invalid
                        { DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} {FAILWITH} };
                        PUSH nat 1 ; ADD @valid } }
                  { SWAP ; DROP }
              }
              {
                # There were fewer signatures in the list
                # than keys. Not all signatures must be present, but
                # they should be marked as absent using the option type.
                FAIL
              } ;
            SWAP
          }
      } ;
    # Assert that the threshold is less than or equal to the
    # number of valid signatures.
    ASSERT_CMPLE ;
    DROP ; DROP ;

    # Increment counter and place in storage
    DIP { UNPAIR ; PUSH nat 1 ; ADD @new_counter ; PAIR} ;

    # We have now handled the signature verification part,
    # produce the operation requested by the signers.
    NIL operation ; SWAP ;
    IF_LEFT
      { # Transfer tokens
        UNPAIR ; UNIT ; TRANSFER_TOKENS ; CONS }
      { IF_LEFT {
                  # Change delegate
                  SET_DELEGATE ; CONS }
                {
                  # Change set of signatures
                  DIP { SWAP ; CAR } ; SWAP ; PAIR ; SWAP }} ;
    PAIR }
"
    % string.

Definition multisig_script
  : Tezos_base__TzPervasives.tzresult
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
  Tezos_base__TzPervasives.op_gt_gt_question
    (apply Tezos_micheline.Micheline_parser.no_parsing_error
      (Tezos_client_alpha.Michelson_v1_parser.parse_toplevel (Some true)
        multisig_script_string))
    (fun parsing_result =>
      Tezos_base__TzPervasives.ok (Michelson_v1_parser.expanded parsing_result)).

Definition multisig_script_hash
  : Tezos_base__TzPervasives.tzresult
    Tezos_protocol_alpha.Protocol.Script_expr_hash.t :=
  Tezos_base__TzPervasives.op_gt_gt_question multisig_script
    (fun mcontract =>
      let bytes :=
        Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr_encoding
          mcontract in
      let hash :=
        Tezos_protocol_alpha.Protocol.Script_expr_hash.hash_bytes None
          (cons string []) in
      Tezos_base__TzPervasives.ok hash).

Record multisig_contract_description := {
  hash : Tezos_protocol_alpha.Protocol.Script_expr_hash.t;
  requires_chain_id : bool;
  generic : bool }.

Definition script_hash_of_hex_string (s : string)
  : Tezos_protocol_alpha.Protocol.Script_expr_hash.t :=
  apply Tezos_protocol_alpha.Protocol.Script_expr_hash.of_bytes_exn
    (apply Tezos_base__TzPervasives.MBytes.of_hex variant).

Definition known_multisig_contracts
  : Tezos_base__TzPervasives.tzresult (list multisig_contract_description) :=
  Tezos_base__TzPervasives.op_gt_gt_question multisig_script_hash
    (fun hash =>
      Tezos_base__TzPervasives.ok
        (cons {| hash := hash; requires_chain_id := true; generic := false |}
          (cons
            {|
              hash :=
                script_hash_of_hex_string
                  "36cf0b376c2d0e21f0ed42b2974fedaafdcafb9b7f8eb9254ef811b37cb46d94"
                    % string; requires_chain_id := true; generic := false |}
            (cons
              {|
                hash :=
                  script_hash_of_hex_string
                    "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31"
                      % string; requires_chain_id := false; generic := false |}
              [])))).

Definition known_multisig_hashes
  : Tezos_base__TzPervasives.tzresult
    (list Tezos_protocol_alpha.Protocol.Script_expr_hash.t) :=
  Tezos_base__TzPervasives.op_gt_gt_question known_multisig_contracts
    (fun l =>
      Tezos_base__TzPervasives.ok
        (Tezos_base__TzPervasives.List.map (fun descr => hash descr) l)).

Definition check_multisig_script
  (script :
    Tezos_base__TzPervasives.Data_encoding.lazy_t
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_description) :=
  let bytes := Tezos_base__TzPervasives.Data_encoding.force_bytes script in
  let hash :=
    Tezos_protocol_alpha.Protocol.Script_expr_hash.hash_bytes None
      (cons string []) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Lwt._return known_multisig_contracts)
    (fun l =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_base__TzPervasives.fold_left_s
          (fun descr_opt =>
            fun d =>
              apply Tezos_base__TzPervasives._return
                match descr_opt with
                | Some descr => Some descr
                | None =>
                  if
                    Tezos_protocol_alpha.Protocol.Script_expr_hash.op_eq
                      (hash d) hash then
                    Some d
                  else
                    None
                end) None l)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            Tezos_base__TzPervasives.fail
              (Not_a_supported_multisig_contract
                (hash,
                  match
                    Tezos_base__TzPervasives.Data_encoding.force_decode script
                    with
                  | Some s => s
                  | None => false
                  end))
          | Some d => Tezos_base__TzPervasives._return d
          end)).

Definition check_multisig_contract {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_description) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_alpha.Client_proto_context.get_script cctxt chain block
      contract)
    (fun script_opt =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        match script_opt with
        | Some script => Tezos_base__TzPervasives._return (code script)
        | None =>
          Tezos_base__TzPervasives.fail (Contract_has_no_script contract)
        end check_multisig_script).

Definition seq {A B : Type}
  (loc : A) (l : list (Tezos_micheline.Micheline.node A B))
  : Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Seq loc l.

Definition pair {A : Type}
  (loc : A)
  (a :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  (b :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  Tezos_micheline.Micheline.Prim loc Script.D_Pair (cons a (cons b [])) [].

Definition none {A : Type} (loc : A) (function_parameter : unit)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  match function_parameter with
  | tt => Tezos_micheline.Micheline.Prim loc Script.D_None [] []
  end.

Definition some {A : Type}
  (loc : A)
  (a :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  Tezos_micheline.Micheline.Prim loc Script.D_Some (cons a []) [].

Definition left {A : Type}
  (loc : A)
  (a :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  Tezos_micheline.Micheline.Prim loc Script.D_Left (cons a []) [].

Definition right {A : Type}
  (loc : A)
  (b :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  Tezos_micheline.Micheline.Prim loc Script.D_Right (cons b []) [].

Definition int {A B : Type} (loc : A) (i : Z.t)
  : Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Int loc i.

Definition bytes {A B : Type} (loc : A) (s : Stdlib.Bytes.t)
  : Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Bytes loc s.

Inductive multisig_action : Type :=
| Transfer : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t -> multisig_action
| Change_delegate :
  (option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
  multisig_action
| Change_keys : Z.t ->
  (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key) ->
  multisig_action.

Definition action_to_expr {A : Type}
  (loc : A) (function_parameter : multisig_action)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  match function_parameter with
  | Transfer amount destination =>
    left loc
      (pair loc
        (Z loc
          (Z.of_int64
            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez amount)))
        (string loc
          (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.encoding
            destination)))
  | Change_delegate delegate_opt =>
    right loc
      (left loc
        match delegate_opt with
        | None => none loc tt
        | Some delegate =>
          some loc
            (string loc
              (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                Tezos_base__TzPervasives.Signature.Public_key_hash.encoding
                delegate))
        end)
  | Change_keys threshold keys =>
    right loc
      (right loc
        (pair loc (Z loc threshold)
          (seq loc
            (Tezos_base__TzPervasives.List.map
              (fun k =>
                string loc
                  (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                    Tezos_base__TzPervasives.Signature.Public_key.encoding k))
              keys))))
  end.

Definition action_of_expr {A : Type}
  (e :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult multisig_action) :=
  let fail {B : Type} (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult B) :=
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.Error_monad.fail
        (Action_deserialisation_error
          (Tezos_micheline.Micheline.strip_locations e))
    end in
  match e with
  |
    Tezos_micheline.Micheline.Prim _ Script.D_Left
      (cons
        (Tezos_micheline.Micheline.Prim _ Script.D_Pair
          (cons (Tezos_micheline.Micheline.Int _ i)
            (cons (Tezos_micheline.Micheline.Bytes _ s) [])) []) []) [] =>
    match
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez (Z.to_int64 i)
      with
    | None => fail tt
    | Some amount =>
      apply Tezos_base__TzPervasives._return
        (Transfer amount
          (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.encoding s))
    end
  |
    Tezos_micheline.Micheline.Prim _ Script.D_Right
      (cons
        (Tezos_micheline.Micheline.Prim _ Script.D_Left
          (cons (Tezos_micheline.Micheline.Prim _ Script.D_None [] []) []) [])
        []) [] => apply Tezos_base__TzPervasives._return (Change_delegate None)
  |
    Tezos_micheline.Micheline.Prim _ Script.D_Right
      (cons
        (Tezos_micheline.Micheline.Prim _ Script.D_Left
          (cons
            (Tezos_micheline.Micheline.Prim _ Script.D_Some
              (cons (Tezos_micheline.Micheline.Bytes _ s) []) []) []) []) []) []
    =>
    apply Tezos_base__TzPervasives._return
      (Change_delegate
        (Some
          (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
            Tezos_base__TzPervasives.Signature.Public_key_hash.encoding s)))
  |
    Tezos_micheline.Micheline.Prim _ Script.D_Right
      (cons
        (Tezos_micheline.Micheline.Prim _ Script.D_Right
          (cons
            (Tezos_micheline.Micheline.Prim _ Script.D_Pair
              (cons (Tezos_micheline.Micheline.Int _ threshold)
                (cons (Tezos_micheline.Micheline.Seq _ key_bytes) [])) []) [])
          []) []) [] =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.map_s
        (fun function_parameter =>
          match function_parameter with
          | Tezos_micheline.Micheline.Bytes _ s =>
            apply Tezos_base__TzPervasives._return
              (Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes_exn
                Tezos_base__TzPervasives.Signature.Public_key.encoding s)
          | _ => fail tt
          end) key_bytes)
      (fun keys =>
        apply Tezos_base__TzPervasives._return (Change_keys threshold keys))
  | _ => fail tt
  end.

Definition key_list := list Tezos_base__TzPervasives.Signature.Public_key.t.

Record multisig_contract_information := {
  counter : Z.t;
  threshold : Z.t;
  keys : key_list }.

Definition multisig_get_information {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_information) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_alpha.Client_proto_context.get_storage cctxt chain block
      contract)
    (fun storage_opt =>
      match storage_opt with
      | None => Tezos_base__TzPervasives.fail (Contract_has_no_storage contract)
      | Some storage =>
        match Tezos_micheline.Micheline.root storage with
        |
          Prim _ D_Pair
            (cons (Int _ counter)
              (cons
                (Prim _ D_Pair
                  (cons (Int _ threshold) (cons (Seq _ key_nodes) [])) _) [])) _
          =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_base__TzPervasives.map_s
              (fun function_parameter =>
                match function_parameter with
                | String _ key_str =>
                  apply Tezos_base__TzPervasives._return
                    (Tezos_base__TzPervasives.Signature.Public_key.of_b58check_exn
                      key_str)
                | _ =>
                  Tezos_base__TzPervasives.fail
                    (Contract_has_unexpected_storage contract)
                end) key_nodes)
            (fun keys =>
              Tezos_base__TzPervasives._return
                {| counter := counter; threshold := threshold; keys := keys |})
        | _ =>
          Tezos_base__TzPervasives.fail
            (Contract_has_unexpected_storage contract)
        end
      end).

Definition multisig_create_storage
  (counter : Z.t) (threshold : Z.t)
  (keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr) :=
  match function_parameter with
  | tt =>
    let loc := Tezos_micheline.Micheline_parser.location_zero in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.map_s
        (fun key =>
          let key_str :=
            Tezos_base__TzPervasives.Signature.Public_key.to_b58check key in
          Tezos_base__TzPervasives._return (String loc key_str)) keys)
      (fun l =>
        apply Tezos_base__TzPervasives._return
          (apply Tezos_micheline.Micheline.strip_locations
            (pair loc (Z loc counter) (pair loc (Z loc threshold) (seq loc l)))))
  end.

Definition multisig_storage_string
  (counter : Z.t) (threshold : Z.t)
  (keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
  (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (multisig_create_storage counter threshold keys tt)
      (fun expr =>
        apply Tezos_base__TzPervasives._return
          (Stdlib.Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Tezos_client_alpha.Michelson_v1_printer.print_expr expr))
  end.

Definition multisig_create_param
  (counter : Z.t) (action : multisig_action)
  (optional_signatures : list (option Tezos_base__TzPervasives.Signature.t))
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr) :=
  match function_parameter with
  | tt =>
    let loc := Tezos_micheline.Micheline_parser.location_zero in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.map_s
        (fun sig_opt =>
          match sig_opt with
          | None => apply Tezos_base__TzPervasives._return (none loc tt)
          | Some signature =>
            apply Tezos_base__TzPervasives._return
              (some loc
                (String loc
                  (Tezos_base__TzPervasives.Signature.to_b58check signature)))
          end) optional_signatures)
      (fun l =>
        apply Tezos_base__TzPervasives._return
          (apply Tezos_micheline.Micheline.strip_locations
            (pair loc (pair loc (Z loc counter) (action_to_expr loc action))
              (Seq loc l))))
  end.

Definition mutlisig_param_string
  (counter : Z.t) (action : multisig_action)
  (optional_signatures : list (option Tezos_base__TzPervasives.Signature.t))
  (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (multisig_create_param counter action optional_signatures tt)
      (fun expr =>
        apply Tezos_base__TzPervasives._return
          (Stdlib.Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Tezos_client_alpha.Michelson_v1_printer.print_expr expr))
  end.

Definition get_contract_address_maybe_chain_id {A : Type}
  (descr : multisig_contract_description) (loc : A)
  (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  let address :=
    string loc
      (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.encoding contract)
    in
  if requires_chain_id descr then
    let chain_id_bytes :=
      string loc
        (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_base__TzPervasives.Chain_id.encoding chain_id) in
    pair loc chain_id_bytes address
  else
    address.

Definition multisig_bytes
  (counter : Z.t) (action : multisig_action)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (descr : multisig_contract_description) (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
  match function_parameter with
  | tt =>
    let loc := Tezos_micheline.Micheline_parser.location_zero in
    let triple :=
      pair loc (get_contract_address_maybe_chain_id descr loc chain_id contract)
        (pair loc (Z loc counter) (action_to_expr loc action)) in
    let bytes :=
      apply
        (Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr_encoding)
        (apply Tezos_micheline.Micheline.strip_locations triple) in
    apply Tezos_base__TzPervasives._return
      (String.concat (Stdlib.Bytes.of_string "" % string)
        (cons (Stdlib.Bytes.of_string "" % string) (cons string [])))
  end.

Definition check_threshold {A : Type}
  (threshold : Z.t) (keys : list A) (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | tt =>
    let nkeys := Tezos_base__TzPervasives.List.length keys in
    let threshold := Z.to_int threshold in
    if
      Tezos_base__TzPervasives.Compare.Int.op_lt
        (Tezos_base__TzPervasives.List.length keys) threshold then
      Tezos_base__TzPervasives.fail (Threshold_too_high threshold nkeys)
    else
      if Tezos_base__TzPervasives.Compare.Int.op_lt_eq threshold 0 then
        Tezos_base__TzPervasives.fail (Non_positive_threshold threshold)
      else
        Tezos_base__TzPervasives.return_unit
  end.

Definition originate_multisig {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (branch : option Z)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (gas_limit : option Z.t) (storage_limit : option Z.t)
  (delegate : option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (threshold : Z.t)
  (keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
  (balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination)) *
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question (Lwt._return multisig_script)
      (fun code =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (multisig_storage_string Z.zero threshold keys tt)
          (fun initial_storage =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (check_threshold threshold keys tt)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_client_alpha.Client_proto_context.originate_contract
                    cctxt chain block confirmations dry_run None branch fee
                    gas_limit storage_limit delegate initial_storage balance
                    source src_pk src_sk code fee_parameter tt
                end)))
  end.

Record multisig_prepared_action := {
  bytes : Stdlib.Bytes.t;
  threshold : Z.t;
  keys : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key;
  counter : Z.t }.

Definition check_action (action : multisig_action) (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | tt =>
    match action with
    | Change_keys threshold keys => check_threshold threshold keys tt
    | _ => Tezos_base__TzPervasives.return_unit
    end
  end.

Definition prepare_multisig_transaction {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (action : multisig_action) (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_prepared_action) :=
  match function_parameter with
  | tt =>
    let contract := multisig_contract in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (check_multisig_contract cctxt chain block contract)
      (fun descr =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question (check_action action tt)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (multisig_get_information cctxt chain block contract)
                (fun function_parameter =>
                  match function_parameter with
                  | {|
                    counter := counter;
                      threshold := threshold;
                      keys := keys
                      |} =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell_services.Chain_services.chain_id cctxt
                        (Some chain) tt)
                      (fun chain_id =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (multisig_bytes counter action contract chain_id descr
                            tt)
                          (fun bytes =>
                            Tezos_base__TzPervasives._return
                              {| string := string; threshold := threshold;
                                keys := keys; counter := counter |}))
                  end)
            end))
  end.

Definition check_multisig_signatures
  (bytes : Stdlib.Bytes.t) (threshold : Z.t)
  (keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
  (signatures : list Tezos_base__TzPervasives.Signature.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (option Tezos_base__TzPervasives.Signature.t))) :=
  let key_array := Stdlib.Array.of_list keys in
  let nkeys := Stdlib.Array.length key_array in
  let opt_sigs_arr := Stdlib.Array.make nkeys None in
  let matching_key_found := Stdlib.ref false in
  let check_signature_against_key_number
    (signature : Tezos_base__TzPervasives.Signature.t) (i : Z) (key :
    Tezos_base__TzPervasives.Signature.Public_key.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives._when
      (Tezos_base__TzPervasives.Signature.check None key signature string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          apply Tezos_base__TzPervasives._return
            (Stdlib.op_colon_eq matching_key_found true;
            Stdlib.Array.set opt_sigs_arr i (Some signature))
        end) in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.iter_p
      (fun signature =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (apply Tezos_base__TzPervasives._return
            (Stdlib.op_colon_eq matching_key_found false))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives.iteri_p
                  (check_signature_against_key_number signature) keys)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.fail_unless
                      (Stdlib.op_exclamation matching_key_found)
                      (Invalid_signature signature)
                  end)
            end)) signatures)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let opt_sigs := Stdlib.Array.to_list opt_sigs_arr in
        let signature_count :=
          Tezos_base__TzPervasives.List.fold_left
            (fun n =>
              fun sig_opt =>
                match sig_opt with
                | Some _ => Z.add n 1
                | None => n
                end) 0 opt_sigs in
        let threshold_int := Z.to_int threshold in
        if OCaml.Stdlib.ge signature_count threshold_int then
          Tezos_base__TzPervasives._return opt_sigs
        else
          Tezos_base__TzPervasives.fail
            (Not_enough_signatures threshold_int signature_count)
      end).

Definition call_multisig {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (branch : option Z)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (action : multisig_action)
  (signatures : list Tezos_base__TzPervasives.Signature.t)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (gas_limit : option Z.t) (storage_limit : option Z.t) (counter : option Z.t)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)) *
        (list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (prepare_multisig_transaction cctxt chain block multisig_contract action
        tt)
      (fun function_parameter =>
        match function_parameter with
        | {|
          string := bytes;
            threshold := threshold;
            keys := keys;
            counter := stored_counter
            |} =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (check_multisig_signatures string threshold keys signatures)
            (fun optional_signatures =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (mutlisig_param_string stored_counter action optional_signatures
                  tt)
                (fun arg =>
                  Tezos_client_alpha.Client_proto_context.transfer cctxt chain
                    block confirmations dry_run None branch source src_pk src_sk
                    multisig_contract None (Some arg) amount fee gas_limit
                    storage_limit counter fee_parameter tt))
        end)
  end.

Definition action_of_bytes
  (multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (stored_counter : Tezos_protocol_alpha.Protocol.Alpha_context.counter)
  (descr : multisig_contract_description)
  (chain_id : Tezos_base__TzPervasives.Chain_id.t) (bytes : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_action) :=
  if
    andb
      (Tezos_base__TzPervasives.Compare.Int.op_gt_eq (String.length string) 1)
      (Tezos_base__TzPervasives.Compare.Int.op_eq
        (Tezos_base__TzPervasives.TzEndian.get_uint8 string 0) 5) then
    let nbytes := String.sub string 1 (Z.sub (String.length string) 1) in
    match
      Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
        Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr_encoding nbytes
      with
    | None => Tezos_base__TzPervasives.fail (Bytes_deserialisation_error string)
    | Some e =>
      match Tezos_micheline.Micheline.root e with
      | _ => Tezos_base__TzPervasives.fail (Bytes_deserialisation_error string)
      end
    end
  else
    Tezos_base__TzPervasives.fail (Bytes_deserialisation_error string).

Definition call_multisig_on_bytes {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (branch : option Z)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (bytes : Stdlib.Bytes.t)
  (signatures : list Tezos_base__TzPervasives.Signature.t)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (gas_limit : option Z.t) (storage_limit : option Z.t) (counter : option Z.t)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)) *
        (list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (multisig_get_information cctxt chain block multisig_contract)
      (fun info =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (check_multisig_contract cctxt chain block multisig_contract)
          (fun descr =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_shell_services.Chain_services.chain_id cctxt (Some chain)
                tt)
              (fun chain_id =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (action_of_bytes multisig_contract (counter info) descr
                    chain_id string)
                  (fun action =>
                    call_multisig cctxt chain block confirmations dry_run branch
                      source src_pk src_sk multisig_contract action signatures
                      amount fee gas_limit storage_limit counter fee_parameter
                      tt))))
  end.
src/proto_alpha/lib_client/client_proto_multisig.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Protocol_client_context

type multisig_action =
  | Transfer of Tez.t * Contract.t
  | Change_delegate of public_key_hash option
  | Change_keys of Z.t * public_key list

type multisig_prepared_action = {
  bytes : Bytes.t;
  threshold : Z.t;
  keys : public_key list;
  counter : Z.t;
}

val known_multisig_hashes : Script_expr_hash.t list tzresult

val originate_multisig :
  full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?branch:int ->
  ?fee:Tez.t ->
  ?gas_limit:Z.t ->
  ?storage_limit:Z.t ->
  delegate:public_key_hash option ->
  threshold:Z.t ->
  keys:public_key list ->
  balance:Tez.t ->
  source:public_key_hash ->
  src_pk:public_key ->
  src_sk:Client_keys.sk_uri ->
  fee_parameter:Injection.fee_parameter ->
  unit ->
  (Kind.origination Kind.manager Injection.result * Contract.t) tzresult Lwt.t

val prepare_multisig_transaction :
  full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  multisig_contract:Contract.t ->
  action:multisig_action ->
  unit ->
  multisig_prepared_action tzresult Lwt.t

val call_multisig :
  full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?branch:int ->
  source:public_key_hash ->
  src_pk:public_key ->
  src_sk:Client_keys.sk_uri ->
  multisig_contract:Contract.t ->
  action:multisig_action ->
  signatures:Signature.t list ->
  amount:Tez.t ->
  ?fee:Tez.t ->
  ?gas_limit:Z.t ->
  ?storage_limit:Z.t ->
  ?counter:Z.t ->
  fee_parameter:Injection.fee_parameter ->
  unit ->
  (Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult
  Lwt.t

val call_multisig_on_bytes :
  full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?branch:int ->
  source:public_key_hash ->
  src_pk:public_key ->
  src_sk:Client_keys.sk_uri ->
  multisig_contract:Contract.t ->
  bytes:Bytes.t ->
  signatures:Signature.t list ->
  amount:Tez.t ->
  ?fee:Tez.t ->
  ?gas_limit:Z.t ->
  ?storage_limit:Z.t ->
  ?counter:Z.t ->
  fee_parameter:Injection.fee_parameter ->
  unit ->
  (Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult
  Lwt.t
src/proto_alpha/lib_client/client_proto_multisig.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive multisig_action : Type :=
| Transfer : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t -> multisig_action
| Change_delegate :
  (option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
  multisig_action
| Change_keys : Z.t ->
  (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key) ->
  multisig_action.

Record multisig_prepared_action := {
  bytes : Stdlib.Bytes.t;
  threshold : Z.t;
  keys : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key;
  counter : Z.t }.

Parameter known_multisig_hashes :
Tezos_base__TzPervasives.tzresult
  (list Tezos_protocol_alpha.Protocol.Script_expr_hash.t).

Parameter originate_multisig :
Tezos_client_alpha.Protocol_client_context.full ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option Z) ->
            (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
              (option Z.t) ->
                (option Z.t) ->
                  (option
                    Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
                    ->
                    Z.t ->
                      (list
                        Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
                        ->
                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
                          Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash
                            ->
                            Tezos_protocol_alpha.Protocol.Alpha_context.public_key
                              ->
                              Tezos_client_base.Client_keys.sk_uri ->
                                Tezos_client_alpha.Injection.fee_parameter ->
                                  unit ->
                                    Lwt.t
                                      (Tezos_base__TzPervasives.tzresult
                                        ((Tezos_client_alpha.Injection.result
                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination))
                                          *
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)).

Parameter prepare_multisig_transaction :
Tezos_client_alpha.Protocol_client_context.full ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        multisig_action ->
          unit ->
            Lwt.t (Tezos_base__TzPervasives.tzresult multisig_prepared_action).

Parameter call_multisig :
Tezos_client_alpha.Protocol_client_context.full ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option Z) ->
            Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
              Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
                Tezos_client_base.Client_keys.sk_uri ->
                  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
                    multisig_action ->
                      (list Tezos_base__TzPervasives.Signature.t) ->
                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
                          (option
                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
                            ->
                            (option Z.t) ->
                              (option Z.t) ->
                                (option Z.t) ->
                                  Tezos_client_alpha.Injection.fee_parameter ->
                                    unit ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult
                                          ((Tezos_client_alpha.Injection.result
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
                                            *
                                            (list
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))).

Parameter call_multisig_on_bytes :
Tezos_client_alpha.Protocol_client_context.full ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option Z) ->
            Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
              Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
                Tezos_client_base.Client_keys.sk_uri ->
                  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
                    Stdlib.Bytes.t ->
                      (list Tezos_base__TzPervasives.Signature.t) ->
                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
                          (option
                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
                            ->
                            (option Z.t) ->
                              (option Z.t) ->
                                (option Z.t) ->
                                  Tezos_client_alpha.Injection.fee_parameter ->
                                    unit ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult
                                          ((Tezos_client_alpha.Injection.result
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
                                            *
                                            (list
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))).
src/proto_alpha/lib_client/client_proto_programs.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline
open Michelson_v1_printer

module Program = Client_aliases.Alias (struct
  type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result

  let encoding =
    Data_encoding.conv
      (fun ({Michelson_v1_parser.source; _}, _) -> source)
      (fun source -> Michelson_v1_parser.parse_toplevel source)
      Data_encoding.string

  let of_source source = return (Michelson_v1_parser.parse_toplevel source)

  let to_source ({Michelson_v1_parser.source; _}, _) = return source

  let name = "script"
end)

let print_errors (cctxt : #Client_context.printer) errs ~show_source ~parsed =
  cctxt#warning
    "%a"
    (Michelson_v1_error_reporter.report_errors
       ~details:false
       ~show_source
       ~parsed)
    errs
  >>= fun () -> cctxt#error "error running script" >>= fun () -> return_unit

let print_run_result (cctxt : #Client_context.printer) ~show_source ~parsed =
  function
  | Ok (storage, operations, maybe_diff) ->
      cctxt#message
        "@[<v 0>@[<v 2>storage@,\
         %a@]@,\
         @[<v 2>emitted operations@,\
         %a@]@,\
         @[<v 2>big_map diff@,\
         %a@]@]@."
        print_expr
        storage
        (Format.pp_print_list Operation_result.pp_internal_operation)
        operations
        (fun ppf -> function None -> () | Some diff ->
              print_big_map_diff ppf diff)
        maybe_diff
      >>= fun () -> return_unit
  | Error errs ->
      print_errors cctxt errs ~show_source ~parsed

let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed =
  function
  | Ok (storage, operations, trace, maybe_big_map_diff) ->
      cctxt#message
        "@[<v 0>@[<v 2>storage@,\
         %a@]@,\
         @[<v 2>emitted operations@,\
         %a@]@,\
         @[<v 2>big_map diff@,\
         %a@]@,\
         @[<v 2>trace@,\
         %a@]@]@."
        print_expr
        storage
        (Format.pp_print_list Operation_result.pp_internal_operation)
        operations
        (fun ppf -> function None -> () | Some diff ->
              print_big_map_diff ppf diff)
        maybe_big_map_diff
        print_execution_trace
        trace
      >>= fun () -> return_unit
  | Error errs ->
      print_errors cctxt errs ~show_source ~parsed

let run (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents)
    ~(program : Michelson_v1_parser.parsed)
    ~(storage : Michelson_v1_parser.parsed)
    ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas
    ?(entrypoint = "default") () =
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Alpha_services.Helpers.Scripts.run_code
    cctxt
    (chain, block)
    program.expanded
    ( storage.expanded,
      input.expanded,
      amount,
      chain_id,
      source,
      payer,
      gas,
      entrypoint )

let trace (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents)
    ~(program : Michelson_v1_parser.parsed)
    ~(storage : Michelson_v1_parser.parsed)
    ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas
    ?(entrypoint = "default") () =
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Alpha_services.Helpers.Scripts.trace_code
    cctxt
    (chain, block)
    program.expanded
    ( storage.expanded,
      input.expanded,
      amount,
      chain_id,
      source,
      payer,
      gas,
      entrypoint )

let typecheck_data cctxt ~(chain : Chain_services.chain) ~block ?gas
    ~(data : Michelson_v1_parser.parsed) ~(ty : Michelson_v1_parser.parsed) ()
    =
  Alpha_services.Helpers.Scripts.typecheck_data
    cctxt
    (chain, block)
    (data.expanded, ty.expanded, gas)

let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas
    (program : Michelson_v1_parser.parsed) =
  Alpha_services.Helpers.Scripts.typecheck_code
    cctxt
    (chain, block)
    (program.expanded, gas)

let print_typecheck_result ~emacs ~show_types ~print_source_on_error program
    res (cctxt : #Client_context.printer) =
  if emacs then
    let (type_map, errs, _gas) =
      match res with
      | Ok (type_map, gas) ->
          (type_map, [], Some gas)
      | Error
          ( Environment.Ecoproto_error
              (Script_tc_errors.Ill_typed_contract (_, type_map))
            :: _ as errs ) ->
          (type_map, errs, None)
      | Error errs ->
          ([], errs, None)
    in
    cctxt#message
      "(@[<v 0>(types . %a)@ (errors . %a)@])"
      Michelson_v1_emacs.print_type_map
      (program, type_map)
      Michelson_v1_emacs.report_errors
      (program, errs)
    >>= fun () -> return_unit
  else
    match res with
    | Ok (type_map, gas) ->
        let program = Michelson_v1_printer.inject_types type_map program in
        cctxt#message "@[<v 0>Well typed@,Gas remaining: %a@]" Gas.pp gas
        >>= fun () ->
        if show_types then
          cctxt#message "%a" Micheline_printer.print_expr program
          >>= fun () -> return_unit
        else return_unit
    | Error errs ->
        cctxt#warning
          "%a"
          (Michelson_v1_error_reporter.report_errors
             ~details:show_types
             ~show_source:print_source_on_error
             ~parsed:program)
          errs
        >>= fun () -> cctxt#error "ill-typed script"

let entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) ~entrypoint =
  Michelson_v1_entrypoints.script_entrypoint_type
    cctxt
    ~chain
    ~block
    program.expanded
    ~entrypoint

let print_entrypoint_type (cctxt : #Client_context.printer) ~emacs ?script_name
    ~show_source ~parsed ~entrypoint ty =
  Michelson_v1_entrypoints.print_entrypoint_type
    cctxt
    ~entrypoint
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty

let list_entrypoints cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) =
  Michelson_v1_entrypoints.list_entrypoints
    cctxt
    ~chain
    ~block
    program.expanded

let print_entrypoints_list (cctxt : #Client_context.printer) ~emacs
    ?script_name ~show_source ~parsed ty =
  Michelson_v1_entrypoints.print_entrypoints_list
    cctxt
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty

let list_unreachables cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) =
  Michelson_v1_entrypoints.list_unreachables
    cctxt
    ~chain
    ~block
    program.expanded

let print_unreachables (cctxt : #Client_context.printer) ~emacs ?script_name
    ~show_source ~parsed ty =
  Michelson_v1_entrypoints.print_unreachables
    cctxt
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty
src/proto_alpha/lib_client/client_proto_programs.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_micheline.

Import Tezos_client_alpha.Michelson_v1_printer.

Definition print_errors {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (errs : list Tezos_base__TzPervasives.Error_monad.error) (show_source : bool)
  (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string)
      (Tezos_client_alpha.Michelson_v1_error_reporter.report_errors false
        show_source (Some parsed)) errs)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "error running script" % string
                CamlinternalFormatBasics.End_of_format)
              "error running script" % string))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      end).

Definition print_run_result {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (show_source : bool)
  (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (function_parameter :
    sum
      (Tezos_protocol_alpha.Protocol.Script_repr.expr *
        (list
          Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
        *
        (option
          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff))
      (list Tezos_base__TzPervasives.Error_monad.error))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | inl (storage, operations, maybe_diff) =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal "storage" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "emitted operations" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<v 2>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<v 2>" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "big_map diff" % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Flush_newline
                                                  CamlinternalFormatBasics.End_of_format))))))))))))))))))))
          "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>emitted operations@,%a@]@,@[<v 2>big_map diff@,%a@]@]@."
            % string) Tezos_client_alpha.Michelson_v1_printer.print_expr storage
        (Stdlib.Format.pp_print_list None
          Tezos_client_alpha.Operation_result.pp_internal_operation) operations
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | None => tt
            | Some diff =>
              Tezos_client_alpha.Michelson_v1_printer.print_big_map_diff ppf
                diff
            end) maybe_diff)
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives.return_unit
        end)
  | inr errs => print_errors cctxt errs show_source parsed
  end.

Definition print_trace_result {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (show_source : bool)
  (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (function_parameter :
    sum
      (Tezos_protocol_alpha.Protocol.Script_repr.expr *
        (list
          Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
        *
        (list
          (Tezos_protocol_alpha.Protocol.Alpha_context.Script.location *
            Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t *
            (list
              (Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr *
                (option string))))) *
        (option
          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff))
      (list Tezos_base__TzPervasives.Error_monad.error))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | inl (storage, operations, trace, maybe_big_map_diff) =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal "storage" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "emitted operations" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<v 2>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<v 2>" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "big_map diff" % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Formatting_lit
                                                (CamlinternalFormatBasics.Break
                                                  "@," % string 0 0)
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "<v 2>" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "<v 2>" % string))
                                                  (CamlinternalFormatBasics.String_literal
                                                    "trace" % string
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@," % string 0 0)
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Close_box
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_box
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Flush_newline
                                                              CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))
          "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>emitted operations@,%a@]@,@[<v 2>big_map diff@,%a@]@,@[<v 2>trace@,%a@]@]@."
            % string) Tezos_client_alpha.Michelson_v1_printer.print_expr storage
        (Stdlib.Format.pp_print_list None
          Tezos_client_alpha.Operation_result.pp_internal_operation) operations
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | None => tt
            | Some diff =>
              Tezos_client_alpha.Michelson_v1_printer.print_big_map_diff ppf
                diff
            end) maybe_big_map_diff
        Tezos_client_alpha.Michelson_v1_printer.print_execution_trace trace)
      (fun function_parameter =>
        match function_parameter with
        | tt => Tezos_base__TzPervasives.return_unit
        end)
  | inr errs => print_errors cctxt errs show_source parsed
  end.

Definition run {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (op_star_o_p_t_star :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_client_alpha.Michelson_v1_parser.parsed ->
    Tezos_client_alpha.Michelson_v1_parser.parsed ->
      Tezos_client_alpha.Michelson_v1_parser.parsed ->
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
            (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
              (option string) ->
                unit ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                        (list
                          Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
                        *
                        (option
                          Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
  let amount :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_protocol_alpha.Protocol.Alpha_context.Tez.fifty_cents
    end in
  fun program =>
    fun storage =>
      fun input =>
        fun source =>
          fun payer =>
            fun gas =>
              fun op_star_o_p_t_star =>
                let entrypoint :=
                  match op_star_o_p_t_star with
                  | Some op_star_s_t_h_star => op_star_s_t_h_star
                  | None => "default" % string
                  end in
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell_services.Chain_services.chain_id cctxt
                        (Some chain) tt)
                      (fun chain_id =>
                        Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.run_code
                          cctxt (chain, block) (expanded program)
                          ((expanded storage), (expanded input), amount,
                            chain_id, source, payer, gas, entrypoint))
                  end.

Definition trace {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (op_star_o_p_t_star :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_client_alpha.Michelson_v1_parser.parsed ->
    Tezos_client_alpha.Michelson_v1_parser.parsed ->
      Tezos_client_alpha.Michelson_v1_parser.parsed ->
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
            (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
              (option string) ->
                unit ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                        (list
                          Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
                        *
                        Tezos_raw_protocol_alpha.Script_interpreter.execution_trace
                        *
                        (option
                          Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
  let amount :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_protocol_alpha.Protocol.Alpha_context.Tez.fifty_cents
    end in
  fun program =>
    fun storage =>
      fun input =>
        fun source =>
          fun payer =>
            fun gas =>
              fun op_star_o_p_t_star =>
                let entrypoint :=
                  match op_star_o_p_t_star with
                  | Some op_star_s_t_h_star => op_star_s_t_h_star
                  | None => "default" % string
                  end in
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell_services.Chain_services.chain_id cctxt
                        (Some chain) tt)
                      (fun chain_id =>
                        Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.trace_code
                          cctxt (chain, block) (expanded program)
                          ((expanded storage), (expanded input), amount,
                            chain_id, source, payer, gas, entrypoint))
                  end.

Definition typecheck_data {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (gas : option Tezos_protocol_environment_alpha__Environment.Z.t)
  (data : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (ty : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.typecheck_data
      cctxt (chain, block) ((expanded data), (expanded ty), gas)
  end.

Definition typecheck_program {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (gas : option Tezos_protocol_environment_alpha__Environment.Z.t)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (Tezos_raw_protocol_alpha.Script_tc_errors.type_map *
        Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.typecheck_code
    cctxt (chain, block) ((expanded program), gas).

Definition print_typecheck_result {C a b : Type}
  (emacs : bool) (show_types : bool) (print_source_on_error : bool)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (res :
    sum
      (Tezos_protocol_alpha.Protocol.Script_tc_errors.type_map *
        Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t)
      (list Tezos_base__TzPervasives.Error_monad.error))
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if emacs then
    match
      match res with
      | inl (type_map, gas) => (type_map, [], (Some gas))
      |
        inr
          ((cons
            (Environment.Ecoproto_error
              (Script_tc_errors.Ill_typed_contract _ type_map)) _) as errs) =>
        (type_map, errs, None)
      | inr errs => ([], errs, None)
      end with
    | (type_map, errs, _gas) =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "(" % char
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                (CamlinternalFormatBasics.String_literal "(types . " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.String_literal
                          "(errors . " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Char_literal
                                  ")" % char
                                  CamlinternalFormatBasics.End_of_format)))))))))))
            "(@[<v 0>(types . %a)@ (errors . %a)@])" % string)
          Tezos_client_alpha.Michelson_v1_emacs.print_type_map
          (program, type_map)
          Tezos_client_alpha.Michelson_v1_emacs.report_errors (program, errs))
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_base__TzPervasives.return_unit
          end)
    end
  else
    match res with
    | inl (type_map, gas) =>
      let program :=
        Tezos_client_alpha.Michelson_v1_printer.inject_types type_map program in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal "Well typed" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal
                    "Gas remaining: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@[<v 0>Well typed@,Gas remaining: %a@]" % string)
          Tezos_protocol_alpha.Protocol.Alpha_context.Gas.pp gas)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            if show_types then
              Tezos_base__TzPervasives.op_gt_gt_eq
                (send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format) "%a" % string)
                  Tezos_micheline.Micheline_printer.print_expr program)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            else
              Tezos_base__TzPervasives.return_unit
          end)
    | inr errs =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          (Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
            show_types print_source_on_error (Some program)) errs)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "ill-typed script" % string
                  CamlinternalFormatBasics.End_of_format)
                "ill-typed script" % string)
          end)
    end.

Definition entrypoint_type {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (entrypoint : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)) :=
  Tezos_client_alpha.Michelson_v1_entrypoints.script_entrypoint_type cctxt chain
    block (expanded program) entrypoint.

Definition print_entrypoint_type {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (emacs : bool) (script_name : option string)
  (show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (entrypoint : string)
  (ty :
    Tezos_base__TzPervasives.tzresult
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_client_alpha.Michelson_v1_entrypoints.print_entrypoint_type cctxt
    (Some (print_errors cctxt expected_argument show_source parsed)) emacs None
    script_name entrypoint ty.

Definition list_entrypoints {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))) :=
  Tezos_client_alpha.Michelson_v1_entrypoints.list_entrypoints cctxt chain block
    (expanded program).

Definition print_entrypoints_list {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (emacs : bool) (script_name : option string)
  (show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (ty :
    Tezos_base__TzPervasives.tzresult
      (list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_client_alpha.Michelson_v1_entrypoints.print_entrypoints_list cctxt
    (Some (print_errors cctxt expected_argument show_source parsed)) emacs None
    script_name ty.

Definition list_unreachables {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))) :=
  Tezos_client_alpha.Michelson_v1_entrypoints.list_unreachables cctxt chain
    block (expanded program).

Definition print_unreachables {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (emacs : bool) (script_name : option string)
  (show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (ty :
    Tezos_base__TzPervasives.tzresult
      (list (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim)))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_client_alpha.Michelson_v1_entrypoints.print_unreachables cctxt
    (Some (print_errors cctxt expected_argument show_source parsed)) emacs None
    script_name ty.
src/proto_alpha/lib_client/client_proto_programs.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline

module Program :
  Client_aliases.Alias
    with type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result

val run :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?amount:Tez.t ->
  program:Michelson_v1_parser.parsed ->
  storage:Michelson_v1_parser.parsed ->
  input:Michelson_v1_parser.parsed ->
  ?source:Contract.t ->
  ?payer:Contract.t ->
  ?gas:Z.t ->
  ?entrypoint:string ->
  unit ->
  (Script.expr * packed_internal_operation list * Contract.big_map_diff option)
  tzresult
  Lwt.t

val trace :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?amount:Tez.t ->
  program:Michelson_v1_parser.parsed ->
  storage:Michelson_v1_parser.parsed ->
  input:Michelson_v1_parser.parsed ->
  ?source:Contract.t ->
  ?payer:Contract.t ->
  ?gas:Z.t ->
  ?entrypoint:string ->
  unit ->
  ( Script.expr
  * packed_internal_operation list
  * Script_interpreter.execution_trace
  * Contract.big_map_diff option )
  tzresult
  Lwt.t

val print_run_result :
  #Client_context.printer ->
  show_source:bool ->
  parsed:Michelson_v1_parser.parsed ->
  ( Script_repr.expr
  * packed_internal_operation list
  * Contract.big_map_diff option )
  tzresult ->
  unit tzresult Lwt.t

val print_trace_result :
  #Client_context.printer ->
  show_source:bool ->
  parsed:Michelson_v1_parser.parsed ->
  ( Script_repr.expr
  * packed_internal_operation list
  * Script_interpreter.execution_trace
  * Contract.big_map_diff option )
  tzresult ->
  unit tzresult Lwt.t

val typecheck_data :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?gas:Z.t ->
  data:Michelson_v1_parser.parsed ->
  ty:Michelson_v1_parser.parsed ->
  unit ->
  Gas.t tzresult Lwt.t

val typecheck_program :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?gas:Z.t ->
  Michelson_v1_parser.parsed ->
  (Script_tc_errors.type_map * Gas.t) tzresult Lwt.t

val print_typecheck_result :
  emacs:bool ->
  show_types:bool ->
  print_source_on_error:bool ->
  Michelson_v1_parser.parsed ->
  (Script_tc_errors.type_map * Gas.t) tzresult ->
  #Client_context.printer ->
  unit tzresult Lwt.t

val entrypoint_type :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Michelson_v1_parser.parsed ->
  entrypoint:string ->
  Script.expr option tzresult Lwt.t

val print_entrypoint_type :
  #Client_context.printer ->
  emacs:bool ->
  ?script_name:string ->
  show_source:bool ->
  parsed:Michelson_v1_parser.parsed ->
  entrypoint:string ->
  Script_repr.expr option tzresult ->
  unit tzresult Lwt.t

val list_entrypoints :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Michelson_v1_parser.parsed ->
  (string * Script.expr) list tzresult Lwt.t

val print_entrypoints_list :
  #Client_context.printer ->
  emacs:bool ->
  ?script_name:string ->
  show_source:bool ->
  parsed:Michelson_v1_parser.parsed ->
  (string * Script.expr) list tzresult ->
  unit tzresult Lwt.t

val list_unreachables :
  #Protocol_client_context.rpc_context ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  Michelson_v1_parser.parsed ->
  Michelson_v1_primitives.prim list list tzresult Lwt.t

val print_unreachables :
  #Client_context.printer ->
  emacs:bool ->
  ?script_name:string ->
  show_source:bool ->
  parsed:Michelson_v1_parser.parsed ->
  Michelson_v1_primitives.prim list list tzresult ->
  unit tzresult Lwt.t
src/proto_alpha/lib_client/client_proto_programs.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

Parameter run : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
        Tezos_client_alpha.Michelson_v1_parser.parsed ->
          Tezos_client_alpha.Michelson_v1_parser.parsed ->
            Tezos_client_alpha.Michelson_v1_parser.parsed ->
              (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
                (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
                  ->
                  (option Z.t) ->
                    (option string) ->
                      unit ->
                        Lwt.t
                          (Tezos_base__TzPervasives.tzresult
                            (Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr
                              *
                              (list
                                Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
                              *
                              (option
                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff))).

Parameter trace : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
        Tezos_client_alpha.Michelson_v1_parser.parsed ->
          Tezos_client_alpha.Michelson_v1_parser.parsed ->
            Tezos_client_alpha.Michelson_v1_parser.parsed ->
              (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
                (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
                  ->
                  (option Z.t) ->
                    (option string) ->
                      unit ->
                        Lwt.t
                          (Tezos_base__TzPervasives.tzresult
                            (Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr
                              *
                              (list
                                Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
                              *
                              Tezos_protocol_alpha.Protocol.Script_interpreter.execution_trace
                              *
                              (option
                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff))).

Parameter print_run_result : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) * _))))) * _) ->
  bool ->
    Tezos_client_alpha.Michelson_v1_parser.parsed ->
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Script_repr.expr *
          (list
            Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
          *
          (option
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff)))
        -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter print_trace_result : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) * _))))) * _) ->
  bool ->
    Tezos_client_alpha.Michelson_v1_parser.parsed ->
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Script_repr.expr *
          (list
            Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
          * Tezos_protocol_alpha.Protocol.Script_interpreter.execution_trace *
          (option
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff)))
        -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter typecheck_data : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z.t) ->
        Tezos_client_alpha.Michelson_v1_parser.parsed ->
          Tezos_client_alpha.Michelson_v1_parser.parsed ->
            unit ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t).

Parameter typecheck_program : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z.t) ->
        Tezos_client_alpha.Michelson_v1_parser.parsed ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (Tezos_protocol_alpha.Protocol.Script_tc_errors.type_map *
                Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t)).

Parameter print_typecheck_result : forall {_ a b : Type},
bool ->
  bool ->
    bool ->
      Tezos_client_alpha.Michelson_v1_parser.parsed ->
        (Tezos_base__TzPervasives.tzresult
          (Tezos_protocol_alpha.Protocol.Script_tc_errors.type_map *
            Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t)) ->
          (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
            *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) * _))))) * _) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter entrypoint_type : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_client_alpha.Michelson_v1_parser.parsed ->
        string ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)).

Parameter print_entrypoint_type : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) * _))))) * _) ->
  bool ->
    (option string) ->
      bool ->
        Tezos_client_alpha.Michelson_v1_parser.parsed ->
          string ->
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_protocol_alpha.Protocol.Script_repr.expr)) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter list_entrypoints : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_client_alpha.Michelson_v1_parser.parsed ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list
              (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))).

Parameter print_entrypoints_list : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) * _))))) * _) ->
  bool ->
    (option string) ->
      bool ->
        Tezos_client_alpha.Michelson_v1_parser.parsed ->
          (Tezos_base__TzPervasives.tzresult
            (list
              (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)))
            -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter list_unreachables : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_client_alpha.Michelson_v1_parser.parsed ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list
              (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))).

Parameter print_unreachables : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) * _))))) * _) ->
  bool ->
    (option string) ->
      bool ->
        Tezos_client_alpha.Michelson_v1_parser.parsed ->
          (Tezos_base__TzPervasives.tzresult
            (list
              (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim)))
            -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_client/injection.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Apply_results
open Protocol_client_context

let get_branch (rpc_config : #Protocol_client_context.full) ~chain
    ~(block : Block_services.block) branch =
  let branch = Option.unopt ~default:0 branch in
  (* TODO export parameter *)
  ( match block with
  | `Head n ->
      return (`Head (n + branch))
  | `Hash (h, n) ->
      return (`Hash (h, n + branch))
  | `Alias (a, n) ->
      return (`Alias (a, n))
  | `Genesis ->
      return `Genesis
  | `Level i ->
      return (`Level i) )
  >>=? fun block ->
  Shell_services.Blocks.hash rpc_config ~chain ~block ()
  >>=? fun hash ->
  Shell_services.Chain.chain_id rpc_config ~chain ()
  >>=? fun chain_id -> return (chain_id, hash)

type 'kind preapply_result =
  Operation_hash.t * 'kind operation * 'kind operation_metadata

type 'kind result_list =
  Operation_hash.t * 'kind contents_list * 'kind contents_result_list

type 'kind result = Operation_hash.t * 'kind contents * 'kind contents_result

let get_manager_operation_gas_and_fee contents =
  let open Operation in
  let l = to_list (Contents_list contents) in
  List.fold_left
    (fun acc -> function
      | Contents (Manager_operation {fee; gas_limit; _}) -> (
        match acc with
        | Error _ as e ->
            e
        | Ok (total_fee, total_gas) -> (
          match Tez.(total_fee +? fee) with
          | Ok total_fee ->
              Ok (total_fee, Z.add total_gas gas_limit)
          | Error _ as e ->
              e ) ) | _ -> acc)
    (Ok (Tez.zero, Z.zero))
    l

type fee_parameter = {
  minimal_fees : Tez.t;
  minimal_nanotez_per_byte : Z.t;
  minimal_nanotez_per_gas_unit : Z.t;
  force_low_fee : bool;
  fee_cap : Tez.t;
  burn_cap : Tez.t;
}

let dummy_fee_parameter =
  {
    minimal_fees = Tez.zero;
    minimal_nanotez_per_byte = Z.zero;
    minimal_nanotez_per_gas_unit = Z.zero;
    force_low_fee = false;
    fee_cap = Tez.one;
    burn_cap = Tez.zero;
  }

let check_fees :
    type t.
    #Protocol_client_context.full ->
    fee_parameter ->
    t contents_list ->
    int ->
    unit Lwt.t =
 fun cctxt config op size ->
  match get_manager_operation_gas_and_fee op with
  | Error _ ->
      assert false (* FIXME *)
  | Ok (fee, gas) ->
      if Tez.compare fee config.fee_cap > 0 then
        cctxt#error
          "The proposed fee (%s%a) are higher than the configured fee cap \
           (%s%a).@\n\
          \ Use `--fee-cap %a` to emit this operation anyway."
          Client_proto_args.tez_sym
          Tez.pp
          fee
          Client_proto_args.tez_sym
          Tez.pp
          config.fee_cap
          Tez.pp
          fee
        >>= fun () -> exit 1
      else
        (* *)
        let fees_in_nanotez =
          Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
        in
        let minimal_fees_in_nanotez =
          Z.mul (Z.of_int64 (Tez.to_mutez config.minimal_fees)) (Z.of_int 1000)
        in
        let minimal_fees_for_gas_in_nanotez =
          Z.mul config.minimal_nanotez_per_gas_unit gas
        in
        let minimal_fees_for_size_in_nanotez =
          Z.mul config.minimal_nanotez_per_byte (Z.of_int size)
        in
        let estimated_fees_in_nanotez =
          Z.add
            minimal_fees_in_nanotez
            (Z.add
               minimal_fees_for_gas_in_nanotez
               minimal_fees_for_size_in_nanotez)
        in
        let estimated_fees =
          match
            Tez.of_mutez
              (Z.to_int64
                 (Z.div
                    (Z.add (Z.of_int 999) estimated_fees_in_nanotez)
                    (Z.of_int 1000)))
          with
          | None ->
              assert false
          | Some fee ->
              fee
        in
        if
          (not config.force_low_fee)
          && Z.compare fees_in_nanotez estimated_fees_in_nanotez < 0
        then
          cctxt#error
            "The proposed fee (%s%a) are lower than the fee that baker expect \
             by default (%s%a).@\n\
            \ Use `--force-low-fee` to emit this operation anyway."
            Client_proto_args.tez_sym
            Tez.pp
            fee
            Client_proto_args.tez_sym
            Tez.pp
            estimated_fees
          >>= fun () -> exit 1
        else Lwt.return_unit

let print_for_verbose_signing ppf ~watermark ~bytes ~branch ~contents =
  let open Format in
  pp_open_vbox ppf 0 ;
  let item f =
    pp_open_hovbox ppf 4 ;
    pp_print_string ppf "  * " ;
    f ppf () ;
    pp_close_box ppf () ;
    pp_print_cut ppf ()
  in
  let hash_pp l =
    fprintf ppf "%s" (Base58.raw_encode Blake2B.(hash_bytes l |> to_string))
  in
  item (fun ppf () ->
      pp_print_text ppf "Branch: " ;
      Block_hash.pp ppf branch) ;
  item (fun ppf () ->
      fprintf
        ppf
        "Watermark: `%a` (0x%s)"
        Signature.pp_watermark
        watermark
        (Hex.of_bytes (Signature.bytes_of_watermark watermark) |> Hex.show)) ;
  item (fun ppf () ->
      pp_print_text ppf "Operation bytes: " ;
      TzString.fold_left (* We split the bytes into lines for display: *)
        (fun n c ->
          pp_print_char ppf c ;
          if
            n < 72
            (* is the email-body standard width, ideal for copy-pasting. *)
          then n + 1
          else (pp_print_space ppf () ; 0))
        0
        (Hex.of_bytes bytes |> Hex.show)
      |> ignore) ;
  item (fun ppf () ->
      pp_print_text ppf "Blake 2B Hash (raw): " ;
      hash_pp [bytes]) ;
  item (fun ppf () ->
      pp_print_text
        ppf
        "Blake 2B Hash (ledger-style, with operation watermark): " ;
      hash_pp [Signature.bytes_of_watermark watermark; bytes]) ;
  let json =
    Data_encoding.Json.construct
      Operation.unsigned_encoding
      ({branch}, Contents_list contents)
  in
  item (fun ppf () ->
      pp_print_text ppf "JSON encoding: " ;
      Data_encoding.Json.pp ppf json) ;
  pp_close_box ppf ()

let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block
    ?(verbose_signing = false) ?fee_parameter ?branch ?src_sk
    (contents : t contents_list) =
  get_branch cctxt ~chain ~block branch
  >>=? fun (chain_id, branch) ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      Operation.unsigned_encoding
      ({branch}, Contents_list contents)
  in
  ( match src_sk with
  | None ->
      return_none
  | Some src_sk ->
      let watermark =
        match contents with
        | Single (Endorsement _) ->
            Signature.(Endorsement chain_id)
        | _ ->
            Signature.Generic_operation
      in
      ( if verbose_signing then
        cctxt#message
          "Pre-signature information (verbose signing):@.%t%!"
          (print_for_verbose_signing ~watermark ~bytes ~branch ~contents)
      else Lwt.return_unit )
      >>= fun () ->
      Client_keys.sign cctxt ~watermark src_sk bytes
      >>=? fun signature -> return_some signature )
  >>=? fun signature ->
  let op : _ Operation.t =
    {shell = {branch}; protocol_data = {contents; signature}}
  in
  let oph = Operation.hash op in
  let size = Bytes.length bytes + Signature.size in
  ( match fee_parameter with
  | Some fee_parameter ->
      check_fees cctxt fee_parameter contents size
  | None ->
      Lwt.return_unit )
  >>= fun () ->
  Protocol_client_context.Alpha_block_services.Helpers.Preapply.operations
    cctxt
    ~chain
    ~block
    [Operation.pack op]
  >>=? function
  | [(Operation_data op', Operation_metadata result)] -> (
    match
      ( Operation.equal op {shell = {branch}; protocol_data = op'},
        Apply_results.kind_equal_list contents result.contents )
    with
    | (Some Operation.Eq, Some Apply_results.Eq) ->
        return ((oph, op, result) : t preapply_result)
    | _ ->
        failwith "Unexpected result" )
  | _ ->
      failwith "Unexpected result"

let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block
    ?branch (contents : t contents_list) =
  get_branch cctxt ~chain ~block branch
  >>=? fun (_chain_id, branch) ->
  let op : _ Operation.t =
    {shell = {branch}; protocol_data = {contents; signature = None}}
  in
  let oph = Operation.hash op in
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Alpha_services.Helpers.Scripts.run_operation
    cctxt
    (chain, block)
    (Operation.pack op, chain_id)
  >>=? function
  | (Operation_data op', Operation_metadata result) -> (
    match
      ( Operation.equal op {shell = {branch}; protocol_data = op'},
        Apply_results.kind_equal_list contents result.contents )
    with
    | (Some Operation.Eq, Some Apply_results.Eq) ->
        return ((oph, op, result) : t preapply_result)
    | _ ->
        failwith "Unexpected result" )
  | _ ->
      failwith "Unexpected result"

let estimated_gas_single (type kind)
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let consumed_gas (type kind) (result : kind manager_operation_result) =
    match result with
    | Applied (Transaction_result {consumed_gas; _}) ->
        Ok consumed_gas
    | Applied (Origination_result {consumed_gas; _}) ->
        Ok consumed_gas
    | Applied (Reveal_result {consumed_gas}) ->
        Ok consumed_gas
    | Applied (Delegation_result {consumed_gas}) ->
        Ok consumed_gas
    | Skipped _ ->
        assert false
    | Backtracked (_, None) ->
        Ok Z.zero (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) ->
        Environment.wrap_error (Error errs)
    | Failed (_, errs) ->
        Environment.wrap_error (Error errs)
  in
  List.fold_left
    (fun acc (Internal_operation_result (_, r)) ->
      acc >>? fun acc -> consumed_gas r >>? fun gas -> Ok (Z.add acc gas))
    (consumed_gas operation_result)
    internal_operation_results

let estimated_storage_single (type kind) origination_size
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let storage_size_diff (type kind) (result : kind manager_operation_result) =
    match result with
    | Applied
        (Transaction_result
          {paid_storage_size_diff; allocated_destination_contract; _}) ->
        if allocated_destination_contract then
          Ok (Z.add paid_storage_size_diff origination_size)
        else Ok paid_storage_size_diff
    | Applied (Origination_result {paid_storage_size_diff; _}) ->
        Ok (Z.add paid_storage_size_diff origination_size)
    | Applied (Reveal_result _) ->
        Ok Z.zero
    | Applied (Delegation_result _) ->
        Ok Z.zero
    | Skipped _ ->
        assert false
    | Backtracked (_, None) ->
        Ok Z.zero (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) ->
        Environment.wrap_error (Error errs)
    | Failed (_, errs) ->
        Environment.wrap_error (Error errs)
  in
  List.fold_left
    (fun acc (Internal_operation_result (_, r)) ->
      acc
      >>? fun acc ->
      storage_size_diff r >>? fun storage -> Ok (Z.add acc storage))
    (storage_size_diff operation_result)
    internal_operation_results

let estimated_storage origination_size res =
  let rec estimated_storage : type kind. kind contents_result_list -> _ =
    function
    | Single_result (Manager_operation_result _ as res) ->
        estimated_storage_single origination_size res
    | Single_result _ ->
        Ok Z.zero
    | Cons_result (res, rest) ->
        estimated_storage_single origination_size res
        >>? fun storage1 ->
        estimated_storage rest >>? fun storage2 -> Ok (Z.add storage1 storage2)
  in
  estimated_storage res >>? fun diff -> Ok (Z.max Z.zero diff)

let originated_contracts_single (type kind)
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let originated_contracts (type kind) (result : kind manager_operation_result)
      =
    match result with
    | Applied (Transaction_result {originated_contracts; _}) ->
        Ok originated_contracts
    | Applied (Origination_result {originated_contracts; _}) ->
        Ok originated_contracts
    | Applied (Reveal_result _) ->
        Ok []
    | Applied (Delegation_result _) ->
        Ok []
    | Skipped _ ->
        assert false
    | Backtracked (_, None) ->
        Ok [] (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) ->
        Environment.wrap_error (Error errs)
    | Failed (_, errs) ->
        Environment.wrap_error (Error errs)
  in
  List.fold_left
    (fun acc (Internal_operation_result (_, r)) ->
      acc
      >>? fun acc ->
      originated_contracts r
      >>? fun contracts -> Ok (List.rev_append contracts acc))
    (originated_contracts operation_result >|? List.rev)
    internal_operation_results

let rec originated_contracts : type kind. kind contents_result_list -> _ =
  function
  | Single_result (Manager_operation_result _ as res) ->
      originated_contracts_single res >|? List.rev
  | Single_result _ ->
      Ok []
  | Cons_result (res, rest) ->
      originated_contracts_single res
      >>? fun contracts1 ->
      originated_contracts rest
      >>? fun contracts2 -> Ok (List.rev_append contracts1 contracts2)

let detect_script_failure : type kind. kind operation_metadata -> _ =
  let rec detect_script_failure : type kind. kind contents_result_list -> _ =
    let detect_script_failure_single (type kind)
        (Manager_operation_result
           {operation_result; internal_operation_results; _} :
          kind Kind.manager contents_result) =
      let detect_script_failure (type kind)
          (result : kind manager_operation_result) =
        match result with
        | Applied _ ->
            Ok ()
        | Skipped _ ->
            assert false
        | Backtracked (_, None) ->
            (* there must be another error for this to happen *)
            Ok ()
        | Backtracked (_, Some errs) ->
            record_trace
              (failure "The transfer simulation failed.")
              (Environment.wrap_error (Error errs))
        | Failed (_, errs) ->
            record_trace
              (failure "The transfer simulation failed.")
              (Environment.wrap_error (Error errs))
      in
      List.fold_left
        (fun acc (Internal_operation_result (_, r)) ->
          acc >>? fun () -> detect_script_failure r)
        (detect_script_failure operation_result)
        internal_operation_results
    in
    function
    | Single_result (Manager_operation_result _ as res) ->
        detect_script_failure_single res
    | Single_result _ ->
        Ok ()
    | Cons_result (res, rest) ->
        detect_script_failure_single res
        >>? fun () -> detect_script_failure rest
  in
  fun {contents} -> detect_script_failure contents

let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full)
    ~fee_parameter ~chain ~block ?branch ?(compute_fee = false)
    (contents : kind contents_list) : kind contents_list tzresult Lwt.t =
  Alpha_services.Constants.all cctxt (chain, block)
  >>=? fun { parametric =
               { hard_gas_limit_per_operation = gas_limit;
                 hard_storage_limit_per_operation = storage_limit;
                 origination_size;
                 cost_per_byte;
                 _ };
             _ } ->
  let may_need_patching_single :
      type kind. kind contents -> kind contents option = function
    | Manager_operation c
      when compute_fee || c.gas_limit < Z.zero || gas_limit <= c.gas_limit
           || c.storage_limit < Z.zero
           || storage_limit <= c.storage_limit ->
        let gas_limit =
          if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then gas_limit
          else c.gas_limit
        in
        let storage_limit =
          if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then
            storage_limit
          else c.storage_limit
        in
        Some (Manager_operation {c with gas_limit; storage_limit})
    | _ ->
        None
  in
  let rec may_need_patching :
      type kind. kind contents_list -> kind contents_list option = function
    | Single (Manager_operation _ as c) -> (
      match may_need_patching_single c with
      | None ->
          None
      | Some op ->
          Some (Single op) )
    | Single _ ->
        None
    | Cons ((Manager_operation _ as c), rest) -> (
      match (may_need_patching_single c, may_need_patching rest) with
      | (None, None) ->
          None
      | (Some c, None) ->
          Some (Cons (c, rest))
      | (None, Some rest) ->
          Some (Cons (c, rest))
      | (Some c, Some rest) ->
          Some (Cons (c, rest)) )
  in
  let rec patch_fee : type kind. bool -> kind contents -> kind contents =
   fun first -> function
    | Manager_operation c as op -> (
        let gas_limit = c.gas_limit in
        let size =
          if first then
            Data_encoding.Binary.fixed_length_exn
              Tezos_base.Operation.shell_header_encoding
            + Data_encoding.Binary.length
                Operation.contents_encoding
                (Contents op)
            + Signature.size
          else
            Data_encoding.Binary.length
              Operation.contents_encoding
              (Contents op)
        in
        let minimal_fees_in_nanotez =
          Z.mul
            (Z.of_int64 (Tez.to_mutez fee_parameter.minimal_fees))
            (Z.of_int 1000)
        in
        let minimal_fees_for_gas_in_nanotez =
          Z.mul fee_parameter.minimal_nanotez_per_gas_unit gas_limit
        in
        let minimal_fees_for_size_in_nanotez =
          Z.mul fee_parameter.minimal_nanotez_per_byte (Z.of_int size)
        in
        let fees_in_nanotez =
          Z.add minimal_fees_in_nanotez
          @@ Z.add
               minimal_fees_for_gas_in_nanotez
               minimal_fees_for_size_in_nanotez
        in
        match
          Tez.of_mutez
            (Z.to_int64
               (Z.div (Z.add (Z.of_int 999) fees_in_nanotez) (Z.of_int 1000)))
        with
        | None ->
            assert false
        | Some fee ->
            if fee <= c.fee then op
            else patch_fee first (Manager_operation {c with fee}) )
    | c ->
        c
  in
  let patch :
      type kind.
      bool ->
      kind contents * kind contents_result ->
      kind contents tzresult Lwt.t =
   fun first -> function
    | (Manager_operation c, (Manager_operation_result _ as result)) ->
        ( if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then
          Lwt.return (estimated_gas_single result)
          >>=? fun gas ->
          if Z.equal gas Z.zero then
            cctxt#message "Estimated gas: none" >>= fun () -> return Z.zero
          else
            cctxt#message
              "Estimated gas: %s units (will add 100 for safety)"
              (Z.to_string gas)
            >>= fun () -> return (Z.min (Z.add gas (Z.of_int 100)) gas_limit)
        else return c.gas_limit )
        >>=? fun gas_limit ->
        ( if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then
          Lwt.return
            (estimated_storage_single (Z.of_int origination_size) result)
          >>=? fun storage ->
          if Z.equal storage Z.zero then
            cctxt#message "Estimated storage: no bytes added"
            >>= fun () -> return Z.zero
          else
            cctxt#message
              "Estimated storage: %s bytes added (will add 20 for safety)"
              (Z.to_string storage)
            >>= fun () ->
            return (Z.min (Z.add storage (Z.of_int 20)) storage_limit)
        else return c.storage_limit )
        >>=? fun storage_limit ->
        let c = Manager_operation {c with gas_limit; storage_limit} in
        if compute_fee then return (patch_fee first c) else return c
    | (c, _) ->
        return c
  in
  let rec patch_list :
      type kind.
      bool ->
      kind contents_and_result_list ->
      kind contents_list tzresult Lwt.t =
   fun first -> function
    | Single_and_result
        ((Manager_operation _ as op), (Manager_operation_result _ as res)) ->
        patch first (op, res) >>=? fun op -> return (Single op)
    | Single_and_result (op, _) ->
        return (Single op)
    | Cons_and_result
        ((Manager_operation _ as op), (Manager_operation_result _ as res), rest)
      ->
        patch first (op, res)
        >>=? fun op ->
        patch_list false rest >>=? fun rest -> return (Cons (op, rest))
  in
  match may_need_patching contents with
  | Some contents ->
      simulate cctxt ~chain ~block ?branch contents
      >>=? fun (_, _, result) ->
      ( match detect_script_failure result with
      | Ok () ->
          return_unit
      | Error _ ->
          cctxt#message
            "@[<v 2>This simulation failed:@,%a@]"
            Operation_result.pp_operation_result
            (contents, result.contents)
          >>= fun () -> return_unit )
      >>=? fun () ->
      Lwt.return
        (estimated_storage (Z.of_int origination_size) result.contents)
      >>=? (fun storage ->
             Lwt.return
               (Environment.wrap_error
                  Tez.(cost_per_byte *? Z.to_int64 storage))
             >>=? fun burn ->
             if Tez.(burn > fee_parameter.burn_cap) then
               cctxt#error
                 "The operation will burn %s%a which is higher than the \
                  configured burn cap (%s%a).@\n\
                 \ Use `--burn-cap %a` to emit this operation."
                 Client_proto_args.tez_sym
                 Tez.pp
                 burn
                 Client_proto_args.tez_sym
                 Tez.pp
                 fee_parameter.burn_cap
                 Tez.pp
                 burn
               >>= fun () -> exit 1
             else return_unit)
      >>=? fun () ->
      let res = pack_contents_list contents result.contents in
      patch_list true res
  | None ->
      return contents

let inject_operation (type kind) cctxt ~chain ~block ?confirmations
    ?(dry_run = false) ?branch ?src_sk ?verbose_signing ~fee_parameter
    ?compute_fee (contents : kind contents_list) =
  Tezos_client_base.Client_confirmations.wait_for_bootstrapped cctxt
  >>=? fun () ->
  may_patch_limits
    cctxt
    ~chain
    ~block
    ?branch
    ~fee_parameter
    ?compute_fee
    contents
  >>=? fun contents ->
  preapply
    cctxt
    ~chain
    ~block
    ~fee_parameter
    ?verbose_signing
    ?branch
    ?src_sk
    contents
  >>=? fun (_oph, op, result) ->
  ( match detect_script_failure result with
  | Ok () ->
      return_unit
  | Error _ as res ->
      cctxt#message
        "@[<v 2>This simulation failed:@,%a@]"
        Operation_result.pp_operation_result
        (op.protocol_data.contents, result.contents)
      >>= fun () -> Lwt.return res )
  >>=? fun () ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn Operation.encoding (Operation.pack op)
  in
  if dry_run then
    let oph = Operation_hash.hash_bytes [bytes] in
    cctxt#message
      "@[<v 0>Operation: 0x%a@,Operation hash is '%a'@]"
      Hex.pp
      (Hex.of_bytes bytes)
      Operation_hash.pp
      oph
    >>= fun () ->
    cctxt#message
      "@[<v 2>Simulation result:@,%a@]"
      Operation_result.pp_operation_result
      (op.protocol_data.contents, result.contents)
    >>= fun () -> return (oph, op.protocol_data.contents, result.contents)
  else
    Shell_services.Injection.operation cctxt ~chain bytes
    >>=? fun oph ->
    cctxt#message "Operation successfully injected in the node."
    >>= fun () ->
    cctxt#message "Operation hash is '%a'" Operation_hash.pp oph
    >>= fun () ->
    ( match confirmations with
    | None ->
        cctxt#message
          "@[<v 0>NOT waiting for the operation to be included.@,\
           Use command@,\
          \  tezos-client wait for %a to be included --confirmations 30 \
           --branch %a@,\
           and/or an external block explorer to make sure that it has been \
           included.@]"
          Operation_hash.pp
          oph
          Block_hash.pp
          op.shell.branch
        >>= fun () -> return result
    | Some confirmations -> (
        cctxt#message "Waiting for the operation to be included..."
        >>= fun () ->
        Client_confirmations.wait_for_operation_inclusion
          ~branch:op.shell.branch
          ~confirmations
          cctxt
          ~chain
          oph
        >>=? fun (h, i, j) ->
        Alpha_block_services.Operations.operation
          cctxt
          ~chain
          ~block:(`Hash (h, 0))
          i
          j
        >>=? fun op' ->
        match op'.receipt with
        | No_operation_metadata ->
            failwith "Internal error: unexpected receipt."
        | Operation_metadata receipt -> (
          match Apply_results.kind_equal_list contents receipt.contents with
          | Some Apply_results.Eq ->
              return (receipt : kind operation_metadata)
          | None ->
              failwith "Internal error: unexpected receipt." ) ) )
    >>=? fun result ->
    cctxt#message
      "@[<v 2>This sequence of operations was run:@,%a@]"
      Operation_result.pp_operation_result
      (op.protocol_data.contents, result.contents)
    >>= fun () ->
    Lwt.return (originated_contracts result.contents)
    >>=? fun contracts ->
    Lwt_list.iter_s
      (fun c -> cctxt#message "New contract %a originated." Contract.pp c)
      contracts
    >>= fun () ->
    ( match confirmations with
    | None ->
        Lwt.return_unit
    | Some number ->
        if number >= 30 then
          cctxt#message
            "The operation was included in a block %d blocks ago."
            number
        else
          cctxt#message
            "@[<v 0>The operation has only been included %d blocks ago.@,\
             We recommend to wait more.@,\
             Use command@,\
            \  tezos-client wait for %a to be included --confirmations 30 \
             --branch %a@,\
             and/or an external block explorer.@]"
            number
            Operation_hash.pp
            oph
            Block_hash.pp
            op.shell.branch )
    >>= fun () -> return (oph, op.protocol_data.contents, result.contents)

let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations
    ?dry_run ?verbose_signing ~source ~src_pk ~src_sk ?fee
    ?(gas_limit = Z.minus_one) ?(storage_limit = Z.of_int (-1)) ?counter
    ~fee_parameter (type kind) (operation : kind manager_operation) :
    ( Operation_hash.t
    * kind Kind.manager contents
    * kind Kind.manager contents_result )
    tzresult
    Lwt.t =
  ( match counter with
  | None ->
      Alpha_services.Contract.counter cctxt (chain, block) source
      >>=? fun pcounter ->
      let counter = Z.succ pcounter in
      return counter
  | Some counter ->
      return counter )
  >>=? fun counter ->
  Alpha_services.Contract.manager_key cctxt (chain, block) source
  >>=? fun key ->
  let is_reveal : type kind. kind manager_operation -> bool = function
    | Reveal _ ->
        true
    | _ ->
        false
  in
  let (compute_fee, fee) =
    match fee with None -> (true, Tez.zero) | Some fee -> (false, fee)
  in
  match key with
  | None when not (is_reveal operation) -> (
      let contents =
        Cons
          ( Manager_operation
              {
                source;
                fee = Tez.zero;
                counter;
                gas_limit = Z.of_int 10_000;
                storage_limit = Z.zero;
                operation = Reveal src_pk;
              },
            Single
              (Manager_operation
                 {
                   source;
                   fee;
                   counter = Z.succ counter;
                   gas_limit;
                   storage_limit;
                   operation;
                 }) )
      in
      inject_operation
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        ~fee_parameter
        ~compute_fee
        ?verbose_signing
        ?branch
        ~src_sk
        contents
      >>=? fun (oph, op, result) ->
      match pack_contents_list op result with
      | Cons_and_result (_, _, Single_and_result (op, result)) ->
          return (oph, op, result)
      | Single_and_result (Manager_operation _, _) ->
          .
      | _ ->
          assert false
      (* Grrr... *) )
  | _ -> (
      let contents =
        Single
          (Manager_operation
             {source; fee; counter; gas_limit; storage_limit; operation})
      in
      inject_operation
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        ?verbose_signing
        ~compute_fee
        ~fee_parameter
        ?branch
        ~src_sk
        contents
      >>=? fun (oph, op, result) ->
      match pack_contents_list op result with
      | Single_and_result ((Manager_operation _ as op), result) ->
          return (oph, op, result)
      | _ ->
          assert false )

(* Grrr... *)
src/proto_alpha/lib_client/injection.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_protocol_alpha.Protocol.Apply_results.

Import Tezos_client_alpha.Protocol_client_context.

Definition get_branch {D F H J L M N a b c i o p q : Type}
  (rpc_config :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services.Block_services.block) (branch : option Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Chain_id.t *
        Tezos_base__TzPervasives.Block_hash.t)) :=
  let branch := Tezos_base__TzPervasives.Option.unopt 0 branch in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match block with
    | Head n => Tezos_base__TzPervasives._return variant
    | Hash (h, n) => Tezos_base__TzPervasives._return variant
    | Alias (a, n) => Tezos_base__TzPervasives._return variant
    | Genesis => Tezos_base__TzPervasives._return variant
    | Level i => Tezos_base__TzPervasives._return variant
    end
    (fun block =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell_services.Shell_services.Blocks.hash rpc_config (Some chain)
          (Some block) tt)
        (fun hash =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_shell_services.Shell_services.Chain.chain_id rpc_config
              (Some chain) tt)
            (fun chain_id => Tezos_base__TzPervasives._return (chain_id, hash)))).

Definition preapply_result (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.operation kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind).

Definition result_list (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind).

Definition result (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result kind).

Definition get_manager_operation_gas_and_fee {A : Type}
  (contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A)
  : sum (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)
    (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
  let l :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.to_list
      (Contents_list contents) in
  Tezos_base__TzPervasives.List.fold_left
    (fun acc =>
      fun function_parameter =>
        match function_parameter with
        | Contents (Manager_operation {| fee := fee; gas_limit := gas_limit |})
          =>
          match acc with
          | (inr _) as e => e
          | inl (total_fee, total_gas) =>
            match
              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                total_fee fee with
            | inl total_fee => inl (total_fee, (Z.add total_gas gas_limit))
            | (inr _) as e => e
            end
          end
        | _ => acc
        end)
    (inl (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero, Z.zero)) l.

Record fee_parameter := {
  minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  minimal_nanotez_per_byte : Z.t;
  minimal_nanotez_per_gas_unit : Z.t;
  force_low_fee : bool;
  fee_cap : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  burn_cap : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t }.

Definition dummy_fee_parameter : fee_parameter :=
  {| minimal_fees := Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero;
    minimal_nanotez_per_byte := Z.zero; minimal_nanotez_per_gas_unit := Z.zero;
    force_low_fee := false;
    fee_cap := Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one;
    burn_cap := Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero |}.

Definition check_fees {D F H J L M N a b c i o p q t : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (config : fee_parameter)
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list t) (size : Z)
  : Lwt.t unit :=
  match get_manager_operation_gas_and_fee op with
  | inr _ => false
  | inl (fee, gas) =>
    if
      OCaml.Stdlib.gt
        (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.compare fee
          (fee_cap config)) 0 then
      Tezos_base__TzPervasives.op_gt_gt_eq
        (send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "The proposed fee (" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    ") are higher than the configured fee cap (" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal ")." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Force_newline
                            (CamlinternalFormatBasics.String_literal
                              " Use `--fee-cap " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  "` to emit this operation anyway." % string
                                  CamlinternalFormatBasics.End_of_format)))))))))))
            "The proposed fee (%s%a) are higher than the configured fee cap (%s%a).@
 Use `--fee-cap %a` to emit this operation anyway."
              % string) Tezos_client_alpha.Client_proto_args.tez_sym
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp fee
          Tezos_client_alpha.Client_proto_args.tez_sym
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp (fee_cap config)
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp fee)
        (fun function_parameter =>
          match function_parameter with
          | tt => Stdlib.exit 1
          end)
    else
      let fees_in_nanotez :=
        Z.mul
          (Z.of_int64
            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez fee))
          (Z.of_int 1000) in
      let minimal_fees_in_nanotez :=
        Z.mul
          (Z.of_int64
            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez
              (minimal_fees config))) (Z.of_int 1000) in
      let minimal_fees_for_gas_in_nanotez :=
        Z.mul (minimal_nanotez_per_gas_unit config) gas in
      let minimal_fees_for_size_in_nanotez :=
        Z.mul (minimal_nanotez_per_byte config) (Z.of_int size) in
      let estimated_fees_in_nanotez :=
        Z.add minimal_fees_in_nanotez
          (Z.add minimal_fees_for_gas_in_nanotez
            minimal_fees_for_size_in_nanotez) in
      let estimated_fees :=
        match
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez
            (Z.to_int64
              (Z.div (Z.add (Z.of_int 999) estimated_fees_in_nanotez)
                (Z.of_int 1000))) with
        | None => false
        | Some fee => fee
        end in
      if
        andb (negb (force_low_fee config))
          (OCaml.Stdlib.lt (Z.compare fees_in_nanotez estimated_fees_in_nanotez)
            0) then
        Tezos_base__TzPervasives.op_gt_gt_eq
          (send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "The proposed fee (" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      ") are lower than the fee that baker expect by default ("
                        % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal ")." % string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Force_newline
                              (CamlinternalFormatBasics.String_literal
                                " Use `--force-low-fee` to emit this operation anyway."
                                  % string
                                CamlinternalFormatBasics.End_of_format)))))))))
              "The proposed fee (%s%a) are lower than the fee that baker expect by default (%s%a).@
 Use `--force-low-fee` to emit this operation anyway."
                % string) Tezos_client_alpha.Client_proto_args.tez_sym
            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp fee
            Tezos_client_alpha.Client_proto_args.tez_sym
            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp estimated_fees)
          (fun function_parameter =>
            match function_parameter with
            | tt => Stdlib.exit 1
            end)
      else
        Lwt.return_unit
  end.

Definition print_for_verbose_signing {A : Type}
  (ppf : Stdlib.Format.formatter)
  (watermark : Tezos_base__TzPervasives.Signature.watermark) (bytes : string)
  (branch : Tezos_base__TzPervasives.Block_hash.t)
  (contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A)
  : unit :=
  Stdlib.Format.pp_open_vbox ppf 0;
  let item (f : Stdlib.Format.formatter -> unit -> unit) : unit :=
    Stdlib.Format.pp_open_hovbox ppf 4;
    Stdlib.Format.pp_print_string ppf "  * " % string;
    f ppf tt;
    Stdlib.Format.pp_close_box ppf tt;
    Stdlib.Format.pp_print_cut ppf tt in
  let hash_pp (l : list Stdlib.Bytes.t) : unit :=
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string)
      (Tezos_base__TzPervasives.Base58.raw_encode None
        (OCaml.Stdlib.reverse_apply
          (Tezos_base__TzPervasives.Blake2B.hash_bytes None l)
          Tezos_base__TzPervasives.Blake2B.to_string)) in
  item
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Stdlib.Format.pp_print_text ppf "Branch: " % string;
          Tezos_base__TzPervasives.Block_hash.pp ppf branch
        end);
  item
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Watermark: `" % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "` (0x" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))))
              "Watermark: `%a` (0x%s)" % string)
            Tezos_base__TzPervasives.Signature.pp_watermark watermark
            (OCaml.Stdlib.reverse_apply
              (Hex.of_bytes None
                (Tezos_base__TzPervasives.Signature.bytes_of_watermark watermark))
              Hex.show)
        end);
  item
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Stdlib.Format.pp_print_text ppf "Operation bytes: " % string;
          OCaml.Stdlib.reverse_apply
            (Tezos_base__TzPervasives.TzString.fold_left
              (fun n =>
                fun c =>
                  Stdlib.Format.pp_print_char ppf c;
                  if OCaml.Stdlib.lt n 72 then
                    Z.add n 1
                  else
                    Stdlib.Format.pp_print_space ppf tt;
                    0) 0
              (OCaml.Stdlib.reverse_apply (Hex.of_bytes None string) Hex.show))
            OCaml.Stdlib.ignore
        end);
  item
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Stdlib.Format.pp_print_text ppf "Blake 2B Hash (raw): " % string;
          hash_pp (cons string [])
        end);
  item
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Stdlib.Format.pp_print_text ppf
            "Blake 2B Hash (ledger-style, with operation watermark): " % string;
          hash_pp
            (cons
              (Tezos_base__TzPervasives.Signature.bytes_of_watermark watermark)
              (cons string []))
        end);
  let json :=
    Tezos_base__TzPervasives.Data_encoding.Json.construct
      Tezos_protocol_alpha.Protocol.Alpha_context.Operation.unsigned_encoding
      ({| branch := branch |}, (Contents_list contents)) in
  item
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Stdlib.Format.pp_print_text ppf "JSON encoding: " % string;
          Tezos_base__TzPervasives.Data_encoding.Json.pp ppf json
        end);
  Stdlib.Format.pp_close_box ppf tt.

Definition preapply {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (op_star_o_p_t_star : option bool)
  : (option fee_parameter) ->
    (option Z) ->
      (option Tezos_client_base.Client_keys.sk_uri) ->
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult (preapply_result O)) :=
  let verbose_signing :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun fee_parameter =>
    fun branch =>
      fun src_sk =>
        fun contents =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (get_branch cctxt chain block branch)
            (fun function_parameter =>
              match function_parameter with
              | (chain_id, branch) =>
                let bytes :=
                  Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.unsigned_encoding
                    ({| branch := branch |}, (Contents_list contents)) in
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  match src_sk with
                  | None => Tezos_base__TzPervasives.return_none
                  | Some src_sk =>
                    let watermark :=
                      match contents with
                      | Single (Endorsement _) => Endorsement chain_id
                      | _ => Signature.Generic_operation
                      end in
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (if verbose_signing then
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Pre-signature information (verbose signing):" %
                                string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                (CamlinternalFormatBasics.Theta
                                  (CamlinternalFormatBasics.Flush
                                    CamlinternalFormatBasics.End_of_format))))
                            "Pre-signature information (verbose signing):@.%t%!"
                              % string)
                          (print_for_verbose_signing expected_argument watermark
                            string branch contents)
                      else
                        Lwt.return_unit)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_client_base.Client_keys.sign cctxt
                              (Some watermark) src_sk string)
                            (fun signature =>
                              Tezos_base__TzPervasives.return_some signature)
                        end)
                  end
                  (fun signature =>
                    let op :=
                      {| shell := {| branch := branch |};
                        protocol_data :=
                          {| contents := contents; signature := signature |} |}
                      in
                    let oph :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash
                        op in
                    let size :=
                      Z.add (String.length string)
                        Tezos_base__TzPervasives.Signature.size in
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      match fee_parameter with
                      | Some fee_parameter =>
                        check_fees cctxt fee_parameter contents size
                      | None => Lwt.return_unit
                      end
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Helpers.Preapply.operations
                              cctxt (Some chain) (Some block)
                              (cons
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                  op) []))
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                cons
                                  (Operation_data op', Operation_metadata result)
                                  [] =>
                                match
                                  ((Tezos_protocol_alpha.Protocol.Alpha_context.Operation.equal
                                    op
                                    {| shell := {| branch := branch |};
                                      protocol_data := op' |}),
                                    (Tezos_protocol_alpha.Protocol.Apply_results.kind_equal_list
                                      contents (contents result))) with
                                | (Some Operation.Eq, Some Apply_results.Eq) =>
                                  Tezos_base__TzPervasives._return
                                    (oph, op, result)
                                | _ =>
                                  Tezos_base__TzPervasives.failwith
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Unexpected result" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "Unexpected result" % string)
                                end
                              | _ =>
                                Tezos_base__TzPervasives.failwith
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Unexpected result" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "Unexpected result" % string)
                              end)
                        end))
              end).

Definition simulate {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services.Block_services.block) (branch : option Z)
  (contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (preapply_result O)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (get_branch cctxt chain block branch)
    (fun function_parameter =>
      match function_parameter with
      | (_chain_id, branch) =>
        let op :=
          {| shell := {| branch := branch |};
            protocol_data := {| contents := contents; signature := None |} |} in
        let oph := Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash op
          in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_shell_services.Chain_services.chain_id cctxt (Some chain) tt)
          (fun chain_id =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.run_operation
                cctxt (chain, block)
                ((Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack op),
                  chain_id))
              (fun function_parameter =>
                match function_parameter with
                | (Operation_data op', Operation_metadata result) =>
                  match
                    ((Tezos_protocol_alpha.Protocol.Alpha_context.Operation.equal
                      op
                      {| shell := {| branch := branch |}; protocol_data := op'
                        |}),
                      (Tezos_protocol_alpha.Protocol.Apply_results.kind_equal_list
                        contents (contents result))) with
                  | (Some Operation.Eq, Some Apply_results.Eq) =>
                    Tezos_base__TzPervasives._return (oph, op, result)
                  | _ =>
                    Tezos_base__TzPervasives.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected result" % string
                          CamlinternalFormatBasics.End_of_format)
                        "Unexpected result" % string)
                  end
                | _ =>
                  Tezos_base__TzPervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Unexpected result" % string
                        CamlinternalFormatBasics.End_of_format)
                      "Unexpected result" % string)
                end))
      end).

Definition estimated_gas_single {A : Type}
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
  : Tezos_base__TzPervasives.tzresult
    Tezos_protocol_environment_alpha__Environment.Z.t :=
  match function_parameter with
  |
    Manager_operation_result {|
      operation_result := operation_result;
        internal_operation_results := internal_operation_results
        |} =>
    let consumed_gas {B : Type}
      (result :
      Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
      : sum Tezos_protocol_environment_alpha__Environment.Z.t
        (list Tezos_base__TzPervasives.Error_monad.error) :=
      match result with
      | Applied (Transaction_result {| consumed_gas := consumed_gas |}) =>
        inl consumed_gas
      | Applied (Origination_result {| consumed_gas := consumed_gas |}) =>
        inl consumed_gas
      | Applied (Reveal_result {| consumed_gas := consumed_gas |}) =>
        inl consumed_gas
      | Applied (Delegation_result {| consumed_gas := consumed_gas |}) =>
        inl consumed_gas
      | Skipped _ => false
      | Backtracked _ None => inl Z.zero
      | Backtracked _ (Some errs) =>
        Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs)
      | Failed _ errs =>
        Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs)
      end in
    Tezos_base__TzPervasives.List.fold_left
      (fun acc =>
        fun function_parameter =>
          match function_parameter with
          | Internal_operation_result _ r =>
            Tezos_base__TzPervasives.op_gt_gt_question acc
              (fun acc =>
                Tezos_base__TzPervasives.op_gt_gt_question (consumed_gas r)
                  (fun gas => inl (Z.add acc gas)))
          end) (consumed_gas operation_result) internal_operation_results
  end.

Definition estimated_storage_single {A : Type}
  (origination_size : Z.t)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
  : Tezos_base__TzPervasives.tzresult
    Tezos_protocol_environment_alpha__Environment.Z.t :=
  match function_parameter with
  |
    Manager_operation_result {|
      operation_result := operation_result;
        internal_operation_results := internal_operation_results
        |} =>
    let storage_size_diff {B : Type}
      (result :
      Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
      : sum Tezos_protocol_environment_alpha__Environment.Z.t
        (list Tezos_base__TzPervasives.Error_monad.error) :=
      match result with
      |
        Applied
          (Transaction_result {|
            paid_storage_size_diff := paid_storage_size_diff;
              allocated_destination_contract := allocated_destination_contract
              |}) =>
        if allocated_destination_contract then
          inl (Z.add paid_storage_size_diff origination_size)
        else
          inl paid_storage_size_diff
      |
        Applied
          (Origination_result {|
            paid_storage_size_diff := paid_storage_size_diff |}) =>
        inl (Z.add paid_storage_size_diff origination_size)
      | Applied (Reveal_result _) => inl Z.zero
      | Applied (Delegation_result _) => inl Z.zero
      | Skipped _ => false
      | Backtracked _ None => inl Z.zero
      | Backtracked _ (Some errs) =>
        Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs)
      | Failed _ errs =>
        Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs)
      end in
    Tezos_base__TzPervasives.List.fold_left
      (fun acc =>
        fun function_parameter =>
          match function_parameter with
          | Internal_operation_result _ r =>
            Tezos_base__TzPervasives.op_gt_gt_question acc
              (fun acc =>
                Tezos_base__TzPervasives.op_gt_gt_question (storage_size_diff r)
                  (fun storage => inl (Z.add acc storage)))
          end) (storage_size_diff operation_result) internal_operation_results
  end.

Definition estimated_storage {A : Type}
  (origination_size : Z.t)
  (res : Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list A)
  : Tezos_base__TzPervasives.tzresult Z.t :=
  let fix estimated_storage {kind : Type}
    (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind)
    : Tezos_base__TzPervasives.tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    match function_parameter with
    | Single_result ((Manager_operation_result _) as res) =>
      estimated_storage_single origination_size res
    | Single_result _ => inl Z.zero
    | Cons_result res rest =>
      Tezos_base__TzPervasives.op_gt_gt_question
        (estimated_storage_single origination_size res)
        (fun storage1 =>
          Tezos_base__TzPervasives.op_gt_gt_question (estimated_storage rest)
            (fun storage2 => inl (Z.add storage1 storage2)))
    end in
  Tezos_base__TzPervasives.op_gt_gt_question (estimated_storage res)
    (fun diff => inl (Z.max Z.zero diff)).

Definition originated_contracts_single {A : Type}
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
  : Tezos_base__TzPervasives.tzresult
    (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
  match function_parameter with
  |
    Manager_operation_result {|
      operation_result := operation_result;
        internal_operation_results := internal_operation_results
        |} =>
    let originated_contracts {B : Type}
      (result :
      Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
      : sum (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
        (list Tezos_base__TzPervasives.Error_monad.error) :=
      match result with
      |
        Applied
          (Transaction_result {| originated_contracts := originated_contracts |})
        => inl originated_contracts
      |
        Applied
          (Origination_result {| originated_contracts := originated_contracts |})
        => inl originated_contracts
      | Applied (Reveal_result _) => inl []
      | Applied (Delegation_result _) => inl []
      | Skipped _ => false
      | Backtracked _ None => inl []
      | Backtracked _ (Some errs) =>
        Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs)
      | Failed _ errs =>
        Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs)
      end in
    Tezos_base__TzPervasives.List.fold_left
      (fun acc =>
        fun function_parameter =>
          match function_parameter with
          | Internal_operation_result _ r =>
            Tezos_base__TzPervasives.op_gt_gt_question acc
              (fun acc =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (originated_contracts r)
                  (fun contracts =>
                    inl (Tezos_base__TzPervasives.List.rev_append contracts acc)))
          end)
      (Tezos_base__TzPervasives.op_gt_pipe_question
        (originated_contracts operation_result)
        Tezos_base__TzPervasives.List.rev) internal_operation_results
  end.

Fixpoint originated_contracts {kind : Type}
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind)
  : Tezos_base__TzPervasives.tzresult
    (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
  match function_parameter with
  | Single_result ((Manager_operation_result _) as res) =>
    Tezos_base__TzPervasives.op_gt_pipe_question
      (originated_contracts_single res) Tezos_base__TzPervasives.List.rev
  | Single_result _ => inl []
  | Cons_result res rest =>
    Tezos_base__TzPervasives.op_gt_gt_question (originated_contracts_single res)
      (fun contracts1 =>
        Tezos_base__TzPervasives.op_gt_gt_question (originated_contracts rest)
          (fun contracts2 =>
            inl (Tezos_base__TzPervasives.List.rev_append contracts1 contracts2)))
  end.

Definition detect_script_failure {kind : Type}
  : (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind) ->
    Tezos_base__TzPervasives.tzresult unit :=
  let detect_script_failure :=
    let detect_script_failure_single {B : Type}
      (function_parameter :
      Tezos_protocol_alpha.Protocol.Apply_results.contents_result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager B))
      : Tezos_base__TzPervasives.tzresult unit :=
      match function_parameter with
      |
        Manager_operation_result {|
          operation_result := operation_result;
            internal_operation_results := internal_operation_results
            |} =>
        let detect_script_failure {C : Type}
          (result :
          Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
          : sum unit (list Tezos_base__TzPervasives.error) :=
          match result with
          | Applied _ => inl tt
          | Skipped _ => false
          | Backtracked _ None => inl tt
          | Backtracked _ (Some errs) =>
            Tezos_base__TzPervasives.record_trace
              (Tezos_base__TzPervasives.failure
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The transfer simulation failed." % string
                    CamlinternalFormatBasics.End_of_format)
                  "The transfer simulation failed." % string))
              (Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs))
          | Failed _ errs =>
            Tezos_base__TzPervasives.record_trace
              (Tezos_base__TzPervasives.failure
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The transfer simulation failed." % string
                    CamlinternalFormatBasics.End_of_format)
                  "The transfer simulation failed." % string))
              (Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs))
          end in
        Tezos_base__TzPervasives.List.fold_left
          (fun acc =>
            fun function_parameter =>
              match function_parameter with
              | Internal_operation_result _ r =>
                Tezos_base__TzPervasives.op_gt_gt_question acc
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => detect_script_failure r
                    end)
              end) (detect_script_failure operation_result)
          internal_operation_results
      end in
    fun function_parameter =>
      match function_parameter with
      | Single_result ((Manager_operation_result _) as res) =>
        detect_script_failure_single res
      | Single_result _ => inl tt
      | Cons_result res rest =>
        Tezos_base__TzPervasives.op_gt_gt_question
          (detect_script_failure_single res)
          (fun function_parameter =>
            match function_parameter with
            | tt => detect_script_failure rest
            end)
      end in
  fun function_parameter =>
    match function_parameter with
    | {| contents := contents |} => detect_script_failure contents
    end.

Definition may_patch_limits {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (fee_parameter : fee_parameter)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (branch : option Z)
  (op_star_o_p_t_star : option bool)
  : (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)) :=
  let compute_fee :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun contents =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all cctxt
        (chain, block))
      (fun function_parameter =>
        match function_parameter with
        | {|
          parametric := {|
            hard_gas_limit_per_operation := gas_limit;
              origination_size := origination_size;
              cost_per_byte := cost_per_byte;
              hard_storage_limit_per_operation := storage_limit
              |}
            |} =>
          let may_need_patching_single {kind : Type}
            (function_parameter :
            Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)
            : option (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) :=
            match function_parameter with
            | Manager_operation c =>
              let gas_limit :=
                if
                  orb (OCaml.Stdlib.lt (gas_limit c) Z.zero)
                    (OCaml.Stdlib.le gas_limit (gas_limit c)) then
                  gas_limit
                else
                  gas_limit c in
              let storage_limit :=
                if
                  orb (OCaml.Stdlib.lt (storage_limit c) Z.zero)
                    (OCaml.Stdlib.le storage_limit (storage_limit c)) then
                  storage_limit
                else
                  storage_limit c in
              Some (Manager_operation record)
            | _ => None
            end in
          let fix may_need_patching {kind : Type}
            (function_parameter :
            Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind)
            : option
              (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) :=
            match function_parameter with
            | Single ((Manager_operation _) as c) =>
              match may_need_patching_single c with
              | None => None
              | Some op => Some (Single op)
              end
            | Single _ => None
            | Cons ((Manager_operation _) as c) rest =>
              match ((may_need_patching_single c), (may_need_patching rest))
                with
              | (None, None) => None
              | (Some c, None) => Some (Cons c rest)
              | (None, Some rest) => Some (Cons c rest)
              | (Some c, Some rest) => Some (Cons c rest)
              end
            end in
          let fix patch_fee {kind : Type}
            (first : bool) (function_parameter :
            Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)
            : Tezos_protocol_alpha.Protocol.Alpha_context.contents kind :=
            match function_parameter with
            | (Manager_operation c) as op =>
              let gas_limit := gas_limit c in
              let size :=
                if first then
                  Z.add
                    (Z.add
                      (Tezos_base__TzPervasives.Data_encoding.Binary.fixed_length_exn
                        Tezos_base.Operation.shell_header_encoding)
                      (Tezos_base__TzPervasives.Data_encoding.Binary.length
                        Tezos_protocol_alpha.Protocol.Alpha_context.Operation.contents_encoding
                        (Contents op))) Tezos_base__TzPervasives.Signature.size
                else
                  Tezos_base__TzPervasives.Data_encoding.Binary.length
                    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.contents_encoding
                    (Contents op) in
              let minimal_fees_in_nanotez :=
                Z.mul
                  (Z.of_int64
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez
                      (minimal_fees fee_parameter))) (Z.of_int 1000) in
              let minimal_fees_for_gas_in_nanotez :=
                Z.mul (minimal_nanotez_per_gas_unit fee_parameter) gas_limit in
              let minimal_fees_for_size_in_nanotez :=
                Z.mul (minimal_nanotez_per_byte fee_parameter) (Z.of_int size)
                in
              let fees_in_nanotez :=
                apply (Z.add minimal_fees_in_nanotez)
                  (Z.add minimal_fees_for_gas_in_nanotez
                    minimal_fees_for_size_in_nanotez) in
              match
                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez
                  (Z.to_int64
                    (Z.div (Z.add (Z.of_int 999) fees_in_nanotez)
                      (Z.of_int 1000))) with
              | None => false
              | Some fee =>
                if OCaml.Stdlib.le fee (fee c) then
                  op
                else
                  patch_fee first (Manager_operation record)
              end
            | c => c
            end in
          let patch {kind : Type}
            (first : bool) (function_parameter :
            (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) *
              (Tezos_protocol_alpha.Protocol.Apply_results.contents_result kind))
            : Lwt.t
              (Tezos_base__TzPervasives.tzresult
                (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)) :=
            match function_parameter with
            | (Manager_operation c, (Manager_operation_result _) as result) =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (if
                  orb (OCaml.Stdlib.lt (gas_limit c) Z.zero)
                    (OCaml.Stdlib.le gas_limit (gas_limit c)) then
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Lwt._return (estimated_gas_single result))
                    (fun gas =>
                      if Z.equal gas Z.zero then
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Estimated gas: none" % string
                                CamlinternalFormatBasics.End_of_format)
                              "Estimated gas: none" % string))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives._return Z.zero
                            end)
                      else
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Estimated gas: " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " units (will add 100 for safety)" % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "Estimated gas: %s units (will add 100 for safety)"
                                % string) (Z.to_string gas))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_base__TzPervasives._return
                                (Z.min (Z.add gas (Z.of_int 100)) gas_limit)
                            end))
                else
                  Tezos_base__TzPervasives._return (gas_limit c))
                (fun gas_limit =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (if
                      orb (OCaml.Stdlib.lt (storage_limit c) Z.zero)
                        (OCaml.Stdlib.le storage_limit (storage_limit c)) then
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Lwt._return
                          (estimated_storage_single (Z.of_int origination_size)
                            result))
                        (fun storage =>
                          if Z.equal storage Z.zero then
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Estimated storage: no bytes added" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "Estimated storage: no bytes added" % string))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives._return Z.zero
                                end)
                          else
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Estimated storage: " % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.String_literal
                                        " bytes added (will add 20 for safety)"
                                          % string
                                        CamlinternalFormatBasics.End_of_format)))
                                  "Estimated storage: %s bytes added (will add 20 for safety)"
                                    % string) (Z.to_string storage))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives._return
                                    (Z.min (Z.add storage (Z.of_int 20))
                                      storage_limit)
                                end))
                    else
                      Tezos_base__TzPervasives._return (storage_limit c))
                    (fun storage_limit =>
                      let c := Manager_operation record in
                      if compute_fee then
                        Tezos_base__TzPervasives._return (patch_fee first c)
                      else
                        Tezos_base__TzPervasives._return c))
            | (c, _) => Tezos_base__TzPervasives._return c
            end in
          let fix patch_list {kind : Type}
            (first : bool) (function_parameter :
            Tezos_protocol_alpha.Protocol.Apply_results.contents_and_result_list
              kind)
            : Lwt.t
              (Tezos_base__TzPervasives.tzresult
                (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind)) :=
            match function_parameter with
            |
              Single_and_result ((Manager_operation _) as op)
                ((Manager_operation_result _) as res) =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (patch first (op, res))
                (fun op => Tezos_base__TzPervasives._return (Single op))
            | Single_and_result op _ =>
              Tezos_base__TzPervasives._return (Single op)
            |
              Cons_and_result ((Manager_operation _) as op)
                ((Manager_operation_result _) as res) rest =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (patch first (op, res))
                (fun op =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (patch_list false rest)
                    (fun rest => Tezos_base__TzPervasives._return (Cons op rest)))
            end in
          match may_need_patching contents with
          | Some contents =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (simulate cctxt chain block branch contents)
              (fun function_parameter =>
                match function_parameter with
                | (_, _, result) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    match detect_script_failure result with
                    | inl tt => Tezos_base__TzPervasives.return_unit
                    | inr _ =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<v 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<v 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "This simulation failed:" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))
                            "@[<v 2>This simulation failed:@,%a@]" % string)
                          Tezos_client_alpha.Operation_result.pp_operation_result
                          (contents, (contents result)))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives.return_unit
                          end)
                    end
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Lwt._return
                              (estimated_storage (Z.of_int origination_size)
                                (contents result)))
                            (fun storage =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Lwt._return
                                  (Tezos_protocol_alpha.Protocol.Environment.wrap_error
                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                                      cost_per_byte (Z.to_int64 storage))))
                                (fun burn =>
                                  if
                                    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_gt
                                      burn (burn_cap fee_parameter) then
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "The operation will burn " % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  " which is higher than the configured burn cap ("
                                                    % string
                                                  (CamlinternalFormatBasics.String
                                                    CamlinternalFormatBasics.No_padding
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        ")." % string
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Force_newline
                                                          (CamlinternalFormatBasics.String_literal
                                                            " Use `--burn-cap "
                                                              % string
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.String_literal
                                                                "` to emit this operation."
                                                                  % string
                                                                CamlinternalFormatBasics.End_of_format)))))))))))
                                          "The operation will burn %s%a which is higher than the configured burn cap (%s%a).@
 Use `--burn-cap %a` to emit this operation."
                                            % string)
                                        Tezos_client_alpha.Client_proto_args.tez_sym
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp
                                        burn
                                        Tezos_client_alpha.Client_proto_args.tez_sym
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp
                                        (burn_cap fee_parameter)
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp
                                        burn)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt => Stdlib.exit 1
                                        end)
                                  else
                                    Tezos_base__TzPervasives.return_unit)))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              let res :=
                                Tezos_protocol_alpha.Protocol.Apply_results.pack_contents_list
                                  contents (contents result) in
                              patch_list true res
                            end)
                      end)
                end)
          | None => Tezos_base__TzPervasives._return contents
          end
        end).

Definition inject_operation {F G I J K M N O a b c i o p q : Type}
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) *
                                              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                variant
                                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                q i o) ->
                                                (Tezos_shell_services.Shell_services.chain
                                                  *
                                                  Tezos_shell_services.Shell_services.block)
                                                  ->
                                                  q ->
                                                    i ->
                                                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                          o)) * (I * q * i * o))
                                                *
                                                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                  variant
                                                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                  (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                    * a) q i o) ->
                                                  (Tezos_shell_services.Shell_services.chain
                                                    *
                                                    Tezos_shell_services.Shell_services.block)
                                                    ->
                                                    a ->
                                                      q ->
                                                        i ->
                                                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                              o)) *
                                                  (J * a * q * i * o)) *
                                                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                    variant
                                                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                    ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                      * a) * b) q i o) ->
                                                    (Tezos_shell_services.Shell_services.chain
                                                      *
                                                      Tezos_shell_services.Shell_services.block)
                                                      ->
                                                      a ->
                                                        b ->
                                                          q ->
                                                            i ->
                                                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                                  o)) *
                                                    (K * a * b * q * i * o)) *
                                                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                      variant
                                                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                      (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                        * a) * b) * c) q i o) ->
                                                      (Tezos_shell_services.Shell_services.chain
                                                        *
                                                        Tezos_shell_services.Shell_services.block)
                                                        ->
                                                        a ->
                                                          b ->
                                                            c ->
                                                              q ->
                                                                i ->
                                                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                                      o)) *
                                                      (M * a * b * c * q * i * o))
                                                      * N)))))))))))))))))))))))))
      *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (I * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (J * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (K * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (M * a * b * c * q * i * o)) * N)))))
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (op_star_o_p_t_star : option bool)
  : (option Z) ->
    (option Tezos_client_base.Client_keys.sk_uri) ->
      (option bool) ->
        fee_parameter ->
          (option bool) ->
            (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  (Tezos_base__TzPervasives.Operation_hash.t *
                    (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)
                    *
                    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list
                      O))) :=
  let dry_run :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun branch =>
    fun src_sk =>
      fun verbose_signing =>
        fun fee_parameter =>
          fun compute_fee =>
            fun contents =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_client_base.Client_confirmations.wait_for_bootstrapped
                  cctxt)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (may_patch_limits cctxt fee_parameter chain block branch
                        compute_fee contents)
                      (fun contents =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (preapply cctxt chain block verbose_signing
                            (Some fee_parameter) branch src_sk contents)
                          (fun function_parameter =>
                            match function_parameter with
                            | (_oph, op, result) =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                match detect_script_failure result with
                                | inl tt => Tezos_base__TzPervasives.return_unit
                                | (inr _) as res =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.Formatting_gen
                                          (CamlinternalFormatBasics.Open_box
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "<v 2>" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "<v 2>" % string))
                                          (CamlinternalFormatBasics.String_literal
                                            "This simulation failed:" % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@," % string 0 0)
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_box
                                                  CamlinternalFormatBasics.End_of_format)))))
                                        "@[<v 2>This simulation failed:@,%a@]" %
                                          string)
                                      Tezos_client_alpha.Operation_result.pp_operation_result
                                      ((contents (protocol_data op)),
                                        (contents result)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt => Lwt._return res
                                      end)
                                end
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    let bytes :=
                                      Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Operation.encoding
                                        (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                          op) in
                                    if dry_run then
                                      let oph :=
                                        Tezos_base__TzPervasives.Operation_hash.hash_bytes
                                          None (cons string []) in
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_box
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "<v 0>" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "<v 0>" % string))
                                              (CamlinternalFormatBasics.String_literal
                                                "Operation: 0x" % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@," % string 0 0)
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Operation hash is '" %
                                                        string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Char_literal
                                                          "'" % char
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_box
                                                            CamlinternalFormatBasics.End_of_format))))))))
                                            "@[<v 0>Operation: 0x%a@,Operation hash is '%a'@]"
                                              % string) Hex.pp
                                          (Hex.of_bytes None string)
                                          Tezos_base__TzPervasives.Operation_hash.pp
                                          oph)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.Formatting_gen
                                                    (CamlinternalFormatBasics.Open_box
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "<v 2>" % string
                                                          CamlinternalFormatBasics.End_of_format)
                                                        "<v 2>" % string))
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Simulation result:" %
                                                        string
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@," % string 0 0)
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_box
                                                            CamlinternalFormatBasics.End_of_format)))))
                                                  "@[<v 2>Simulation result:@,%a@]"
                                                    % string)
                                                Tezos_client_alpha.Operation_result.pp_operation_result
                                                ((contents (protocol_data op)),
                                                  (contents result)))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_base__TzPervasives._return
                                                    (oph,
                                                      (contents
                                                        (protocol_data op)),
                                                      (contents result))
                                                end)
                                          end)
                                    else
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_shell_services.Shell_services.Injection.operation
                                          cctxt None (Some chain) string)
                                        (fun oph =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Operation successfully injected in the node."
                                                    % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "Operation successfully injected in the node."
                                                  % string))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                  (send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "Operation hash is '" %
                                                          string
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.Char_literal
                                                            "'" % char
                                                            CamlinternalFormatBasics.End_of_format)))
                                                      "Operation hash is '%a'" %
                                                        string)
                                                    Tezos_base__TzPervasives.Operation_hash.pp
                                                    oph)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                        match confirmations with
                                                        | None =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (send
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.Formatting_gen
                                                                  (CamlinternalFormatBasics.Open_box
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "<v 0>"
                                                                          %
                                                                          string
                                                                        CamlinternalFormatBasics.End_of_format)
                                                                      "<v 0>" %
                                                                        string))
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "NOT waiting for the operation to be included."
                                                                      % string
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      (CamlinternalFormatBasics.Break
                                                                        "@," %
                                                                          string
                                                                        0 0)
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "Use command"
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          (CamlinternalFormatBasics.Break
                                                                            "@,"
                                                                              %
                                                                              string
                                                                            0 0)
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "  tezos-client wait for "
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Alpha
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                " to be included --confirmations 30 --branch "
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Alpha
                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                    (CamlinternalFormatBasics.Break
                                                                                      "@,"
                                                                                        %
                                                                                        string
                                                                                      0
                                                                                      0)
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      "and/or an external block explorer to make sure that it has been included."
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                                        CamlinternalFormatBasics.Close_box
                                                                                        CamlinternalFormatBasics.End_of_format))))))))))))
                                                                "@[<v 0>NOT waiting for the operation to be included.@,Use command@,  tezos-client wait for %a to be included --confirmations 30 --branch %a@,and/or an external block explorer to make sure that it has been included.@]"
                                                                  % string)
                                                              Tezos_base__TzPervasives.Operation_hash.pp
                                                              oph
                                                              Tezos_base__TzPervasives.Block_hash.pp
                                                              (branch (shell op)))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_base__TzPervasives._return
                                                                  result
                                                              end)
                                                        | Some confirmations =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (send
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "Waiting for the operation to be included..."
                                                                    % string
                                                                  CamlinternalFormatBasics.End_of_format)
                                                                "Waiting for the operation to be included..."
                                                                  % string))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                  (Tezos_client_base.Client_confirmations.wait_for_operation_inclusion
                                                                    cctxt chain
                                                                    None
                                                                    (Some
                                                                      confirmations)
                                                                    (Some
                                                                      (branch
                                                                        (shell
                                                                          op)))
                                                                    oph)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | (h, i, j)
                                                                      =>
                                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                        (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Operations.operation
                                                                          cctxt
                                                                          (Some
                                                                            chain)
                                                                          (Some
                                                                            variant)
                                                                          i j)
                                                                        (fun op'
                                                                          =>
                                                                          match
                                                                            receipt
                                                                              op'
                                                                            with
                                                                          |
                                                                            No_operation_metadata
                                                                            =>
                                                                            Tezos_base__TzPervasives.failwith
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "Internal error: unexpected receipt."
                                                                                    %
                                                                                    string
                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                "Internal error: unexpected receipt."
                                                                                  %
                                                                                  string)
                                                                          |
                                                                            Operation_metadata
                                                                              receipt
                                                                            =>
                                                                            match
                                                                              Tezos_protocol_alpha.Protocol.Apply_results.kind_equal_list
                                                                                contents
                                                                                (contents
                                                                                  receipt)
                                                                              with
                                                                            |
                                                                              Some
                                                                                Apply_results.Eq
                                                                              =>
                                                                              Tezos_base__TzPervasives._return
                                                                                receipt
                                                                            |
                                                                              None
                                                                              =>
                                                                              Tezos_base__TzPervasives.failwith
                                                                                (CamlinternalFormatBasics.Format
                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                    "Internal error: unexpected receipt."
                                                                                      %
                                                                                      string
                                                                                    CamlinternalFormatBasics.End_of_format)
                                                                                  "Internal error: unexpected receipt."
                                                                                    %
                                                                                    string)
                                                                            end
                                                                          end)
                                                                    end)
                                                              end)
                                                        end
                                                        (fun result =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (send
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.Formatting_gen
                                                                  (CamlinternalFormatBasics.Open_box
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "<v 2>"
                                                                          %
                                                                          string
                                                                        CamlinternalFormatBasics.End_of_format)
                                                                      "<v 2>" %
                                                                        string))
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "This sequence of operations was run:"
                                                                      % string
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      (CamlinternalFormatBasics.Break
                                                                        "@," %
                                                                          string
                                                                        0 0)
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          CamlinternalFormatBasics.Close_box
                                                                          CamlinternalFormatBasics.End_of_format)))))
                                                                "@[<v 2>This sequence of operations was run:@,%a@]"
                                                                  % string)
                                                              Tezos_client_alpha.Operation_result.pp_operation_result
                                                              ((contents
                                                                (protocol_data
                                                                  op)),
                                                                (contents result)))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                  (Lwt._return
                                                                    (originated_contracts
                                                                      (contents
                                                                        result)))
                                                                  (fun contracts
                                                                    =>
                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                      (Lwt_list.iter_s
                                                                        (fun c
                                                                          =>
                                                                          send
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "New contract "
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Alpha
                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                    " originated."
                                                                                      %
                                                                                      string
                                                                                    CamlinternalFormatBasics.End_of_format)))
                                                                              "New contract %a originated."
                                                                                %
                                                                                string)
                                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp
                                                                            c)
                                                                        contracts)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                            match
                                                                              confirmations
                                                                              with
                                                                            |
                                                                              None
                                                                              =>
                                                                              Lwt.return_unit
                                                                            |
                                                                              Some
                                                                                number
                                                                              =>
                                                                              if
                                                                                OCaml.Stdlib.ge
                                                                                  number
                                                                                  30
                                                                                then
                                                                                send
                                                                                  (CamlinternalFormatBasics.Format
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      "The operation was included in a block "
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Int
                                                                                        CamlinternalFormatBasics.Int_d
                                                                                        CamlinternalFormatBasics.No_padding
                                                                                        CamlinternalFormatBasics.No_precision
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          " blocks ago."
                                                                                            %
                                                                                            string
                                                                                          CamlinternalFormatBasics.End_of_format)))
                                                                                    "The operation was included in a block %d blocks ago."
                                                                                      %
                                                                                      string)
                                                                                  number
                                                                              else
                                                                                send
                                                                                  (CamlinternalFormatBasics.Format
                                                                                    (CamlinternalFormatBasics.Formatting_gen
                                                                                      (CamlinternalFormatBasics.Open_box
                                                                                        (CamlinternalFormatBasics.Format
                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                            "<v 0>"
                                                                                              %
                                                                                              string
                                                                                            CamlinternalFormatBasics.End_of_format)
                                                                                          "<v 0>"
                                                                                            %
                                                                                            string))
                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                        "The operation has only been included "
                                                                                          %
                                                                                          string
                                                                                        (CamlinternalFormatBasics.Int
                                                                                          CamlinternalFormatBasics.Int_d
                                                                                          CamlinternalFormatBasics.No_padding
                                                                                          CamlinternalFormatBasics.No_precision
                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                            " blocks ago."
                                                                                              %
                                                                                              string
                                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                                              (CamlinternalFormatBasics.Break
                                                                                                "@,"
                                                                                                  %
                                                                                                  string
                                                                                                0
                                                                                                0)
                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                "We recommend to wait more."
                                                                                                  %
                                                                                                  string
                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                  (CamlinternalFormatBasics.Break
                                                                                                    "@,"
                                                                                                      %
                                                                                                      string
                                                                                                    0
                                                                                                    0)
                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                    "Use command"
                                                                                                      %
                                                                                                      string
                                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                                      (CamlinternalFormatBasics.Break
                                                                                                        "@,"
                                                                                                          %
                                                                                                          string
                                                                                                        0
                                                                                                        0)
                                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                                        "  tezos-client wait for "
                                                                                                          %
                                                                                                          string
                                                                                                        (CamlinternalFormatBasics.Alpha
                                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                                            " to be included --confirmations 30 --branch "
                                                                                                              %
                                                                                                              string
                                                                                                            (CamlinternalFormatBasics.Alpha
                                                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                                                (CamlinternalFormatBasics.Break
                                                                                                                  "@,"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  0
                                                                                                                  0)
                                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                                  "and/or an external block explorer."
                                                                                                                    %
                                                                                                                    string
                                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                                    CamlinternalFormatBasics.Close_box
                                                                                                                    CamlinternalFormatBasics.End_of_format))))))))))))))))
                                                                                    "@[<v 0>The operation has only been included %d blocks ago.@,We recommend to wait more.@,Use command@,  tezos-client wait for %a to be included --confirmations 30 --branch %a@,and/or an external block explorer.@]"
                                                                                      %
                                                                                      string)
                                                                                  number
                                                                                  Tezos_base__TzPervasives.Operation_hash.pp
                                                                                  oph
                                                                                  Tezos_base__TzPervasives.Block_hash.pp
                                                                                  (branch
                                                                                    (shell
                                                                                      op))
                                                                            end
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                Tezos_base__TzPervasives._return
                                                                                  (oph,
                                                                                    (contents
                                                                                      (protocol_data
                                                                                        op)),
                                                                                    (contents
                                                                                      result))
                                                                              end)
                                                                        end))
                                                              end))
                                                    end)
                                              end))
                                  end)
                            end))
                  end).

Definition inject_manager_operation {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (Uri.t *
          (Tezos_shell_services.Shell_services.block *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
              (L * p * q * i * o)) *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                (o -> unit) ->
                  (unit -> unit) ->
                    p ->
                      q ->
                        i ->
                          Lwt.t
                            (Tezos_error_monad.Error_monad.tzresult
                              (unit -> unit))) * (M * p * q * i * o)) *
                (Tezos_shell_services.Shell_services.chain *
                  ((option Z) *
                    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                      (a * b)) *
                      ((Tezos_rpc.RPC_service.meth ->
                        (option Tezos_data_encoding.Data_encoding.json) ->
                          Uri.t ->
                            Lwt.t
                              (Tezos_rpc.RPC_context.rest_result
                                Tezos_data_encoding.Data_encoding.json
                                (option Tezos_data_encoding.Data_encoding.json)))
                        *
                        (((string ->
                          a ->
                            (Tezos_base__TzPervasives.Data_encoding.encoding a)
                              -> Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                          (a)) *
                          ((option (Lwt_stream.t string)) *
                            (((string ->
                              (Tezos_client_base.Client_context.lwt_format a
                                unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                unit) -> a) * (a)) *
                                ((unit -> Ptime.t) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((float -> Lwt.t unit) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * N)))))))))))))))))))))
      *
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block))
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (branch : option Z)
  (confirmations : option Z) (dry_run : option bool)
  (verbose_signing : option bool)
  (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (op_star_o_p_t_star : option Z.t)
  : (option Z.t) ->
    (option Z.t) ->
      fee_parameter ->
        (Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation O) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (Tezos_base__TzPervasives.Operation_hash.t *
                (Tezos_protocol_alpha.Protocol.Alpha_context.contents
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager O))
                *
                (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager O)))) :=
  let gas_limit :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Z.minus_one
    end in
  fun op_star_o_p_t_star =>
    let storage_limit :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => Z.of_int (-1)
      end in
    fun counter =>
      fun fee_parameter =>
        fun operation =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            match counter with
            | None =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_protocol_alpha.Protocol.Alpha_services.Contract.counter
                  cctxt (chain, block) source)
                (fun pcounter =>
                  let counter := Z.succ pcounter in
                  Tezos_base__TzPervasives._return counter)
            | Some counter => Tezos_base__TzPervasives._return counter
            end
            (fun counter =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_protocol_alpha.Protocol.Alpha_services.Contract.manager_key
                  cctxt (chain, block) source)
                (fun key =>
                  let is_reveal {kind : Type}
                    (function_parameter :
                    Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation
                      kind) : bool :=
                    match function_parameter with
                    | Reveal _ => true
                    | _ => false
                    end in
                  match
                    match fee with
                    | None =>
                      (true,
                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                    | Some fee => (false, fee)
                    end with
                  | (compute_fee, fee) =>
                    match key with
                    | _ =>
                      let contents :=
                        Single
                          (Manager_operation
                            {| source := source; fee := fee; counter := counter;
                              operation := operation; gas_limit := gas_limit;
                              storage_limit := storage_limit |}) in
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (inject_operation cctxt chain block confirmations
                          dry_run branch (Some src_sk) verbose_signing
                          fee_parameter (Some compute_fee) contents)
                        (fun function_parameter =>
                          match function_parameter with
                          | (oph, op, result) =>
                            match
                              Tezos_protocol_alpha.Protocol.Apply_results.pack_contents_list
                                op result with
                            |
                              Single_and_result ((Manager_operation _) as op)
                                result =>
                              Tezos_base__TzPervasives._return (oph, op, result)
                            | _ => false
                            end
                          end)
                    end
                  end)).
src/proto_alpha/lib_client/injection.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Apply_results

type 'kind preapply_result =
  Operation_hash.t * 'kind operation * 'kind operation_metadata

type fee_parameter = {
  minimal_fees : Tez.t;
  minimal_nanotez_per_byte : Z.t;
  minimal_nanotez_per_gas_unit : Z.t;
  force_low_fee : bool;
  fee_cap : Tez.t;
  burn_cap : Tez.t;
}

val dummy_fee_parameter : fee_parameter

val preapply :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?verbose_signing:bool ->
  ?fee_parameter:fee_parameter ->
  ?branch:int ->
  ?src_sk:Client_keys.sk_uri ->
  'kind contents_list ->
  'kind preapply_result tzresult Lwt.t

type 'kind result_list =
  Operation_hash.t * 'kind contents_list * 'kind contents_result_list

val inject_operation :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?branch:int ->
  ?src_sk:Client_keys.sk_uri ->
  ?verbose_signing:bool ->
  fee_parameter:fee_parameter ->
  ?compute_fee:bool ->
  'kind contents_list ->
  'kind result_list tzresult Lwt.t

type 'kind result = Operation_hash.t * 'kind contents * 'kind contents_result

val inject_manager_operation :
  #Protocol_client_context.full ->
  chain:Shell_services.chain ->
  block:Shell_services.block ->
  ?branch:int ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  source:Signature.Public_key_hash.t ->
  src_pk:Signature.public_key ->
  src_sk:Client_keys.sk_uri ->
  ?fee:Tez.t ->
  ?gas_limit:Z.t ->
  ?storage_limit:Z.t ->
  ?counter:Z.t ->
  fee_parameter:fee_parameter ->
  'kind manager_operation ->
  'kind Kind.manager result tzresult Lwt.t

val originated_contracts :
  'kind contents_result_list -> Contract.t list tzresult
src/proto_alpha/lib_client/injection.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition preapply_result (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.operation kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind).

Record fee_parameter := {
  minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  minimal_nanotez_per_byte : Z.t;
  minimal_nanotez_per_gas_unit : Z.t;
  force_low_fee : bool;
  fee_cap : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  burn_cap : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t }.

Parameter dummy_fee_parameter : fee_parameter.

Parameter preapply : forall {_ a b c i kind o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option bool) ->
        (option fee_parameter) ->
          (option Z) ->
            (option Tezos_client_base.Client_keys.sk_uri) ->
              (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind)
                ->
                Lwt.t (Tezos_base__TzPervasives.tzresult (preapply_result kind)).

Definition result_list (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind).

Parameter inject_operation : forall {_ a b c i kind o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option bool) ->
          (option Z) ->
            (option Tezos_client_base.Client_keys.sk_uri) ->
              (option bool) ->
                fee_parameter ->
                  (option bool) ->
                    (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list
                      kind) ->
                      Lwt.t
                        (Tezos_base__TzPervasives.tzresult (result_list kind)).

Definition result (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result kind).

Parameter inject_manager_operation : forall
{_ a b c i kind o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Shell_services.block ->
      (option Z) ->
        (option Z) ->
          (option bool) ->
            (option bool) ->
              Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
                Tezos_base__TzPervasives.Signature.public_key ->
                  Tezos_client_base.Client_keys.sk_uri ->
                    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
                      ->
                      (option Z.t) ->
                        (option Z.t) ->
                          (option Z.t) ->
                            fee_parameter ->
                              (Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation
                                kind) ->
                                Lwt.t
                                  (Tezos_base__TzPervasives.tzresult
                                    (result
                                      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                        kind))).

Parameter originated_contracts : forall {kind : Type},
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind) ->
  Tezos_base__TzPervasives.tzresult
    (list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t).
src/proto_alpha/lib_client/managed_contract.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Protocol_client_context
open Tezos_micheline
open Client_proto_context

let get_contract_manager (cctxt : #full) contract =
  let open Micheline in
  let open Michelson_v1_primitives in
  get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract
  >>=? function
  | None ->
      cctxt#error "This is not a smart contract."
  | Some storage -> (
    match root storage with
    | Prim (_, D_Pair, [Bytes (_, bytes); _], _) | Bytes (_, bytes) -> (
      match
        Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes
      with
      | Some k ->
          return k
      | None ->
          cctxt#error
            "Cannot find a manager key in contracts storage (decoding bytes \
             failed).\n\
             Transfer from scripted contract are currently only supported for \
             \"manager\" contract." )
    | Prim (_, D_Pair, [String (_, value); _], _) | String (_, value) -> (
      match Signature.Public_key_hash.of_b58check_opt value with
      | Some k ->
          return k
      | None ->
          cctxt#error
            "Cannot find a manager key in contracts storage (\"%s\" is not a \
             valid key).\n\
             Transfer from scripted contract are currently only supported for \
             \"manager\" contract."
            value )
    | _raw_storage ->
        cctxt#error
          "Cannot find a manager key in contracts storage (wrong storage \
           format : @[%a@]).\n\
           Transfer from scripted contract are currently only supported for \
           \"manager\" contract."
          Michelson_v1_printer.print_expr
          storage )

let parse code =
  Lwt.return
    ( Micheline_parser.no_parsing_error
      @@ Michelson_v1_parser.parse_expression code
    >>? fun exp ->
    Error_monad.ok @@ Script.lazy_expr Michelson_v1_parser.(exp.expanded) )

let set_delegate (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?branch ~fee_parameter ?fee ~source ~src_pk ~src_sk
    contract (* the KT1 to delegate *)
    (delegate : Signature.public_key_hash option) =
  let entrypoint = "do" in
  Michelson_v1_entrypoints.contract_entrypoint_type
    cctxt
    ~chain
    ~block
    ~contract
    ~entrypoint
  >>=? (function
         | Some _ ->
             (* their is a "do" entrypoint (we could check its type here)*)
             let lambda =
               match delegate with
               | Some delegate ->
                   let (`Hex delegate) =
                     Signature.Public_key_hash.to_hex delegate
                   in
                   Format.asprintf
                     "{ DROP ; NIL operation ; PUSH key_hash 0x%s ; SOME ; \
                      SET_DELEGATE ; CONS }"
                     delegate
               | None ->
                   "{ DROP ; NIL operation ; NONE key_hash ; SET_DELEGATE ; \
                    CONS }"
             in
             parse lambda >>=? fun param -> return (param, entrypoint)
         | None -> (
             (*  their is no "do" entrypoint trying "set_delegate" *)
             let entrypoint = "set_delegate" in
             Michelson_v1_entrypoints.contract_entrypoint_type
               cctxt
               ~chain
               ~block
               ~contract
               ~entrypoint
             >>=? function
             | Some _ ->
                 (*  their is a "set_delegate" entrypoint *)
                 let delegate_data =
                   match delegate with
                   | Some delegate ->
                       let (`Hex delegate) =
                         Signature.Public_key_hash.to_hex delegate
                       in
                       "0x" ^ delegate
                   | None ->
                       "Unit"
                 in
                 let entrypoint =
                   match delegate with
                   | Some _ ->
                       "set_delegate"
                   | None ->
                       "remove_delegate"
                 in
                 parse delegate_data
                 >>=? fun param -> return (param, entrypoint)
             | None ->
                 cctxt#error
                   "Cannot find a %%do or %%set_delegate entrypoint in \
                    contract@." ))
  >>=? fun (parameters, entrypoint) ->
  let operation =
    Transaction
      {amount = Tez.zero; parameters; entrypoint; destination = contract}
  in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ~storage_limit:Z.zero
    ~src_pk
    ~src_sk
    ~fee_parameter
    operation
  >>=? fun res -> return res

let d_unit =
  Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))

let t_unit =
  Micheline.strip_locations (Prim (0, Michelson_v1_primitives.T_unit, [], []))

let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?branch ~source ~src_pk ~src_sk ~contract ~destination
    ?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit ?storage_limit
    ?counter ~fee_parameter () :
    (Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult
    Lwt.t =
  ( match Alpha_context.Contract.is_implicit destination with
  | None -> (
      Michelson_v1_entrypoints.contract_entrypoint_type
        cctxt
        ~chain
        ~block
        ~contract:destination
        ~entrypoint
      >>=? function
      | None ->
          cctxt#error
            "Contract %a has no entrypoint named %s"
            Contract.pp
            destination
            entrypoint
      | Some parameter_type ->
          return parameter_type )
  | Some _ when entrypoint = "default" ->
      return t_unit (* if contract is implicit, parameter type is unit *)
  | _ ->
      cctxt#error
        "Implicit accounts have no entrypoints. (targeted entrypoint %%%s on \
         contract %a)"
        entrypoint
        Contract.pp
        destination )
  >>=? fun parameter_type ->
  ( match arg with
  | Some arg ->
      Lwt.return @@ Micheline_parser.no_parsing_error
      @@ Michelson_v1_parser.parse_expression arg
      >>=? fun {expanded = arg; _} -> return_some arg
  | None ->
      return_none )
  >>=? fun parameters ->
  let parameters = Option.unopt ~default:d_unit parameters in
  let lambda =
    let destination =
      Data_encoding.Binary.to_bytes_exn Contract.encoding destination
    in
    let (`Hex destination) = MBytes.to_hex destination in
    Format.asprintf
      "{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; \
       ASSERT_SOME;PUSH mutez %Ld ;PUSH %a %a;TRANSFER_TOKENS ; CONS }"
      destination
      (match entrypoint with "default" -> "" | s -> "%" ^ s)
      Michelson_v1_printer.print_expr
      parameter_type
      (Tez.to_mutez amount)
      Michelson_v1_printer.print_expr
      parameter_type
      Michelson_v1_printer.print_expr
      parameters
  in
  parse lambda
  >>=? fun parameters ->
  let entrypoint = "do" in
  let operation =
    Transaction
      {amount = Tez.zero; parameters; entrypoint; destination = contract}
  in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~src_pk
    ~src_sk
    ~fee_parameter
    operation
  >>=? fun ((_oph, _op, result) as res) ->
  Lwt.return (Injection.originated_contracts (Single_result result))
  >>=? fun contracts -> return (res, contracts)
src/proto_alpha/lib_client/managed_contract.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_micheline.

Import Tezos_client_alpha.Client_proto_context.

Definition get_contract_manager {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Public_key_hash.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_alpha.Client_proto_context.get_storage cctxt send send
      contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This is not a smart contract." % string
              CamlinternalFormatBasics.End_of_format)
            "This is not a smart contract." % string)
      | Some storage =>
        match Tezos_micheline.Micheline.root storage with
        | Prim _ D_Pair (cons (Bytes _ bytes) (cons _ [])) _ | Bytes _ bytes =>
          match
            Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
              Tezos_base__TzPervasives.Signature.Public_key_hash.encoding string
            with
          | Some k => Tezos_base__TzPervasives._return k
          | None =>
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Cannot find a manager key in contracts storage (decoding bytes failed).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                    % string CamlinternalFormatBasics.End_of_format)
                "Cannot find a manager key in contracts storage (decoding bytes failed).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                  % string)
          end
        | Prim _ D_Pair (cons (String _ value) (cons _ [])) _ | String _ value
          =>
          match
            Tezos_base__TzPervasives.Signature.Public_key_hash.of_b58check_opt
              value with
          | Some k => Tezos_base__TzPervasives._return k
          | None =>
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Cannot find a manager key in contracts storage (""" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      """ is not a valid key).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                        % string CamlinternalFormatBasics.End_of_format)))
                "Cannot find a manager key in contracts storage (""%s"" is not a valid key).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                  % string) value
          end
        | _raw_storage =>
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Cannot find a manager key in contracts storage (wrong storage format : "
                  % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.String_literal
                        ").
Transfer from scripted contract are currently only supported for ""manager"" contract."
                          % string CamlinternalFormatBasics.End_of_format)))))
              "Cannot find a manager key in contracts storage (wrong storage format : @[%a@]).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                % string) Tezos_client_alpha.Michelson_v1_printer.print_expr
            storage
        end
      end).

Definition parse (code : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr) :=
  Lwt._return
    (Tezos_base__TzPervasives.op_gt_gt_question
      (apply Tezos_micheline.Micheline_parser.no_parsing_error
        (Tezos_client_alpha.Michelson_v1_parser.parse_expression None code))
      (fun exp =>
        apply Tezos_base__TzPervasives.Error_monad.ok
          (Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr
            (expanded exp)))).

Definition set_delegate {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (delegate : option Tezos_base__TzPervasives.Signature.public_key_hash)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))) :=
  let entrypoint := "do" % string in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_client_alpha.Michelson_v1_entrypoints.contract_entrypoint_type
        cctxt chain block contract entrypoint)
      (fun function_parameter =>
        match function_parameter with
        | Some _ =>
          let lambda :=
            match delegate with
            | Some delegate =>
              match
                Tezos_base__TzPervasives.Signature.Public_key_hash.to_hex
                  delegate with
              | Hex delegate =>
                Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "{ DROP ; NIL operation ; PUSH key_hash 0x" % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          " ; SOME ; SET_DELEGATE ; CONS }" % string
                          CamlinternalFormatBasics.End_of_format)))
                    "{ DROP ; NIL operation ; PUSH key_hash 0x%s ; SOME ; SET_DELEGATE ; CONS }"
                      % string) delegate
              end
            | None =>
              "{ DROP ; NIL operation ; NONE key_hash ; SET_DELEGATE ; CONS }" %
                string
            end in
          Tezos_base__TzPervasives.op_gt_gt_eq_question (parse lambda)
            (fun param => Tezos_base__TzPervasives._return (param, entrypoint))
        | None =>
          let entrypoint := "set_delegate" % string in
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_client_alpha.Michelson_v1_entrypoints.contract_entrypoint_type
              cctxt chain block contract entrypoint)
            (fun function_parameter =>
              match function_parameter with
              | Some _ =>
                let delegate_data :=
                  match delegate with
                  | Some delegate =>
                    match
                      Tezos_base__TzPervasives.Signature.Public_key_hash.to_hex
                        delegate with
                    | Hex delegate => String.append "0x" % string delegate
                    end
                  | None => "Unit" % string
                  end in
                let entrypoint :=
                  match delegate with
                  | Some _ => "set_delegate" % string
                  | None => "remove_delegate" % string
                  end in
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (parse delegate_data)
                  (fun param =>
                    Tezos_base__TzPervasives._return (param, entrypoint))
              | None =>
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Cannot find a " % string
                      (CamlinternalFormatBasics.Char_literal "%" % char
                        (CamlinternalFormatBasics.String_literal
                          "do or " % string
                          (CamlinternalFormatBasics.Char_literal "%" % char
                            (CamlinternalFormatBasics.String_literal
                              "set_delegate entrypoint in contract" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                CamlinternalFormatBasics.End_of_format))))))
                    "Cannot find a %%do or %%set_delegate entrypoint in contract@."
                      % string)
              end)
        end))
    (fun function_parameter =>
      match function_parameter with
      | (parameters, entrypoint) =>
        let operation :=
          Transaction
            {| amount := Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero;
              parameters := parameters; entrypoint := entrypoint;
              destination := contract |} in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_client_alpha.Injection.inject_manager_operation cctxt chain
            block branch confirmations dry_run verbose_signing source src_pk
            src_sk fee None (Some Z.zero) None fee_parameter operation)
          (fun res => Tezos_base__TzPervasives._return res)
      end).

Definition d_unit
  : Tezos_micheline.Micheline.canonical
    Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim :=
  Tezos_micheline.Micheline.strip_locations
    (Prim 0 Michelson_v1_primitives.D_Unit [] []).

Definition t_unit
  : Tezos_micheline.Micheline.canonical
    Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim :=
  Tezos_micheline.Micheline.strip_locations
    (Prim 0 Michelson_v1_primitives.T_unit [] []).

Definition transfer {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
  (destination : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
  (op_star_o_p_t_star : option string)
  : (option string) ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
        (option Z.t) ->
          (option Z.t) ->
            (option Z.t) ->
              Tezos_client_alpha.Injection.fee_parameter ->
                unit ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      ((Tezos_client_alpha.Injection.result
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
                        *
                        (list
                          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
  let entrypoint :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "default" % string
    end in
  fun arg =>
    fun amount =>
      fun fee =>
        fun gas_limit =>
          fun storage_limit =>
            fun counter =>
              fun fee_parameter =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      match
                        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                          destination with
                      | None =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_alpha.Michelson_v1_entrypoints.contract_entrypoint_type
                            cctxt chain block destination entrypoint)
                          (fun function_parameter =>
                            match function_parameter with
                            | None =>
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Contract " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " has no entrypoint named " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))))
                                  "Contract %a has no entrypoint named %s" %
                                    string)
                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp
                                destination entrypoint
                            | Some parameter_type =>
                              Tezos_base__TzPervasives._return parameter_type
                            end)
                      | _ =>
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Implicit accounts have no entrypoints. (targeted entrypoint "
                                % string
                              (CamlinternalFormatBasics.Char_literal "%" % char
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " on contract " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        ")" % char
                                        CamlinternalFormatBasics.End_of_format))))))
                            "Implicit accounts have no entrypoints. (targeted entrypoint %%%s on contract %a)"
                              % string) entrypoint
                          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp
                          destination
                      end
                      (fun parameter_type =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          match arg with
                          | Some arg =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (apply Lwt._return
                                (apply
                                  Tezos_micheline.Micheline_parser.no_parsing_error
                                  (Tezos_client_alpha.Michelson_v1_parser.parse_expression
                                    None arg)))
                              (fun function_parameter =>
                                match function_parameter with
                                | {| expanded := arg |} =>
                                  Tezos_base__TzPervasives.return_some arg
                                end)
                          | None => Tezos_base__TzPervasives.return_none
                          end
                          (fun parameters =>
                            let parameters :=
                              Tezos_base__TzPervasives.Option.unopt d_unit
                                parameters in
                            let lambda :=
                              let destination :=
                                Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.encoding
                                  destination in
                              match
                                Tezos_base__TzPervasives.MBytes.to_hex
                                  destination with
                              | Hex destination =>
                                Stdlib.Format.asprintf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "{ DROP ; NIL operation ;PUSH address 0x"
                                        % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.String_literal
                                          "; CONTRACT " % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.Char_literal
                                              " " % char
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  "; ASSERT_SOME;PUSH mutez " %
                                                    string
                                                  (CamlinternalFormatBasics.Int64
                                                    CamlinternalFormatBasics.Int_d
                                                    CamlinternalFormatBasics.No_padding
                                                    CamlinternalFormatBasics.No_precision
                                                    (CamlinternalFormatBasics.String_literal
                                                      " ;PUSH " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Char_literal
                                                          " " % char
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.String_literal
                                                              ";TRANSFER_TOKENS ; CONS }"
                                                                % string
                                                              CamlinternalFormatBasics.End_of_format)))))))))))))
                                    "{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; ASSERT_SOME;PUSH mutez %Ld ;PUSH %a %a;TRANSFER_TOKENS ; CONS }"
                                      % string) destination
                                  match entrypoint with
                                  | "default" % string => "" % string
                                  | s => String.append "%" % string s
                                  end
                                  Tezos_client_alpha.Michelson_v1_printer.print_expr
                                  parameter_type
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez
                                    amount)
                                  Tezos_client_alpha.Michelson_v1_printer.print_expr
                                  parameter_type
                                  Tezos_client_alpha.Michelson_v1_printer.print_expr
                                  parameters
                              end in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (parse lambda)
                              (fun parameters =>
                                let entrypoint := "do" % string in
                                let operation :=
                                  Transaction
                                    {|
                                      amount :=
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero;
                                      parameters := parameters;
                                      entrypoint := entrypoint;
                                      destination := contract |} in
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_client_alpha.Injection.inject_manager_operation
                                    cctxt chain block branch confirmations
                                    dry_run verbose_signing source src_pk src_sk
                                    fee gas_limit storage_limit counter
                                    fee_parameter operation)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (_oph, _op, result) as res =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Lwt._return
                                          (Tezos_client_alpha.Injection.originated_contracts
                                            (Single_result result)))
                                        (fun contracts =>
                                          Tezos_base__TzPervasives._return
                                            (res, contracts))
                                    end))))
                  end.
src/proto_alpha/lib_client/managed_contract.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Protocol_client_context

(** Retreive the manager key in a contract storage.
    The storage has to be of type `pair key_hash 'a`.
*)
val get_contract_manager :
  #full -> Contract.t -> public_key_hash tzresult Lwt.t

(** Set the delegate of a manageable contract.
    For a contract with a `do`entrypoint, it builds the lamba that set
    the provided delegate.
    `~source` has to be the registered manager of the contract.
*)
val set_delegate :
  #Protocol_client_context.full ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  ?branch:int ->
  fee_parameter:Injection.fee_parameter ->
  ?fee:Tez.t ->
  source:public_key_hash ->
  src_pk:public_key ->
  src_sk:Client_keys.sk_uri ->
  Contract.t ->
  public_key_hash option ->
  Kind.transaction Kind.manager Injection.result tzresult Lwt.t

(** Perform a transfer on behalf of a managed contract .
    For a contract with a `do`entrypoint, it builds the lamba that
    does the requested operation.
    `~source` has to be the registered manager of the contract.
*)
val transfer :
  #Protocol_client_context.full ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  ?confirmations:int ->
  ?dry_run:bool ->
  ?verbose_signing:bool ->
  ?branch:int ->
  source:public_key_hash ->
  src_pk:public_key ->
  src_sk:Client_keys.sk_uri ->
  contract:Contract.t ->
  destination:Contract.t ->
  ?entrypoint:string ->
  ?arg:string ->
  amount:Tez.t ->
  ?fee:Tez.t ->
  ?gas_limit:counter ->
  ?storage_limit:counter ->
  ?counter:counter ->
  fee_parameter:Injection.fee_parameter ->
  unit ->
  (Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult
  Lwt.t
src/proto_alpha/lib_client/managed_contract.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_contract_manager : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash).

Parameter set_delegate : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      (option Z) ->
        (option bool) ->
          (option bool) ->
            (option Z) ->
              Tezos_client_alpha.Injection.fee_parameter ->
                (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
                  Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
                    Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
                      Tezos_client_base.Client_keys.sk_uri ->
                        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t
                          ->
                          (option
                            Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
                            ->
                            Lwt.t
                              (Tezos_base__TzPervasives.tzresult
                                (Tezos_client_alpha.Injection.result
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                    Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))).

Parameter transfer : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      (option Z) ->
        (option bool) ->
          (option bool) ->
            (option Z) ->
              Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
                Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
                  Tezos_client_base.Client_keys.sk_uri ->
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
                      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
                        (option string) ->
                          (option string) ->
                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
                              (option
                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
                                ->
                                (option
                                  Tezos_protocol_alpha.Protocol.Alpha_context.counter)
                                  ->
                                  (option
                                    Tezos_protocol_alpha.Protocol.Alpha_context.counter)
                                    ->
                                    (option
                                      Tezos_protocol_alpha.Protocol.Alpha_context.counter)
                                      ->
                                      Tezos_client_alpha.Injection.fee_parameter
                                        ->
                                        unit ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              ((Tezos_client_alpha.Injection.result
                                                (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
                                                *
                                                (list
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))).
src/proto_alpha/lib_client/michelson_v1_emacs.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Tezos_micheline
open Micheline

let print_expr ppf expr =
  let print_annot ppf = function
    | [] ->
        ()
    | annots ->
        Format.fprintf ppf " %s" (String.concat " " annots)
  in
  let rec print_expr ppf = function
    | Int (_, value) ->
        Format.fprintf ppf "%s" (Z.to_string value)
    | String (_, value) ->
        Micheline_printer.print_string ppf value
    | Bytes (_, value) ->
        Format.fprintf ppf "0x%a" Hex.pp (Hex.of_bytes value)
    | Seq (_, items) ->
        Format.fprintf
          ppf
          "(seq %a)"
          (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
          items
    | Prim (_, name, [], []) ->
        Format.fprintf ppf "%s" name
    | Prim (_, name, items, annot) ->
        Format.fprintf
          ppf
          "(%s%a%s%a)"
          name
          print_annot
          annot
          (if items = [] then "" else " ")
          (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
          items
  in
  let root = root (Michelson_v1_primitives.strings_of_prims expr) in
  Format.fprintf ppf "@[<h>%a@]" print_expr root

let print_var_annots ppf = List.iter (Format.fprintf ppf "%s ")

let print_annot_expr ppf (expr, annot) =
  Format.fprintf ppf "(%a%a)" print_var_annots annot print_expr expr

open Micheline_parser
open Script_tc_errors

let print_type_map ppf (parsed, type_map) =
  let rec print_expr_types ppf = function
    | Seq (loc, [])
    | Prim (loc, _, [], _)
    | Int (loc, _)
    | Bytes (loc, _)
    | String (loc, _) ->
        print_item ppf loc
    | Seq (loc, items) | Prim (loc, _, items, _) ->
        print_item ppf loc ;
        List.iter (print_expr_types ppf) items
  and print_stack ppf items =
    Format.fprintf
      ppf
      "(%a)"
      (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr)
      items
  and print_item ppf loc =
    try
      let ({start = {point = s; _}; stop = {point = e; _}}, locs) =
        List.assoc loc parsed.Michelson_v1_parser.expansion_table
      in
      let locs = List.sort compare locs in
      let (bef, aft) = List.assoc (List.hd locs) type_map in
      Format.fprintf
        ppf
        "(@[<h>%d %d %a %a@])@,"
        s
        e
        print_stack
        bef
        print_stack
        aft
    with Not_found -> ()
  in
  Format.fprintf ppf "(@[<v 0>%a@])" print_expr_types (root parsed.unexpanded)

let first_error_location errs =
  let rec find = function
    | [] ->
        0
    | ( Inconsistent_type_annotations (loc, _, _)
      | Unexpected_annotation loc
      | Ill_formed_type (_, _, loc)
      | Invalid_arity (loc, _, _, _)
      | Invalid_namespace (loc, _, _, _)
      | Invalid_primitive (loc, _, _)
      | Invalid_kind (loc, _, _)
      | Fail_not_in_tail_position loc
      | Undefined_binop (loc, _, _, _)
      | Undefined_unop (loc, _, _)
      | Bad_return (loc, _, _)
      | Bad_stack (loc, _, _, _)
      | Unmatched_branches (loc, _, _)
      | Invalid_constant (loc, _, _)
      | Invalid_syntactic_constant (loc, _, _)
      | Invalid_contract (loc, _)
      | Comparable_type_expected (loc, _)
      | Michelson_v1_primitives.Invalid_primitive_name (_, loc) )
      :: _ ->
        loc
    | _ :: rest ->
        find rest
  in
  find errs

let report_errors ppf (parsed, errs) =
  let (eco, out) =
    List.fold_left
      (fun (eco, out) -> function Environment.Ecoproto_error err ->
            (err :: eco, out) | err -> (eco, err :: out))
      ([], [])
      errs
  in
  let (eco, out) = (List.rev eco, List.rev out) in
  Format.fprintf
    ppf
    "(@[<v 0>%a@,%a@])"
    (fun ppf errs ->
      let find_location loc =
        let oloc =
          List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
        in
        fst (List.assoc oloc parsed.expansion_table)
      in
      match errs with
      | top :: errs ->
          let (errs, loc) =
            ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs),
              match top with
              | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) ->
                  if expr = parsed.expanded then
                    find_location (first_error_location (top :: errs))
                  else find_location 0
              | Michelson_v1_primitives.Invalid_primitive_name (expr, loc) ->
                  if
                    Micheline.strip_locations
                      (Michelson_v1_macros.unexpand_rec (Micheline.root expr))
                    = parsed.Michelson_v1_parser.unexpanded
                  then find_location loc
                  else find_location 0
              | _ ->
                  find_location 0 )
          in
          let message =
            Format.asprintf
              "%a"
              (Michelson_v1_error_reporter.report_errors
                 ~details:false
                 ~show_source:false
                 ~parsed)
              errs
          in
          let {start = {point = s; _}; stop = {point = e; _}} = loc in
          Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message
      | [] ->
          ())
    eco
    (Format.pp_print_list (fun ppf err ->
         let find_location loc =
           let oloc =
             List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
           in
           fst (List.assoc oloc parsed.expansion_table)
         in
         let loc =
           match err with
           | Invalid_utf8_sequence (point, _)
           | Unexpected_character (point, _)
           | Undefined_escape_sequence (point, _)
           | Missing_break_after_number point ->
               {start = point; stop = point}
           | Unterminated_string loc
           | Unterminated_integer loc
           | Unterminated_comment loc
           | Odd_lengthed_bytes loc
           | Unclosed {loc; _}
           | Unexpected {loc; _}
           | Extra {loc; _} ->
               loc
           | Misaligned node ->
               location node
           | _ ->
               find_location 0
         in
         let message =
           Format.asprintf
             "%a"
             (Michelson_v1_error_reporter.report_errors
                ~details:false
                ~show_source:false
                ~parsed)
             [err]
         in
         let {start = {point = s; _}; stop = {point = e; _}} = loc in
         Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message))
    out
src/proto_alpha/lib_client/michelson_v1_emacs.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_micheline.

Import Tezos_micheline.Micheline.

Definition print_expr
  (ppf : Stdlib.Format.formatter)
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
  let print_annot
    (ppf : Stdlib.Format.formatter) (function_parameter : list string) : unit :=
    match function_parameter with
    | [] => tt
    | annots =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal " " % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)) " %s" % string)
        (Tezos_base__TzPervasives.String.concat " " % string annots)
    end in
  let fix print_expr {A : Type}
    (ppf : Stdlib.Format.formatter) (function_parameter :
    Tezos_micheline.Micheline.node A string) : unit :=
    match function_parameter with
    | Int _ value =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string)
        (Z.to_string value)
    | String _ value => Tezos_micheline.Micheline_printer.print_string ppf value
    | Bytes _ value =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "0x" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "0x%a" % string) Hex.pp
        (Hex.of_bytes None value)
    | Seq _ items =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(seq " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))) "(seq %a)" % string)
        (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space)
          print_expr) items
    | Prim _ name [] [] =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) name
    | Prim _ name items annot =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "(" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format))))))
          "(%s%a%s%a)" % string) name print_annot annot
        (if equiv_decb items [] then
          "" % string
        else
          " " % string)
        (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space)
          print_expr) items
    end in
  let root :=
    Tezos_micheline.Micheline.root
      (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.strings_of_prims
        expr) in
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<h>" % string
              CamlinternalFormatBasics.End_of_format) "<h>" % string))
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format))) "@[<h>%a@]" % string)
    print_expr root.

Definition print_var_annots (ppf : Stdlib.Format.formatter)
  : (list string) -> unit :=
  Tezos_base__TzPervasives.List.iter
    (Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal " " % char
            CamlinternalFormatBasics.End_of_format)) "%s " % string)).

Definition print_annot_expr
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
      (list string)) : unit :=
  match function_parameter with
  | (expr, annot) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))) "(%a%a)" % string)
      print_var_annots annot print_expr expr
  end.

Import Tezos_micheline.Micheline_parser.

Import Tezos_protocol_alpha.Protocol.Script_tc_errors.

Definition print_type_map
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_client_alpha.Michelson_v1_parser.parsed *
      (list
        (Z *
          ((list
            ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
              Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
              (list string))) *
            (list
              ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
                Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
                (list string))))))) : unit :=
  match function_parameter with
  | (parsed, type_map) =>
    let fix print_expr_types {A : Type}
      (ppf : Stdlib.Format.formatter) (function_parameter :
      Tezos_micheline.Micheline.node Z A) : unit :=
      match function_parameter with
      | Seq loc [] | Prim loc _ [] _ | Int loc _ | Bytes loc _ | String loc _ =>
        print_item ppf loc
      | Seq loc items | Prim loc _ items _ =>
        print_item ppf loc;
        Tezos_base__TzPervasives.List.iter (print_expr_types ppf) items
      end
    with print_stack
      (ppf : Stdlib.Format.formatter) (items :
      list
        ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
          Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
          (list string))) : unit :=
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "(" % char
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))) "(%a)" % string)
        (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space)
          print_annot_expr) items
    with print_item (ppf : Stdlib.Format.formatter) (loc : Z) : unit :=
      try in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "(@[<v 0>%a@])" % string) print_expr_types
      (Tezos_micheline.Micheline.root (unexpanded parsed))
  end.

Definition first_error_location
  (errs : list Tezos_protocol_environment_alpha__Environment.Error_monad.error)
  : Z :=
  let fix find
    (function_parameter :
    list Tezos_protocol_environment_alpha__Environment.Error_monad.error) : Z :=
    match function_parameter with
    | [] => 0
    |
      cons
        (Inconsistent_type_annotations loc _ _ | Unexpected_annotation loc |
          Ill_formed_type _ _ loc | Invalid_arity loc _ _ _ |
          Invalid_namespace loc _ _ _ | Invalid_primitive loc _ _ |
          Invalid_kind loc _ _ | Fail_not_in_tail_position loc |
          Undefined_binop loc _ _ _ | Undefined_unop loc _ _ |
          Bad_return loc _ _ | Bad_stack loc _ _ _ | Unmatched_branches loc _ _
          | Invalid_constant loc _ _ | Invalid_syntactic_constant loc _ _ |
          Invalid_contract loc _ | Comparable_type_expected loc _ |
          Michelson_v1_primitives.Invalid_primitive_name _ loc) _ => loc
    | cons _ rest => find rest
    end in
  find errs.

Definition report_errors
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_client_alpha.Michelson_v1_parser.parsed *
      (list Tezos_base__TzPervasives.Error_monad.error)) : unit :=
  match function_parameter with
  | (parsed, errs) =>
    match
      Tezos_base__TzPervasives.List.fold_left
        (fun function_parameter =>
          match function_parameter with
          | (eco, out) =>
            fun function_parameter =>
              match function_parameter with
              | Environment.Ecoproto_error err => ((cons err eco), out)
              | err => (eco, (cons err out))
              end
          end) ([], []) errs with
    | (eco, out) =>
      match
        ((Tezos_base__TzPervasives.List.rev eco),
          (Tezos_base__TzPervasives.List.rev out)) with
      | (eco, out) =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "(" % char
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))))))
            "(@[<v 0>%a@,%a@])" % string)
          (fun ppf =>
            fun errs =>
              let find_location (loc : Z)
                : Tezos_micheline.Micheline_parser.location :=
                let oloc :=
                  Tezos_base__TzPervasives.List.assoc loc
                    (Michelson_v1_parser.unexpansion_table parsed) in
                fst
                  (Tezos_base__TzPervasives.List.assoc oloc
                    (expansion_table parsed)) in
              match errs with
              | cons top errs =>
                match
                  ((Tezos_base__TzPervasives.List.map
                    (fun e => Environment.Ecoproto_error e) (cons top errs)),
                    match top with
                    | Ill_typed_contract expr _ | Ill_typed_data _ expr _ =>
                      if equiv_decb expr (expanded parsed) then
                        find_location (first_error_location (cons top errs))
                      else
                        find_location 0
                    | Michelson_v1_primitives.Invalid_primitive_name expr loc =>
                      if
                        equiv_decb
                          (Tezos_micheline.Micheline.strip_locations
                            (Tezos_client_alpha.Michelson_v1_macros.unexpand_rec
                              (Tezos_micheline.Micheline.root expr)))
                          (Michelson_v1_parser.unexpanded parsed) then
                        find_location loc
                      else
                        find_location 0
                    | _ => find_location 0
                    end) with
                | (errs, loc) =>
                  let message :=
                    Stdlib.Format.asprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format) "%a" % string)
                      (Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                        false false (Some parsed)) errs in
                  match loc with
                  | {| start := {| point := s |}; stop := {| point := e |} |} =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Char_literal "(" % char
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.Char_literal " " % char
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.Char_literal
                                  " " % char
                                  (CamlinternalFormatBasics.Caml_string
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Char_literal
                                      ")" % char
                                      CamlinternalFormatBasics.End_of_format)))))))
                        "(%d %d %S)" % string) (Z.add s 1) (Z.add e 1) message
                  end
                end
              | [] => tt
              end) eco
          (Stdlib.Format.pp_print_list None
            (fun ppf =>
              fun err =>
                let find_location (loc : Z)
                  : Tezos_micheline.Micheline_parser.location :=
                  let oloc :=
                    Tezos_base__TzPervasives.List.assoc loc
                      (Michelson_v1_parser.unexpansion_table parsed) in
                  fst
                    (Tezos_base__TzPervasives.List.assoc oloc
                      (expansion_table parsed)) in
                let loc :=
                  match err with
                  |
                    Invalid_utf8_sequence point _ | Unexpected_character point _
                      | Undefined_escape_sequence point _ |
                      Missing_break_after_number point =>
                    {| start := point; stop := point |}
                  |
                    Unterminated_string loc | Unterminated_integer loc |
                      Unterminated_comment loc | Odd_lengthed_bytes loc |
                      Unclosed {| loc := loc |} | Unexpected {| loc := loc |} |
                      Extra {| loc := loc |} => loc
                  | Misaligned node => Tezos_micheline.Micheline.location node
                  | _ => find_location 0
                  end in
                let message :=
                  Stdlib.Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format) "%a" % string)
                    (Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                      false false (Some parsed)) (cons err []) in
                match loc with
                | {| start := {| point := s |}; stop := {| point := e |} |} =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Char_literal "(" % char
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal " " % char
                            (CamlinternalFormatBasics.Int
                              CamlinternalFormatBasics.Int_d
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.No_precision
                              (CamlinternalFormatBasics.Char_literal " " % char
                                (CamlinternalFormatBasics.Caml_string
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Char_literal
                                    ")" % char
                                    CamlinternalFormatBasics.End_of_format)))))))
                      "(%d %d %S)" % string) (Z.add s 1) (Z.add e 1) message
                end)) out
      end
    end
  end.
src/proto_alpha/lib_client/michelson_v1_emacs.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

val print_expr : Format.formatter -> Script.expr -> unit

val print_type_map :
  Format.formatter ->
  Michelson_v1_parser.parsed * Script_tc_errors.type_map ->
  unit

val report_errors :
  Format.formatter ->
  Michelson_v1_parser.parsed * Error_monad.error list ->
  unit
src/proto_alpha/lib_client/michelson_v1_emacs.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter print_expr :
Stdlib.Format.formatter ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr -> unit.

Parameter print_type_map :
Stdlib.Format.formatter ->
  (Tezos_client_alpha.Michelson_v1_parser.parsed *
    Tezos_protocol_alpha.Protocol.Script_tc_errors.type_map) -> unit.

Parameter report_errors :
Stdlib.Format.formatter ->
  (Tezos_client_alpha.Michelson_v1_parser.parsed *
    (list Tezos_base__TzPervasives.Error_monad.error)) -> unit.
src/proto_alpha/lib_client/michelson_v1_entrypoints.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Protocol_client_context
open Alpha_context

type error += Contract_without_code of Contract.t

let () =
  register_error_kind
    `Permanent
    ~id:"contractWithoutCode"
    ~title:"The given contract has no code"
    ~description:
      "Attempt to get the code of a contract failed because it has nocode. No \
       scriptless contract should remain."
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract has no code %a." Contract.pp contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_without_code c -> Some c | _ -> None)
    (fun c -> Contract_without_code c)

let print_errors (cctxt : #Client_context.printer) errs =
  cctxt#error "%a" Error_monad.pp_print_error errs >>= fun () -> return_unit

let script_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
    (program : Script.expr) ~entrypoint =
  Alpha_services.Helpers.Scripts.entrypoint_type
    cctxt
    (chain, block)
    (program, entrypoint)
  >>= function
  | Ok ty ->
      return_some ty
  | Error
      (Environment.Ecoproto_error (Script_tc_errors.No_such_entrypoint _) :: _)
    ->
      return None
  | Error _ as err ->
      Lwt.return err

let contract_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
    ~contract ~entrypoint =
  Alpha_services.Contract.entrypoint_type
    cctxt
    (chain, block)
    contract
    entrypoint
  >>= function
  | Ok ty ->
      return_some ty
  | Error (RPC_context.Not_found _ :: _) ->
      return None
  | Error _ as err ->
      Lwt.return err

let print_entrypoint_type (cctxt : #Client_context.printer)
    ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name ~entrypoint
    = function
  | Ok (Some ty) ->
      ( if emacs then
        cctxt#message
          "@[<v 2>((entrypoint . %s) (type . %a))@]@."
          entrypoint
          Michelson_v1_emacs.print_expr
          ty
      else
        cctxt#message
          "@[<v 2>Entrypoint %s: %a@]@."
          entrypoint
          Michelson_v1_printer.print_expr
          ty )
      >>= fun () -> return_unit
  | Ok None ->
      cctxt#message
        "@[<v 2>No entrypoint named %s%a%a@]@."
        entrypoint
        (Option.pp ~default:"" (fun ppf ->
             Format.fprintf ppf " for contract %a" Contract.pp))
        contract
        (Option.pp ~default:"" (fun ppf -> Format.fprintf ppf " for script %s"))
        script_name
      >>= fun () -> return_unit
  | Error errs ->
      on_errors errs

let list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract =
  Alpha_services.Contract.list_entrypoints cctxt (chain, block) contract

let list_contract_unreachables cctxt ~chain ~block ~contract =
  list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract
  >>=? fun (unreachables, _) -> return unreachables

let list_contract_entrypoints cctxt ~chain ~block ~contract =
  list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract
  >>=? fun (_, entrypoints) ->
  if not @@ List.mem_assoc "default" entrypoints then
    contract_entrypoint_type
      cctxt
      ~chain
      ~block
      ~contract
      ~entrypoint:"default"
    >>= function
    | Ok (Some ty) ->
        return (("default", ty) :: entrypoints)
    | _ ->
        return entrypoints
  else return entrypoints

let list_unreachables cctxt ~chain ~block (program : Script.expr) =
  Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program
  >>=? fun (unreachables, _) -> return unreachables

let list_entrypoints cctxt ~chain ~block (program : Script.expr) =
  Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program
  >>=? fun (_, entrypoints) ->
  if not @@ List.mem_assoc "default" entrypoints then
    script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default"
    >>= function
    | Ok (Some ty) ->
        return (("default", ty) :: entrypoints)
    | _ ->
        return entrypoints
  else return entrypoints

let print_entrypoints_list (cctxt : #Client_context.printer)
    ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function
  | Ok entrypoint_list ->
      ( if emacs then
        cctxt#message
          "@[<v 2>(@[%a@])@."
          (Format.pp_print_list
             ~pp_sep:Format.pp_print_cut
             (fun ppf (entrypoint, ty) ->
               Format.fprintf
                 ppf
                 "@[<v 2>( ( entrypoint . %s ) ( type . @[%a@]))@]"
                 entrypoint
                 Michelson_v1_emacs.print_expr
                 ty))
          entrypoint_list
      else
        cctxt#message
          "@[<v 2>Entrypoints%a%a: @,%a@]@."
          (Option.pp ~default:"" (fun ppf ->
               Format.fprintf ppf " for contract %a" Contract.pp))
          contract
          (Option.pp ~default:"" (fun ppf ->
               Format.fprintf ppf " for script %s"))
          script_name
          (Format.pp_print_list
             ~pp_sep:Format.pp_print_cut
             (fun ppf (entrypoint, ty) ->
               Format.fprintf
                 ppf
                 "@[<v 2>%s: @[%a@]@]"
                 entrypoint
                 Michelson_v1_printer.print_expr
                 ty))
          entrypoint_list )
      >>= fun () -> return_unit
  | Error errs ->
      on_errors errs

let print_unreachables (cctxt : #Client_context.printer)
    ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function
  | Ok unreachable ->
      ( if emacs then
        cctxt#message
          "@[<v 2>(@[%a@])@."
          (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path ->
               Format.fprintf
                 ppf
                 "@[<h>( unreachable-path . %a )@]"
                 (Format.pp_print_list
                    ~pp_sep:Format.pp_print_space
                    (fun ppf prim ->
                      Format.pp_print_string ppf
                      @@ Michelson_v1_primitives.string_of_prim prim))
                 path))
          unreachable
      else
        match unreachable with
        | [] ->
            cctxt#message "@[<v 2>None.@]@."
        | _ ->
            cctxt#message
              "@[<v 2>Unreachable paths in the argument%a%a: @[%a@]@."
              (Option.pp ~default:"" (fun ppf ->
                   Format.fprintf ppf " of contract %a" Contract.pp))
              contract
              (Option.pp ~default:"" (fun ppf ->
                   Format.fprintf ppf " of script %s"))
              script_name
              (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf ->
                   Format.fprintf
                     ppf
                     "@[<h> %a @]"
                     (Format.pp_print_list
                        ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/")
                        (fun ppf prim ->
                          Format.pp_print_string ppf
                          @@ Michelson_v1_primitives.string_of_prim prim))))
              unreachable )
      >>= fun () -> return_unit
  | Error errs ->
      on_errors errs
src/proto_alpha/lib_client/michelson_v1_entrypoints.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition print_errors {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (errs : list Tezos_base__TzPervasives.Error_monad.error)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Tezos_base__TzPervasives.Error_monad.pp_print_error errs)
    (fun function_parameter =>
      match function_parameter with
      | tt => Tezos_base__TzPervasives.return_unit
      end).

Definition script_entrypoint_type {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  (entrypoint : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.entrypoint_type
      cctxt (chain, block) (program, entrypoint))
    (fun function_parameter =>
      match function_parameter with
      | inl ty => Tezos_base__TzPervasives.return_some ty
      |
        inr
          (cons
            (Environment.Ecoproto_error (Script_tc_errors.No_such_entrypoint _))
            _) => Tezos_base__TzPervasives._return None
      | (inr _) as err => Lwt._return err
      end).

Definition contract_entrypoint_type {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (entrypoint : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_protocol_alpha.Protocol.Alpha_services.Contract.entrypoint_type cctxt
      (chain, block) contract entrypoint)
    (fun function_parameter =>
      match function_parameter with
      | inl ty => Tezos_base__TzPervasives.return_some ty
      | inr (cons (RPC_context.Not_found _) _) =>
        Tezos_base__TzPervasives._return None
      | (inr _) as err => Lwt._return err
      end).

Definition print_entrypoint_type {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (op_star_o_p_t_star :
    option
      ((list Tezos_base__TzPervasives.Error_monad.error) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
  : bool ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
      (option string) ->
        string ->
          (sum (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
            (list Tezos_base__TzPervasives.Error_monad.error)) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let on_errors :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => print_errors cctxt
    end in
  fun emacs =>
    fun contract =>
      fun script_name =>
        fun entrypoint =>
          fun function_parameter =>
            match function_parameter with
            | inl (Some ty) =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (if emacs then
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "((entrypoint . " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              ") (type . " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  "))" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      CamlinternalFormatBasics.End_of_format))))))))
                      "@[<v 2>((entrypoint . %s) (type . %a))@]@." % string)
                    entrypoint Tezos_client_alpha.Michelson_v1_emacs.print_expr
                    ty
                else
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Entrypoint " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              ": " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format)))))))
                      "@[<v 2>Entrypoint %s: %a@]@." % string) entrypoint
                    Tezos_client_alpha.Michelson_v1_printer.print_expr ty)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            | inl None =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "No entrypoint named " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "@[<v 2>No entrypoint named %s%a%a@]@." % string) entrypoint
                  (Tezos_base__TzPervasives.Option.pp (Some "" % string)
                    (fun ppf =>
                      Stdlib.Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            " for contract " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          " for contract %a" % string)
                        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp))
                  contract
                  (Tezos_base__TzPervasives.Option.pp (Some "" % string)
                    (fun ppf =>
                      Stdlib.Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            " for script " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))
                          " for script %s" % string))) script_name)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            | inr errs => on_errors errs
            end.

Definition list_contract_unreachables_and_entrypoints
  {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
        (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Contract.list_entrypoints cctxt
    (chain, block) contract.

Definition list_contract_unreachables {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (list_contract_unreachables_and_entrypoints cctxt chain block contract)
    (fun function_parameter =>
      match function_parameter with
      | (unreachables, _) => Tezos_base__TzPervasives._return unreachables
      end).

Definition list_contract_entrypoints {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (list_contract_unreachables_and_entrypoints cctxt chain block contract)
    (fun function_parameter =>
      match function_parameter with
      | (_, entrypoints) =>
        if
          apply negb
            (Tezos_base__TzPervasives.List.mem_assoc "default" % string
              entrypoints) then
          Tezos_base__TzPervasives.op_gt_gt_eq
            (contract_entrypoint_type cctxt chain block contract
              "default" % string)
            (fun function_parameter =>
              match function_parameter with
              | inl (Some ty) =>
                Tezos_base__TzPervasives._return
                  (cons ("default" % string, ty) entrypoints)
              | _ => Tezos_base__TzPervasives._return entrypoints
              end)
        else
          Tezos_base__TzPervasives._return entrypoints
      end).

Definition list_unreachables {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.list_entrypoints
      cctxt (chain, block) program)
    (fun function_parameter =>
      match function_parameter with
      | (unreachables, _) => Tezos_base__TzPervasives._return unreachables
      end).

Definition list_entrypoints {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.list_entrypoints
      cctxt (chain, block) program)
    (fun function_parameter =>
      match function_parameter with
      | (_, entrypoints) =>
        if
          apply negb
            (Tezos_base__TzPervasives.List.mem_assoc "default" % string
              entrypoints) then
          Tezos_base__TzPervasives.op_gt_gt_eq
            (script_entrypoint_type cctxt chain block program "default" % string)
            (fun function_parameter =>
              match function_parameter with
              | inl (Some ty) =>
                Tezos_base__TzPervasives._return
                  (cons ("default" % string, ty) entrypoints)
              | _ => Tezos_base__TzPervasives._return entrypoints
              end)
        else
          Tezos_base__TzPervasives._return entrypoints
      end).

Definition print_entrypoints_list {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (op_star_o_p_t_star :
    option
      ((list Tezos_base__TzPervasives.Error_monad.error) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
  : bool ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
      (option string) ->
        (sum (list (string * Tezos_protocol_alpha.Protocol.Script_repr.expr))
          (list Tezos_base__TzPervasives.Error_monad.error)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let on_errors :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => print_errors cctxt
    end in
  fun emacs =>
    fun contract =>
      fun script_name =>
        fun function_parameter =>
          match function_parameter with
          | inl entrypoint_list =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (if emacs then
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.Char_literal "(" % char
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "@[<v 2>(@[%a@])@." % string)
                  (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_cut)
                    (fun ppf =>
                      fun function_parameter =>
                        match function_parameter with
                        | (entrypoint, ty) =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "( ( entrypoint . " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String_literal
                                      " ) ( type . " % string
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            CamlinternalFormatBasics.End_of_format
                                            "" % string))
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            (CamlinternalFormatBasics.String_literal
                                              "))" % string
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                CamlinternalFormatBasics.End_of_format)))))))))
                              "@[<v 2>( ( entrypoint . %s ) ( type . @[%a@]))@]"
                                % string) entrypoint
                            Tezos_client_alpha.Michelson_v1_emacs.print_expr ty
                        end)) entrypoint_list
              else
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Entrypoints" % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              ": " % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      CamlinternalFormatBasics.End_of_format)))))))))
                    "@[<v 2>Entrypoints%a%a: @,%a@]@." % string)
                  (Tezos_base__TzPervasives.Option.pp (Some "" % string)
                    (fun ppf =>
                      Stdlib.Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            " for contract " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          " for contract %a" % string)
                        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp))
                  contract
                  (Tezos_base__TzPervasives.Option.pp (Some "" % string)
                    (fun ppf =>
                      Stdlib.Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            " for script " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))
                          " for script %s" % string))) script_name
                  (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_cut)
                    (fun ppf =>
                      fun function_parameter =>
                        match function_parameter with
                        | (entrypoint, ty) =>
                          Stdlib.Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    ": " % string
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          CamlinternalFormatBasics.End_of_format
                                          "" % string))
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))))
                              "@[<v 2>%s: @[%a@]@]" % string) entrypoint
                            Tezos_client_alpha.Michelson_v1_printer.print_expr
                            ty
                        end)) entrypoint_list)
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives.return_unit
                end)
          | inr errs => on_errors errs
          end.

Definition print_unreachables {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (op_star_o_p_t_star :
    option
      ((list Tezos_base__TzPervasives.Error_monad.error) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
  : bool ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
      (option string) ->
        (sum
          (list
            (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))
          (list Tezos_base__TzPervasives.Error_monad.error)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let on_errors :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => print_errors cctxt
    end in
  fun emacs =>
    fun contract =>
      fun script_name =>
        fun function_parameter =>
          match function_parameter with
          | inl unreachable =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (if emacs then
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.Char_literal "(" % char
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "@[<v 2>(@[%a@])@." % string)
                  (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_cut)
                    (fun ppf =>
                      fun path =>
                        Stdlib.Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<h>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<h>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "( unreachable-path . " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " )" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))
                            "@[<h>( unreachable-path . %a )@]" % string)
                          (Stdlib.Format.pp_print_list
                            (Some Stdlib.Format.pp_print_space)
                            (fun ppf =>
                              fun prim =>
                                apply (Stdlib.Format.pp_print_string ppf)
                                  (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
                                    prim))) path)) unreachable
              else
                match unreachable with
                | [] =>
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "None." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              CamlinternalFormatBasics.End_of_format))))
                      "@[<v 2>None.@]@." % string)
                | _ =>
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unreachable paths in the argument" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                ": " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      CamlinternalFormatBasics.End_of_format
                                      "" % string))
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Flush_newline
                                        CamlinternalFormatBasics.End_of_format)))))))))
                      "@[<v 2>Unreachable paths in the argument%a%a: @[%a@]@." %
                        string)
                    (Tezos_base__TzPervasives.Option.pp (Some "" % string)
                      (fun ppf =>
                        Stdlib.Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              " of contract " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))
                            " of contract %a" % string)
                          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp))
                    contract
                    (Tezos_base__TzPervasives.Option.pp (Some "" % string)
                      (fun ppf =>
                        Stdlib.Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              " of script " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.End_of_format))
                            " of script %s" % string))) script_name
                    (Stdlib.Format.pp_print_list
                      (Some Stdlib.Format.pp_print_cut)
                      (fun ppf =>
                        Stdlib.Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<h>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<h>" % string))
                              (CamlinternalFormatBasics.Char_literal " " % char
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    " " % char
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))
                            "@[<h> %a @]" % string)
                          (Stdlib.Format.pp_print_list
                            (Some
                              (fun ppf =>
                                fun function_parameter =>
                                  match function_parameter with
                                  | _ =>
                                    Stdlib.Format.pp_print_string ppf
                                      "/" % string
                                  end))
                            (fun ppf =>
                              fun prim =>
                                apply (Stdlib.Format.pp_print_string ppf)
                                  (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
                                    prim))))) unreachable
                end)
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives.return_unit
                end)
          | inr errs => on_errors errs
          end.
src/proto_alpha/lib_client/michelson_v1_entrypoints.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

(** Returns [Some type] if the contract has an entrypoint of type [type]. None if it does not exists.  *)
val script_entrypoint_type :
  #Protocol_client_context.rpc_context ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  Alpha_context.Script.expr ->
  entrypoint:string ->
  Alpha_context.Script.expr option tzresult Lwt.t

(** Returns [Some type] if the script has an entrypoint of type [type]. None if it does not exists.  *)
val contract_entrypoint_type :
  #Protocol_client_context.rpc_context ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  contract:Alpha_context.Contract.t ->
  entrypoint:string ->
  Alpha_context.Script.expr option tzresult Lwt.t

val print_entrypoint_type :
  #Client_context.printer ->
  ?on_errors:(error list -> unit tzresult Lwt.t) ->
  emacs:bool ->
  ?contract:Alpha_context.Contract.t ->
  ?script_name:string ->
  entrypoint:string ->
  Alpha_context.Script.expr option tzresult ->
  unit tzresult Lwt.t

(** List paths of unreachable parameters.
    Only useful to test the stitching, as no such parameter should be
    allowed in originated contracts.  *)
val list_contract_unreachables :
  #Protocol_client_context.rpc_context ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  contract:Alpha_context.Contract.t ->
  Michelson_v1_primitives.prim list list tzresult Lwt.t

val list_unreachables :
  #Protocol_client_context.rpc_context ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  Alpha_context.Script.expr ->
  Michelson_v1_primitives.prim list list tzresult Lwt.t

val print_unreachables :
  #Client_context.printer ->
  ?on_errors:(error list -> unit tzresult Lwt.t) ->
  emacs:bool ->
  ?contract:Alpha_context.Contract.t ->
  ?script_name:string ->
  Michelson_v1_primitives.prim list list tzresult ->
  unit tzresult Lwt.t

(** List the contract entrypoints with their types.
    If their is no explicit default, th type of default entrypoint will still be given.
*)
val list_contract_entrypoints :
  #Protocol_client_context.rpc_context ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  contract:Alpha_context.Contract.t ->
  (string * Alpha_context.Script.expr) list tzresult Lwt.t

(** List the script entrypoints with their types.  *)
val list_entrypoints :
  #Protocol_client_context.rpc_context ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  Alpha_context.Script.expr ->
  (string * Alpha_context.Script.expr) list tzresult Lwt.t

(** Print the contract entrypoints with their types.  *)
val print_entrypoints_list :
  #Client_context.printer ->
  ?on_errors:(error list -> unit tzresult Lwt.t) ->
  emacs:bool ->
  ?contract:Alpha_context.Contract.t ->
  ?script_name:string ->
  (string * Alpha_context.Script.expr) list tzresult ->
  unit tzresult Lwt.t
src/proto_alpha/lib_client/michelson_v1_entrypoints.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter script_entrypoint_type : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr ->
        string ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)).

Parameter contract_entrypoint_type : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        string ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)).

Parameter print_entrypoint_type : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) * _))))) * _) ->
  (option
    ((list Tezos_base__TzPervasives.error) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit))) ->
    bool ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
        (option string) ->
          string ->
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))
              -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter list_contract_unreachables : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list
              (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))).

Parameter list_unreachables : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list
              (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))).

Parameter print_unreachables : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) * _))))) * _) ->
  (option
    ((list Tezos_base__TzPervasives.error) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit))) ->
    bool ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
        (option string) ->
          (Tezos_base__TzPervasives.tzresult
            (list
              (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim)))
            -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter list_contract_entrypoints : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list
              (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))).

Parameter list_entrypoints : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list
              (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))).

Parameter print_entrypoints_list : forall {_ a b : Type},
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
          * (a)) * _))))) * _) ->
  (option
    ((list Tezos_base__TzPervasives.error) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit))) ->
    bool ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
        (option string) ->
          (Tezos_base__TzPervasives.tzresult
            (list
              (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)))
            -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline
open Script_tc_errors
open Script_interpreter
open Michelson_v1_printer

let print_ty ppf ty = Michelson_v1_printer.print_expr_unwrapped ppf ty

let print_var_annot ppf annot = List.iter (Format.fprintf ppf "@ %s") annot

let print_stack_ty ?(depth = max_int) ppf s =
  let rec loop depth ppf = function
    | [] ->
        ()
    | _ when depth <= 0 ->
        Format.fprintf ppf "..."
    | [(last, annot)] ->
        Format.fprintf ppf "%a%a" print_ty last print_var_annot annot
    | (last, annot) :: rest ->
        Format.fprintf
          ppf
          "%a%a@ :@ %a"
          print_ty
          last
          print_var_annot
          annot
          (loop (depth - 1))
          rest
  in
  match s with
  | [] ->
      Format.fprintf ppf "[]"
  | sty ->
      Format.fprintf ppf "@[<hov 2>[ %a ]@]" (loop depth) sty

let rec print_enumeration ppf = function
  | [single] ->
      Format.fprintf ppf "%a" Format.pp_print_text single
  | [prev; last] ->
      Format.fprintf
        ppf
        "%a@ or@ %a"
        Format.pp_print_text
        prev
        Format.pp_print_text
        last
  | first :: rest ->
      Format.fprintf
        ppf
        "%a,@ %a"
        Format.pp_print_text
        first
        print_enumeration
        rest
  | [] ->
      assert false

let collect_error_locations errs =
  let rec collect acc = function
    | Environment.Ecoproto_error
        ( Ill_formed_type (_, _, _)
        | No_such_entrypoint _
        | Duplicate_entrypoint _
        | Unreachable_entrypoint _
        | Runtime_contract_error (_, _)
        | Michelson_v1_primitives.Invalid_primitive_name (_, _)
        | Ill_typed_data (_, _, _)
        | Ill_typed_contract (_, _) )
      :: _
    | [] ->
        acc
    | Environment.Ecoproto_error
        ( Invalid_arity (loc, _, _, _)
        | Inconsistent_type_annotations (loc, _, _)
        | Unexpected_annotation loc
        | Ungrouped_annotations loc
        | Type_too_large (loc, _, _)
        | Invalid_namespace (loc, _, _, _)
        | Invalid_primitive (loc, _, _)
        | Invalid_kind (loc, _, _)
        | Duplicate_field (loc, _)
        | Unexpected_big_map loc
        | Unexpected_operation loc
        | Fail_not_in_tail_position loc
        | Undefined_binop (loc, _, _, _)
        | Undefined_unop (loc, _, _)
        | Bad_return (loc, _, _)
        | Bad_stack (loc, _, _, _)
        | Unmatched_branches (loc, _, _)
        | Self_in_lambda loc
        | Invalid_constant (loc, _, _)
        | Invalid_syntactic_constant (loc, _, _)
        | Invalid_contract (loc, _)
        | Comparable_type_expected (loc, _)
        | Overflow (loc, _)
        | Reject (loc, _, _) )
      :: rest ->
        collect (loc :: acc) rest
    | _ :: rest ->
        collect acc rest
  in
  collect [] errs

let report_errors ~details ~show_source ?parsed ppf errs =
  let rec print_trace locations errs =
    let print_loc ppf loc =
      match locations loc with
      | None ->
          Format.fprintf ppf "At (unshown) location %d, " loc
      | Some loc ->
          Format.fprintf
            ppf
            "%s,@ "
            (String.capitalize_ascii
               (Format.asprintf "%a" Micheline_parser.print_location loc))
    in
    let parsed_locations parsed loc =
      try
        let oloc =
          List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
        in
        let (ploc, _) = List.assoc oloc parsed.expansion_table in
        Some ploc
      with Not_found -> None
    in
    let print_source ppf (parsed, _hilights (* TODO *)) =
      let lines =
        String.split_on_char '\n' parsed.Michelson_v1_parser.source
      in
      let cols = String.length (string_of_int (List.length lines)) in
      Format.fprintf
        ppf
        "@[<v 0>%a@]"
        (Format.pp_print_list (fun ppf (i, l) ->
             Format.fprintf ppf "%0*d: %s" cols i l))
        (List.mapi (fun i l -> (i + 1, l)) lines)
    in
    match errs with
    | [] ->
        ()
    | Environment.Ecoproto_error
        (Michelson_v1_primitives.Invalid_primitive_name (expr, loc))
      :: rest ->
        let parsed =
          match parsed with
          | Some parsed ->
              if
                Micheline.strip_locations
                  (Michelson_v1_macros.unexpand_rec (Micheline.root expr))
                = parsed.Michelson_v1_parser.unexpanded
              then parsed
              else Michelson_v1_printer.unparse_invalid expr
          | None ->
              Michelson_v1_printer.unparse_invalid expr
        in
        let hilights = loc :: collect_error_locations rest in
        if show_source then
          Format.fprintf
            ppf
            "@[<hov 0>@[<hov 2>Invalid primitive:@ %a@]@]"
            print_source
            (parsed, hilights)
        else Format.fprintf ppf "Invalid primitive." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error (Ill_typed_data (name, expr, ty)) :: rest ->
        let parsed =
          match parsed with
          | Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
              parsed
          | Some _ | None ->
              Michelson_v1_printer.unparse_expression expr
        in
        let hilights = collect_error_locations rest in
        Format.fprintf
          ppf
          "@[<hov 0>@[<hov 2>Ill typed %adata:@ %a@]@ @[<hov 2>is not an \
           expression of type@ %a@]@]"
          (fun ppf -> function None -> () | Some s ->
                Format.fprintf ppf "%s " s)
          name
          print_source
          (parsed, hilights)
          print_ty
          ty ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error (No_such_entrypoint entrypoint) :: rest ->
        Format.fprintf ppf "Contract has no entrypoint named %s" entrypoint ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Duplicate_entrypoint entrypoint) :: rest ->
        Format.fprintf ppf "Contract has two entrypoints named %s" entrypoint ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Unreachable_entrypoint path) :: rest ->
        let path =
          String.concat
            "/"
            (List.map Michelson_v1_primitives.string_of_prim path)
        in
        Format.fprintf ppf "Entrypoint at path %s is not reachable" path ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Ill_formed_type (_, expr, loc)) :: rest ->
        let parsed =
          match parsed with
          | Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
              parsed
          | Some _ | None ->
              Michelson_v1_printer.unparse_expression expr
        in
        let hilights = loc :: collect_error_locations errs in
        if show_source then
          Format.fprintf
            ppf
            "@[<v 2>%aill formed type:@ %a@]"
            print_loc
            loc
            print_source
            (parsed, hilights)
        else Format.fprintf ppf "Ill formed type." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error (Ill_typed_contract (expr, type_map)) :: rest
      ->
        let parsed =
          match parsed with
          | Some parsed
            when (not details) && expr = parsed.Michelson_v1_parser.expanded ->
              parsed
          | Some _ | None ->
              Michelson_v1_printer.unparse_toplevel ~type_map expr
        in
        let hilights = collect_error_locations rest in
        if show_source then
          Format.fprintf
            ppf
            "@[<v 0>Ill typed contract:@,  %a@]"
            print_source
            (parsed, hilights)
        else Format.fprintf ppf "Ill typed contract." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error Apply.Gas_quota_exceeded_init_deserialize
      :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Not enough gas to deserialize the operation.@,\
           Injecting such a transaction could have you banned from mempools.@]" ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Cannot_serialize_error :: rest ->
        Format.fprintf
          ppf
          "Error too big to serialize within the provided gas bounds." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Deprecated_instruction prim) :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Use of deprecated instruction: %s@]"
          (Michelson_v1_primitives.string_of_prim prim) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Cannot_serialize_storage :: rest ->
        Format.fprintf
          ppf
          "Cannot serialize the resulting storage value within the provided \
           gas bounds." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Missing_field prim) :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Missing contract field: %s@]"
          (Michelson_v1_primitives.string_of_prim prim) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Duplicate_field (loc, prim)) :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>%aduplicate contract field: %s@]"
          print_loc
          loc
          (Michelson_v1_primitives.string_of_prim prim) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Unexpected_big_map loc) :: rest ->
        Format.fprintf
          ppf
          "%abig_map type not allowed inside another big_map"
          print_loc
          loc ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Unexpected_operation loc) :: rest ->
        Format.fprintf
          ppf
          "%aoperation type forbidden in parameter, storage and constants"
          print_loc
          loc ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Unexpected_contract loc) :: rest ->
        Format.fprintf
          ppf
          "%acontract type forbidden in storage and constants"
          print_loc
          loc ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Runtime_contract_error (contract, expr))
      :: rest ->
        let parsed =
          match parsed with
          | Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
              parsed
          | Some _ | None ->
              Michelson_v1_printer.unparse_toplevel expr
        in
        let hilights = collect_error_locations rest in
        Format.fprintf
          ppf
          "@[<v 2>Runtime error in contract %a:@ %a@]"
          Contract.pp
          contract
          print_source
          (parsed, hilights) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error (Apply.Internal_operation_replay op) :: rest
      ->
        Format.fprintf
          ppf
          "@[<v 2>Internal operation replay attempt:@,%a@]"
          Operation_result.pp_internal_operation
          op ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Gas.Gas_limit_too_high :: rest ->
        Format.fprintf
          ppf
          "Gas limit for the operation is out of the protocol hard bounds." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Gas.Block_quota_exceeded :: rest ->
        Format.fprintf
          ppf
          "Gas limit for the block exceeded during typechecking or execution." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Gas.Operation_quota_exceeded :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Gas limit exceeded during typechecking or execution.@,\
           Try again with a higher gas limit.@]" ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Fees.Operation_quota_exceeded :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Storage limit exceeded during typechecking or execution.@,\
           Try again with a higher storage limit.@]" ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | [Environment.Ecoproto_error (Script_interpreter.Bad_contract_parameter c)]
      ->
        Format.fprintf
          ppf
          "@[<v 0>Account %a is not a smart contract, it does not take \
           arguments.@,\
           The `-arg' flag should not be used when transferring to an \
           account.@]"
          Contract.pp
          c
    | Environment.Ecoproto_error err :: rest ->
        ( match err with
        | Script_interpreter.Bad_contract_parameter c ->
            Format.fprintf
              ppf
              "Invalid argument passed to contract %a."
              Contract.pp
              c
        | Invalid_arity (loc, name, exp, got) ->
            Format.fprintf
              ppf
              "%aprimitive %s expects %d arguments but is given %d."
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim name)
              exp
              got
        | Invalid_namespace (loc, name, exp, got) ->
            let human_namespace = function
              | Instr_namespace ->
                  ("an", "instruction")
              | Type_namespace ->
                  ("a", "type name")
              | Constant_namespace ->
                  ("a", "constant constructor")
              | Keyword_namespace ->
                  ("a", "keyword")
            in
            Format.fprintf
              ppf
              "@[%aunexpected %s %s, only %s %s can be used here."
              print_loc
              loc
              (snd (human_namespace got))
              (Michelson_v1_primitives.string_of_prim name)
              (fst (human_namespace exp))
              (snd (human_namespace exp))
        | Invalid_primitive (loc, exp, got) ->
            Format.fprintf
              ppf
              "@[%ainvalid primitive %s, only %a can be used here."
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim got)
              print_enumeration
              (List.map Michelson_v1_primitives.string_of_prim exp)
        | Invalid_kind (loc, exp, got) ->
            let human_kind = function
              | Seq_kind ->
                  ("a", "sequence")
              | Prim_kind ->
                  ("a", "primitive")
              | Int_kind ->
                  ("an", "int")
              | String_kind ->
                  ("a", "string")
              | Bytes_kind ->
                  ("a", "byte sequence")
            in
            Format.fprintf
              ppf
              "@[%aunexpected %s, only@ %a@ can be used here."
              print_loc
              loc
              (snd (human_kind got))
              print_enumeration
              (List.map
                 (fun k ->
                   let (a, n) = human_kind k in
                   a ^ " " ^ n)
                 exp)
        | Duplicate_map_keys (_, expr) ->
            Format.fprintf
              ppf
              "@[<v 2>Map literals cannot contain duplicate keys, however a \
               duplicate key was found:@ @[%a@]"
              print_expr
              expr
        | Unordered_map_keys (_, expr) ->
            Format.fprintf
              ppf
              "@[<v 2>Keys in a map literal must be in strictly ascending \
               order, but they were unordered in literal:@ @[%a@]"
              print_expr
              expr
        | Duplicate_set_values (_, expr) ->
            Format.fprintf
              ppf
              "@[<v 2>Set literals cannot contain duplicate values, however a \
               duplicate value was found:@ @[%a@]"
              print_expr
              expr
        | Unordered_set_values (_, expr) ->
            Format.fprintf
              ppf
              "@[<v 2>Values in a set literal must be in strictly ascending \
               order, but they were unordered in literal:@ @[%a@]"
              print_expr
              expr
        | Fail_not_in_tail_position loc ->
            Format.fprintf
              ppf
              "%aThe FAIL instruction must appear in a tail position."
              print_loc
              loc
        | Undefined_binop (loc, name, tya, tyb) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>%aoperator %s is undefined between@ %a@]@ \
               @[<hov 2>and@ %a.@]@]"
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim name)
              print_ty
              tya
              print_ty
              tyb
        | Undefined_unop (loc, name, ty) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]"
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim name)
              print_ty
              ty
        | Bad_return (loc, got, exp) ->
            Format.fprintf
              ppf
              "@[<v 2>%awrong stack type at end of body:@,\
               - @[<v 0>expected return stack type:@ %a,@]@,\
               - @[<v 0>actual stack type:@ %a.@]@]"
              print_loc
              loc
              (fun ppf -> print_stack_ty ppf)
              [(exp, [])]
              (fun ppf -> print_stack_ty ppf)
              got
        | Bad_stack (loc, name, depth, sty) ->
            Format.fprintf
              ppf
              "@[<hov 2>%awrong stack type for instruction %s:@ %a.@]"
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim name)
              (print_stack_ty ~depth)
              sty
        | Unmatched_branches (loc, sta, stb) ->
            Format.fprintf
              ppf
              "@[<v 2>%atwo branches don't end with the same stack type:@,\
               - @[<hov>first stack type:@ %a,@]@,\
               - @[<hov>other stack type:@ %a.@]@]"
              print_loc
              loc
              (fun ppf -> print_stack_ty ppf)
              sta
              (fun ppf -> print_stack_ty ppf)
              stb
        | Inconsistent_annotations (annot1, annot2) ->
            Format.fprintf
              ppf
              "@[<v 2>The two annotations do not match:@,\
               - @[<v>%s@]@,\
               - @[<v>%s@]@]"
              annot1
              annot2
        | Inconsistent_field_annotations (annot1, annot2) ->
            Format.fprintf
              ppf
              "@[<v 2>The field access annotation does not match:@,\
               - @[<v>%s@]@,\
               - @[<v>%s@]@]"
              annot1
              annot2
        | Inconsistent_type_annotations (loc, ty1, ty2) ->
            Format.fprintf
              ppf
              "@[<v 2>%athe two types contain incompatible annotations:@,\
               - @[<hov>%a@]@,\
               - @[<hov>%a@]@]"
              print_loc
              loc
              print_ty
              ty1
              print_ty
              ty2
        | Unexpected_annotation loc ->
            Format.fprintf ppf "@[<v 2>%aunexpected annotation." print_loc loc
        | Ungrouped_annotations loc ->
            Format.fprintf
              ppf
              "@[<v 2>%aAnnotations of the same kind must be grouped."
              print_loc
              loc
        | Type_too_large (loc, size, maximum_size) ->
            Format.fprintf
              ppf
              "@[<v 2>%atype size (%d) exceeded maximum type size (%d)."
              print_loc
              loc
              size
              maximum_size
        | Self_in_lambda loc ->
            Format.fprintf
              ppf
              "%aThe SELF instruction cannot appear in a lambda."
              print_loc
              loc
        | Bad_stack_length ->
            Format.fprintf ppf "Bad stack length."
        | Bad_stack_item lvl ->
            Format.fprintf ppf "Bad stack item %d." lvl
        | Invalid_constant (loc, got, exp) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid for type@ \
               %a.@]@]"
              print_loc
              loc
              print_expr
              got
              print_ty
              exp
        | Invalid_syntactic_constant (loc, got, exp) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid, \
               expected@ %s@]@]"
              print_loc
              loc
              print_expr
              got
              exp
        | Invalid_contract (loc, contract) ->
            Format.fprintf
              ppf
              "%ainvalid contract %a."
              print_loc
              loc
              Contract.pp
              contract
        | Comparable_type_expected (loc, ty) ->
            Format.fprintf ppf "%acomparable type expected." print_loc loc ;
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]"
              print_ty
              ty
        | Inconsistent_types (tya, tyb) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>Type@ %a@]@ @[<hov 2>is not compatible with \
               type@ %a.@]@]"
              print_ty
              tya
              print_ty
              tyb
        | Reject (loc, v, trace) ->
            Format.fprintf
              ppf
              "%ascript reached FAILWITH instruction@ @[<hov 2>with@ %a@]%a"
              print_loc
              loc
              print_expr
              v
              (fun ppf -> function None -> () | Some trace ->
                    Format.fprintf
                      ppf
                      "@,@[<v 2>trace@,%a@]"
                      print_execution_trace
                      trace)
              trace
        | Overflow (loc, trace) ->
            Format.fprintf
              ppf
              "%aunexpected arithmetic overflow%a"
              print_loc
              loc
              (fun ppf -> function None -> () | Some trace ->
                    Format.fprintf
                      ppf
                      "@,@[<v 2>trace@,%a@]"
                      print_execution_trace
                      trace)
              trace
        | err ->
            Format.fprintf ppf "%a" Environment.Error_monad.pp err ) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | err :: rest ->
        Format.fprintf ppf "%a" Error_monad.pp err ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
  in
  Format.fprintf ppf "@[<v 0>" ;
  print_trace (fun _ -> None) errs ;
  Format.fprintf ppf "@]"
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_micheline.

Import Tezos_protocol_alpha.Protocol.Script_tc_errors.

Import Tezos_protocol_alpha.Protocol.Script_interpreter.

Import Tezos_client_alpha.Michelson_v1_printer.

Definition print_ty
  (ppf : Stdlib.Format.formatter)
  (ty : Tezos_protocol_alpha.Protocol.Script_repr.expr) : unit :=
  Tezos_client_alpha.Michelson_v1_printer.print_expr_unwrapped ppf ty.

Definition print_var_annot (ppf : Stdlib.Format.formatter) (annot : list string)
  : unit :=
  Tezos_base__TzPervasives.List.iter
    (Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          (CamlinternalFormatBasics.Break "@ " % string 1 0)
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "@ %s" % string)) annot.

Definition print_stack_ty (op_star_o_p_t_star : option Z)
  : Stdlib.Format.formatter ->
    (list (Tezos_protocol_alpha.Protocol.Script_repr.expr * (list string))) ->
      unit :=
  let depth :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Stdlib.max_int
    end in
  fun ppf =>
    fun s =>
      let fix loop
        (depth : Z) (ppf : Stdlib.Format.formatter) (function_parameter :
        list (Tezos_protocol_alpha.Protocol.Script_repr.expr * (list string)))
        : unit :=
        match function_parameter with
        | [] => tt
        | _ =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "..." % string
                CamlinternalFormatBasics.End_of_format) "..." % string)
        | cons (last, annot) [] =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)) "%a%a" % string)
            print_ty last print_var_annot annot
        | cons (last, annot) rest =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Char_literal ":" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))))))
              "%a%a@ :@ %a" % string) print_ty last print_var_annot annot
            (loop (Z.sub depth 1)) rest
        end in
      match s with
      | [] =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "[]" % string
              CamlinternalFormatBasics.End_of_format) "[]" % string)
      | sty =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
              (CamlinternalFormatBasics.String_literal "[ " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " ]" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<hov 2>[ %a ]@]" % string) (loop depth) sty
      end.

Fixpoint print_enumeration
  (ppf : Stdlib.Format.formatter) (function_parameter : list string) : unit :=
  match function_parameter with
  | cons single [] =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Stdlib.Format.pp_print_text single
  | cons prev (cons last []) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "or" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))))
        "%a@ or@ %a" % string) Stdlib.Format.pp_print_text prev
      Stdlib.Format.pp_print_text last
  | cons first rest =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Char_literal "," % char
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)))) "%a,@ %a" % string)
      Stdlib.Format.pp_print_text first print_enumeration rest
  | [] => false
  end.

Definition collect_error_locations
  (errs : list Tezos_base__TzPervasives.Error_monad.error)
  : list Tezos_raw_protocol_alpha.Alpha_context.Script.location :=
  let fix collect
    (acc : list Tezos_raw_protocol_alpha.Alpha_context.Script.location)
    (function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
    : list Tezos_raw_protocol_alpha.Alpha_context.Script.location :=
    match function_parameter with
    |
      cons
        (Environment.Ecoproto_error
          (Ill_formed_type _ _ _ | No_such_entrypoint _ | Duplicate_entrypoint _
            | Unreachable_entrypoint _ | Runtime_contract_error _ _ |
            Michelson_v1_primitives.Invalid_primitive_name _ _ |
            Ill_typed_data _ _ _ | Ill_typed_contract _ _)) _ | [] => acc
    |
      cons
        (Environment.Ecoproto_error
          (Invalid_arity loc _ _ _ | Inconsistent_type_annotations loc _ _ |
            Unexpected_annotation loc | Ungrouped_annotations loc |
            Type_too_large loc _ _ | Invalid_namespace loc _ _ _ |
            Invalid_primitive loc _ _ | Invalid_kind loc _ _ |
            Duplicate_field loc _ | Unexpected_big_map loc |
            Unexpected_operation loc | Fail_not_in_tail_position loc |
            Undefined_binop loc _ _ _ | Undefined_unop loc _ _ |
            Bad_return loc _ _ | Bad_stack loc _ _ _ |
            Unmatched_branches loc _ _ | Self_in_lambda loc |
            Invalid_constant loc _ _ | Invalid_syntactic_constant loc _ _ |
            Invalid_contract loc _ | Comparable_type_expected loc _ |
            Overflow loc _ | Reject loc _ _)) rest =>
      collect (cons loc acc) rest
    | cons _ rest => collect acc rest
    end in
  collect [] errs.

Definition report_errors
  (details : bool) (show_source : bool)
  (parsed : option Tezos_client_alpha.Michelson_v1_parser.parsed)
  (ppf : Stdlib.Format.formatter)
  (errs : list Tezos_base__TzPervasives.Error_monad.error) : unit :=
  let fix print_trace
    (locations : Z -> option Tezos_micheline.Micheline_parser.location) (errs :
    list Tezos_base__TzPervasives.Error_monad.error) : unit :=
    let print_loc (ppf : Stdlib.Format.formatter) (loc : Z) : unit :=
      match locations loc with
      | None =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "At (unshown) location " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal ", " % string
                  CamlinternalFormatBasics.End_of_format)))
            "At (unshown) location %d, " % string) loc
      | Some loc =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "," % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  CamlinternalFormatBasics.End_of_format))) "%s,@ " % string)
          (Tezos_base__TzPervasives.String.capitalize_ascii
            (Stdlib.Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              Tezos_micheline.Micheline_parser.print_location loc))
      end in
    let parsed_locations
      (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed) (loc : Z)
      : option Tezos_micheline.Micheline_parser.location :=
      try in
    let print_source {A : Type}
      (ppf : Stdlib.Format.formatter) (function_parameter :
      Tezos_client_alpha.Michelson_v1_parser.parsed * A) : unit :=
      match function_parameter with
      | (parsed, _hilights) =>
        let lines :=
          Tezos_base__TzPervasives.String.split_on_char "010" % char
            (Michelson_v1_parser.source parsed) in
        let cols :=
          Tezos_base__TzPervasives.String.length
            (OCaml.Stdlib.string_of_int
              (Tezos_base__TzPervasives.List.length lines)) in
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 0>%a@]" % string)
          (Stdlib.Format.pp_print_list None
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | (i, l) =>
                  Stdlib.Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        (CamlinternalFormatBasics.Arg_padding
                          CamlinternalFormatBasics.Zeros)
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal ": " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.End_of_format)))
                      "%0*d: %s" % string) cols i l
                end))
          (Tezos_base__TzPervasives.List.mapi
            (fun i => fun l => ((Z.add i 1), l)) lines)
      end in
    match errs with
    | [] => tt
    |
      cons
        (Environment.Ecoproto_error
          (Michelson_v1_primitives.Invalid_primitive_name expr loc)) rest =>
      let parsed :=
        match parsed with
        | Some parsed =>
          if
            equiv_decb
              (Tezos_micheline.Micheline.strip_locations
                (Tezos_client_alpha.Michelson_v1_macros.unexpand_rec
                  (Tezos_micheline.Micheline.root expr)))
              (Michelson_v1_parser.unexpanded parsed) then
            parsed
          else
            Tezos_client_alpha.Michelson_v1_printer.unparse_invalid expr
        | None => Tezos_client_alpha.Michelson_v1_printer.unparse_invalid expr
        end in
      let hilights := cons loc (collect_error_locations rest) in
      if show_source then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Invalid primitive:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))))
            "@[<hov 0>@[<hov 2>Invalid primitive:@ %a@]@]" % string)
          print_source (parsed, hilights)
      else
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Invalid primitive." % string
              CamlinternalFormatBasics.End_of_format)
            "Invalid primitive." % string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace (parsed_locations parsed) rest
    | cons (Environment.Ecoproto_error (Ill_typed_data name expr ty)) rest =>
      let parsed :=
        match parsed with
        | Some _ | None =>
          Tezos_client_alpha.Michelson_v1_printer.unparse_expression expr
        end in
      let hilights := collect_error_locations rest in
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
              (CamlinternalFormatBasics.String_literal "Ill typed " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "data:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<hov 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<hov 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "is not an expression of type" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format)))))))))))))))
          "@[<hov 0>@[<hov 2>Ill typed %adata:@ %a@]@ @[<hov 2>is not an expression of type@ %a@]@]"
            % string)
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | None => tt
            | Some s =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal " " % char
                      CamlinternalFormatBasics.End_of_format)) "%s " % string) s
            end) name print_source (parsed, hilights) print_ty ty;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace (parsed_locations parsed) rest
    | cons (Environment.Ecoproto_error (No_such_entrypoint entrypoint)) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Contract has no entrypoint named " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format))
          "Contract has no entrypoint named %s" % string) entrypoint;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Duplicate_entrypoint entrypoint)) rest
      =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Contract has two entrypoints named " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format))
          "Contract has two entrypoints named %s" % string) entrypoint;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Unreachable_entrypoint path)) rest =>
      let path :=
        Tezos_base__TzPervasives.String.concat "/" % string
          (Tezos_base__TzPervasives.List.map
            Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
            path) in
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Entrypoint at path " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " is not reachable" % string
                CamlinternalFormatBasics.End_of_format)))
          "Entrypoint at path %s is not reachable" % string) path;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Ill_formed_type _ expr loc)) rest =>
      let parsed :=
        match parsed with
        | Some _ | None =>
          Tezos_client_alpha.Michelson_v1_printer.unparse_expression expr
        end in
      let hilights := cons loc (collect_error_locations errs) in
      if show_source then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "ill formed type:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@[<v 2>%aill formed type:@ %a@]" % string) print_loc loc
          print_source (parsed, hilights)
      else
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Ill formed type." % string
              CamlinternalFormatBasics.End_of_format)
            "Ill formed type." % string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace (parsed_locations parsed) rest
    | cons (Environment.Ecoproto_error (Ill_typed_contract expr type_map)) rest
      =>
      let parsed :=
        match parsed with
        | Some _ | None =>
          Tezos_client_alpha.Michelson_v1_printer.unparse_toplevel
            (Some type_map) expr
        end in
      let hilights := collect_error_locations rest in
      if show_source then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "Ill typed contract:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "  " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@[<v 0>Ill typed contract:@,  %a@]" % string) print_source
          (parsed, hilights)
      else
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Ill typed contract." % string
              CamlinternalFormatBasics.End_of_format)
            "Ill typed contract." % string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace (parsed_locations parsed) rest
    |
      cons
        (Environment.Ecoproto_error Apply.Gas_quota_exceeded_init_deserialize)
        rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Not enough gas to deserialize the operation." % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Injecting such a transaction could have you banned from mempools."
                    % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "@[<v 0>Not enough gas to deserialize the operation.@,Injecting such a transaction could have you banned from mempools.@]"
            % string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error Cannot_serialize_error) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Error too big to serialize within the provided gas bounds." %
              string CamlinternalFormatBasics.End_of_format)
          "Error too big to serialize within the provided gas bounds." % string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Deprecated_instruction prim)) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Use of deprecated instruction: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format))))
          "@[<v 0>Use of deprecated instruction: %s@]" % string)
        (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
          prim);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error Cannot_serialize_storage) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cannot serialize the resulting storage value within the provided gas bounds."
              % string CamlinternalFormatBasics.End_of_format)
          "Cannot serialize the resulting storage value within the provided gas bounds."
            % string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Missing_field prim)) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Missing contract field: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format))))
          "@[<v 0>Missing contract field: %s@]" % string)
        (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
          prim);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Duplicate_field loc prim)) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "duplicate contract field: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "@[<v 0>%aduplicate contract field: %s@]" % string) print_loc loc
        (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
          prim);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Unexpected_big_map loc)) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              "big_map type not allowed inside another big_map" % string
              CamlinternalFormatBasics.End_of_format))
          "%abig_map type not allowed inside another big_map" % string)
        print_loc loc;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Unexpected_operation loc)) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              "operation type forbidden in parameter, storage and constants" %
                string CamlinternalFormatBasics.End_of_format))
          "%aoperation type forbidden in parameter, storage and constants" %
            string) print_loc loc;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error (Unexpected_contract loc)) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              "contract type forbidden in storage and constants" % string
              CamlinternalFormatBasics.End_of_format))
          "%acontract type forbidden in storage and constants" % string)
        print_loc loc;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    |
      cons (Environment.Ecoproto_error (Runtime_contract_error contract expr))
        rest =>
      let parsed :=
        match parsed with
        | Some _ | None =>
          Tezos_client_alpha.Michelson_v1_printer.unparse_toplevel None expr
        end in
      let hilights := collect_error_locations rest in
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String_literal
              "Runtime error in contract " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal ":" % char
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))
          "@[<v 2>Runtime error in contract %a:@ %a@]" % string)
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp contract
        print_source (parsed, hilights);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace (parsed_locations parsed) rest
    |
      cons (Environment.Ecoproto_error (Apply.Internal_operation_replay op))
        rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String_literal
              "Internal operation replay attempt:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "@[<v 2>Internal operation replay attempt:@,%a@]" % string)
        Tezos_client_alpha.Operation_result.pp_internal_operation op;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error Gas.Gas_limit_too_high) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Gas limit for the operation is out of the protocol hard bounds." %
              string CamlinternalFormatBasics.End_of_format)
          "Gas limit for the operation is out of the protocol hard bounds." %
            string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error Gas.Block_quota_exceeded) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Gas limit for the block exceeded during typechecking or execution."
              % string CamlinternalFormatBasics.End_of_format)
          "Gas limit for the block exceeded during typechecking or execution." %
            string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error Gas.Operation_quota_exceeded) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Gas limit exceeded during typechecking or execution." % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Try again with a higher gas limit." % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "@[<v 0>Gas limit exceeded during typechecking or execution.@,Try again with a higher gas limit.@]"
            % string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons (Environment.Ecoproto_error Fees.Operation_quota_exceeded) rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Storage limit exceeded during typechecking or execution." %
                string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Try again with a higher storage limit." % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "@[<v 0>Storage limit exceeded during typechecking or execution.@,Try again with a higher storage limit.@]"
            % string);
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    |
      cons
        (Environment.Ecoproto_error
          (Script_interpreter.Bad_contract_parameter c)) [] =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal "Account " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  " is not a smart contract, it does not take arguments." %
                    string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "The `-arg' flag should not be used when transferring to an account."
                        % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))
          "@[<v 0>Account %a is not a smart contract, it does not take arguments.@,The `-arg' flag should not be used when transferring to an account.@]"
            % string) Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp c
    | cons (Environment.Ecoproto_error err) rest =>
      match err with
      | Script_interpreter.Bad_contract_parameter c =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Invalid argument passed to contract " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  CamlinternalFormatBasics.End_of_format)))
            "Invalid argument passed to contract %a." % string)
          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp c
      | Invalid_arity loc name exp got =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal "primitive " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " expects " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        " arguments but is given " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal "." % char
                            CamlinternalFormatBasics.End_of_format))))))))
            "%aprimitive %s expects %d arguments but is given %d." % string)
          print_loc loc
          (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
            name) exp got
      | Invalid_namespace loc name exp got =>
        let human_namespace
          (function_parameter :
          Tezos_protocol_alpha.Protocol.Script_tc_errors.namespace)
          : string * string :=
          match function_parameter with
          | Instr_namespace => ("an" % string, "instruction" % string)
          | Type_namespace => ("a" % string, "type name" % string)
          | Constant_namespace =>
            ("a" % string, "constant constructor" % string)
          | Keyword_namespace => ("a" % string, "keyword" % string)
          end in
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal "unexpected " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal " " % char
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          ", only " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.Char_literal " " % char
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " can be used here." % string
                                  CamlinternalFormatBasics.End_of_format)))))))))))
            "@[%aunexpected %s %s, only %s %s can be used here." % string)
          print_loc loc (snd (human_namespace got))
          (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
            name) (fst (human_namespace exp)) (snd (human_namespace exp))
      | Invalid_primitive loc exp got =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "invalid primitive " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal ", only " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " can be used here." % string
                          CamlinternalFormatBasics.End_of_format)))))))
            "@[%ainvalid primitive %s, only %a can be used here." % string)
          print_loc loc
          (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
            got) print_enumeration
          (Tezos_base__TzPervasives.List.map
            Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
            exp)
      | Invalid_kind loc exp got =>
        let human_kind
          (function_parameter :
          Tezos_protocol_alpha.Protocol.Script_tc_errors.kind)
          : string * string :=
          match function_parameter with
          | Seq_kind => ("a" % string, "sequence" % string)
          | Prim_kind => ("a" % string, "primitive" % string)
          | Int_kind => ("an" % string, "int" % string)
          | String_kind => ("a" % string, "string" % string)
          | Bytes_kind => ("a" % string, "byte sequence" % string)
          end in
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal "unexpected " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal ", only" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "can be used here." % string
                              CamlinternalFormatBasics.End_of_format)))))))))
            "@[%aunexpected %s, only@ %a@ can be used here." % string) print_loc
          loc (snd (human_kind got)) print_enumeration
          (Tezos_base__TzPervasives.List.map
            (fun k =>
              match human_kind k with
              | (a, n) => String.append a (String.append " " % string n)
              end) exp)
      | Duplicate_map_keys _ expr =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Map literals cannot contain duplicate keys, however a duplicate key was found:"
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@[<v 2>Map literals cannot contain duplicate keys, however a duplicate key was found:@ @[%a@]"
              % string) Tezos_client_alpha.Michelson_v1_printer.print_expr expr
      | Unordered_map_keys _ expr =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Keys in a map literal must be in strictly ascending order, but they were unordered in literal:"
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@[<v 2>Keys in a map literal must be in strictly ascending order, but they were unordered in literal:@ @[%a@]"
              % string) Tezos_client_alpha.Michelson_v1_printer.print_expr expr
      | Duplicate_set_values _ expr =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Set literals cannot contain duplicate values, however a duplicate value was found:"
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@[<v 2>Set literals cannot contain duplicate values, however a duplicate value was found:@ @[%a@]"
              % string) Tezos_client_alpha.Michelson_v1_printer.print_expr expr
      | Unordered_set_values _ expr =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Values in a set literal must be in strictly ascending order, but they were unordered in literal:"
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@[<v 2>Values in a set literal must be in strictly ascending order, but they were unordered in literal:@ @[%a@]"
              % string) Tezos_client_alpha.Michelson_v1_printer.print_expr expr
      | Fail_not_in_tail_position loc =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "The FAIL instruction must appear in a tail position." % string
                CamlinternalFormatBasics.End_of_format))
            "%aThe FAIL instruction must appear in a tail position." % string)
          print_loc loc
      | Undefined_binop loc name tya tyb =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "operator " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        " is undefined between" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<hov 2>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<hov 2>" % string))
                                  (CamlinternalFormatBasics.String_literal
                                    "and" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "." % char
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format)))))))))))))))))
            "@[<hov 0>@[<hov 2>%aoperator %s is undefined between@ %a@]@ @[<hov 2>and@ %a.@]@]"
              % string) print_loc loc
          (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
            name) print_ty tya print_ty tyb
      | Undefined_unop loc name ty =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "operator " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        " is undefined on" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))))))
            "@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]" % string)
          print_loc loc
          (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
            name) print_ty ty
      | Bad_return loc got exp =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "wrong stack type at end of body:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "- " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 0>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 0>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "expected return stack type:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal "," % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "- " % string
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 0>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 0>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "actual stack type:" % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                "." % char
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_box
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    CamlinternalFormatBasics.End_of_format))))))))))))))))))))
            "@[<v 2>%awrong stack type at end of body:@,- @[<v 0>expected return stack type:@ %a,@]@,- @[<v 0>actual stack type:@ %a.@]@]"
              % string) print_loc loc (fun ppf => print_stack_ty None ppf)
          (cons (exp, []) []) (fun ppf => print_stack_ty None ppf) got
      | Bad_stack loc name depth sty =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "wrong stack type for instruction " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal ":" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "." % char
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))))))
            "@[<hov 2>%awrong stack type for instruction %s:@ %a.@]" % string)
          print_loc loc
          (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.string_of_prim
            name) (print_stack_ty (Some depth)) sty
      | Unmatched_branches loc sta stb =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "two branches don't end with the same stack type:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "- " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<hov>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<hov>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "first stack type:" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal "," % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "- " % string
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<hov>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<hov>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "other stack type:" % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                "." % char
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_box
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    CamlinternalFormatBasics.End_of_format))))))))))))))))))))
            "@[<v 2>%atwo branches don't end with the same stack type:@,- @[<hov>first stack type:@ %a,@]@,- @[<hov>other stack type:@ %a.@]@]"
              % string) print_loc loc (fun ppf => print_stack_ty None ppf) sta
          (fun ppf => print_stack_ty None ppf) stb
      | Inconsistent_annotations annot1 annot2 =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "The two annotations do not match:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "- " % string
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v>" % string))
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "- " % string
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v>" % string))
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))
            "@[<v 2>The two annotations do not match:@,- @[<v>%s@]@,- @[<v>%s@]@]"
              % string) annot1 annot2
      | Inconsistent_field_annotations annot1 annot2 =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "The field access annotation does not match:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "- " % string
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v>" % string))
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "- " % string
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v>" % string))
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))
            "@[<v 2>The field access annotation does not match:@,- @[<v>%s@]@,- @[<v>%s@]@]"
              % string) annot1 annot2
      | Inconsistent_type_annotations loc ty1 ty2 =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "the two types contain incompatible annotations:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "- " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<hov>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<hov>" % string))
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "- " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<hov>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<hov>" % string))
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))
            "@[<v 2>%athe two types contain incompatible annotations:@,- @[<hov>%a@]@,- @[<hov>%a@]@]"
              % string) print_loc loc print_ty ty1 print_ty ty2
      | Unexpected_annotation loc =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "unexpected annotation." % string
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 2>%aunexpected annotation." % string) print_loc loc
      | Ungrouped_annotations loc =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "Annotations of the same kind must be grouped." % string
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 2>%aAnnotations of the same kind must be grouped." % string)
          print_loc loc
      | Type_too_large loc size maximum_size =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal "type size (" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal
                      ") exceeded maximum type size (" % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal ")." % string
                          CamlinternalFormatBasics.End_of_format)))))))
            "@[<v 2>%atype size (%d) exceeded maximum type size (%d)." % string)
          print_loc loc size maximum_size
      | Self_in_lambda loc =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "The SELF instruction cannot appear in a lambda." % string
                CamlinternalFormatBasics.End_of_format))
            "%aThe SELF instruction cannot appear in a lambda." % string)
          print_loc loc
      | Bad_stack_length =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Bad stack length." % string
              CamlinternalFormatBasics.End_of_format)
            "Bad stack length." % string)
      | Bad_stack_item lvl =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Bad stack item " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal "." % char
                  CamlinternalFormatBasics.End_of_format)))
            "Bad stack item %d." % string) lvl
      | Invalid_constant loc got exp =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "value" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<hov 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<hov 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "is invalid for type" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      "." % char
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format)))))))))))))))
            "@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid for type@ %a.@]@]"
              % string) print_loc loc
          Tezos_client_alpha.Michelson_v1_printer.print_expr got print_ty exp
      | Invalid_syntactic_constant loc got exp =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "value" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<hov 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<hov 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "is invalid, expected" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))
            "@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid, expected@ %s@]@]"
              % string) print_loc loc
          Tezos_client_alpha.Michelson_v1_printer.print_expr got exp
      | Invalid_contract loc contract =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "invalid contract " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format))))
            "%ainvalid contract %a." % string) print_loc loc
          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp contract
      | Comparable_type_expected loc ty =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "comparable type expected." % string
                CamlinternalFormatBasics.End_of_format))
            "%acomparable type expected." % string) print_loc loc;
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.String_literal "Type" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.String_literal
                            "is not comparable." % string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))))))
            "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]" % string)
          print_ty ty
      | Inconsistent_types tya tyb =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.String_literal "Type" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_box
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<hov 2>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<hov 2>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "is not compatible with type" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    "." % char
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))
            "@[<hov 0>@[<hov 2>Type@ %a@]@ @[<hov 2>is not compatible with type@ %a.@]@]"
              % string) print_ty tya print_ty tyb
      | Reject loc v trace =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "script reached FAILWITH instruction" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<hov 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<hov 2>" % string))
                    (CamlinternalFormatBasics.String_literal "with" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)))))))))
            "%ascript reached FAILWITH instruction@ @[<hov 2>with@ %a@]%a" %
              string) print_loc loc
          Tezos_client_alpha.Michelson_v1_printer.print_expr v
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              | None => tt
              | Some trace =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "trace" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))
                    "@,@[<v 2>trace@,%a@]" % string)
                  Tezos_client_alpha.Michelson_v1_printer.print_execution_trace
                  trace
              end) trace
      | Overflow loc trace =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "unexpected arithmetic overflow" % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))
            "%aunexpected arithmetic overflow%a" % string) print_loc loc
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              | None => tt
              | Some trace =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "trace" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))
                    "@,@[<v 2>trace@,%a@]" % string)
                  Tezos_client_alpha.Michelson_v1_printer.print_execution_trace
                  trace
              end) trace
      | err =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Tezos_protocol_alpha.Protocol.Environment.Error_monad.pp err
      end;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    | cons err rest =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) Tezos_base__TzPervasives.Error_monad.pp err;
      if nequiv_decb rest [] then
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              CamlinternalFormatBasics.End_of_format) "@," % string)
      else
        tt;
      print_trace locations rest
    end in
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 0>" % string
              CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
        CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string);
  print_trace
    (fun function_parameter =>
      match function_parameter with
      | _ => None
      end) errs;
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_lit
        CamlinternalFormatBasics.Close_box
        CamlinternalFormatBasics.End_of_format) "@]" % string).
src/proto_alpha/lib_client/michelson_v1_error_reporter.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val report_errors :
  details:bool ->
  show_source:bool ->
  ?parsed:Michelson_v1_parser.parsed ->
  Format.formatter ->
  Error_monad.error list ->
  unit
src/proto_alpha/lib_client/michelson_v1_error_reporter.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter report_errors :
bool ->
  bool ->
    (option Tezos_client_alpha.Michelson_v1_parser.parsed) ->
      Stdlib.Format.formatter ->
        (list Tezos_base__TzPervasives.Error_monad.error) -> unit.
src/proto_alpha/lib_client/michelson_v1_macros.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Tezos_micheline
open Micheline
module IntMap = Map.Make (Compare.Int)

type 'l node = ('l, string) Micheline.node

type error += Unexpected_macro_annotation of string

type error += Sequence_expected of string

type error += Invalid_arity of string * int * int

let rec check_letters str i j f =
  i > j || (f str.[i] && check_letters str (i + 1) j f)

let expand_caddadr original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len > 3
        && str.[0] = 'C'
        && str.[len - 1] = 'R'
        && check_letters str 1 (len - 2) (function
               | 'A' | 'D' ->
                   true
               | _ ->
                   false)
      then
        ( match args with
        | [] ->
            ok ()
        | _ :: _ ->
            error (Invalid_arity (str, List.length args, 0)) )
        >>? fun () ->
        let path_annot =
          List.filter (function "@%" | "@%%" -> true | _ -> false) annot
        in
        let rec parse i acc =
          if i = 0 then Seq (loc, acc)
          else
            let annot = if i = len - 2 then annot else path_annot in
            match str.[i] with
            | 'A' ->
                parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc)
            | 'D' ->
                parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc)
            | _ ->
                assert false
        in
        ok (Some (parse (len - 2) []))
      else ok None
  | _ ->
      ok None

let extract_field_annots annot =
  List.partition
    (fun a ->
      match a.[0] with
      | '%' ->
          true
      | _ ->
          false
      | exception Invalid_argument _ ->
          false)
    annot

let expand_set_caddadr original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len >= 7
        && String.sub str 0 5 = "SET_C"
        && str.[len - 1] = 'R'
        && check_letters str 5 (len - 2) (function
               | 'A' | 'D' ->
                   true
               | _ ->
                   false)
      then
        ( match args with
        | [] ->
            ok ()
        | _ :: _ ->
            error (Invalid_arity (str, List.length args, 0)) )
        >>? fun () ->
        ( match extract_field_annots annot with
        | ([], annot) ->
            ok (None, annot)
        | ([f], annot) ->
            ok (Some f, annot)
        | (_, _) ->
            error (Unexpected_macro_annotation str) )
        >>? fun (field_annot, annot) ->
        let rec parse i acc =
          if i = 4 then acc
          else
            let annot = if i = 5 then annot else [] in
            match str.[i] with
            | 'A' ->
                let acc =
                  Seq
                    ( loc,
                      [ Prim (loc, "DUP", [], []);
                        Prim
                          ( loc,
                            "DIP",
                            [Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])],
                            [] );
                        Prim (loc, "CDR", [], ["@%%"]);
                        Prim (loc, "SWAP", [], []);
                        Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
                in
                parse (i - 1) acc
            | 'D' ->
                let acc =
                  Seq
                    ( loc,
                      [ Prim (loc, "DUP", [], []);
                        Prim
                          ( loc,
                            "DIP",
                            [Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])],
                            [] );
                        Prim (loc, "CAR", [], ["@%%"]);
                        Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
                in
                parse (i - 1) acc
            | _ ->
                assert false
        in
        match str.[len - 2] with
        | 'A' ->
            let access_check =
              match field_annot with
              | None ->
                  []
              | Some f ->
                  [ Prim (loc, "DUP", [], []);
                    Prim (loc, "CAR", [], [f]);
                    Prim (loc, "DROP", [], []) ]
            in
            let encoding =
              [Prim (loc, "CDR", [], ["@%%"]); Prim (loc, "SWAP", [], [])]
            in
            let pair =
              [ Prim
                  ( loc,
                    "PAIR",
                    [],
                    [Option.unopt field_annot ~default:"%"; "%@"] ) ]
            in
            let init = Seq (loc, access_check @ encoding @ pair) in
            ok (Some (parse (len - 3) init))
        | 'D' ->
            let access_check =
              match field_annot with
              | None ->
                  []
              | Some f ->
                  [ Prim (loc, "DUP", [], []);
                    Prim (loc, "CDR", [], [f]);
                    Prim (loc, "DROP", [], []) ]
            in
            let encoding = [Prim (loc, "CAR", [], ["@%%"])] in
            let pair =
              [ Prim
                  ( loc,
                    "PAIR",
                    [],
                    ["%@"; Option.unopt field_annot ~default:"%"] ) ]
            in
            let init = Seq (loc, access_check @ encoding @ pair) in
            ok (Some (parse (len - 3) init))
        | _ ->
            assert false
      else ok None
  | _ ->
      ok None

let expand_map_caddadr original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len >= 7
        && String.sub str 0 5 = "MAP_C"
        && str.[len - 1] = 'R'
        && check_letters str 5 (len - 2) (function
               | 'A' | 'D' ->
                   true
               | _ ->
                   false)
      then
        ( match args with
        | [(Seq _ as code)] ->
            ok code
        | [_] ->
            error (Sequence_expected str)
        | [] | _ :: _ :: _ ->
            error (Invalid_arity (str, List.length args, 1)) )
        >>? fun code ->
        ( match extract_field_annots annot with
        | ([], annot) ->
            ok (None, annot)
        | ([f], annot) ->
            ok (Some f, annot)
        | (_, _) ->
            error (Unexpected_macro_annotation str) )
        >>? fun (field_annot, annot) ->
        let rec parse i acc =
          if i = 4 then acc
          else
            let annot = if i = 5 then annot else [] in
            match str.[i] with
            | 'A' ->
                let acc =
                  Seq
                    ( loc,
                      [ Prim (loc, "DUP", [], []);
                        Prim
                          ( loc,
                            "DIP",
                            [Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])],
                            [] );
                        Prim (loc, "CDR", [], ["@%%"]);
                        Prim (loc, "SWAP", [], []);
                        Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
                in
                parse (i - 1) acc
            | 'D' ->
                let acc =
                  Seq
                    ( loc,
                      [ Prim (loc, "DUP", [], []);
                        Prim
                          ( loc,
                            "DIP",
                            [Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])],
                            [] );
                        Prim (loc, "CAR", [], ["@%%"]);
                        Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
                in
                parse (i - 1) acc
            | _ ->
                assert false
        in
        let cr_annot =
          match field_annot with
          | None ->
              []
          | Some f ->
              ["@" ^ String.sub f 1 (String.length f - 1)]
        in
        match str.[len - 2] with
        | 'A' ->
            let init =
              Seq
                ( loc,
                  [ Prim (loc, "DUP", [], []);
                    Prim (loc, "CDR", [], ["@%%"]);
                    Prim
                      ( loc,
                        "DIP",
                        [Seq (loc, [Prim (loc, "CAR", [], cr_annot); code])],
                        [] );
                    Prim (loc, "SWAP", [], []);
                    Prim
                      ( loc,
                        "PAIR",
                        [],
                        [Option.unopt field_annot ~default:"%"; "%@"] ) ] )
            in
            ok (Some (parse (len - 3) init))
        | 'D' ->
            let init =
              Seq
                ( loc,
                  [ Prim (loc, "DUP", [], []);
                    Prim (loc, "CDR", [], cr_annot);
                    code;
                    Prim (loc, "SWAP", [], []);
                    Prim (loc, "CAR", [], ["@%%"]);
                    Prim
                      ( loc,
                        "PAIR",
                        [],
                        ["%@"; Option.unopt field_annot ~default:"%"] ) ] )
            in
            ok (Some (parse (len - 3) init))
        | _ ->
            assert false
      else ok None
  | _ ->
      ok None

exception Not_a_roman

let decimal_of_roman roman =
  (* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *)
  let arabic = ref 0 in
  let lastval = ref 0 in
  for i = String.length roman - 1 downto 0 do
    let n =
      match roman.[i] with
      | 'M' ->
          1000
      | 'D' ->
          500
      | 'C' ->
          100
      | 'L' ->
          50
      | 'X' ->
          10
      | 'V' ->
          5
      | 'I' ->
          1
      | _ ->
          raise_notrace Not_a_roman
    in
    if Compare.Int.(n < !lastval) then arabic := !arabic - n
    else arabic := !arabic + n ;
    lastval := n
  done ;
  !arabic

let dip ~loc ?(annot = []) depth instr =
  assert (depth >= 0) ;
  if depth = 1 then Prim (loc, "DIP", [instr], annot)
  else Prim (loc, "DIP", [Int (loc, Z.of_int depth); instr], annot)

let expand_deprecated_dxiiivp original =
  (* transparently expands deprecated macro [DI...IP] to instruction [DIP n] *)
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if len > 3 && str.[0] = 'D' && str.[len - 1] = 'P' then
        try
          let depth = decimal_of_roman (String.sub str 1 (len - 2)) in
          match args with
          | [(Seq (_, _) as arg)] ->
              ok @@ Some (dip ~loc ~annot depth arg)
          | [_] ->
              error (Sequence_expected str)
          | [] | _ :: _ :: _ ->
              error (Invalid_arity (str, List.length args, 1))
        with Not_a_roman -> ok None
      else ok None
  | _ ->
      ok None

exception Not_a_pair

type pair_item = A | I | P of int * pair_item * pair_item

let parse_pair_substr str ~len start =
  let rec parse ?left i =
    if i = len - 1 then raise_notrace Not_a_pair
    else if str.[i] = 'P' then
      let (next_i, l) = parse ~left:true (i + 1) in
      let (next_i, r) = parse ~left:false next_i in
      (next_i, P (i, l, r))
    else if str.[i] = 'A' && left = Some true then (i + 1, A)
    else if str.[i] = 'I' && left <> Some true then (i + 1, I)
    else raise_notrace Not_a_pair
  in
  let (last, ast) = parse start in
  if last <> len - 1 then raise_notrace Not_a_pair else ast

let unparse_pair_item ast =
  let rec unparse ast acc =
    match ast with
    | P (_, l, r) ->
        unparse r (unparse l ("P" :: acc))
    | A ->
        "A" :: acc
    | I ->
        "I" :: acc
  in
  List.rev ("R" :: unparse ast []) |> String.concat ""

let pappaiir_annots_pos ast annot =
  let rec find_annots_pos p_pos ast annots acc =
    match (ast, annots) with
    | (_, []) ->
        (annots, acc)
    | (P (i, left, right), _) ->
        let (annots, acc) = find_annots_pos i left annots acc in
        find_annots_pos i right annots acc
    | (A, a :: annots) ->
        let pos =
          match IntMap.find_opt p_pos acc with
          | None ->
              ([a], [])
          | Some (_, cdr) ->
              ([a], cdr)
        in
        (annots, IntMap.add p_pos pos acc)
    | (I, a :: annots) ->
        let pos =
          match IntMap.find_opt p_pos acc with
          | None ->
              ([], [a])
          | Some (car, _) ->
              (car, [a])
        in
        (annots, IntMap.add p_pos pos acc)
  in
  snd (find_annots_pos 0 ast annot IntMap.empty)

let expand_pappaiir original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len > 4
        && str.[0] = 'P'
        && str.[len - 1] = 'R'
        && check_letters str 1 (len - 2) (function
               | 'P' | 'A' | 'I' ->
                   true
               | _ ->
                   false)
      then
        try
          let (field_annots, annot) = extract_field_annots annot in
          let ast = parse_pair_substr str ~len 0 in
          let field_annots_pos = pappaiir_annots_pos ast field_annots in
          let rec parse p (depth, acc) =
            match p with
            | P (i, left, right) ->
                let annot =
                  match (i, IntMap.find_opt i field_annots_pos) with
                  | (0, None) ->
                      annot
                  | (_, None) ->
                      []
                  | (0, Some ([], cdr_annot)) ->
                      ("%" :: cdr_annot) @ annot
                  | (_, Some ([], cdr_annot)) ->
                      "%" :: cdr_annot
                  | (0, Some (car_annot, cdr_annot)) ->
                      car_annot @ cdr_annot @ annot
                  | (_, Some (car_annot, cdr_annot)) ->
                      car_annot @ cdr_annot
                in
                let acc =
                  if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc
                  else
                    dip ~loc depth (Seq (loc, [Prim (loc, "PAIR", [], annot)]))
                    :: acc
                in
                (depth, acc) |> parse left |> parse right
            | A | I ->
                (depth + 1, acc)
          in
          let (_, expanded) = parse ast (0, []) in
          ( match args with
          | [] ->
              ok ()
          | _ :: _ ->
              error (Invalid_arity (str, List.length args, 0)) )
          >>? fun () -> ok (Some (Seq (loc, expanded)))
        with Not_a_pair -> ok None
      else ok None
  | _ ->
      ok None

let expand_unpappaiir original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len >= 6
        && String.sub str 0 3 = "UNP"
        && str.[len - 1] = 'R'
        && check_letters str 3 (len - 2) (function
               | 'P' | 'A' | 'I' ->
                   true
               | _ ->
                   false)
      then
        try
          let unpair car_annot cdr_annot =
            Seq
              ( loc,
                [ Prim (loc, "DUP", [], []);
                  Prim (loc, "CAR", [], car_annot);
                  dip ~loc 1 (Seq (loc, [Prim (loc, "CDR", [], cdr_annot)])) ]
              )
          in
          let ast = parse_pair_substr str ~len 2 in
          let annots_pos = pappaiir_annots_pos ast annot in
          let rec parse p (depth, acc) =
            match p with
            | P (i, left, right) ->
                let (car_annot, cdr_annot) =
                  match IntMap.find_opt i annots_pos with
                  | None ->
                      ([], [])
                  | Some (car_annot, cdr_annot) ->
                      (car_annot, cdr_annot)
                in
                let acc =
                  if depth = 0 then unpair car_annot cdr_annot :: acc
                  else
                    dip ~loc depth (Seq (loc, [unpair car_annot cdr_annot]))
                    :: acc
                in
                (depth, acc) |> parse left |> parse right
            | A | I ->
                (depth + 1, acc)
          in
          let (_, rev_expanded) = parse ast (0, []) in
          let expanded = Seq (loc, List.rev rev_expanded) in
          ( match args with
          | [] ->
              ok ()
          | _ :: _ ->
              error (Invalid_arity (str, List.length args, 0)) )
          >>? fun () -> ok (Some expanded)
        with Not_a_pair -> ok None
      else ok None
  | _ ->
      ok None

exception Not_a_dup

let dupn loc nloc n annot =
  assert (n > 1) ;
  if n = 2 then
    (* keep the old expansion, shorter for [DUP 2] *)
    Seq
      ( loc,
        [ Prim (loc, "DIP", [Seq (loc, [Prim (nloc, "DUP", [], annot)])], []);
          Prim (loc, "SWAP", [], []) ] )
  else
    Seq
      ( loc,
        [ Prim
            ( loc,
              "DIP",
              [ Int (loc, Z.of_int (n - 1));
                Seq (loc, [Prim (loc, "DUP", [], annot)]) ],
              [] );
          Prim (loc, "DIG", [Int (nloc, Z.of_int n)], []) ] )

let expand_dupn original =
  match original with
  | Prim (loc, "DUP", [Int (nloc, n)], annot) ->
      ok (Some (dupn loc nloc (Z.to_int n) annot))
  | _ ->
      ok None

let expand_deprecated_duuuuup original =
  (* transparently expands deprecated macro [DU...UP] to [{ DIP n { DUP } ; DIG n }] *)
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len > 3
        && str.[0] = 'D'
        && str.[len - 1] = 'P'
        && check_letters str 1 (len - 2) (( = ) 'U')
      then
        ( match args with
        | [] ->
            ok ()
        | _ :: _ ->
            error (Invalid_arity (str, List.length args, 0)) )
        >>? fun () ->
        try
          let rec parse i =
            if i = 1 then dupn loc loc (len - 2) annot
            else if str.[i] = 'U' then parse (i - 1)
            else raise_notrace Not_a_dup
          in
          ok (Some (parse (len - 2)))
        with Not_a_dup -> ok None
      else ok None
  | _ ->
      ok None

let expand_compare original =
  let cmp loc is annot =
    let is =
      match List.rev_map (fun i -> Prim (loc, i, [], [])) is with
      | Prim (loc, i, args, _) :: r ->
          List.rev (Prim (loc, i, args, annot) :: r)
      | is ->
          List.rev is
    in
    ok (Some (Seq (loc, is)))
  in
  let ifcmp loc is l r annot =
    let is =
      List.map (fun i -> Prim (loc, i, [], [])) is
      @ [Prim (loc, "IF", [l; r], annot)]
    in
    ok (Some (Seq (loc, is)))
  in
  match original with
  | Prim (loc, "CMPEQ", [], annot) ->
      cmp loc ["COMPARE"; "EQ"] annot
  | Prim (loc, "CMPNEQ", [], annot) ->
      cmp loc ["COMPARE"; "NEQ"] annot
  | Prim (loc, "CMPLT", [], annot) ->
      cmp loc ["COMPARE"; "LT"] annot
  | Prim (loc, "CMPGT", [], annot) ->
      cmp loc ["COMPARE"; "GT"] annot
  | Prim (loc, "CMPLE", [], annot) ->
      cmp loc ["COMPARE"; "LE"] annot
  | Prim (loc, "CMPGE", [], annot) ->
      cmp loc ["COMPARE"; "GE"] annot
  | Prim
      ( _,
        (("CMPEQ" | "CMPNEQ" | "CMPLT" | "CMPGT" | "CMPLE" | "CMPGE") as str),
        args,
        [] ) ->
      error (Invalid_arity (str, List.length args, 0))
  | Prim (loc, "IFCMPEQ", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "EQ"] l r annot
  | Prim (loc, "IFCMPNEQ", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "NEQ"] l r annot
  | Prim (loc, "IFCMPLT", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "LT"] l r annot
  | Prim (loc, "IFCMPGT", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "GT"] l r annot
  | Prim (loc, "IFCMPLE", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "LE"] l r annot
  | Prim (loc, "IFCMPGE", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "GE"] l r annot
  | Prim (loc, "IFEQ", [l; r], annot) ->
      ifcmp loc ["EQ"] l r annot
  | Prim (loc, "IFNEQ", [l; r], annot) ->
      ifcmp loc ["NEQ"] l r annot
  | Prim (loc, "IFLT", [l; r], annot) ->
      ifcmp loc ["LT"] l r annot
  | Prim (loc, "IFGT", [l; r], annot) ->
      ifcmp loc ["GT"] l r annot
  | Prim (loc, "IFLE", [l; r], annot) ->
      ifcmp loc ["LE"] l r annot
  | Prim (loc, "IFGE", [l; r], annot) ->
      ifcmp loc ["GE"] l r annot
  | Prim
      ( _,
        ( ( "IFCMPEQ"
          | "IFCMPNEQ"
          | "IFCMPLT"
          | "IFCMPGT"
          | "IFCMPLE"
          | "IFCMPGE"
          | "IFEQ"
          | "IFNEQ"
          | "IFLT"
          | "IFGT"
          | "IFLE"
          | "IFGE" ) as str ),
        args,
        [] ) ->
      error (Invalid_arity (str, List.length args, 2))
  | Prim
      ( _,
        ( ( "IFCMPEQ"
          | "IFCMPNEQ"
          | "IFCMPLT"
          | "IFCMPGT"
          | "IFCMPLE"
          | "IFCMPGE"
          | "IFEQ"
          | "IFNEQ"
          | "IFLT"
          | "IFGT"
          | "IFLE"
          | "IFGE" ) as str ),
        [],
        _ :: _ ) ->
      error (Unexpected_macro_annotation str)
  | _ ->
      ok None

let expand_asserts original =
  let may_rename loc = function
    | [] ->
        Seq (loc, [])
    | annot ->
        Seq (loc, [Prim (loc, "RENAME", [], annot)])
  in
  let fail_false ?(annot = []) loc =
    [may_rename loc annot; Seq (loc, [Prim (loc, "FAIL", [], [])])]
  in
  let fail_true ?(annot = []) loc =
    [Seq (loc, [Prim (loc, "FAIL", [], [])]); may_rename loc annot]
  in
  match original with
  | Prim (loc, "ASSERT", [], []) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF", fail_false loc, [])]))
  | Prim (loc, "ASSERT_NONE", [], []) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_false loc, [])]))
  | Prim (loc, "ASSERT_SOME", [], annot) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_true ~annot loc, [])]))
  | Prim (loc, "ASSERT_LEFT", [], annot) ->
      ok
      @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_false ~annot loc, [])]))
  | Prim (loc, "ASSERT_RIGHT", [], annot) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_true ~annot loc, [])]))
  | Prim
      ( _,
        ( ( "ASSERT"
          | "ASSERT_NONE"
          | "ASSERT_SOME"
          | "ASSERT_LEFT"
          | "ASSERT_RIGHT" ) as str ),
        args,
        [] ) ->
      error (Invalid_arity (str, List.length args, 0))
  | Prim (_, (("ASSERT" | "ASSERT_NONE") as str), [], _ :: _) ->
      error (Unexpected_macro_annotation str)
  | Prim (loc, s, args, annot)
    when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> (
      ( match args with
      | [] ->
          ok ()
      | _ :: _ ->
          error (Invalid_arity (s, List.length args, 0)) )
      >>? fun () ->
      ( match annot with
      | _ :: _ ->
          error (Unexpected_macro_annotation s)
      | [] ->
          ok () )
      >>? fun () ->
      let remaining = String.(sub s 7 (length s - 7)) in
      let remaining_prim = Prim (loc, remaining, [], []) in
      match remaining with
      | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" ->
          ok
          @@ Some
               (Seq
                  (loc, [remaining_prim; Prim (loc, "IF", fail_false loc, [])]))
      | _ -> (
          expand_compare remaining_prim
          >|? function
          | None ->
              None
          | Some seq ->
              Some (Seq (loc, [seq; Prim (loc, "IF", fail_false loc, [])])) ) )
  | _ ->
      ok None

let expand_if_some = function
  | Prim (loc, "IF_SOME", [right; left], annot) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", [left; right], annot)]))
  | Prim (_, "IF_SOME", args, _annot) ->
      error (Invalid_arity ("IF_SOME", List.length args, 2))
  | _ ->
      ok @@ None

let expand_if_right = function
  | Prim (loc, "IF_RIGHT", [right; left], annot) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", [left; right], annot)]))
  | Prim (_, "IF_RIGHT", args, _annot) ->
      error (Invalid_arity ("IF_RIGHT", List.length args, 2))
  | _ ->
      ok @@ None

let expand_fail = function
  | Prim (loc, "FAIL", [], []) ->
      ok
      @@ Some
           (Seq
              ( loc,
                [Prim (loc, "UNIT", [], []); Prim (loc, "FAILWITH", [], [])] ))
  | _ ->
      ok @@ None

let expand original =
  let rec try_expansions = function
    | [] ->
        ok @@ original
    | expander :: expanders -> (
        expander original
        >>? function
        | None -> try_expansions expanders | Some rewritten -> ok rewritten )
  in
  try_expansions
    [ expand_caddadr;
      expand_set_caddadr;
      expand_map_caddadr;
      expand_deprecated_dxiiivp;
      (* expand_paaiair ; *)
      expand_pappaiir;
      (* expand_unpaaiair ; *)
      expand_unpappaiir;
      expand_deprecated_duuuuup;
      expand_dupn;
      expand_compare;
      expand_asserts;
      expand_if_some;
      expand_if_right;
      expand_fail ]

let expand_rec expr =
  let rec error_map (expanded, errors) f = function
    | [] ->
        (List.rev expanded, List.rev errors)
    | hd :: tl ->
        let (new_expanded, new_errors) = f hd in
        error_map
          (new_expanded :: expanded, List.rev_append new_errors errors)
          f
          tl
  in
  let error_map = error_map ([], []) in
  let rec expand_rec expr =
    match expand expr with
    | Ok expanded -> (
      match expanded with
      | Seq (loc, items) ->
          let (items, errors) = error_map expand_rec items in
          (Seq (loc, items), errors)
      | Prim (loc, name, args, annot) ->
          let (args, errors) = error_map expand_rec args in
          (Prim (loc, name, args, annot), errors)
      | (Int _ | String _ | Bytes _) as atom ->
          (atom, []) )
    | Error errors ->
        (expr, errors)
  in
  expand_rec expr

let unexpand_caddadr expanded =
  let rec rsteps acc = function
    | [] ->
        Some acc
    | Prim (_, "CAR", [], []) :: rest ->
        rsteps ("A" :: acc) rest
    | Prim (_, "CDR", [], []) :: rest ->
        rsteps ("D" :: acc) rest
    | _ ->
        None
  in
  match expanded with
  | Seq (loc, (Prim (_, "CAR", [], []) :: _ as nodes))
  | Seq (loc, (Prim (_, "CDR", [], []) :: _ as nodes)) -> (
    match rsteps [] nodes with
    | Some steps ->
        let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in
        Some (Prim (loc, name, [], []))
    | None ->
        None )
  | _ ->
      None

let unexpand_set_caddadr expanded =
  let rec steps acc annots = function
    | Seq
        ( loc,
          [ Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], _);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "A" :: acc, annots)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CAR", [], [field_annot]);
            Prim (_, "DROP", [], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "A" :: acc, field_annot :: annots)
    | Seq (loc, [Prim (_, "CAR", [], _); Prim (_, "PAIR", [], _)]) ->
        Some (loc, "D" :: acc, annots)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], [field_annot]);
            Prim (_, "DROP", [], []);
            Prim (_, "CAR", [], _);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "D" :: acc, field_annot :: annots)
    | Seq
        ( _,
          [ Prim (_, "DUP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim (_, "PAIR", [], pair_annots) ] ) ->
        let (_, pair_annots) = extract_field_annots pair_annots in
        steps ("A" :: acc) (List.rev_append pair_annots annots) sub
    | Seq
        ( _,
          [ Prim (_, "DUP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], _); sub])], []);
            Prim (_, "CAR", [], _);
            Prim (_, "PAIR", [], pair_annots) ] ) ->
        let (_, pair_annots) = extract_field_annots pair_annots in
        steps ("D" :: acc) (List.rev_append pair_annots annots) sub
    | _ ->
        None
  in
  match steps [] [] expanded with
  | Some (loc, steps, annots) ->
      let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in
      Some (Prim (loc, name, [], List.rev annots))
  | None ->
      None

let unexpand_map_caddadr expanded =
  let rec steps acc annots = function
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], []); code])], []);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "A" :: acc, annots, code)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim
              ( _,
                "DIP",
                [Seq (_, [Prim (_, "CAR", [], [field_annot]); code])],
                [] );
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "A" :: acc, field_annot :: annots, code)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], []);
            code;
            Prim (_, "SWAP", [], []);
            Prim (_, "CAR", [], _);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "D" :: acc, annots, code)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], [field_annot]);
            code;
            Prim (_, "SWAP", [], []);
            Prim (_, "CAR", [], _);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "D" :: acc, field_annot :: annots, code)
    | Seq
        ( _,
          [ Prim (_, "DUP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim (_, "PAIR", [], pair_annots) ] ) ->
        let (_, pair_annots) = extract_field_annots pair_annots in
        steps ("A" :: acc) (List.rev_append pair_annots annots) sub
    | Seq
        ( _,
          [ Prim (_, "DUP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], []); sub])], []);
            Prim (_, "CAR", [], []);
            Prim (_, "PAIR", [], pair_annots) ] ) ->
        let (_, pair_annots) = extract_field_annots pair_annots in
        steps ("D" :: acc) (List.rev_append pair_annots annots) sub
    | _ ->
        None
  in
  match steps [] [] expanded with
  | Some (loc, steps, annots, code) ->
      let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in
      Some (Prim (loc, name, [code], List.rev annots))
  | None ->
      None

let unexpand_deprecated_dxiiivp expanded =
  (* transparently turn the old expansion of deprecated [DI...IP] to [DIP n] *)
  match expanded with
  | Seq
      ( loc,
        [Prim (_, "DIP", [(Seq (_, [Prim (_, "DIP", [_], [])]) as sub)], [])]
      ) ->
      let rec count acc = function
        | Seq (_, [Prim (_, "DIP", [sub], [])]) ->
            count (acc + 1) sub
        | sub ->
            (acc, sub)
      in
      let (depth, sub) = count 1 sub in
      Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], []))
  | _ ->
      None

let unexpand_dupn expanded =
  match expanded with
  | Seq
      ( loc,
        [ Prim
            (_, "DIP", [Int (_, np); Seq (_, [Prim (_, "DUP", [], annot)])], []);
          Prim (_, "DIG", [Int (nloc, ng)], []) ] )
    when Z.equal np (Z.pred ng) ->
      Some (Prim (loc, "DUP", [Int (nloc, ng)], annot))
  | _ ->
      None

let unexpand_deprecated_duuuuup expanded =
  (* transparently turn the old expansion of deprecated [DU...UP] to [DUP n] *)
  let rec expand n = function
    | Seq (loc, [Prim (nloc, "DUP", [], annot)]) ->
        if n = 1 then None
        else Some (Prim (loc, "DUP", [Int (nloc, Z.of_int n)], annot))
    | Seq (_, [Prim (_, "DIP", [expanded'], []); Prim (_, "SWAP", [], [])]) ->
        expand (n + 1) expanded'
    | _ ->
        None
  in
  expand 1 expanded

let rec normalize_pair_item ?(right = false) = function
  | P (i, a, b) ->
      P (i, normalize_pair_item a, normalize_pair_item ~right:true b)
  | A when right ->
      I
  | A ->
      A
  | I ->
      I

let unexpand_pappaiir expanded =
  match expanded with
  | Seq (_, [Prim (_, "PAIR", [], [])]) ->
      Some expanded
  | Seq (loc, (_ :: _ as nodes)) -> (
      let rec exec stack nodes =
        match (nodes, stack) with
        | ([], _) ->
            stack
        (* support new expansion using [DIP n] *)
        | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest,
            a :: rstack )
          when Z.to_int n > 1 ->
            exec
              ( a
              :: exec
                   rstack
                   [ Prim
                       (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
                   ] )
              rest
        | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack)
          when Z.to_int n = 1 ->
            exec (a :: exec rstack sub) rest
        | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [])
          when Z.to_int n > 1 ->
            exec
              ( A
              :: exec
                   []
                   [ Prim
                       (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
                   ] )
              rest
        | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [])
          when Z.to_int n = 1 ->
            exec (A :: exec [] sub) rest
        (* support old expansion using [DIP] *)
        | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) ->
            exec (a :: exec rstack sub) rest
        | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) ->
            exec (A :: exec [] sub) rest
        | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) ->
            exec (P (0, a, b) :: rstack) rest
        | (Prim (_, "PAIR", [], []) :: rest, [a]) ->
            exec [P (0, a, I)] rest
        | (Prim (_, "PAIR", [], []) :: rest, []) ->
            exec [P (0, A, I)] rest
        | _ ->
            raise_notrace Not_a_pair
      in
      match exec [] nodes with
      | [] ->
          None
      | res :: _ ->
          let res = normalize_pair_item res in
          let name = unparse_pair_item res in
          Some (Prim (loc, name, [], []))
      | exception Not_a_pair ->
          None )
  | _ ->
      None

let unexpand_unpappaiir expanded =
  match expanded with
  | Seq (loc, (_ :: _ as nodes)) -> (
      let rec exec stack nodes =
        match (nodes, stack) with
        | ([], _) ->
            stack
        (* support new expansion using [DIP n] *)
        | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest,
            a :: rstack )
          when Z.to_int n > 1 ->
            exec
              ( a
              :: exec
                   rstack
                   [ Prim
                       (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
                   ] )
              rest
        | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack)
          when Z.to_int n = 1 ->
            exec (a :: exec rstack sub) rest
        | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [])
          when Z.to_int n > 1 ->
            exec
              ( A
              :: exec
                   []
                   [ Prim
                       (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
                   ] )
              rest
        | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [])
          when Z.to_int n = 1 ->
            exec (A :: exec [] sub) rest
        (* support old expansion using [DIP] *)
        | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) ->
            exec (a :: exec rstack sub) rest
        | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) ->
            exec (A :: exec [] sub) rest
        | ( Seq
              ( _,
                [ Prim (_, "DUP", [], []);
                  Prim (_, "CAR", [], []);
                  Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
              )
            :: rest,
            a :: b :: rstack ) ->
            exec (P (0, a, b) :: rstack) rest
        | ( Seq
              ( _,
                [ Prim (_, "DUP", [], []);
                  Prim (_, "CAR", [], []);
                  Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
              )
            :: rest,
            [a] ) ->
            exec [P (0, a, I)] rest
        | ( Seq
              ( _,
                [ Prim (_, "DUP", [], []);
                  Prim (_, "CAR", [], []);
                  Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
              )
            :: rest,
            [] ) ->
            exec [P (0, A, I)] rest
        | _ ->
            raise_notrace Not_a_pair
      in
      match exec [] (List.rev nodes) with
      | [] ->
          None
      | res :: _ ->
          let res = normalize_pair_item res in
          let name = "UN" ^ unparse_pair_item res in
          Some (Prim (loc, name, [], []))
      | exception Not_a_pair ->
          None )
  | _ ->
      None

let unexpand_compare expanded =
  match expanded with
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "EQ", [], annot)]) ->
      Some (Prim (loc, "CMPEQ", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "NEQ", [], annot)]) ->
      Some (Prim (loc, "CMPNEQ", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LT", [], annot)]) ->
      Some (Prim (loc, "CMPLT", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GT", [], annot)]) ->
      Some (Prim (loc, "CMPGT", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LE", [], annot)]) ->
      Some (Prim (loc, "CMPLE", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GE", [], annot)]) ->
      Some (Prim (loc, "CMPGE", [], annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "EQ", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPEQ", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "NEQ", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPNEQ", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "LT", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPLT", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "GT", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPGT", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "LE", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPLE", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "GE", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPGE", args, annot))
  | Seq (loc, [Prim (_, "EQ", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFEQ", args, annot))
  | Seq (loc, [Prim (_, "NEQ", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFNEQ", args, annot))
  | Seq (loc, [Prim (_, "LT", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFLT", args, annot))
  | Seq (loc, [Prim (_, "GT", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFGT", args, annot))
  | Seq (loc, [Prim (_, "LE", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFLE", args, annot))
  | Seq (loc, [Prim (_, "GE", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFGE", args, annot))
  | _ ->
      None

let unexpand_asserts expanded =
  match expanded with
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT", [], []))
  | Seq
      ( loc,
        [ Seq (_, [Prim (_, "COMPARE", [], []); Prim (_, comparison, [], [])]);
          Prim
            ( _,
              "IF",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], []))
  | Seq
      ( loc,
        [ Prim (_, comparison, [], []);
          Prim
            ( _,
              "IF",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_" ^ comparison, [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_NONE",
              [ Seq (_, [Prim (_, "RENAME", [], annot)]);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_NONE", [], annot))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_NONE",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_NONE", [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_NONE",
              [ Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] );
                Seq (_, []) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_SOME", [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_NONE",
              [ Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] );
                Seq (_, [Prim (_, "RENAME", [], annot)]) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_SOME", [], annot))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_LEFT",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_LEFT", [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_LEFT",
              [ Seq (_, [Prim (_, "RENAME", [], annot)]);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_LEFT", [], annot))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_LEFT",
              [ Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] );
                Seq (_, []) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_RIGHT", [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_LEFT",
              [ Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] );
                Seq (_, [Prim (_, "RENAME", [], annot)]) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_RIGHT", [], annot))
  | _ ->
      None

let unexpand_if_some = function
  | Seq (loc, [Prim (_, "IF_NONE", [left; right], annot)]) ->
      Some (Prim (loc, "IF_SOME", [right; left], annot))
  | _ ->
      None

let unexpand_if_right = function
  | Seq (loc, [Prim (_, "IF_LEFT", [left; right], annot)]) ->
      Some (Prim (loc, "IF_RIGHT", [right; left], annot))
  | _ ->
      None

let unexpand_fail = function
  | Seq (loc, [Prim (_, "UNIT", [], []); Prim (_, "FAILWITH", [], [])]) ->
      Some (Prim (loc, "FAIL", [], []))
  | _ ->
      None

let unexpand original =
  let try_unexpansions unexpanders =
    match
      List.fold_left
        (fun acc f ->
          match acc with
          | None ->
              f original
          | Some rewritten ->
              Some rewritten)
        None
        unexpanders
    with
    | None ->
        original
    | Some rewritten ->
        rewritten
  in
  try_unexpansions
    [ unexpand_asserts;
      unexpand_caddadr;
      unexpand_set_caddadr;
      unexpand_map_caddadr;
      unexpand_deprecated_dxiiivp;
      unexpand_pappaiir;
      unexpand_unpappaiir;
      unexpand_deprecated_duuuuup;
      unexpand_dupn;
      unexpand_compare;
      unexpand_if_some;
      unexpand_if_right;
      unexpand_fail ]

(*
   If an argument of Prim is a sequence, we do not want to unexpand
   its root in case the source already contains an expanded macro. In
   which case unexpansion would remove surrounding braces and generate
   ill-formed code.

   For example, DIIP { DIP { DUP }; SWAP } is not unexpandable but
   DIIP {{ DIP { DUP }; SWAP }} (note the double braces) is unexpanded
   to DIIP { DUUP }.

   unexpand_rec_but_root is the same as unexpand_rec but does not try
   to unexpand at root *)

let rec unexpand_rec expr = unexpand_rec_but_root (unexpand expr)

and unexpand_rec_but_root = function
  | Seq (loc, items) ->
      Seq (loc, List.map unexpand_rec items)
  | Prim (loc, name, args, annot) ->
      Prim (loc, name, List.map unexpand_rec_but_root args, annot)
  | (Int _ | String _ | Bytes _) as atom ->
      atom

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"michelson.macros.unexpected_annotation"
    ~title:"Unexpected annotation"
    ~description:
      "A macro had an annotation, but no annotation was permitted on this \
       macro."
    ~pp:(fun ppf -> Format.fprintf ppf "Unexpected annotation on macro %s.")
    (obj1 (req "macro_name" string))
    (function Unexpected_macro_annotation str -> Some str | _ -> None)
    (fun s -> Unexpected_macro_annotation s) ;
  register_error_kind
    `Permanent
    ~id:"michelson.macros.sequence_expected"
    ~title:"Macro expects a sequence"
    ~description:"An macro expects a sequence, but a sequence was not provided"
    ~pp:(fun ppf name ->
      Format.fprintf
        ppf
        "Macro %s expects a sequence, but did not receive one."
        name)
    (obj1 (req "macro_name" string))
    (function Sequence_expected name -> Some name | _ -> None)
    (fun name -> Sequence_expected name) ;
  register_error_kind
    `Permanent
    ~id:"michelson.macros.bas_arity"
    ~title:"Wrong number of arguments to macro"
    ~description:"A wrong number of arguments was provided to a macro"
    ~pp:(fun ppf (name, got, exp) ->
      Format.fprintf
        ppf
        "Macro %s expects %d arguments, was given %d."
        name
        exp
        got)
    (obj3
       (req "macro_name" string)
       (req "given_number_of_arguments" uint16)
       (req "expected_number_of_arguments" uint16))
    (function
      | Invalid_arity (name, got, exp) -> Some (name, got, exp) | _ -> None)
    (fun (name, got, exp) -> Invalid_arity (name, got, exp))
src/proto_alpha/lib_client/michelson_v1_macros.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_micheline.

Import Tezos_micheline.Micheline.

Definition node (l : Type) := Tezos_micheline.Micheline.node l string.

Fixpoint check_letters (str : string) (i : Z) (j : Z) (f : ascii -> bool)
  : bool :=
  orb (OCaml.Stdlib.gt i j)
    (andb (f (Tezos_base__TzPervasives.String.get str i))
      (check_letters str (Z.add i 1) j f)).

Definition expand_caddadr {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Prim loc str args annot =>
    let len := Tezos_base__TzPervasives.String.length str in
    if
      andb (OCaml.Stdlib.gt len 3)
        (andb
          (equiv_decb (Tezos_base__TzPervasives.String.get str 0) "C" % char)
          (andb
            (equiv_decb (Tezos_base__TzPervasives.String.get str (Z.sub len 1))
              "R" % char)
            (check_letters str 1 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "A" % char | "D" % char => true
                | _ => false
                end)))) then
      Tezos_base__TzPervasives.op_gt_gt_question
        match args with
        | [] => Tezos_base__TzPervasives.ok tt
        | cons _ _ =>
          Tezos_base__TzPervasives.error
            (Invalid_arity str (Tezos_base__TzPervasives.List.length args) 0)
        end
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let path_annot :=
              Tezos_base__TzPervasives.List.filter
                (fun function_parameter =>
                  match function_parameter with
                  | "@%" % string | "@%%" % string => true
                  | _ => false
                  end) annot in
            let fix parse
              (i : Z) (acc : list (Tezos_micheline.Micheline.node A string))
              : Tezos_micheline.Micheline.node A string :=
              if equiv_decb i 0 then
                Seq loc acc
              else
                let annot :=
                  if equiv_decb i (Z.sub len 2) then
                    annot
                  else
                    path_annot in
                match Tezos_base__TzPervasives.String.get str i with
                | "A" % char =>
                  parse (Z.sub i 1)
                    (cons (Prim loc "CAR" % string [] annot) acc)
                | "D" % char =>
                  parse (Z.sub i 1)
                    (cons (Prim loc "CDR" % string [] annot) acc)
                | _ => false
                end in
            Tezos_base__TzPervasives.ok (Some (parse (Z.sub len 2) []))
          end)
    else
      Tezos_base__TzPervasives.ok None
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition extract_field_annots (annot : list string)
  : (list string) * (list string) :=
  Tezos_base__TzPervasives.List.partition
    (fun a =>
      match Tezos_base__TzPervasives.String.get a 0 with
      | "%" % char => true
      | _ => false
      end) annot.

Definition expand_set_caddadr {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Prim loc str args annot =>
    let len := Tezos_base__TzPervasives.String.length str in
    if
      andb (OCaml.Stdlib.ge len 7)
        (andb
          (equiv_decb (Tezos_base__TzPervasives.String.sub str 0 5)
            "SET_C" % string)
          (andb
            (equiv_decb (Tezos_base__TzPervasives.String.get str (Z.sub len 1))
              "R" % char)
            (check_letters str 5 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "A" % char | "D" % char => true
                | _ => false
                end)))) then
      Tezos_base__TzPervasives.op_gt_gt_question
        match args with
        | [] => Tezos_base__TzPervasives.ok tt
        | cons _ _ =>
          Tezos_base__TzPervasives.error
            (Invalid_arity str (Tezos_base__TzPervasives.List.length args) 0)
        end
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_question
              match extract_field_annots annot with
              | ([], annot) => Tezos_base__TzPervasives.ok (None, annot)
              | (cons f [], annot) =>
                Tezos_base__TzPervasives.ok ((Some f), annot)
              | (_, _) =>
                Tezos_base__TzPervasives.error (Unexpected_macro_annotation str)
              end
              (fun function_parameter =>
                match function_parameter with
                | (field_annot, annot) =>
                  let fix parse
                    (i : Z) (acc : Tezos_micheline.Micheline.node A string)
                    : Tezos_micheline.Micheline.node A string :=
                    if equiv_decb i 4 then
                      acc
                    else
                      let annot :=
                        if equiv_decb i 5 then
                          annot
                        else
                          [] in
                      match Tezos_base__TzPervasives.String.get str i with
                      | "A" % char =>
                        let acc :=
                          Seq loc
                            (cons (Prim loc "DUP" % string [] [])
                              (cons
                                (Prim loc "DIP" % string
                                  (cons
                                    (Seq loc
                                      (cons
                                        (Prim loc "CAR" % string []
                                          (cons "@%%" % string []))
                                        (cons acc []))) []) [])
                                (cons
                                  (Prim loc "CDR" % string []
                                    (cons "@%%" % string []))
                                  (cons (Prim loc "SWAP" % string [] [])
                                    (cons
                                      (Prim loc "PAIR" % string []
                                        (cons "%@" % string
                                          (cons "%@" % string annot))) [])))))
                          in
                        parse (Z.sub i 1) acc
                      | "D" % char =>
                        let acc :=
                          Seq loc
                            (cons (Prim loc "DUP" % string [] [])
                              (cons
                                (Prim loc "DIP" % string
                                  (cons
                                    (Seq loc
                                      (cons
                                        (Prim loc "CDR" % string []
                                          (cons "@%%" % string []))
                                        (cons acc []))) []) [])
                                (cons
                                  (Prim loc "CAR" % string []
                                    (cons "@%%" % string []))
                                  (cons
                                    (Prim loc "PAIR" % string []
                                      (cons "%@" % string
                                        (cons "%@" % string annot))) [])))) in
                        parse (Z.sub i 1) acc
                      | _ => false
                      end in
                  match Tezos_base__TzPervasives.String.get str (Z.sub len 2)
                    with
                  | "A" % char =>
                    let access_check :=
                      match field_annot with
                      | None => []
                      | Some f =>
                        cons (Prim loc "DUP" % string [] [])
                          (cons (Prim loc "CAR" % string [] (cons f []))
                            (cons (Prim loc "DROP" % string [] []) []))
                      end in
                    let encoding :=
                      cons (Prim loc "CDR" % string [] (cons "@%%" % string []))
                        (cons (Prim loc "SWAP" % string [] []) []) in
                    let pair :=
                      cons
                        (Prim loc "PAIR" % string []
                          (cons
                            (Tezos_base__TzPervasives.Option.unopt "%" % string
                              field_annot) (cons "%@" % string []))) [] in
                    let init :=
                      Seq loc
                        (OCaml.Stdlib.app access_check
                          (OCaml.Stdlib.app encoding pair)) in
                    Tezos_base__TzPervasives.ok
                      (Some (parse (Z.sub len 3) init))
                  | "D" % char =>
                    let access_check :=
                      match field_annot with
                      | None => []
                      | Some f =>
                        cons (Prim loc "DUP" % string [] [])
                          (cons (Prim loc "CDR" % string [] (cons f []))
                            (cons (Prim loc "DROP" % string [] []) []))
                      end in
                    let encoding :=
                      cons (Prim loc "CAR" % string [] (cons "@%%" % string []))
                        [] in
                    let pair :=
                      cons
                        (Prim loc "PAIR" % string []
                          (cons "%@" % string
                            (cons
                              (Tezos_base__TzPervasives.Option.unopt
                                "%" % string field_annot) []))) [] in
                    let init :=
                      Seq loc
                        (OCaml.Stdlib.app access_check
                          (OCaml.Stdlib.app encoding pair)) in
                    Tezos_base__TzPervasives.ok
                      (Some (parse (Z.sub len 3) init))
                  | _ => false
                  end
                end)
          end)
    else
      Tezos_base__TzPervasives.ok None
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition expand_map_caddadr {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Prim loc str args annot =>
    let len := Tezos_base__TzPervasives.String.length str in
    if
      andb (OCaml.Stdlib.ge len 7)
        (andb
          (equiv_decb (Tezos_base__TzPervasives.String.sub str 0 5)
            "MAP_C" % string)
          (andb
            (equiv_decb (Tezos_base__TzPervasives.String.get str (Z.sub len 1))
              "R" % char)
            (check_letters str 5 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "A" % char | "D" % char => true
                | _ => false
                end)))) then
      Tezos_base__TzPervasives.op_gt_gt_question
        match args with
        | cons ((Seq _ _) as code) [] => Tezos_base__TzPervasives.ok code
        | cons _ [] => Tezos_base__TzPervasives.error (Sequence_expected str)
        | [] | cons _ (cons _ _) =>
          Tezos_base__TzPervasives.error
            (Invalid_arity str (Tezos_base__TzPervasives.List.length args) 1)
        end
        (fun code =>
          Tezos_base__TzPervasives.op_gt_gt_question
            match extract_field_annots annot with
            | ([], annot) => Tezos_base__TzPervasives.ok (None, annot)
            | (cons f [], annot) =>
              Tezos_base__TzPervasives.ok ((Some f), annot)
            | (_, _) =>
              Tezos_base__TzPervasives.error (Unexpected_macro_annotation str)
            end
            (fun function_parameter =>
              match function_parameter with
              | (field_annot, annot) =>
                let fix parse
                  (i : Z) (acc : Tezos_micheline.Micheline.node A string)
                  : Tezos_micheline.Micheline.node A string :=
                  if equiv_decb i 4 then
                    acc
                  else
                    let annot :=
                      if equiv_decb i 5 then
                        annot
                      else
                        [] in
                    match Tezos_base__TzPervasives.String.get str i with
                    | "A" % char =>
                      let acc :=
                        Seq loc
                          (cons (Prim loc "DUP" % string [] [])
                            (cons
                              (Prim loc "DIP" % string
                                (cons
                                  (Seq loc
                                    (cons
                                      (Prim loc "CAR" % string []
                                        (cons "@%%" % string [])) (cons acc [])))
                                  []) [])
                              (cons
                                (Prim loc "CDR" % string []
                                  (cons "@%%" % string []))
                                (cons (Prim loc "SWAP" % string [] [])
                                  (cons
                                    (Prim loc "PAIR" % string []
                                      (cons "%@" % string
                                        (cons "%@" % string annot))) []))))) in
                      parse (Z.sub i 1) acc
                    | "D" % char =>
                      let acc :=
                        Seq loc
                          (cons (Prim loc "DUP" % string [] [])
                            (cons
                              (Prim loc "DIP" % string
                                (cons
                                  (Seq loc
                                    (cons
                                      (Prim loc "CDR" % string []
                                        (cons "@%%" % string [])) (cons acc [])))
                                  []) [])
                              (cons
                                (Prim loc "CAR" % string []
                                  (cons "@%%" % string []))
                                (cons
                                  (Prim loc "PAIR" % string []
                                    (cons "%@" % string
                                      (cons "%@" % string annot))) [])))) in
                      parse (Z.sub i 1) acc
                    | _ => false
                    end in
                let cr_annot :=
                  match field_annot with
                  | None => []
                  | Some f =>
                    cons
                      (String.append "@" % string
                        (Tezos_base__TzPervasives.String.sub f 1
                          (Z.sub (Tezos_base__TzPervasives.String.length f) 1)))
                      []
                  end in
                match Tezos_base__TzPervasives.String.get str (Z.sub len 2) with
                | "A" % char =>
                  let init :=
                    Seq loc
                      (cons (Prim loc "DUP" % string [] [])
                        (cons
                          (Prim loc "CDR" % string [] (cons "@%%" % string []))
                          (cons
                            (Prim loc "DIP" % string
                              (cons
                                (Seq loc
                                  (cons (Prim loc "CAR" % string [] cr_annot)
                                    (cons code []))) []) [])
                            (cons (Prim loc "SWAP" % string [] [])
                              (cons
                                (Prim loc "PAIR" % string []
                                  (cons
                                    (Tezos_base__TzPervasives.Option.unopt
                                      "%" % string field_annot)
                                    (cons "%@" % string []))) []))))) in
                  Tezos_base__TzPervasives.ok (Some (parse (Z.sub len 3) init))
                | "D" % char =>
                  let init :=
                    Seq loc
                      (cons (Prim loc "DUP" % string [] [])
                        (cons (Prim loc "CDR" % string [] cr_annot)
                          (cons code
                            (cons (Prim loc "SWAP" % string [] [])
                              (cons
                                (Prim loc "CAR" % string []
                                  (cons "@%%" % string []))
                                (cons
                                  (Prim loc "PAIR" % string []
                                    (cons "%@" % string
                                      (cons
                                        (Tezos_base__TzPervasives.Option.unopt
                                          "%" % string field_annot) []))) []))))))
                    in
                  Tezos_base__TzPervasives.ok (Some (parse (Z.sub len 3) init))
                | _ => false
                end
              end))
    else
      Tezos_base__TzPervasives.ok None
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition decimal_of_roman (roman : string) : Z :=
  let arabic := Stdlib.ref 0 in
  let lastval := Stdlib.ref 0 in
  for;
  Stdlib.op_exclamation arabic.

Definition dip {A : Type}
  (loc : A) (op_star_o_p_t_star : option Tezos_micheline.Micheline.annot)
  : Z ->
    (Tezos_micheline.Micheline.node A string) ->
      Tezos_micheline.Micheline.node A string :=
  let annot :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun depth =>
    fun instr =>
      OCaml.Stdlib.ge depth 0;
      if equiv_decb depth 1 then
        Prim loc "DIP" % string (cons instr []) annot
      else
        Prim loc "DIP" % string
          (cons (Int loc (Z.of_int depth)) (cons instr [])) annot.

Definition expand_deprecated_dxiiivp {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Prim loc str args annot =>
    let len := Tezos_base__TzPervasives.String.length str in
    if
      andb (OCaml.Stdlib.gt len 3)
        (andb
          (equiv_decb (Tezos_base__TzPervasives.String.get str 0) "D" % char)
          (equiv_decb (Tezos_base__TzPervasives.String.get str (Z.sub len 1))
            "P" % char)) then
      try
    else
      Tezos_base__TzPervasives.ok None
  | _ => Tezos_base__TzPervasives.ok None
  end.

Inductive pair_item : Type :=
| A : pair_item
| I : pair_item
| P : Z -> pair_item -> pair_item -> pair_item.

Definition parse_pair_substr (str : string) (len : Z) (start : Z) : pair_item :=
  let fix parse (left : option bool) (i : Z) : Z * pair_item :=
    if equiv_decb i (Z.sub len 1) then
      Stdlib.raise_notrace Not_a_pair
    else
      if equiv_decb (Tezos_base__TzPervasives.String.get str i) "P" % char then
        match parse (Some true) (Z.add i 1) with
        | (next_i, l) =>
          match parse (Some false) next_i with
          | (next_i, r) => (next_i, (P i l r))
          end
        end
      else
        if
          andb
            (equiv_decb (Tezos_base__TzPervasives.String.get str i) "A" % char)
            (equiv_decb left (Some true)) then
          ((Z.add i 1), A)
        else
          if
            andb
              (equiv_decb (Tezos_base__TzPervasives.String.get str i) "I" % char)
              (nequiv_decb left (Some true)) then
            ((Z.add i 1), I)
          else
            Stdlib.raise_notrace Not_a_pair in
  match parse None start with
  | (last, ast) =>
    if nequiv_decb last (Z.sub len 1) then
      Stdlib.raise_notrace Not_a_pair
    else
      ast
  end.

Definition unparse_pair_item (ast : pair_item) : string :=
  let fix unparse (ast : pair_item) (acc : list string) : list string :=
    match ast with
    | P _ l r => unparse r (unparse l (cons "P" % string acc))
    | A => cons "A" % string acc
    | I => cons "I" % string acc
    end in
  OCaml.Stdlib.reverse_apply
    (Tezos_base__TzPervasives.List.rev (cons "R" % string (unparse ast [])))
    (Tezos_base__TzPervasives.String.concat "" % string).

Definition pappaiir_annots_pos {A : Type} (ast : pair_item) (annot : list A)
  : IntMap.t ((list A) * (list A)) :=
  let fix find_annots_pos {B : Type}
    (p_pos : IntMap.key) (ast : pair_item) (annots : list B) (acc :
    IntMap.t ((list B) * (list B)))
    : (list B) * (IntMap.t ((list B) * (list B))) :=
    match (ast, annots) with
    | (_, []) => (annots, acc)
    | (P i left right, _) =>
      match find_annots_pos i left annots acc with
      | (annots, acc) => find_annots_pos i right annots acc
      end
    | (A, cons a annots) =>
      let pos :=
        match IntMap.find_opt p_pos acc with
        | None => ((cons a []), [])
        | Some (_, cdr) => ((cons a []), cdr)
        end in
      (annots, (IntMap.add p_pos pos acc))
    | (I, cons a annots) =>
      let pos :=
        match IntMap.find_opt p_pos acc with
        | None => ([], (cons a []))
        | Some (car, _) => (car, (cons a []))
        end in
      (annots, (IntMap.add p_pos pos acc))
    end in
  snd (find_annots_pos 0 ast annot IntMap.empty).

Definition expand_pappaiir {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Prim loc str args annot =>
    let len := Tezos_base__TzPervasives.String.length str in
    if
      andb (OCaml.Stdlib.gt len 4)
        (andb
          (equiv_decb (Tezos_base__TzPervasives.String.get str 0) "P" % char)
          (andb
            (equiv_decb (Tezos_base__TzPervasives.String.get str (Z.sub len 1))
              "R" % char)
            (check_letters str 1 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "P" % char | "A" % char | "I" % char => true
                | _ => false
                end)))) then
      try
    else
      Tezos_base__TzPervasives.ok None
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition expand_unpappaiir {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Prim loc str args annot =>
    let len := Tezos_base__TzPervasives.String.length str in
    if
      andb (OCaml.Stdlib.ge len 6)
        (andb
          (equiv_decb (Tezos_base__TzPervasives.String.sub str 0 3)
            "UNP" % string)
          (andb
            (equiv_decb (Tezos_base__TzPervasives.String.get str (Z.sub len 1))
              "R" % char)
            (check_letters str 3 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "P" % char | "A" % char | "I" % char => true
                | _ => false
                end)))) then
      try
    else
      Tezos_base__TzPervasives.ok None
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition dupn {A : Type}
  (loc : A) (nloc : A) (n : Z) (annot : Tezos_micheline.Micheline.annot)
  : Tezos_micheline.Micheline.node A string :=
  OCaml.Stdlib.gt n 1;
  if equiv_decb n 2 then
    Seq loc
      (cons
        (Prim loc "DIP" % string
          (cons (Seq loc (cons (Prim nloc "DUP" % string [] annot) [])) []) [])
        (cons (Prim loc "SWAP" % string [] []) []))
  else
    Seq loc
      (cons
        (Prim loc "DIP" % string
          (cons (Int loc (Z.of_int (Z.sub n 1)))
            (cons (Seq loc (cons (Prim loc "DUP" % string [] annot) [])) [])) [])
        (cons (Prim loc "DIG" % string (cons (Int nloc (Z.of_int n)) []) []) [])).

Definition expand_dupn {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Prim loc "DUP" % string (cons (Int nloc n) []) annot =>
    Tezos_base__TzPervasives.ok (Some (dupn loc nloc (Z.to_int n) annot))
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition expand_deprecated_duuuuup {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Prim loc str args annot =>
    let len := Tezos_base__TzPervasives.String.length str in
    if
      andb (OCaml.Stdlib.gt len 3)
        (andb
          (equiv_decb (Tezos_base__TzPervasives.String.get str 0) "D" % char)
          (andb
            (equiv_decb (Tezos_base__TzPervasives.String.get str (Z.sub len 1))
              "P" % char)
            (check_letters str 1 (Z.sub len 2) (equiv_decb "U" % char)))) then
      Tezos_base__TzPervasives.op_gt_gt_question
        match args with
        | [] => Tezos_base__TzPervasives.ok tt
        | cons _ _ =>
          Tezos_base__TzPervasives.error
            (Invalid_arity str (Tezos_base__TzPervasives.List.length args) 0)
        end
        (fun function_parameter =>
          match function_parameter with
          | tt => try
          end)
    else
      Tezos_base__TzPervasives.ok None
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition expand_compare {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  let cmp {B C : Type}
    (loc : B) (is : list C) (annot : Tezos_micheline.Micheline.annot)
    : Tezos_base__TzPervasives.tzresult
      (option (Tezos_micheline.Micheline.node B C)) :=
    let is :=
      match Tezos_base__TzPervasives.List.rev_map (fun i => Prim loc i [] []) is
        with
      | cons (Prim loc i args _) r =>
        Tezos_base__TzPervasives.List.rev (cons (Prim loc i args annot) r)
      | is => Tezos_base__TzPervasives.List.rev is
      end in
    Tezos_base__TzPervasives.ok (Some (Seq loc is)) in
  let ifcmp {B : Type}
    (loc : B) (is : list string) (l : Tezos_micheline.Micheline.node B string)
    (r : Tezos_micheline.Micheline.node B string) (annot :
    Tezos_micheline.Micheline.annot)
    : Tezos_base__TzPervasives.tzresult
      (option (Tezos_micheline.Micheline.node B string)) :=
    let is :=
      OCaml.Stdlib.app
        (Tezos_base__TzPervasives.List.map (fun i => Prim loc i [] []) is)
        (cons (Prim loc "IF" % string (cons l (cons r [])) annot) []) in
    Tezos_base__TzPervasives.ok (Some (Seq loc is)) in
  match original with
  | Prim loc "CMPEQ" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "EQ" % string [])) annot
  | Prim loc "CMPNEQ" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "NEQ" % string [])) annot
  | Prim loc "CMPLT" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "LT" % string [])) annot
  | Prim loc "CMPGT" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "GT" % string [])) annot
  | Prim loc "CMPLE" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "LE" % string [])) annot
  | Prim loc "CMPGE" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "GE" % string [])) annot
  |
    Prim _
      (("CMPEQ" % string | "CMPNEQ" % string | "CMPLT" % string |
        "CMPGT" % string | "CMPLE" % string | "CMPGE" % string) as str) args []
    =>
    Tezos_base__TzPervasives.error
      (Invalid_arity str (Tezos_base__TzPervasives.List.length args) 0)
  | Prim loc "IFCMPEQ" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "COMPARE" % string (cons "EQ" % string [])) l r annot
  | Prim loc "IFCMPNEQ" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "COMPARE" % string (cons "NEQ" % string [])) l r annot
  | Prim loc "IFCMPLT" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "COMPARE" % string (cons "LT" % string [])) l r annot
  | Prim loc "IFCMPGT" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "COMPARE" % string (cons "GT" % string [])) l r annot
  | Prim loc "IFCMPLE" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "COMPARE" % string (cons "LE" % string [])) l r annot
  | Prim loc "IFCMPGE" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "COMPARE" % string (cons "GE" % string [])) l r annot
  | Prim loc "IFEQ" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "EQ" % string []) l r annot
  | Prim loc "IFNEQ" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "NEQ" % string []) l r annot
  | Prim loc "IFLT" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "LT" % string []) l r annot
  | Prim loc "IFGT" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "GT" % string []) l r annot
  | Prim loc "IFLE" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "LE" % string []) l r annot
  | Prim loc "IFGE" % string (cons l (cons r [])) annot =>
    ifcmp loc (cons "GE" % string []) l r annot
  |
    Prim _
      (("IFCMPEQ" % string | "IFCMPNEQ" % string | "IFCMPLT" % string |
        "IFCMPGT" % string | "IFCMPLE" % string | "IFCMPGE" % string |
        "IFEQ" % string | "IFNEQ" % string | "IFLT" % string | "IFGT" % string |
        "IFLE" % string | "IFGE" % string) as str) args [] =>
    Tezos_base__TzPervasives.error
      (Invalid_arity str (Tezos_base__TzPervasives.List.length args) 2)
  |
    Prim _
      (("IFCMPEQ" % string | "IFCMPNEQ" % string | "IFCMPLT" % string |
        "IFCMPGT" % string | "IFCMPLE" % string | "IFCMPGE" % string |
        "IFEQ" % string | "IFNEQ" % string | "IFLT" % string | "IFGT" % string |
        "IFLE" % string | "IFGE" % string) as str) [] (cons _ _) =>
    Tezos_base__TzPervasives.error (Unexpected_macro_annotation str)
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition expand_asserts {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  let may_rename {B : Type}
    (loc : B) (function_parameter : Tezos_micheline.Micheline.annot)
    : Tezos_micheline.Micheline.node B string :=
    match function_parameter with
    | [] => Seq loc []
    | annot => Seq loc (cons (Prim loc "RENAME" % string [] annot) [])
    end in
  let fail_false {B : Type}
    (op_star_o_p_t_star : option Tezos_micheline.Micheline.annot)
    : B -> list (Tezos_micheline.Micheline.node B string) :=
    let annot :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun loc =>
      cons (may_rename loc annot)
        (cons (Seq loc (cons (Prim loc "FAIL" % string [] []) [])) []) in
  let fail_true {B : Type}
    (op_star_o_p_t_star : option Tezos_micheline.Micheline.annot)
    : B -> list (Tezos_micheline.Micheline.node B string) :=
    let annot :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun loc =>
      cons (Seq loc (cons (Prim loc "FAIL" % string [] []) []))
        (cons (may_rename loc annot) []) in
  match original with
  | Prim loc "ASSERT" % string [] [] =>
    apply Tezos_base__TzPervasives.ok
      (Some
        (Seq loc (cons (Prim loc "IF" % string (fail_false None loc) []) [])))
  | Prim loc "ASSERT_NONE" % string [] [] =>
    apply Tezos_base__TzPervasives.ok
      (Some
        (Seq loc
          (cons (Prim loc "IF_NONE" % string (fail_false None loc) []) [])))
  | Prim loc "ASSERT_SOME" % string [] annot =>
    apply Tezos_base__TzPervasives.ok
      (Some
        (Seq loc
          (cons (Prim loc "IF_NONE" % string (fail_true (Some annot) loc) []) [])))
  | Prim loc "ASSERT_LEFT" % string [] annot =>
    apply Tezos_base__TzPervasives.ok
      (Some
        (Seq loc
          (cons (Prim loc "IF_LEFT" % string (fail_false (Some annot) loc) [])
            [])))
  | Prim loc "ASSERT_RIGHT" % string [] annot =>
    apply Tezos_base__TzPervasives.ok
      (Some
        (Seq loc
          (cons (Prim loc "IF_LEFT" % string (fail_true (Some annot) loc) []) [])))
  |
    Prim _
      (("ASSERT" % string | "ASSERT_NONE" % string | "ASSERT_SOME" % string |
        "ASSERT_LEFT" % string | "ASSERT_RIGHT" % string) as str) args [] =>
    Tezos_base__TzPervasives.error
      (Invalid_arity str (Tezos_base__TzPervasives.List.length args) 0)
  | Prim _ (("ASSERT" % string | "ASSERT_NONE" % string) as str) [] (cons _ _)
    => Tezos_base__TzPervasives.error (Unexpected_macro_annotation str)
  | _ => Tezos_base__TzPervasives.ok None
  end.

Definition expand_if_some {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match function_parameter with
  | Prim loc "IF_SOME" % string (cons right (cons left [])) annot =>
    apply Tezos_base__TzPervasives.ok
      (Some
        (Seq loc
          (cons (Prim loc "IF_NONE" % string (cons left (cons right [])) annot)
            [])))
  | Prim _ "IF_SOME" % string args _annot =>
    Tezos_base__TzPervasives.error
      (Invalid_arity "IF_SOME" % string
        (Tezos_base__TzPervasives.List.length args) 2)
  | _ => apply Tezos_base__TzPervasives.ok None
  end.

Definition expand_if_right {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match function_parameter with
  | Prim loc "IF_RIGHT" % string (cons right (cons left [])) annot =>
    apply Tezos_base__TzPervasives.ok
      (Some
        (Seq loc
          (cons (Prim loc "IF_LEFT" % string (cons left (cons right [])) annot)
            [])))
  | Prim _ "IF_RIGHT" % string args _annot =>
    Tezos_base__TzPervasives.error
      (Invalid_arity "IF_RIGHT" % string
        (Tezos_base__TzPervasives.List.length args) 2)
  | _ => apply Tezos_base__TzPervasives.ok None
  end.

Definition expand_fail {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match function_parameter with
  | Prim loc "FAIL" % string [] [] =>
    apply Tezos_base__TzPervasives.ok
      (Some
        (Seq loc
          (cons (Prim loc "UNIT" % string [] [])
            (cons (Prim loc "FAILWITH" % string [] []) []))))
  | _ => apply Tezos_base__TzPervasives.ok None
  end.

Definition expand {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult (Tezos_micheline.Micheline.node A string) :=
  let fix try_expansions
    (function_parameter :
    list
      ((Tezos_micheline.Micheline.node A string) ->
        Tezos_base__TzPervasives.tzresult
          (option (Tezos_micheline.Micheline.node A string))))
    : Tezos_base__TzPervasives.tzresult
      (Tezos_micheline.Micheline.node A string) :=
    match function_parameter with
    | [] => apply Tezos_base__TzPervasives.ok original
    | cons expander expanders =>
      Tezos_base__TzPervasives.op_gt_gt_question (expander original)
        (fun function_parameter =>
          match function_parameter with
          | None => try_expansions expanders
          | Some rewritten => Tezos_base__TzPervasives.ok rewritten
          end)
    end in
  try_expansions
    (cons expand_caddadr
      (cons expand_set_caddadr
        (cons expand_map_caddadr
          (cons expand_deprecated_dxiiivp
            (cons expand_pappaiir
              (cons expand_unpappaiir
                (cons expand_deprecated_duuuuup
                  (cons expand_dupn
                    (cons expand_compare
                      (cons expand_asserts
                        (cons expand_if_some
                          (cons expand_if_right (cons expand_fail []))))))))))))).

Definition expand_rec {A : Type}
  (expr : Tezos_micheline.Micheline.node A string)
  : (Tezos_micheline.Micheline.node A string) *
    (list Tezos_base__TzPervasives.error) :=
  let fix error_map {B C D : Type} (function_parameter : (list B) * (list C))
    : (D -> B * (list C)) -> (list D) -> (list B) * (list C) :=
    match function_parameter with
    | (expanded, errors) =>
      fun f =>
        fun function_parameter =>
          match function_parameter with
          | [] =>
            ((Tezos_base__TzPervasives.List.rev expanded),
              (Tezos_base__TzPervasives.List.rev errors))
          | cons hd tl =>
            match f hd with
            | (new_expanded, new_errors) =>
              error_map
                ((cons new_expanded expanded),
                  (Tezos_base__TzPervasives.List.rev_append new_errors errors))
                f tl
            end
          end
    end in
  let error_map := error_map ([], []) in
  let fix expand_rec (expr : Tezos_micheline.Micheline.node A string)
    : (Tezos_micheline.Micheline.node A string) *
      (list Tezos_base__TzPervasives.error) :=
    match expand expr with
    | inl expanded =>
      match expanded with
      | Seq loc items =>
        match error_map expand_rec items with
        | (items, errors) => ((Seq loc items), errors)
        end
      | Prim loc name args annot =>
        match error_map expand_rec args with
        | (args, errors) => ((Prim loc name args annot), errors)
        end
      | (Int _ _ | String _ _ | Bytes _ _) as atom => (atom, [])
      end
    | inr errors => (expr, errors)
    end in
  expand_rec expr.

Definition unexpand_caddadr {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  let fix rsteps {B : Type}
    (acc : list string) (function_parameter :
    list (Tezos_micheline.Micheline.node B string)) : option (list string) :=
    match function_parameter with
    | [] => Some acc
    | cons (Prim _ "CAR" % string [] []) rest =>
      rsteps (cons "A" % string acc) rest
    | cons (Prim _ "CDR" % string [] []) rest =>
      rsteps (cons "D" % string acc) rest
    | _ => None
    end in
  match expanded with
  |
    Seq loc ((cons (Prim _ "CAR" % string [] []) _) as nodes) |
      Seq loc ((cons (Prim _ "CDR" % string [] []) _) as nodes) =>
    match rsteps [] nodes with
    | Some steps =>
      let name :=
        Tezos_base__TzPervasives.String.concat "" % string
          (cons "C" % string
            (Tezos_base__TzPervasives.List.rev (cons "R" % string steps))) in
      Some (Prim loc name [] [])
    | None => None
    end
  | _ => None
  end.

Definition unexpand_set_caddadr {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  let fix steps {B : Type}
    (acc : list string) (annots : list string) (function_parameter :
    Tezos_micheline.Micheline.node B string)
    : option (B * (list string) * (list string)) :=
    match function_parameter with
    |
      Seq loc
        (cons (Prim _ "CDR" % string [] _)
          (cons (Prim _ "SWAP" % string [] _)
            (cons (Prim _ "PAIR" % string [] _) []))) =>
      Some (loc, (cons "A" % string acc), annots)
    |
      Seq loc
        (cons (Prim _ "DUP" % string [] [])
          (cons (Prim _ "CAR" % string [] (cons field_annot []))
            (cons (Prim _ "DROP" % string [] [])
              (cons (Prim _ "CDR" % string [] _)
                (cons (Prim _ "SWAP" % string [] [])
                  (cons (Prim _ "PAIR" % string [] _) [])))))) =>
      Some (loc, (cons "A" % string acc), (cons field_annot annots))
    |
      Seq loc
        (cons (Prim _ "CAR" % string [] _)
          (cons (Prim _ "PAIR" % string [] _) [])) =>
      Some (loc, (cons "D" % string acc), annots)
    |
      Seq loc
        (cons (Prim _ "DUP" % string [] [])
          (cons (Prim _ "CDR" % string [] (cons field_annot []))
            (cons (Prim _ "DROP" % string [] [])
              (cons (Prim _ "CAR" % string [] _)
                (cons (Prim _ "PAIR" % string [] _) []))))) =>
      Some (loc, (cons "D" % string acc), (cons field_annot annots))
    |
      Seq _
        (cons (Prim _ "DUP" % string [] [])
          (cons
            (Prim _ "DIP" % string
              (cons (Seq _ (cons (Prim _ "CAR" % string [] _) (cons sub []))) [])
              [])
            (cons (Prim _ "CDR" % string [] _)
              (cons (Prim _ "SWAP" % string [] [])
                (cons (Prim _ "PAIR" % string [] pair_annots) []))))) =>
      match extract_field_annots pair_annots with
      | (_, pair_annots) =>
        steps (cons "A" % string acc)
          (Tezos_base__TzPervasives.List.rev_append pair_annots annots) sub
      end
    |
      Seq _
        (cons (Prim _ "DUP" % string [] [])
          (cons
            (Prim _ "DIP" % string
              (cons (Seq _ (cons (Prim _ "CDR" % string [] _) (cons sub []))) [])
              [])
            (cons (Prim _ "CAR" % string [] _)
              (cons (Prim _ "PAIR" % string [] pair_annots) [])))) =>
      match extract_field_annots pair_annots with
      | (_, pair_annots) =>
        steps (cons "D" % string acc)
          (Tezos_base__TzPervasives.List.rev_append pair_annots annots) sub
      end
    | _ => None
    end in
  match steps [] [] expanded with
  | Some (loc, steps, annots) =>
    let name :=
      Tezos_base__TzPervasives.String.concat "" % string
        (cons "SET_C" % string
          (Tezos_base__TzPervasives.List.rev (cons "R" % string steps))) in
    Some (Prim loc name [] (Tezos_base__TzPervasives.List.rev annots))
  | None => None
  end.

Definition unexpand_map_caddadr {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  let fix steps {B : Type}
    (acc : list string) (annots : list string) (function_parameter :
    Tezos_micheline.Micheline.node B string)
    : option
      (B * (list string) * (list string) *
        (Tezos_micheline.Micheline.node B string)) :=
    match function_parameter with
    |
      Seq loc
        (cons (Prim _ "DUP" % string [] [])
          (cons (Prim _ "CDR" % string [] _)
            (cons (Prim _ "SWAP" % string [] [])
              (cons
                (Prim _ "DIP" % string
                  (cons
                    (Seq _ (cons (Prim _ "CAR" % string [] []) (cons code [])))
                    []) []) (cons (Prim _ "PAIR" % string [] _) []))))) =>
      Some (loc, (cons "A" % string acc), annots, code)
    |
      Seq loc
        (cons (Prim _ "DUP" % string [] [])
          (cons (Prim _ "CDR" % string [] _)
            (cons (Prim _ "SWAP" % string [] [])
              (cons
                (Prim _ "DIP" % string
                  (cons
                    (Seq _
                      (cons (Prim _ "CAR" % string [] (cons field_annot []))
                        (cons code []))) []) [])
                (cons (Prim _ "PAIR" % string [] _) []))))) =>
      Some (loc, (cons "A" % string acc), (cons field_annot annots), code)
    |
      Seq loc
        (cons (Prim _ "DUP" % string [] [])
          (cons (Prim _ "CDR" % string [] [])
            (cons code
              (cons (Prim _ "SWAP" % string [] [])
                (cons (Prim _ "CAR" % string [] _)
                  (cons (Prim _ "PAIR" % string [] _) [])))))) =>
      Some (loc, (cons "D" % string acc), annots, code)
    |
      Seq loc
        (cons (Prim _ "DUP" % string [] [])
          (cons (Prim _ "CDR" % string [] (cons field_annot []))
            (cons code
              (cons (Prim _ "SWAP" % string [] [])
                (cons (Prim _ "CAR" % string [] _)
                  (cons (Prim _ "PAIR" % string [] _) [])))))) =>
      Some (loc, (cons "D" % string acc), (cons field_annot annots), code)
    |
      Seq _
        (cons (Prim _ "DUP" % string [] [])
          (cons
            (Prim _ "DIP" % string
              (cons (Seq _ (cons (Prim _ "CAR" % string [] _) (cons sub []))) [])
              [])
            (cons (Prim _ "CDR" % string [] _)
              (cons (Prim _ "SWAP" % string [] [])
                (cons (Prim _ "PAIR" % string [] pair_annots) []))))) =>
      match extract_field_annots pair_annots with
      | (_, pair_annots) =>
        steps (cons "A" % string acc)
          (Tezos_base__TzPervasives.List.rev_append pair_annots annots) sub
      end
    |
      Seq _
        (cons (Prim _ "DUP" % string [] [])
          (cons
            (Prim _ "DIP" % string
              (cons (Seq _ (cons (Prim _ "CDR" % string [] []) (cons sub [])))
                []) [])
            (cons (Prim _ "CAR" % string [] [])
              (cons (Prim _ "PAIR" % string [] pair_annots) [])))) =>
      match extract_field_annots pair_annots with
      | (_, pair_annots) =>
        steps (cons "D" % string acc)
          (Tezos_base__TzPervasives.List.rev_append pair_annots annots) sub
      end
    | _ => None
    end in
  match steps [] [] expanded with
  | Some (loc, steps, annots, code) =>
    let name :=
      Tezos_base__TzPervasives.String.concat "" % string
        (cons "MAP_C" % string
          (Tezos_base__TzPervasives.List.rev (cons "R" % string steps))) in
    Some
      (Prim loc name (cons code []) (Tezos_base__TzPervasives.List.rev annots))
  | None => None
  end.

Definition unexpand_deprecated_dxiiivp {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  |
    Seq loc
      (cons
        (Prim _ "DIP" % string
          (cons
            ((Seq _ (cons (Prim _ "DIP" % string (cons _ []) []) [])) as sub) [])
          []) []) =>
    let fix count {B : Type}
      (acc : Z) (function_parameter : Tezos_micheline.Micheline.node B string)
      : Z * (Tezos_micheline.Micheline.node B string) :=
      match function_parameter with
      | Seq _ (cons (Prim _ "DIP" % string (cons sub []) []) []) =>
        count (Z.add acc 1) sub
      | sub => (acc, sub)
      end in
    match count 1 sub with
    | (depth, sub) =>
      Some
        (Prim loc "DIP" % string (cons (Int loc (Z.of_int depth)) (cons sub []))
          [])
    end
  | _ => None
  end.

Definition unexpand_dupn {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  | _ => None
  end.

Definition unexpand_deprecated_duuuuup {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  let fix expand {B : Type}
    (n : Z) (function_parameter : Tezos_micheline.Micheline.node B string)
    : option (Tezos_micheline.Micheline.node B string) :=
    match function_parameter with
    | Seq loc (cons (Prim nloc "DUP" % string [] annot) []) =>
      if equiv_decb n 1 then
        None
      else
        Some (Prim loc "DUP" % string (cons (Int nloc (Z.of_int n)) []) annot)
    |
      Seq _
        (cons (Prim _ "DIP" % string (cons expanded' []) [])
          (cons (Prim _ "SWAP" % string [] []) [])) =>
      expand (Z.add n 1) expanded'
    | _ => None
    end in
  expand 1 expanded.

Fixpoint normalize_pair_item (op_star_o_p_t_star : option bool)
  : pair_item -> pair_item :=
  let right :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun function_parameter =>
    match function_parameter with
    | P i a b =>
      P i (normalize_pair_item None a) (normalize_pair_item (Some true) b)
    | A => I
    | A => A
    | I => I
    end.

Definition unexpand_pappaiir {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  | Seq _ (cons (Prim _ "PAIR" % string [] []) []) => Some expanded
  | Seq loc ((cons _ _) as nodes) =>
    let fix exec {B : Type}
      (stack : list pair_item) (nodes :
      list (Tezos_micheline.Micheline.node B string)) : list pair_item :=
      match (nodes, stack) with
      | ([], _) => stack
      |
        (cons (Prim _ "DIP" % string (cons (Seq _ sub) []) []) rest,
          cons a rstack) => exec (cons a (exec rstack sub)) rest
      | (cons (Prim _ "DIP" % string (cons (Seq _ sub) []) []) rest, []) =>
        exec (cons A (exec [] sub)) rest
      | (cons (Prim _ "PAIR" % string [] []) rest, cons a (cons b rstack)) =>
        exec (cons (P 0 a b) rstack) rest
      | (cons (Prim _ "PAIR" % string [] []) rest, cons a []) =>
        exec (cons (P 0 a I) []) rest
      | (cons (Prim _ "PAIR" % string [] []) rest, []) =>
        exec (cons (P 0 A I) []) rest
      | _ => Stdlib.raise_notrace Not_a_pair
      end in
    match exec [] nodes with
    | [] => None
    | cons res _ =>
      let res := normalize_pair_item None res in
      let name := unparse_pair_item res in
      Some (Prim loc name [] [])
    end
  | _ => None
  end.

Definition unexpand_unpappaiir {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  | Seq loc ((cons _ _) as nodes) =>
    let fix exec {B : Type}
      (stack : list pair_item) (nodes :
      list (Tezos_micheline.Micheline.node B string)) : list pair_item :=
      match (nodes, stack) with
      | ([], _) => stack
      |
        (cons (Prim _ "DIP" % string (cons (Seq _ sub) []) []) rest,
          cons a rstack) => exec (cons a (exec rstack sub)) rest
      | (cons (Prim _ "DIP" % string (cons (Seq _ sub) []) []) rest, []) =>
        exec (cons A (exec [] sub)) rest
      |
        (cons
          (Seq _
            (cons (Prim _ "DUP" % string [] [])
              (cons (Prim _ "CAR" % string [] [])
                (cons
                  (Prim _ "DIP" % string
                    (cons (Seq _ (cons (Prim _ "CDR" % string [] []) [])) []) [])
                  [])))) rest, cons a (cons b rstack)) =>
        exec (cons (P 0 a b) rstack) rest
      |
        (cons
          (Seq _
            (cons (Prim _ "DUP" % string [] [])
              (cons (Prim _ "CAR" % string [] [])
                (cons
                  (Prim _ "DIP" % string
                    (cons (Seq _ (cons (Prim _ "CDR" % string [] []) [])) []) [])
                  [])))) rest, cons a []) => exec (cons (P 0 a I) []) rest
      |
        (cons
          (Seq _
            (cons (Prim _ "DUP" % string [] [])
              (cons (Prim _ "CAR" % string [] [])
                (cons
                  (Prim _ "DIP" % string
                    (cons (Seq _ (cons (Prim _ "CDR" % string [] []) [])) []) [])
                  [])))) rest, []) => exec (cons (P 0 A I) []) rest
      | _ => Stdlib.raise_notrace Not_a_pair
      end in
    match exec [] (Tezos_base__TzPervasives.List.rev nodes) with
    | [] => None
    | cons res _ =>
      let res := normalize_pair_item None res in
      let name := String.append "UN" % string (unparse_pair_item res) in
      Some (Prim loc name [] [])
    end
  | _ => None
  end.

Definition unexpand_compare {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "EQ" % string [] annot) [])) =>
    Some (Prim loc "CMPEQ" % string [] annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "NEQ" % string [] annot) [])) =>
    Some (Prim loc "CMPNEQ" % string [] annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "LT" % string [] annot) [])) =>
    Some (Prim loc "CMPLT" % string [] annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "GT" % string [] annot) [])) =>
    Some (Prim loc "CMPGT" % string [] annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "LE" % string [] annot) [])) =>
    Some (Prim loc "CMPLE" % string [] annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "GE" % string [] annot) [])) =>
    Some (Prim loc "CMPGE" % string [] annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "EQ" % string [] _)
          (cons (Prim _ "IF" % string args annot) []))) =>
    Some (Prim loc "IFCMPEQ" % string args annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "NEQ" % string [] _)
          (cons (Prim _ "IF" % string args annot) []))) =>
    Some (Prim loc "IFCMPNEQ" % string args annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "LT" % string [] _)
          (cons (Prim _ "IF" % string args annot) []))) =>
    Some (Prim loc "IFCMPLT" % string args annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "GT" % string [] _)
          (cons (Prim _ "IF" % string args annot) []))) =>
    Some (Prim loc "IFCMPGT" % string args annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "LE" % string [] _)
          (cons (Prim _ "IF" % string args annot) []))) =>
    Some (Prim loc "IFCMPLE" % string args annot)
  |
    Seq loc
      (cons (Prim _ "COMPARE" % string [] _)
        (cons (Prim _ "GE" % string [] _)
          (cons (Prim _ "IF" % string args annot) []))) =>
    Some (Prim loc "IFCMPGE" % string args annot)
  |
    Seq loc
      (cons (Prim _ "EQ" % string [] _)
        (cons (Prim _ "IF" % string args annot) [])) =>
    Some (Prim loc "IFEQ" % string args annot)
  |
    Seq loc
      (cons (Prim _ "NEQ" % string [] _)
        (cons (Prim _ "IF" % string args annot) [])) =>
    Some (Prim loc "IFNEQ" % string args annot)
  |
    Seq loc
      (cons (Prim _ "LT" % string [] _)
        (cons (Prim _ "IF" % string args annot) [])) =>
    Some (Prim loc "IFLT" % string args annot)
  |
    Seq loc
      (cons (Prim _ "GT" % string [] _)
        (cons (Prim _ "IF" % string args annot) [])) =>
    Some (Prim loc "IFGT" % string args annot)
  |
    Seq loc
      (cons (Prim _ "LE" % string [] _)
        (cons (Prim _ "IF" % string args annot) [])) =>
    Some (Prim loc "IFLE" % string args annot)
  |
    Seq loc
      (cons (Prim _ "GE" % string [] _)
        (cons (Prim _ "IF" % string args annot) [])) =>
    Some (Prim loc "IFGE" % string args annot)
  | _ => None
  end.

Definition unexpand_asserts {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  |
    Seq loc
      (cons
        (Prim _ "IF" % string
          (cons (Seq _ [])
            (cons
              (Seq _
                (cons
                  (Seq _
                    (cons (Prim _ "UNIT" % string [] [])
                      (cons (Prim _ "FAILWITH" % string [] []) []))) [])) []))
          []) []) => Some (Prim loc "ASSERT" % string [] [])
  |
    Seq loc
      (cons
        (Seq _
          (cons (Prim _ "COMPARE" % string [] [])
            (cons (Prim _ comparison [] []) [])))
        (cons
          (Prim _ "IF" % string
            (cons (Seq _ [])
              (cons
                (Seq _
                  (cons
                    (Seq _
                      (cons (Prim _ "UNIT" % string [] [])
                        (cons (Prim _ "FAILWITH" % string [] []) []))) [])) []))
            []) [])) =>
    Some (Prim loc (String.append "ASSERT_CMP" % string comparison) [] [])
  |
    Seq loc
      (cons (Prim _ comparison [] [])
        (cons
          (Prim _ "IF" % string
            (cons (Seq _ [])
              (cons
                (Seq _
                  (cons
                    (Seq _
                      (cons (Prim _ "UNIT" % string [] [])
                        (cons (Prim _ "FAILWITH" % string [] []) []))) [])) []))
            []) [])) =>
    Some (Prim loc (String.append "ASSERT_" % string comparison) [] [])
  |
    Seq loc
      (cons
        (Prim _ "IF_NONE" % string
          (cons (Seq _ (cons (Prim _ "RENAME" % string [] annot) []))
            (cons
              (Seq _
                (cons
                  (Seq _
                    (cons (Prim _ "UNIT" % string [] [])
                      (cons (Prim _ "FAILWITH" % string [] []) []))) [])) []))
          []) []) => Some (Prim loc "ASSERT_NONE" % string [] annot)
  |
    Seq loc
      (cons
        (Prim _ "IF_NONE" % string
          (cons (Seq _ [])
            (cons
              (Seq _
                (cons
                  (Seq _
                    (cons (Prim _ "UNIT" % string [] [])
                      (cons (Prim _ "FAILWITH" % string [] []) []))) [])) []))
          []) []) => Some (Prim loc "ASSERT_NONE" % string [] [])
  |
    Seq loc
      (cons
        (Prim _ "IF_NONE" % string
          (cons
            (Seq _
              (cons
                (Seq _
                  (cons (Prim _ "UNIT" % string [] [])
                    (cons (Prim _ "FAILWITH" % string [] []) []))) []))
            (cons (Seq _ []) [])) []) []) =>
    Some (Prim loc "ASSERT_SOME" % string [] [])
  |
    Seq loc
      (cons
        (Prim _ "IF_NONE" % string
          (cons
            (Seq _
              (cons
                (Seq _
                  (cons (Prim _ "UNIT" % string [] [])
                    (cons (Prim _ "FAILWITH" % string [] []) []))) []))
            (cons (Seq _ (cons (Prim _ "RENAME" % string [] annot) [])) [])) [])
        []) => Some (Prim loc "ASSERT_SOME" % string [] annot)
  |
    Seq loc
      (cons
        (Prim _ "IF_LEFT" % string
          (cons (Seq _ [])
            (cons
              (Seq _
                (cons
                  (Seq _
                    (cons (Prim _ "UNIT" % string [] [])
                      (cons (Prim _ "FAILWITH" % string [] []) []))) [])) []))
          []) []) => Some (Prim loc "ASSERT_LEFT" % string [] [])
  |
    Seq loc
      (cons
        (Prim _ "IF_LEFT" % string
          (cons (Seq _ (cons (Prim _ "RENAME" % string [] annot) []))
            (cons
              (Seq _
                (cons
                  (Seq _
                    (cons (Prim _ "UNIT" % string [] [])
                      (cons (Prim _ "FAILWITH" % string [] []) []))) [])) []))
          []) []) => Some (Prim loc "ASSERT_LEFT" % string [] annot)
  |
    Seq loc
      (cons
        (Prim _ "IF_LEFT" % string
          (cons
            (Seq _
              (cons
                (Seq _
                  (cons (Prim _ "UNIT" % string [] [])
                    (cons (Prim _ "FAILWITH" % string [] []) []))) []))
            (cons (Seq _ []) [])) []) []) =>
    Some (Prim loc "ASSERT_RIGHT" % string [] [])
  |
    Seq loc
      (cons
        (Prim _ "IF_LEFT" % string
          (cons
            (Seq _
              (cons
                (Seq _
                  (cons (Prim _ "UNIT" % string [] [])
                    (cons (Prim _ "FAILWITH" % string [] []) []))) []))
            (cons (Seq _ (cons (Prim _ "RENAME" % string [] annot) [])) [])) [])
        []) => Some (Prim loc "ASSERT_RIGHT" % string [] annot)
  | _ => None
  end.

Definition unexpand_if_some {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match function_parameter with
  |
    Seq loc
      (cons (Prim _ "IF_NONE" % string (cons left (cons right [])) annot) []) =>
    Some (Prim loc "IF_SOME" % string (cons right (cons left [])) annot)
  | _ => None
  end.

Definition unexpand_if_right {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match function_parameter with
  |
    Seq loc
      (cons (Prim _ "IF_LEFT" % string (cons left (cons right [])) annot) []) =>
    Some (Prim loc "IF_RIGHT" % string (cons right (cons left [])) annot)
  | _ => None
  end.

Definition unexpand_fail {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match function_parameter with
  |
    Seq loc
      (cons (Prim _ "UNIT" % string [] [])
        (cons (Prim _ "FAILWITH" % string [] []) [])) =>
    Some (Prim loc "FAIL" % string [] [])
  | _ => None
  end.

Definition unexpand {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_micheline.Micheline.node A string :=
  let try_unexpansions
    (unexpanders :
    list
      ((Tezos_micheline.Micheline.node A string) ->
        option (Tezos_micheline.Micheline.node A string)))
    : Tezos_micheline.Micheline.node A string :=
    match
      Tezos_base__TzPervasives.List.fold_left
        (fun acc =>
          fun f =>
            match acc with
            | None => f original
            | Some rewritten => Some rewritten
            end) None unexpanders with
    | None => original
    | Some rewritten => rewritten
    end in
  try_unexpansions
    (cons unexpand_asserts
      (cons unexpand_caddadr
        (cons unexpand_set_caddadr
          (cons unexpand_map_caddadr
            (cons unexpand_deprecated_dxiiivp
              (cons unexpand_pappaiir
                (cons unexpand_unpappaiir
                  (cons unexpand_deprecated_duuuuup
                    (cons unexpand_dupn
                      (cons unexpand_compare
                        (cons unexpand_if_some
                          (cons unexpand_if_right (cons unexpand_fail []))))))))))))).

Fixpoint unexpand_rec {A : Type}
  (expr : Tezos_micheline.Micheline.node A string)
  : Tezos_micheline.Micheline.node A string :=
  unexpand_rec_but_root (unexpand expr)

with unexpand_rec_but_root {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : Tezos_micheline.Micheline.node A string :=
  match function_parameter with
  | Seq loc items =>
    Seq loc (Tezos_base__TzPervasives.List.map unexpand_rec items)
  | Prim loc name args annot =>
    Prim loc name (Tezos_base__TzPervasives.List.map unexpand_rec_but_root args)
      annot
  | (Int _ _ | String _ _ | Bytes _ _) as atom => atom
  end.
src/proto_alpha/lib_client/michelson_v1_macros.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Tezos_micheline

type 'l node = ('l, string) Micheline.node

type error += Unexpected_macro_annotation of string

type error += Sequence_expected of string

type error += Invalid_arity of string * int * int

val expand : 'l node -> 'l node tzresult

val expand_rec : 'l node -> 'l node * error list

val expand_caddadr : 'l node -> 'l node option tzresult

val expand_set_caddadr : 'l node -> 'l node option tzresult

val expand_map_caddadr : 'l node -> 'l node option tzresult

val expand_deprecated_dxiiivp : 'l node -> 'l node option tzresult

val expand_pappaiir : 'l node -> 'l node option tzresult

val expand_deprecated_duuuuup : 'l node -> 'l node option tzresult

val expand_compare : 'l node -> 'l node option tzresult

val expand_asserts : 'l node -> 'l node option tzresult

val expand_unpappaiir : 'l node -> 'l node option tzresult

val expand_if_some : 'l node -> 'l node option tzresult

val expand_if_right : 'l node -> 'l node option tzresult

val unexpand : 'l node -> 'l node

val unexpand_rec : 'l node -> 'l node

val unexpand_caddadr : 'l node -> 'l node option

val unexpand_set_caddadr : 'l node -> 'l node option

val unexpand_map_caddadr : 'l node -> 'l node option

val unexpand_deprecated_dxiiivp : 'l node -> 'l node option

val unexpand_pappaiir : 'l node -> 'l node option

val unexpand_deprecated_duuuuup : 'l node -> 'l node option

val unexpand_compare : 'l node -> 'l node option

val unexpand_asserts : 'l node -> 'l node option

val unexpand_unpappaiir : 'l node -> 'l node option

val unexpand_if_some : 'l node -> 'l node option

val unexpand_if_right : 'l node -> 'l node option
src/proto_alpha/lib_client/michelson_v1_macros.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition node (l : Type) := Tezos_micheline.Micheline.node l string.

extensible_type

extensible_type

extensible_type

Parameter expand : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (node l).

Parameter expand_rec : forall {l : Type},
(node l) -> (node l) * (list Tezos_base__TzPervasives.error).

Parameter expand_caddadr : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_set_caddadr : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_map_caddadr : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_deprecated_dxiiivp : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_pappaiir : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_deprecated_duuuuup : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_compare : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_asserts : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_unpappaiir : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_if_some : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter expand_if_right : forall {l : Type},
(node l) -> Tezos_base__TzPervasives.tzresult (option (node l)).

Parameter unexpand : forall {l : Type}, (node l) -> node l.

Parameter unexpand_rec : forall {l : Type}, (node l) -> node l.

Parameter unexpand_caddadr : forall {l : Type}, (node l) -> option (node l).

Parameter unexpand_set_caddadr : forall {l : Type}, (node l) -> option (node l).

Parameter unexpand_map_caddadr : forall {l : Type}, (node l) -> option (node l).

Parameter unexpand_deprecated_dxiiivp : forall {l : Type},
(node l) -> option (node l).

Parameter unexpand_pappaiir : forall {l : Type}, (node l) -> option (node l).

Parameter unexpand_deprecated_duuuuup : forall {l : Type},
(node l) -> option (node l).

Parameter unexpand_compare : forall {l : Type}, (node l) -> option (node l).

Parameter unexpand_asserts : forall {l : Type}, (node l) -> option (node l).

Parameter unexpand_unpappaiir : forall {l : Type}, (node l) -> option (node l).

Parameter unexpand_if_some : forall {l : Type}, (node l) -> option (node l).

Parameter unexpand_if_right : forall {l : Type}, (node l) -> option (node l).
src/proto_alpha/lib_client/michelson_v1_parser.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Tezos_micheline
open Micheline_parser
open Micheline

type parsed = {
  source : string;
  unexpanded : string canonical;
  expanded : Michelson_v1_primitives.prim canonical;
  expansion_table : (int * (Micheline_parser.location * int list)) list;
  unexpansion_table : (int * int) list;
}

(* Unexpanded toplevel expression should be a sequence *)
let expand_all source ast errors =
  let (unexpanded, loc_table) = extract_locations ast in
  let (expanded, expansion_errors) =
    Michelson_v1_macros.expand_rec (root unexpanded)
  in
  let (expanded, unexpansion_table) = extract_locations expanded in
  let expansion_table =
    let sorted =
      List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table
    in
    let grouped =
      let rec group = function
        | (acc, []) ->
            acc
        | ([], (u, e) :: r) ->
            group ([(e, [u])], r)
        | (((pe, us) :: racc as acc), (u, e) :: r) ->
            if e = pe then group ((e, u :: us) :: racc, r)
            else group ((e, [u]) :: acc, r)
      in
      group ([], sorted)
    in
    List.map2
      (fun (l, ploc) (l', elocs) ->
        assert (l = l') ;
        (l, (ploc, elocs)))
      (List.sort compare loc_table)
      (List.sort compare grouped)
  in
  match
    Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded)
  with
  | Ok expanded ->
      ( {source; unexpanded; expanded; expansion_table; unexpansion_table},
        errors @ expansion_errors )
  | Error errs ->
      ( {
          source;
          unexpanded;
          expanded = Micheline.strip_locations (Seq ((), []));
          expansion_table;
          unexpansion_table;
        },
        errors @ expansion_errors @ errs )

let parse_toplevel ?check source =
  let (tokens, lexing_errors) = Micheline_parser.tokenize source in
  let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in
  let ast =
    let start = min_point asts and stop = max_point asts in
    Seq ({start; stop}, asts)
  in
  expand_all source ast (lexing_errors @ parsing_errors)

let parse_expression ?check source =
  let (tokens, lexing_errors) = Micheline_parser.tokenize source in
  let (ast, parsing_errors) =
    Micheline_parser.parse_expression ?check tokens
  in
  expand_all source ast (lexing_errors @ parsing_errors)

let expand_all ~source ~original = expand_all source original []
src/proto_alpha/lib_client/michelson_v1_parser.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_micheline.

Import Tezos_micheline.Micheline_parser.

Import Tezos_micheline.Micheline.

Record parsed := {
  source : string;
  unexpanded : Tezos_micheline.Micheline.canonical string;
  expanded :
    Tezos_micheline.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim;
  expansion_table :
    list (Z * (Tezos_micheline.Micheline_parser.location * (list Z)));
  unexpansion_table : list (Z * Z) }.

Definition expand_all
  (source : string)
  (ast :
    Tezos_micheline.Micheline.node Tezos_micheline.Micheline_parser.location
      string) (errors : list Tezos_base__TzPervasives.error)
  : parsed * (list Tezos_base__TzPervasives.error) :=
  match Tezos_micheline.Micheline.extract_locations ast with
  | (unexpanded, loc_table) =>
    match
      Tezos_client_alpha.Michelson_v1_macros.expand_rec
        (Tezos_micheline.Micheline.root unexpanded) with
    | (expanded, expansion_errors) =>
      match Tezos_micheline.Micheline.extract_locations expanded with
      | (expanded, unexpansion_table) =>
        let expansion_table :=
          let sorted :=
            Tezos_base__TzPervasives.List.sort
              (fun function_parameter =>
                match function_parameter with
                | (_, a) =>
                  fun function_parameter =>
                    match function_parameter with
                    | (_, b) => OCaml.Stdlib.compare a b
                    end
                end) unexpansion_table in
          let grouped :=
            let fix group {A B : Type}
              (function_parameter : (list (A * (list B))) * (list (B * A)))
              : list (A * (list B)) :=
              match function_parameter with
              | (acc, []) => acc
              | ([], cons (u, e) r) => group ((cons (e, (cons u [])) []), r)
              | ((cons (pe, us) racc) as acc, cons (u, e) r) =>
                if equiv_decb e pe then
                  group ((cons (e, (cons u us)) racc), r)
                else
                  group ((cons (e, (cons u [])) acc), r)
              end in
            group ([], sorted) in
          Tezos_base__TzPervasives.List.map2
            (fun function_parameter =>
              match function_parameter with
              | (l, ploc) =>
                fun function_parameter =>
                  match function_parameter with
                  | (l', elocs) =>
                    equiv_decb l l';
                    (l, (ploc, elocs))
                  end
              end)
            (Tezos_base__TzPervasives.List.sort OCaml.Stdlib.compare loc_table)
            (Tezos_base__TzPervasives.List.sort OCaml.Stdlib.compare grouped) in
        match
          Tezos_protocol_alpha.Protocol.Environment.wrap_error
            (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prims_of_strings
              expanded) with
        | inl expanded =>
          ({| source := source; unexpanded := unexpanded; expanded := expanded;
            expansion_table := expansion_table;
            unexpansion_table := unexpansion_table |},
            (OCaml.Stdlib.app errors expansion_errors))
        | inr errs =>
          ({| source := source; unexpanded := unexpanded;
            expanded := Tezos_micheline.Micheline.strip_locations (Seq tt []);
            expansion_table := expansion_table;
            unexpansion_table := unexpansion_table |},
            (OCaml.Stdlib.app errors (OCaml.Stdlib.app expansion_errors errs)))
        end
      end
    end
  end.

Definition parse_toplevel (check : option bool) (source : string)
  : parsed * (list Tezos_base__TzPervasives.error) :=
  match Tezos_micheline.Micheline_parser.tokenize source with
  | (tokens, lexing_errors) =>
    match Tezos_micheline.Micheline_parser.parse_toplevel check tokens with
    | (asts, parsing_errors) =>
      let ast :=
        let start : Tezos_micheline.Micheline_parser.point :=
          Tezos_micheline.Micheline_parser.min_point asts
        with stop : Tezos_micheline.Micheline_parser.point :=
          Tezos_micheline.Micheline_parser.max_point asts in
        Seq {| start := start; stop := stop |} asts in
      expand_all source ast (OCaml.Stdlib.app lexing_errors parsing_errors)
    end
  end.

Definition parse_expression (check : option bool) (source : string)
  : parsed * (list Tezos_base__TzPervasives.error) :=
  match Tezos_micheline.Micheline_parser.tokenize source with
  | (tokens, lexing_errors) =>
    match Tezos_micheline.Micheline_parser.parse_expression check tokens with
    | (ast, parsing_errors) =>
      expand_all source ast (OCaml.Stdlib.app lexing_errors parsing_errors)
    end
  end.

Definition expand_all
  (source : string)
  (original :
    Tezos_micheline.Micheline.node Tezos_micheline.Micheline_parser.location
      string) : parsed * (list Tezos_base__TzPervasives.error) :=
  expand_all source original [].
src/proto_alpha/lib_client/michelson_v1_parser.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline

(** The result of parsing and expanding a Michelson V1 script or data. *)
type parsed = {
  source : string;  (** The original source code. *)
  unexpanded : string Micheline.canonical;
      (** Original expression with macros. *)
  expanded : Script.expr;  (** Expression with macros fully expanded. *)
  expansion_table : (int * (Micheline_parser.location * int list)) list;
      (** Associates unexpanded nodes to their parsing locations and
        the nodes expanded from it in the expanded expression. *)
  unexpansion_table : (int * int) list;
      (** Associates an expanded node to its source in the unexpanded
        expression. *)
}

val parse_toplevel :
  ?check:bool -> string -> parsed Micheline_parser.parsing_result

val parse_expression :
  ?check:bool -> string -> parsed Micheline_parser.parsing_result

val expand_all :
  source:string ->
  original:Micheline_parser.node ->
  parsed Micheline_parser.parsing_result
src/proto_alpha/lib_client/michelson_v1_parser.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record parsed := {
  source : string;
  unexpanded : Tezos_micheline.Micheline.canonical string;
  expanded : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr;
  expansion_table :
    list (Z * (Tezos_micheline.Micheline_parser.location * (list Z)));
  unexpansion_table : list (Z * Z) }.

Parameter parse_toplevel :
(option bool) ->
  string -> Tezos_micheline.Micheline_parser.parsing_result parsed.

Parameter parse_expression :
(option bool) ->
  string -> Tezos_micheline.Micheline_parser.parsing_result parsed.

Parameter expand_all :
string ->
  Tezos_micheline.Micheline_parser.node ->
    Tezos_micheline.Micheline_parser.parsing_result parsed.
src/proto_alpha/lib_client/michelson_v1_printer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline
open Micheline
open Micheline_printer

let anon = {comment = None}

let print_expr ppf expr =
  expr |> Michelson_v1_primitives.strings_of_prims
  |> Micheline.inject_locations (fun _ -> anon)
  |> print_expr ppf

let print_expr_unwrapped ppf expr =
  expr |> Michelson_v1_primitives.strings_of_prims
  |> Micheline.inject_locations (fun _ -> anon)
  |> print_expr_unwrapped ppf

let print_var_annots ppf = List.iter (Format.fprintf ppf "%s ")

let print_annot_expr_unwrapped ppf (expr, annot) =
  Format.fprintf ppf "%a%a" print_var_annots annot print_expr_unwrapped expr

let print_stack ppf = function
  | [] ->
      Format.fprintf ppf "[]"
  | more ->
      Format.fprintf
        ppf
        "@[<hov 0>[ %a ]@]"
        (Format.pp_print_list
           ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ : ")
           print_annot_expr_unwrapped)
        more

let print_execution_trace ppf trace =
  Format.pp_print_list
    (fun ppf (loc, gas, stack) ->
      Format.fprintf
        ppf
        "- @[<v 0>location: %d (remaining gas: %a)@,[ @[<v 0>%a ]@]@]"
        loc
        Gas.pp
        gas
        (Format.pp_print_list (fun ppf (e, annot) ->
             Format.fprintf
               ppf
               "@[<v 0>%a  \t%s@]"
               print_expr
               e
               (match annot with None -> "" | Some a -> a)))
        stack)
    ppf
    trace

let print_big_map_diff ppf diff =
  let pp_map ppf id =
    if Compare.Z.(id < Z.zero) then
      Format.fprintf ppf "temp(%s)" (Z.to_string (Z.neg id))
    else Format.fprintf ppf "map(%s)" (Z.to_string id)
  in
  Format.fprintf
    ppf
    "@[<v 0>%a@]"
    (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf ->
       function
       | Contract.Clear id ->
           Format.fprintf ppf "Clear %a" pp_map id
       | Contract.Alloc {big_map; key_type; value_type} ->
           Format.fprintf
             ppf
             "New %a of type (big_map %a %a)"
             pp_map
             big_map
             print_expr
             key_type
             print_expr
             value_type
       | Contract.Copy (src, dst) ->
           Format.fprintf ppf "Copy %a to %a" pp_map src pp_map dst
       | Contract.Update {big_map; diff_key; diff_value; _} ->
           Format.fprintf
             ppf
             "%s %a[%a]%a"
             (match diff_value with None -> "Unset" | Some _ -> "Set")
             pp_map
             big_map
             print_expr
             diff_key
             (fun ppf -> function None -> () | Some x ->
                   Format.fprintf ppf " to %a" print_expr x)
             diff_value))
    diff

let inject_types type_map parsed =
  let rec inject_expr = function
    | Seq (loc, items) ->
        Seq (inject_loc `before loc, List.map inject_expr items)
    | Prim (loc, name, items, annot) ->
        Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
    | Int (loc, value) ->
        Int (inject_loc `after loc, value)
    | String (loc, value) ->
        String (inject_loc `after loc, value)
    | Bytes (loc, value) ->
        Bytes (inject_loc `after loc, value)
  and inject_loc which loc =
    try
      let stack =
        let locs =
          List.assoc loc parsed.Michelson_v1_parser.expansion_table
          |> snd |> List.sort compare
        in
        let (bef, aft) = List.assoc (List.hd locs) type_map in
        match which with `before -> bef | `after -> aft
      in
      {comment = Some (Format.asprintf "%a" print_stack stack)}
    with Not_found -> {comment = None}
  in
  inject_expr (root parsed.unexpanded)

let unparse ?type_map parse expanded =
  let source =
    match type_map with
    | Some type_map ->
        let (unexpanded, unexpansion_table) =
          expanded |> Michelson_v1_primitives.strings_of_prims |> root
          |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations
        in
        let rec inject_expr = function
          | Seq (loc, items) ->
              Seq (inject_loc `before loc, List.map inject_expr items)
          | Prim (loc, name, items, annot) ->
              Prim
                (inject_loc `after loc, name, List.map inject_expr items, annot)
          | Int (loc, value) ->
              Int (inject_loc `after loc, value)
          | String (loc, value) ->
              String (inject_loc `after loc, value)
          | Bytes (loc, value) ->
              Bytes (inject_loc `after loc, value)
        and inject_loc which loc =
          try
            let stack =
              let (bef, aft) =
                List.assoc (List.assoc loc unexpansion_table) type_map
              in
              match which with `before -> bef | `after -> aft
            in
            {comment = Some (Format.asprintf "%a" print_stack stack)}
          with Not_found -> {comment = None}
        in
        unexpanded |> root |> inject_expr
        |> Format.asprintf "%a" Micheline_printer.print_expr
    | None ->
        expanded |> Michelson_v1_primitives.strings_of_prims |> root
        |> Michelson_v1_macros.unexpand_rec |> Micheline.strip_locations
        |> Micheline_printer.printable (fun n -> n)
        |> Format.asprintf "%a" Micheline_printer.print_expr
  in
  match parse source with
  | (res, []) ->
      res
  | (_, _ :: _) ->
      Pervasives.failwith "Michelson_v1_printer.unparse"

let unparse_toplevel ?type_map =
  unparse ?type_map Michelson_v1_parser.parse_toplevel

let unparse_expression = unparse Michelson_v1_parser.parse_expression

let unparse_invalid expanded =
  let source =
    expanded |> root |> Michelson_v1_macros.unexpand_rec
    |> Micheline.strip_locations
    |> Micheline_printer.printable (fun n -> n)
    |> Format.asprintf "%a" Micheline_printer.print_expr_unwrapped
  in
  fst (Michelson_v1_parser.parse_toplevel source)
src/proto_alpha/lib_client/michelson_v1_printer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_micheline.

Import Tezos_micheline.Micheline.

Import Tezos_micheline.Micheline_printer.

Definition anon : Tezos_micheline.Micheline_printer.location :=
  {| comment := None |}.

Definition print_expr
  (ppf : Stdlib.Format.formatter)
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply expr
        Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.strings_of_prims)
      (Tezos_micheline.Micheline.inject_locations
        (fun function_parameter =>
          match function_parameter with
          | _ => anon
          end))) (Tezos_micheline.Micheline_printer.print_expr ppf).

Definition print_expr_unwrapped
  (ppf : Stdlib.Format.formatter)
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply expr
        Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.strings_of_prims)
      (Tezos_micheline.Micheline.inject_locations
        (fun function_parameter =>
          match function_parameter with
          | _ => anon
          end))) (Tezos_micheline.Micheline_printer.print_expr_unwrapped ppf).

Definition print_var_annots (ppf : Stdlib.Format.formatter)
  : (list string) -> unit :=
  Tezos_base__TzPervasives.List.iter
    (Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal " " % char
            CamlinternalFormatBasics.End_of_format)) "%s " % string)).

Definition print_annot_expr_unwrapped
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
      (list string)) : unit :=
  match function_parameter with
  | (expr, annot) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "%a%a" % string) print_var_annots annot print_expr_unwrapped expr
  end.

Definition print_stack
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    list
      ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
        Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
        (list string))) : unit :=
  match function_parameter with
  | [] =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "[]" % string
          CamlinternalFormatBasics.End_of_format) "[]" % string)
  | more =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
          (CamlinternalFormatBasics.String_literal "[ " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " ]" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<hov 0>[ %a ]@]" % string)
      (Stdlib.Format.pp_print_list
        (Some
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Stdlib.Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal ": " % string
                        CamlinternalFormatBasics.End_of_format)) "@ : " % string)
              end)) print_annot_expr_unwrapped) more
  end.

Definition print_execution_trace
  (ppf : Stdlib.Format.formatter)
  (trace :
    list
      (Z * Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t *
        (list
          ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
            Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
            (option string))))) : unit :=
  Stdlib.Format.pp_print_list None
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | (loc, gas, stack) =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "- " % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 0>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                  (CamlinternalFormatBasics.String_literal "location: " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        " (remaining gas: " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "[ " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<v 0>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<v 0>" % string))
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " ]" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))))))))))))
              "- @[<v 0>location: %d (remaining gas: %a)@,[ @[<v 0>%a ]@]@]" %
                string) loc Tezos_protocol_alpha.Protocol.Alpha_context.Gas.pp
            gas
            (Stdlib.Format.pp_print_list None
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | (e, annot) =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 0>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 0>" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              "  	" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format)))))
                        "@[<v 0>%a  	%s@]" % string) print_expr e
                      match annot with
                      | None => "" % string
                      | Some a => a
                      end
                  end)) stack
        end) ppf trace.

Definition print_big_map_diff
  (ppf : Stdlib.Format.formatter)
  (diff :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff_item)
  : unit :=
  let pp_map
    (ppf : Stdlib.Format.formatter) (id : Tezos_base__TzPervasives.Compare.Z.t)
    : unit :=
    if Tezos_base__TzPervasives.Compare.Z.op_lt id Z.zero then
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "temp(" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))) "temp(%s)" % string)
        (Z.to_string (Z.neg id))
    else
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "map(" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))) "map(%s)" % string)
        (Z.to_string id) in
  Stdlib.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 0>" % string
              CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format))) "@[<v 0>%a@]" % string)
    (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space)
      (fun ppf =>
        fun function_parameter =>
          match function_parameter with
          | Contract.Clear id =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Clear " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)) "Clear %a" % string)
              pp_map id
          |
            Contract.Alloc {|
              big_map := big_map;
                key_type := key_type;
                value_type := value_type
                |} =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "New " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " of type (big_map " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal " " % char
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format)))))))
                "New %a of type (big_map %a %a)" % string) pp_map big_map
              print_expr key_type print_expr value_type
          | Contract.Copy src dst =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Copy " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal " to " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "Copy %a to %a" % string) pp_map src pp_map dst
          |
            Contract.Update {|
              big_map := big_map;
                diff_key := diff_key;
                diff_value := diff_value
                |} =>
            Stdlib.Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "[" % char
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "]" % char
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)))))))
                "%s %a[%a]%a" % string)
              match diff_value with
              | None => "Unset" % string
              | Some _ => "Set" % string
              end pp_map big_map print_expr diff_key
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | None => tt
                  | Some x =>
                    Stdlib.Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal " to " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        " to %a" % string) print_expr x
                  end) diff_value
          end)) diff.

Definition inject_types
  (type_map :
    list
      (Z *
        ((list
          ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
            Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
            (list string))) *
          (list
            ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
              Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
              (list string))))))
  (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Tezos_micheline.Micheline.node Tezos_micheline.Micheline_printer.location
    string :=
  let fix inject_expr {A : Type}
    (function_parameter : Tezos_micheline.Micheline.node Z A)
    : Tezos_micheline.Micheline.node Tezos_micheline.Micheline_printer.location
      A :=
    match function_parameter with
    | Seq loc items =>
      Seq (inject_loc variant loc)
        (Tezos_base__TzPervasives.List.map inject_expr items)
    | Prim loc name items annot =>
      Prim (inject_loc variant loc) name
        (Tezos_base__TzPervasives.List.map inject_expr items) annot
    | Int loc value => Int (inject_loc variant loc) value
    | String loc value => String (inject_loc variant loc) value
    | Bytes loc value => Bytes (inject_loc variant loc) value
    end
  with inject_loc (which : variant) (loc : Z)
    : Tezos_micheline.Micheline_printer.location :=
    try in
  inject_expr (Tezos_micheline.Micheline.root (unexpanded parsed)).

Definition unparse {A B : Type}
  (type_map :
    option
      (list
        (Tezos_micheline.Micheline.canonical_location *
          ((list
            ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
              Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
              (list string))) *
            (list
              ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
                Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
                (list string))))))) (parse : string -> A * (list B))
  (expanded :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : A :=
  let source :=
    match type_map with
    | Some type_map =>
      match
        OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply expanded
                Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.strings_of_prims)
              Tezos_micheline.Micheline.root)
            Tezos_client_alpha.Michelson_v1_macros.unexpand_rec)
          Tezos_micheline.Micheline.extract_locations with
      | (unexpanded, unexpansion_table) =>
        let fix inject_expr {C : Type}
          (function_parameter :
          Tezos_micheline.Micheline.node
            Tezos_micheline.Micheline.canonical_location C)
          : Tezos_micheline.Micheline.node
            Tezos_micheline.Micheline_printer.location C :=
          match function_parameter with
          | Seq loc items =>
            Seq (inject_loc variant loc)
              (Tezos_base__TzPervasives.List.map inject_expr items)
          | Prim loc name items annot =>
            Prim (inject_loc variant loc) name
              (Tezos_base__TzPervasives.List.map inject_expr items) annot
          | Int loc value => Int (inject_loc variant loc) value
          | String loc value => String (inject_loc variant loc) value
          | Bytes loc value => Bytes (inject_loc variant loc) value
          end
        with inject_loc
          (which : variant) (loc : Tezos_micheline.Micheline.canonical_location)
          : Tezos_micheline.Micheline_printer.location :=
          try in
        OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply unexpanded
              Tezos_micheline.Micheline.root) inject_expr)
          (Stdlib.Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Tezos_micheline.Micheline_printer.print_expr)
      end
    | None =>
      OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply
                (OCaml.Stdlib.reverse_apply expanded
                  Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.strings_of_prims)
                Tezos_micheline.Micheline.root)
              Tezos_client_alpha.Michelson_v1_macros.unexpand_rec)
            Tezos_micheline.Micheline.strip_locations)
          (Tezos_micheline.Micheline_printer.printable None (fun n => n)))
        (Stdlib.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Tezos_micheline.Micheline_printer.print_expr)
    end in
  match parse source with
  | (res, []) => res
  | (_, cons _ _) =>
    Stdlib.Pervasives.failwith "Michelson_v1_printer.unparse" % string
  end.

Definition unparse_toplevel
  (type_map :
    option
      (list
        (Tezos_micheline.Micheline.canonical_location *
          ((list
            ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
              Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
              (list string))) *
            (list
              ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
                Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
                (list string)))))))
  : (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) ->
    Tezos_client_alpha.Michelson_v1_parser.parsed :=
  unparse type_map
    (let arg := Tezos_client_alpha.Michelson_v1_parser.parse_toplevel in
    fun eta => arg None eta).

Definition unparse_expression
  : (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) ->
    Tezos_client_alpha.Michelson_v1_parser.parsed :=
  unparse None
    (let arg := Tezos_client_alpha.Michelson_v1_parser.parse_expression in
    fun eta => arg None eta).

Definition unparse_invalid
  (expanded : Tezos_micheline.Micheline.canonical string)
  : Tezos_client_alpha.Michelson_v1_parser.parsed :=
  let source :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply expanded Tezos_micheline.Micheline.root)
            Tezos_client_alpha.Michelson_v1_macros.unexpand_rec)
          Tezos_micheline.Micheline.strip_locations)
        (Tezos_micheline.Micheline_printer.printable None (fun n => n)))
      (Stdlib.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) Tezos_micheline.Micheline_printer.print_expr_unwrapped)
    in
  fst (Tezos_client_alpha.Michelson_v1_parser.parse_toplevel None source).
src/proto_alpha/lib_client/michelson_v1_printer.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline

val print_expr : Format.formatter -> Script_repr.expr -> unit

val print_expr_unwrapped : Format.formatter -> Script_repr.expr -> unit

val print_execution_trace :
  Format.formatter ->
  (Script.location * Gas.t * (Script.expr * string option) list) list ->
  unit

val print_big_map_diff : Format.formatter -> Contract.big_map_diff -> unit

(** Insert the type map returned by the typechecker as comments in a
    printable Micheline AST. *)
val inject_types :
  Script_tc_errors.type_map ->
  Michelson_v1_parser.parsed ->
  Micheline_printer.node

(** Unexpand the macros and produce the result of parsing an
    intermediate pretty printed source. Useful when working with
    contracts extracted from the blockchain and not local files. *)
val unparse_toplevel :
  ?type_map:Script_tc_errors.type_map ->
  Script.expr ->
  Michelson_v1_parser.parsed

val unparse_expression : Script.expr -> Michelson_v1_parser.parsed

(** Unexpand the macros and produce the result of parsing an
    intermediate pretty printed source. Works on generic trees,for
    programs that fail to be converted to a specific script version. *)
val unparse_invalid : string Micheline.canonical -> Michelson_v1_parser.parsed
src/proto_alpha/lib_client/michelson_v1_printer.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter print_expr :
Stdlib.Format.formatter ->
  Tezos_protocol_alpha.Protocol.Script_repr.expr -> unit.

Parameter print_expr_unwrapped :
Stdlib.Format.formatter ->
  Tezos_protocol_alpha.Protocol.Script_repr.expr -> unit.

Parameter print_execution_trace :
Stdlib.Format.formatter ->
  (list
    (Tezos_protocol_alpha.Protocol.Alpha_context.Script.location *
      Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t *
      (list
        (Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr *
          (option string))))) -> unit.

Parameter print_big_map_diff :
Stdlib.Format.formatter ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff -> unit.

Parameter inject_types :
Tezos_protocol_alpha.Protocol.Script_tc_errors.type_map ->
  Tezos_client_alpha.Michelson_v1_parser.parsed ->
    Tezos_micheline.Micheline_printer.node.

Parameter unparse_toplevel :
(option Tezos_protocol_alpha.Protocol.Script_tc_errors.type_map) ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr ->
    Tezos_client_alpha.Michelson_v1_parser.parsed.

Parameter unparse_expression :
Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr ->
  Tezos_client_alpha.Michelson_v1_parser.parsed.

Parameter unparse_invalid :
(Tezos_micheline.Micheline.canonical string) ->
  Tezos_client_alpha.Michelson_v1_parser.parsed.
src/proto_alpha/lib_client/operation_result.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Apply_results

let pp_manager_operation_content (type kind) source internal pp_result ppf
    ((operation, result) : kind manager_operation * _) =
  Format.fprintf ppf "@[<v 0>" ;
  ( match operation with
  | Transaction {destination; amount; parameters; entrypoint} ->
      Format.fprintf
        ppf
        "@[<v 2>%s:@,Amount: %s%a@,From: %a@,To: %a"
        (if internal then "Internal transaction" else "Transaction")
        Client_proto_args.tez_sym
        Tez.pp
        amount
        Contract.pp
        source
        Contract.pp
        destination ;
      ( match entrypoint with
      | "default" ->
          ()
      | _ ->
          Format.fprintf ppf "@,Entrypoint: %s" entrypoint ) ;
      ( if not (Script_repr.is_unit_parameter parameters) then
        let expr =
          Option.unopt_exn
            (Failure "ill-serialized argument")
            (Data_encoding.force_decode parameters)
        in
        Format.fprintf
          ppf
          "@,Parameter: @[<v 0>%a@]"
          Michelson_v1_printer.print_expr
          expr ) ;
      pp_result ppf result ; Format.fprintf ppf "@]"
  | Origination {delegate; credit; script = {code; storage}; preorigination = _}
    ->
      Format.fprintf
        ppf
        "@[<v 2>%s:@,From: %a@,Credit: %s%a"
        (if internal then "Internal origination" else "Origination")
        Contract.pp
        source
        Client_proto_args.tez_sym
        Tez.pp
        credit ;
      let code =
        Option.unopt_exn
          (Failure "ill-serialized code")
          (Data_encoding.force_decode code)
      and storage =
        Option.unopt_exn
          (Failure "ill-serialized storage")
          (Data_encoding.force_decode storage)
      in
      let {Michelson_v1_parser.source; _} =
        Michelson_v1_printer.unparse_toplevel code
      in
      Format.fprintf
        ppf
        "@,@[<hv 2>Script:@ @[<h>%a@]@,@[<hv 2>Initial storage:@ %a@]"
        Format.pp_print_text
        source
        Michelson_v1_printer.print_expr
        storage ;
      ( match delegate with
      | None ->
          Format.fprintf ppf "@,No delegate for this contract"
      | Some delegate ->
          Format.fprintf
            ppf
            "@,Delegate: %a"
            Signature.Public_key_hash.pp
            delegate ) ;
      pp_result ppf result ; Format.fprintf ppf "@]"
  | Reveal key ->
      Format.fprintf
        ppf
        "@[<v 2>%s of manager public key:@,Contract: %a@,Key: %a%a@]"
        (if internal then "Internal revelation" else "Revelation")
        Contract.pp
        source
        Signature.Public_key.pp
        key
        pp_result
        result
  | Delegation None ->
      Format.fprintf
        ppf
        "@[<v 2>%s:@,Contract: %a@,To: nobody%a@]"
        (if internal then "Internal Delegation" else "Delegation")
        Contract.pp
        source
        pp_result
        result
  | Delegation (Some delegate) ->
      Format.fprintf
        ppf
        "@[<v 2>%s:@,Contract: %a@,To: %a%a@]"
        (if internal then "Internal Delegation" else "Delegation")
        Contract.pp
        source
        Signature.Public_key_hash.pp
        delegate
        pp_result
        result ) ;
  Format.fprintf ppf "@]"

let pp_balance_updates ppf = function
  | [] ->
      ()
  | balance_updates ->
      let open Delegate in
      let balance_updates =
        List.map
          (fun (balance, update) ->
            let balance =
              match balance with
              | Contract c ->
                  Format.asprintf "%a" Contract.pp c
              | Rewards (pkh, l) ->
                  Format.asprintf
                    "rewards(%a,%a)"
                    Signature.Public_key_hash.pp
                    pkh
                    Cycle.pp
                    l
              | Fees (pkh, l) ->
                  Format.asprintf
                    "fees(%a,%a)"
                    Signature.Public_key_hash.pp
                    pkh
                    Cycle.pp
                    l
              | Deposits (pkh, l) ->
                  Format.asprintf
                    "deposits(%a,%a)"
                    Signature.Public_key_hash.pp
                    pkh
                    Cycle.pp
                    l
            in
            (balance, update))
          balance_updates
      in
      let column_size =
        List.fold_left
          (fun acc (balance, _) -> Compare.Int.max acc (String.length balance))
          0
          balance_updates
      in
      let pp_update ppf = function
        | Credited amount ->
            Format.fprintf ppf "+%s%a" Client_proto_args.tez_sym Tez.pp amount
        | Debited amount ->
            Format.fprintf ppf "-%s%a" Client_proto_args.tez_sym Tez.pp amount
      in
      let pp_one ppf (balance, update) =
        let to_fill = column_size + 3 - String.length balance in
        let filler = String.make to_fill '.' in
        Format.fprintf ppf "%s %s %a" balance filler pp_update update
      in
      Format.fprintf
        ppf
        "@[<v 0>%a@]"
        (Format.pp_print_list pp_one)
        balance_updates

let pp_manager_operation_contents_and_result ppf
    ( Manager_operation
        {source; fee; operation; counter; gas_limit; storage_limit},
      Manager_operation_result
        {balance_updates; operation_result; internal_operation_results} ) =
  let pp_transaction_result
      (Transaction_result
        { balance_updates;
          consumed_gas;
          storage;
          originated_contracts;
          storage_size;
          paid_storage_size_diff;
          big_map_diff;
          allocated_destination_contract = _ }) =
    ( match originated_contracts with
    | [] ->
        ()
    | contracts ->
        Format.fprintf
          ppf
          "@,@[<v 2>Originated contracts:@,%a@]"
          (Format.pp_print_list Contract.pp)
          contracts ) ;
    ( match storage with
    | None ->
        ()
    | Some expr ->
        Format.fprintf
          ppf
          "@,@[<hv 2>Updated storage:@ %a@]"
          Michelson_v1_printer.print_expr
          expr ) ;
    ( match big_map_diff with
    | None | Some [] ->
        ()
    | Some diff ->
        Format.fprintf
          ppf
          "@,@[<v 2>Updated big_maps:@ %a@]"
          Michelson_v1_printer.print_big_map_diff
          diff ) ;
    if storage_size <> Z.zero then
      Format.fprintf ppf "@,Storage size: %s bytes" (Z.to_string storage_size) ;
    if paid_storage_size_diff <> Z.zero then
      Format.fprintf
        ppf
        "@,Paid storage size diff: %s bytes"
        (Z.to_string paid_storage_size_diff) ;
    Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas) ;
    match balance_updates with
    | [] ->
        ()
    | balance_updates ->
        Format.fprintf
          ppf
          "@,Balance updates:@,  %a"
          pp_balance_updates
          balance_updates
  in
  let pp_origination_result
      (Origination_result
        { big_map_diff;
          balance_updates;
          consumed_gas;
          originated_contracts;
          storage_size;
          paid_storage_size_diff }) =
    ( match originated_contracts with
    | [] ->
        ()
    | contracts ->
        Format.fprintf
          ppf
          "@,@[<v 2>Originated contracts:@,%a@]"
          (Format.pp_print_list Contract.pp)
          contracts ) ;
    if storage_size <> Z.zero then
      Format.fprintf ppf "@,Storage size: %s bytes" (Z.to_string storage_size) ;
    ( match big_map_diff with
    | None | Some [] ->
        ()
    | Some diff ->
        Format.fprintf
          ppf
          "@,@[<v 2>Updated big_maps:@ %a@]"
          Michelson_v1_printer.print_big_map_diff
          diff ) ;
    if paid_storage_size_diff <> Z.zero then
      Format.fprintf
        ppf
        "@,Paid storage size diff: %s bytes"
        (Z.to_string paid_storage_size_diff) ;
    Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas) ;
    match balance_updates with
    | [] ->
        ()
    | balance_updates ->
        Format.fprintf
          ppf
          "@,Balance updates:@,  %a"
          pp_balance_updates
          balance_updates
  in
  let pp_result (type kind) ppf (result : kind manager_operation_result) =
    Format.fprintf ppf "@," ;
    match result with
    | Skipped _ ->
        Format.fprintf ppf "This operation was skipped"
    | Failed (_, _errs) ->
        Format.fprintf ppf "This operation FAILED."
    | Applied (Reveal_result {consumed_gas}) ->
        Format.fprintf ppf "This revelation was successfully applied" ;
        Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas)
    | Backtracked (Reveal_result _, _) ->
        Format.fprintf
          ppf
          "@[<v 0>This revelation was BACKTRACKED, its expected effects were \
           NOT applied.@]"
    | Applied (Delegation_result {consumed_gas}) ->
        Format.fprintf ppf "This delegation was successfully applied" ;
        Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas)
    | Backtracked (Delegation_result _, _) ->
        Format.fprintf
          ppf
          "@[<v 0>This delegation was BACKTRACKED, its expected effects were \
           NOT applied.@]"
    | Applied (Transaction_result _ as tx) ->
        Format.fprintf ppf "This transaction was successfully applied" ;
        pp_transaction_result tx
    | Backtracked ((Transaction_result _ as tx), _errs) ->
        Format.fprintf
          ppf
          "@[<v 0>This transaction was BACKTRACKED, its expected effects (as \
           follow) were NOT applied.@]" ;
        pp_transaction_result tx
    | Applied (Origination_result _ as op) ->
        Format.fprintf ppf "This origination was successfully applied" ;
        pp_origination_result op
    | Backtracked ((Origination_result _ as op), _errs) ->
        Format.fprintf
          ppf
          "@[<v 0>This origination was BACKTRACKED, its expected effects (as \
           follow) were NOT applied.@]" ;
        pp_origination_result op
  in
  Format.fprintf
    ppf
    "@[<v 0>@[<v 2>Manager signed operations:@,\
     From: %a@,\
     Fee to the baker: %s%a@,\
     Expected counter: %s@,\
     Gas limit: %s@,\
     Storage limit: %s bytes"
    Signature.Public_key_hash.pp
    source
    Client_proto_args.tez_sym
    Tez.pp
    fee
    (Z.to_string counter)
    (Z.to_string gas_limit)
    (Z.to_string storage_limit) ;
  ( match balance_updates with
  | [] ->
      ()
  | balance_updates ->
      Format.fprintf
        ppf
        "@,Balance updates:@,  %a"
        pp_balance_updates
        balance_updates ) ;
  Format.fprintf
    ppf
    "@,%a"
    (pp_manager_operation_content
       (Contract.implicit_contract source)
       false
       pp_result)
    (operation, operation_result) ;
  ( match internal_operation_results with
  | [] ->
      ()
  | _ :: _ ->
      Format.fprintf
        ppf
        "@,@[<v 2>Internal operations:@ %a@]"
        (Format.pp_print_list (fun ppf (Internal_operation_result (op, res)) ->
             pp_manager_operation_content
               op.source
               false
               pp_result
               ppf
               (op.operation, res)))
        internal_operation_results ) ;
  Format.fprintf ppf "@]"

let rec pp_contents_and_result_list :
    type kind. Format.formatter -> kind contents_and_result_list -> unit =
 fun ppf -> function
  | Single_and_result
      (Seed_nonce_revelation {level; nonce}, Seed_nonce_revelation_result bus)
    ->
      Format.fprintf
        ppf
        "@[<v 2>Seed nonce revelation:@,\
         Level: %a@,\
         Nonce (hash): %a@,\
         Balance updates:@,\
        \  %a@]"
        Raw_level.pp
        level
        Nonce_hash.pp
        (Nonce.hash nonce)
        pp_balance_updates
        bus
  | Single_and_result
      (Double_baking_evidence {bh1; bh2}, Double_baking_evidence_result bus) ->
      Format.fprintf
        ppf
        "@[<v 2>Double baking evidence:@,\
         Exhibit A: %a@,\
         Exhibit B: %a@,\
         Balance updates:@,\
        \  %a@]"
        Block_hash.pp
        (Block_header.hash bh1)
        Block_hash.pp
        (Block_header.hash bh2)
        pp_balance_updates
        bus
  | Single_and_result
      ( Double_endorsement_evidence {op1; op2},
        Double_endorsement_evidence_result bus ) ->
      Format.fprintf
        ppf
        "@[<v 2>Double endorsement evidence:@,\
         Exhibit A: %a@,\
         Exhibit B: %a@,\
         Balance updates:@,\
        \  %a@]"
        Operation_hash.pp
        (Operation.hash op1)
        Operation_hash.pp
        (Operation.hash op2)
        pp_balance_updates
        bus
  | Single_and_result (Activate_account {id; _}, Activate_account_result bus)
    ->
      Format.fprintf
        ppf
        "@[<v 2>Genesis account activation:@,\
         Account: %a@,\
         Balance updates:@,\
        \  %a@]"
        Ed25519.Public_key_hash.pp
        id
        pp_balance_updates
        bus
  | Single_and_result
      ( Endorsement {level},
        Endorsement_result {balance_updates; delegate; slots} ) ->
      Format.fprintf
        ppf
        "@[<v 2>Endorsement:@,\
         Level: %a@,\
         Balance updates:%a@,\
         Delegate: %a@,\
         Slots: %a@]"
        Raw_level.pp
        level
        pp_balance_updates
        balance_updates
        Signature.Public_key_hash.pp
        delegate
        (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
        slots
  | Single_and_result (Proposals {source; period; proposals}, Proposals_result)
    ->
      Format.fprintf
        ppf
        "@[<v 2>Proposals:@,From: %a@,Period: %a@,Protocols:@,  @[<v 0>%a@]@]"
        Signature.Public_key_hash.pp
        source
        Voting_period.pp
        period
        (Format.pp_print_list Protocol_hash.pp)
        proposals
  | Single_and_result (Ballot {source; period; proposal; ballot}, Ballot_result)
    ->
      Format.fprintf
        ppf
        "@[<v 2>Ballot:@,From: %a@,Period: %a@,Protocol: %a@,Vote: %a@]"
        Signature.Public_key_hash.pp
        source
        Voting_period.pp
        period
        Protocol_hash.pp
        proposal
        Data_encoding.Json.pp
        (Data_encoding.Json.construct Vote.ballot_encoding ballot)
  | Single_and_result
      ((Manager_operation _ as op), (Manager_operation_result _ as res)) ->
      Format.fprintf ppf "%a" pp_manager_operation_contents_and_result (op, res)
  | Cons_and_result
      ((Manager_operation _ as op), (Manager_operation_result _ as res), rest)
    ->
      Format.fprintf
        ppf
        "%a@\n%a"
        pp_manager_operation_contents_and_result
        (op, res)
        pp_contents_and_result_list
        rest

let pp_operation_result ppf
    ((op, res) : 'kind contents_list * 'kind contents_result_list) =
  Format.fprintf ppf "@[<v 0>" ;
  let contents_and_result_list = Apply_results.pack_contents_list op res in
  pp_contents_and_result_list ppf contents_and_result_list ;
  Format.fprintf ppf "@]@."

let pp_internal_operation ppf
    (Internal_operation {source; operation; nonce = _}) =
  pp_manager_operation_content
    source
    true
    (fun _ppf () -> ())
    ppf
    (operation, ())
src/proto_alpha/lib_client/operation_result.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_protocol_alpha.Protocol.Apply_results.

Definition pp_manager_operation_content {A B : Type}
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (internal : bool) (pp_result : Stdlib.Format.formatter -> A -> unit)
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation B) * A)
  : unit :=
  match function_parameter with
  | (operation, result) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string);
    match operation with
    |
      Transaction {|
        amount := amount;
          parameters := parameters;
          entrypoint := entrypoint;
          destination := destination
          |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "Amount: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "From: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "To: " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format)))))))))))))
          "@[<v 2>%s:@,Amount: %s%a@,From: %a@,To: %a" % string)
        (if internal then
          "Internal transaction" % string
        else
          "Transaction" % string) Tezos_client_alpha.Client_proto_args.tez_sym
        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp amount
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp source
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp destination;
      match entrypoint with
      | "default" % string => tt
      | _ =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Entrypoint: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)))
            "@,Entrypoint: %s" % string) entrypoint
      end;
      if
        negb
          (Tezos_protocol_alpha.Protocol.Script_repr.is_unit_parameter
            parameters) then
        let expr :=
          Tezos_base__TzPervasives.Option.unopt_exn
            (OCaml.Failure "ill-serialized argument" % string)
            (Tezos_base__TzPervasives.Data_encoding.force_decode parameters) in
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Parameter: " % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 0>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@,Parameter: @[<v 0>%a@]" % string)
          Tezos_client_alpha.Michelson_v1_printer.print_expr expr
      else
        tt;
      pp_result ppf result;
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format) "@]" % string)
    |
      Origination {|
        delegate := delegate;
          script := {| code := code; storage := storage |};
          credit := credit;
          preorigination := _
          |} =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "From: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          "Credit: " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))))))))))
          "@[<v 2>%s:@,From: %a@,Credit: %s%a" % string)
        (if internal then
          "Internal origination" % string
        else
          "Origination" % string)
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp source
        Tezos_client_alpha.Client_proto_args.tez_sym
        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp credit;
      let code : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
        Tezos_base__TzPervasives.Option.unopt_exn
          (OCaml.Failure "ill-serialized code" % string)
          (Tezos_base__TzPervasives.Data_encoding.force_decode code)
      with storage : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
        Tezos_base__TzPervasives.Option.unopt_exn
          (OCaml.Failure "ill-serialized storage" % string)
          (Tezos_base__TzPervasives.Data_encoding.force_decode storage) in
      match Tezos_client_alpha.Michelson_v1_printer.unparse_toplevel None code
        with
      | {| Michelson_v1_parser.source := source |} =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hv 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hv 2>" % string))
                (CamlinternalFormatBasics.String_literal "Script:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<h>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<h>" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<hv 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<hv 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "Initial storage:" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))
            "@,@[<hv 2>Script:@ @[<h>%a@]@,@[<hv 2>Initial storage:@ %a@]" %
              string) Stdlib.Format.pp_print_text source
          Tezos_client_alpha.Michelson_v1_printer.print_expr storage;
        match delegate with
        | None =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "No delegate for this contract" % string
                  CamlinternalFormatBasics.End_of_format))
              "@,No delegate for this contract" % string)
        | Some delegate =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "Delegate: " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))
              "@,Delegate: %a" % string)
            Tezos_base__TzPervasives.Signature.Public_key_hash.pp delegate
        end;
        pp_result ppf result;
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format) "@]" % string)
      end
    | Reveal key =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " of manager public key:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "Contract: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          "Key: " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))))))))
          "@[<v 2>%s of manager public key:@,Contract: %a@,Key: %a%a@]" % string)
        (if internal then
          "Internal revelation" % string
        else
          "Revelation" % string)
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp source
        Tezos_base__TzPervasives.Signature.Public_key.pp key pp_result result
    | Delegation None =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "Contract: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          "To: nobody" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format))))))))))
          "@[<v 2>%s:@,Contract: %a@,To: nobody%a@]" % string)
        (if internal then
          "Internal Delegation" % string
        else
          "Delegation" % string)
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp source pp_result
        result
    | Delegation (Some delegate) =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "Contract: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal "To: " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))))))))
          "@[<v 2>%s:@,Contract: %a@,To: %a%a@]" % string)
        (if internal then
          "Internal Delegation" % string
        else
          "Delegation" % string)
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp source
        Tezos_base__TzPervasives.Signature.Public_key_hash.pp delegate pp_result
        result
    end;
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          CamlinternalFormatBasics.End_of_format) "@]" % string)
  end.

Definition pp_balance_updates
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    list
      (Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance *
        Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update))
  : unit :=
  match function_parameter with
  | [] => tt
  | balance_updates =>
    let balance_updates :=
      Tezos_base__TzPervasives.List.map
        (fun function_parameter =>
          match function_parameter with
          | (balance, update) =>
            let balance :=
              match balance with
              | Contract c =>
                Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format) "%a" % string)
                  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp c
              | Rewards pkh l =>
                Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "rewards(" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "," % char
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format)))))
                    "rewards(%a,%a)" % string)
                  Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh
                  Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.pp l
              | Fees pkh l =>
                Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "fees(" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "," % char
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format)))))
                    "fees(%a,%a)" % string)
                  Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh
                  Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.pp l
              | Deposits pkh l =>
                Stdlib.Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "deposits(" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "," % char
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format)))))
                    "deposits(%a,%a)" % string)
                  Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh
                  Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.pp l
              end in
            (balance, update)
          end) balance_updates in
    let column_size :=
      Tezos_base__TzPervasives.List.fold_left
        (fun acc =>
          fun function_parameter =>
            match function_parameter with
            | (balance, _) =>
              Tezos_base__TzPervasives.Compare.Int.max acc
                (Tezos_base__TzPervasives.String.length balance)
            end) 0 balance_updates in
    let pp_update
      (ppf : Stdlib.Format.formatter) (function_parameter :
      Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update)
      : unit :=
      match function_parameter with
      | Credited amount =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "+" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))) "+%s%a" % string)
          Tezos_client_alpha.Client_proto_args.tez_sym
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp amount
      | Debited amount =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "-" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))) "-%s%a" % string)
          Tezos_client_alpha.Client_proto_args.tez_sym
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp amount
      end in
    let pp_one
      (ppf : Stdlib.Format.formatter) (function_parameter :
      string *
        Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update)
      : unit :=
      match function_parameter with
      | (balance, update) =>
        let to_fill :=
          Z.sub (Z.add column_size 3)
            (Tezos_base__TzPervasives.String.length balance) in
        let filler := Tezos_base__TzPervasives.String.make to_fill "." % char in
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal " " % char
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))))
            "%s %s %a" % string) balance filler pp_update update
      end in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format))) "@[<v 0>%a@]" % string)
      (Stdlib.Format.pp_print_list None pp_one) balance_updates
  end.

Definition pp_manager_operation_contents_and_result {A B : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents
      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A)) *
      (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
        (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager B))) : unit :=
  match function_parameter with
  |
    (Manager_operation {|
      source := source;
        fee := fee;
        counter := counter;
        operation := operation;
        gas_limit := gas_limit;
        storage_limit := storage_limit
        |},
      Manager_operation_result {|
        balance_updates := balance_updates;
          operation_result := operation_result;
          internal_operation_results := internal_operation_results
          |}) =>
    let pp_transaction_result
      (function_parameter :
      Tezos_protocol_alpha.Protocol.Apply_results.successful_manager_operation_result
        Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction) : unit :=
      match function_parameter with
      |
        Transaction_result {|
          storage := storage;
            big_map_diff := big_map_diff;
            balance_updates := balance_updates;
            originated_contracts := originated_contracts;
            consumed_gas := consumed_gas;
            storage_size := storage_size;
            paid_storage_size_diff := paid_storage_size_diff;
            allocated_destination_contract := _
            |} =>
        match originated_contracts with
        | [] => tt
        | contracts =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Originated contracts:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@,@[<v 2>Originated contracts:@,%a@]" % string)
            (Stdlib.Format.pp_print_list None
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp) contracts
        end;
        match storage with
        | None => tt
        | Some expr =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<hv 2>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hv 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Updated storage:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@,@[<hv 2>Updated storage:@ %a@]" % string)
            Tezos_client_alpha.Michelson_v1_printer.print_expr expr
        end;
        match big_map_diff with
        | None | Some [] => tt
        | Some diff =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Updated big_maps:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@,@[<v 2>Updated big_maps:@ %a@]" % string)
            Tezos_client_alpha.Michelson_v1_printer.print_big_map_diff diff
        end;
        if nequiv_decb storage_size Z.zero then
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Storage size: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal " bytes" % string
                      CamlinternalFormatBasics.End_of_format))))
              "@,Storage size: %s bytes" % string) (Z.to_string storage_size)
        else
          tt;
        if nequiv_decb paid_storage_size_diff Z.zero then
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Paid storage size diff: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal " bytes" % string
                      CamlinternalFormatBasics.End_of_format))))
              "@,Paid storage size diff: %s bytes" % string)
            (Z.to_string paid_storage_size_diff)
        else
          tt;
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Consumed gas: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)))
            "@,Consumed gas: %s" % string) (Z.to_string consumed_gas);
        match balance_updates with
        | [] => tt
        | balance_updates =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Balance updates:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "  " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)))))
              "@,Balance updates:@,  %a" % string) pp_balance_updates
            balance_updates
        end
      end in
    let pp_origination_result
      (function_parameter :
      Tezos_protocol_alpha.Protocol.Apply_results.successful_manager_operation_result
        Tezos_raw_protocol_alpha.Alpha_context.Kind.origination) : unit :=
      match function_parameter with
      |
        Origination_result {|
          big_map_diff := big_map_diff;
            balance_updates := balance_updates;
            originated_contracts := originated_contracts;
            consumed_gas := consumed_gas;
            storage_size := storage_size;
            paid_storage_size_diff := paid_storage_size_diff
            |} =>
        match originated_contracts with
        | [] => tt
        | contracts =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Originated contracts:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@,@[<v 2>Originated contracts:@,%a@]" % string)
            (Stdlib.Format.pp_print_list None
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp) contracts
        end;
        if nequiv_decb storage_size Z.zero then
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Storage size: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal " bytes" % string
                      CamlinternalFormatBasics.End_of_format))))
              "@,Storage size: %s bytes" % string) (Z.to_string storage_size)
        else
          tt;
        match big_map_diff with
        | None | Some [] => tt
        | Some diff =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Updated big_maps:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@,@[<v 2>Updated big_maps:@ %a@]" % string)
            Tezos_client_alpha.Michelson_v1_printer.print_big_map_diff diff
        end;
        if nequiv_decb paid_storage_size_diff Z.zero then
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Paid storage size diff: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal " bytes" % string
                      CamlinternalFormatBasics.End_of_format))))
              "@,Paid storage size diff: %s bytes" % string)
            (Z.to_string paid_storage_size_diff)
        else
          tt;
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Consumed gas: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)))
            "@,Consumed gas: %s" % string) (Z.to_string consumed_gas);
        match balance_updates with
        | [] => tt
        | balance_updates =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Balance updates:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "  " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)))))
              "@,Balance updates:@,  %a" % string) pp_balance_updates
            balance_updates
        end
      end in
    let pp_result {C : Type}
      (ppf : Stdlib.Format.formatter) (result :
      Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
      : unit :=
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            CamlinternalFormatBasics.End_of_format) "@," % string);
      match result with
      | Skipped _ =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This operation was skipped" % string
              CamlinternalFormatBasics.End_of_format)
            "This operation was skipped" % string)
      | Failed _ _errs =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This operation FAILED." % string
              CamlinternalFormatBasics.End_of_format)
            "This operation FAILED." % string)
      | Applied (Reveal_result {| consumed_gas := consumed_gas |}) =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This revelation was successfully applied" % string
              CamlinternalFormatBasics.End_of_format)
            "This revelation was successfully applied" % string);
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Consumed gas: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)))
            "@,Consumed gas: %s" % string) (Z.to_string consumed_gas)
      | Backtracked (Reveal_result _) _ =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "This revelation was BACKTRACKED, its expected effects were NOT applied."
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 0>This revelation was BACKTRACKED, its expected effects were NOT applied.@]"
              % string)
      | Applied (Delegation_result {| consumed_gas := consumed_gas |}) =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This delegation was successfully applied" % string
              CamlinternalFormatBasics.End_of_format)
            "This delegation was successfully applied" % string);
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Consumed gas: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)))
            "@,Consumed gas: %s" % string) (Z.to_string consumed_gas)
      | Backtracked (Delegation_result _) _ =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "This delegation was BACKTRACKED, its expected effects were NOT applied."
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 0>This delegation was BACKTRACKED, its expected effects were NOT applied.@]"
              % string)
      | Applied ((Transaction_result _) as tx) =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This transaction was successfully applied" % string
              CamlinternalFormatBasics.End_of_format)
            "This transaction was successfully applied" % string);
        pp_transaction_result tx
      | Backtracked ((Transaction_result _) as tx) _errs =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "This transaction was BACKTRACKED, its expected effects (as follow) were NOT applied."
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 0>This transaction was BACKTRACKED, its expected effects (as follow) were NOT applied.@]"
              % string);
        pp_transaction_result tx
      | Applied ((Origination_result _) as op) =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This origination was successfully applied" % string
              CamlinternalFormatBasics.End_of_format)
            "This origination was successfully applied" % string);
        pp_origination_result op
      | Backtracked ((Origination_result _) as op) _errs =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "This origination was BACKTRACKED, its expected effects (as follow) were NOT applied."
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 0>This origination was BACKTRACKED, its expected effects (as follow) were NOT applied.@]"
              % string);
        pp_origination_result op
      end in
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String_literal
              "Manager signed operations:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "From: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String_literal
                        "Fee to the baker: " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "Expected counter: " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "Gas limit: " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "Storage limit: " % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.String_literal
                                                " bytes" % string
                                                CamlinternalFormatBasics.End_of_format))))))))))))))))))))
        "@[<v 0>@[<v 2>Manager signed operations:@,From: %a@,Fee to the baker: %s%a@,Expected counter: %s@,Gas limit: %s@,Storage limit: %s bytes"
          % string) Tezos_base__TzPervasives.Signature.Public_key_hash.pp source
      Tezos_client_alpha.Client_proto_args.tez_sym
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp fee
      (Z.to_string counter) (Z.to_string gas_limit) (Z.to_string storage_limit);
    match balance_updates with
    | [] => tt
    | balance_updates =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.String_literal "Balance updates:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "  " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))))
          "@,Balance updates:@,  %a" % string) pp_balance_updates
        balance_updates
    end;
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          (CamlinternalFormatBasics.Break "@," % string 0 0)
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "@,%a" % string)
      (pp_manager_operation_content
        (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
          source) false pp_result) (operation, operation_result);
    match internal_operation_results with
    | [] => tt
    | cons _ _ =>
      Stdlib.Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Internal operations:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format))))))
          "@,@[<v 2>Internal operations:@ %a@]" % string)
        (Stdlib.Format.pp_print_list None
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              | Internal_operation_result op res =>
                pp_manager_operation_content (source op) false pp_result ppf
                  ((operation op), res)
              end)) internal_operation_results
    end;
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          CamlinternalFormatBasics.End_of_format) "@]" % string)
  end.

Fixpoint pp_contents_and_result_list {kind : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_and_result_list kind)
  : unit :=
  match function_parameter with
  |
    Single_and_result
      (Seed_nonce_revelation {| level := level; nonce := nonce |})
      (Seed_nonce_revelation_result bus) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Seed nonce revelation:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Level: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Nonce (hash): " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Balance updates:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "  " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))))))))))))
        "@[<v 2>Seed nonce revelation:@,Level: %a@,Nonce (hash): %a@,Balance updates:@,  %a@]"
          % string) Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.pp
      level Tezos_protocol_alpha.Protocol.Nonce_hash.pp
      (Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.hash nonce)
      pp_balance_updates bus
  |
    Single_and_result (Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |})
      (Double_baking_evidence_result bus) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Double baking evidence:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Exhibit A: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Exhibit B: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Balance updates:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "  " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))))))))))))
        "@[<v 2>Double baking evidence:@,Exhibit A: %a@,Exhibit B: %a@,Balance updates:@,  %a@]"
          % string) Tezos_base__TzPervasives.Block_hash.pp
      (Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.hash bh1)
      Tezos_base__TzPervasives.Block_hash.pp
      (Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.hash bh2)
      pp_balance_updates bus
  |
    Single_and_result (Double_endorsement_evidence {| op1 := op1; op2 := op2 |})
      (Double_endorsement_evidence_result bus) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Double endorsement evidence:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Exhibit A: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Exhibit B: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Balance updates:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "  " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))))))))))))
        "@[<v 2>Double endorsement evidence:@,Exhibit A: %a@,Exhibit B: %a@,Balance updates:@,  %a@]"
          % string) Tezos_base__TzPervasives.Operation_hash.pp
      (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash op1)
      Tezos_base__TzPervasives.Operation_hash.pp
      (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash op2)
      pp_balance_updates bus
  |
    Single_and_result (Activate_account {| id := id |})
      (Activate_account_result bus) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Genesis account activation:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Account: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Balance updates:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal "  " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))))))))
        "@[<v 2>Genesis account activation:@,Account: %a@,Balance updates:@,  %a@]"
          % string) Tezos_base__TzPervasives.Ed25519.Public_key_hash.pp id
      pp_balance_updates bus
  |
    Single_and_result (Endorsement {| level := level |})
      (Endorsement_result {|
        balance_updates := balance_updates;
          delegate := delegate;
          slots := slots
          |}) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Endorsement:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Level: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Balance updates:" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Delegate: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "Slots: " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[<v 2>Endorsement:@,Level: %a@,Balance updates:%a@,Delegate: %a@,Slots: %a@]"
          % string) Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.pp
      level pp_balance_updates balance_updates
      Tezos_base__TzPervasives.Signature.Public_key_hash.pp delegate
      (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_space)
        Stdlib.Format.pp_print_int) slots
  |
    Single_and_result
      (Proposals {|
        source := source; period := period; proposals := proposals |})
      Proposals_result =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Proposals:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "From: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "Period: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Protocols:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "  " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<v 0>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<v 0>" % string))
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))))
        "@[<v 2>Proposals:@,From: %a@,Period: %a@,Protocols:@,  @[<v 0>%a@]@]" %
          string) Tezos_base__TzPervasives.Signature.Public_key_hash.pp source
      Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.pp period
      (Stdlib.Format.pp_print_list None
        Tezos_base__TzPervasives.Protocol_hash.pp) proposals
  |
    Single_and_result
      (Ballot {|
        source := source;
          period := period;
          proposal := proposal;
          ballot := ballot
          |}) Ballot_result =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Ballot:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "From: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "Period: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Protocol: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "Vote: " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[<v 2>Ballot:@,From: %a@,Period: %a@,Protocol: %a@,Vote: %a@]" %
          string) Tezos_base__TzPervasives.Signature.Public_key_hash.pp source
      Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.pp period
      Tezos_base__TzPervasives.Protocol_hash.pp proposal
      Tezos_base__TzPervasives.Data_encoding.Json.pp
      (Tezos_base__TzPervasives.Data_encoding.Json.construct
        Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot_encoding ballot)
  |
    Single_and_result ((Manager_operation _) as op)
      ((Manager_operation_result _) as res) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) pp_manager_operation_contents_and_result (op, res)
  |
    Cons_and_result ((Manager_operation _) as op)
      ((Manager_operation_result _) as res) rest =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Force_newline
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))) "%a@
%a" % string)
      pp_manager_operation_contents_and_result (op, res)
      pp_contents_and_result_list rest
  end.

Definition pp_operation_result {kind : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) *
      (Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind))
  : unit :=
  match function_parameter with
  | (op, res) =>
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string);
    let contents_and_result_list :=
      Tezos_protocol_alpha.Protocol.Apply_results.pack_contents_list op res in
    pp_contents_and_result_list ppf contents_and_result_list;
    Stdlib.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Flush_newline
            CamlinternalFormatBasics.End_of_format)) "@]@." % string)
  end.

Definition pp_internal_operation
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
  : unit :=
  match function_parameter with
  |
    Internal_operation {|
      source := source; operation := operation; nonce := _ |} =>
    pp_manager_operation_content source true
      (fun _ppf =>
        fun function_parameter =>
          match function_parameter with
          | tt => tt
          end) ppf (operation, tt)
  end.
src/proto_alpha/lib_client/operation_result.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

val pp_internal_operation :
  Format.formatter -> packed_internal_operation -> unit

val pp_operation_result :
  Format.formatter ->
  'kind contents_list * 'kind Apply_results.contents_result_list ->
  unit
src/proto_alpha/lib_client/operation_result.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter pp_internal_operation :
Stdlib.Format.formatter ->
  Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation -> unit.

Parameter pp_operation_result : forall {kind : Type},
Stdlib.Format.formatter ->
  ((Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind)) ->
    unit.
src/proto_alpha/lib_client/protocol_client_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Alpha_block_services = Block_services.Make (Protocol) (Protocol)

(** Client RPC context *)

class type rpc_context =
  object
    inherit RPC_context.json

    inherit
      [Shell_services.chain * Shell_services.block] Protocol.Environment
                                                    .RPC_context
                                                    .simple
  end

class wrap_rpc_context (t : RPC_context.json) : rpc_context =
  object
    method base : Uri.t = t#base

    method generic_json_call = t#generic_json_call

    method call_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
          'q -> 'i -> 'o tzresult Lwt.t =
      t#call_service

    method call_streamed_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
          on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
          (unit -> unit) tzresult Lwt.t =
      t#call_streamed_service

    inherit
      [Shell_services.chain, Shell_services.block] Protocol.Environment
                                                   .proto_rpc_context
        (t :> RPC_context.t)
        Shell_services.Blocks.path
  end

class type full =
  object
    inherit Client_context.full

    inherit
      [Shell_services.chain * Shell_services.block] Protocol.Environment
                                                    .RPC_context
                                                    .simple

    inherit
      [Shell_services.chain, Shell_services.block] Protocol.Environment
                                                   .proto_rpc_context
  end

class wrap_full (t : Client_context.full) : full =
  object
    inherit Client_context.proxy_context t

    inherit
      [Shell_services.chain, Shell_services.block] Protocol.Environment
                                                   .proto_rpc_context
        (t :> RPC_context.t)
        Shell_services.Blocks.path
  end

let register_error_kind category ~id ~title ~description ?pp encoding
    from_error to_error =
  let id = "client." ^ Protocol.name ^ "." ^ id in
  register_error_kind
    category
    ~id
    ~title
    ~description
    ?pp
    encoding
    from_error
    to_error

let () =
  let open Tezos_data_encoding.Data_encoding.Registration in
  let open Tezos_data_encoding.Data_encoding in
  let stamp_proto id ids = String.concat "." (Protocol.name :: id :: ids) in
  register
  @@ def (stamp_proto "parameters" []) Protocol.Parameters_repr.encoding ;
  register ~pp:Protocol.Alpha_context.Tez.pp
  @@ def (stamp_proto "tez" []) Protocol.Alpha_context.Tez.encoding ;
  register @@ def (stamp_proto "roll" []) Protocol.Alpha_context.Roll.encoding ;
  register ~pp:Protocol.Alpha_context.Fitness.pp
  @@ def (stamp_proto "fitness" []) Protocol.Alpha_context.Fitness.encoding ;
  register ~pp:Protocol.Alpha_context.Timestamp.pp
  @@ def (stamp_proto "timestamp" []) Protocol.Alpha_context.Timestamp.encoding ;
  register ~pp:Protocol.Alpha_context.Raw_level.pp
  @@ def (stamp_proto "raw_level" []) Protocol.Alpha_context.Raw_level.encoding ;
  register
  @@ def
       (stamp_proto "vote" ["ballot"])
       Protocol.Alpha_context.Vote.ballot_encoding ;
  register
  @@ def
       (stamp_proto "vote" ["ballots"])
       Protocol.Alpha_context.Vote.ballots_encoding ;
  register
  @@ def
       (stamp_proto "vote" ["listings"])
       Protocol.Alpha_context.Vote.listings_encoding ;
  register
  @@ def (stamp_proto "seed" []) Protocol.Alpha_context.Seed.seed_encoding ;
  register ~pp:Protocol.Alpha_context.Gas.pp
  @@ def (stamp_proto "gas" []) Protocol.Alpha_context.Gas.encoding ;
  register ~pp:Protocol.Alpha_context.Gas.pp_cost
  @@ def (stamp_proto "gas" ["cost"]) Protocol.Alpha_context.Gas.cost_encoding ;
  register
  @@ def (stamp_proto "script" []) Protocol.Alpha_context.Script.encoding ;
  register
  @@ def
       (stamp_proto "script" ["expr"])
       Protocol.Alpha_context.Script.expr_encoding ;
  register
  @@ def
       (stamp_proto "script" ["prim"])
       Protocol.Alpha_context.Script.prim_encoding ;
  register
  @@ def
       (stamp_proto "script" ["lazy_expr"])
       Protocol.Alpha_context.Script.lazy_expr_encoding ;
  register
  @@ def
       (stamp_proto "script" ["loc"])
       Protocol.Alpha_context.Script.location_encoding ;
  register ~pp:Protocol.Alpha_context.Contract.pp
  @@ def (stamp_proto "contract" []) Protocol.Alpha_context.Contract.encoding ;
  register
  @@ def
       (stamp_proto "contract" ["big_map_diff"])
       Protocol.Alpha_context.Contract.big_map_diff_encoding ;
  register
  @@ def
       (stamp_proto "delegate" ["frozen_balance"])
       Protocol.Alpha_context.Delegate.frozen_balance_encoding ;
  register
  @@ def
       (stamp_proto "delegate" ["balance_updates"])
       Protocol.Alpha_context.Delegate.balance_updates_encoding ;
  register
  @@ def
       (stamp_proto "delegate" ["frozen_balance_by_cycles"])
       Protocol.Alpha_context.Delegate.frozen_balance_by_cycle_encoding ;
  register ~pp:Protocol.Alpha_context.Level.pp_full
  @@ def (stamp_proto "level" []) Protocol.Alpha_context.Level.encoding ;
  register
  @@ def (stamp_proto "operation" []) Protocol.Alpha_context.Operation.encoding ;
  register
  @@ def
       (stamp_proto "operation" ["contents"])
       Protocol.Alpha_context.Operation.contents_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["contents_list"])
       Protocol.Alpha_context.Operation.contents_list_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["protocol_data"])
       Protocol.Alpha_context.Operation.protocol_data_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["raw"])
       Protocol.Alpha_context.Operation.raw_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["internal"])
       Protocol.Alpha_context.Operation.internal_operation_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["unsigned"])
       Protocol.Alpha_context.Operation.unsigned_encoding ;
  register ~pp:Protocol.Alpha_context.Period.pp
  @@ def (stamp_proto "period" []) Protocol.Alpha_context.Period.encoding ;
  register ~pp:Protocol.Alpha_context.Cycle.pp
  @@ def (stamp_proto "cycle" []) Protocol.Alpha_context.Cycle.encoding ;
  register
  @@ def (stamp_proto "constants" []) Protocol.Alpha_context.Constants.encoding ;
  register
  @@ def
       (stamp_proto "constants" ["fixed"])
       Protocol.Alpha_context.Constants.fixed_encoding ;
  register
  @@ def
       (stamp_proto "constants" ["parametric"])
       Protocol.Alpha_context.Constants.parametric_encoding ;
  register
  @@ def (stamp_proto "nonce" []) Protocol.Alpha_context.Nonce.encoding ;
  register
  @@ def
       (stamp_proto "block_header" [])
       Protocol.Alpha_context.Block_header.encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["unsigned"])
       Protocol.Alpha_context.Block_header.unsigned_encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["raw"])
       Protocol.Alpha_context.Block_header.raw_encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["contents"])
       Protocol.Alpha_context.Block_header.contents_encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["shell_header"])
       Protocol.Alpha_context.Block_header.shell_header_encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["protocol_data"])
       Protocol.Alpha_context.Block_header.protocol_data_encoding ;
  register ~pp:Protocol.Alpha_context.Voting_period.pp
  @@ def
       (stamp_proto "voting_period" [])
       Protocol.Alpha_context.Voting_period.encoding ;
  register
  @@ def
       (stamp_proto "voting_period" ["kind"])
       Protocol.Alpha_context.Voting_period.kind_encoding ;
  register
  @@ Data_encoding.def
       (stamp_proto "errors" [])
       ~description:
         "The full list of RPC errors would be too long to include.It is\n\
          available through the RPC `/errors` (GET)."
       error_encoding
src/proto_alpha/lib_client/protocol_client_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition register_error_kind {A : Type}
  (category : Tezos_error_monad.Error_monad_sig.error_category) (id : string)
  (title : string) (description : string)
  (pp : option (Stdlib.Format.formatter -> A -> unit))
  (encoding : Tezos_data_encoding.Data_encoding.t A)
  (from_error : Tezos_base__TzPervasives.error -> option A)
  (to_error : A -> Tezos_base__TzPervasives.error) : unit :=
  let id :=
    String.append "client." % string
      (String.append Tezos_protocol_alpha.Protocol.name
        (String.append "." % string id)) in
  Tezos_base__TzPervasives.register_error_kind category id title description pp
    encoding from_error to_error.
src/proto_alpha/lib_client/test/assert.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let default_printer _ = ""

let equal ?(eq = ( = )) ?(print = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (print x) (print y) msg
src/proto_alpha/lib_client/test/assert.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  match function_parameter with
  | _ => "" % string
  end.

Definition equal {A : Type} (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb
    end in
  fun op_star_o_p_t_star =>
    let print :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (print x) (print y) msg
          else
            tt.
src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let print expr : string =
  expr
  |> Micheline_printer.printable (fun s -> s)
  |> Format.asprintf "%a" Micheline_printer.print_expr

(* expands : expression with macros fully expanded *)

let assert_expands
    (original : (Micheline_parser.location, string) Micheline.node)
    (expanded : (Micheline_parser.location, string) Micheline.node) =
  let ({Michelson_v1_parser.expanded = expansion; _}, errors) =
    let source = print (Micheline.strip_locations original) in
    Michelson_v1_parser.expand_all ~source ~original
  in
  match errors with
  | [] ->
      Assert.equal
        ~print
        (Michelson_v1_primitives.strings_of_prims expansion)
        (Micheline.strip_locations expanded) ;
      ok ()
  | errors ->
      Error errors

(****************************************************************************)

open Micheline

let zero_loc = Micheline_parser.location_zero

let left_branch = Seq (zero_loc, [Prim (zero_loc, "SWAP", [], [])])

let right_branch = Seq (zero_loc, [])

(***************************************************************************)
(* Test expands *)
(***************************************************************************)

let assert_compare_macro prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "COMPARE", [], []);
           Prim (zero_loc, compare_name, [], []) ] ))

let test_compare_marco_expansion () =
  assert_compare_macro "CMPEQ" "EQ"
  >>? fun () ->
  assert_compare_macro "CMPNEQ" "NEQ"
  >>? fun () ->
  assert_compare_macro "CMPLT" "LT"
  >>? fun () ->
  assert_compare_macro "CMPGT" "GT"
  >>? fun () ->
  assert_compare_macro "CMPLE" "LE"
  >>? fun () -> assert_compare_macro "CMPGE" "GE"

let assert_if_macro prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [left_branch; right_branch], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, compare_name, [], []);
           Prim (zero_loc, "IF", [left_branch; right_branch], []) ] ))

let test_if_compare_macros_expansion () =
  assert_if_macro "IFEQ" "EQ"
  >>? fun () ->
  assert_if_macro "IFNEQ" "NEQ"
  >>? fun () ->
  assert_if_macro "IFLT" "LT"
  >>? fun () ->
  assert_if_macro "IFGT" "GT"
  >>? fun () ->
  assert_if_macro "IFLE" "LE" >>? fun () -> assert_if_macro "IFGE" "GE"

let assert_if_cmp_macros prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [left_branch; right_branch], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "COMPARE", [], []);
           Prim (zero_loc, compare_name, [], []);
           Prim (zero_loc, "IF", [left_branch; right_branch], []) ] ))

let test_if_cmp_macros_expansion () =
  assert_if_cmp_macros "IFCMPEQ" "EQ"
  >>? fun () ->
  assert_if_cmp_macros "IFCMPNEQ" "NEQ"
  >>? fun () ->
  assert_if_cmp_macros "IFCMPLT" "LT"
  >>? fun () ->
  assert_if_cmp_macros "IFCMPGT" "GT"
  >>? fun () ->
  assert_if_cmp_macros "IFCMPLE" "LE"
  >>? fun () -> assert_if_cmp_macros "IFCMPGE" "GE"

(****************************************************************************)
(* Fail *)

let test_fail_expansion () =
  assert_expands
    (Prim (zero_loc, "FAIL", [], []))
    (Seq
       ( zero_loc,
         [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])]
       ))

(**********************************************************************)
(* assertion *)

let seq_unit_failwith =
  Seq
    ( zero_loc,
      [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])] )

(* {} {FAIL} *)
let fail_false = [Seq (zero_loc, []); Seq (zero_loc, [seq_unit_failwith])]

(* {FAIL} {} *)
let fail_true = [Seq (zero_loc, [seq_unit_failwith]); Seq (zero_loc, [])]

let test_assert_expansion () =
  assert_expands
    (Prim (zero_loc, "ASSERT", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF", fail_false, [])]))

let assert_assert_if_compare prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, compare_name, [], []);
           Prim (zero_loc, "IF", fail_false, []) ] ))

let test_assert_if () =
  assert_assert_if_compare "ASSERT_EQ" "EQ"
  >>? fun () ->
  assert_assert_if_compare "ASSERT_NEQ" "NEQ"
  >>? fun () ->
  assert_assert_if_compare "ASSERT_LT" "LT"
  >>? fun () ->
  assert_assert_if_compare "ASSERT_LE" "LE"
  >>? fun () ->
  assert_assert_if_compare "ASSERT_GT" "GT"
  >>? fun () -> assert_assert_if_compare "ASSERT_GE" "GE"

let assert_cmp_if prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [], []))
    (Seq
       ( zero_loc,
         [ Seq
             ( zero_loc,
               [ Prim (zero_loc, "COMPARE", [], []);
                 Prim (zero_loc, compare_name, [], []) ] );
           Prim (zero_loc, "IF", fail_false, []) ] ))

let test_assert_cmp_if () =
  assert_cmp_if "ASSERT_CMPEQ" "EQ"
  >>? fun () ->
  assert_cmp_if "ASSERT_CMPNEQ" "NEQ"
  >>? fun () ->
  assert_cmp_if "ASSERT_CMPLT" "LT"
  >>? fun () ->
  assert_cmp_if "ASSERT_CMPLE" "LE"
  >>? fun () ->
  assert_cmp_if "ASSERT_CMPGT" "GT"
  >>? fun () -> assert_cmp_if "ASSERT_CMPGE" "GE"

(* The work of merge request !628
   > ASSERT_LEFT @x  =>  IF_LEFT {RENAME @x} {FAIL}
   > ASSERT_RIGHT @x  =>  IF_LEFT {FAIL} {RENAME @x}
   > ASSERT_SOME @x  =>  IF_NONE {FAIL} {RENAME @x}
*)

let may_rename annot = Seq (zero_loc, [Prim (zero_loc, "RENAME", [], annot)])

let fail_false_may_rename =
  [ may_rename ["@annot"];
    Seq
      ( zero_loc,
        [ Seq
            ( zero_loc,
              [ Prim (zero_loc, "UNIT", [], []);
                Prim (zero_loc, "FAILWITH", [], []) ] ) ] ) ]

let fail_true_may_rename =
  [ Seq
      ( zero_loc,
        [ Seq
            ( zero_loc,
              [ Prim (zero_loc, "UNIT", [], []);
                Prim (zero_loc, "FAILWITH", [], []) ] ) ] );
    may_rename ["@annot"] ]

let test_assert_some_annot () =
  assert_expands
    (Prim (zero_loc, "ASSERT_SOME", [], ["@annot"]))
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true_may_rename, [])]))

let test_assert_left_annot () =
  assert_expands
    (Prim (zero_loc, "ASSERT_LEFT", [], ["@annot"]))
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false_may_rename, [])]))

let test_assert_right_annot () =
  assert_expands
    (Prim (zero_loc, "ASSERT_RIGHT", [], ["@annot"]))
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true_may_rename, [])]))

let test_assert_none () =
  assert_expands
    (Prim (zero_loc, "ASSERT_NONE", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_false, [])]))

let test_assert_some () =
  assert_expands
    (Prim (zero_loc, "ASSERT_SOME", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true, [])]))

let test_assert_left () =
  assert_expands
    (Prim (zero_loc, "ASSERT_LEFT", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false, [])]))

let test_assert_right () =
  assert_expands
    (Prim (zero_loc, "ASSERT_RIGHT", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true, [])]))

(***********************************************************************)
(*Syntactic Conveniences*)

(* diip *)

let test_diip () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_expands
    (Prim (zero_loc, "DIP", [code], []))
    (Prim (zero_loc, "DIP", [code], []))
  >>? fun () ->
  assert_expands
    (Prim (zero_loc, "DIIIIIIIIP", [code], []))
    (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 8); code], []))
  >>? fun () ->
  assert_expands
    (Prim (zero_loc, "DIIP", [code], []))
    (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []))

(* pair *)

let test_pair () =
  assert_expands
    (Prim (zero_loc, "PAIR", [], []))
    (Prim (zero_loc, "PAIR", [], []))

let test_pappaiir () =
  let pair = Prim (zero_loc, "PAIR", [], []) in
  assert_expands
    (Prim (zero_loc, "PAPPAIIR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DIP", [Seq (zero_loc, [pair])], []);
           Prim (zero_loc, "DIP", [Seq (zero_loc, [pair])], []);
           pair ] ))

(* unpair *)

let test_unpair () =
  assert_expands
    (Prim (zero_loc, "UNPAIR", [], []))
    (Seq
       ( zero_loc,
         [ Seq
             ( zero_loc,
               [ Prim (zero_loc, "DUP", [], []);
                 Prim (zero_loc, "CAR", [], []);
                 Prim
                   ( zero_loc,
                     "DIP",
                     [Seq (zero_loc, [Prim (zero_loc, "CDR", [], [])])],
                     [] ) ] ) ] ))

(* duup *)

let test_duup () =
  let dup = Prim (zero_loc, "DUP", [], []) in
  assert_expands
    (Prim (zero_loc, "DUUP", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DIP", [Seq (zero_loc, [dup])], []);
           Prim (zero_loc, "SWAP", [], []) ] ))

(* car/cdr *)

let test_caddadr_expansion () =
  let car = Prim (zero_loc, "CAR", [], []) in
  assert_expands (Prim (zero_loc, "CAR", [], [])) car
  >>? fun () ->
  let cdr = Prim (zero_loc, "CDR", [], []) in
  assert_expands (Prim (zero_loc, "CDR", [], [])) cdr
  >>? fun () ->
  assert_expands (Prim (zero_loc, "CADR", [], [])) (Seq (zero_loc, [car; cdr]))
  >>? fun () ->
  assert_expands (Prim (zero_loc, "CDAR", [], [])) (Seq (zero_loc, [cdr; car]))

(* if_some *)

let test_if_some () =
  assert_expands
    (Prim (zero_loc, "IF_SOME", [right_branch; left_branch], []))
    (Seq
       (zero_loc, [Prim (zero_loc, "IF_NONE", [left_branch; right_branch], [])]))

(*set_caddadr*)

let test_set_car_expansion () =
  assert_expands
    (Prim (zero_loc, "SET_CAR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))

let test_set_cdr_expansion () =
  assert_expands
    (Prim (zero_loc, "SET_CDR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))

let test_set_cadr_expansion () =
  let set_car =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "CAR", [], ["@%%"]);
          Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
  in
  assert_expands
    (Prim (zero_loc, "SET_CADR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); set_car])],
               [] );
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

let test_set_cdar_expansion () =
  let set_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] )
  in
  assert_expands
    (Prim (zero_loc, "SET_CDAR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); set_cdr])],
               [] );
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

(* TO BE CHANGE IN THE DOCUMENTATION: @MR!791
   FROM:
   > MAP_CAR code  =>  DUP ; CDR ; DIP { CAR ; code } ; SWAP ; PAIR
   TO:
   > MAP_CAR code  =>  DUP ; CDR ; DIP { CAR ; {code} } ; SWAP ; PAIR
*)

let test_map_car () =
  (* code is a sequence *)
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_expands
    (Prim (zero_loc, "MAP_CAR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], []); code])],
               [] );
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))

let test_map_cdr () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_expands
    (Prim (zero_loc, "MAP_CDR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], []);
           code;
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))

let test_map_caadr () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  let map_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim (zero_loc, "CDR", [], []);
          code;
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "CAR", [], ["@%%"]);
          Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
  in
  let map_cadr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim
            ( zero_loc,
              "DIP",
              [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
              [] );
          Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
  in
  assert_expands
    (Prim (zero_loc, "MAP_CAADR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cadr])],
               [] );
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

let test_map_cdadr () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  let map_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim (zero_loc, "CDR", [], []);
          code;
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "CAR", [], ["@%%"]);
          Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
  in
  let map_cadr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim
            ( zero_loc,
              "DIP",
              [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
              [] );
          Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
  in
  assert_expands
    (Prim (zero_loc, "MAP_CDADR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); map_cadr])],
               [] );
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

(****************************************************************************)
(* Unexpand tests *)
(****************************************************************************)

(* unpexpanded : original expression with macros *)

let assert_unexpansion original ex =
  let ({Michelson_v1_parser.expanded; _}, errors) =
    let source = print (Micheline.strip_locations original) in
    Michelson_v1_parser.expand_all ~source ~original
  in
  let unparse = Michelson_v1_printer.unparse_expression expanded in
  match errors with
  | [] ->
      Assert.equal
        ~print
        unparse.Michelson_v1_parser.unexpanded
        (Micheline.strip_locations ex) ;
      ok ()
  | _ :: _ ->
      Error errors

let assert_unexpansion_consistent original =
  let ({Michelson_v1_parser.expanded; _}, errors) =
    let source = print (Micheline.strip_locations original) in
    Michelson_v1_parser.expand_all ~source ~original
  in
  match errors with
  | _ :: _ ->
      Error errors
  | [] ->
      let {Michelson_v1_parser.unexpanded; _} =
        Michelson_v1_printer.unparse_expression expanded
      in
      Assert.equal ~print unexpanded (Micheline.strip_locations original) ;
      ok ()

let test_unexpand_fail () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])]
       ))
    (Prim (zero_loc, "FAIL", [], []))

let test_unexpand_if_right () =
  assert_unexpansion
    (Seq
       (zero_loc, [Prim (zero_loc, "IF_LEFT", [left_branch; right_branch], [])]))
    (Prim (zero_loc, "IF_RIGHT", [right_branch; left_branch], []))

let test_unexpand_if_some () =
  assert_unexpansion
    (Seq
       (zero_loc, [Prim (zero_loc, "IF_NONE", [left_branch; right_branch], [])]))
    (Prim (zero_loc, "IF_SOME", [right_branch; left_branch], []))

let test_unexpand_assert () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF", fail_false, [])]))
    (Prim (zero_loc, "ASSERT", [], []))

let assert_unexpansion_assert_if_compare compare_name prim_name =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, compare_name, [], []);
           Prim (zero_loc, "IF", fail_false, []) ] ))
    (Prim (zero_loc, prim_name, [], []))

let test_unexpand_assert_if () =
  assert_unexpansion_assert_if_compare "EQ" "ASSERT_EQ"
  >>? fun () ->
  assert_unexpansion_assert_if_compare "NEQ" "ASSERT_NEQ"
  >>? fun () ->
  assert_unexpansion_assert_if_compare "LT" "ASSERT_LT"
  >>? fun () ->
  assert_unexpansion_assert_if_compare "LE" "ASSERT_LE"
  >>? fun () ->
  assert_unexpansion_assert_if_compare "GT" "ASSERT_GT"
  >>? fun () -> assert_unexpansion_assert_if_compare "GE" "ASSERT_GE"

let assert_unexpansion_assert_cmp_if_compare compare_name prim_name =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Seq
             ( zero_loc,
               [ Prim (zero_loc, "COMPARE", [], []);
                 Prim (zero_loc, compare_name, [], []) ] );
           Prim (zero_loc, "IF", fail_false, []) ] ))
    (Prim (zero_loc, prim_name, [], []))

let test_unexpansion_assert_cmp_if () =
  assert_unexpansion_assert_cmp_if_compare "EQ" "ASSERT_CMPEQ"
  >>? fun () ->
  assert_unexpansion_assert_cmp_if_compare "NEQ" "ASSERT_CMPNEQ"
  >>? fun () ->
  assert_unexpansion_assert_cmp_if_compare "LT" "ASSERT_CMPLT"
  >>? fun () ->
  assert_unexpansion_assert_cmp_if_compare "LE" "ASSERT_CMPLE"
  >>? fun () ->
  assert_unexpansion_assert_cmp_if_compare "GT" "ASSERT_CMPGT"
  >>? fun () -> assert_unexpansion_assert_cmp_if_compare "GE" "ASSERT_CMPGE"

let test_unexpand_assert_some_annot () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true_may_rename, [])]))
    (Prim (zero_loc, "ASSERT_SOME", [], ["@annot"]))

let test_unexpand_assert_left_annot () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false_may_rename, [])]))
    (Prim (zero_loc, "ASSERT_LEFT", [], ["@annot"]))

let test_unexpand_assert_right_annot () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true_may_rename, [])]))
    (Prim (zero_loc, "ASSERT_RIGHT", [], ["@annot"]))

let test_unexpand_assert_none () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_false, [])]))
    (Prim (zero_loc, "ASSERT_NONE", [], []))

let test_unexpand_assert_some () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true, [])]))
    (Prim (zero_loc, "ASSERT_SOME", [], []))

let test_unexpand_assert_left () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false, [])]))
    (Prim (zero_loc, "ASSERT_LEFT", [], []))

let test_unexpand_assert_right () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true, [])]))
    (Prim (zero_loc, "ASSERT_RIGHT", [], []))

let test_unexpand_unpair () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Seq
             ( zero_loc,
               [ Prim (zero_loc, "DUP", [], []);
                 Prim (zero_loc, "CAR", [], []);
                 Prim
                   ( zero_loc,
                     "DIP",
                     [Seq (zero_loc, [Prim (zero_loc, "CDR", [], [])])],
                     [] ) ] ) ] ))
    (Prim (zero_loc, "UNPAIR", [], []))

let test_unexpand_pair () =
  assert_unexpansion
    (Prim (zero_loc, "PAIR", [], []))
    (Prim (zero_loc, "PAIR", [], []))

let test_unexpand_pappaiir () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
               [] );
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
               [] );
           Prim (zero_loc, "PAIR", [], []) ] ))
    (Prim (zero_loc, "PAPPAIIR", [], []))

let test_unexpand_duup () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "DUP", [], [])])],
               [] );
           Prim (zero_loc, "SWAP", [], []) ] ))
    (Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], []))

let test_unexpand_caddadr () =
  let car = Prim (zero_loc, "CAR", [], []) in
  let cdr = Prim (zero_loc, "CDR", [], []) in
  assert_unexpansion (Seq (zero_loc, [car])) car
  >>? fun () ->
  assert_unexpansion (Seq (zero_loc, [cdr])) cdr
  >>? fun () ->
  assert_unexpansion
    (Seq (zero_loc, [car; cdr]))
    (Prim (zero_loc, "CADR", [], []))
  >>? fun () ->
  assert_unexpansion
    (Seq (zero_loc, [cdr; car]))
    (Prim (zero_loc, "CDAR", [], []))

let test_unexpand_set_car () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))
    (Prim (zero_loc, "SET_CAR", [], []))

let test_unexpand_set_cdr () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))
    (Prim (zero_loc, "SET_CDR", [], []))

let test_unexpand_set_car_annot () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CAR", [], ["%@"]);
           Prim (zero_loc, "DROP", [], []);
           Prim (zero_loc, "CDR", [], []);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], []) ] ))
    (Prim (zero_loc, "SET_CAR", [], ["%@"]))

let test_unexpand_set_cdr_annot () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], ["%@"]);
           Prim (zero_loc, "DROP", [], []);
           Prim (zero_loc, "CAR", [], []);
           Prim (zero_loc, "PAIR", [], []) ] ))
    (Prim (zero_loc, "SET_CDR", [], ["%@"]))

let test_unexpand_set_cadr () =
  let set_car =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "CAR", [], ["@%%"]);
          Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
  in
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); set_car])],
               [] );
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
    (Prim (zero_loc, "SET_CADR", [], []))

let test_unexpand_set_cdar () =
  let set_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] )
  in
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); set_cdr])],
               [] );
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
    (Prim (zero_loc, "SET_CDAR", [], []))

(* FIXME: Seq()(Prim): does not parse, raise an error unparse *)
let test_unexpand_map_car () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_unexpansion
    (Prim (zero_loc, "MAP_CAR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim
             ( zero_loc,
               "DIP",
               [ Seq
                   ( zero_loc,
                     [ Prim (zero_loc, "CAR", [], []);
                       Prim (zero_loc, "CAR", [], []) ] ) ],
               [] );
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))

(***********************************************************************)
(*BUG: DIIP and the test with MAP_CDR: or any map with "D" inside fail *)

let test_unexpand_diip () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_unexpansion
    (Prim (zero_loc, "DIIP", [code], []))
    (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []))

let test_unexpand_map_cdr () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], []);
           code;
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "CAR", [], []);
           Prim (zero_loc, "PAIR", [], []) ] ))
    (Prim (zero_loc, "MAP_CDR", [code], []))

let test_unexpand_map_caadr () =
  let code = [Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])])] in
  let map_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim
            ( zero_loc,
              "DIP",
              [ Seq
                  ( zero_loc,
                    [ Prim (zero_loc, "CAR", [], ["@%%"]);
                      Seq
                        ( zero_loc,
                          [ Prim (zero_loc, "DUP", [], []);
                            Prim (zero_loc, "CDR", [], []);
                            Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]);
                            Prim (zero_loc, "SWAP", [], []);
                            Prim (zero_loc, "CAR", [], ["@%%"]);
                            Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ) ] ) ],
              [] );
          Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
  in
  assert_unexpansion
    (Prim (zero_loc, "MAP_CAAR", code, []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
               [] );
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

let test_unexpand_map_cdadr () =
  let code = [Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])])] in
  let map_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim
            ( zero_loc,
              "DIP",
              [ Seq
                  ( zero_loc,
                    [ Prim (zero_loc, "CAR", [], ["@%%"]);
                      Seq
                        ( zero_loc,
                          [ Prim (zero_loc, "DUP", [], []);
                            Prim (zero_loc, "CDR", [], []);
                            Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]);
                            Prim (zero_loc, "SWAP", [], []);
                            Prim (zero_loc, "CAR", [], ["@%%"]);
                            Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ) ] ) ],
              [] );
          Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
  in
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); map_cdr])],
               [] );
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
    (Prim (zero_loc, "MAP_CDADR", code, []))

let test_unexpand_diip_duup1 () =
  let single code = Seq (zero_loc, [code]) in
  let cst str = Prim (zero_loc, str, [], []) in
  let app str code = Prim (zero_loc, str, [code], []) in
  let dip = app "DIP" in
  let diip code =
    Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])
  in
  let dup = cst "DUP" in
  let swap = cst "SWAP" in
  let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in
  assert_unexpansion
    (* { DIP { DIP { DIP { DUP }; SWAP }}} *)
    (single (dip (single (dip dip_dup_swap))))
    (* DIIP { DIP { DUP }; SWAP } *)
    (diip dip_dup_swap)

let test_unexpand_diip_duup2 () =
  let single code = Seq (zero_loc, [code]) in
  let cst str = Prim (zero_loc, str, [], []) in
  let app str code = Prim (zero_loc, str, [code], []) in
  let dip = app "DIP" in
  let diip code =
    Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])
  in
  let dup = cst "DUP" in
  let duup = Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], []) in
  let swap = cst "SWAP" in
  let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in
  assert_unexpansion
    (* { DIP { DIP {{ DIP { DUP }; SWAP }}}} *)
    (single (dip (single (dip (single dip_dup_swap)))))
    (* DIIP { DUUP } *)
    (diip (single duup))

(*****************************************************************************)
(* Test           *)
(*****************************************************************************)

let tests =
  [ (*compare*)
    ("compare expansion", fun _ -> Lwt.return (test_compare_marco_expansion ()));
    ( "if compare expansion",
      fun _ -> Lwt.return (test_if_compare_macros_expansion ()) );
    ( "if compare expansion: IFCMP",
      fun _ -> Lwt.return (test_if_cmp_macros_expansion ()) );
    (*fail*)
    ("fail expansion", fun _ -> Lwt.return (test_fail_expansion ()));
    (*assertion*)
    ("assert expansion", fun _ -> Lwt.return (test_assert_expansion ()));
    ("assert if expansion", fun _ -> Lwt.return (test_assert_if ()));
    ("assert cmpif expansion", fun _ -> Lwt.return (test_assert_cmp_if ()));
    ("assert none expansion", fun _ -> Lwt.return (test_assert_none ()));
    ("assert some expansion", fun _ -> Lwt.return (test_assert_some ()));
    ("assert left expansion", fun _ -> Lwt.return (test_assert_left ()));
    ("assert right expansion", fun _ -> Lwt.return (test_assert_right ()));
    ( "assert some annot expansion",
      fun _ -> Lwt.return (test_assert_some_annot ()) );
    ( "assert left annot expansion",
      fun _ -> Lwt.return (test_assert_left_annot ()) );
    ( "assert right annot expansion",
      fun _ -> Lwt.return (test_assert_right_annot ()) );
    (*syntactic conveniences*)
    ("diip expansion", fun _ -> Lwt.return (test_diip ()));
    ("duup expansion", fun _ -> Lwt.return (test_duup ()));
    ("pair expansion", fun _ -> Lwt.return (test_pair ()));
    ("pappaiir expansion", fun _ -> Lwt.return (test_pappaiir ()));
    ("unpair expansion", fun _ -> Lwt.return (test_unpair ()));
    ("caddadr expansion", fun _ -> Lwt.return (test_caddadr_expansion ()));
    ("if_some expansion", fun _ -> Lwt.return (test_if_some ()));
    ("set_car expansion", fun _ -> Lwt.return (test_set_car_expansion ()));
    ("set_cdr expansion", fun _ -> Lwt.return (test_set_cdr_expansion ()));
    ("set_cadr expansion", fun _ -> Lwt.return (test_set_cadr_expansion ()));
    ("set_cdar expansion", fun _ -> Lwt.return (test_set_cdar_expansion ()));
    ("map_car expansion", fun _ -> Lwt.return (test_map_car ()));
    ("map_cdr expansion", fun _ -> Lwt.return (test_map_cdr ()));
    ("map_caadr expansion", fun _ -> Lwt.return (test_map_caadr ()));
    ("map_cdadr expansion", fun _ -> Lwt.return (test_map_cdadr ()));
    (*Unexpand*)
    ("fail unexpansion", fun _ -> Lwt.return (test_unexpand_fail ()));
    ("if_right unexpansion", fun _ -> Lwt.return (test_unexpand_if_right ()));
    ("if_some unexpansion", fun _ -> Lwt.return (test_unexpand_if_some ()));
    ("assert unexpansion", fun _ -> Lwt.return (test_unexpand_assert ()));
    ("assert_if unexpansion", fun _ -> Lwt.return (test_unexpand_assert_if ()));
    ( "assert_cmp_if unexpansion",
      fun _ -> Lwt.return (test_unexpansion_assert_cmp_if ()) );
    ( "assert_none unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_none ()) );
    ( "assert_some unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_some ()) );
    ( "assert_left unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_left ()) );
    ( "assert_right unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_right ()) );
    ( "assert_some annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_some_annot ()) );
    ( "assert_left annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_left_annot ()) );
    ( "assert_right annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_right_annot ()) );
    ("unpair unexpansion", fun _ -> Lwt.return (test_unexpand_unpair ()));
    ("pair unexpansion", fun _ -> Lwt.return (test_unexpand_pair ()));
    ("pappaiir unexpansion", fun _ -> Lwt.return (test_unexpand_pappaiir ()));
    ("duup unexpansion", fun _ -> Lwt.return (test_unexpand_duup ()));
    ("caddadr unexpansion", fun _ -> Lwt.return (test_unexpand_caddadr ()));
    ("set_car unexpansion", fun _ -> Lwt.return (test_unexpand_set_car ()));
    ("set_cdr unexpansion", fun _ -> Lwt.return (test_unexpand_set_cdr ()));
    ("set_cadr unexpansion", fun _ -> Lwt.return (test_unexpand_set_cadr ()));
    ( "set_car annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_set_car_annot ()) );
    ( "set_cdr annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_set_cdr_annot ()) );
    ("map_car unexpansion", fun _ -> Lwt.return (test_unexpand_map_car ()));
    ( "diip_duup1 unexpansion",
      fun _ -> Lwt.return (test_unexpand_diip_duup1 ()) );
    ( "diip_duup2 unexpansion",
      fun _ -> Lwt.return (test_unexpand_diip_duup2 ()) )
    (***********************************************************************)
    (*BUG
      the function in Michelson_v1_macros.unexpand_map_caddadr
      failed to test the case with the character "D".
      It returns an empty {} for the expand *)
    (*"diip unexpansion",  (fun _ -> Lwt.return (test_unexpand_diip ())) ;*)
    (*"map_cdr unexpansion",  (fun _ -> Lwt.return (test_unexpand_map_cdr ())) ;*)
    (*"map_caadr unexpansion",  (fun _ -> Lwt.return (test_unexpand_map_caadr ())) ;*)
    (*"map_cdadr unexpansion",  (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*)
   ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-lib-client"
    [("micheline v1 macros", List.map wrap tests)]
src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition print {A : Type} (expr : A) : string :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply expr
      (op_star_t_y_p_e_minus_e_r_r_o_r_star (fun s => s)))
    (Stdlib.Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) op_star_t_y_p_e_minus_e_r_r_o_r_star).

Definition assert_expands {A B : Type} (function_parameter : A)
  : B -> Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        match
          let source :=
            print
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star) in
          Tezos_client_alpha.Michelson_v1_parser.expand_all source
            op_star_t_y_p_e_minus_e_r_r_o_r_star with
        | ({| Michelson_v1_parser.expanded := expansion |}, errors) =>
          match errors with
          | [] =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star print
              (Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.strings_of_prims
                expansion)
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star);
            Tezos_base__TzPervasives.ok tt
          | errors => inr errors
          end
        end
      end
  end.

Definition zero_loc {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition left_branch {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition right_branch {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition assert_compare_macro {A B : Type} (prim_name : A) (compare_name : B)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition test_compare_marco_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_compare_macro "CMPEQ" % string "EQ" % string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_compare_macro "CMPNEQ" % string "NEQ" % string)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_compare_macro "CMPLT" % string "LT" % string)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_question
                        (assert_compare_macro "CMPGT" % string "GT" % string)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_question
                              (assert_compare_macro "CMPLE" % string
                                "LE" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  assert_compare_macro "CMPGE" % string
                                    "GE" % string
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition assert_if_macro {A B : Type} (prim_name : A) (compare_name : B)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition test_if_compare_macros_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_if_macro "IFEQ" % string "EQ" % string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_if_macro "IFNEQ" % string "NEQ" % string)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_if_macro "IFLT" % string "LT" % string)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_question
                        (assert_if_macro "IFGT" % string "GT" % string)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_question
                              (assert_if_macro "IFLE" % string "LE" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  assert_if_macro "IFGE" % string "GE" % string
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition assert_if_cmp_macros {A B : Type} (prim_name : A) (compare_name : B)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition test_if_cmp_macros_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_if_cmp_macros "IFCMPEQ" % string "EQ" % string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_if_cmp_macros "IFCMPNEQ" % string "NEQ" % string)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_if_cmp_macros "IFCMPLT" % string "LT" % string)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_question
                        (assert_if_cmp_macros "IFCMPGT" % string "GT" % string)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_question
                              (assert_if_cmp_macros "IFCMPLE" % string
                                "LE" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  assert_if_cmp_macros "IFCMPGE" % string
                                    "GE" % string
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition test_fail_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition seq_unit_failwith {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition fail_false {A : Type} : list A :=
  cons op_star_t_y_p_e_minus_e_r_r_o_r_star
    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []).

Definition fail_true {A : Type} : list A :=
  cons op_star_t_y_p_e_minus_e_r_r_o_r_star
    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []).

Definition test_assert_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition assert_assert_if_compare {A B : Type}
  (prim_name : A) (compare_name : B) : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition test_assert_if (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_assert_if_compare "ASSERT_EQ" % string "EQ" % string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_assert_if_compare "ASSERT_NEQ" % string "NEQ" % string)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_assert_if_compare "ASSERT_LT" % string "LT" % string)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_question
                        (assert_assert_if_compare "ASSERT_LE" % string
                          "LE" % string)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_question
                              (assert_assert_if_compare "ASSERT_GT" % string
                                "GT" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  assert_assert_if_compare "ASSERT_GE" % string
                                    "GE" % string
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition assert_cmp_if {A B : Type} (prim_name : A) (compare_name : B)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition test_assert_cmp_if (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_cmp_if "ASSERT_CMPEQ" % string "EQ" % string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_cmp_if "ASSERT_CMPNEQ" % string "NEQ" % string)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_cmp_if "ASSERT_CMPLT" % string "LT" % string)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_question
                        (assert_cmp_if "ASSERT_CMPLE" % string "LE" % string)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_question
                              (assert_cmp_if "ASSERT_CMPGT" % string
                                "GT" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  assert_cmp_if "ASSERT_CMPGE" % string
                                    "GE" % string
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition may_rename {A B : Type} (annot : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition fail_false_may_rename {A : Type} : list A :=
  cons (may_rename (cons "@annot" % string []))
    (cons op_star_t_y_p_e_minus_e_r_r_o_r_star []).

Definition fail_true_may_rename {A : Type} : list A :=
  cons op_star_t_y_p_e_minus_e_r_r_o_r_star
    (cons (may_rename (cons "@annot" % string [])) []).

Definition test_assert_some_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_assert_left_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_assert_right_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_assert_none (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_assert_some (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_assert_left (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_assert_right (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_diip (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
        op_star_t_y_p_e_minus_e_r_r_o_r_star)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
              end)
        end)
  end.

Definition test_pair (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_pappaiir (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let pair := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unpair (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_duup (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let dup := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_caddadr_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let car := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star car)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let cdr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star cdr)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                    end)
              end)
        end)
  end.

Definition test_if_some (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_set_car_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_set_cdr_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_set_cadr_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let set_car := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_set_cdar_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let set_cdr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_map_car (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_map_cdr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_map_caadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let map_cdr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let map_cadr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_map_cdadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let map_cdr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let map_cadr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_expands op_star_t_y_p_e_minus_e_r_r_o_r_star
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition assert_unexpansion {A : Type}
  (original : Tezos_micheline.Micheline_parser.node) (ex : A)
  : Tezos_base__TzPervasives.tzresult unit :=
  match
    let source := print (op_star_t_y_p_e_minus_e_r_r_o_r_star original) in
    Tezos_client_alpha.Michelson_v1_parser.expand_all source original with
  | ({| Michelson_v1_parser.expanded := expanded |}, errors) =>
    let unparse :=
      Tezos_client_alpha.Michelson_v1_printer.unparse_expression expanded in
    match errors with
    | [] =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star print
        (Michelson_v1_parser.unexpanded unparse)
        (op_star_t_y_p_e_minus_e_r_r_o_r_star ex);
      Tezos_base__TzPervasives.ok tt
    | cons _ _ => inr errors
    end
  end.

Definition assert_unexpansion_consistent
  (original : Tezos_micheline.Micheline_parser.node)
  : sum unit (list Tezos_error_monad.Error_monad.error) :=
  match
    let source := print (op_star_t_y_p_e_minus_e_r_r_o_r_star original) in
    Tezos_client_alpha.Michelson_v1_parser.expand_all source original with
  | ({| Michelson_v1_parser.expanded := expanded |}, errors) =>
    match errors with
    | cons _ _ => inr errors
    | [] =>
      match Tezos_client_alpha.Michelson_v1_printer.unparse_expression expanded
        with
      | {| Michelson_v1_parser.unexpanded := unexpanded |} =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star print unexpanded
          (op_star_t_y_p_e_minus_e_r_r_o_r_star original);
        Tezos_base__TzPervasives.ok tt
      end
    end
  end.

Definition test_unexpand_fail (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "UNIT" % string [] [])
          (cons (Prim zero_loc "FAILWITH" % string [] []) [])))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_if_right (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons
          (Prim zero_loc "IF_LEFT" % string
            (cons left_branch (cons right_branch [])) []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_if_some (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons
          (Prim zero_loc "IF_NONE" % string
            (cons left_branch (cons right_branch [])) []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_assert (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc (cons (Prim zero_loc "IF" % string fail_false []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition assert_unexpansion_assert_if_compare {A : Type}
  (compare_name : string) (prim_name : A)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_unexpansion
    (Seq zero_loc
      (cons (Prim zero_loc compare_name [] [])
        (cons (Prim zero_loc "IF" % string fail_false []) [])))
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition test_unexpand_assert_if (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_unexpansion_assert_if_compare "EQ" % string "ASSERT_EQ" % string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_unexpansion_assert_if_compare "NEQ" % string
              "ASSERT_NEQ" % string)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_unexpansion_assert_if_compare "LT" % string
                    "ASSERT_LT" % string)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_question
                        (assert_unexpansion_assert_if_compare "LE" % string
                          "ASSERT_LE" % string)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_question
                              (assert_unexpansion_assert_if_compare
                                "GT" % string "ASSERT_GT" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  assert_unexpansion_assert_if_compare
                                    "GE" % string "ASSERT_GE" % string
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition assert_unexpansion_assert_cmp_if_compare {A : Type}
  (compare_name : string) (prim_name : A)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_unexpansion
    (Seq zero_loc
      (cons
        (Seq zero_loc
          (cons (Prim zero_loc "COMPARE" % string [] [])
            (cons (Prim zero_loc compare_name [] []) [])))
        (cons (Prim zero_loc "IF" % string fail_false []) [])))
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition test_unexpansion_assert_cmp_if (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_unexpansion_assert_cmp_if_compare "EQ" % string
        "ASSERT_CMPEQ" % string)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_unexpansion_assert_cmp_if_compare "NEQ" % string
              "ASSERT_CMPNEQ" % string)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_unexpansion_assert_cmp_if_compare "LT" % string
                    "ASSERT_CMPLT" % string)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_question
                        (assert_unexpansion_assert_cmp_if_compare "LE" % string
                          "ASSERT_CMPLE" % string)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_question
                              (assert_unexpansion_assert_cmp_if_compare
                                "GT" % string "ASSERT_CMPGT" % string)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  assert_unexpansion_assert_cmp_if_compare
                                    "GE" % string "ASSERT_CMPGE" % string
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition test_unexpand_assert_some_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "IF_NONE" % string fail_true_may_rename []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_assert_left_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "IF_LEFT" % string fail_false_may_rename []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_assert_right_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "IF_LEFT" % string fail_true_may_rename []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_assert_none (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc (cons (Prim zero_loc "IF_NONE" % string fail_false []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_assert_some (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc (cons (Prim zero_loc "IF_NONE" % string fail_true []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_assert_left (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc (cons (Prim zero_loc "IF_LEFT" % string fail_false []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_assert_right (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc (cons (Prim zero_loc "IF_LEFT" % string fail_true []) []))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_unpair (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons
          (Seq zero_loc
            (cons (Prim zero_loc "DUP" % string [] [])
              (cons (Prim zero_loc "CAR" % string [] [])
                (cons
                  (Prim zero_loc "DIP" % string
                    (cons
                      (Seq zero_loc
                        (cons (Prim zero_loc "CDR" % string [] []) [])) []) [])
                  [])))) [])) op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_pair (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion (Prim zero_loc "PAIR" % string [] [])
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_pappaiir (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons
          (Prim zero_loc "DIP" % string
            (cons (Seq zero_loc (cons (Prim zero_loc "PAIR" % string [] []) []))
              []) [])
          (cons
            (Prim zero_loc "DIP" % string
              (cons
                (Seq zero_loc (cons (Prim zero_loc "PAIR" % string [] []) []))
                []) []) (cons (Prim zero_loc "PAIR" % string [] []) []))))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_duup (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons
          (Prim zero_loc "DIP" % string
            (cons (Seq zero_loc (cons (Prim zero_loc "DUP" % string [] []) []))
              []) []) (cons (Prim zero_loc "SWAP" % string [] []) [])))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_caddadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let car := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let cdr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    Tezos_base__TzPervasives.op_gt_gt_question
      (assert_unexpansion (Seq zero_loc (cons car [])) car)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_question
            (assert_unexpansion (Seq zero_loc (cons cdr [])) cdr)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_question
                  (assert_unexpansion (Seq zero_loc (cons car (cons cdr [])))
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      assert_unexpansion (Seq zero_loc (cons cdr (cons car [])))
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                    end)
              end)
        end)
  end.

Definition test_unexpand_set_car (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "CDR" % string [] (cons "@%%" % string []))
          (cons (Prim zero_loc "SWAP" % string [] [])
            (cons
              (Prim zero_loc "PAIR" % string []
                (cons "%" % string (cons "%@" % string []))) []))))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_set_cdr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "CAR" % string [] (cons "@%%" % string []))
          (cons
            (Prim zero_loc "PAIR" % string []
              (cons "%@" % string (cons "%" % string []))) [])))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_set_car_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "DUP" % string [] [])
          (cons (Prim zero_loc "CAR" % string [] (cons "%@" % string []))
            (cons (Prim zero_loc "DROP" % string [] [])
              (cons (Prim zero_loc "CDR" % string [] [])
                (cons (Prim zero_loc "SWAP" % string [] [])
                  (cons (Prim zero_loc "PAIR" % string [] []) [])))))))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_set_cdr_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "DUP" % string [] [])
          (cons (Prim zero_loc "CDR" % string [] (cons "%@" % string []))
            (cons (Prim zero_loc "DROP" % string [] [])
              (cons (Prim zero_loc "CAR" % string [] [])
                (cons (Prim zero_loc "PAIR" % string [] []) []))))))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_set_cadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let set_car := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "DUP" % string [] [])
          (cons
            (Prim zero_loc "DIP" % string
              (cons
                (Seq zero_loc
                  (cons
                    (Prim zero_loc "CAR" % string [] (cons "@%%" % string []))
                    (cons set_car []))) []) [])
            (cons (Prim zero_loc "CDR" % string [] (cons "@%%" % string []))
              (cons (Prim zero_loc "SWAP" % string [] [])
                (cons
                  (Prim zero_loc "PAIR" % string []
                    (cons "%@" % string (cons "%@" % string []))) []))))))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_set_cdar (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let set_cdr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "DUP" % string [] [])
          (cons
            (Prim zero_loc "DIP" % string
              (cons
                (Seq zero_loc
                  (cons
                    (Prim zero_loc "CDR" % string [] (cons "@%%" % string []))
                    (cons set_cdr []))) []) [])
            (cons (Prim zero_loc "CAR" % string [] (cons "@%%" % string []))
              (cons
                (Prim zero_loc "PAIR" % string []
                  (cons "%@" % string (cons "%@" % string []))) [])))))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_map_car (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion (Prim zero_loc "MAP_CAR" % string (cons code []) [])
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_diip (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion (Prim zero_loc "DIIP" % string (cons code []) [])
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_map_cdr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "DUP" % string [] [])
          (cons (Prim zero_loc "CDR" % string [] [])
            (cons code
              (cons (Prim zero_loc "SWAP" % string [] [])
                (cons (Prim zero_loc "CAR" % string [] [])
                  (cons (Prim zero_loc "PAIR" % string [] []) [])))))))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_map_caadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := cons op_star_t_y_p_e_minus_e_r_r_o_r_star [] in
    let map_cdr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion (Prim zero_loc "MAP_CAAR" % string code [])
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_map_cdadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let code := cons op_star_t_y_p_e_minus_e_r_r_o_r_star [] in
    let map_cdr := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion
      (Seq zero_loc
        (cons (Prim zero_loc "DUP" % string [] [])
          (cons
            (Prim zero_loc "DIP" % string
              (cons
                (Seq zero_loc
                  (cons
                    (Prim zero_loc "CDR" % string [] (cons "@%%" % string []))
                    (cons map_cdr []))) []) [])
            (cons (Prim zero_loc "CAR" % string [] (cons "@%%" % string []))
              (cons
                (Prim zero_loc "PAIR" % string []
                  (cons "%@" % string (cons "%@" % string []))) [])))))
      op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition test_unexpand_diip_duup1 (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let single {A B : Type} (code : A) : B :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let cst {A B : Type} (str : A) : B :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let app {A B C : Type} (str : A) (code : B) : C :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let dip := app "DIP" % string in
    let diip {A B : Type} (code : A) : B :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let dup := cst "DUP" % string in
    let swap := cst "SWAP" % string in
    let dip_dup_swap := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion (single (dip (single (dip dip_dup_swap))))
      (diip dip_dup_swap)
  end.

Definition test_unexpand_diip_duup2 (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  match function_parameter with
  | tt =>
    let single {A B : Type} (code : A) : B :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let cst {A B : Type} (str : A) : B :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let app {A B C : Type} (str : A) (code : B) : C :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let dip := app "DIP" % string in
    let diip {A B : Type} (code : A) : B :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let dup := cst "DUP" % string in
    let duup := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    let swap := cst "SWAP" % string in
    let dip_dup_swap := op_star_t_y_p_e_minus_e_r_r_o_r_star in
    assert_unexpansion (single (dip (single (dip (single dip_dup_swap)))))
      (diip (single duup))
  end.

Definition tests {A : Type}
  : list (string * (A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  cons
    ("compare expansion" % string,
      (fun function_parameter =>
        match function_parameter with
        | _ => Lwt._return (test_compare_marco_expansion tt)
        end))
    (cons
      ("if compare expansion" % string,
        (fun function_parameter =>
          match function_parameter with
          | _ => Lwt._return (test_if_compare_macros_expansion tt)
          end))
      (cons
        ("if compare expansion: IFCMP" % string,
          (fun function_parameter =>
            match function_parameter with
            | _ => Lwt._return (test_if_cmp_macros_expansion tt)
            end))
        (cons
          ("fail expansion" % string,
            (fun function_parameter =>
              match function_parameter with
              | _ => Lwt._return (test_fail_expansion tt)
              end))
          (cons
            ("assert expansion" % string,
              (fun function_parameter =>
                match function_parameter with
                | _ => Lwt._return (test_assert_expansion tt)
                end))
            (cons
              ("assert if expansion" % string,
                (fun function_parameter =>
                  match function_parameter with
                  | _ => Lwt._return (test_assert_if tt)
                  end))
              (cons
                ("assert cmpif expansion" % string,
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => Lwt._return (test_assert_cmp_if tt)
                    end))
                (cons
                  ("assert none expansion" % string,
                    (fun function_parameter =>
                      match function_parameter with
                      | _ => Lwt._return (test_assert_none tt)
                      end))
                  (cons
                    ("assert some expansion" % string,
                      (fun function_parameter =>
                        match function_parameter with
                        | _ => Lwt._return (test_assert_some tt)
                        end))
                    (cons
                      ("assert left expansion" % string,
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => Lwt._return (test_assert_left tt)
                          end))
                      (cons
                        ("assert right expansion" % string,
                          (fun function_parameter =>
                            match function_parameter with
                            | _ => Lwt._return (test_assert_right tt)
                            end))
                        (cons
                          ("assert some annot expansion" % string,
                            (fun function_parameter =>
                              match function_parameter with
                              | _ => Lwt._return (test_assert_some_annot tt)
                              end))
                          (cons
                            ("assert left annot expansion" % string,
                              (fun function_parameter =>
                                match function_parameter with
                                | _ => Lwt._return (test_assert_left_annot tt)
                                end))
                            (cons
                              ("assert right annot expansion" % string,
                                (fun function_parameter =>
                                  match function_parameter with
                                  | _ =>
                                    Lwt._return (test_assert_right_annot tt)
                                  end))
                              (cons
                                ("diip expansion" % string,
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ => Lwt._return (test_diip tt)
                                    end))
                                (cons
                                  ("duup expansion" % string,
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | _ => Lwt._return (test_duup tt)
                                      end))
                                  (cons
                                    ("pair expansion" % string,
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ => Lwt._return (test_pair tt)
                                        end))
                                    (cons
                                      ("pappaiir expansion" % string,
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | _ => Lwt._return (test_pappaiir tt)
                                          end))
                                      (cons
                                        ("unpair expansion" % string,
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ => Lwt._return (test_unpair tt)
                                            end))
                                        (cons
                                          ("caddadr expansion" % string,
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | _ =>
                                                Lwt._return
                                                  (test_caddadr_expansion tt)
                                              end))
                                          (cons
                                            ("if_some expansion" % string,
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | _ =>
                                                  Lwt._return (test_if_some tt)
                                                end))
                                            (cons
                                              ("set_car expansion" % string,
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | _ =>
                                                    Lwt._return
                                                      (test_set_car_expansion tt)
                                                  end))
                                              (cons
                                                ("set_cdr expansion" % string,
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | _ =>
                                                      Lwt._return
                                                        (test_set_cdr_expansion
                                                          tt)
                                                    end))
                                                (cons
                                                  ("set_cadr expansion" % string,
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | _ =>
                                                        Lwt._return
                                                          (test_set_cadr_expansion
                                                            tt)
                                                      end))
                                                  (cons
                                                    ("set_cdar expansion" %
                                                      string,
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | _ =>
                                                          Lwt._return
                                                            (test_set_cdar_expansion
                                                              tt)
                                                        end))
                                                    (cons
                                                      ("map_car expansion" %
                                                        string,
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | _ =>
                                                            Lwt._return
                                                              (test_map_car tt)
                                                          end))
                                                      (cons
                                                        ("map_cdr expansion" %
                                                          string,
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | _ =>
                                                              Lwt._return
                                                                (test_map_cdr tt)
                                                            end))
                                                        (cons
                                                          ("map_caadr expansion"
                                                            % string,
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | _ =>
                                                                Lwt._return
                                                                  (test_map_caadr
                                                                    tt)
                                                              end))
                                                          (cons
                                                            ("map_cdadr expansion"
                                                              % string,
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | _ =>
                                                                  Lwt._return
                                                                    (test_map_cdadr
                                                                      tt)
                                                                end))
                                                            (cons
                                                              ("fail unexpansion"
                                                                % string,
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | _ =>
                                                                    Lwt._return
                                                                      (test_unexpand_fail
                                                                        tt)
                                                                  end))
                                                              (cons
                                                                ("if_right unexpansion"
                                                                  % string,
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | _ =>
                                                                      Lwt._return
                                                                        (test_unexpand_if_right
                                                                          tt)
                                                                    end))
                                                                (cons
                                                                  ("if_some unexpansion"
                                                                    % string,
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | _ =>
                                                                        Lwt._return
                                                                          (test_unexpand_if_some
                                                                            tt)
                                                                      end))
                                                                  (cons
                                                                    ("assert unexpansion"
                                                                      % string,
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | _ =>
                                                                          Lwt._return
                                                                            (test_unexpand_assert
                                                                              tt)
                                                                        end))
                                                                    (cons
                                                                      ("assert_if unexpansion"
                                                                        % string,
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | _ =>
                                                                            Lwt._return
                                                                              (test_unexpand_assert_if
                                                                                tt)
                                                                          end))
                                                                      (cons
                                                                        ("assert_cmp_if unexpansion"
                                                                          %
                                                                          string,
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            | _
                                                                              =>
                                                                              Lwt._return
                                                                                (test_unexpansion_assert_cmp_if
                                                                                  tt)
                                                                            end))
                                                                        (cons
                                                                          ("assert_none unexpansion"
                                                                            %
                                                                            string,
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                _
                                                                                =>
                                                                                Lwt._return
                                                                                  (test_unexpand_assert_none
                                                                                    tt)
                                                                              end))
                                                                          (cons
                                                                            ("assert_some unexpansion"
                                                                              %
                                                                              string,
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  _
                                                                                  =>
                                                                                  Lwt._return
                                                                                    (test_unexpand_assert_some
                                                                                      tt)
                                                                                end))
                                                                            (cons
                                                                              ("assert_left unexpansion"
                                                                                %
                                                                                string,
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    _
                                                                                    =>
                                                                                    Lwt._return
                                                                                      (test_unexpand_assert_left
                                                                                        tt)
                                                                                  end))
                                                                              (cons
                                                                                ("assert_right unexpansion"
                                                                                  %
                                                                                  string,
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      _
                                                                                      =>
                                                                                      Lwt._return
                                                                                        (test_unexpand_assert_right
                                                                                          tt)
                                                                                    end))
                                                                                (cons
                                                                                  ("assert_some annot unexpansion"
                                                                                    %
                                                                                    string,
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        _
                                                                                        =>
                                                                                        Lwt._return
                                                                                          (test_unexpand_assert_some_annot
                                                                                            tt)
                                                                                      end))
                                                                                  (cons
                                                                                    ("assert_left annot unexpansion"
                                                                                      %
                                                                                      string,
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          _
                                                                                          =>
                                                                                          Lwt._return
                                                                                            (test_unexpand_assert_left_annot
                                                                                              tt)
                                                                                        end))
                                                                                    (cons
                                                                                      ("assert_right annot unexpansion"
                                                                                        %
                                                                                        string,
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          match
                                                                                            function_parameter
                                                                                            with
                                                                                          |
                                                                                            _
                                                                                            =>
                                                                                            Lwt._return
                                                                                              (test_unexpand_assert_right_annot
                                                                                                tt)
                                                                                          end))
                                                                                      (cons
                                                                                        ("unpair unexpansion"
                                                                                          %
                                                                                          string,
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            match
                                                                                              function_parameter
                                                                                              with
                                                                                            |
                                                                                              _
                                                                                              =>
                                                                                              Lwt._return
                                                                                                (test_unexpand_unpair
                                                                                                  tt)
                                                                                            end))
                                                                                        (cons
                                                                                          ("pair unexpansion"
                                                                                            %
                                                                                            string,
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                _
                                                                                                =>
                                                                                                Lwt._return
                                                                                                  (test_unexpand_pair
                                                                                                    tt)
                                                                                              end))
                                                                                          (cons
                                                                                            ("pappaiir unexpansion"
                                                                                              %
                                                                                              string,
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  _
                                                                                                  =>
                                                                                                  Lwt._return
                                                                                                    (test_unexpand_pappaiir
                                                                                                      tt)
                                                                                                end))
                                                                                            (cons
                                                                                              ("duup unexpansion"
                                                                                                %
                                                                                                string,
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  match
                                                                                                    function_parameter
                                                                                                    with
                                                                                                  |
                                                                                                    _
                                                                                                    =>
                                                                                                    Lwt._return
                                                                                                      (test_unexpand_duup
                                                                                                        tt)
                                                                                                  end))
                                                                                              (cons
                                                                                                ("caddadr unexpansion"
                                                                                                  %
                                                                                                  string,
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    match
                                                                                                      function_parameter
                                                                                                      with
                                                                                                    |
                                                                                                      _
                                                                                                      =>
                                                                                                      Lwt._return
                                                                                                        (test_unexpand_caddadr
                                                                                                          tt)
                                                                                                    end))
                                                                                                (cons
                                                                                                  ("set_car unexpansion"
                                                                                                    %
                                                                                                    string,
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      match
                                                                                                        function_parameter
                                                                                                        with
                                                                                                      |
                                                                                                        _
                                                                                                        =>
                                                                                                        Lwt._return
                                                                                                          (test_unexpand_set_car
                                                                                                            tt)
                                                                                                      end))
                                                                                                  (cons
                                                                                                    ("set_cdr unexpansion"
                                                                                                      %
                                                                                                      string,
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        match
                                                                                                          function_parameter
                                                                                                          with
                                                                                                        |
                                                                                                          _
                                                                                                          =>
                                                                                                          Lwt._return
                                                                                                            (test_unexpand_set_cdr
                                                                                                              tt)
                                                                                                        end))
                                                                                                    (cons
                                                                                                      ("set_cadr unexpansion"
                                                                                                        %
                                                                                                        string,
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          match
                                                                                                            function_parameter
                                                                                                            with
                                                                                                          |
                                                                                                            _
                                                                                                            =>
                                                                                                            Lwt._return
                                                                                                              (test_unexpand_set_cadr
                                                                                                                tt)
                                                                                                          end))
                                                                                                      (cons
                                                                                                        ("set_car annot unexpansion"
                                                                                                          %
                                                                                                          string,
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            match
                                                                                                              function_parameter
                                                                                                              with
                                                                                                            |
                                                                                                              _
                                                                                                              =>
                                                                                                              Lwt._return
                                                                                                                (test_unexpand_set_car_annot
                                                                                                                  tt)
                                                                                                            end))
                                                                                                        (cons
                                                                                                          ("set_cdr annot unexpansion"
                                                                                                            %
                                                                                                            string,
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              match
                                                                                                                function_parameter
                                                                                                                with
                                                                                                              |
                                                                                                                _
                                                                                                                =>
                                                                                                                Lwt._return
                                                                                                                  (test_unexpand_set_cdr_annot
                                                                                                                    tt)
                                                                                                              end))
                                                                                                          (cons
                                                                                                            ("map_car unexpansion"
                                                                                                              %
                                                                                                              string,
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                match
                                                                                                                  function_parameter
                                                                                                                  with
                                                                                                                |
                                                                                                                  _
                                                                                                                  =>
                                                                                                                  Lwt._return
                                                                                                                    (test_unexpand_map_car
                                                                                                                      tt)
                                                                                                                end))
                                                                                                            (cons
                                                                                                              ("diip_duup1 unexpansion"
                                                                                                                %
                                                                                                                string,
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  match
                                                                                                                    function_parameter
                                                                                                                    with
                                                                                                                  |
                                                                                                                    _
                                                                                                                    =>
                                                                                                                    Lwt._return
                                                                                                                      (test_unexpand_diip_duup1
                                                                                                                        tt)
                                                                                                                  end))
                                                                                                              (cons
                                                                                                                ("diip_duup2 unexpansion"
                                                                                                                  %
                                                                                                                  string,
                                                                                                                  (fun
                                                                                                                    function_parameter
                                                                                                                    =>
                                                                                                                    match
                                                                                                                      function_parameter
                                                                                                                      with
                                                                                                                    |
                                                                                                                      _
                                                                                                                      =>
                                                                                                                      Lwt._return
                                                                                                                        (test_unexpand_diip_duup2
                                                                                                                          tt)
                                                                                                                    end))
                                                                                                                [])))))))))))))))))))))))))))))))))))))))))))))))))))))).

Definition wrap {A B : Type}
  (function_parameter :
    A * (unit -> Lwt.t (sum unit (list Tezos_base__TzPervasives.error)))) : B :=
  match function_parameter with
  | (n, f) =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq (f tt)
                (fun function_parameter =>
                  match function_parameter with
                  | inl tt => Lwt.return_unit
                  | inr error =>
                    Stdlib.Format.kasprintf Stdlib.Pervasives.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format) "%a" % string)
                      Tezos_base__TzPervasives.pp_print_error error
                  end)
            end
        end)
  end.
src/proto_alpha/lib_client_commands/alpha_commands_registration.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Client_commands.register Protocol.hash
  @@ fun network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Client_proto_programs_commands.commands ()
  @ Client_proto_contracts_commands.commands ()
  @ Client_proto_context_commands.commands network ()
  @ Client_proto_multisig_commands.commands ()
src/proto_alpha/lib_client_commands/alpha_commands_registration.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/proto_alpha/lib_client_commands/client_proto_context_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline
open Client_proto_context
open Client_proto_contracts
open Client_proto_programs
open Client_keys
open Client_proto_args

let encrypted_switch =
  Clic.switch ~long:"encrypted" ~doc:"encrypt the key on-disk" ()

let dry_run_switch =
  Clic.switch
    ~long:"dry-run"
    ~short:'D'
    ~doc:"don't inject the operation, just display it"
    ()

let verbose_signing_switch =
  Clic.switch
    ~long:"verbose-signing"
    ~doc:"display extra information before signing the operation"
    ()

let report_michelson_errors ?(no_print_source = false) ~msg
    (cctxt : #Client_context.printer) = function
  | Error errs ->
      cctxt#warning
        "%a"
        (Michelson_v1_error_reporter.report_errors
           ~details:(not no_print_source)
           ~show_source:(not no_print_source)
           ?parsed:None)
        errs
      >>= fun () -> cctxt#error "%s" msg >>= fun () -> Lwt.return_none
  | Ok data ->
      Lwt.return_some data

let file_parameter =
  Clic.parameter (fun _ p ->
      if not (Sys.file_exists p) then failwith "File doesn't exist: '%s'" p
      else return p)

let data_parameter =
  Clic.parameter (fun _ data ->
      Lwt.return
        ( Micheline_parser.no_parsing_error
        @@ Michelson_v1_parser.parse_expression data ))

let non_negative_param =
  Clic.parameter (fun _ s ->
      match int_of_string_opt s with
      | Some i when i >= 0 ->
          return i
      | _ ->
          failwith "Parameter should be a non-negative integer literal")

let block_hash_param =
  Clic.parameter (fun _ s ->
      try return (Block_hash.of_b58check_exn s)
      with _ -> failwith "Parameter '%s' is an invalid block hash" s)

let group =
  {
    Clic.name = "context";
    title = "Block contextual commands (see option -block)";
  }

let alphanet = {Clic.name = "alphanet"; title = "Alphanet only commands"}

let binary_description =
  {Clic.name = "description"; title = "Binary Description"}

let commands version () =
  let open Clic in
  [ command
      ~group
      ~desc:"Access the timestamp of the block."
      (args1
         (switch ~doc:"output time in seconds" ~short:'s' ~long:"seconds" ()))
      (fixed ["get"; "timestamp"])
      (fun seconds (cctxt : Protocol_client_context.full) ->
        Shell_services.Blocks.Header.shell_header
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ()
        >>=? fun {timestamp = v; _} ->
        ( if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v)
        else cctxt#message "%s" (Time.Protocol.to_notation v) )
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Lists all non empty contracts of the block."
      no_options
      (fixed ["list"; "contracts"])
      (fun () (cctxt : Protocol_client_context.full) ->
        list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block
        >>=? fun contracts ->
        Lwt_list.iter_s
          (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias)
          contracts
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Get the balance of a contract."
      no_options
      ( prefixes ["get"; "balance"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        get_balance cctxt ~chain:cctxt#chain ~block:cctxt#block contract
        >>=? fun amount ->
        cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Get the storage of a contract."
      no_options
      ( prefixes ["get"; "contract"; "storage"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract
        >>=? function
        | None ->
            cctxt#error "This is not a smart contract."
        | Some storage ->
            cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage
            >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Get the value associated to a key in the big map storage of a \
         contract (deprecated)."
      no_options
      ( prefixes ["get"; "big"; "map"; "value"; "for"]
      @@ Clic.param ~name:"key" ~desc:"the key to look for" data_parameter
      @@ prefixes ["of"; "type"]
      @@ Clic.param ~name:"type" ~desc:"type of the key" data_parameter
      @@ prefix "in"
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () key key_type (_, contract) (cctxt : Protocol_client_context.full) ->
        get_contract_big_map_value
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          contract
          (key.expanded, key_type.expanded)
        >>=? function
        | None ->
            cctxt#error "No value associated to this key."
        | Some value ->
            cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value
            >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Get a value in a big map."
      no_options
      ( prefixes ["get"; "element"]
      @@ Clic.param
           ~name:"key"
           ~desc:"the key to look for"
           (Clic.parameter (fun _ s ->
                return (Script_expr_hash.of_b58check_exn s)))
      @@ prefixes ["of"; "big"; "map"]
      @@ Clic.param
           ~name:"big_map"
           ~desc:"identifier of the big_map"
           int_parameter
      @@ stop )
      (fun () key id (cctxt : Protocol_client_context.full) ->
        get_big_map_value
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          (Z.of_int id)
          key
        >>=? fun value ->
        cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Get the code of a contract."
      no_options
      ( prefixes ["get"; "contract"; "code"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        get_script cctxt ~chain:cctxt#chain ~block:cctxt#block contract
        >>=? function
        | None ->
            cctxt#error "This is not a smart contract."
        | Some {code; storage = _} -> (
          match Script_repr.force_decode code with
          | Error errs ->
              cctxt#error
                "%a"
                (Format.pp_print_list
                   ~pp_sep:Format.pp_print_newline
                   Environment.Error_monad.pp)
                errs
          | Ok (code, _) ->
              let {Michelson_v1_parser.source; _} =
                Michelson_v1_printer.unparse_toplevel code
              in
              cctxt#answer "%a" Format.pp_print_text source >>= return ));
    command
      ~group
      ~desc:"Get the type of an entrypoint of a contract."
      no_options
      ( prefixes ["get"; "contract"; "entrypoint"; "type"; "of"]
      @@ Clic.string ~name:"entrypoint" ~desc:"the entrypoint to describe"
      @@ prefixes ["for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () entrypoint (_, contract) (cctxt : Protocol_client_context.full) ->
        Michelson_v1_entrypoints.contract_entrypoint_type
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ~contract
          ~entrypoint
        >>= Michelson_v1_entrypoints.print_entrypoint_type
              cctxt
              ~emacs:false
              ~contract
              ~entrypoint);
    command
      ~group
      ~desc:"Get the entrypoint list of a contract."
      no_options
      ( prefixes ["get"; "contract"; "entrypoints"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        Michelson_v1_entrypoints.list_contract_entrypoints
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ~contract
        >>= Michelson_v1_entrypoints.print_entrypoints_list
              cctxt
              ~emacs:false
              ~contract);
    command
      ~group
      ~desc:"Get the list of unreachable pathsin a contract's parameter type."
      no_options
      ( prefixes ["get"; "contract"; "unreachable"; "paths"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        Michelson_v1_entrypoints.list_contract_unreachables
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ~contract
        >>= Michelson_v1_entrypoints.print_unreachables
              cctxt
              ~emacs:false
              ~contract);
    command
      ~group
      ~desc:"Get the delegate of a contract."
      no_options
      ( prefixes ["get"; "delegate"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        Client_proto_contracts.get_delegate
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          contract
        >>=? function
        | None ->
            cctxt#message "none" >>= fun () -> return_unit
        | Some delegate ->
            Public_key_hash.rev_find cctxt delegate
            >>=? fun mn ->
            Public_key_hash.to_source delegate
            >>=? fun m ->
            cctxt#message
              "%s (%s)"
              m
              (match mn with None -> "unknown" | Some n -> "known as " ^ n)
            >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Set the delegate of a contract."
      (args9
         fee_arg
         dry_run_switch
         verbose_signing_switch
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["set"; "delegate"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ prefix "to"
      @@ Public_key_hash.alias_param
           ~name:"mgr"
           ~desc:"new delegate of the contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           (_, contract)
           (_, delegate)
           (cctxt : Protocol_client_context.full) ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        match Contract.is_implicit contract with
        | None ->
            Managed_contract.get_contract_manager cctxt contract
            >>=? fun source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            Managed_contract.set_delegate
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              ~source
              ~src_pk
              ~src_sk
              contract
              (Some delegate)
            >>= fun errors ->
            report_michelson_errors
              ~no_print_source:true
              ~msg:"Setting delegate through entrypoints failed."
              cctxt
              errors
            >>= fun _ -> return_unit
        | Some mgr ->
            Client_keys.get_key cctxt mgr
            >>=? fun (_, src_pk, manager_sk) ->
            set_delegate
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              mgr
              (Some delegate)
              ~src_pk
              ~manager_sk
            >>=? fun _ -> return_unit);
    command
      ~group
      ~desc:"Withdraw the delegate from a contract."
      (args9
         fee_arg
         dry_run_switch
         verbose_signing_switch
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["withdraw"; "delegate"; "from"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           (_, contract)
           (cctxt : Protocol_client_context.full) ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        match Contract.is_implicit contract with
        | None ->
            Managed_contract.get_contract_manager cctxt contract
            >>=? fun source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            Managed_contract.set_delegate
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              ~source
              ~src_pk
              ~src_sk
              contract
              None
            >>= fun errors ->
            report_michelson_errors
              ~no_print_source:true
              ~msg:"Withdrawing delegate through entrypoints failed."
              cctxt
              errors
            >>= fun _ -> return_unit
        | Some mgr ->
            Client_keys.get_key cctxt mgr
            >>=? fun (_, src_pk, manager_sk) ->
            set_delegate
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              mgr
              None
              ?fee
              ~src_pk
              ~manager_sk
            >>= fun _ -> return_unit);
    command
      ~group
      ~desc:"Launch a smart contract on the blockchain."
      (args15
         fee_arg
         dry_run_switch
         verbose_signing_switch
         gas_limit_arg
         storage_limit_arg
         delegate_arg
         (Client_keys.force_switch ())
         init_arg
         no_print_source_flag
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["originate"; "contract"]
      @@ RawContractAlias.fresh_alias_param
           ~name:"new"
           ~desc:"name of the new contract"
      @@ prefix "transferring"
      @@ tez_param ~name:"qty" ~desc:"amount taken from source"
      @@ prefix "from"
      @@ ContractAlias.destination_param
           ~name:"src"
           ~desc:"name of the source contract"
      @@ prefix "running"
      @@ Program.source_param
           ~name:"prg"
           ~desc:
             "script of the account\n\
              Combine with -init if the storage type is not unit."
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             gas_limit,
             storage_limit,
             delegate,
             force,
             initial_storage,
             no_print_source,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           alias_name
           balance
           (_, source)
           program
           (cctxt : Protocol_client_context.full) ->
        RawContractAlias.of_fresh cctxt force alias_name
        >>=? fun alias_name ->
        Lwt.return (Micheline_parser.no_parsing_error program)
        >>=? fun {expanded = code; _} ->
        match Contract.is_implicit source with
        | None ->
            failwith
              "only implicit accounts can be the source of an origination"
        | Some source -> (
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            let fee_parameter =
              {
                Injection.minimal_fees;
                minimal_nanotez_per_byte;
                minimal_nanotez_per_gas_unit;
                force_low_fee;
                fee_cap;
                burn_cap;
              }
            in
            originate_contract
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ?fee
              ?gas_limit
              ?storage_limit
              ~delegate
              ~initial_storage
              ~balance
              ~source
              ~src_pk
              ~src_sk
              ~code
              ~fee_parameter
              ()
            >>= fun errors ->
            report_michelson_errors
              ~no_print_source
              ~msg:"origination simulation failed"
              cctxt
              errors
            >>= function
            | None ->
                return_unit
            | Some (_res, contract) ->
                if dry_run then return_unit
                else
                  save_contract ~force cctxt alias_name contract
                  >>=? fun () -> return_unit ));
    command
      ~group
      ~desc:"Transfer tokens / call a smart contract."
      (args15
         fee_arg
         dry_run_switch
         verbose_signing_switch
         gas_limit_arg
         storage_limit_arg
         counter_arg
         arg_arg
         no_print_source_flag
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg
         entrypoint_arg)
      ( prefixes ["transfer"]
      @@ tez_param ~name:"qty" ~desc:"amount taken from source"
      @@ prefix "from"
      @@ ContractAlias.destination_param
           ~name:"src"
           ~desc:"name of the source contract"
      @@ prefix "to"
      @@ ContractAlias.destination_param
           ~name:"dst"
           ~desc:"name/literal of the destination contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             gas_limit,
             storage_limit,
             counter,
             arg,
             no_print_source,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap,
             entrypoint )
           amount
           (_, source)
           (_, destination)
           cctxt ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        ( match Contract.is_implicit source with
        | None ->
            let contract = source in
            Managed_contract.get_contract_manager cctxt source
            >>=? fun source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            Managed_contract.transfer
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              ~contract
              ~source
              ~src_pk
              ~src_sk
              ~destination
              ?entrypoint
              ?arg
              ~amount
              ?gas_limit
              ?storage_limit
              ?counter
              ()
        | Some source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            transfer
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ~source
              ?fee
              ~src_pk
              ~src_sk
              ~destination
              ?entrypoint
              ?arg
              ~amount
              ?gas_limit
              ?storage_limit
              ?counter
              () )
        >>= report_michelson_errors
              ~no_print_source
              ~msg:"transfer simulation failed"
              cctxt
        >>= function
        | None -> return_unit | Some (_res, _contracts) -> return_unit);
    command
      ~group
      ~desc:"Call a smart contract (same as 'transfer 0')."
      (args15
         fee_arg
         dry_run_switch
         verbose_signing_switch
         gas_limit_arg
         storage_limit_arg
         counter_arg
         arg_arg
         no_print_source_flag
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg
         entrypoint_arg)
      ( prefixes ["call"]
      @@ prefix "from"
      @@ ContractAlias.destination_param
           ~name:"src"
           ~desc:"name of the source contract"
      @@ prefix "to"
      @@ ContractAlias.destination_param
           ~name:"dst"
           ~desc:"name/literal of the destination contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             gas_limit,
             storage_limit,
             counter,
             arg,
             no_print_source,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap,
             entrypoint )
           (_, source)
           (_, destination)
           cctxt ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        let amount = Tez.zero in
        ( match Contract.is_implicit source with
        | None ->
            let contract = source in
            Managed_contract.get_contract_manager cctxt source
            >>=? fun source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            Managed_contract.transfer
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              ~contract
              ~source
              ~src_pk
              ~src_sk
              ~destination
              ?entrypoint
              ?arg
              ~amount
              ?gas_limit
              ?storage_limit
              ?counter
              ()
        | Some source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            transfer
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ~source
              ?fee
              ~src_pk
              ~src_sk
              ~destination
              ?entrypoint
              ?arg
              ~amount
              ?gas_limit
              ?storage_limit
              ?counter
              () )
        >>= report_michelson_errors
              ~no_print_source
              ~msg:"transfer simulation failed"
              cctxt
        >>= function
        | None -> return_unit | Some (_res, _contracts) -> return_unit);
    command
      ~group
      ~desc:"Reveal the public key of the contract manager."
      (args9
         fee_arg
         dry_run_switch
         verbose_signing_switch
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["reveal"; "key"; "for"]
      @@ ContractAlias.alias_param
           ~name:"src"
           ~desc:"name of the source contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           (_, source)
           cctxt ->
        match Contract.is_implicit source with
        | None ->
            failwith "only implicit accounts can be revealed"
        | Some source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            let fee_parameter =
              {
                Injection.minimal_fees;
                minimal_nanotez_per_byte;
                minimal_nanotez_per_gas_unit;
                force_low_fee;
                fee_cap;
                burn_cap;
              }
            in
            reveal
              cctxt
              ~dry_run
              ~verbose_signing
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~source
              ?fee
              ~src_pk
              ~src_sk
              ~fee_parameter
              ()
            >>=? fun _res -> return_unit);
    command
      ~group
      ~desc:"Register the public key hash as a delegate."
      (args9
         fee_arg
         dry_run_switch
         verbose_signing_switch
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["register"; "key"]
      @@ Public_key_hash.source_param ~name:"mgr" ~desc:"the delegate key"
      @@ prefixes ["as"; "delegate"]
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           src_pkh
           cctxt ->
        Client_keys.get_key cctxt src_pkh
        >>=? fun (_, src_pk, src_sk) ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        register_as_delegate
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ?confirmations:cctxt#confirmations
          ~dry_run
          ~fee_parameter
          ~verbose_signing
          ?fee
          ~manager_sk:src_sk
          src_pk
        >>= function
        | Ok _ ->
            return_unit
        | Error [Environment.Ecoproto_error Delegate_storage.Active_delegate]
          ->
            cctxt#message "Delegate already activated."
            >>= fun () -> return_unit
        | Error el ->
            Lwt.return_error el) ]
  @ ( if version = Some `Mainnet then []
    else
      [ command
          ~group
          ~desc:"Register and activate an Alphanet/Zeronet faucet account."
          (args2 (Secret_key.force_switch ()) encrypted_switch)
          ( prefixes ["activate"; "account"]
          @@ Secret_key.fresh_alias_param
          @@ prefixes ["with"]
          @@ param
               ~name:"activation_key"
               ~desc:
                 "Activate an Alphanet/Zeronet faucet account from the \
                  downloaded JSON file."
               file_parameter
          @@ stop )
          (fun (force, encrypted) name activation_key_file cctxt ->
            Secret_key.of_fresh cctxt force name
            >>=? fun name ->
            Lwt_utils_unix.Json.read_file activation_key_file
            >>=? fun json ->
            match
              Data_encoding.Json.destruct
                Client_proto_context.activation_key_encoding
                json
            with
            | exception (Data_encoding.Json.Cannot_destruct _ as exn) ->
                Format.kasprintf
                  (fun s -> failwith "%s" s)
                  "Invalid activation file: %a %a"
                  (fun ppf -> Data_encoding.Json.print_error ppf)
                  exn
                  Data_encoding.Json.pp
                  json
            | key ->
                activate_account
                  cctxt
                  ~chain:cctxt#chain
                  ~block:cctxt#block
                  ?confirmations:cctxt#confirmations
                  ~encrypted
                  ~force
                  key
                  name
                >>=? fun _res -> return_unit) ] )
  @ ( if version <> Some `Mainnet then []
    else
      [ command
          ~group
          ~desc:"Activate a fundraiser account."
          (args1 dry_run_switch)
          ( prefixes ["activate"; "fundraiser"; "account"]
          @@ Public_key_hash.alias_param
          @@ prefixes ["with"]
          @@ param
               ~name:"code"
               (Clic.parameter (fun _ctx code ->
                    protect (fun () ->
                        return
                          (Blinded_public_key_hash.activation_code_of_hex code))))
               ~desc:"Activation code obtained from the Tezos foundation."
          @@ stop )
          (fun dry_run (name, _pkh) code cctxt ->
            activate_existing_account
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              name
              code
            >>=? fun _res -> return_unit) ] )
  @ [ command
        ~desc:"Wait until an operation is included in a block"
        (args3
           (default_arg
              ~long:"confirmations"
              ~placeholder:"num_blocks"
              ~doc:
                "wait until 'N' additional blocks after the operation appears \
                 in the considered chain"
              ~default:"0"
              non_negative_param)
           (default_arg
              ~long:"check-previous"
              ~placeholder:"num_blocks"
              ~doc:"number of previous blocks to check"
              ~default:"10"
              non_negative_param)
           (arg
              ~long:"branch"
              ~placeholder:"block_hash"
              ~doc:
                "hash of the oldest block where we should look for the \
                 operation"
              block_hash_param))
        ( prefixes ["wait"; "for"]
        @@ param
             ~name:"operation"
             ~desc:"Operation to be included"
             (parameter (fun _ x ->
                  match Operation_hash.of_b58check_opt x with
                  | None ->
                      Error_monad.failwith "Invalid operation hash: '%s'" x
                  | Some hash ->
                      return hash))
        @@ prefixes ["to"; "be"; "included"]
        @@ stop )
        (fun (confirmations, predecessors, branch)
             operation_hash
             (ctxt : Protocol_client_context.full) ->
          Client_confirmations.wait_for_operation_inclusion
            ctxt
            ~chain:ctxt#chain
            ~confirmations
            ~predecessors
            ?branch
            operation_hash
          >>=? fun _ -> return_unit);
      command
        ~desc:"Get receipt for past operation"
        (args1
           (default_arg
              ~long:"check-previous"
              ~placeholder:"num_blocks"
              ~doc:"number of previous blocks to check"
              ~default:"10"
              non_negative_param))
        ( prefixes ["get"; "receipt"; "for"]
        @@ param
             ~name:"operation"
             ~desc:"Operation to be looked up"
             (parameter (fun _ x ->
                  match Operation_hash.of_b58check_opt x with
                  | None ->
                      Error_monad.failwith "Invalid operation hash: '%s'" x
                  | Some hash ->
                      return hash))
        @@ stop )
        (fun predecessors operation_hash (ctxt : Protocol_client_context.full) ->
          display_receipt_for_operation
            ctxt
            ~chain:ctxt#chain
            ~predecessors
            operation_hash
          >>=? fun _ -> return_unit);
      command
        ~group:binary_description
        ~desc:"Describe unsigned block header"
        no_options
        (fixed ["describe"; "unsigned"; "block"; "header"])
        (fun () (cctxt : Protocol_client_context.full) ->
          cctxt#message
            "%a"
            Data_encoding.Binary_schema.pp
            (Data_encoding.Binary.describe
               Alpha_context.Block_header.unsigned_encoding)
          >>= fun () -> return_unit);
      command
        ~group:binary_description
        ~desc:"Describe unsigned block header"
        no_options
        (fixed ["describe"; "unsigned"; "operation"])
        (fun () (cctxt : Protocol_client_context.full) ->
          cctxt#message
            "%a"
            Data_encoding.Binary_schema.pp
            (Data_encoding.Binary.describe
               Alpha_context.Operation.unsigned_encoding)
          >>= fun () -> return_unit);
      command
        ~group
        ~desc:"Submit protocol proposals"
        (args3
           dry_run_switch
           verbose_signing_switch
           (switch
              ~doc:
                "Do not fail when the checks that try to prevent the user \
                 from shooting themselves in the foot do."
              ~long:"force"
              ()))
        ( prefixes ["submit"; "proposals"; "for"]
        @@ Client_keys.Secret_key.alias_param
             ~name:"delegate"
             ~desc:"the delegate who makes the proposal"
        @@ seq_of_param
             (param
                ~name:"proposal"
                ~desc:"the protocol hash proposal to be submitted"
                (parameter (fun _ x ->
                     match Protocol_hash.of_b58check_opt x with
                     | None ->
                         Error_monad.failwith "Invalid proposal hash: '%s'" x
                     | Some hash ->
                         return hash))) )
        (fun (dry_run, verbose_signing, force)
             (src_name, src_sk)
             proposals
             (cctxt : Protocol_client_context.full) ->
          Client_keys.neuterize src_sk
          >>=? fun src_pk ->
          Client_keys.public_key_hash src_pk
          >>=? fun (src_pkh, _) ->
          get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun info ->
          ( match info.current_period_kind with
          | Proposal ->
              return_unit
          | _ ->
              cctxt#error "Not in a proposal period" )
          >>=? fun () ->
          Shell_services.Protocol.list cctxt
          >>=? fun known_protos ->
          get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun known_proposals ->
          Alpha_services.Voting.listings cctxt (cctxt#chain, cctxt#block)
          >>=? fun listings ->
          (* for a proposal to be valid it must either a protocol that was already
           proposed by somebody else or a protocol known by the node, because
           the user is the first proposer and just injected it with
           tezos-admin-client *)
          let check_proposals proposals : bool tzresult Lwt.t =
            let n = List.length proposals in
            let errors = ref [] in
            let error ppf =
              Format.kasprintf (fun s -> errors := s :: !errors) ppf
            in
            if n = 0 then error "Empty proposal list." ;
            if n > Constants.fixed.max_proposals_per_delegate then
              error
                "Too many proposals: %d > %d."
                n
                Constants.fixed.max_proposals_per_delegate ;
            ( match
                Base.List.find_all_dups
                  ~compare:Protocol_hash.compare
                  proposals
              with
            | [] ->
                ()
            | dups ->
                error
                  "There %s: %a."
                  ( if List.length dups = 1 then "is a duplicate proposal"
                  else "are duplicate proposals" )
                  Format.(
                    pp_print_list
                      ~pp_sep:(fun ppf () -> pp_print_string ppf ", ")
                      Protocol_hash.pp)
                  dups ) ;
            List.iter
              (fun (p : Protocol_hash.t) ->
                if
                  List.mem p known_protos
                  || Environment.Protocol_hash.Map.mem p known_proposals
                then ()
                else
                  error
                    "Protocol %a is not a known proposal."
                    Protocol_hash.pp
                    p)
              proposals ;
            if
              not
                (List.exists
                   (fun (pkh, _) ->
                     Signature.Public_key_hash.equal pkh src_pkh)
                   listings)
            then
              error
                "Public-key-hash `%a` from account `%s` does not appear to \
                 have voting rights."
                Signature.Public_key_hash.pp
                src_pkh
                src_name ;
            if !errors <> [] then
              cctxt#message
                "There %s with the submission:%t"
                ( if List.length !errors = 1 then "is an issue"
                else "are issues" )
                Format.(
                  fun ppf ->
                    pp_print_cut ppf () ;
                    pp_open_vbox ppf 0 ;
                    List.iter
                      (fun msg ->
                        pp_open_hovbox ppf 2 ;
                        pp_print_string ppf "* " ;
                        pp_print_text ppf msg ;
                        pp_close_box ppf () ;
                        pp_print_cut ppf ())
                      !errors ;
                    pp_close_box ppf ())
              >>= fun () -> return_false
            else return_true
          in
          check_proposals proposals
          >>=? fun all_valid ->
          ( if all_valid then cctxt#message "All proposals are valid."
          else if force then
            cctxt#message
              "Some proposals are not valid, but `--force` was used."
          else cctxt#error "Submission failed because of invalid proposals." )
          >>= fun () ->
          submit_proposals
            ~dry_run
            ~verbose_signing
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~src_sk
            src_pkh
            proposals
          >>= function
          | Ok _res ->
              return_unit
          | Error errs ->
              ( match errs with
              | [ Unregistred_error
                    (`O [("kind", `String "generic"); ("error", `String msg)])
                ] ->
                  cctxt#message
                    "Error:@[<hov>@.%a@]"
                    Format.pp_print_text
                    ( String.split_on_char ' ' msg
                    |> List.filter (function "" | "\n" -> false | _ -> true)
                    |> String.concat " "
                    |> String.map (function '\n' | '\t' -> ' ' | c -> c) )
              | el ->
                  cctxt#message "Error:@ %a" pp_print_error el )
              >>= fun () -> failwith "Failed to submit proposals");
      command
        ~group
        ~desc:"Submit a ballot"
        (args2 verbose_signing_switch dry_run_switch)
        ( prefixes ["submit"; "ballot"; "for"]
        @@ Client_keys.Secret_key.alias_param
             ~name:"delegate"
             ~desc:"the delegate who votes"
        @@ param
             ~name:"proposal"
             ~desc:"the protocol hash proposal to vote for"
             (parameter (fun _ x ->
                  match Protocol_hash.of_b58check_opt x with
                  | None ->
                      failwith "Invalid proposal hash: '%s'" x
                  | Some hash ->
                      return hash))
        @@ param
             ~name:"ballot"
             ~desc:"the ballot value (yea/yay, nay, or pass)"
             (parameter
                ~autocomplete:(fun _ -> return ["yea"; "nay"; "pass"])
                (fun _ s ->
                  (* We should have [Vote.of_string]. *)
                  match String.lowercase_ascii s with
                  | "yay" | "yea" ->
                      return Vote.Yay
                  | "nay" ->
                      return Vote.Nay
                  | "pass" ->
                      return Vote.Pass
                  | s ->
                      failwith "Invalid ballot: '%s'" s))
        @@ stop )
        (fun (verbose_signing, dry_run)
             (_, src_sk)
             proposal
             ballot
             (cctxt : Protocol_client_context.full) ->
          Client_keys.neuterize src_sk
          >>=? fun src_pk ->
          Client_keys.public_key_hash src_pk
          >>=? fun (src_pkh, _) ->
          get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun info ->
          ( match info.current_period_kind with
          | Testing_vote | Promotion_vote ->
              return_unit
          | _ ->
              cctxt#error "Not in a Testing_vote or Promotion_vote period" )
          >>=? fun () ->
          submit_ballot
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~src_sk
            src_pkh
            ~verbose_signing
            ~dry_run
            proposal
            ballot
          >>=? fun _res -> return_unit);
      command
        ~group
        ~desc:"Summarize the current voting period"
        no_options
        (fixed ["show"; "voting"; "period"])
        (fun () (cctxt : Protocol_client_context.full) ->
          get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun info ->
          cctxt#message
            "Current period: %a\nBlocks remaining until end of period: %ld"
            Data_encoding.Json.pp
            (Data_encoding.Json.construct
               Alpha_context.Voting_period.kind_encoding
               info.current_period_kind)
            info.remaining
          >>= fun () ->
          Shell_services.Protocol.list cctxt
          >>=? fun known_protos ->
          get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun props ->
          let ranks =
            Environment.Protocol_hash.Map.bindings props
            |> List.sort (fun (_, v1) (_, v2) -> Int32.(compare v2 v1))
          in
          let print_proposal = function
            | None ->
                assert false (* not called during proposal phase *)
            | Some proposal ->
                cctxt#message "Current proposal: %a" Protocol_hash.pp proposal
          in
          match info.current_period_kind with
          | Proposal ->
              cctxt#answer
                "Current proposals:%t"
                Format.(
                  fun ppf ->
                    pp_print_cut ppf () ;
                    pp_open_vbox ppf 0 ;
                    List.iter
                      (fun (p, w) ->
                        fprintf
                          ppf
                          "* %a %ld (%sknown by the node)@."
                          Protocol_hash.pp
                          p
                          w
                          (if List.mem p known_protos then "" else "not "))
                      ranks ;
                    pp_close_box ppf ())
              >>= fun () -> return_unit
          | Testing_vote | Promotion_vote ->
              print_proposal info.current_proposal
              >>= fun () ->
              get_ballots_info ~chain:cctxt#chain ~block:cctxt#block cctxt
              >>=? fun ballots_info ->
              cctxt#answer
                "Ballots: %a@,\
                 Current participation %.2f%%, necessary quorum %.2f%%@,\
                 Current in favor %ld, needed supermajority %ld"
                Data_encoding.Json.pp
                (Data_encoding.Json.construct
                   Vote.ballots_encoding
                   ballots_info.ballots)
                (Int32.to_float ballots_info.participation /. 100.)
                (Int32.to_float ballots_info.current_quorum /. 100.)
                ballots_info.ballots.yay
                ballots_info.supermajority
              >>= fun () -> return_unit
          | Testing ->
              print_proposal info.current_proposal >>= fun () -> return_unit)
    ]
src/proto_alpha/lib_client_commands/client_proto_context_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_micheline.

Import Tezos_client_alpha.Client_proto_context.

Import Tezos_client_alpha.Client_proto_contracts.

Import Tezos_client_alpha.Client_proto_programs.

Import Tezos_client_base.Client_keys.

Import Tezos_client_alpha.Client_proto_args.

Definition encrypted_switch
  : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.switch "encrypt the key on-disk" % string None
    "encrypted" % string tt.

Definition dry_run_switch
  : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.switch
    "don't inject the operation, just display it" % string (Some "D" % char)
    "dry-run" % string tt.

Definition verbose_signing_switch
  : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.switch
    "display extra information before signing the operation" % string None
    "verbose-signing" % string tt.

Definition report_michelson_errors {C D a b : Type}
  (op_star_o_p_t_star : option bool)
  : string ->
    (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) ->
      (sum D (list Tezos_base__TzPervasives.Error_monad.error)) ->
        Lwt.t (option D) :=
  let no_print_source :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun msg =>
    fun cctxt =>
      fun function_parameter =>
        match function_parameter with
        | inr errs =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              (Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                (negb no_print_source) (negb no_print_source) None) errs)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format) "%s" % string)
                    msg)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Lwt.return_none
                    end)
              end)
        | inl data => Lwt.return_some data
        end.

Definition file_parameter
  : Tezos_base__TzPervasives.Clic.parameter string
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun p =>
          if negb (Stdlib.Sys.file_exists p) then
            Tezos_base__TzPervasives.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "File doesn't exist: '" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal "'" % char
                      CamlinternalFormatBasics.End_of_format)))
                "File doesn't exist: '%s'" % string) p
          else
            Tezos_base__TzPervasives._return p
      end).

Definition data_parameter
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_client_alpha.Michelson_v1_parser.parsed
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun data =>
          Lwt._return
            (apply Tezos_micheline.Micheline_parser.no_parsing_error
              (Tezos_client_alpha.Michelson_v1_parser.parse_expression None data))
      end).

Definition non_negative_param
  : Tezos_base__TzPervasives.Clic.parameter Z
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun s =>
          match Stdlib.int_of_string_opt s with
          | _ =>
            Tezos_base__TzPervasives.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Parameter should be a non-negative integer literal" % string
                  CamlinternalFormatBasics.End_of_format)
                "Parameter should be a non-negative integer literal" % string)
          end
      end).

Definition block_hash_param
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_base__TzPervasives.Block_hash.t
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ => fun s => try
      end).

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "context" % string;
    Clic.title := "Block contextual commands (see option -block)" % string |}.

Definition alphanet : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "alphanet" % string;
    Clic.title := "Alphanet only commands" % string |}.

Definition binary_description : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "description" % string;
    Clic.title := "Binary Description" % string |}.

Definition commands (version : option variant) (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  match function_parameter with
  | tt =>
    OCaml.Stdlib.app
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Access the timestamp of the block." % string
          (Tezos_base__TzPervasives.Clic.args1
            (Tezos_base__TzPervasives.Clic.switch
              "output time in seconds" % string (Some "s" % char)
              "seconds" % string tt))
          (Tezos_base__TzPervasives.Clic.fixed
            (cons "get" % string (cons "timestamp" % string [])))
          (fun seconds =>
            fun cctxt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell_services.Shell_services.Blocks.Header.shell_header
                  cctxt (Some send) (Some send) tt)
                (fun function_parameter =>
                  match function_parameter with
                  | {| timestamp := v |} =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (if seconds then
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Int64
                              CamlinternalFormatBasics.Int_d
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.No_precision
                              CamlinternalFormatBasics.End_of_format)
                            "%Ld" % string)
                          (Tezos_base__TzPervasives.Time.Protocol.to_seconds v)
                      else
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format)
                            "%s" % string)
                          (Tezos_base__TzPervasives.Time.Protocol.to_notation v))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_base__TzPervasives.return_unit
                        end)
                  end)))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Lists all non empty contracts of the block." % string
            Tezos_base__TzPervasives.Clic.no_options
            (Tezos_base__TzPervasives.Clic.fixed
              (cons "list" % string (cons "contracts" % string [])))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_client_alpha.Client_proto_context.list_contract_labels
                      cctxt send send)
                    (fun contracts =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (Lwt_list.iter_s
                          (fun function_parameter =>
                            match function_parameter with
                            | (alias, hash, kind) =>
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format)))
                                  "%s%s%s" % string) hash kind alias
                            end) contracts)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives.return_unit
                          end))
              end))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Get the balance of a contract." % string
              Tezos_base__TzPervasives.Clic.no_options
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "get" % string
                    (cons "balance" % string (cons "for" % string []))))
                (apply
                  (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                    (Some "src" % string) (Some "source contract" % string))
                  Tezos_base__TzPervasives.Clic.stop))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun function_parameter =>
                    match function_parameter with
                    | (_, contract) =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_alpha.Client_proto_context.get_balance
                            cctxt send send contract)
                          (fun amount =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      " " % char
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format)))
                                  "%a %s" % string)
                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp
                                amount
                                Tezos_client_alpha.Client_proto_args.tez_sym)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_unit
                                end))
                    end
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Get the storage of a contract." % string
                Tezos_base__TzPervasives.Clic.no_options
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "get" % string
                      (cons "contract" % string
                        (cons "storage" % string (cons "for" % string [])))))
                  (apply
                    (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                      (Some "src" % string) (Some "source contract" % string))
                    Tezos_base__TzPervasives.Clic.stop))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    fun function_parameter =>
                      match function_parameter with
                      | (_, contract) =>
                        fun cctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_client_alpha.Client_proto_context.get_storage
                              cctxt send send contract)
                            (fun function_parameter =>
                              match function_parameter with
                              | None =>
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "This is not a smart contract." % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "This is not a smart contract." % string)
                              | Some storage =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format)
                                      "%a" % string)
                                    Tezos_client_alpha.Michelson_v1_printer.print_expr_unwrapped
                                    storage)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end)
                              end)
                      end
                  end))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some group)
                  "Get the value associated to a key in the big map storage of a contract (deprecated)."
                    % string Tezos_base__TzPervasives.Clic.no_options
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "get" % string
                        (cons "big" % string
                          (cons "map" % string
                            (cons "value" % string (cons "for" % string []))))))
                    (apply
                      (Tezos_base__TzPervasives.Clic.param "key" % string
                        "the key to look for" % string data_parameter)
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "of" % string (cons "type" % string [])))
                        (apply
                          (Tezos_base__TzPervasives.Clic.param "type" % string
                            "type of the key" % string data_parameter)
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefix "in" % string)
                            (apply
                              (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                (Some "src" % string)
                                (Some "source contract" % string))
                              Tezos_base__TzPervasives.Clic.stop))))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      fun key =>
                        fun key_type =>
                          fun function_parameter =>
                            match function_parameter with
                            | (_, contract) =>
                              fun cctxt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_client_alpha.Client_proto_context.get_contract_big_map_value
                                    cctxt send send contract
                                    ((expanded key), (expanded key_type)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | None =>
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "No value associated to this key." %
                                              string
                                            CamlinternalFormatBasics.End_of_format)
                                          "No value associated to this key." %
                                            string)
                                    | Some value =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format)
                                            "%a" % string)
                                          Tezos_client_alpha.Michelson_v1_printer.print_expr_unwrapped
                                          value)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.return_unit
                                          end)
                                    end)
                            end
                    end))
                (cons
                  (Tezos_base__TzPervasives.Clic.command (Some group)
                    "Get a value in a big map." % string
                    Tezos_base__TzPervasives.Clic.no_options
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "get" % string (cons "element" % string [])))
                      (apply
                        (Tezos_base__TzPervasives.Clic.param "key" % string
                          "the key to look for" % string
                          (Tezos_base__TzPervasives.Clic.parameter None
                            (fun function_parameter =>
                              match function_parameter with
                              | _ =>
                                fun s =>
                                  Tezos_base__TzPervasives._return
                                    (Tezos_protocol_alpha.Protocol.Script_expr_hash.of_b58check_exn
                                      s)
                              end)))
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "of" % string
                              (cons "big" % string (cons "map" % string []))))
                          (apply
                            (Tezos_base__TzPervasives.Clic.param
                              "big_map" % string
                              "identifier of the big_map" % string
                              Tezos_client_alpha.Client_proto_args.int_parameter)
                            Tezos_base__TzPervasives.Clic.stop))))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        fun key =>
                          fun id =>
                            fun cctxt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_client_alpha.Client_proto_context.get_big_map_value
                                  cctxt send send (Z.of_int id) key)
                                (fun value =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.Alpha
                                          CamlinternalFormatBasics.End_of_format)
                                        "%a" % string)
                                      Tezos_client_alpha.Michelson_v1_printer.print_expr_unwrapped
                                      value)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.return_unit
                                      end))
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Clic.command (Some group)
                      "Get the code of a contract." % string
                      Tezos_base__TzPervasives.Clic.no_options
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "get" % string
                            (cons "contract" % string
                              (cons "code" % string (cons "for" % string [])))))
                        (apply
                          (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                            (Some "src" % string)
                            (Some "source contract" % string))
                          Tezos_base__TzPervasives.Clic.stop))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          fun function_parameter =>
                            match function_parameter with
                            | (_, contract) =>
                              fun cctxt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_client_alpha.Client_proto_context.get_script
                                    cctxt send send contract)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | None =>
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "This is not a smart contract." %
                                              string
                                            CamlinternalFormatBasics.End_of_format)
                                          "This is not a smart contract." %
                                            string)
                                    | Some {| code := code; storage := _ |} =>
                                      match
                                        Tezos_protocol_alpha.Protocol.Script_repr.force_decode
                                          code with
                                      | inr errs =>
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format)
                                            "%a" % string)
                                          (Stdlib.Format.pp_print_list
                                            (Some Stdlib.Format.pp_print_newline)
                                            Tezos_protocol_alpha.Protocol.Environment.Error_monad.pp)
                                          errs
                                      | inl (code, _) =>
                                        match
                                          Tezos_client_alpha.Michelson_v1_printer.unparse_toplevel
                                            None code with
                                        | {|
                                          Michelson_v1_parser.source := source
                                            |} =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.Alpha
                                                  CamlinternalFormatBasics.End_of_format)
                                                "%a" % string)
                                              Stdlib.Format.pp_print_text source)
                                            Tezos_base__TzPervasives._return
                                        end
                                      end
                                    end)
                            end
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Clic.command (Some group)
                        "Get the type of an entrypoint of a contract." % string
                        Tezos_base__TzPervasives.Clic.no_options
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "get" % string
                              (cons "contract" % string
                                (cons "entrypoint" % string
                                  (cons "type" % string (cons "of" % string []))))))
                          (apply
                            (Tezos_base__TzPervasives.Clic.string
                              "entrypoint" % string
                              "the entrypoint to describe" % string)
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "for" % string []))
                              (apply
                                (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                  (Some "src" % string)
                                  (Some "source contract" % string))
                                Tezos_base__TzPervasives.Clic.stop))))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            fun entrypoint =>
                              fun function_parameter =>
                                match function_parameter with
                                | (_, contract) =>
                                  fun cctxt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Tezos_client_alpha.Michelson_v1_entrypoints.contract_entrypoint_type
                                        cctxt send send contract entrypoint)
                                      (let arg :=
                                        Tezos_client_alpha.Michelson_v1_entrypoints.print_entrypoint_type
                                          cctxt expected_argument false
                                          (Some contract) expected_argument
                                          entrypoint in
                                      fun eta => arg None None eta)
                                end
                          end))
                      (cons
                        (Tezos_base__TzPervasives.Clic.command (Some group)
                          "Get the entrypoint list of a contract." % string
                          Tezos_base__TzPervasives.Clic.no_options
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefixes
                              (cons "get" % string
                                (cons "contract" % string
                                  (cons "entrypoints" % string
                                    (cons "for" % string [])))))
                            (apply
                              (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                (Some "src" % string)
                                (Some "source contract" % string))
                              Tezos_base__TzPervasives.Clic.stop))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              fun function_parameter =>
                                match function_parameter with
                                | (_, contract) =>
                                  fun cctxt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Tezos_client_alpha.Michelson_v1_entrypoints.list_contract_entrypoints
                                        cctxt send send contract)
                                      (let arg :=
                                        Tezos_client_alpha.Michelson_v1_entrypoints.print_entrypoints_list
                                          cctxt expected_argument false
                                          (Some contract) in
                                      fun eta => arg None None eta)
                                end
                            end))
                        (cons
                          (Tezos_base__TzPervasives.Clic.command (Some group)
                            "Get the list of unreachable pathsin a contract's parameter type."
                              % string Tezos_base__TzPervasives.Clic.no_options
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "get" % string
                                  (cons "contract" % string
                                    (cons "unreachable" % string
                                      (cons "paths" % string
                                        (cons "for" % string []))))))
                              (apply
                                (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                  (Some "src" % string)
                                  (Some "source contract" % string))
                                Tezos_base__TzPervasives.Clic.stop))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                fun function_parameter =>
                                  match function_parameter with
                                  | (_, contract) =>
                                    fun cctxt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (Tezos_client_alpha.Michelson_v1_entrypoints.list_contract_unreachables
                                          cctxt send send contract)
                                        (let arg :=
                                          Tezos_client_alpha.Michelson_v1_entrypoints.print_unreachables
                                            cctxt expected_argument false
                                            (Some contract) in
                                        fun eta => arg None None eta)
                                  end
                              end))
                          (cons
                            (Tezos_base__TzPervasives.Clic.command (Some group)
                              "Get the delegate of a contract." % string
                              Tezos_base__TzPervasives.Clic.no_options
                              (apply
                                (Tezos_base__TzPervasives.Clic.prefixes
                                  (cons "get" % string
                                    (cons "delegate" % string
                                      (cons "for" % string []))))
                                (apply
                                  (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                    (Some "src" % string)
                                    (Some "source contract" % string))
                                  Tezos_base__TzPervasives.Clic.stop))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  fun function_parameter =>
                                    match function_parameter with
                                    | (_, contract) =>
                                      fun cctxt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_client_alpha.Client_proto_contracts.get_delegate
                                            cctxt send send contract)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | None =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "none" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "none" % string))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.return_unit
                                                  end)
                                            | Some delegate =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_client_base.Client_keys.Public_key_hash.rev_find
                                                  cctxt delegate)
                                                (fun mn =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    (Tezos_client_base.Client_keys.Public_key_hash.to_source
                                                      delegate)
                                                    (fun m =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String
                                                              CamlinternalFormatBasics.No_padding
                                                              (CamlinternalFormatBasics.String_literal
                                                                " (" % string
                                                                (CamlinternalFormatBasics.String
                                                                  CamlinternalFormatBasics.No_padding
                                                                  (CamlinternalFormatBasics.Char_literal
                                                                    ")" % char
                                                                    CamlinternalFormatBasics.End_of_format))))
                                                            "%s (%s)" % string)
                                                          m
                                                          match mn with
                                                          | None =>
                                                            "unknown" % string
                                                          | Some n =>
                                                            String.append
                                                              "known as " %
                                                                string n
                                                          end)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)))
                                            end)
                                    end
                                end))
                            (cons
                              (Tezos_base__TzPervasives.Clic.command
                                (Some group)
                                "Set the delegate of a contract." % string
                                (Tezos_base__TzPervasives.Clic.args9
                                  Tezos_client_alpha.Client_proto_args.fee_arg
                                  dry_run_switch verbose_signing_switch
                                  Tezos_client_alpha.Client_proto_args.minimal_fees_arg
                                  Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
                                  Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
                                  Tezos_client_alpha.Client_proto_args.force_low_fee_arg
                                  Tezos_client_alpha.Client_proto_args.fee_cap_arg
                                  Tezos_client_alpha.Client_proto_args.burn_cap_arg)
                                (apply
                                  (Tezos_base__TzPervasives.Clic.prefixes
                                    (cons "set" % string
                                      (cons "delegate" % string
                                        (cons "for" % string []))))
                                  (apply
                                    (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                      (Some "src" % string)
                                      (Some "source contract" % string))
                                    (apply
                                      (Tezos_base__TzPervasives.Clic.prefix
                                        "to" % string)
                                      (apply
                                        (Tezos_client_base.Client_keys.Public_key_hash.alias_param
                                          (Some "mgr" % string)
                                          (Some
                                            "new delegate of the contract" %
                                              string))
                                        Tezos_base__TzPervasives.Clic.stop))))
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    (fee, dry_run, verbose_signing,
                                      minimal_fees, minimal_nanotez_per_byte,
                                      minimal_nanotez_per_gas_unit,
                                      force_low_fee, fee_cap, burn_cap) =>
                                    fun function_parameter =>
                                      match function_parameter with
                                      | (_, contract) =>
                                        fun function_parameter =>
                                          match function_parameter with
                                          | (_, delegate) =>
                                            fun cctxt =>
                                              let fee_parameter :=
                                                {|
                                                  Injection.minimal_fees :=
                                                    minimal_fees;
                                                  Injection.minimal_nanotez_per_byte :=
                                                    minimal_nanotez_per_byte;
                                                  Injection.minimal_nanotez_per_gas_unit :=
                                                    minimal_nanotez_per_gas_unit;
                                                  Injection.force_low_fee :=
                                                    force_low_fee;
                                                  Injection.fee_cap := fee_cap;
                                                  Injection.burn_cap := burn_cap
                                                  |} in
                                              match
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                  contract with
                                              | None =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_client_alpha.Managed_contract.get_contract_manager
                                                    cctxt contract)
                                                  (fun source =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                      (Tezos_client_base.Client_keys.get_key
                                                        cctxt source)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | (_, src_pk, src_sk) =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (Tezos_client_alpha.Managed_contract.set_delegate
                                                              cctxt send send
                                                              send
                                                              (Some dry_run)
                                                              (Some
                                                                verbose_signing)
                                                              None fee_parameter
                                                              fee source src_pk
                                                              src_sk contract
                                                              (Some delegate))
                                                            (fun errors =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (report_michelson_errors
                                                                  (Some true)
                                                                  "Setting delegate through entrypoints failed."
                                                                    % string
                                                                  cctxt errors)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | _ =>
                                                                    Tezos_base__TzPervasives.return_unit
                                                                  end))
                                                        end))
                                              | Some mgr =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_client_base.Client_keys.get_key
                                                    cctxt mgr)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | (_, src_pk, manager_sk) =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                        (Tezos_client_alpha.Client_proto_context.set_delegate
                                                          cctxt send send send
                                                          (Some dry_run)
                                                          (Some verbose_signing)
                                                          fee mgr src_pk
                                                          manager_sk
                                                          fee_parameter
                                                          (Some delegate))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | _ =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)
                                                    end)
                                              end
                                          end
                                      end
                                  end))
                              (cons
                                (Tezos_base__TzPervasives.Clic.command
                                  (Some group)
                                  "Withdraw the delegate from a contract." %
                                    string
                                  (Tezos_base__TzPervasives.Clic.args9
                                    Tezos_client_alpha.Client_proto_args.fee_arg
                                    dry_run_switch verbose_signing_switch
                                    Tezos_client_alpha.Client_proto_args.minimal_fees_arg
                                    Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
                                    Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
                                    Tezos_client_alpha.Client_proto_args.force_low_fee_arg
                                    Tezos_client_alpha.Client_proto_args.fee_cap_arg
                                    Tezos_client_alpha.Client_proto_args.burn_cap_arg)
                                  (apply
                                    (Tezos_base__TzPervasives.Clic.prefixes
                                      (cons "withdraw" % string
                                        (cons "delegate" % string
                                          (cons "from" % string []))))
                                    (apply
                                      (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                        (Some "src" % string)
                                        (Some "source contract" % string))
                                      Tezos_base__TzPervasives.Clic.stop))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    |
                                      (fee, dry_run, verbose_signing,
                                        minimal_fees, minimal_nanotez_per_byte,
                                        minimal_nanotez_per_gas_unit,
                                        force_low_fee, fee_cap, burn_cap) =>
                                      fun function_parameter =>
                                        match function_parameter with
                                        | (_, contract) =>
                                          fun cctxt =>
                                            let fee_parameter :=
                                              {|
                                                Injection.minimal_fees :=
                                                  minimal_fees;
                                                Injection.minimal_nanotez_per_byte :=
                                                  minimal_nanotez_per_byte;
                                                Injection.minimal_nanotez_per_gas_unit :=
                                                  minimal_nanotez_per_gas_unit;
                                                Injection.force_low_fee :=
                                                  force_low_fee;
                                                Injection.fee_cap := fee_cap;
                                                Injection.burn_cap := burn_cap
                                                |} in
                                            match
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                contract with
                                            | None =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_client_alpha.Managed_contract.get_contract_manager
                                                  cctxt contract)
                                                (fun source =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    (Tezos_client_base.Client_keys.get_key
                                                      cctxt source)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | (_, src_pk, src_sk) =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (Tezos_client_alpha.Managed_contract.set_delegate
                                                            cctxt send send send
                                                            (Some dry_run)
                                                            (Some
                                                              verbose_signing)
                                                            None fee_parameter
                                                            fee source src_pk
                                                            src_sk contract None)
                                                          (fun errors =>
                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                              (report_michelson_errors
                                                                (Some true)
                                                                "Withdrawing delegate through entrypoints failed."
                                                                  % string cctxt
                                                                errors)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | _ =>
                                                                  Tezos_base__TzPervasives.return_unit
                                                                end))
                                                      end))
                                            | Some mgr =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_client_base.Client_keys.get_key
                                                  cctxt mgr)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (_, src_pk, manager_sk) =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (Tezos_client_alpha.Client_proto_context.set_delegate
                                                        cctxt send send send
                                                        (Some dry_run)
                                                        (Some verbose_signing)
                                                        fee mgr src_pk
                                                        manager_sk fee_parameter
                                                        None)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | _ =>
                                                          Tezos_base__TzPervasives.return_unit
                                                        end)
                                                  end)
                                            end
                                        end
                                    end))
                                (cons
                                  (Tezos_base__TzPervasives.Clic.command
                                    (Some group)
                                    "Launch a smart contract on the blockchain."
                                      % string
                                    (Tezos_base__TzPervasives.Clic.args15
                                      Tezos_client_alpha.Client_proto_args.fee_arg
                                      dry_run_switch verbose_signing_switch
                                      Tezos_client_alpha.Client_proto_args.gas_limit_arg
                                      Tezos_client_alpha.Client_proto_args.storage_limit_arg
                                      Tezos_client_alpha.Client_proto_args.delegate_arg
                                      (Tezos_client_base.Client_keys.force_switch
                                        tt)
                                      Tezos_client_alpha.Client_proto_args.init_arg
                                      Tezos_client_alpha.Client_proto_args.no_print_source_flag
                                      Tezos_client_alpha.Client_proto_args.minimal_fees_arg
                                      Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
                                      Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
                                      Tezos_client_alpha.Client_proto_args.force_low_fee_arg
                                      Tezos_client_alpha.Client_proto_args.fee_cap_arg
                                      Tezos_client_alpha.Client_proto_args.burn_cap_arg)
                                    (apply
                                      (Tezos_base__TzPervasives.Clic.prefixes
                                        (cons "originate" % string
                                          (cons "contract" % string [])))
                                      (apply
                                        (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.fresh_alias_param
                                          (Some "new" % string)
                                          (Some
                                            "name of the new contract" % string))
                                        (apply
                                          (Tezos_base__TzPervasives.Clic.prefix
                                            "transferring" % string)
                                          (apply
                                            (Tezos_client_alpha.Client_proto_args.tez_param
                                              "qty" % string
                                              "amount taken from source" %
                                                string)
                                            (apply
                                              (Tezos_base__TzPervasives.Clic.prefix
                                                "from" % string)
                                              (apply
                                                (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                                  (Some "src" % string)
                                                  (Some
                                                    "name of the source contract"
                                                      % string))
                                                (apply
                                                  (Tezos_base__TzPervasives.Clic.prefix
                                                    "running" % string)
                                                  (apply
                                                    (Tezos_client_alpha.Client_proto_programs.Program.source_param
                                                      (Some "prg" % string)
                                                      (Some
                                                        "script of the account
Combine with -init if the storage type is not unit."
                                                          % string))
                                                    Tezos_base__TzPervasives.Clic.stop))))))))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      |
                                        (fee, dry_run, verbose_signing,
                                          gas_limit, storage_limit, delegate,
                                          force, initial_storage,
                                          no_print_source, minimal_fees,
                                          minimal_nanotez_per_byte,
                                          minimal_nanotez_per_gas_unit,
                                          force_low_fee, fee_cap, burn_cap) =>
                                        fun alias_name =>
                                          fun balance =>
                                            fun function_parameter =>
                                              match function_parameter with
                                              | (_, source) =>
                                                fun program =>
                                                  fun cctxt =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                      (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.of_fresh
                                                        cctxt force alias_name)
                                                      (fun alias_name =>
                                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                          (Lwt._return
                                                            (Tezos_micheline.Micheline_parser.no_parsing_error
                                                              program))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | {|
                                                              expanded := code
                                                                |} =>
                                                              match
                                                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                                  source with
                                                              | None =>
                                                                Tezos_base__TzPervasives.failwith
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "only implicit accounts can be the source of an origination"
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "only implicit accounts can be the source of an origination"
                                                                      % string)
                                                              | Some source =>
                                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                  (Tezos_client_base.Client_keys.get_key
                                                                    cctxt source)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    |
                                                                      (_,
                                                                        src_pk,
                                                                        src_sk)
                                                                      =>
                                                                      let
                                                                        fee_parameter :=
                                                                        {|
                                                                          Injection.minimal_fees :=
                                                                            minimal_fees;
                                                                          Injection.minimal_nanotez_per_byte :=
                                                                            minimal_nanotez_per_byte;
                                                                          Injection.minimal_nanotez_per_gas_unit :=
                                                                            minimal_nanotez_per_gas_unit;
                                                                          Injection.force_low_fee :=
                                                                            force_low_fee;
                                                                          Injection.fee_cap :=
                                                                            fee_cap;
                                                                          Injection.burn_cap :=
                                                                            burn_cap
                                                                          |} in
                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                        (Tezos_client_alpha.Client_proto_context.originate_contract
                                                                          cctxt
                                                                          send
                                                                          send
                                                                          send
                                                                          (Some
                                                                            dry_run)
                                                                          (Some
                                                                            verbose_signing)
                                                                          None
                                                                          fee
                                                                          gas_limit
                                                                          storage_limit
                                                                          delegate
                                                                          initial_storage
                                                                          balance
                                                                          source
                                                                          src_pk
                                                                          src_sk
                                                                          code
                                                                          fee_parameter
                                                                          tt)
                                                                        (fun
                                                                          errors
                                                                          =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                            (report_michelson_errors
                                                                              (Some
                                                                                no_print_source)
                                                                              "origination simulation failed"
                                                                                %
                                                                                string
                                                                              cctxt
                                                                              errors)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                None
                                                                                =>
                                                                                Tezos_base__TzPervasives.return_unit
                                                                              |
                                                                                Some
                                                                                  (_res,
                                                                                    contract)
                                                                                =>
                                                                                if
                                                                                  dry_run
                                                                                  then
                                                                                  Tezos_base__TzPervasives.return_unit
                                                                                else
                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                    (Tezos_client_alpha.Client_proto_context.save_contract
                                                                                      force
                                                                                      cctxt
                                                                                      alias_name
                                                                                      contract)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        tt
                                                                                        =>
                                                                                        Tezos_base__TzPervasives.return_unit
                                                                                      end)
                                                                              end))
                                                                    end)
                                                              end
                                                            end))
                                              end
                                      end))
                                  (cons
                                    (Tezos_base__TzPervasives.Clic.command
                                      (Some group)
                                      "Transfer tokens / call a smart contract."
                                        % string
                                      (Tezos_base__TzPervasives.Clic.args15
                                        Tezos_client_alpha.Client_proto_args.fee_arg
                                        dry_run_switch verbose_signing_switch
                                        Tezos_client_alpha.Client_proto_args.gas_limit_arg
                                        Tezos_client_alpha.Client_proto_args.storage_limit_arg
                                        Tezos_client_alpha.Client_proto_args.counter_arg
                                        Tezos_client_alpha.Client_proto_args.arg_arg
                                        Tezos_client_alpha.Client_proto_args.no_print_source_flag
                                        Tezos_client_alpha.Client_proto_args.minimal_fees_arg
                                        Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
                                        Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
                                        Tezos_client_alpha.Client_proto_args.force_low_fee_arg
                                        Tezos_client_alpha.Client_proto_args.fee_cap_arg
                                        Tezos_client_alpha.Client_proto_args.burn_cap_arg
                                        Tezos_client_alpha.Client_proto_args.entrypoint_arg)
                                      (apply
                                        (Tezos_base__TzPervasives.Clic.prefixes
                                          (cons "transfer" % string []))
                                        (apply
                                          (Tezos_client_alpha.Client_proto_args.tez_param
                                            "qty" % string
                                            "amount taken from source" % string)
                                          (apply
                                            (Tezos_base__TzPervasives.Clic.prefix
                                              "from" % string)
                                            (apply
                                              (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                                (Some "src" % string)
                                                (Some
                                                  "name of the source contract"
                                                    % string))
                                              (apply
                                                (Tezos_base__TzPervasives.Clic.prefix
                                                  "to" % string)
                                                (apply
                                                  (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                                    (Some "dst" % string)
                                                    (Some
                                                      "name/literal of the destination contract"
                                                        % string))
                                                  Tezos_base__TzPervasives.Clic.stop))))))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        |
                                          (fee, dry_run, verbose_signing,
                                            gas_limit, storage_limit, counter,
                                            arg, no_print_source, minimal_fees,
                                            minimal_nanotez_per_byte,
                                            minimal_nanotez_per_gas_unit,
                                            force_low_fee, fee_cap, burn_cap,
                                            entrypoint) =>
                                          fun amount =>
                                            fun function_parameter =>
                                              match function_parameter with
                                              | (_, source) =>
                                                fun function_parameter =>
                                                  match function_parameter with
                                                  | (_, destination) =>
                                                    fun cctxt =>
                                                      let fee_parameter :=
                                                        {|
                                                          Injection.minimal_fees :=
                                                            minimal_fees;
                                                          Injection.minimal_nanotez_per_byte :=
                                                            minimal_nanotez_per_byte;
                                                          Injection.minimal_nanotez_per_gas_unit :=
                                                            minimal_nanotez_per_gas_unit;
                                                          Injection.force_low_fee :=
                                                            force_low_fee;
                                                          Injection.fee_cap :=
                                                            fee_cap;
                                                          Injection.burn_cap :=
                                                            burn_cap |} in
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (Tezos_base__TzPervasives.op_gt_gt_eq
                                                          match
                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                              source with
                                                          | None =>
                                                            let contract :=
                                                              source in
                                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                              (Tezos_client_alpha.Managed_contract.get_contract_manager
                                                                cctxt source)
                                                              (fun source =>
                                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                  (Tezos_client_base.Client_keys.get_key
                                                                    cctxt source)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    |
                                                                      (_,
                                                                        src_pk,
                                                                        src_sk)
                                                                      =>
                                                                      Tezos_client_alpha.Managed_contract.transfer
                                                                        cctxt
                                                                        send
                                                                        send
                                                                        send
                                                                        (Some
                                                                          dry_run)
                                                                        (Some
                                                                          verbose_signing)
                                                                        None
                                                                        source
                                                                        src_pk
                                                                        src_sk
                                                                        contract
                                                                        destination
                                                                        entrypoint
                                                                        arg
                                                                        amount
                                                                        fee
                                                                        gas_limit
                                                                        storage_limit
                                                                        counter
                                                                        fee_parameter
                                                                        tt
                                                                    end))
                                                          | Some source =>
                                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                              (Tezos_client_base.Client_keys.get_key
                                                                cctxt source)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                |
                                                                  (_, src_pk,
                                                                    src_sk) =>
                                                                  Tezos_client_alpha.Client_proto_context.transfer
                                                                    cctxt send
                                                                    send send
                                                                    (Some
                                                                      dry_run)
                                                                    (Some
                                                                      verbose_signing)
                                                                    None source
                                                                    src_pk
                                                                    src_sk
                                                                    destination
                                                                    entrypoint
                                                                    arg amount
                                                                    fee
                                                                    gas_limit
                                                                    storage_limit
                                                                    counter
                                                                    fee_parameter
                                                                    tt
                                                                end)
                                                          end
                                                          (report_michelson_errors
                                                            (Some
                                                              no_print_source)
                                                            "transfer simulation failed"
                                                              % string cctxt))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | None =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          |
                                                            Some
                                                              (_res, _contracts)
                                                            =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)
                                                  end
                                              end
                                        end))
                                    (cons
                                      (Tezos_base__TzPervasives.Clic.command
                                        (Some group)
                                        "Call a smart contract (same as 'transfer 0')."
                                          % string
                                        (Tezos_base__TzPervasives.Clic.args15
                                          Tezos_client_alpha.Client_proto_args.fee_arg
                                          dry_run_switch verbose_signing_switch
                                          Tezos_client_alpha.Client_proto_args.gas_limit_arg
                                          Tezos_client_alpha.Client_proto_args.storage_limit_arg
                                          Tezos_client_alpha.Client_proto_args.counter_arg
                                          Tezos_client_alpha.Client_proto_args.arg_arg
                                          Tezos_client_alpha.Client_proto_args.no_print_source_flag
                                          Tezos_client_alpha.Client_proto_args.minimal_fees_arg
                                          Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
                                          Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
                                          Tezos_client_alpha.Client_proto_args.force_low_fee_arg
                                          Tezos_client_alpha.Client_proto_args.fee_cap_arg
                                          Tezos_client_alpha.Client_proto_args.burn_cap_arg
                                          Tezos_client_alpha.Client_proto_args.entrypoint_arg)
                                        (apply
                                          (Tezos_base__TzPervasives.Clic.prefixes
                                            (cons "call" % string []))
                                          (apply
                                            (Tezos_base__TzPervasives.Clic.prefix
                                              "from" % string)
                                            (apply
                                              (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                                (Some "src" % string)
                                                (Some
                                                  "name of the source contract"
                                                    % string))
                                              (apply
                                                (Tezos_base__TzPervasives.Clic.prefix
                                                  "to" % string)
                                                (apply
                                                  (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                                    (Some "dst" % string)
                                                    (Some
                                                      "name/literal of the destination contract"
                                                        % string))
                                                  Tezos_base__TzPervasives.Clic.stop)))))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            (fee, dry_run, verbose_signing,
                                              gas_limit, storage_limit, counter,
                                              arg, no_print_source,
                                              minimal_fees,
                                              minimal_nanotez_per_byte,
                                              minimal_nanotez_per_gas_unit,
                                              force_low_fee, fee_cap, burn_cap,
                                              entrypoint) =>
                                            fun function_parameter =>
                                              match function_parameter with
                                              | (_, source) =>
                                                fun function_parameter =>
                                                  match function_parameter with
                                                  | (_, destination) =>
                                                    fun cctxt =>
                                                      let fee_parameter :=
                                                        {|
                                                          Injection.minimal_fees :=
                                                            minimal_fees;
                                                          Injection.minimal_nanotez_per_byte :=
                                                            minimal_nanotez_per_byte;
                                                          Injection.minimal_nanotez_per_gas_unit :=
                                                            minimal_nanotez_per_gas_unit;
                                                          Injection.force_low_fee :=
                                                            force_low_fee;
                                                          Injection.fee_cap :=
                                                            fee_cap;
                                                          Injection.burn_cap :=
                                                            burn_cap |} in
                                                      let amount :=
                                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                        in
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (Tezos_base__TzPervasives.op_gt_gt_eq
                                                          match
                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                              source with
                                                          | None =>
                                                            let contract :=
                                                              source in
                                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                              (Tezos_client_alpha.Managed_contract.get_contract_manager
                                                                cctxt source)
                                                              (fun source =>
                                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                  (Tezos_client_base.Client_keys.get_key
                                                                    cctxt source)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    |
                                                                      (_,
                                                                        src_pk,
                                                                        src_sk)
                                                                      =>
                                                                      Tezos_client_alpha.Managed_contract.transfer
                                                                        cctxt
                                                                        send
                                                                        send
                                                                        send
                                                                        (Some
                                                                          dry_run)
                                                                        (Some
                                                                          verbose_signing)
                                                                        None
                                                                        source
                                                                        src_pk
                                                                        src_sk
                                                                        contract
                                                                        destination
                                                                        entrypoint
                                                                        arg
                                                                        amount
                                                                        fee
                                                                        gas_limit
                                                                        storage_limit
                                                                        counter
                                                                        fee_parameter
                                                                        tt
                                                                    end))
                                                          | Some source =>
                                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                              (Tezos_client_base.Client_keys.get_key
                                                                cctxt source)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                |
                                                                  (_, src_pk,
                                                                    src_sk) =>
                                                                  Tezos_client_alpha.Client_proto_context.transfer
                                                                    cctxt send
                                                                    send send
                                                                    (Some
                                                                      dry_run)
                                                                    (Some
                                                                      verbose_signing)
                                                                    None source
                                                                    src_pk
                                                                    src_sk
                                                                    destination
                                                                    entrypoint
                                                                    arg amount
                                                                    fee
                                                                    gas_limit
                                                                    storage_limit
                                                                    counter
                                                                    fee_parameter
                                                                    tt
                                                                end)
                                                          end
                                                          (report_michelson_errors
                                                            (Some
                                                              no_print_source)
                                                            "transfer simulation failed"
                                                              % string cctxt))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | None =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          |
                                                            Some
                                                              (_res, _contracts)
                                                            =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)
                                                  end
                                              end
                                          end))
                                      (cons
                                        (Tezos_base__TzPervasives.Clic.command
                                          (Some group)
                                          "Reveal the public key of the contract manager."
                                            % string
                                          (Tezos_base__TzPervasives.Clic.args9
                                            Tezos_client_alpha.Client_proto_args.fee_arg
                                            dry_run_switch
                                            verbose_signing_switch
                                            Tezos_client_alpha.Client_proto_args.minimal_fees_arg
                                            Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
                                            Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
                                            Tezos_client_alpha.Client_proto_args.force_low_fee_arg
                                            Tezos_client_alpha.Client_proto_args.fee_cap_arg
                                            Tezos_client_alpha.Client_proto_args.burn_cap_arg)
                                          (apply
                                            (Tezos_base__TzPervasives.Clic.prefixes
                                              (cons "reveal" % string
                                                (cons "key" % string
                                                  (cons "for" % string []))))
                                            (apply
                                              (Tezos_client_alpha.Client_proto_contracts.ContractAlias.alias_param
                                                (Some "src" % string)
                                                (Some
                                                  "name of the source contract"
                                                    % string))
                                              Tezos_base__TzPervasives.Clic.stop))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              (fee, dry_run, verbose_signing,
                                                minimal_fees,
                                                minimal_nanotez_per_byte,
                                                minimal_nanotez_per_gas_unit,
                                                force_low_fee, fee_cap, burn_cap)
                                              =>
                                              fun function_parameter =>
                                                match function_parameter with
                                                | (_, source) =>
                                                  fun cctxt =>
                                                    match
                                                      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                        source with
                                                    | None =>
                                                      Tezos_base__TzPervasives.failwith
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.String_literal
                                                            "only implicit accounts can be revealed"
                                                              % string
                                                            CamlinternalFormatBasics.End_of_format)
                                                          "only implicit accounts can be revealed"
                                                            % string)
                                                    | Some source =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                        (Tezos_client_base.Client_keys.get_key
                                                          cctxt source)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | (_, src_pk, src_sk)
                                                            =>
                                                            let fee_parameter :=
                                                              {|
                                                                Injection.minimal_fees :=
                                                                  minimal_fees;
                                                                Injection.minimal_nanotez_per_byte :=
                                                                  minimal_nanotez_per_byte;
                                                                Injection.minimal_nanotez_per_gas_unit :=
                                                                  minimal_nanotez_per_gas_unit;
                                                                Injection.force_low_fee :=
                                                                  force_low_fee;
                                                                Injection.fee_cap :=
                                                                  fee_cap;
                                                                Injection.burn_cap :=
                                                                  burn_cap |} in
                                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                              (Tezos_client_alpha.Client_proto_context.reveal
                                                                cctxt send send
                                                                send
                                                                (Some dry_run)
                                                                (Some
                                                                  verbose_signing)
                                                                None source
                                                                src_pk src_sk
                                                                fee
                                                                fee_parameter tt)
                                                              (fun _res =>
                                                                Tezos_base__TzPervasives.return_unit)
                                                          end)
                                                    end
                                                end
                                            end))
                                        (cons
                                          (Tezos_base__TzPervasives.Clic.command
                                            (Some group)
                                            "Register the public key hash as a delegate."
                                              % string
                                            (Tezos_base__TzPervasives.Clic.args9
                                              Tezos_client_alpha.Client_proto_args.fee_arg
                                              dry_run_switch
                                              verbose_signing_switch
                                              Tezos_client_alpha.Client_proto_args.minimal_fees_arg
                                              Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
                                              Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
                                              Tezos_client_alpha.Client_proto_args.force_low_fee_arg
                                              Tezos_client_alpha.Client_proto_args.fee_cap_arg
                                              Tezos_client_alpha.Client_proto_args.burn_cap_arg)
                                            (apply
                                              (Tezos_base__TzPervasives.Clic.prefixes
                                                (cons "register" % string
                                                  (cons "key" % string [])))
                                              (apply
                                                (Tezos_client_base.Client_keys.Public_key_hash.source_param
                                                  (Some "mgr" % string)
                                                  (Some
                                                    "the delegate key" % string))
                                                (apply
                                                  (Tezos_base__TzPervasives.Clic.prefixes
                                                    (cons "as" % string
                                                      (cons "delegate" % string
                                                        [])))
                                                  Tezos_base__TzPervasives.Clic.stop)))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              |
                                                (fee, dry_run, verbose_signing,
                                                  minimal_fees,
                                                  minimal_nanotez_per_byte,
                                                  minimal_nanotez_per_gas_unit,
                                                  force_low_fee, fee_cap,
                                                  burn_cap) =>
                                                fun src_pkh =>
                                                  fun cctxt =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                      (Tezos_client_base.Client_keys.get_key
                                                        cctxt src_pkh)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | (_, src_pk, src_sk) =>
                                                          let fee_parameter :=
                                                            {|
                                                              Injection.minimal_fees :=
                                                                minimal_fees;
                                                              Injection.minimal_nanotez_per_byte :=
                                                                minimal_nanotez_per_byte;
                                                              Injection.minimal_nanotez_per_gas_unit :=
                                                                minimal_nanotez_per_gas_unit;
                                                              Injection.force_low_fee :=
                                                                force_low_fee;
                                                              Injection.fee_cap :=
                                                                fee_cap;
                                                              Injection.burn_cap :=
                                                                burn_cap |} in
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (Tezos_client_alpha.Client_proto_context.register_as_delegate
                                                              cctxt send send
                                                              send
                                                              (Some dry_run)
                                                              (Some
                                                                verbose_signing)
                                                              fee src_sk
                                                              fee_parameter
                                                              src_pk)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | inl _ =>
                                                                Tezos_base__TzPervasives.return_unit
                                                              |
                                                                inr
                                                                  (cons
                                                                    (Environment.Ecoproto_error
                                                                      Delegate_storage.Active_delegate)
                                                                    []) =>
                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                  (send
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "Delegate already activated."
                                                                          %
                                                                          string
                                                                        CamlinternalFormatBasics.End_of_format)
                                                                      "Delegate already activated."
                                                                        % string))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | tt =>
                                                                      Tezos_base__TzPervasives.return_unit
                                                                    end)
                                                              | inr el =>
                                                                Lwt.return_error
                                                                  el
                                                              end)
                                                        end)
                                              end)) []))))))))))))))))))
      (OCaml.Stdlib.app
        (if equiv_decb version (Some variant) then
          []
        else
          cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Register and activate an Alphanet/Zeronet faucet account." %
                string
              (Tezos_base__TzPervasives.Clic.args2
                (Tezos_client_base.Client_keys.Secret_key.force_switch tt)
                encrypted_switch)
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "activate" % string (cons "account" % string [])))
                (apply
                  (let arg :=
                    Tezos_client_base.Client_keys.Secret_key.fresh_alias_param
                    in
                  fun eta => arg None None eta)
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "with" % string []))
                    (apply
                      (Tezos_base__TzPervasives.Clic.param
                        "activation_key" % string
                        "Activate an Alphanet/Zeronet faucet account from the downloaded JSON file."
                          % string file_parameter)
                      Tezos_base__TzPervasives.Clic.stop))))
              (fun function_parameter =>
                match function_parameter with
                | (force, encrypted) =>
                  fun name =>
                    fun activation_key_file =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_base.Client_keys.Secret_key.of_fresh
                            cctxt force name)
                          (fun name =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file
                                activation_key_file)
                              (fun json =>
                                match
                                  Tezos_base__TzPervasives.Data_encoding.Json.destruct
                                    Tezos_client_alpha.Client_proto_context.activation_key_encoding
                                    json with
                                | key =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_client_alpha.Client_proto_context.activate_account
                                      cctxt send send send None (Some encrypted)
                                      (Some force) key name)
                                    (fun _res =>
                                      Tezos_base__TzPervasives.return_unit)
                                end))
                end)) [])
        (OCaml.Stdlib.app
          (if nequiv_decb version (Some variant) then
            []
          else
            cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Activate a fundraiser account." % string
                (Tezos_base__TzPervasives.Clic.args1 dry_run_switch)
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "activate" % string
                      (cons "fundraiser" % string (cons "account" % string []))))
                  (apply
                    (let arg :=
                      Tezos_client_base.Client_keys.Public_key_hash.alias_param
                      in
                    fun eta => arg None None eta)
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "with" % string []))
                      (apply
                        (Tezos_base__TzPervasives.Clic.param "code" % string
                          "Activation code obtained from the Tezos foundation."
                            % string
                          (Tezos_base__TzPervasives.Clic.parameter None
                            (fun _ctx =>
                              fun code =>
                                Tezos_base__TzPervasives.protect None None
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives._return
                                        (Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code_of_hex
                                          code)
                                    end)))) Tezos_base__TzPervasives.Clic.stop))))
                (fun dry_run =>
                  fun function_parameter =>
                    match function_parameter with
                    | (name, _pkh) =>
                      fun code =>
                        fun cctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_client_alpha.Client_proto_context.activate_existing_account
                              cctxt send send send (Some dry_run) name code)
                            (fun _res => Tezos_base__TzPervasives.return_unit)
                    end)) [])
          (cons
            (Tezos_base__TzPervasives.Clic.command None
              "Wait until an operation is included in a block" % string
              (Tezos_base__TzPervasives.Clic.args3
                (Tezos_base__TzPervasives.Clic.default_arg
                  "wait until 'N' additional blocks after the operation appears in the considered chain"
                    % string None "confirmations" % string "num_blocks" % string
                  "0" % string non_negative_param)
                (Tezos_base__TzPervasives.Clic.default_arg
                  "number of previous blocks to check" % string None
                  "check-previous" % string "num_blocks" % string "10" % string
                  non_negative_param)
                (Tezos_base__TzPervasives.Clic.arg
                  "hash of the oldest block where we should look for the operation"
                    % string None "branch" % string "block_hash" % string
                  block_hash_param))
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "wait" % string (cons "for" % string [])))
                (apply
                  (Tezos_base__TzPervasives.Clic.param "operation" % string
                    "Operation to be included" % string
                    (Tezos_base__TzPervasives.Clic.parameter None
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          fun x =>
                            match
                              Tezos_base__TzPervasives.Operation_hash.of_b58check_opt
                                x with
                            | None =>
                              Tezos_base__TzPervasives.Error_monad.failwith
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Invalid operation hash: '" % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Char_literal
                                        "'" % char
                                        CamlinternalFormatBasics.End_of_format)))
                                  "Invalid operation hash: '%s'" % string) x
                            | Some hash => Tezos_base__TzPervasives._return hash
                            end
                        end)))
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "to" % string
                        (cons "be" % string (cons "included" % string []))))
                    Tezos_base__TzPervasives.Clic.stop)))
              (fun function_parameter =>
                match function_parameter with
                | (confirmations, predecessors, branch) =>
                  fun operation_hash =>
                    fun ctxt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_client_base.Client_confirmations.wait_for_operation_inclusion
                          ctxt send (Some predecessors) (Some confirmations)
                          branch operation_hash)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => Tezos_base__TzPervasives.return_unit
                          end)
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command None
                "Get receipt for past operation" % string
                (Tezos_base__TzPervasives.Clic.args1
                  (Tezos_base__TzPervasives.Clic.default_arg
                    "number of previous blocks to check" % string None
                    "check-previous" % string "num_blocks" % string
                    "10" % string non_negative_param))
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "get" % string
                      (cons "receipt" % string (cons "for" % string []))))
                  (apply
                    (Tezos_base__TzPervasives.Clic.param "operation" % string
                      "Operation to be looked up" % string
                      (Tezos_base__TzPervasives.Clic.parameter None
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            fun x =>
                              match
                                Tezos_base__TzPervasives.Operation_hash.of_b58check_opt
                                  x with
                              | None =>
                                Tezos_base__TzPervasives.Error_monad.failwith
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Invalid operation hash: '" % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.Char_literal
                                          "'" % char
                                          CamlinternalFormatBasics.End_of_format)))
                                    "Invalid operation hash: '%s'" % string) x
                              | Some hash =>
                                Tezos_base__TzPervasives._return hash
                              end
                          end))) Tezos_base__TzPervasives.Clic.stop))
                (fun predecessors =>
                  fun operation_hash =>
                    fun ctxt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_client_alpha.Client_proto_context.display_receipt_for_operation
                          ctxt send (Some predecessors) operation_hash)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => Tezos_base__TzPervasives.return_unit
                          end)))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some binary_description)
                  "Describe unsigned block header" % string
                  Tezos_base__TzPervasives.Clic.no_options
                  (Tezos_base__TzPervasives.Clic.fixed
                    (cons "describe" % string
                      (cons "unsigned" % string
                        (cons "block" % string (cons "header" % string [])))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format)
                              "%a" % string)
                            Tezos_base__TzPervasives.Data_encoding.Binary_schema.pp
                            (Tezos_base__TzPervasives.Data_encoding.Binary.describe
                              Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.unsigned_encoding))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_unit
                            end)
                    end))
                (cons
                  (Tezos_base__TzPervasives.Clic.command
                    (Some binary_description)
                    "Describe unsigned block header" % string
                    Tezos_base__TzPervasives.Clic.no_options
                    (Tezos_base__TzPervasives.Clic.fixed
                      (cons "describe" % string
                        (cons "unsigned" % string (cons "operation" % string []))))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        fun cctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)
                                "%a" % string)
                              Tezos_base__TzPervasives.Data_encoding.Binary_schema.pp
                              (Tezos_base__TzPervasives.Data_encoding.Binary.describe
                                Tezos_protocol_alpha.Protocol.Alpha_context.Operation.unsigned_encoding))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Clic.command (Some group)
                      "Submit protocol proposals" % string
                      (Tezos_base__TzPervasives.Clic.args3 dry_run_switch
                        verbose_signing_switch
                        (Tezos_base__TzPervasives.Clic.switch
                          "Do not fail when the checks that try to prevent the user from shooting themselves in the foot do."
                            % string None "force" % string tt))
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "submit" % string
                            (cons "proposals" % string (cons "for" % string []))))
                        (apply
                          (Tezos_client_base.Client_keys.Secret_key.alias_param
                            (Some "delegate" % string)
                            (Some "the delegate who makes the proposal" % string))
                          (Tezos_base__TzPervasives.Clic.seq_of_param
                            (Tezos_base__TzPervasives.Clic.param
                              "proposal" % string
                              "the protocol hash proposal to be submitted" %
                                string
                              (Tezos_base__TzPervasives.Clic.parameter None
                                (fun function_parameter =>
                                  match function_parameter with
                                  | _ =>
                                    fun x =>
                                      match
                                        Tezos_base__TzPervasives.Protocol_hash.of_b58check_opt
                                          x with
                                      | None =>
                                        Tezos_base__TzPervasives.Error_monad.failwith
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Invalid proposal hash: '" %
                                                string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                (CamlinternalFormatBasics.Char_literal
                                                  "'" % char
                                                  CamlinternalFormatBasics.End_of_format)))
                                            "Invalid proposal hash: '%s'" %
                                              string) x
                                      | Some hash =>
                                        Tezos_base__TzPervasives._return hash
                                      end
                                  end))))))
                      (fun function_parameter =>
                        match function_parameter with
                        | (dry_run, verbose_signing, force) =>
                          fun function_parameter =>
                            match function_parameter with
                            | (src_name, src_sk) =>
                              fun proposals =>
                                fun cctxt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_client_base.Client_keys.neuterize
                                      src_sk)
                                    (fun src_pk =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_client_base.Client_keys.public_key_hash
                                          src_pk)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (src_pkh, _) =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                              (Tezos_client_alpha.Client_proto_context.get_period_info
                                                cctxt send send)
                                              (fun info =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  match current_period_kind info
                                                    with
                                                  | Proposal =>
                                                    Tezos_base__TzPervasives.return_unit
                                                  | _ =>
                                                    send
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Not in a proposal period"
                                                            % string
                                                          CamlinternalFormatBasics.End_of_format)
                                                        "Not in a proposal period"
                                                          % string)
                                                  end
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                        (Tezos_shell_services.Shell_services.Protocol.list
                                                          cctxt)
                                                        (fun known_protos =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                            (Tezos_client_alpha.Client_proto_context.get_proposals
                                                              cctxt send send)
                                                            (fun known_proposals
                                                              =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                (Tezos_protocol_alpha.Protocol.Alpha_services.Voting.listings
                                                                  cctxt
                                                                  (send, send))
                                                                (fun listings =>
                                                                  let
                                                                    check_proposals
                                                                    (proposals :
                                                                    Base.List.t
                                                                      Tezos_base__TzPervasives.Protocol_hash.t)
                                                                    : Lwt.t
                                                                      (Tezos_base__TzPervasives.tzresult
                                                                        bool) :=
                                                                    let n :=
                                                                      Tezos_base__TzPervasives.List.length
                                                                        proposals
                                                                      in
                                                                    let
                                                                      errors :=
                                                                      Stdlib.ref
                                                                        [] in
                                                                    let error
                                                                      {A : Type}
                                                                      (ppf :
                                                                      Stdlib.format4
                                                                        A
                                                                        Stdlib.Format.formatter
                                                                        unit
                                                                        unit)
                                                                      : A :=
                                                                      Stdlib.Format.kasprintf
                                                                        (fun s
                                                                          =>
                                                                          Stdlib.op_colon_eq
                                                                            errors
                                                                            (cons
                                                                              s
                                                                              (Stdlib.op_exclamation
                                                                                errors)))
                                                                        ppf in
                                                                    if
                                                                      equiv_decb
                                                                        n 0 then
                                                                      error
                                                                        (CamlinternalFormatBasics.Format
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "Empty proposal list."
                                                                              %
                                                                              string
                                                                            CamlinternalFormatBasics.End_of_format)
                                                                          "Empty proposal list."
                                                                            %
                                                                            string)
                                                                    else
                                                                      tt;
                                                                    if
                                                                      OCaml.Stdlib.gt
                                                                        n
                                                                        (max_proposals_per_delegate
                                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Constants.fixed)
                                                                      then
                                                                      error
                                                                        (CamlinternalFormatBasics.Format
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "Too many proposals: "
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Int
                                                                              CamlinternalFormatBasics.Int_d
                                                                              CamlinternalFormatBasics.No_padding
                                                                              CamlinternalFormatBasics.No_precision
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                " > "
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Int
                                                                                  CamlinternalFormatBasics.Int_d
                                                                                  CamlinternalFormatBasics.No_padding
                                                                                  CamlinternalFormatBasics.No_precision
                                                                                  (CamlinternalFormatBasics.Char_literal
                                                                                    "."
                                                                                      %
                                                                                      char
                                                                                    CamlinternalFormatBasics.End_of_format)))))
                                                                          "Too many proposals: %d > %d."
                                                                            %
                                                                            string)
                                                                        n
                                                                        (max_proposals_per_delegate
                                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Constants.fixed)
                                                                    else
                                                                      tt;
                                                                    match
                                                                      Base.List.find_all_dups
                                                                        Tezos_base__TzPervasives.Protocol_hash.compare
                                                                        proposals
                                                                      with
                                                                    | [] => tt
                                                                    | dups =>
                                                                      error
                                                                        (CamlinternalFormatBasics.Format
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "There "
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.String
                                                                              CamlinternalFormatBasics.No_padding
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                ": "
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Alpha
                                                                                  (CamlinternalFormatBasics.Char_literal
                                                                                    "."
                                                                                      %
                                                                                      char
                                                                                    CamlinternalFormatBasics.End_of_format)))))
                                                                          "There %s: %a."
                                                                            %
                                                                            string)
                                                                        (if
                                                                          equiv_decb
                                                                            (Tezos_base__TzPervasives.List.length
                                                                              dups)
                                                                            1
                                                                          then
                                                                          "is a duplicate proposal"
                                                                            %
                                                                            string
                                                                        else
                                                                          "are duplicate proposals"
                                                                            %
                                                                            string)
                                                                        (Stdlib.Format.pp_print_list
                                                                          (Some
                                                                            (fun
                                                                              ppf
                                                                              =>
                                                                              fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  tt
                                                                                  =>
                                                                                  Stdlib.Format.pp_print_string
                                                                                    ppf
                                                                                    ", "
                                                                                      %
                                                                                      string
                                                                                end))
                                                                          Tezos_base__TzPervasives.Protocol_hash.pp)
                                                                        dups
                                                                    end;
                                                                    Tezos_base__TzPervasives.List.iter
                                                                      (fun p =>
                                                                        if
                                                                          orb
                                                                            (Tezos_base__TzPervasives.List.mem
                                                                              p
                                                                              known_protos)
                                                                            (Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.mem
                                                                              p
                                                                              known_proposals)
                                                                          then
                                                                          tt
                                                                        else
                                                                          error
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "Protocol "
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Alpha
                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                    " is not a known proposal."
                                                                                      %
                                                                                      string
                                                                                    CamlinternalFormatBasics.End_of_format)))
                                                                              "Protocol %a is not a known proposal."
                                                                                %
                                                                                string)
                                                                            Tezos_base__TzPervasives.Protocol_hash.pp
                                                                            p)
                                                                      proposals;
                                                                    if
                                                                      negb
                                                                        (Tezos_base__TzPervasives.List._exists
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            |
                                                                              (pkh,
                                                                                _)
                                                                              =>
                                                                              Tezos_base__TzPervasives.Signature.Public_key_hash.equal
                                                                                pkh
                                                                                src_pkh
                                                                            end)
                                                                          listings)
                                                                      then
                                                                      error
                                                                        (CamlinternalFormatBasics.Format
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "Public-key-hash `"
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Alpha
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "` from account `"
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.String
                                                                                  CamlinternalFormatBasics.No_padding
                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                    "` does not appear to have voting rights."
                                                                                      %
                                                                                      string
                                                                                    CamlinternalFormatBasics.End_of_format)))))
                                                                          "Public-key-hash `%a` from account `%s` does not appear to have voting rights."
                                                                            %
                                                                            string)
                                                                        Tezos_base__TzPervasives.Signature.Public_key_hash.pp
                                                                        src_pkh
                                                                        src_name
                                                                    else
                                                                      tt;
                                                                    if
                                                                      nequiv_decb
                                                                        (Stdlib.op_exclamation
                                                                          errors)
                                                                        [] then
                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                        (send
                                                                          (CamlinternalFormatBasics.Format
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              "There "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.String
                                                                                CamlinternalFormatBasics.No_padding
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  " with the submission:"
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Theta
                                                                                    CamlinternalFormatBasics.End_of_format))))
                                                                            "There %s with the submission:%t"
                                                                              %
                                                                              string)
                                                                          (if
                                                                            equiv_decb
                                                                              (Tezos_base__TzPervasives.List.length
                                                                                (Stdlib.op_exclamation
                                                                                  errors))
                                                                              1
                                                                            then
                                                                            "is an issue"
                                                                              %
                                                                              string
                                                                          else
                                                                            "are issues"
                                                                              %
                                                                              string)
                                                                          (fun
                                                                            ppf
                                                                            =>
                                                                            Stdlib.Format.pp_print_cut
                                                                              ppf
                                                                              tt;
                                                                            Stdlib.Format.pp_open_vbox
                                                                              ppf
                                                                              0;
                                                                            Tezos_base__TzPervasives.List.iter
                                                                              (fun
                                                                                msg
                                                                                =>
                                                                                Stdlib.Format.pp_open_hovbox
                                                                                  ppf
                                                                                  2;
                                                                                Stdlib.Format.pp_print_string
                                                                                  ppf
                                                                                  "* "
                                                                                    %
                                                                                    string;
                                                                                Stdlib.Format.pp_print_text
                                                                                  ppf
                                                                                  msg;
                                                                                Stdlib.Format.pp_close_box
                                                                                  ppf
                                                                                  tt;
                                                                                Stdlib.Format.pp_print_cut
                                                                                  ppf
                                                                                  tt)
                                                                              (Stdlib.op_exclamation
                                                                                errors);
                                                                            Stdlib.Format.pp_close_box
                                                                              ppf
                                                                              tt))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | tt
                                                                            =>
                                                                            Tezos_base__TzPervasives.return_false
                                                                          end)
                                                                    else
                                                                      Tezos_base__TzPervasives.return_true
                                                                    in
                                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                    (check_proposals
                                                                      proposals)
                                                                    (fun
                                                                      all_valid
                                                                      =>
                                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                                        (if
                                                                          all_valid
                                                                          then
                                                                          send
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "All proposals are valid."
                                                                                  %
                                                                                  string
                                                                                CamlinternalFormatBasics.End_of_format)
                                                                              "All proposals are valid."
                                                                                %
                                                                                string)
                                                                        else
                                                                          if
                                                                            force
                                                                            then
                                                                            send
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "Some proposals are not valid, but `--force` was used."
                                                                                    %
                                                                                    string
                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                "Some proposals are not valid, but `--force` was used."
                                                                                  %
                                                                                  string)
                                                                          else
                                                                            send
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "Submission failed because of invalid proposals."
                                                                                    %
                                                                                    string
                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                "Submission failed because of invalid proposals."
                                                                                  %
                                                                                  string))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | tt
                                                                            =>
                                                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                                                              (Tezos_client_alpha.Client_proto_context.submit_proposals
                                                                                (Some
                                                                                  dry_run)
                                                                                (Some
                                                                                  verbose_signing)
                                                                                cctxt
                                                                                send
                                                                                send
                                                                                None
                                                                                src_sk
                                                                                src_pkh
                                                                                proposals)
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  inl
                                                                                    _res
                                                                                  =>
                                                                                  Tezos_base__TzPervasives.return_unit
                                                                                |
                                                                                  inr
                                                                                    errs
                                                                                  =>
                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                    match
                                                                                      errs
                                                                                      with
                                                                                    |
                                                                                      cons
                                                                                        (Unregistred_error
                                                                                          (O
                                                                                            (cons
                                                                                              ("kind"
                                                                                                %
                                                                                                string,
                                                                                                String
                                                                                                  "generic"
                                                                                                    %
                                                                                                    string)
                                                                                              (cons
                                                                                                ("error"
                                                                                                  %
                                                                                                  string,
                                                                                                  String
                                                                                                    msg)
                                                                                                []))))
                                                                                        []
                                                                                      =>
                                                                                      send
                                                                                        (CamlinternalFormatBasics.Format
                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                            "Error:"
                                                                                              %
                                                                                              string
                                                                                            (CamlinternalFormatBasics.Formatting_gen
                                                                                              (CamlinternalFormatBasics.Open_box
                                                                                                (CamlinternalFormatBasics.Format
                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                    "<hov>"
                                                                                                      %
                                                                                                      string
                                                                                                    CamlinternalFormatBasics.End_of_format)
                                                                                                  "<hov>"
                                                                                                    %
                                                                                                    string))
                                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                                CamlinternalFormatBasics.Flush_newline
                                                                                                (CamlinternalFormatBasics.Alpha
                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                    CamlinternalFormatBasics.Close_box
                                                                                                    CamlinternalFormatBasics.End_of_format)))))
                                                                                          "Error:@[<hov>@.%a@]"
                                                                                            %
                                                                                            string)
                                                                                        Stdlib.Format.pp_print_text
                                                                                        (OCaml.Stdlib.reverse_apply
                                                                                          (OCaml.Stdlib.reverse_apply
                                                                                            (OCaml.Stdlib.reverse_apply
                                                                                              (Tezos_base__TzPervasives.String.split_on_char
                                                                                                " "
                                                                                                  %
                                                                                                  char
                                                                                                msg)
                                                                                              (Tezos_base__TzPervasives.List.filter
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  match
                                                                                                    function_parameter
                                                                                                    with
                                                                                                  |
                                                                                                    ""
                                                                                                      %
                                                                                                      string
                                                                                                      |
                                                                                                      "
"
                                                                                                        %
                                                                                                        string
                                                                                                    =>
                                                                                                    false
                                                                                                  |
                                                                                                    _
                                                                                                    =>
                                                                                                    true
                                                                                                  end)))
                                                                                            (Tezos_base__TzPervasives.String.concat
                                                                                              " "
                                                                                                %
                                                                                                string))
                                                                                          (Tezos_base__TzPervasives.String.map
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                "010"
                                                                                                  %
                                                                                                  char
                                                                                                  |
                                                                                                  "009"
                                                                                                    %
                                                                                                    char
                                                                                                =>
                                                                                                " "
                                                                                                  %
                                                                                                  char
                                                                                              |
                                                                                                c
                                                                                                =>
                                                                                                c
                                                                                              end)))
                                                                                    |
                                                                                      el
                                                                                      =>
                                                                                      send
                                                                                        (CamlinternalFormatBasics.Format
                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                            "Error:"
                                                                                              %
                                                                                              string
                                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                                              (CamlinternalFormatBasics.Break
                                                                                                "@ "
                                                                                                  %
                                                                                                  string
                                                                                                1
                                                                                                0)
                                                                                              (CamlinternalFormatBasics.Alpha
                                                                                                CamlinternalFormatBasics.End_of_format)))
                                                                                          "Error:@ %a"
                                                                                            %
                                                                                            string)
                                                                                        Tezos_base__TzPervasives.pp_print_error
                                                                                        el
                                                                                    end
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        tt
                                                                                        =>
                                                                                        Tezos_base__TzPervasives.failwith
                                                                                          (CamlinternalFormatBasics.Format
                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                              "Failed to submit proposals"
                                                                                                %
                                                                                                string
                                                                                              CamlinternalFormatBasics.End_of_format)
                                                                                            "Failed to submit proposals"
                                                                                              %
                                                                                              string)
                                                                                      end)
                                                                                end)
                                                                          end)))))
                                                    end))
                                          end))
                            end
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Clic.command (Some group)
                        "Submit a ballot" % string
                        (Tezos_base__TzPervasives.Clic.args2
                          verbose_signing_switch dry_run_switch)
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "submit" % string
                              (cons "ballot" % string (cons "for" % string []))))
                          (apply
                            (Tezos_client_base.Client_keys.Secret_key.alias_param
                              (Some "delegate" % string)
                              (Some "the delegate who votes" % string))
                            (apply
                              (Tezos_base__TzPervasives.Clic.param
                                "proposal" % string
                                "the protocol hash proposal to vote for" %
                                  string
                                (Tezos_base__TzPervasives.Clic.parameter None
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ =>
                                      fun x =>
                                        match
                                          Tezos_base__TzPervasives.Protocol_hash.of_b58check_opt
                                            x with
                                        | None =>
                                          Tezos_base__TzPervasives.failwith
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Invalid proposal hash: '" %
                                                  string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.Char_literal
                                                    "'" % char
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "Invalid proposal hash: '%s'" %
                                                string) x
                                        | Some hash =>
                                          Tezos_base__TzPervasives._return hash
                                        end
                                    end)))
                              (apply
                                (Tezos_base__TzPervasives.Clic.param
                                  "ballot" % string
                                  "the ballot value (yea/yay, nay, or pass)" %
                                    string
                                  (Tezos_base__TzPervasives.Clic.parameter
                                    (Some
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          Tezos_base__TzPervasives._return
                                            (cons "yea" % string
                                              (cons "nay" % string
                                                (cons "pass" % string [])))
                                        end))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | _ =>
                                        fun s =>
                                          match
                                            Tezos_base__TzPervasives.String.lowercase_ascii
                                              s with
                                          | "yay" % string | "yea" % string =>
                                            Tezos_base__TzPervasives._return
                                              Vote.Yay
                                          | "nay" % string =>
                                            Tezos_base__TzPervasives._return
                                              Vote.Nay
                                          | "pass" % string =>
                                            Tezos_base__TzPervasives._return
                                              Vote.Pass
                                          | s =>
                                            Tezos_base__TzPervasives.failwith
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Invalid ballot: '" % string
                                                  (CamlinternalFormatBasics.String
                                                    CamlinternalFormatBasics.No_padding
                                                    (CamlinternalFormatBasics.Char_literal
                                                      "'" % char
                                                      CamlinternalFormatBasics.End_of_format)))
                                                "Invalid ballot: '%s'" % string)
                                              s
                                          end
                                      end))) Tezos_base__TzPervasives.Clic.stop))))
                        (fun function_parameter =>
                          match function_parameter with
                          | (verbose_signing, dry_run) =>
                            fun function_parameter =>
                              match function_parameter with
                              | (_, src_sk) =>
                                fun proposal =>
                                  fun ballot =>
                                    fun cctxt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_client_base.Client_keys.neuterize
                                          src_sk)
                                        (fun src_pk =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            (Tezos_client_base.Client_keys.public_key_hash
                                              src_pk)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | (src_pkh, _) =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_client_alpha.Client_proto_context.get_period_info
                                                    cctxt send send)
                                                  (fun info =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                      match
                                                        current_period_kind info
                                                        with
                                                      |
                                                        Testing_vote |
                                                          Promotion_vote =>
                                                        Tezos_base__TzPervasives.return_unit
                                                      | _ =>
                                                        send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "Not in a Testing_vote or Promotion_vote period"
                                                                % string
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "Not in a Testing_vote or Promotion_vote period"
                                                              % string)
                                                      end
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                            (Tezos_client_alpha.Client_proto_context.submit_ballot
                                                              (Some dry_run)
                                                              (Some
                                                                verbose_signing)
                                                              cctxt send send
                                                              None src_sk
                                                              src_pkh proposal
                                                              ballot)
                                                            (fun _res =>
                                                              Tezos_base__TzPervasives.return_unit)
                                                        end))
                                              end))
                              end
                          end))
                      (cons
                        (Tezos_base__TzPervasives.Clic.command (Some group)
                          "Summarize the current voting period" % string
                          Tezos_base__TzPervasives.Clic.no_options
                          (Tezos_base__TzPervasives.Clic.fixed
                            (cons "show" % string
                              (cons "voting" % string
                                (cons "period" % string []))))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              fun cctxt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_client_alpha.Client_proto_context.get_period_info
                                    cctxt send send)
                                  (fun info =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Current period: " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                "
Blocks remaining until end of period: "
                                                  % string
                                                (CamlinternalFormatBasics.Int32
                                                  CamlinternalFormatBasics.Int_d
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.No_precision
                                                  CamlinternalFormatBasics.End_of_format))))
                                          "Current period: %a
Blocks remaining until end of period: %ld"
                                            % string)
                                        Tezos_base__TzPervasives.Data_encoding.Json.pp
                                        (Tezos_base__TzPervasives.Data_encoding.Json.construct
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.kind_encoding
                                          (current_period_kind info))
                                        (remaining info))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            (Tezos_shell_services.Shell_services.Protocol.list
                                              cctxt)
                                            (fun known_protos =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_client_alpha.Client_proto_context.get_proposals
                                                  cctxt send send)
                                                (fun props =>
                                                  let ranks :=
                                                    OCaml.Stdlib.reverse_apply
                                                      (Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.bindings
                                                        props)
                                                      (Tezos_base__TzPervasives.List.sort
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | (_, v1) =>
                                                            fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | (_, v2) =>
                                                                Stdlib.Int32.compare
                                                                  v2 v1
                                                              end
                                                          end)) in
                                                  let print_proposal
                                                    (function_parameter :
                                                    option
                                                      Tezos_base__TzPervasives.Protocol_hash.t)
                                                    : Lwt.t unit :=
                                                    match function_parameter
                                                      with
                                                    | None => false
                                                    | Some proposal =>
                                                      send
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Current proposal: "
                                                              % string
                                                            (CamlinternalFormatBasics.Alpha
                                                              CamlinternalFormatBasics.End_of_format))
                                                          "Current proposal: %a"
                                                            % string)
                                                        Tezos_base__TzPervasives.Protocol_hash.pp
                                                        proposal
                                                    end in
                                                  match current_period_kind info
                                                    with
                                                  | Proposal =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (send
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Current proposals:"
                                                              % string
                                                            (CamlinternalFormatBasics.Theta
                                                              CamlinternalFormatBasics.End_of_format))
                                                          "Current proposals:%t"
                                                            % string)
                                                        (fun ppf =>
                                                          Stdlib.Format.pp_print_cut
                                                            ppf tt;
                                                          Stdlib.Format.pp_open_vbox
                                                            ppf 0;
                                                          Tezos_base__TzPervasives.List.iter
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | (p, w) =>
                                                                Stdlib.Format.fprintf
                                                                  ppf
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "* " %
                                                                        string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Char_literal
                                                                          " " %
                                                                            char
                                                                          (CamlinternalFormatBasics.Int32
                                                                            CamlinternalFormatBasics.Int_d
                                                                            CamlinternalFormatBasics.No_padding
                                                                            CamlinternalFormatBasics.No_precision
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              " ("
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.String
                                                                                CamlinternalFormatBasics.No_padding
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "known by the node)"
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                    CamlinternalFormatBasics.Flush_newline
                                                                                    CamlinternalFormatBasics.End_of_format))))))))
                                                                    "* %a %ld (%sknown by the node)@."
                                                                      % string)
                                                                  Tezos_base__TzPervasives.Protocol_hash.pp
                                                                  p w
                                                                  (if
                                                                    Tezos_base__TzPervasives.List.mem
                                                                      p
                                                                      known_protos
                                                                    then
                                                                    "" % string
                                                                  else
                                                                    "not " %
                                                                      string)
                                                              end) ranks;
                                                          Stdlib.Format.pp_close_box
                                                            ppf tt))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.return_unit
                                                        end)
                                                  |
                                                    Testing_vote |
                                                      Promotion_vote =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (print_proposal
                                                        (current_proposal info))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                            (Tezos_client_alpha.Client_proto_context.get_ballots_info
                                                              cctxt send send)
                                                            (fun ballots_info =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (send
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "Ballots: "
                                                                        % string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          (CamlinternalFormatBasics.Break
                                                                            "@,"
                                                                              %
                                                                              string
                                                                            0 0)
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "Current participation "
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Float
                                                                              CamlinternalFormatBasics.Float_f
                                                                              CamlinternalFormatBasics.No_padding
                                                                              (CamlinternalFormatBasics.Lit_precision
                                                                                2)
                                                                              (CamlinternalFormatBasics.Char_literal
                                                                                "%"
                                                                                  %
                                                                                  char
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  ", necessary quorum "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Float
                                                                                    CamlinternalFormatBasics.Float_f
                                                                                    CamlinternalFormatBasics.No_padding
                                                                                    (CamlinternalFormatBasics.Lit_precision
                                                                                      2)
                                                                                    (CamlinternalFormatBasics.Char_literal
                                                                                      "%"
                                                                                        %
                                                                                        char
                                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                                        (CamlinternalFormatBasics.Break
                                                                                          "@,"
                                                                                            %
                                                                                            string
                                                                                          0
                                                                                          0)
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          "Current in favor "
                                                                                            %
                                                                                            string
                                                                                          (CamlinternalFormatBasics.Int32
                                                                                            CamlinternalFormatBasics.Int_d
                                                                                            CamlinternalFormatBasics.No_padding
                                                                                            CamlinternalFormatBasics.No_precision
                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                              ", needed supermajority "
                                                                                                %
                                                                                                string
                                                                                              (CamlinternalFormatBasics.Int32
                                                                                                CamlinternalFormatBasics.Int_d
                                                                                                CamlinternalFormatBasics.No_padding
                                                                                                CamlinternalFormatBasics.No_precision
                                                                                                CamlinternalFormatBasics.End_of_format))))))))))))))
                                                                    "Ballots: %a@,Current participation %.2f%%, necessary quorum %.2f%%@,Current in favor %ld, needed supermajority %ld"
                                                                      % string)
                                                                  Tezos_base__TzPervasives.Data_encoding.Json.pp
                                                                  (Tezos_base__TzPervasives.Data_encoding.Json.construct
                                                                    Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots_encoding
                                                                    (ballots
                                                                      ballots_info))
                                                                  (Stdlib.op_div_point
                                                                    (Stdlib.Int32.to_float
                                                                      (participation
                                                                        ballots_info))
                                                                    100)
                                                                  (Stdlib.op_div_point
                                                                    (Stdlib.Int32.to_float
                                                                      (current_quorum
                                                                        ballots_info))
                                                                    100)
                                                                  (yay
                                                                    (ballots
                                                                      ballots_info))
                                                                  (supermajority
                                                                    ballots_info))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_base__TzPervasives.return_unit
                                                                  end))
                                                        end)
                                                  | Testing =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (print_proposal
                                                        (current_proposal info))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_base__TzPervasives.return_unit
                                                        end)
                                                  end))
                                        end))
                            end)) [])))))))))
  end.
src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Client_proto_contracts

let group =
  {
    Clic.name = "contracts";
    title = "Commands for managing the record of known contracts";
  }

let commands () =
  let open Clic in
  [ command
      ~group
      ~desc:"Add a contract to the wallet."
      (args1 (RawContractAlias.force_switch ()))
      ( prefixes ["remember"; "contract"]
      @@ RawContractAlias.fresh_alias_param @@ RawContractAlias.source_param
      @@ stop )
      (fun force name hash cctxt ->
        RawContractAlias.of_fresh cctxt force name
        >>=? fun name -> RawContractAlias.add ~force cctxt name hash);
    command
      ~group
      ~desc:"Remove a contract from the wallet."
      no_options
      (prefixes ["forget"; "contract"] @@ RawContractAlias.alias_param @@ stop)
      (fun () (name, _) cctxt -> RawContractAlias.del cctxt name);
    command
      ~group
      ~desc:"Lists all known contracts in the wallet."
      no_options
      (fixed ["list"; "known"; "contracts"])
      (fun () (cctxt : Protocol_client_context.full) ->
        list_contracts cctxt
        >>=? fun contracts ->
        iter_s
          (fun (prefix, alias, contract) ->
            cctxt#message
              "%s%s: %s"
              prefix
              alias
              (Contract.to_b58check contract)
            >>= return)
          contracts);
    command
      ~group
      ~desc:"Forget the entire wallet of known contracts."
      (args1 (RawContractAlias.force_switch ()))
      (fixed ["forget"; "all"; "contracts"])
      (fun force cctxt ->
        fail_unless force (failure "this can only used with option -force")
        >>=? fun () -> RawContractAlias.set cctxt []);
    command
      ~group
      ~desc:"Display a contract from the wallet."
      no_options
      ( prefixes ["show"; "known"; "contract"]
      @@ RawContractAlias.alias_param @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        cctxt#message "%a\n%!" Contract.pp contract >>= fun () -> return_unit)
  ]
src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_client_alpha.Client_proto_contracts.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "contracts" % string;
    Clic.title := "Commands for managing the record of known contracts" % string
    |}.

Definition commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  match function_parameter with
  | tt =>
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Add a contract to the wallet." % string
        (Tezos_base__TzPervasives.Clic.args1
          (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.force_switch
            tt))
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "remember" % string (cons "contract" % string [])))
          (apply
            (let arg :=
              Tezos_client_alpha.Client_proto_contracts.RawContractAlias.fresh_alias_param
              in
            fun eta => arg None None eta)
            (apply
              (let arg :=
                Tezos_client_alpha.Client_proto_contracts.RawContractAlias.source_param
                in
              fun eta => arg None None eta) Tezos_base__TzPervasives.Clic.stop)))
        (fun force =>
          fun name =>
            fun hash =>
              fun cctxt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.of_fresh
                    cctxt force name)
                  (fun name =>
                    Tezos_client_alpha.Client_proto_contracts.RawContractAlias.add
                      force cctxt name hash)))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Remove a contract from the wallet." % string
          Tezos_base__TzPervasives.Clic.no_options
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "forget" % string (cons "contract" % string [])))
            (apply
              (let arg :=
                Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                in
              fun eta => arg None None eta) Tezos_base__TzPervasives.Clic.stop))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (name, _) =>
                  fun cctxt =>
                    Tezos_client_alpha.Client_proto_contracts.RawContractAlias.del
                      cctxt name
                end
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Lists all known contracts in the wallet." % string
            Tezos_base__TzPervasives.Clic.no_options
            (Tezos_base__TzPervasives.Clic.fixed
              (cons "list" % string
                (cons "known" % string (cons "contracts" % string []))))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_client_alpha.Client_proto_contracts.list_contracts
                      cctxt)
                    (fun contracts =>
                      Tezos_base__TzPervasives.iter_s
                        (fun function_parameter =>
                          match function_parameter with
                          | (prefix, alias, contract) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.String_literal
                                        ": " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))))
                                  "%s%s: %s" % string) prefix alias
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.to_b58check
                                  contract)) Tezos_base__TzPervasives._return
                          end) contracts)
              end))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Forget the entire wallet of known contracts." % string
              (Tezos_base__TzPervasives.Clic.args1
                (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.force_switch
                  tt))
              (Tezos_base__TzPervasives.Clic.fixed
                (cons "forget" % string
                  (cons "all" % string (cons "contracts" % string []))))
              (fun force =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_base__TzPervasives.fail_unless force
                      (Tezos_base__TzPervasives.failure
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "this can only used with option -force" % string
                            CamlinternalFormatBasics.End_of_format)
                          "this can only used with option -force" % string)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_client_alpha.Client_proto_contracts.RawContractAlias.set
                          cctxt []
                      end)))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Display a contract from the wallet." % string
                Tezos_base__TzPervasives.Clic.no_options
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "show" % string
                      (cons "known" % string (cons "contract" % string []))))
                  (apply
                    (let arg :=
                      Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                      in
                    fun eta => arg None None eta)
                    Tezos_base__TzPervasives.Clic.stop))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    fun function_parameter =>
                      match function_parameter with
                      | (_, contract) =>
                        fun cctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    "010" % char
                                    (CamlinternalFormatBasics.Flush
                                      CamlinternalFormatBasics.End_of_format)))
                                "%a
%!" % string)
                              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp
                              contract)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                      end
                  end)) []))))
  end.
src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

let group =
  {
    Clic.name = "multisig";
    title = "Commands for managing a multisig smart contract";
  }

let threshold_param () =
  Clic.param
    ~name:"threshold"
    ~desc:"Number of required signatures"
    Client_proto_args.int_parameter

let public_key_param () =
  Client_keys.Public_key.source_param
    ~name:"key"
    ~desc:"Each signer of the multisig contract"

let secret_key_param () =
  Client_keys.Secret_key.source_param
    ~name:"key"
    ~desc:
      "Secret key corresponding to one of the public keys stored on the \
       multisig contract"

let signature_param () =
  Clic.param
    ~name:"signature"
    ~desc:"Each signer of the multisig contract"
    Client_proto_args.signature_parameter

let bytes_only_switch =
  Clic.switch
    ~long:"bytes-only"
    ~doc:"return only the byte sequence to be signed"
    ()

let bytes_param ~name ~desc =
  Clic.param ~name ~desc Client_proto_args.bytes_parameter

let transfer_options =
  Clic.args12
    Client_proto_args.fee_arg
    Client_proto_context_commands.dry_run_switch
    Client_proto_args.gas_limit_arg
    Client_proto_args.storage_limit_arg
    Client_proto_args.counter_arg
    Client_proto_args.no_print_source_flag
    Client_proto_args.minimal_fees_arg
    Client_proto_args.minimal_nanotez_per_byte_arg
    Client_proto_args.minimal_nanotez_per_gas_unit_arg
    Client_proto_args.force_low_fee_arg
    Client_proto_args.fee_cap_arg
    Client_proto_args.burn_cap_arg

let commands () : #Protocol_client_context.full Clic.command list =
  Clic.
    [ command
        ~group
        ~desc:"Originate a new multisig contract."
        (args13
           Client_proto_args.fee_arg
           Client_proto_context_commands.dry_run_switch
           Client_proto_args.gas_limit_arg
           Client_proto_args.storage_limit_arg
           Client_proto_args.delegate_arg
           (Client_keys.force_switch ())
           Client_proto_args.no_print_source_flag
           Client_proto_args.minimal_fees_arg
           Client_proto_args.minimal_nanotez_per_byte_arg
           Client_proto_args.minimal_nanotez_per_gas_unit_arg
           Client_proto_args.force_low_fee_arg
           Client_proto_args.fee_cap_arg
           Client_proto_args.burn_cap_arg)
        ( prefixes ["deploy"; "multisig"]
        @@ Client_proto_contracts.RawContractAlias.fresh_alias_param
             ~name:"new_multisig"
             ~desc:"name of the new multisig contract"
        @@ prefix "transferring"
        @@ Client_proto_args.tez_param
             ~name:"qty"
             ~desc:"amount taken from source"
        @@ prefix "from"
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"name of the source contract"
        @@ prefixes ["with"; "threshold"]
        @@ threshold_param ()
        @@ prefixes ["on"; "public"; "keys"]
        @@ seq_of_param (public_key_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               delegate,
               force,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             alias_name
             balance
             (_, source)
             threshold
             keys
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_contracts.RawContractAlias.of_fresh
            cctxt
            force
            alias_name
          >>=? fun alias_name ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of an origination"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys
              >>=? fun keys ->
              Client_proto_multisig.originate_multisig
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ?fee
                ?gas_limit
                ?storage_limit
                ~delegate
                ~threshold:(Z.of_int threshold)
                ~keys
                ~balance
                ~source
                ~src_pk
                ~src_sk
                ~fee_parameter
                ()
              >>= fun errors ->
              Client_proto_context_commands.report_michelson_errors
                ~no_print_source
                ~msg:"multisig origination simulation failed"
                cctxt
                errors
              >>= function
              | None ->
                  return_unit
              | Some (_res, contract) ->
                  if dry_run then return_unit
                  else
                    Client_proto_context.save_contract
                      ~force
                      cctxt
                      alias_name
                      contract
                    >>=? fun () -> return_unit ));
      command
        ~group
        ~desc:
          "Display the threshold, public keys, and byte sequence to sign for \
           a multisigned transfer."
        (args1 bytes_only_switch)
        ( prefixes ["prepare"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefix "transferring"
        @@ Client_proto_args.tez_param
             ~name:"qty"
             ~desc:"amount taken from source"
        @@ prefix "to"
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"dst"
             ~desc:"name/literal of the destination contract"
        @@ stop )
        (fun bytes_only
             (_, multisig_contract)
             amount
             (_, destination)
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Transfer (amount, destination))
            ()
          >>=? fun prepared_command ->
          return
          @@
          if bytes_only then
            Format.printf
              "0x%a@."
              Hex.pp
              (Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
          else
            Format.printf
              "%a@.%a@.%a@."
              (fun ppf x ->
                Format.fprintf
                  ppf
                  "Bytes to sign: '0x%a'"
                  Hex.pp
                  (Hex.of_bytes x))
              prepared_command.Client_proto_multisig.bytes
              (fun ppf z ->
                Format.fprintf
                  ppf
                  "Threshold (number of signatures required): %s"
                  (Z.to_string z))
              prepared_command.Client_proto_multisig.threshold
              (fun ppf ->
                Format.fprintf
                  ppf
                  "@[<2>Public keys of the signers:@ %a@]"
                  (Format.pp_print_list
                     ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
                     Signature.Public_key.pp))
              prepared_command.Client_proto_multisig.keys);
      command
        ~group
        ~desc:
          "Display the threshold, public keys, and byte sequence to sign for \
           a multisigned delegate change."
        (args1 bytes_only_switch)
        ( prefixes ["prepare"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["setting"; "delegate"; "to"]
        @@ Client_keys.Public_key_hash.source_param
             ~name:"dlgt"
             ~desc:"new delegate of the new multisig contract"
        @@ stop )
        (fun bytes_only
             (_, multisig_contract)
             new_delegate
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Change_delegate (Some new_delegate))
            ()
          >>=? fun prepared_command ->
          return
          @@
          if bytes_only then
            Format.printf
              "0x%a@."
              Hex.pp
              (Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
          else
            Format.printf
              "%a@.%a@.%a@."
              (fun ppf x ->
                Format.fprintf
                  ppf
                  "Bytes to sign: '0x%a'"
                  Hex.pp
                  (Hex.of_bytes x))
              prepared_command.Client_proto_multisig.bytes
              (fun ppf z ->
                Format.fprintf
                  ppf
                  "Threshold (number of signatures required): %s"
                  (Z.to_string z))
              prepared_command.Client_proto_multisig.threshold
              (fun ppf ->
                Format.fprintf
                  ppf
                  "@[<2>Public keys of the signers:@ %a@]"
                  (Format.pp_print_list
                     ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
                     Signature.Public_key.pp))
              prepared_command.Client_proto_multisig.keys);
      command
        ~group
        ~desc:
          "Display the threshold, public keys, and byte sequence to sign for \
           a multisigned delegate withdraw."
        (args1 bytes_only_switch)
        ( prefixes ["prepare"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["withdrawing"; "delegate"]
        @@ stop )
        (fun bytes_only
             (_, multisig_contract)
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Change_delegate None)
            ()
          >>=? fun prepared_command ->
          return
          @@
          if bytes_only then
            Format.printf
              "0x%a@."
              Hex.pp
              (Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
          else
            Format.printf
              "%a@.%a@.%a@."
              (fun ppf x ->
                Format.fprintf
                  ppf
                  "Bytes to sign: '0x%a'"
                  Hex.pp
                  (Hex.of_bytes x))
              prepared_command.Client_proto_multisig.bytes
              (fun ppf z ->
                Format.fprintf
                  ppf
                  "Threshold (number of signatures required): %s"
                  (Z.to_string z))
              prepared_command.Client_proto_multisig.threshold
              (fun ppf ->
                Format.fprintf
                  ppf
                  "@[<2>Public keys of the signers:@ %a@]"
                  (Format.pp_print_list
                     ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
                     Signature.Public_key.pp))
              prepared_command.Client_proto_multisig.keys);
      command
        ~group
        ~desc:
          "Display the threshold, public keys, and byte sequence to sign for \
           a multisigned change of keys and threshold."
        (args1 bytes_only_switch)
        ( prefixes ["prepare"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["setting"; "threshold"; "to"]
        @@ threshold_param ()
        @@ prefixes ["and"; "public"; "keys"; "to"]
        @@ seq_of_param (public_key_param ()) )
        (fun bytes_only
             (_, multisig_contract)
             new_threshold
             new_keys
             (cctxt : #Protocol_client_context.full) ->
          map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys
          >>=? fun keys ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:
              (Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys))
            ()
          >>=? fun prepared_command ->
          return
          @@
          if bytes_only then
            Format.printf
              "0x%a@."
              Hex.pp
              (Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
          else
            Format.printf
              "%a@.%a@.%a@."
              (fun ppf x ->
                Format.fprintf
                  ppf
                  "Bytes to sign: '0x%a'"
                  Hex.pp
                  (Hex.of_bytes x))
              prepared_command.Client_proto_multisig.bytes
              (fun ppf z ->
                Format.fprintf
                  ppf
                  "Threshold (number of signatures required): %s"
                  (Z.to_string z))
              prepared_command.Client_proto_multisig.threshold
              (fun ppf ->
                Format.fprintf
                  ppf
                  "@[<2>Public keys of the signers:@ %a@]"
                  (Format.pp_print_list
                     ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
                     Signature.Public_key.pp))
              prepared_command.Client_proto_multisig.keys);
      command
        ~group
        ~desc:"Sign a transaction for a multisig contract."
        no_options
        ( prefixes ["sign"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefix "transferring"
        @@ Client_proto_args.tez_param
             ~name:"qty"
             ~desc:"amount taken from source"
        @@ prefix "to"
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"dst"
             ~desc:"name/literal of the destination contract"
        @@ prefixes ["using"; "secret"; "key"]
        @@ secret_key_param () @@ stop )
        (fun ()
             (_, multisig_contract)
             amount
             (_, destination)
             sk
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Transfer (amount, destination))
            ()
          >>=? fun prepared_command ->
          Client_keys.sign cctxt sk prepared_command.bytes
          >>=? fun signature ->
          return @@ Format.printf "%a@." Signature.pp signature);
      command
        ~group
        ~desc:"Sign a delegate change for a multisig contract."
        no_options
        ( prefixes ["sign"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["setting"; "delegate"; "to"]
        @@ Client_keys.Public_key_hash.source_param
             ~name:"dlgt"
             ~desc:"new delegate of the new multisig contract"
        @@ prefixes ["using"; "secret"; "key"]
        @@ secret_key_param () @@ stop )
        (fun ()
             (_, multisig_contract)
             delegate
             sk
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Change_delegate (Some delegate))
            ()
          >>=? fun prepared_command ->
          Client_keys.sign cctxt sk prepared_command.bytes
          >>=? fun signature ->
          return @@ Format.printf "%a@." Signature.pp signature);
      command
        ~group
        ~desc:"Sign a delegate withdraw for a multisig contract."
        no_options
        ( prefixes ["sign"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["withdrawing"; "delegate"]
        @@ prefixes ["using"; "secret"; "key"]
        @@ secret_key_param () @@ stop )
        (fun ()
             (_, multisig_contract)
             sk
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Change_delegate None)
            ()
          >>=? fun prepared_command ->
          Client_keys.sign cctxt sk prepared_command.bytes
          >>=? fun signature ->
          return @@ Format.printf "%a@." Signature.pp signature);
      command
        ~group
        ~desc:
          "Sign a change of public keys and threshold for a multisig contract."
        no_options
        ( prefixes ["sign"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["using"; "secret"; "key"]
        @@ secret_key_param ()
        @@ prefixes ["setting"; "threshold"; "to"]
        @@ threshold_param ()
        @@ prefixes ["and"; "public"; "keys"; "to"]
        @@ seq_of_param (public_key_param ()) )
        (fun ()
             (_, multisig_contract)
             sk
             new_threshold
             new_keys
             (cctxt : #Protocol_client_context.full) ->
          map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys
          >>=? fun keys ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:
              (Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys))
            ()
          >>=? fun prepared_command ->
          Client_keys.sign cctxt sk prepared_command.bytes
          >>=? fun signature ->
          return @@ Format.printf "%a@." Signature.pp signature);
      command
        ~group
        ~desc:"Transfer tokens using a multisig contract."
        transfer_options
        ( prefixes ["from"; "multisig"; "contract"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"multisig"
             ~desc:"name/literal of the multisig contract"
        @@ prefix "transfer"
        @@ Client_proto_args.tez_param
             ~name:"qty"
             ~desc:"amount taken from the multisig contract"
        @@ prefix "to"
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"dst"
             ~desc:"name/literal of the destination contract"
        @@ prefixes ["on"; "behalf"; "of"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"source calling the multisig contract"
        @@ prefixes ["with"; "signatures"]
        @@ seq_of_param (signature_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               counter,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             (_, multisig_contract)
             amount
             (_, destination)
             (_, source)
             signatures
             (cctxt : #Protocol_client_context.full) ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of a contract call"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              Client_proto_multisig.call_multisig
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ~fee_parameter
                ~source
                ?fee
                ~src_pk
                ~src_sk
                ~multisig_contract
                ~action:(Client_proto_multisig.Transfer (amount, destination))
                ~signatures
                ~amount:Tez.zero
                ?gas_limit
                ?storage_limit
                ?counter
                ()
              >>= Client_proto_context_commands.report_michelson_errors
                    ~no_print_source
                    ~msg:"transfer simulation failed"
                    cctxt
              >>= function
              | None -> return_unit | Some (_res, _contracts) -> return_unit ));
      command
        ~group
        ~desc:"Change the delegate of a multisig contract."
        transfer_options
        ( prefixes ["set"; "delegate"; "of"; "multisig"; "contract"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefix "to"
        @@ Client_keys.Public_key_hash.source_param
             ~name:"dlgt"
             ~desc:"new delegate of the new multisig contract"
        @@ prefixes ["on"; "behalf"; "of"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"source calling the multisig contract"
        @@ prefixes ["with"; "signatures"]
        @@ seq_of_param (signature_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               counter,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             (_, multisig_contract)
             delegate
             (_, source)
             signatures
             (cctxt : #Protocol_client_context.full) ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of a contract call"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              Client_proto_multisig.call_multisig
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ~fee_parameter
                ~source
                ?fee
                ~src_pk
                ~src_sk
                ~multisig_contract
                ~action:(Client_proto_multisig.Change_delegate (Some delegate))
                ~signatures
                ~amount:Tez.zero
                ?gas_limit
                ?storage_limit
                ?counter
                ()
              >>= Client_proto_context_commands.report_michelson_errors
                    ~no_print_source
                    ~msg:"transfer simulation failed"
                    cctxt
              >>= function
              | None -> return_unit | Some (_res, _contracts) -> return_unit ));
      command
        ~group
        ~desc:"Withdrow the delegate of a multisig contract."
        transfer_options
        ( prefixes ["withdraw"; "delegate"; "of"; "multisig"; "contract"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["on"; "behalf"; "of"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"source calling the multisig contract"
        @@ prefixes ["with"; "signatures"]
        @@ seq_of_param (signature_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               counter,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             (_, multisig_contract)
             (_, source)
             signatures
             (cctxt : #Protocol_client_context.full) ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of a contract call"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              Client_proto_multisig.call_multisig
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ~fee_parameter
                ~source
                ?fee
                ~src_pk
                ~src_sk
                ~multisig_contract
                ~action:(Client_proto_multisig.Change_delegate None)
                ~signatures
                ~amount:Tez.zero
                ?gas_limit
                ?storage_limit
                ?counter
                ()
              >>= Client_proto_context_commands.report_michelson_errors
                    ~no_print_source
                    ~msg:"transfer simulation failed"
                    cctxt
              >>= function
              | None -> return_unit | Some (_res, _contracts) -> return_unit ));
      (* Unfortunately, Clic does not support non terminal lists of
       parameters so we cannot pass both a list of public keys and a
       list of signatures on the command line. This would permit a
       command for running the Change_keys action.

       However, we can run any action by deserialising the sequence of
       bytes built using the "prepare multisig transaction" commands *)
      command
        ~group
        ~desc:
          "Run a transaction described by a sequence of bytes on a multisig \
           contract."
        transfer_options
        ( prefixes ["run"; "transaction"]
        @@ bytes_param
             ~name:"bytes"
             ~desc:
               "the sequence of bytes to deserialize as a multisig action, \
                can be obtained by one of the \"prepare multisig \
                transaction\" commands"
        @@ prefixes ["on"; "multisig"; "contract"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["on"; "behalf"; "of"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"source calling the multisig contract"
        @@ prefixes ["with"; "signatures"]
        @@ seq_of_param (signature_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               counter,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             bytes
             (_, multisig_contract)
             (_, source)
             signatures
             (cctxt : #Protocol_client_context.full) ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of a contract call"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              Client_proto_multisig.call_multisig_on_bytes
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ~fee_parameter
                ~source
                ?fee
                ~src_pk
                ~src_sk
                ~multisig_contract
                ~bytes
                ~signatures
                ~amount:Tez.zero
                ?gas_limit
                ?storage_limit
                ?counter
                ()
              >>= Client_proto_context_commands.report_michelson_errors
                    ~no_print_source
                    ~msg:"transfer simulation failed"
                    cctxt
              >>= function
              | None -> return_unit | Some (_res, _contracts) -> return_unit ));
      command
        ~group
        ~desc:"Show the hashes of the supported multisig contracts."
        no_options
        (fixed ["show"; "supported"; "multisig"; "hashes"])
        (fun () _cctxt ->
          Lwt.return Client_proto_multisig.known_multisig_hashes
          >>=? fun l ->
          Format.printf "Hashes of supported multisig contracts:@." ;
          List.iter
            (fun h ->
              Format.printf
                "  0x%a@."
                Hex.pp
                (Script_expr_hash.to_bytes h |> Hex.of_bytes))
            l ;
          return_unit) ]
src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "multisig" % string;
    Clic.title := "Commands for managing a multisig smart contract" % string |}.

Definition threshold_param {A : Type} (function_parameter : unit)
  : (Tezos_base__TzPervasives.Clic.params A
    Tezos_client_alpha.Protocol_client_context.full) ->
    Tezos_base__TzPervasives.Clic.params (Z -> A)
      Tezos_client_alpha.Protocol_client_context.full :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.param "threshold" % string
      "Number of required signatures" % string
      Tezos_client_alpha.Client_proto_args.int_parameter
  end.

Definition public_key_param {A C a : Type} (function_parameter : unit)
  : (Tezos_base__TzPervasives.Clic.params A
    (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
      * C)) ->
    Tezos_base__TzPervasives.Clic.params
      (Tezos_client_base.Client_keys.Public_key.t -> A)
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
        * C) :=
  match function_parameter with
  | tt =>
    Tezos_client_base.Client_keys.Public_key.source_param (Some "key" % string)
      (Some "Each signer of the multisig contract" % string)
  end.

Definition secret_key_param {A C a : Type} (function_parameter : unit)
  : (Tezos_base__TzPervasives.Clic.params A
    (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
      * C)) ->
    Tezos_base__TzPervasives.Clic.params
      (Tezos_client_base.Client_keys.Secret_key.t -> A)
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
        * C) :=
  match function_parameter with
  | tt =>
    Tezos_client_base.Client_keys.Secret_key.source_param (Some "key" % string)
      (Some
        "Secret key corresponding to one of the public keys stored on the multisig contract"
          % string)
  end.

Definition signature_param {A : Type} (function_parameter : unit)
  : (Tezos_base__TzPervasives.Clic.params A
    Tezos_client_alpha.Protocol_client_context.full) ->
    Tezos_base__TzPervasives.Clic.params
      (Tezos_base__TzPervasives.Signature.t -> A)
      Tezos_client_alpha.Protocol_client_context.full :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.Clic.param "signature" % string
      "Each signer of the multisig contract" % string
      Tezos_client_alpha.Client_proto_args.signature_parameter
  end.

Definition bytes_only_switch
  : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.switch
    "return only the byte sequence to be signed" % string None
    "bytes-only" % string tt.

Definition bytes_param {A : Type} (name : string) (desc : string)
  : (Tezos_base__TzPervasives.Clic.params A
    Tezos_client_alpha.Protocol_client_context.full) ->
    Tezos_base__TzPervasives.Clic.params (Stdlib.Bytes.t -> A)
      Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.param name desc
    Tezos_client_alpha.Client_proto_args.bytes_parameter.

Definition transfer_options
  : Tezos_base__TzPervasives.Clic.options
    ((option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) * bool *
      (option Z.t) * (option Z.t) * (option Z.t) * bool *
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t * Z.t * bool *
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t *
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.args12
    Tezos_client_alpha.Client_proto_args.fee_arg
    Tezos_client_alpha_commands.Client_proto_context_commands.dry_run_switch
    Tezos_client_alpha.Client_proto_args.gas_limit_arg
    Tezos_client_alpha.Client_proto_args.storage_limit_arg
    Tezos_client_alpha.Client_proto_args.counter_arg
    Tezos_client_alpha.Client_proto_args.no_print_source_flag
    Tezos_client_alpha.Client_proto_args.minimal_fees_arg
    Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
    Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
    Tezos_client_alpha.Client_proto_args.force_low_fee_arg
    Tezos_client_alpha.Client_proto_args.fee_cap_arg
    Tezos_client_alpha.Client_proto_args.burn_cap_arg.

Definition commands {D F H J L M a b c i o p q : Type}
  (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  a ->
                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                      a) ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult a)) *
                                  (a)) *
                                  ((option (Lwt_stream.t string)) *
                                    (((string ->
                                      (Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                        ((unit -> Ptime.t) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                Bigstring.t)) -> a) * (a)) *
                                              ((string ->
                                                Lwt.t
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) *
                                                ((float -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) *
                                                    ((((unit -> Lwt.t a) ->
                                                      Lwt.t a) * (a)) *
                                                      (((string ->
                                                        a ->
                                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                                            a) ->
                                                            Lwt.t
                                                              (Tezos_base__TzPervasives.tzresult
                                                                unit)) * (a)) *
                                                        nil)))))))))))))))))))))))))
        * nil)) :=
  match function_parameter with
  | tt =>
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Originate a new multisig contract." % string
        (Tezos_base__TzPervasives.Clic.args13
          Tezos_client_alpha.Client_proto_args.fee_arg
          Tezos_client_alpha_commands.Client_proto_context_commands.dry_run_switch
          Tezos_client_alpha.Client_proto_args.gas_limit_arg
          Tezos_client_alpha.Client_proto_args.storage_limit_arg
          Tezos_client_alpha.Client_proto_args.delegate_arg
          (Tezos_client_base.Client_keys.force_switch tt)
          Tezos_client_alpha.Client_proto_args.no_print_source_flag
          Tezos_client_alpha.Client_proto_args.minimal_fees_arg
          Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
          Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
          Tezos_client_alpha.Client_proto_args.force_low_fee_arg
          Tezos_client_alpha.Client_proto_args.fee_cap_arg
          Tezos_client_alpha.Client_proto_args.burn_cap_arg)
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "deploy" % string (cons "multisig" % string [])))
          (apply
            (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.fresh_alias_param
              (Some "new_multisig" % string)
              (Some "name of the new multisig contract" % string))
            (apply
              (Tezos_base__TzPervasives.Clic.prefix "transferring" % string)
              (apply
                (Tezos_client_alpha.Client_proto_args.tez_param "qty" % string
                  "amount taken from source" % string)
                (apply (Tezos_base__TzPervasives.Clic.prefix "from" % string)
                  (apply
                    (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                      (Some "src" % string)
                      (Some "name of the source contract" % string))
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "with" % string (cons "threshold" % string [])))
                      (apply (threshold_param tt)
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "on" % string
                              (cons "public" % string (cons "keys" % string []))))
                          (Tezos_base__TzPervasives.Clic.seq_of_param
                            (public_key_param tt)))))))))))
        (fun function_parameter =>
          match function_parameter with
          |
            (fee, dry_run, gas_limit, storage_limit, delegate, force,
              no_print_source, minimal_fees, minimal_nanotez_per_byte,
              minimal_nanotez_per_gas_unit, force_low_fee, fee_cap, burn_cap) =>
            fun alias_name =>
              fun balance =>
                fun function_parameter =>
                  match function_parameter with
                  | (_, source) =>
                    fun threshold =>
                      fun keys =>
                        fun cctxt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.of_fresh
                              cctxt force alias_name)
                            (fun alias_name =>
                              match
                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                  source with
                              | None =>
                                Tezos_base__TzPervasives.failwith
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "only implicit accounts can be the source of an origination"
                                        % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "only implicit accounts can be the source of an origination"
                                      % string)
                              | Some source =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_client_base.Client_keys.get_key cctxt
                                    source)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (_, src_pk, src_sk) =>
                                      let fee_parameter :=
                                        {|
                                          Injection.minimal_fees := minimal_fees;
                                          Injection.minimal_nanotez_per_byte :=
                                            minimal_nanotez_per_byte;
                                          Injection.minimal_nanotez_per_gas_unit :=
                                            minimal_nanotez_per_gas_unit;
                                          Injection.force_low_fee :=
                                            force_low_fee;
                                          Injection.fee_cap := fee_cap;
                                          Injection.burn_cap := burn_cap |} in
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_base__TzPervasives.map_s
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (pk_uri, _) =>
                                              Tezos_client_base.Client_keys.public_key
                                                pk_uri
                                            end) keys)
                                        (fun keys =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Tezos_client_alpha.Client_proto_multisig.originate_multisig
                                              cctxt send send send
                                              (Some dry_run) None fee gas_limit
                                              storage_limit delegate
                                              (Z.of_int threshold) keys balance
                                              source src_pk src_sk fee_parameter
                                              tt)
                                            (fun errors =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (Tezos_client_alpha_commands.Client_proto_context_commands.report_michelson_errors
                                                  (Some no_print_source)
                                                  "multisig origination simulation failed"
                                                    % string cctxt errors)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | None =>
                                                    Tezos_base__TzPervasives.return_unit
                                                  | Some (_res, contract) =>
                                                    if dry_run then
                                                      Tezos_base__TzPervasives.return_unit
                                                    else
                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                        (Tezos_client_alpha.Client_proto_context.save_contract
                                                          force cctxt alias_name
                                                          contract)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)
                                                  end)))
                                    end)
                              end)
                  end
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Display the threshold, public keys, and byte sequence to sign for a multisigned transfer."
            % string (Tezos_base__TzPervasives.Clic.args1 bytes_only_switch)
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "prepare" % string
                (cons "multisig" % string
                  (cons "transaction" % string (cons "on" % string [])))))
            (apply
              (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                (Some "multisig" % string)
                (Some "name of the originated multisig contract" % string))
              (apply
                (Tezos_base__TzPervasives.Clic.prefix "transferring" % string)
                (apply
                  (Tezos_client_alpha.Client_proto_args.tez_param "qty" % string
                    "amount taken from source" % string)
                  (apply (Tezos_base__TzPervasives.Clic.prefix "to" % string)
                    (apply
                      (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                        (Some "dst" % string)
                        (Some
                          "name/literal of the destination contract" % string))
                      Tezos_base__TzPervasives.Clic.stop))))))
          (fun bytes_only =>
            fun function_parameter =>
              match function_parameter with
              | (_, multisig_contract) =>
                fun amount =>
                  fun function_parameter =>
                    match function_parameter with
                    | (_, destination) =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_alpha.Client_proto_multisig.prepare_multisig_transaction
                            cctxt send send multisig_contract
                            (Client_proto_multisig.Transfer amount destination)
                            tt)
                          (fun prepared_command =>
                            apply Tezos_base__TzPervasives._return
                              (if bytes_only then
                                Stdlib.Format.printf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "0x" % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Flush_newline
                                          CamlinternalFormatBasics.End_of_format)))
                                    "0x%a@." % string) Hex.pp
                                  (Hex.of_bytes None
                                    (Client_proto_multisig.bytes
                                      prepared_command))
                              else
                                Stdlib.Format.printf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Flush_newline
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Flush_newline
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Flush_newline
                                                CamlinternalFormatBasics.End_of_format))))))
                                    "%a@.%a@.%a@." % string)
                                  (fun ppf =>
                                    fun x =>
                                      Stdlib.Format.fprintf ppf
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Bytes to sign: '0x" % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                "'" % char
                                                CamlinternalFormatBasics.End_of_format)))
                                          "Bytes to sign: '0x%a'" % string)
                                        Hex.pp (Hex.of_bytes None x))
                                  (Client_proto_multisig.bytes prepared_command)
                                  (fun ppf =>
                                    fun z =>
                                      Stdlib.Format.fprintf ppf
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Threshold (number of signatures required): "
                                              % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              CamlinternalFormatBasics.End_of_format))
                                          "Threshold (number of signatures required): %s"
                                            % string) (Z.to_string z))
                                  (Client_proto_multisig.threshold
                                    prepared_command)
                                  (fun ppf =>
                                    Stdlib.Format.fprintf ppf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.Formatting_gen
                                          (CamlinternalFormatBasics.Open_box
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "<2>" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "<2>" % string))
                                          (CamlinternalFormatBasics.String_literal
                                            "Public keys of the signers:" %
                                              string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_box
                                                  CamlinternalFormatBasics.End_of_format)))))
                                        "@[<2>Public keys of the signers:@ %a@]"
                                          % string)
                                      (Stdlib.Format.pp_print_list
                                        (Some
                                          (fun ppf =>
                                            fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Stdlib.Format.fprintf ppf
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@ " % string 1 0)
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "@ " % string)
                                              end))
                                        Tezos_base__TzPervasives.Signature.Public_key.pp))
                                  (Client_proto_multisig.keys prepared_command)))
                    end
              end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Display the threshold, public keys, and byte sequence to sign for a multisigned delegate change."
              % string (Tezos_base__TzPervasives.Clic.args1 bytes_only_switch)
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "prepare" % string
                  (cons "multisig" % string
                    (cons "transaction" % string (cons "on" % string [])))))
              (apply
                (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                  (Some "multisig" % string)
                  (Some "name of the originated multisig contract" % string))
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "setting" % string
                      (cons "delegate" % string (cons "to" % string []))))
                  (apply
                    (Tezos_client_base.Client_keys.Public_key_hash.source_param
                      (Some "dlgt" % string)
                      (Some "new delegate of the new multisig contract" % string))
                    Tezos_base__TzPervasives.Clic.stop))))
            (fun bytes_only =>
              fun function_parameter =>
                match function_parameter with
                | (_, multisig_contract) =>
                  fun new_delegate =>
                    fun cctxt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_client_alpha.Client_proto_multisig.prepare_multisig_transaction
                          cctxt send send multisig_contract
                          (Client_proto_multisig.Change_delegate
                            (Some new_delegate)) tt)
                        (fun prepared_command =>
                          apply Tezos_base__TzPervasives._return
                            (if bytes_only then
                              Stdlib.Format.printf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "0x" % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Flush_newline
                                        CamlinternalFormatBasics.End_of_format)))
                                  "0x%a@." % string) Hex.pp
                                (Hex.of_bytes None
                                  (Client_proto_multisig.bytes prepared_command))
                            else
                              Stdlib.Format.printf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Flush_newline
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format))))))
                                  "%a@.%a@.%a@." % string)
                                (fun ppf =>
                                  fun x =>
                                    Stdlib.Format.fprintf ppf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Bytes to sign: '0x" % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Char_literal
                                              "'" % char
                                              CamlinternalFormatBasics.End_of_format)))
                                        "Bytes to sign: '0x%a'" % string) Hex.pp
                                      (Hex.of_bytes None x))
                                (Client_proto_multisig.bytes prepared_command)
                                (fun ppf =>
                                  fun z =>
                                    Stdlib.Format.fprintf ppf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Threshold (number of signatures required): "
                                            % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            CamlinternalFormatBasics.End_of_format))
                                        "Threshold (number of signatures required): %s"
                                          % string) (Z.to_string z))
                                (Client_proto_multisig.threshold
                                  prepared_command)
                                (fun ppf =>
                                  Stdlib.Format.fprintf ppf
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<2>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<2>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Public keys of the signers:" % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                CamlinternalFormatBasics.End_of_format)))))
                                      "@[<2>Public keys of the signers:@ %a@]" %
                                        string)
                                    (Stdlib.Format.pp_print_list
                                      (Some
                                        (fun ppf =>
                                          fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Stdlib.Format.fprintf ppf
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@ " % string 1 0)
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "@ " % string)
                                            end))
                                      Tezos_base__TzPervasives.Signature.Public_key.pp))
                                (Client_proto_multisig.keys prepared_command)))
                end))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Display the threshold, public keys, and byte sequence to sign for a multisigned delegate withdraw."
                % string (Tezos_base__TzPervasives.Clic.args1 bytes_only_switch)
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "prepare" % string
                    (cons "multisig" % string
                      (cons "transaction" % string (cons "on" % string [])))))
                (apply
                  (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                    (Some "multisig" % string)
                    (Some "name of the originated multisig contract" % string))
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "withdrawing" % string (cons "delegate" % string [])))
                    Tezos_base__TzPervasives.Clic.stop)))
              (fun bytes_only =>
                fun function_parameter =>
                  match function_parameter with
                  | (_, multisig_contract) =>
                    fun cctxt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_client_alpha.Client_proto_multisig.prepare_multisig_transaction
                          cctxt send send multisig_contract
                          (Client_proto_multisig.Change_delegate None) tt)
                        (fun prepared_command =>
                          apply Tezos_base__TzPervasives._return
                            (if bytes_only then
                              Stdlib.Format.printf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "0x" % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Flush_newline
                                        CamlinternalFormatBasics.End_of_format)))
                                  "0x%a@." % string) Hex.pp
                                (Hex.of_bytes None
                                  (Client_proto_multisig.bytes prepared_command))
                            else
                              Stdlib.Format.printf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Flush_newline
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format))))))
                                  "%a@.%a@.%a@." % string)
                                (fun ppf =>
                                  fun x =>
                                    Stdlib.Format.fprintf ppf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Bytes to sign: '0x" % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Char_literal
                                              "'" % char
                                              CamlinternalFormatBasics.End_of_format)))
                                        "Bytes to sign: '0x%a'" % string) Hex.pp
                                      (Hex.of_bytes None x))
                                (Client_proto_multisig.bytes prepared_command)
                                (fun ppf =>
                                  fun z =>
                                    Stdlib.Format.fprintf ppf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Threshold (number of signatures required): "
                                            % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            CamlinternalFormatBasics.End_of_format))
                                        "Threshold (number of signatures required): %s"
                                          % string) (Z.to_string z))
                                (Client_proto_multisig.threshold
                                  prepared_command)
                                (fun ppf =>
                                  Stdlib.Format.fprintf ppf
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<2>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<2>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Public keys of the signers:" % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                CamlinternalFormatBasics.End_of_format)))))
                                      "@[<2>Public keys of the signers:@ %a@]" %
                                        string)
                                    (Stdlib.Format.pp_print_list
                                      (Some
                                        (fun ppf =>
                                          fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Stdlib.Format.fprintf ppf
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@ " % string 1 0)
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "@ " % string)
                                            end))
                                      Tezos_base__TzPervasives.Signature.Public_key.pp))
                                (Client_proto_multisig.keys prepared_command)))
                  end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Display the threshold, public keys, and byte sequence to sign for a multisigned change of keys and threshold."
                  % string
                (Tezos_base__TzPervasives.Clic.args1 bytes_only_switch)
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "prepare" % string
                      (cons "multisig" % string
                        (cons "transaction" % string (cons "on" % string [])))))
                  (apply
                    (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                      (Some "multisig" % string)
                      (Some "name of the originated multisig contract" % string))
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "setting" % string
                          (cons "threshold" % string (cons "to" % string []))))
                      (apply (threshold_param tt)
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "and" % string
                              (cons "public" % string
                                (cons "keys" % string (cons "to" % string [])))))
                          (Tezos_base__TzPervasives.Clic.seq_of_param
                            (public_key_param tt)))))))
                (fun bytes_only =>
                  fun function_parameter =>
                    match function_parameter with
                    | (_, multisig_contract) =>
                      fun new_threshold =>
                        fun new_keys =>
                          fun cctxt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_base__TzPervasives.map_s
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (pk_uri, _) =>
                                    Tezos_client_base.Client_keys.public_key
                                      pk_uri
                                  end) new_keys)
                              (fun keys =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_client_alpha.Client_proto_multisig.prepare_multisig_transaction
                                    cctxt send send multisig_contract
                                    (Client_proto_multisig.Change_keys
                                      (Z.of_int new_threshold) keys) tt)
                                  (fun prepared_command =>
                                    apply Tezos_base__TzPervasives._return
                                      (if bytes_only then
                                        Stdlib.Format.printf
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "0x" % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Flush_newline
                                                  CamlinternalFormatBasics.End_of_format)))
                                            "0x%a@." % string) Hex.pp
                                          (Hex.of_bytes None
                                            (Client_proto_multisig.bytes
                                              prepared_command))
                                      else
                                        Stdlib.Format.printf
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Flush_newline
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Flush_newline
                                                        CamlinternalFormatBasics.End_of_format))))))
                                            "%a@.%a@.%a@." % string)
                                          (fun ppf =>
                                            fun x =>
                                              Stdlib.Format.fprintf ppf
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Bytes to sign: '0x" %
                                                      string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Char_literal
                                                        "'" % char
                                                        CamlinternalFormatBasics.End_of_format)))
                                                  "Bytes to sign: '0x%a'" %
                                                    string) Hex.pp
                                                (Hex.of_bytes None x))
                                          (Client_proto_multisig.bytes
                                            prepared_command)
                                          (fun ppf =>
                                            fun z =>
                                              Stdlib.Format.fprintf ppf
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Threshold (number of signatures required): "
                                                      % string
                                                    (CamlinternalFormatBasics.String
                                                      CamlinternalFormatBasics.No_padding
                                                      CamlinternalFormatBasics.End_of_format))
                                                  "Threshold (number of signatures required): %s"
                                                    % string) (Z.to_string z))
                                          (Client_proto_multisig.threshold
                                            prepared_command)
                                          (fun ppf =>
                                            Stdlib.Format.fprintf ppf
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "<2>" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "<2>" % string))
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Public keys of the signers:"
                                                      % string
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@ " % string 1 0)
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Close_box
                                                          CamlinternalFormatBasics.End_of_format)))))
                                                "@[<2>Public keys of the signers:@ %a@]"
                                                  % string)
                                              (Stdlib.Format.pp_print_list
                                                (Some
                                                  (fun ppf =>
                                                    fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Stdlib.Format.fprintf
                                                          ppf
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              (CamlinternalFormatBasics.Break
                                                                "@ " % string 1
                                                                0)
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "@ " % string)
                                                      end))
                                                Tezos_base__TzPervasives.Signature.Public_key.pp))
                                          (Client_proto_multisig.keys
                                            prepared_command))))
                    end))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some group)
                  "Sign a transaction for a multisig contract." % string
                  Tezos_base__TzPervasives.Clic.no_options
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "sign" % string
                        (cons "multisig" % string
                          (cons "transaction" % string (cons "on" % string [])))))
                    (apply
                      (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                        (Some "multisig" % string)
                        (Some
                          "name of the originated multisig contract" % string))
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefix
                          "transferring" % string)
                        (apply
                          (Tezos_client_alpha.Client_proto_args.tez_param
                            "qty" % string "amount taken from source" % string)
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefix "to" % string)
                            (apply
                              (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                (Some "dst" % string)
                                (Some
                                  "name/literal of the destination contract" %
                                    string))
                              (apply
                                (Tezos_base__TzPervasives.Clic.prefixes
                                  (cons "using" % string
                                    (cons "secret" % string
                                      (cons "key" % string []))))
                                (apply (secret_key_param tt)
                                  Tezos_base__TzPervasives.Clic.stop))))))))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      fun function_parameter =>
                        match function_parameter with
                        | (_, multisig_contract) =>
                          fun amount =>
                            fun function_parameter =>
                              match function_parameter with
                              | (_, destination) =>
                                fun sk =>
                                  fun cctxt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_client_alpha.Client_proto_multisig.prepare_multisig_transaction
                                        cctxt send send multisig_contract
                                        (Client_proto_multisig.Transfer amount
                                          destination) tt)
                                      (fun prepared_command =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_client_base.Client_keys.sign
                                            cctxt None sk
                                            (string prepared_command))
                                          (fun signature =>
                                            apply
                                              Tezos_base__TzPervasives._return
                                              (Stdlib.Format.printf
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Flush_newline
                                                      CamlinternalFormatBasics.End_of_format))
                                                  "%a@." % string)
                                                Tezos_base__TzPervasives.Signature.pp
                                                signature)))
                              end
                        end
                    end))
                (cons
                  (Tezos_base__TzPervasives.Clic.command (Some group)
                    "Sign a delegate change for a multisig contract." % string
                    Tezos_base__TzPervasives.Clic.no_options
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "sign" % string
                          (cons "multisig" % string
                            (cons "transaction" % string (cons "on" % string [])))))
                      (apply
                        (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                          (Some "multisig" % string)
                          (Some
                            "name of the originated multisig contract" % string))
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "setting" % string
                              (cons "delegate" % string (cons "to" % string []))))
                          (apply
                            (Tezos_client_base.Client_keys.Public_key_hash.source_param
                              (Some "dlgt" % string)
                              (Some
                                "new delegate of the new multisig contract" %
                                  string))
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "using" % string
                                  (cons "secret" % string
                                    (cons "key" % string []))))
                              (apply (secret_key_param tt)
                                Tezos_base__TzPervasives.Clic.stop))))))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        fun function_parameter =>
                          match function_parameter with
                          | (_, multisig_contract) =>
                            fun delegate =>
                              fun sk =>
                                fun cctxt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_client_alpha.Client_proto_multisig.prepare_multisig_transaction
                                      cctxt send send multisig_contract
                                      (Client_proto_multisig.Change_delegate
                                        (Some delegate)) tt)
                                    (fun prepared_command =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_client_base.Client_keys.sign
                                          cctxt None sk
                                          (string prepared_command))
                                        (fun signature =>
                                          apply Tezos_base__TzPervasives._return
                                            (Stdlib.Format.printf
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    CamlinternalFormatBasics.End_of_format))
                                                "%a@." % string)
                                              Tezos_base__TzPervasives.Signature.pp
                                              signature)))
                          end
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Clic.command (Some group)
                      "Sign a delegate withdraw for a multisig contract." %
                        string Tezos_base__TzPervasives.Clic.no_options
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "sign" % string
                            (cons "multisig" % string
                              (cons "transaction" % string
                                (cons "on" % string [])))))
                        (apply
                          (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                            (Some "multisig" % string)
                            (Some
                              "name of the originated multisig contract" %
                                string))
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefixes
                              (cons "withdrawing" % string
                                (cons "delegate" % string [])))
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "using" % string
                                  (cons "secret" % string
                                    (cons "key" % string []))))
                              (apply (secret_key_param tt)
                                Tezos_base__TzPervasives.Clic.stop)))))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          fun function_parameter =>
                            match function_parameter with
                            | (_, multisig_contract) =>
                              fun sk =>
                                fun cctxt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_client_alpha.Client_proto_multisig.prepare_multisig_transaction
                                      cctxt send send multisig_contract
                                      (Client_proto_multisig.Change_delegate
                                        None) tt)
                                    (fun prepared_command =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_client_base.Client_keys.sign
                                          cctxt None sk
                                          (string prepared_command))
                                        (fun signature =>
                                          apply Tezos_base__TzPervasives._return
                                            (Stdlib.Format.printf
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    CamlinternalFormatBasics.End_of_format))
                                                "%a@." % string)
                                              Tezos_base__TzPervasives.Signature.pp
                                              signature)))
                            end
                        end))
                    (cons
                      (Tezos_base__TzPervasives.Clic.command (Some group)
                        "Sign a change of public keys and threshold for a multisig contract."
                          % string Tezos_base__TzPervasives.Clic.no_options
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "sign" % string
                              (cons "multisig" % string
                                (cons "transaction" % string
                                  (cons "on" % string [])))))
                          (apply
                            (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                              (Some "multisig" % string)
                              (Some
                                "name of the originated multisig contract" %
                                  string))
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "using" % string
                                  (cons "secret" % string
                                    (cons "key" % string []))))
                              (apply (secret_key_param tt)
                                (apply
                                  (Tezos_base__TzPervasives.Clic.prefixes
                                    (cons "setting" % string
                                      (cons "threshold" % string
                                        (cons "to" % string []))))
                                  (apply (threshold_param tt)
                                    (apply
                                      (Tezos_base__TzPervasives.Clic.prefixes
                                        (cons "and" % string
                                          (cons "public" % string
                                            (cons "keys" % string
                                              (cons "to" % string [])))))
                                      (Tezos_base__TzPervasives.Clic.seq_of_param
                                        (public_key_param tt)))))))))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            fun function_parameter =>
                              match function_parameter with
                              | (_, multisig_contract) =>
                                fun sk =>
                                  fun new_threshold =>
                                    fun new_keys =>
                                      fun cctxt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_base__TzPervasives.map_s
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | (pk_uri, _) =>
                                                Tezos_client_base.Client_keys.public_key
                                                  pk_uri
                                              end) new_keys)
                                          (fun keys =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                              (Tezos_client_alpha.Client_proto_multisig.prepare_multisig_transaction
                                                cctxt send send
                                                multisig_contract
                                                (Client_proto_multisig.Change_keys
                                                  (Z.of_int new_threshold) keys)
                                                tt)
                                              (fun prepared_command =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_client_base.Client_keys.sign
                                                    cctxt None sk
                                                    (string prepared_command))
                                                  (fun signature =>
                                                    apply
                                                      Tezos_base__TzPervasives._return
                                                      (Stdlib.Format.printf
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Flush_newline
                                                              CamlinternalFormatBasics.End_of_format))
                                                          "%a@." % string)
                                                        Tezos_base__TzPervasives.Signature.pp
                                                        signature))))
                              end
                          end))
                      (cons
                        (Tezos_base__TzPervasives.Clic.command (Some group)
                          "Transfer tokens using a multisig contract." % string
                          transfer_options
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefixes
                              (cons "from" % string
                                (cons "multisig" % string
                                  (cons "contract" % string []))))
                            (apply
                              (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                (Some "multisig" % string)
                                (Some
                                  "name/literal of the multisig contract" %
                                    string))
                              (apply
                                (Tezos_base__TzPervasives.Clic.prefix
                                  "transfer" % string)
                                (apply
                                  (Tezos_client_alpha.Client_proto_args.tez_param
                                    "qty" % string
                                    "amount taken from the multisig contract" %
                                      string)
                                  (apply
                                    (Tezos_base__TzPervasives.Clic.prefix
                                      "to" % string)
                                    (apply
                                      (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                        (Some "dst" % string)
                                        (Some
                                          "name/literal of the destination contract"
                                            % string))
                                      (apply
                                        (Tezos_base__TzPervasives.Clic.prefixes
                                          (cons "on" % string
                                            (cons "behalf" % string
                                              (cons "of" % string []))))
                                        (apply
                                          (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                            (Some "src" % string)
                                            (Some
                                              "source calling the multisig contract"
                                                % string))
                                          (apply
                                            (Tezos_base__TzPervasives.Clic.prefixes
                                              (cons "with" % string
                                                (cons "signatures" % string [])))
                                            (Tezos_base__TzPervasives.Clic.seq_of_param
                                              (signature_param tt)))))))))))
                          (fun function_parameter =>
                            match function_parameter with
                            |
                              (fee, dry_run, gas_limit, storage_limit, counter,
                                no_print_source, minimal_fees,
                                minimal_nanotez_per_byte,
                                minimal_nanotez_per_gas_unit, force_low_fee,
                                fee_cap, burn_cap) =>
                              fun function_parameter =>
                                match function_parameter with
                                | (_, multisig_contract) =>
                                  fun amount =>
                                    fun function_parameter =>
                                      match function_parameter with
                                      | (_, destination) =>
                                        fun function_parameter =>
                                          match function_parameter with
                                          | (_, source) =>
                                            fun signatures =>
                                              fun cctxt =>
                                                match
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                    source with
                                                | None =>
                                                  Tezos_base__TzPervasives.failwith
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "only implicit accounts can be the source of a contract call"
                                                          % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "only implicit accounts can be the source of a contract call"
                                                        % string)
                                                | Some source =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    (Tezos_client_base.Client_keys.get_key
                                                      cctxt source)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | (_, src_pk, src_sk) =>
                                                        let fee_parameter :=
                                                          {|
                                                            Injection.minimal_fees :=
                                                              minimal_fees;
                                                            Injection.minimal_nanotez_per_byte :=
                                                              minimal_nanotez_per_byte;
                                                            Injection.minimal_nanotez_per_gas_unit :=
                                                              minimal_nanotez_per_gas_unit;
                                                            Injection.force_low_fee :=
                                                              force_low_fee;
                                                            Injection.fee_cap :=
                                                              fee_cap;
                                                            Injection.burn_cap :=
                                                              burn_cap |} in
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (Tezos_client_alpha.Client_proto_multisig.call_multisig
                                                              cctxt send send
                                                              send
                                                              (Some dry_run)
                                                              None source src_pk
                                                              src_sk
                                                              multisig_contract
                                                              (Client_proto_multisig.Transfer
                                                                amount
                                                                destination)
                                                              signatures
                                                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                              fee gas_limit
                                                              storage_limit
                                                              counter
                                                              fee_parameter tt)
                                                            (Tezos_client_alpha_commands.Client_proto_context_commands.report_michelson_errors
                                                              (Some
                                                                no_print_source)
                                                              "transfer simulation failed"
                                                                % string cctxt))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | None =>
                                                              Tezos_base__TzPervasives.return_unit
                                                            |
                                                              Some
                                                                (_res,
                                                                  _contracts) =>
                                                              Tezos_base__TzPervasives.return_unit
                                                            end)
                                                      end)
                                                end
                                          end
                                      end
                                end
                            end))
                        (cons
                          (Tezos_base__TzPervasives.Clic.command (Some group)
                            "Change the delegate of a multisig contract." %
                              string transfer_options
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "set" % string
                                  (cons "delegate" % string
                                    (cons "of" % string
                                      (cons "multisig" % string
                                        (cons "contract" % string []))))))
                              (apply
                                (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                                  (Some "multisig" % string)
                                  (Some
                                    "name of the originated multisig contract" %
                                      string))
                                (apply
                                  (Tezos_base__TzPervasives.Clic.prefix
                                    "to" % string)
                                  (apply
                                    (Tezos_client_base.Client_keys.Public_key_hash.source_param
                                      (Some "dlgt" % string)
                                      (Some
                                        "new delegate of the new multisig contract"
                                          % string))
                                    (apply
                                      (Tezos_base__TzPervasives.Clic.prefixes
                                        (cons "on" % string
                                          (cons "behalf" % string
                                            (cons "of" % string []))))
                                      (apply
                                        (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                          (Some "src" % string)
                                          (Some
                                            "source calling the multisig contract"
                                              % string))
                                        (apply
                                          (Tezos_base__TzPervasives.Clic.prefixes
                                            (cons "with" % string
                                              (cons "signatures" % string [])))
                                          (Tezos_base__TzPervasives.Clic.seq_of_param
                                            (signature_param tt)))))))))
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                (fee, dry_run, gas_limit, storage_limit,
                                  counter, no_print_source, minimal_fees,
                                  minimal_nanotez_per_byte,
                                  minimal_nanotez_per_gas_unit, force_low_fee,
                                  fee_cap, burn_cap) =>
                                fun function_parameter =>
                                  match function_parameter with
                                  | (_, multisig_contract) =>
                                    fun delegate =>
                                      fun function_parameter =>
                                        match function_parameter with
                                        | (_, source) =>
                                          fun signatures =>
                                            fun cctxt =>
                                              match
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                  source with
                                              | None =>
                                                Tezos_base__TzPervasives.failwith
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "only implicit accounts can be the source of a contract call"
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "only implicit accounts can be the source of a contract call"
                                                      % string)
                                              | Some source =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_client_base.Client_keys.get_key
                                                    cctxt source)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | (_, src_pk, src_sk) =>
                                                      let fee_parameter :=
                                                        {|
                                                          Injection.minimal_fees :=
                                                            minimal_fees;
                                                          Injection.minimal_nanotez_per_byte :=
                                                            minimal_nanotez_per_byte;
                                                          Injection.minimal_nanotez_per_gas_unit :=
                                                            minimal_nanotez_per_gas_unit;
                                                          Injection.force_low_fee :=
                                                            force_low_fee;
                                                          Injection.fee_cap :=
                                                            fee_cap;
                                                          Injection.burn_cap :=
                                                            burn_cap |} in
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (Tezos_client_alpha.Client_proto_multisig.call_multisig
                                                            cctxt send send send
                                                            (Some dry_run) None
                                                            source src_pk src_sk
                                                            multisig_contract
                                                            (Client_proto_multisig.Change_delegate
                                                              (Some delegate))
                                                            signatures
                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                            fee gas_limit
                                                            storage_limit
                                                            counter
                                                            fee_parameter tt)
                                                          (Tezos_client_alpha_commands.Client_proto_context_commands.report_michelson_errors
                                                            (Some
                                                              no_print_source)
                                                            "transfer simulation failed"
                                                              % string cctxt))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | None =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          |
                                                            Some
                                                              (_res, _contracts)
                                                            =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)
                                                    end)
                                              end
                                        end
                                  end
                              end))
                          (cons
                            (Tezos_base__TzPervasives.Clic.command (Some group)
                              "Withdrow the delegate of a multisig contract." %
                                string transfer_options
                              (apply
                                (Tezos_base__TzPervasives.Clic.prefixes
                                  (cons "withdraw" % string
                                    (cons "delegate" % string
                                      (cons "of" % string
                                        (cons "multisig" % string
                                          (cons "contract" % string []))))))
                                (apply
                                  (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                                    (Some "multisig" % string)
                                    (Some
                                      "name of the originated multisig contract"
                                        % string))
                                  (apply
                                    (Tezos_base__TzPervasives.Clic.prefixes
                                      (cons "on" % string
                                        (cons "behalf" % string
                                          (cons "of" % string []))))
                                    (apply
                                      (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                        (Some "src" % string)
                                        (Some
                                          "source calling the multisig contract"
                                            % string))
                                      (apply
                                        (Tezos_base__TzPervasives.Clic.prefixes
                                          (cons "with" % string
                                            (cons "signatures" % string [])))
                                        (Tezos_base__TzPervasives.Clic.seq_of_param
                                          (signature_param tt)))))))
                              (fun function_parameter =>
                                match function_parameter with
                                |
                                  (fee, dry_run, gas_limit, storage_limit,
                                    counter, no_print_source, minimal_fees,
                                    minimal_nanotez_per_byte,
                                    minimal_nanotez_per_gas_unit, force_low_fee,
                                    fee_cap, burn_cap) =>
                                  fun function_parameter =>
                                    match function_parameter with
                                    | (_, multisig_contract) =>
                                      fun function_parameter =>
                                        match function_parameter with
                                        | (_, source) =>
                                          fun signatures =>
                                            fun cctxt =>
                                              match
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                  source with
                                              | None =>
                                                Tezos_base__TzPervasives.failwith
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "only implicit accounts can be the source of a contract call"
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "only implicit accounts can be the source of a contract call"
                                                      % string)
                                              | Some source =>
                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                  (Tezos_client_base.Client_keys.get_key
                                                    cctxt source)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | (_, src_pk, src_sk) =>
                                                      let fee_parameter :=
                                                        {|
                                                          Injection.minimal_fees :=
                                                            minimal_fees;
                                                          Injection.minimal_nanotez_per_byte :=
                                                            minimal_nanotez_per_byte;
                                                          Injection.minimal_nanotez_per_gas_unit :=
                                                            minimal_nanotez_per_gas_unit;
                                                          Injection.force_low_fee :=
                                                            force_low_fee;
                                                          Injection.fee_cap :=
                                                            fee_cap;
                                                          Injection.burn_cap :=
                                                            burn_cap |} in
                                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                                        (Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (Tezos_client_alpha.Client_proto_multisig.call_multisig
                                                            cctxt send send send
                                                            (Some dry_run) None
                                                            source src_pk src_sk
                                                            multisig_contract
                                                            (Client_proto_multisig.Change_delegate
                                                              None) signatures
                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                            fee gas_limit
                                                            storage_limit
                                                            counter
                                                            fee_parameter tt)
                                                          (Tezos_client_alpha_commands.Client_proto_context_commands.report_michelson_errors
                                                            (Some
                                                              no_print_source)
                                                            "transfer simulation failed"
                                                              % string cctxt))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | None =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          |
                                                            Some
                                                              (_res, _contracts)
                                                            =>
                                                            Tezos_base__TzPervasives.return_unit
                                                          end)
                                                    end)
                                              end
                                        end
                                    end
                                end))
                            (cons
                              (Tezos_base__TzPervasives.Clic.command
                                (Some group)
                                "Run a transaction described by a sequence of bytes on a multisig contract."
                                  % string transfer_options
                                (apply
                                  (Tezos_base__TzPervasives.Clic.prefixes
                                    (cons "run" % string
                                      (cons "transaction" % string [])))
                                  (apply
                                    (bytes_param "bytes" % string
                                      "the sequence of bytes to deserialize as a multisig action, can be obtained by one of the ""prepare multisig transaction"" commands"
                                        % string)
                                    (apply
                                      (Tezos_base__TzPervasives.Clic.prefixes
                                        (cons "on" % string
                                          (cons "multisig" % string
                                            (cons "contract" % string []))))
                                      (apply
                                        (Tezos_client_alpha.Client_proto_contracts.RawContractAlias.alias_param
                                          (Some "multisig" % string)
                                          (Some
                                            "name of the originated multisig contract"
                                              % string))
                                        (apply
                                          (Tezos_base__TzPervasives.Clic.prefixes
                                            (cons "on" % string
                                              (cons "behalf" % string
                                                (cons "of" % string []))))
                                          (apply
                                            (Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_param
                                              (Some "src" % string)
                                              (Some
                                                "source calling the multisig contract"
                                                  % string))
                                            (apply
                                              (Tezos_base__TzPervasives.Clic.prefixes
                                                (cons "with" % string
                                                  (cons "signatures" % string [])))
                                              (Tezos_base__TzPervasives.Clic.seq_of_param
                                                (signature_param tt)))))))))
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    (fee, dry_run, gas_limit, storage_limit,
                                      counter, no_print_source, minimal_fees,
                                      minimal_nanotez_per_byte,
                                      minimal_nanotez_per_gas_unit,
                                      force_low_fee, fee_cap, burn_cap) =>
                                    fun bytes =>
                                      fun function_parameter =>
                                        match function_parameter with
                                        | (_, multisig_contract) =>
                                          fun function_parameter =>
                                            match function_parameter with
                                            | (_, source) =>
                                              fun signatures =>
                                                fun cctxt =>
                                                  match
                                                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                                                      source with
                                                  | None =>
                                                    Tezos_base__TzPervasives.failwith
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "only implicit accounts can be the source of a contract call"
                                                            % string
                                                          CamlinternalFormatBasics.End_of_format)
                                                        "only implicit accounts can be the source of a contract call"
                                                          % string)
                                                  | Some source =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                      (Tezos_client_base.Client_keys.get_key
                                                        cctxt source)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | (_, src_pk, src_sk) =>
                                                          let fee_parameter :=
                                                            {|
                                                              Injection.minimal_fees :=
                                                                minimal_fees;
                                                              Injection.minimal_nanotez_per_byte :=
                                                                minimal_nanotez_per_byte;
                                                              Injection.minimal_nanotez_per_gas_unit :=
                                                                minimal_nanotez_per_gas_unit;
                                                              Injection.force_low_fee :=
                                                                force_low_fee;
                                                              Injection.fee_cap :=
                                                                fee_cap;
                                                              Injection.burn_cap :=
                                                                burn_cap |} in
                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                            (Tezos_base__TzPervasives.op_gt_gt_eq
                                                              (Tezos_client_alpha.Client_proto_multisig.call_multisig_on_bytes
                                                                cctxt send send
                                                                send
                                                                (Some dry_run)
                                                                None source
                                                                src_pk src_sk
                                                                multisig_contract
                                                                string
                                                                signatures
                                                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                                fee gas_limit
                                                                storage_limit
                                                                counter
                                                                fee_parameter tt)
                                                              (Tezos_client_alpha_commands.Client_proto_context_commands.report_michelson_errors
                                                                (Some
                                                                  no_print_source)
                                                                "transfer simulation failed"
                                                                  % string cctxt))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | None =>
                                                                Tezos_base__TzPervasives.return_unit
                                                              |
                                                                Some
                                                                  (_res,
                                                                    _contracts)
                                                                =>
                                                                Tezos_base__TzPervasives.return_unit
                                                              end)
                                                        end)
                                                  end
                                            end
                                        end
                                  end))
                              (cons
                                (Tezos_base__TzPervasives.Clic.command
                                  (Some group)
                                  "Show the hashes of the supported multisig contracts."
                                    % string
                                  Tezos_base__TzPervasives.Clic.no_options
                                  (Tezos_base__TzPervasives.Clic.fixed
                                    (cons "show" % string
                                      (cons "supported" % string
                                        (cons "multisig" % string
                                          (cons "hashes" % string [])))))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      fun _cctxt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Lwt._return
                                            Tezos_client_alpha.Client_proto_multisig.known_multisig_hashes)
                                          (fun l =>
                                            Stdlib.Format.printf
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Hashes of supported multisig contracts:"
                                                    % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    CamlinternalFormatBasics.End_of_format))
                                                "Hashes of supported multisig contracts:@."
                                                  % string);
                                            Tezos_base__TzPervasives.List.iter
                                              (fun h =>
                                                Stdlib.Format.printf
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "  0x" % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Flush_newline
                                                          CamlinternalFormatBasics.End_of_format)))
                                                    "  0x%a@." % string) Hex.pp
                                                  (OCaml.Stdlib.reverse_apply
                                                    (Tezos_protocol_alpha.Protocol.Script_expr_hash.to_bytes
                                                      h)
                                                    (let arg := Hex.of_bytes in
                                                    fun eta => arg None eta))) l;
                                            Tezos_base__TzPervasives.return_unit)
                                    end)) [])))))))))))))
  end.
src/proto_alpha/lib_client_commands/client_proto_multisig_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> Protocol_client_context.full Clic.command list
src/proto_alpha/lib_client_commands/client_proto_multisig_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands :
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full).
src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let group =
  {
    Clic.name = "scripts";
    title = "Commands for managing the library of known scripts";
  }

open Tezos_micheline
open Client_proto_programs
open Client_proto_args
open Client_proto_contracts

let commands () =
  let open Clic in
  let show_types_switch =
    switch
      ~long:"details"
      ~short:'v'
      ~doc:"show the types of each instruction"
      ()
  in
  let emacs_mode_switch =
    switch
      ~long:"emacs"
      ?short:None
      ~doc:"output in `michelson-mode.el` compatible format"
      ()
  in
  let trace_stack_switch =
    switch ~long:"trace-stack" ~doc:"show the stack after each step" ()
  in
  let amount_arg =
    Client_proto_args.tez_arg
      ~parameter:"amount"
      ~doc:"amount of the transfer in \xEA\x9C\xA9"
      ~default:"0.05"
  in
  let source_arg =
    ContractAlias.destination_arg
      ~name:"source"
      ~doc:"name of the source (i.e. SENDER) contract for the transaction"
      ()
  in
  let payer_arg =
    ContractAlias.destination_arg
      ~name:"payer"
      ~doc:"name of the payer (i.e. SOURCE) contract for the transaction"
      ()
  in
  let custom_gas_flag =
    arg
      ~long:"gas"
      ~short:'G'
      ~doc:"Initial quantity of gas for typechecking and execution"
      ~placeholder:"gas"
      (parameter (fun _ctx str ->
           try
             let v = Z.of_string str in
             assert (Compare.Z.(v >= Z.zero)) ;
             return v
           with _ -> failwith "invalid gas limit (must be a positive number)"))
  in
  let resolve_max_gas cctxt block = function
    | None ->
        Alpha_services.Constants.all cctxt (cctxt#chain, block)
        >>=? fun {parametric = {hard_gas_limit_per_operation; _}; _} ->
        return hard_gas_limit_per_operation
    | Some gas ->
        return gas
  in
  let data_parameter =
    Clic.parameter (fun _ data ->
        Lwt.return
          ( Micheline_parser.no_parsing_error
          @@ Michelson_v1_parser.parse_expression data ))
  in
  let bytes_parameter ~name ~desc =
    Clic.param ~name ~desc Client_proto_args.bytes_parameter
  in
  let signature_parameter =
    Clic.parameter (fun _cctxt s ->
        match Signature.of_b58check_opt s with
        | Some s ->
            return s
        | None ->
            failwith "Not given a valid signature")
  in
  [ command
      ~group
      ~desc:"Lists all scripts in the library."
      no_options
      (fixed ["list"; "known"; "scripts"])
      (fun () (cctxt : Protocol_client_context.full) ->
        Program.load cctxt
        >>=? fun list ->
        Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Add a script to the library."
      (args1 (Program.force_switch ()))
      ( prefixes ["remember"; "script"]
      @@ Program.fresh_alias_param @@ Program.source_param @@ stop )
      (fun force name hash cctxt ->
        Program.of_fresh cctxt force name
        >>=? fun name -> Program.add ~force cctxt name hash);
    command
      ~group
      ~desc:"Remove a script from the library."
      no_options
      (prefixes ["forget"; "script"] @@ Program.alias_param @@ stop)
      (fun () (name, _) cctxt -> Program.del cctxt name);
    command
      ~group
      ~desc:"Display a script from the library."
      no_options
      (prefixes ["show"; "known"; "script"] @@ Program.alias_param @@ stop)
      (fun () (_, program) (cctxt : Protocol_client_context.full) ->
        Program.to_source program
        >>=? fun source ->
        cctxt#message "%s\n" source >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Ask the node to run a script."
      (args7
         trace_stack_switch
         amount_arg
         source_arg
         payer_arg
         no_print_source_flag
         custom_gas_flag
         entrypoint_arg)
      ( prefixes ["run"; "script"]
      @@ Program.source_param
      @@ prefixes ["on"; "storage"]
      @@ Clic.param ~name:"storage" ~desc:"the storage data" data_parameter
      @@ prefixes ["and"; "input"]
      @@ Clic.param ~name:"input" ~desc:"the input data" data_parameter
      @@ stop )
      (fun (trace_exec, amount, source, payer, no_print_source, gas, entrypoint)
           program
           storage
           input
           cctxt ->
        let source = Option.map ~f:snd source in
        let payer = Option.map ~f:snd payer in
        Lwt.return @@ Micheline_parser.no_parsing_error program
        >>=? fun program ->
        let show_source = not no_print_source in
        if trace_exec then
          trace
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~amount
            ~program
            ~storage
            ~input
            ?source
            ?payer
            ?gas
            ?entrypoint
            ()
          >>= fun res ->
          print_trace_result cctxt ~show_source ~parsed:program res
        else
          run
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~amount
            ~program
            ~storage
            ~input
            ?source
            ?payer
            ?gas
            ?entrypoint
            ()
          >>= fun res ->
          print_run_result cctxt ~show_source ~parsed:program res);
    command
      ~group
      ~desc:"Ask the node to typecheck a script."
      (args4
         show_types_switch
         emacs_mode_switch
         no_print_source_flag
         custom_gas_flag)
      (prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop)
      (fun (show_types, emacs_mode, no_print_source, original_gas)
           program
           cctxt ->
        match program with
        | (program, []) ->
            resolve_max_gas cctxt cctxt#block original_gas
            >>=? fun original_gas ->
            typecheck_program
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ~gas:original_gas
              program
            >>= fun res ->
            print_typecheck_result
              ~emacs:emacs_mode
              ~show_types
              ~print_source_on_error:(not no_print_source)
              program
              res
              cctxt
        | res_with_errors when emacs_mode ->
            cctxt#message
              "(@[<v 0>(types . ())@ (errors . %a)@])"
              Michelson_v1_emacs.report_errors
              res_with_errors
            >>= fun () -> return_unit
        | (parsed, errors) ->
            cctxt#message
              "%a"
              (fun ppf () ->
                Michelson_v1_error_reporter.report_errors
                  ~details:(not no_print_source)
                  ~parsed
                  ~show_source:(not no_print_source)
                  ppf
                  errors)
              ()
            >>= fun () -> cctxt#error "syntax error in program");
    command
      ~group
      ~desc:"Ask the node to typecheck a data expression."
      (args2 no_print_source_flag custom_gas_flag)
      ( prefixes ["typecheck"; "data"]
      @@ Clic.param ~name:"data" ~desc:"the data to typecheck" data_parameter
      @@ prefixes ["against"; "type"]
      @@ Clic.param ~name:"type" ~desc:"the expected type" data_parameter
      @@ stop )
      (fun (no_print_source, custom_gas) data ty cctxt ->
        resolve_max_gas cctxt cctxt#block custom_gas
        >>=? fun original_gas ->
        Client_proto_programs.typecheck_data
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ~gas:original_gas
          ~data
          ~ty
          ()
        >>= function
        | Ok gas ->
            cctxt#message
              "@[<v 0>Well typed@,Gas remaining: %a@]"
              Alpha_context.Gas.pp
              gas
            >>= fun () -> return_unit
        | Error errs ->
            cctxt#warning
              "%a"
              (Michelson_v1_error_reporter.report_errors
                 ~details:false
                 ~show_source:(not no_print_source)
                 ?parsed:None)
              errs
            >>= fun () -> cctxt#error "ill-typed data");
    command
      ~group
      ~desc:
        "Ask the node to pack a data expression.\n\
         The returned hash is the same as what Michelson instruction `PACK` \
         would have produced.\n\
         Also displays the result of hashing this packed data with `BLAKE2B`, \
         `SHA256` or `SHA512` instruction."
      (args1 custom_gas_flag)
      ( prefixes ["hash"; "data"]
      @@ Clic.param ~name:"data" ~desc:"the data to hash" data_parameter
      @@ prefixes ["of"; "type"]
      @@ Clic.param ~name:"type" ~desc:"type of the data" data_parameter
      @@ stop )
      (fun custom_gas data typ cctxt ->
        resolve_max_gas cctxt cctxt#block custom_gas
        >>=? fun original_gas ->
        Alpha_services.Helpers.Scripts.pack_data
          cctxt
          (cctxt#chain, cctxt#block)
          (data.expanded, typ.expanded, Some original_gas)
        >>= function
        | Ok (bytes, remaining_gas) ->
            let hash = Script_expr_hash.hash_bytes [bytes] in
            cctxt#message
              "Raw packed data: 0x%a@,\
               Script-expression-ID-Hash: %a@,\
               Raw Script-expression-ID-Hash: 0x%a@,\
               Ledger Blake2b hash: %s@,\
               Raw Sha256 hash: 0x%a@,\
               Raw Sha512 hash: 0x%a@,\
               Gas remaining: %a"
              Hex.pp
              (Hex.of_bytes bytes)
              Script_expr_hash.pp
              hash
              Hex.pp
              (Hex.of_bytes (Script_expr_hash.to_bytes hash))
              (Base58.raw_encode Blake2B.(hash_bytes [bytes] |> to_string))
              Hex.pp
              (Hex.of_bytes (Environment.Raw_hashes.sha256 bytes))
              Hex.pp
              (Hex.of_bytes (Environment.Raw_hashes.sha512 bytes))
              Alpha_context.Gas.pp
              remaining_gas
            >>= fun () -> return_unit
        | Error errs ->
            cctxt#warning
              "%a"
              (Michelson_v1_error_reporter.report_errors
                 ~details:false
                 ~show_source:false
                 ?parsed:None)
              errs
            >>= fun () -> cctxt#error "ill-formed data");
    command
      ~group
      ~desc:
        "Parse a byte sequence (in hexadecimal notation) as a data \
         expression, as per Michelson instruction `UNPACK`."
      Clic.no_options
      ( prefixes ["unpack"; "michelson"; "data"]
      @@ bytes_parameter ~name:"bytes" ~desc:"the packed data to parse"
      @@ stop )
      (fun () bytes cctxt ->
        ( if Bytes.get bytes 0 != '\005' then
          failwith
            "Not a piece of packed Michelson data (must start with `0x05`)"
        else return_unit )
        >>=? fun () ->
        (* Remove first byte *)
        let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in
        match
          Data_encoding.Binary.of_bytes
            Alpha_context.Script.expr_encoding
            bytes
        with
        | None ->
            failwith "Could not decode bytes"
        | Some expr ->
            cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr
            >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Sign a raw sequence of bytes and display it using the format \
         expected by Michelson instruction `CHECK_SIGNATURE`."
      no_options
      ( prefixes ["sign"; "bytes"]
      @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign"
      @@ prefixes ["for"]
      @@ Client_keys.Secret_key.source_param @@ stop )
      (fun () bytes sk cctxt ->
        Client_keys.sign cctxt sk bytes
        >>=? fun signature ->
        cctxt#message "Signature: %a" Signature.pp signature
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Check the signature of a byte sequence as per Michelson instruction \
         `CHECK_SIGNATURE`."
      (args1 (switch ~doc:"Use only exit codes" ~short:'q' ~long:"quiet" ()))
      ( prefixes ["check"; "that"]
      @@ bytes_parameter ~name:"bytes" ~desc:"the signed data"
      @@ prefixes ["was"; "signed"; "by"]
      @@ Client_keys.Public_key.alias_param ~name:"key"
      @@ prefixes ["to"; "produce"]
      @@ Clic.param
           ~name:"signature"
           ~desc:"the signature to check"
           signature_parameter
      @@ stop )
      (fun quiet
           bytes
           (_, (key_locator, _))
           signature
           (cctxt : #Protocol_client_context.full) ->
        Client_keys.check key_locator signature bytes
        >>=? function
        | false ->
            cctxt#error "invalid signature"
        | true ->
            if quiet then return_unit
            else
              cctxt#message "Signature check successfull."
              >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Ask the type of an entrypoint of a script."
      (args2 emacs_mode_switch no_print_source_flag)
      ( prefixes ["get"; "script"; "entrypoint"; "type"; "of"]
      @@ Clic.string ~name:"entrypoint" ~desc:"the entrypoint to describe"
      @@ prefixes ["for"]
      @@ Program.source_param @@ stop )
      (fun (emacs_mode, no_print_source) entrypoint program cctxt ->
        match program with
        | (program, []) ->
            entrypoint_type
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              program
              ~entrypoint
            >>= fun entrypoint_type ->
            print_entrypoint_type
              ~emacs:emacs_mode
              ~show_source:(not no_print_source)
              ~parsed:program
              ~entrypoint
              cctxt
              entrypoint_type
        | res_with_errors when emacs_mode ->
            cctxt#message
              "(@[<v 0>(entrypoint . ())@ (errors . %a)@])"
              Michelson_v1_emacs.report_errors
              res_with_errors
            >>= fun () -> return_unit
        | (parsed, errors) ->
            cctxt#message
              "%a"
              (fun ppf () ->
                Michelson_v1_error_reporter.report_errors
                  ~details:(not no_print_source)
                  ~parsed
                  ~show_source:(not no_print_source)
                  ppf
                  errors)
              ()
            >>= fun () -> cctxt#error "syntax error in program");
    command
      ~group
      ~desc:"Ask the node to list the entrypoints of a script."
      (args2 emacs_mode_switch no_print_source_flag)
      ( prefixes ["get"; "script"; "entrypoints"; "for"]
      @@ Program.source_param @@ stop )
      (fun (emacs_mode, no_print_source) program cctxt ->
        match program with
        | (program, []) ->
            list_entrypoints
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              program
            >>= fun entrypoints ->
            print_entrypoints_list
              ~emacs:emacs_mode
              ~show_source:(not no_print_source)
              ~parsed:program
              cctxt
              entrypoints
        | res_with_errors when emacs_mode ->
            cctxt#message
              "(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
              Michelson_v1_emacs.report_errors
              res_with_errors
            >>= fun () -> return_unit
        | (parsed, errors) ->
            cctxt#message
              "%a"
              (fun ppf () ->
                Michelson_v1_error_reporter.report_errors
                  ~details:(not no_print_source)
                  ~parsed
                  ~show_source:(not no_print_source)
                  ppf
                  errors)
              ()
            >>= fun () -> cctxt#error "syntax error in program");
    command
      ~group
      ~desc:
        "Ask the node to list the unreachable pathsin a script's parameter \
         type."
      (args2 emacs_mode_switch no_print_source_flag)
      ( prefixes ["get"; "script"; "unreachable"; "paths"; "for"]
      @@ Program.source_param @@ stop )
      (fun (emacs_mode, no_print_source) program cctxt ->
        match program with
        | (program, []) ->
            list_unreachables
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              program
            >>= fun entrypoints ->
            print_unreachables
              ~emacs:emacs_mode
              ~show_source:(not no_print_source)
              ~parsed:program
              cctxt
              entrypoints
        | res_with_errors when emacs_mode ->
            cctxt#message
              "(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
              Michelson_v1_emacs.report_errors
              res_with_errors
            >>= fun () -> return_unit
        | (parsed, errors) ->
            cctxt#message
              "%a"
              (fun ppf () ->
                Michelson_v1_error_reporter.report_errors
                  ~details:(not no_print_source)
                  ~parsed
                  ~show_source:(not no_print_source)
                  ppf
                  errors)
              ()
            >>= fun () -> cctxt#error "syntax error in program") ]
src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "scripts" % string;
    Clic.title := "Commands for managing the library of known scripts" % string
    |}.

Import Tezos_micheline.

Import Tezos_client_alpha.Client_proto_programs.

Import Tezos_client_alpha.Client_proto_args.

Import Tezos_client_alpha.Client_proto_contracts.

Definition commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  match function_parameter with
  | tt =>
    let show_types_switch :=
      Tezos_base__TzPervasives.Clic.switch
        "show the types of each instruction" % string (Some "v" % char)
        "details" % string tt in
    let emacs_mode_switch :=
      Tezos_base__TzPervasives.Clic.switch
        "output in `michelson-mode.el` compatible format" % string None
        "emacs" % string tt in
    let trace_stack_switch :=
      Tezos_base__TzPervasives.Clic.switch
        "show the stack after each step" % string None "trace-stack" % string tt
      in
    let amount_arg :=
      Tezos_client_alpha.Client_proto_args.tez_arg "0.05" % string
        "amount" % string "amount of the transfer in ꜩ" % string in
    let source_arg :=
      Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_arg
        (Some "source" % string)
        (Some
          "name of the source (i.e. SENDER) contract for the transaction" %
            string) tt in
    let payer_arg :=
      Tezos_client_alpha.Client_proto_contracts.ContractAlias.destination_arg
        (Some "payer" % string)
        (Some
          "name of the payer (i.e. SOURCE) contract for the transaction" %
            string) tt in
    let custom_gas_flag :=
      Tezos_base__TzPervasives.Clic.arg
        "Initial quantity of gas for typechecking and execution" % string
        (Some "G" % char) "gas" % string "gas" % string
        (Tezos_base__TzPervasives.Clic.parameter None
          (fun _ctx => fun str => try)) in
    let resolve_max_gas {D E F H J L M a b c i o q : Type}
      (cctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (D * E) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (F * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (D * E) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (H * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (D * E) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (D * E) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (L * a * b * c * q * i * o)) * (D * M))))) *
        (D * M) * (D * E)) (block : E) (function_parameter :
      option Tezos_protocol_environment_alpha__Environment.Z.t)
      : Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_environment_alpha__Environment.Z.t) :=
      match function_parameter with
      | None =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all cctxt
            (send, block))
          (fun function_parameter =>
            match function_parameter with
            | {|
              parametric := {|
                hard_gas_limit_per_operation := hard_gas_limit_per_operation
                  |}
                |} =>
              Tezos_base__TzPervasives._return hard_gas_limit_per_operation
            end)
      | Some gas => Tezos_base__TzPervasives._return gas
      end in
    let data_parameter :=
      Tezos_base__TzPervasives.Clic.parameter None
        (fun function_parameter =>
          match function_parameter with
          | _ =>
            fun data =>
              Lwt._return
                (apply Tezos_micheline.Micheline_parser.no_parsing_error
                  (Tezos_client_alpha.Michelson_v1_parser.parse_expression None
                    data))
          end) in
    let bytes_parameter {A : Type} (name : string) (desc : string)
      : (Tezos_base__TzPervasives.Clic.params A
        Tezos_client_alpha.Protocol_client_context.full) ->
        Tezos_base__TzPervasives.Clic.params (Stdlib.Bytes.t -> A)
          Tezos_client_alpha.Protocol_client_context.full :=
      Tezos_base__TzPervasives.Clic.param name desc
        Tezos_client_alpha.Client_proto_args.bytes_parameter in
    let signature_parameter :=
      Tezos_base__TzPervasives.Clic.parameter None
        (fun _cctxt =>
          fun s =>
            match Tezos_base__TzPervasives.Signature.of_b58check_opt s with
            | Some s => Tezos_base__TzPervasives._return s
            | None =>
              Tezos_base__TzPervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Not given a valid signature" % string
                    CamlinternalFormatBasics.End_of_format)
                  "Not given a valid signature" % string)
            end) in
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Lists all scripts in the library." % string
        Tezos_base__TzPervasives.Clic.no_options
        (Tezos_base__TzPervasives.Clic.fixed
          (cons "list" % string
            (cons "known" % string (cons "scripts" % string []))))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun cctxt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_client_alpha.Client_proto_programs.Program.load cctxt)
                (fun list =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Lwt_list.iter_s
                      (fun function_parameter =>
                        match function_parameter with
                        | (n, _) =>
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.End_of_format)
                              "%s" % string) n
                        end) list)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end))
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Add a script to the library." % string
          (Tezos_base__TzPervasives.Clic.args1
            (Tezos_client_alpha.Client_proto_programs.Program.force_switch tt))
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "remember" % string (cons "script" % string [])))
            (apply
              (let arg :=
                Tezos_client_alpha.Client_proto_programs.Program.fresh_alias_param
                in
              fun eta => arg None None eta)
              (apply
                (let arg :=
                  Tezos_client_alpha.Client_proto_programs.Program.source_param
                  in
                fun eta => arg None None eta) Tezos_base__TzPervasives.Clic.stop)))
          (fun force =>
            fun name =>
              fun hash =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_client_alpha.Client_proto_programs.Program.of_fresh
                      cctxt force name)
                    (fun name =>
                      Tezos_client_alpha.Client_proto_programs.Program.add force
                        cctxt name hash)))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Remove a script from the library." % string
            Tezos_base__TzPervasives.Clic.no_options
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "forget" % string (cons "script" % string [])))
              (apply
                (let arg :=
                  Tezos_client_alpha.Client_proto_programs.Program.alias_param
                  in
                fun eta => arg None None eta) Tezos_base__TzPervasives.Clic.stop))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun function_parameter =>
                  match function_parameter with
                  | (name, _) =>
                    fun cctxt =>
                      Tezos_client_alpha.Client_proto_programs.Program.del cctxt
                        name
                  end
              end))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Display a script from the library." % string
              Tezos_base__TzPervasives.Clic.no_options
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "show" % string
                    (cons "known" % string (cons "script" % string []))))
                (apply
                  (let arg :=
                    Tezos_client_alpha.Client_proto_programs.Program.alias_param
                    in
                  fun eta => arg None None eta)
                  Tezos_base__TzPervasives.Clic.stop))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun function_parameter =>
                    match function_parameter with
                    | (_, program) =>
                      fun cctxt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_client_alpha.Client_proto_programs.Program.to_source
                            program)
                          (fun source =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Char_literal
                                      "010" % char
                                      CamlinternalFormatBasics.End_of_format))
                                  "%s
" % string) source)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_unit
                                end))
                    end
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Ask the node to run a script." % string
                (Tezos_base__TzPervasives.Clic.args7 trace_stack_switch
                  amount_arg source_arg payer_arg
                  Tezos_client_alpha.Client_proto_args.no_print_source_flag
                  custom_gas_flag
                  Tezos_client_alpha.Client_proto_args.entrypoint_arg)
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "run" % string (cons "script" % string [])))
                  (apply
                    (let arg :=
                      Tezos_client_alpha.Client_proto_programs.Program.source_param
                      in
                    fun eta => arg None None eta)
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "on" % string (cons "storage" % string [])))
                      (apply
                        (Tezos_base__TzPervasives.Clic.param "storage" % string
                          "the storage data" % string data_parameter)
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "and" % string (cons "input" % string [])))
                          (apply
                            (Tezos_base__TzPervasives.Clic.param
                              "input" % string "the input data" % string
                              data_parameter) Tezos_base__TzPervasives.Clic.stop))))))
                (fun function_parameter =>
                  match function_parameter with
                  |
                    (trace_exec, amount, source, payer, no_print_source, gas,
                      entrypoint) =>
                    fun program =>
                      fun storage =>
                        fun input =>
                          fun cctxt =>
                            let source :=
                              Tezos_base__TzPervasives.Option.map snd source in
                            let payer :=
                              Tezos_base__TzPervasives.Option.map snd payer in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (apply Lwt._return
                                (Tezos_micheline.Micheline_parser.no_parsing_error
                                  program))
                              (fun program =>
                                let show_source := negb no_print_source in
                                if trace_exec then
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_client_alpha.Client_proto_programs.trace
                                      cctxt send send (Some amount) program
                                      storage input source payer gas entrypoint
                                      tt)
                                    (fun res =>
                                      Tezos_client_alpha.Client_proto_programs.print_trace_result
                                        cctxt show_source program res)
                                else
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_client_alpha.Client_proto_programs.run
                                      cctxt send send (Some amount) program
                                      storage input source payer gas entrypoint
                                      tt)
                                    (fun res =>
                                      Tezos_client_alpha.Client_proto_programs.print_run_result
                                        cctxt show_source program res))
                  end))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some group)
                  "Ask the node to typecheck a script." % string
                  (Tezos_base__TzPervasives.Clic.args4 show_types_switch
                    emacs_mode_switch
                    Tezos_client_alpha.Client_proto_args.no_print_source_flag
                    custom_gas_flag)
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "typecheck" % string (cons "script" % string [])))
                    (apply
                      (let arg :=
                        Tezos_client_alpha.Client_proto_programs.Program.source_param
                        in
                      fun eta => arg None None eta)
                      Tezos_base__TzPervasives.Clic.stop))
                  (fun function_parameter =>
                    match function_parameter with
                    | (show_types, emacs_mode, no_print_source, original_gas) =>
                      fun program =>
                        fun cctxt =>
                          match program with
                          | (program, []) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (resolve_max_gas cctxt send original_gas)
                              (fun original_gas =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (Tezos_client_alpha.Client_proto_programs.typecheck_program
                                    cctxt send send (Some original_gas) program)
                                  (fun res =>
                                    Tezos_client_alpha.Client_proto_programs.print_typecheck_result
                                      emacs_mode show_types
                                      (negb no_print_source) program res cctxt))
                          | (parsed, errors) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format)
                                  "%a" % string)
                                (fun ppf =>
                                  fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                                        (negb no_print_source)
                                        (negb no_print_source) (Some parsed) ppf
                                        errors
                                    end) tt)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "syntax error in program" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "syntax error in program" % string)
                                end)
                          end
                    end))
                (cons
                  (Tezos_base__TzPervasives.Clic.command (Some group)
                    "Ask the node to typecheck a data expression." % string
                    (Tezos_base__TzPervasives.Clic.args2
                      Tezos_client_alpha.Client_proto_args.no_print_source_flag
                      custom_gas_flag)
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "typecheck" % string (cons "data" % string [])))
                      (apply
                        (Tezos_base__TzPervasives.Clic.param "data" % string
                          "the data to typecheck" % string data_parameter)
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "against" % string (cons "type" % string [])))
                          (apply
                            (Tezos_base__TzPervasives.Clic.param "type" % string
                              "the expected type" % string data_parameter)
                            Tezos_base__TzPervasives.Clic.stop))))
                    (fun function_parameter =>
                      match function_parameter with
                      | (no_print_source, custom_gas) =>
                        fun data =>
                          fun ty =>
                            fun cctxt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (resolve_max_gas cctxt send custom_gas)
                                (fun original_gas =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_client_alpha.Client_proto_programs.typecheck_data
                                      cctxt send send (Some original_gas) data
                                      ty tt)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | inl gas =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_box
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "<v 0>" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "<v 0>" % string))
                                                (CamlinternalFormatBasics.String_literal
                                                  "Well typed" % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@," % string 0 0)
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Gas remaining: " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Close_box
                                                          CamlinternalFormatBasics.End_of_format))))))
                                              "@[<v 0>Well typed@,Gas remaining: %a@]"
                                                % string)
                                            Tezos_protocol_alpha.Protocol.Alpha_context.Gas.pp
                                            gas)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.return_unit
                                            end)
                                      | inr errs =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.Alpha
                                                CamlinternalFormatBasics.End_of_format)
                                              "%a" % string)
                                            (Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                                              false (negb no_print_source) None)
                                            errs)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "ill-typed data" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "ill-typed data" % string)
                                            end)
                                      end))
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Clic.command (Some group)
                      "Ask the node to pack a data expression.
The returned hash is the same as what Michelson instruction `PACK` would have produced.
Also displays the result of hashing this packed data with `BLAKE2B`, `SHA256` or `SHA512` instruction."
                        % string
                      (Tezos_base__TzPervasives.Clic.args1 custom_gas_flag)
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "hash" % string (cons "data" % string [])))
                        (apply
                          (Tezos_base__TzPervasives.Clic.param "data" % string
                            "the data to hash" % string data_parameter)
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefixes
                              (cons "of" % string (cons "type" % string [])))
                            (apply
                              (Tezos_base__TzPervasives.Clic.param
                                "type" % string "type of the data" % string
                                data_parameter)
                              Tezos_base__TzPervasives.Clic.stop))))
                      (fun custom_gas =>
                        fun data =>
                          fun typ =>
                            fun cctxt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (resolve_max_gas cctxt send custom_gas)
                                (fun original_gas =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.Scripts.pack_data
                                      cctxt (send, send)
                                      ((expanded data), (expanded typ),
                                        (Some original_gas)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | inl (bytes, remaining_gas) =>
                                        let hash :=
                                          Tezos_protocol_alpha.Protocol.Script_expr_hash.hash_bytes
                                            None (cons string []) in
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Raw packed data: 0x" % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@," % string 0 0)
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Script-expression-ID-Hash: "
                                                        % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          (CamlinternalFormatBasics.Break
                                                            "@," % string 0 0)
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Raw Script-expression-ID-Hash: 0x"
                                                              % string
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                (CamlinternalFormatBasics.Break
                                                                  "@," % string
                                                                  0 0)
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "Ledger Blake2b hash: "
                                                                    % string
                                                                  (CamlinternalFormatBasics.String
                                                                    CamlinternalFormatBasics.No_padding
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      (CamlinternalFormatBasics.Break
                                                                        "@," %
                                                                          string
                                                                        0 0)
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "Raw Sha256 hash: 0x"
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Alpha
                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                            (CamlinternalFormatBasics.Break
                                                                              "@,"
                                                                                %
                                                                                string
                                                                              0
                                                                              0)
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              "Raw Sha512 hash: 0x"
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Alpha
                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                  (CamlinternalFormatBasics.Break
                                                                                    "@,"
                                                                                      %
                                                                                      string
                                                                                    0
                                                                                    0)
                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                    "Gas remaining: "
                                                                                      %
                                                                                      string
                                                                                    (CamlinternalFormatBasics.Alpha
                                                                                      CamlinternalFormatBasics.End_of_format))))))))))))))))))))
                                              "Raw packed data: 0x%a@,Script-expression-ID-Hash: %a@,Raw Script-expression-ID-Hash: 0x%a@,Ledger Blake2b hash: %s@,Raw Sha256 hash: 0x%a@,Raw Sha512 hash: 0x%a@,Gas remaining: %a"
                                                % string) Hex.pp
                                            (Hex.of_bytes None string)
                                            Tezos_protocol_alpha.Protocol.Script_expr_hash.pp
                                            hash Hex.pp
                                            (Hex.of_bytes None
                                              (Tezos_protocol_alpha.Protocol.Script_expr_hash.to_bytes
                                                hash))
                                            (Tezos_base__TzPervasives.Base58.raw_encode
                                              None
                                              (OCaml.Stdlib.reverse_apply
                                                (Tezos_base__TzPervasives.Blake2B.hash_bytes
                                                  None (cons string []))
                                                Tezos_base__TzPervasives.Blake2B.to_string))
                                            Hex.pp
                                            (Hex.of_bytes None
                                              (Tezos_protocol_alpha.Protocol.Environment.Raw_hashes.sha256
                                                string)) Hex.pp
                                            (Hex.of_bytes None
                                              (Tezos_protocol_alpha.Protocol.Environment.Raw_hashes.sha512
                                                string))
                                            Tezos_protocol_alpha.Protocol.Alpha_context.Gas.pp
                                            remaining_gas)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.return_unit
                                            end)
                                      | inr errs =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.Alpha
                                                CamlinternalFormatBasics.End_of_format)
                                              "%a" % string)
                                            (Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                                              false false None) errs)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "ill-formed data" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "ill-formed data" % string)
                                            end)
                                      end))))
                    (cons
                      (Tezos_base__TzPervasives.Clic.command (Some group)
                        "Parse a byte sequence (in hexadecimal notation) as a data expression, as per Michelson instruction `UNPACK`."
                          % string Tezos_base__TzPervasives.Clic.no_options
                        (apply
                          (Tezos_base__TzPervasives.Clic.prefixes
                            (cons "unpack" % string
                              (cons "michelson" % string
                                (cons "data" % string []))))
                          (apply
                            (bytes_parameter "bytes" % string
                              "the packed data to parse" % string)
                            Tezos_base__TzPervasives.Clic.stop))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            fun bytes =>
                              fun cctxt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (if
                                    Stdlib.op_exclamation_eq
                                      (Stdlib.Bytes.get string 0) "005" % char
                                    then
                                    Tezos_base__TzPervasives.failwith
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Not a piece of packed Michelson data (must start with `0x05`)"
                                            % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "Not a piece of packed Michelson data (must start with `0x05`)"
                                          % string)
                                  else
                                    Tezos_base__TzPervasives.return_unit)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      let bytes :=
                                        String.sub string 1
                                          (Z.sub (String.length string) 1) in
                                      match
                                        Tezos_base__TzPervasives.Data_encoding.Binary.of_bytes
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr_encoding
                                          string with
                                      | None =>
                                        Tezos_base__TzPervasives.failwith
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Could not decode bytes" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "Could not decode bytes" % string)
                                      | Some expr =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.Alpha
                                                CamlinternalFormatBasics.End_of_format)
                                              "%a" % string)
                                            Tezos_client_alpha.Michelson_v1_printer.print_expr_unwrapped
                                            expr)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.return_unit
                                            end)
                                      end
                                    end)
                          end))
                      (cons
                        (Tezos_base__TzPervasives.Clic.command (Some group)
                          "Sign a raw sequence of bytes and display it using the format expected by Michelson instruction `CHECK_SIGNATURE`."
                            % string Tezos_base__TzPervasives.Clic.no_options
                          (apply
                            (Tezos_base__TzPervasives.Clic.prefixes
                              (cons "sign" % string (cons "bytes" % string [])))
                            (apply
                              (bytes_parameter "data" % string
                                "the raw data to sign" % string)
                              (apply
                                (Tezos_base__TzPervasives.Clic.prefixes
                                  (cons "for" % string []))
                                (apply
                                  (let arg :=
                                    Tezos_client_base.Client_keys.Secret_key.source_param
                                    in
                                  fun eta => arg None None eta)
                                  Tezos_base__TzPervasives.Clic.stop))))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              fun bytes =>
                                fun sk =>
                                  fun cctxt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_client_base.Client_keys.sign cctxt
                                        None sk string)
                                      (fun signature =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Signature: " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  CamlinternalFormatBasics.End_of_format))
                                              "Signature: %a" % string)
                                            Tezos_base__TzPervasives.Signature.pp
                                            signature)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.return_unit
                                            end))
                            end))
                        (cons
                          (Tezos_base__TzPervasives.Clic.command (Some group)
                            "Check the signature of a byte sequence as per Michelson instruction `CHECK_SIGNATURE`."
                              % string
                            (Tezos_base__TzPervasives.Clic.args1
                              (Tezos_base__TzPervasives.Clic.switch
                                "Use only exit codes" % string (Some "q" % char)
                                "quiet" % string tt))
                            (apply
                              (Tezos_base__TzPervasives.Clic.prefixes
                                (cons "check" % string (cons "that" % string [])))
                              (apply
                                (bytes_parameter "bytes" % string
                                  "the signed data" % string)
                                (apply
                                  (Tezos_base__TzPervasives.Clic.prefixes
                                    (cons "was" % string
                                      (cons "signed" % string
                                        (cons "by" % string []))))
                                  (apply
                                    (let arg :=
                                      Tezos_client_base.Client_keys.Public_key.alias_param
                                        (Some "key" % string) in
                                    fun eta => arg None eta)
                                    (apply
                                      (Tezos_base__TzPervasives.Clic.prefixes
                                        (cons "to" % string
                                          (cons "produce" % string [])))
                                      (apply
                                        (Tezos_base__TzPervasives.Clic.param
                                          "signature" % string
                                          "the signature to check" % string
                                          signature_parameter)
                                        Tezos_base__TzPervasives.Clic.stop))))))
                            (fun quiet =>
                              fun bytes =>
                                fun function_parameter =>
                                  match function_parameter with
                                  | (_, (key_locator, _)) =>
                                    fun signature =>
                                      fun cctxt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_client_base.Client_keys.check
                                            None key_locator signature string)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | false =>
                                              send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "invalid signature" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "invalid signature" % string)
                                            | true =>
                                              if quiet then
                                                Tezos_base__TzPervasives.return_unit
                                              else
                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                  (send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "Signature check successfull."
                                                          % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "Signature check successfull."
                                                        % string))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_base__TzPervasives.return_unit
                                                    end)
                                            end)
                                  end))
                          (cons
                            (Tezos_base__TzPervasives.Clic.command (Some group)
                              "Ask the type of an entrypoint of a script." %
                                string
                              (Tezos_base__TzPervasives.Clic.args2
                                emacs_mode_switch
                                Tezos_client_alpha.Client_proto_args.no_print_source_flag)
                              (apply
                                (Tezos_base__TzPervasives.Clic.prefixes
                                  (cons "get" % string
                                    (cons "script" % string
                                      (cons "entrypoint" % string
                                        (cons "type" % string
                                          (cons "of" % string []))))))
                                (apply
                                  (Tezos_base__TzPervasives.Clic.string
                                    "entrypoint" % string
                                    "the entrypoint to describe" % string)
                                  (apply
                                    (Tezos_base__TzPervasives.Clic.prefixes
                                      (cons "for" % string []))
                                    (apply
                                      (let arg :=
                                        Tezos_client_alpha.Client_proto_programs.Program.source_param
                                        in
                                      fun eta => arg None None eta)
                                      Tezos_base__TzPervasives.Clic.stop))))
                              (fun function_parameter =>
                                match function_parameter with
                                | (emacs_mode, no_print_source) =>
                                  fun entrypoint =>
                                    fun program =>
                                      fun cctxt =>
                                        match program with
                                        | (program, []) =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Tezos_client_alpha.Client_proto_programs.entrypoint_type
                                              cctxt send send program entrypoint)
                                            (fun entrypoint_type =>
                                              Tezos_client_alpha.Client_proto_programs.print_entrypoint_type
                                                cctxt emacs_mode None
                                                (negb no_print_source) program
                                                entrypoint entrypoint_type)
                                        | (parsed, errors) =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.Alpha
                                                  CamlinternalFormatBasics.End_of_format)
                                                "%a" % string)
                                              (fun ppf =>
                                                fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                                                      (negb no_print_source)
                                                      (negb no_print_source)
                                                      (Some parsed) ppf errors
                                                  end) tt)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "syntax error in program"
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "syntax error in program" %
                                                      string)
                                              end)
                                        end
                                end))
                            (cons
                              (Tezos_base__TzPervasives.Clic.command
                                (Some group)
                                "Ask the node to list the entrypoints of a script."
                                  % string
                                (Tezos_base__TzPervasives.Clic.args2
                                  emacs_mode_switch
                                  Tezos_client_alpha.Client_proto_args.no_print_source_flag)
                                (apply
                                  (Tezos_base__TzPervasives.Clic.prefixes
                                    (cons "get" % string
                                      (cons "script" % string
                                        (cons "entrypoints" % string
                                          (cons "for" % string [])))))
                                  (apply
                                    (let arg :=
                                      Tezos_client_alpha.Client_proto_programs.Program.source_param
                                      in
                                    fun eta => arg None None eta)
                                    Tezos_base__TzPervasives.Clic.stop))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (emacs_mode, no_print_source) =>
                                    fun program =>
                                      fun cctxt =>
                                        match program with
                                        | (program, []) =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (Tezos_client_alpha.Client_proto_programs.list_entrypoints
                                              cctxt send send program)
                                            (fun entrypoints =>
                                              Tezos_client_alpha.Client_proto_programs.print_entrypoints_list
                                                cctxt emacs_mode None
                                                (negb no_print_source) program
                                                entrypoints)
                                        | (parsed, errors) =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.Alpha
                                                  CamlinternalFormatBasics.End_of_format)
                                                "%a" % string)
                                              (fun ppf =>
                                                fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                                                      (negb no_print_source)
                                                      (negb no_print_source)
                                                      (Some parsed) ppf errors
                                                  end) tt)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "syntax error in program"
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "syntax error in program" %
                                                      string)
                                              end)
                                        end
                                  end))
                              (cons
                                (Tezos_base__TzPervasives.Clic.command
                                  (Some group)
                                  "Ask the node to list the unreachable pathsin a script's parameter type."
                                    % string
                                  (Tezos_base__TzPervasives.Clic.args2
                                    emacs_mode_switch
                                    Tezos_client_alpha.Client_proto_args.no_print_source_flag)
                                  (apply
                                    (Tezos_base__TzPervasives.Clic.prefixes
                                      (cons "get" % string
                                        (cons "script" % string
                                          (cons "unreachable" % string
                                            (cons "paths" % string
                                              (cons "for" % string []))))))
                                    (apply
                                      (let arg :=
                                        Tezos_client_alpha.Client_proto_programs.Program.source_param
                                        in
                                      fun eta => arg None None eta)
                                      Tezos_base__TzPervasives.Clic.stop))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (emacs_mode, no_print_source) =>
                                      fun program =>
                                        fun cctxt =>
                                          match program with
                                          | (program, []) =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (Tezos_client_alpha.Client_proto_programs.list_unreachables
                                                cctxt send send program)
                                              (fun entrypoints =>
                                                Tezos_client_alpha.Client_proto_programs.print_unreachables
                                                  cctxt emacs_mode None
                                                  (negb no_print_source) program
                                                  entrypoints)
                                          | (parsed, errors) =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.Alpha
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "%a" % string)
                                                (fun ppf =>
                                                  fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_client_alpha.Michelson_v1_error_reporter.report_errors
                                                        (negb no_print_source)
                                                        (negb no_print_source)
                                                        (Some parsed) ppf errors
                                                    end) tt)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "syntax error in program"
                                                          % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "syntax error in program"
                                                        % string)
                                                end)
                                          end
                                    end)) [])))))))))))))
  end.
src/proto_alpha/lib_client_commands/client_proto_programs_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val commands : unit -> Protocol_client_context.full Clic.command list
src/proto_alpha/lib_client_commands/client_proto_programs_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter commands :
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full).
src/proto_alpha/lib_delegate/client_baking_blocks.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type block_info = {
  hash : Block_hash.t;
  chain_id : Chain_id.t;
  predecessor : Block_hash.t;
  fitness : Bytes.t list;
  timestamp : Time.Protocol.t;
  protocol : Protocol_hash.t;
  next_protocol : Protocol_hash.t;
  proto_level : int;
  level : Raw_level.t;
  context : Context_hash.t;
}

let raw_info cctxt ?(chain = `Main) hash shell_header =
  let block = `Hash (hash, 0) in
  Shell_services.Chain.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Shell_services.Blocks.protocols cctxt ~chain ~block ()
  >>=? fun {current_protocol = protocol; next_protocol} ->
  let { Tezos_base.Block_header.predecessor;
        fitness;
        timestamp;
        level;
        context;
        proto_level;
        _ } =
    shell_header
  in
  match Raw_level.of_int32 level with
  | Ok level ->
      return
        {
          hash;
          chain_id;
          predecessor;
          fitness;
          timestamp;
          protocol;
          next_protocol;
          proto_level;
          level;
          context;
        }
  | Error _ ->
      failwith "Cannot convert level into int32"

let info cctxt ?(chain = `Main) block =
  Shell_services.Blocks.hash cctxt ~chain ~block ()
  >>=? fun hash ->
  Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
  >>=? fun shell_header -> raw_info cctxt ~chain hash shell_header

module Block_seen_event = struct
  type t = {
    hash : Block_hash.t;
    header : Tezos_base.Block_header.t;
    occurrence : [`Valid_blocks of Chain_id.t | `Heads];
  }

  let make hash header occurrence () = {hash; header; occurrence}

  module Definition = struct
    let name = "block-seen-" ^ Protocol.name

    type nonrec t = t

    let encoding =
      let open Data_encoding in
      let v0_encoding =
        conv
          (function {hash; header; occurrence} -> (hash, occurrence, header))
          (fun (b, o, h) -> make b h o ())
          (obj3
             (req "hash" Block_hash.encoding)
             (* Occurrence has to come before header, because:
                (Invalid_argument
                   "Cannot merge two objects when the left element is of
                    variable length and the right one of dynamic
                    length. You should use the reverse order, or wrap the
                    second one with Data_encoding.dynamic_size.") *)
             (req
                "occurrence"
                (union
                   [ case
                       ~title:"heads"
                       (Tag 0)
                       (obj1 (req "occurrence-kind" (constant "heads")))
                       (function `Heads -> Some () | _ -> None)
                       (fun () -> `Heads);
                     case
                       ~title:"valid-blocks"
                       (Tag 1)
                       (obj2
                          (req "occurrence-kind" (constant "valid-blocks"))
                          (req "chain-id" Chain_id.encoding))
                       (function
                         | `Valid_blocks ch -> Some ((), ch) | _ -> None)
                       (fun ((), ch) -> `Valid_blocks ch) ]))
             (req "header" Tezos_base.Block_header.encoding))
      in
      With_version.(encoding ~name (first_version v0_encoding))

    let pp ppf {hash; _} =
      Format.fprintf ppf "Saw block %a" Block_hash.pp_short hash

    let doc = "Block observed while monitoring a blockchain."

    include Internal_event.Event_defaults
  end

  module Event = Internal_event.Make (Definition)
end

let monitor_valid_blocks cctxt ?chains ?protocols ~next_protocols () =
  Monitor_services.valid_blocks cctxt ?chains ?protocols ?next_protocols ()
  >>=? fun (block_stream, _stop) ->
  return
    (Lwt_stream.map_s
       (fun ((chain, block), header) ->
         Block_seen_event.(
           Event.emit (make block header (`Valid_blocks chain)))
         >>=? fun () ->
         raw_info
           cctxt
           ~chain:(`Hash chain)
           block
           header.Tezos_base.Block_header.shell)
       block_stream)

let monitor_heads cctxt ~next_protocols chain =
  Monitor_services.heads cctxt ?next_protocols chain
  >>=? fun (block_stream, _stop) ->
  return
    (Lwt_stream.map_s
       (fun (block, ({Tezos_base.Block_header.shell; _} as header)) ->
         Block_seen_event.(Event.emit (make block header `Heads))
         >>=? fun () -> raw_info cctxt ~chain block shell)
       block_stream)

let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () =
  Shell_services.Blocks.hash cctxt ~chain ~block ()
  >>=? fun hash ->
  Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
  >>=? fun {level; _} ->
  Alpha_services.Helpers.levels_in_current_cycle cctxt ~offset (chain, block)
  >>= function
  | Error (RPC_context.Not_found _ :: _) ->
      return_nil
  | Error _ as err ->
      Lwt.return err
  | Ok (first, last) ->
      let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in
      Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length ()
      >>=? fun blocks ->
      let blocks =
        List.remove
          (length - Int32.to_int (Raw_level.diff last first))
          (List.hd blocks)
      in
      if Int32.equal level (Raw_level.to_int32 last) then
        return (hash :: blocks)
      else return blocks
src/proto_alpha/lib_delegate/client_baking_blocks.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Record block_info := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  chain_id : Tezos_base__TzPervasives.Chain_id.t;
  predecessor : Tezos_base__TzPervasives.Block_hash.t;
  fitness : list Stdlib.Bytes.t;
  timestamp : Tezos_base__TzPervasives.Time.Protocol.t;
  protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  next_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  proto_level : Z;
  level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t;
  context : Tezos_base__TzPervasives.Context_hash.t }.

Definition raw_info {E F i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (op_star_o_p_t_star : option Tezos_shell_services.Shell_services.Chain.chain)
  : Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base.Block_header.shell_header ->
      Lwt.t (Tezos_base__TzPervasives.tzresult block_info) :=
  let chain :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end in
  fun hash =>
    fun shell_header =>
      let block := variant in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell_services.Shell_services.Chain.chain_id cctxt (Some chain)
          tt)
        (fun chain_id =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_shell_services.Shell_services.Blocks.protocols cctxt
              (Some chain) (Some block) tt)
            (fun function_parameter =>
              match function_parameter with
              | {|
                current_protocol := protocol;
                  next_protocol := next_protocol
                  |} =>
                match shell_header with
                | {|
                  Tezos_base.Block_header.level := level;
                    Tezos_base.Block_header.proto_level := proto_level;
                    Tezos_base.Block_header.predecessor := predecessor;
                    Tezos_base.Block_header.timestamp := timestamp;
                    Tezos_base.Block_header.fitness := fitness;
                    Tezos_base.Block_header.context := context
                    |} =>
                  match
                    Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.of_int32
                      level with
                  | inl level =>
                    Tezos_base__TzPervasives._return
                      {| hash := hash; chain_id := chain_id;
                        predecessor := predecessor; fitness := fitness;
                        timestamp := timestamp; protocol := protocol;
                        next_protocol := next_protocol;
                        proto_level := proto_level; level := level;
                        context := context |}
                  | inr _ =>
                    Tezos_base__TzPervasives.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Cannot convert level into int32" % string
                          CamlinternalFormatBasics.End_of_format)
                        "Cannot convert level into int32" % string)
                  end
                end
              end)).

Definition info {E F i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (op_star_o_p_t_star : option Tezos_shell_services__Block_services.chain)
  : Tezos_shell_services__Block_services.block ->
    Lwt.t (Tezos_base__TzPervasives.tzresult block_info) :=
  let chain :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end in
  fun block =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_shell_services.Shell_services.Blocks.hash cctxt (Some chain)
        (Some block) tt)
      (fun hash =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_shell_services.Shell_services.Blocks.Header.shell_header cctxt
            (Some chain) (Some block) tt)
          (fun shell_header => raw_info cctxt (Some chain) hash shell_header)).

Module Block_seen_event.
  Record t := {
    hash : Tezos_base__TzPervasives.Block_hash.t;
    header : Tezos_base.Block_header.t;
    occurrence : variant }.
  
  Definition make
    (hash : Tezos_base__TzPervasives.Block_hash.t)
    (header : Tezos_base.Block_header.t) (occurrence : variant)
    (function_parameter : unit) : t :=
    match function_parameter with
    | tt => {| hash := hash; header := header; occurrence := occurrence |}
    end.
  
  Module Definition.
    Definition name : string :=
      String.append "block-seen-" % string Tezos_protocol_alpha.Protocol.name.
    
    Definition t := t.
    
    Definition encoding : Tezos_data_encoding__Data_encoding.encoding t :=
      let v0_encoding :=
        Tezos_base__TzPervasives.Data_encoding.conv
          (fun function_parameter =>
            match function_parameter with
            | {| hash := hash; header := header; occurrence := occurrence |} =>
              (hash, occurrence, header)
            end)
          (fun function_parameter =>
            match function_parameter with
            | (b, o, h) => make b h o tt
            end) None
          (Tezos_base__TzPervasives.Data_encoding.obj3
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "hash" % string Tezos_base__TzPervasives.Block_hash.encoding)
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "occurrence" % string
              (Tezos_base__TzPervasives.Data_encoding.union None
                (cons
                  (Tezos_base__TzPervasives.Data_encoding.case "heads" % string
                    None (Tag 0)
                    (Tezos_base__TzPervasives.Data_encoding.obj1
                      (Tezos_base__TzPervasives.Data_encoding.req None None
                        "occurrence-kind" % string
                        (Tezos_base__TzPervasives.Data_encoding.constant
                          "heads" % string)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Heads => Some tt
                      | _ => None
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => variant
                      end))
                  (cons
                    (Tezos_base__TzPervasives.Data_encoding.case
                      "valid-blocks" % string None (Tag 1)
                      (Tezos_base__TzPervasives.Data_encoding.obj2
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "occurrence-kind" % string
                          (Tezos_base__TzPervasives.Data_encoding.constant
                            "valid-blocks" % string))
                        (Tezos_base__TzPervasives.Data_encoding.req None None
                          "chain-id" % string
                          Tezos_base__TzPervasives.Chain_id.encoding))
                      (fun function_parameter =>
                        match function_parameter with
                        | Valid_blocks ch => Some (tt, ch)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | (tt, ch) => variant
                        end)) []))))
            (Tezos_base__TzPervasives.Data_encoding.req None None
              "header" % string Tezos_base.Block_header.encoding)) in
      Tezos_base__TzPervasives.Data_encoding.With_version.encoding name
        (Tezos_base__TzPervasives.Data_encoding.With_version.first_version
          v0_encoding).
    
    Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
      : unit :=
      match function_parameter with
      | {| hash := hash |} =>
        Stdlib.Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Saw block " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "Saw block %a" % string)
          Tezos_base__TzPervasives.Block_hash.pp_short hash
      end.
    
    Definition doc : string :=
      "Block observed while monitoring a blockchain." % string.
  End Definition.
End Block_seen_event.

Definition monitor_valid_blocks {E F G i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) * G)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) * G))
  (chains : option (list Tezos_shell_services.Chain_services.chain))
  (protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
  (next_protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Lwt_stream.t (Tezos_base__TzPervasives.tzresult block_info))) :=
  match function_parameter with
  | tt =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_shell_services.Monitor_services.valid_blocks cctxt chains protocols
        next_protocols tt)
      (fun function_parameter =>
        match function_parameter with
        | (block_stream, _stop) =>
          Tezos_base__TzPervasives._return
            (Lwt_stream.map_s
              (fun function_parameter =>
                match function_parameter with
                | ((chain, block), header) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Block_seen_event.Event.emit None
                      (Block_seen_event.make block header variant))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        raw_info cctxt (Some variant) block
                          (Tezos_base.Block_header.shell header)
                      end)
                end) block_stream)
        end)
  end.

Definition monitor_heads {E F G i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) * G)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) * G))
  (next_protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
  (chain : Tezos_shell_services.Chain_services.chain)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Lwt_stream.t (Tezos_base__TzPervasives.tzresult block_info))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell_services.Monitor_services.heads cctxt next_protocols chain)
    (fun function_parameter =>
      match function_parameter with
      | (block_stream, _stop) =>
        Tezos_base__TzPervasives._return
          (Lwt_stream.map_s
            (fun function_parameter =>
              match function_parameter with
              | (block, {| Tezos_base.Block_header.shell := shell |} as header)
                =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Block_seen_event.Event.emit None
                    (Block_seen_event.make block header variant))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => raw_info cctxt (Some chain) block shell
                    end)
              end) block_stream)
      end).

Definition blocks_from_current_cycle {D F H J L M a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (variant * Tezos_shell_services__Block_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (variant * Tezos_shell_services__Block_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (variant * Tezos_shell_services__Block_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (variant * Tezos_shell_services__Block_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
              (L * p * q * i * o)) * M))))) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (variant * Tezos_shell_services__Block_services.block) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (variant * Tezos_shell_services__Block_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (variant * Tezos_shell_services__Block_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (variant * Tezos_shell_services__Block_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) * M)))))
  (op_star_o_p_t_star : option variant)
  : Tezos_shell_services__Block_services.block ->
    (option int32) ->
      unit ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list Tezos_base__TzPervasives.Block_hash.t)) :=
  let chain :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => variant
    end in
  fun block =>
    fun op_star_o_p_t_star =>
      let offset :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => 0
        end in
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_shell_services.Shell_services.Blocks.hash cctxt (Some chain)
              (Some block) tt)
            (fun hash =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_shell_services.Shell_services.Blocks.Header.shell_header
                  cctxt (Some chain) (Some block) tt)
                (fun function_parameter =>
                  match function_parameter with
                  | {| level := level |} =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.levels_in_current_cycle
                        cctxt (Some offset) (chain, block))
                      (fun function_parameter =>
                        match function_parameter with
                        | inr (cons (RPC_context.Not_found _) _) =>
                          Tezos_base__TzPervasives.return_nil
                        | (inr _) as err => Lwt._return err
                        | inl (first, last) =>
                          let length :=
                            Stdlib.Int32.to_int
                              (Stdlib.Int32.sub level
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
                                  first)) in
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_shell_services.Shell_services.Blocks.list
                              cctxt (Some chain) (Some (cons hash []))
                              (Some length) None tt)
                            (fun blocks =>
                              let blocks :=
                                Tezos_base__TzPervasives.List.remove
                                  (Z.sub length
                                    (Stdlib.Int32.to_int
                                      (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.diff
                                        last first)))
                                  (Tezos_base__TzPervasives.List.hd blocks) in
                              if
                                Stdlib.Int32.equal level
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
                                    last) then
                                Tezos_base__TzPervasives._return
                                  (cons hash blocks)
                              else
                                Tezos_base__TzPervasives._return blocks)
                        end)
                  end))
        end.
src/proto_alpha/lib_delegate/client_baking_blocks.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type block_info = {
  hash : Block_hash.t;
  chain_id : Chain_id.t;
  predecessor : Block_hash.t;
  fitness : Bytes.t list;
  timestamp : Time.Protocol.t;
  protocol : Protocol_hash.t;
  next_protocol : Protocol_hash.t;
  proto_level : int;
  level : Raw_level.t;
  context : Context_hash.t;
}

val info :
  #Protocol_client_context.rpc_context ->
  ?chain:Chain_services.chain ->
  Block_services.block ->
  block_info tzresult Lwt.t

val monitor_valid_blocks :
  #Protocol_client_context.rpc_context ->
  ?chains:Chain_services.chain list ->
  ?protocols:Protocol_hash.t list ->
  next_protocols:Protocol_hash.t list option ->
  unit ->
  block_info tzresult Lwt_stream.t tzresult Lwt.t

val monitor_heads :
  #Protocol_client_context.rpc_context ->
  next_protocols:Protocol_hash.t list option ->
  Chain_services.chain ->
  block_info tzresult Lwt_stream.t tzresult Lwt.t

val blocks_from_current_cycle :
  #Protocol_client_context.rpc_context ->
  ?chain:Chain_services.chain ->
  Block_services.block ->
  ?offset:int32 ->
  unit ->
  Block_hash.t list tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_blocks.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record block_info := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  chain_id : Tezos_base__TzPervasives.Chain_id.t;
  predecessor : Tezos_base__TzPervasives.Block_hash.t;
  fitness : list Stdlib.Bytes.t;
  timestamp : Tezos_base__TzPervasives.Time.Protocol.t;
  protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  next_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  proto_level : Z;
  level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t;
  context : Tezos_base__TzPervasives.Context_hash.t }.

Parameter info : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  (option Tezos_shell_services.Chain_services.chain) ->
    Tezos_shell_services.Block_services.block ->
      Lwt.t (Tezos_base__TzPervasives.tzresult block_info).

Parameter monitor_valid_blocks : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  (option (list Tezos_shell_services.Chain_services.chain)) ->
    (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
      (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
        unit ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (Lwt_stream.t (Tezos_base__TzPervasives.tzresult block_info))).

Parameter monitor_heads : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
    Tezos_shell_services.Chain_services.chain ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Lwt_stream.t (Tezos_base__TzPervasives.tzresult block_info))).

Parameter blocks_from_current_cycle : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        (Uri.t *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              ((Tezos_rpc.RPC_service.meth ->
                (option Tezos_data_encoding.Data_encoding.json) ->
                  Uri.t ->
                    Lwt.t
                      (Tezos_rpc.RPC_context.rest_result
                        Tezos_data_encoding.Data_encoding.json
                        (option Tezos_data_encoding.Data_encoding.json))) * _))))))))
  * _) ->
  (option Tezos_shell_services.Chain_services.chain) ->
    Tezos_shell_services.Block_services.block ->
      (option int32) ->
        unit ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (list Tezos_base__TzPervasives.Block_hash.t)).
src/proto_alpha/lib_delegate/client_baking_denunciation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.denunciation"
end)

open Protocol
open Alpha_context
open Protocol_client_context
open Client_baking_blocks
open Logging

module HLevel = Hashtbl.Make (struct
  type t = Chain_id.t * Raw_level.t

  let equal (c, l) (c', l') = Chain_id.equal c c' && Raw_level.equal l l'

  let hash (c, lvl) = Hashtbl.hash (c, lvl)
end)

module Delegate_Map = Map.Make (Signature.Public_key_hash)

type state = {
  (* Endorsements seen so far *)
  endorsements_table : Kind.endorsement operation Delegate_Map.t HLevel.t;
  (* Blocks received so far *)
  blocks_table : Block_hash.t Delegate_Map.t HLevel.t;
  (* Maximum delta of level to register *)
  preserved_levels : int;
  (* Highest level seen in a block *)
  mutable highest_level_encountered : Raw_level.t;
}

let create_state ~preserved_levels =
  Lwt.return
    {
      endorsements_table = HLevel.create preserved_levels;
      blocks_table = HLevel.create preserved_levels;
      preserved_levels;
      highest_level_encountered = Raw_level.root (* 0l *);
    }

(* We choose a previous offset (5 blocks from head) to ensure that the
   injected operation is branched from a valid predecessor. *)
let get_block_offset level =
  match Environment.wrap_error (Raw_level.of_int32 5l) with
  | Ok min_level ->
      Lwt.return (if Raw_level.(level < min_level) then `Head 0 else `Head 5)
  | Error errs ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Invalid level conversion : %a"
            -% t event "invalid_level_conversion"
            -% a errs_tag errs)
      >>= fun () -> Lwt.return (`Head 0)

let process_endorsements (cctxt : #Protocol_client_context.full) state
    (endorsements : Alpha_block_services.operation list) level =
  iter_s
    (fun {Alpha_block_services.shell; chain_id; receipt; hash; protocol_data; _}
         ->
      let chain = `Hash chain_id in
      match (protocol_data, receipt) with
      | ( Operation_data
            ({contents = Single (Endorsement _); _} as protocol_data),
          Apply_results.(
            Operation_metadata
              {contents = Single_result (Endorsement_result {delegate; _})}) )
        -> (
          let new_endorsement : Kind.endorsement Alpha_context.operation =
            {shell; protocol_data}
          in
          let map =
            match
              HLevel.find_opt state.endorsements_table (chain_id, level)
            with
            | None ->
                Delegate_Map.empty
            | Some x ->
                x
          in
          (* If a previous endorsement made by this pkh is found for
             the same level we inject a double_endorsement *)
          match Delegate_Map.find_opt delegate map with
          | None ->
              return
              @@ HLevel.add
                   state.endorsements_table
                   (chain_id, level)
                   (Delegate_Map.add delegate new_endorsement map)
          | Some existing_endorsement
            when Block_hash.(
                   existing_endorsement.shell.branch
                   <> new_endorsement.shell.branch) ->
              get_block_offset level
              >>= fun block ->
              Alpha_block_services.hash cctxt ~chain ~block ()
              >>=? fun block_hash ->
              Alpha_services.Forge.double_endorsement_evidence
                cctxt
                (`Hash chain_id, block)
                ~branch:block_hash
                ~op1:existing_endorsement
                ~op2:new_endorsement
                ()
              >>=? fun bytes ->
              let bytes = Signature.concat bytes Signature.zero in
              lwt_log_notice
                Tag.DSL.(
                  fun f ->
                    f "Double endorsement detected"
                    -% t event "double_endorsement_detected"
                    -% t
                         conflicting_endorsements_tag
                         (existing_endorsement, new_endorsement))
              >>= fun () ->
              (* A denunciation may have already occured *)
              Shell_services.Injection.operation cctxt ~chain bytes
              >>=? fun op_hash ->
              lwt_log_notice
                Tag.DSL.(
                  fun f ->
                    f "Double endorsement evidence injected %a"
                    -% t event "double_endorsement_denounced"
                    -% t signed_operation_tag bytes
                    -% a Operation_hash.Logging.tag op_hash)
              >>= fun () ->
              return
              @@ HLevel.replace
                   state.endorsements_table
                   (chain_id, level)
                   (Delegate_Map.add delegate new_endorsement map)
          | Some _ ->
              (* This endorsement is already present in another
                   block but endorse the same predecessor *)
              return_unit )
      | _ ->
          lwt_log_error
            Tag.DSL.(
              fun f ->
                f "Inconsistent endorsement found %a"
                -% t event "inconsistent_endorsement"
                -% a Operation_hash.Logging.tag hash)
          >>= fun () -> return_unit)
    endorsements
  >>=? fun () -> return_unit

let process_block (cctxt : #Protocol_client_context.full) state
    (header : Alpha_block_services.block_info) =
  let { Alpha_block_services.chain_id;
        hash;
        metadata = {protocol_data = {baker; level = {level; _}; _}; _};
        _ } =
    header
  in
  let chain = `Hash chain_id in
  let map =
    match HLevel.find_opt state.blocks_table (chain_id, level) with
    | None ->
        Delegate_Map.empty
    | Some x ->
        x
  in
  match Delegate_Map.find_opt baker map with
  | None ->
      return
      @@ HLevel.add
           state.blocks_table
           (chain_id, level)
           (Delegate_Map.add baker hash map)
  | Some existing_hash when Block_hash.( = ) existing_hash hash ->
      (* This case should never happen *)
      lwt_debug
        Tag.DSL.(
          fun f ->
            f
              "Double baking detected but block hashes are equivalent. \
               Skipping..."
            -% t event "double_baking_but_not")
      >>= fun () ->
      return
      @@ HLevel.replace
           state.blocks_table
           (chain_id, level)
           (Delegate_Map.add baker hash map)
  | Some existing_hash ->
      (* If a previous endorsement made by this pkh is found for
           the same level we inject a double_endorsement *)
      Alpha_block_services.header
        cctxt
        ~chain
        ~block:(`Hash (existing_hash, 0))
        ()
      >>=? fun ({shell; protocol_data; _} : Alpha_block_services.block_header) ->
      let bh1 = {Alpha_context.Block_header.shell; protocol_data} in
      Alpha_block_services.header cctxt ~chain ~block:(`Hash (hash, 0)) ()
      >>=? fun ({shell; protocol_data; _} : Alpha_block_services.block_header) ->
      let bh2 = {Alpha_context.Block_header.shell; protocol_data} in
      (* If the blocks are on different chains then skip it *)
      get_block_offset level
      >>= fun block ->
      Alpha_block_services.hash cctxt ~chain ~block ()
      >>=? fun block_hash ->
      Alpha_services.Forge.double_baking_evidence
        cctxt
        (chain, block)
        ~branch:block_hash
        ~bh1
        ~bh2
        ()
      >>=? fun bytes ->
      let bytes = Signature.concat bytes Signature.zero in
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "Double baking detected" -% t event "double_baking_detected")
      >>= fun () ->
      (* A denunciation may have already occured *)
      Shell_services.Injection.operation cctxt ~chain bytes
      >>=? fun op_hash ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "Double baking evidence injected %a"
            -% t event "double_baking_denounced"
            -% t signed_operation_tag bytes
            -% a Operation_hash.Logging.tag op_hash)
      >>= fun () ->
      return
      @@ HLevel.replace
           state.blocks_table
           (chain_id, level)
           (Delegate_Map.add baker hash map)

(* Remove levels that are lower than the [highest_level_encountered] minus [preserved_levels] *)
let cleanup_old_operations state =
  let highest_level_encountered =
    Int32.to_int (Raw_level.to_int32 state.highest_level_encountered)
  in
  let diff = highest_level_encountered - state.preserved_levels in
  let threshold =
    if diff < 0 then Raw_level.root
    else
      Raw_level.of_int32 (Int32.of_int diff)
      |> function Ok threshold -> threshold | Error _ -> Raw_level.root
  in
  let filter hmap =
    HLevel.filter_map_inplace
      (fun (_, level) x ->
        if Raw_level.(level < threshold) then None else Some x)
      hmap
  in
  filter state.endorsements_table ;
  filter state.blocks_table ;
  ()

let endorsements_index = 0

(* Each new block is processed :
   - Checking that every endorser operated only once at this level
   - Checking that every baker injected only once at this level
*)
let process_new_block (cctxt : #Protocol_client_context.full) state
    {hash; chain_id; level; protocol; next_protocol; _} =
  if Protocol_hash.(protocol <> next_protocol) then
    lwt_log_error
      Tag.DSL.(
        fun f ->
          f "Protocol changing detected. Skipping the block."
          -% t event "protocol_change_detected"
        (* TODO which protocols -- in tag *))
    >>= fun () -> return_unit
  else
    lwt_debug
      Tag.DSL.(
        fun f ->
          f "Block level : %a"
          -% t event "accuser_saw_block"
          -% a level_tag level
          -% t Block_hash.Logging.tag hash)
    >>= fun () ->
    let chain = `Hash chain_id in
    let block = `Hash (hash, 0) in
    state.highest_level_encountered <-
      Raw_level.max level state.highest_level_encountered ;
    (* Processing blocks *)
    Alpha_block_services.info cctxt ~chain ~block ()
    >>= (function
          | Ok block_info ->
              process_block cctxt state block_info
          | Error errs ->
              lwt_log_error
                Tag.DSL.(
                  fun f ->
                    f "Error while fetching operations in block %a@\n%a"
                    -% t event "fetch_operations_error"
                    -% a Block_hash.Logging.tag hash
                    -% a errs_tag errs)
              >>= fun () -> return_unit)
    >>=? fun () ->
    (* Processing endorsements *)
    Alpha_block_services.Operations.operations cctxt ~chain ~block ()
    >>= (function
          | Ok operations ->
              if List.length operations > endorsements_index then
                let endorsements = List.nth operations endorsements_index in
                process_endorsements cctxt state endorsements level
              else return_unit
          | Error errs ->
              lwt_log_error
                Tag.DSL.(
                  fun f ->
                    f "Error while fetching operations in block %a@\n%a"
                    -% t event "fetch_operations_error"
                    -% a Block_hash.Logging.tag hash
                    -% a errs_tag errs)
              >>= fun () -> return_unit)
    >>=? fun () ->
    cleanup_old_operations state ;
    return_unit

let create (cctxt : #Protocol_client_context.full) ~preserved_levels
    valid_blocks_stream =
  let process_block cctxt state bi =
    process_new_block cctxt state bi
    >>= function
    | Ok () ->
        lwt_log_notice
          Tag.DSL.(
            fun f ->
              f "Block %a registered"
              -% t event "accuser_processed_block"
              -% a Block_hash.Logging.tag bi.Client_baking_blocks.hash)
        >>= return
    | Error errs ->
        lwt_log_error
          Tag.DSL.(
            fun f ->
              f "Error while processing block %a@\n%a"
              -% t event "accuser_block_error"
              -% a Block_hash.Logging.tag bi.hash
              -% a errs_tag errs)
        >>= return
  in
  let state_maker _ = create_state ~preserved_levels >>= return in
  Client_baking_scheduling.main
    ~name:"accuser"
    ~cctxt
    ~stream:valid_blocks_stream
    ~state_maker
    ~pre_loop:(fun _ _ _ -> return_unit)
    ~compute_timeout:(fun _ -> Lwt_utils.never_ending ())
    ~timeout_k:(fun _ _ () -> return_unit)
    ~event_k:process_block
src/proto_alpha/lib_delegate/client_baking_denunciation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_baking_alpha.Client_baking_blocks.

Import Tezos_baking_alpha.Logging.

Record state := {
  endorsements_table :
    HLevel.t
      (Delegate_Map.t
        (Tezos_protocol_alpha.Protocol.Alpha_context.operation
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement));
  blocks_table : HLevel.t (Delegate_Map.t Tezos_base__TzPervasives.Block_hash.t);
  preserved_levels : Z;
  highest_level_encountered :
    Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t }.

Definition create_state (preserved_levels : Z) : Lwt.t state :=
  Lwt._return
    {| endorsements_table := HLevel.create preserved_levels;
      blocks_table := HLevel.create preserved_levels;
      preserved_levels := preserved_levels;
      highest_level_encountered :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.root |}.

Definition get_block_offset
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  : Lwt.t variant :=
  match
    Tezos_protocol_alpha.Protocol.Environment.wrap_error
      (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.of_int32 5) with
  | inl min_level =>
    Lwt._return
      (if
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.op_lt level
          min_level then
        variant
      else
        variant)
  | inr errs =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (lwt_log_error
        (fun f =>
          Tag.DSL.op_minus_percent
            (Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Invalid level conversion : " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "Invalid level conversion : %a" % string))
              (Tag.DSL.t event "invalid_level_conversion" % string))
            (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs)))
      (fun function_parameter =>
        match function_parameter with
        | tt => Lwt._return variant
        end)
  end.

Definition process_endorsements {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (state : state)
  (endorsements :
    list
      Tezos_client_alpha.Protocol_client_context.Alpha_block_services.operation)
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.iter_s
      (fun function_parameter =>
        match function_parameter with
        | {|
          Alpha_block_services.chain_id := chain_id;
            Alpha_block_services.hash := hash;
            Alpha_block_services.shell := shell;
            Alpha_block_services.protocol_data := protocol_data;
            Alpha_block_services.receipt := receipt
            |} =>
          let chain := variant in
          match (protocol_data, receipt) with
          |
            (Operation_data
              ({| contents := Single (Endorsement _) |} as protocol_data),
              Operation_metadata {|
                contents := Single_result (Endorsement_result {| delegate := delegate |})
                  |}) =>
            let new_endorsement :=
              {| shell := shell; protocol_data := protocol_data |} in
            let map :=
              match HLevel.find_opt (endorsements_table state) (chain_id, level)
                with
              | None => Delegate_Map.empty
              | Some x => x
              end in
            match Delegate_Map.find_opt delegate map with
            | None =>
              apply Tezos_base__TzPervasives._return
                (HLevel.add (endorsements_table state) (chain_id, level)
                  (Delegate_Map.add delegate new_endorsement map))
            | Some _ => Tezos_base__TzPervasives.return_unit
            end
          | _ =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_log_error
                (fun f =>
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Inconsistent endorsement found " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "Inconsistent endorsement found %a" % string))
                      (Tag.DSL.t event "inconsistent_endorsement" % string))
                    (Tag.DSL.a
                      Tezos_base__TzPervasives.Operation_hash.Logging.tag hash)))
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives.return_unit
                end)
          end
        end) endorsements)
    (fun function_parameter =>
      match function_parameter with
      | tt => Tezos_base__TzPervasives.return_unit
      end).

Definition process_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (state : state)
  (header :
    Tezos_client_alpha.Protocol_client_context.Alpha_block_services.block_info)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match header with
  | {|
    Alpha_block_services.chain_id := chain_id;
      Alpha_block_services.hash := hash;
      Alpha_block_services.metadata := {|
        protocol_data := {| baker := baker; level := {| level := level |} |}
          |}
      |} =>
    let chain := variant in
    let map :=
      match HLevel.find_opt (blocks_table state) (chain_id, level) with
      | None => Delegate_Map.empty
      | Some x => x
      end in
    match Delegate_Map.find_opt baker map with
    | None =>
      apply Tezos_base__TzPervasives._return
        (HLevel.add (blocks_table state) (chain_id, level)
          (Delegate_Map.add baker hash map))
    | Some existing_hash =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.header
          cctxt (Some chain) (Some variant) tt)
        (fun function_parameter =>
          match function_parameter with
          | {| shell := shell; protocol_data := protocol_data |} =>
            let bh1 :=
              {| Alpha_context.Block_header.shell := shell;
                Alpha_context.Block_header.protocol_data := protocol_data |} in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.header
                cctxt (Some chain) (Some variant) tt)
              (fun function_parameter =>
                match function_parameter with
                | {| shell := shell; protocol_data := protocol_data |} =>
                  let bh2 :=
                    {| Alpha_context.Block_header.shell := shell;
                      Alpha_context.Block_header.protocol_data := protocol_data
                      |} in
                  Tezos_base__TzPervasives.op_gt_gt_eq (get_block_offset level)
                    (fun block =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.hash
                          cctxt (Some chain) (Some block) tt)
                        (fun block_hash =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_protocol_alpha.Protocol.Alpha_services.Forge.double_baking_evidence
                              cctxt (chain, block) block_hash bh1 bh2 tt)
                            (fun bytes =>
                              let bytes :=
                                Tezos_base__TzPervasives.Signature.concat string
                                  Tezos_base__TzPervasives.Signature.zero in
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (lwt_log_notice
                                  (fun f =>
                                    Tag.DSL.op_minus_percent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Double baking detected" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "Double baking detected" % string))
                                      (Tag.DSL.t event
                                        "double_baking_detected" % string)))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_shell_services.Shell_services.Injection.operation
                                        cctxt None (Some chain) string)
                                      (fun op_hash =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                          (lwt_log_notice
                                            (fun f =>
                                              Tag.DSL.op_minus_percent
                                                (Tag.DSL.op_minus_percent
                                                  (Tag.DSL.op_minus_percent
                                                    (f
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Double baking evidence injected "
                                                            % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            CamlinternalFormatBasics.End_of_format))
                                                        "Double baking evidence injected %a"
                                                          % string))
                                                    (Tag.DSL.t event
                                                      "double_baking_denounced"
                                                        % string))
                                                  (Tag.DSL.t
                                                    Tezos_baking_alpha.Logging.signed_operation_tag
                                                    string))
                                                (Tag.DSL.a
                                                  Tezos_base__TzPervasives.Operation_hash.Logging.tag
                                                  op_hash)))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              apply
                                                Tezos_base__TzPervasives._return
                                                (HLevel.replace
                                                  (blocks_table state)
                                                  (chain_id, level)
                                                  (Delegate_Map.add baker hash
                                                    map))
                                            end))
                                  end))))
                end)
          end)
    end
  end.

Definition cleanup_old_operations (state : state) : unit :=
  let highest_level_encountered :=
    Stdlib.Int32.to_int
      (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
        (highest_level_encountered state)) in
  let diff := Z.sub highest_level_encountered (preserved_levels state) in
  let threshold :=
    if OCaml.Stdlib.lt diff 0 then
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.root
    else
      OCaml.Stdlib.reverse_apply
        (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.of_int32
          (Stdlib.Int32.of_int diff))
        (fun function_parameter =>
          match function_parameter with
          | inl threshold => threshold
          | inr _ => Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.root
          end) in
  let filter {A : Type} (hmap : HLevel.t A) : unit :=
    HLevel.filter_map_inplace
      (fun function_parameter =>
        match function_parameter with
        | (_, level) =>
          fun x =>
            if
              Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.op_lt level
                threshold then
              None
            else
              Some x
        end) hmap in
  filter (endorsements_table state);
  filter (blocks_table state);
  tt.

Definition endorsements_index : Z := 0.

Definition process_new_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (state : state)
  (function_parameter : Tezos_baking_alpha.Client_baking_blocks.block_info)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | {|
    hash := hash;
      chain_id := chain_id;
      protocol := protocol;
      next_protocol := next_protocol;
      level := level
      |} =>
    if Tezos_base__TzPervasives.Protocol_hash.op_lt_gt protocol next_protocol
      then
      Tezos_base__TzPervasives.op_gt_gt_eq
        (lwt_log_error
          (fun f =>
            Tag.DSL.op_minus_percent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Protocol changing detected. Skipping the block." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Protocol changing detected. Skipping the block." % string))
              (Tag.DSL.t event "protocol_change_detected" % string)))
        (fun function_parameter =>
          match function_parameter with
          | tt => Tezos_base__TzPervasives.return_unit
          end)
    else
      Tezos_base__TzPervasives.op_gt_gt_eq
        (lwt_debug
          (fun f =>
            Tag.DSL.op_minus_percent
              (Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Block level : " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))
                      "Block level : %a" % string))
                  (Tag.DSL.t event "accuser_saw_block" % string))
                (Tag.DSL.a Tezos_baking_alpha.Logging.level_tag level))
              (Tag.DSL.t Tezos_base__TzPervasives.Block_hash.Logging.tag hash)))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let chain := variant in
            let block := variant in
            set_field;
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.info
                  cctxt (Some chain) (Some block) tt)
                (fun function_parameter =>
                  match function_parameter with
                  | inl block_info => process_block cctxt state block_info
                  | inr errs =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (lwt_log_error
                        (fun f =>
                          Tag.DSL.op_minus_percent
                            (Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Error while fetching operations in block "
                                        % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Force_newline
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))))
                                    "Error while fetching operations in block %a@
%a"
                                      % string))
                                (Tag.DSL.t event
                                  "fetch_operations_error" % string))
                              (Tag.DSL.a
                                Tezos_base__TzPervasives.Block_hash.Logging.tag
                                hash))
                            (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs)))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_base__TzPervasives.return_unit
                        end)
                  end))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Operations.operations
                        cctxt (Some chain) (Some block) tt)
                      (fun function_parameter =>
                        match function_parameter with
                        | inl operations =>
                          if
                            OCaml.Stdlib.gt
                              (Tezos_base__TzPervasives.List.length operations)
                              endorsements_index then
                            let endorsements :=
                              Tezos_base__TzPervasives.List.nth operations
                                endorsements_index in
                            process_endorsements cctxt state endorsements level
                          else
                            Tezos_base__TzPervasives.return_unit
                        | inr errs =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (lwt_log_error
                              (fun f =>
                                Tag.DSL.op_minus_percent
                                  (Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Error while fetching operations in block "
                                              % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Force_newline
                                                (CamlinternalFormatBasics.Alpha
                                                  CamlinternalFormatBasics.End_of_format))))
                                          "Error while fetching operations in block %a@
%a"
                                            % string))
                                      (Tag.DSL.t event
                                        "fetch_operations_error" % string))
                                    (Tag.DSL.a
                                      Tezos_base__TzPervasives.Block_hash.Logging.tag
                                      hash))
                                  (Tag.DSL.a Tezos_base__TzPervasives.errs_tag
                                    errs)))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Tezos_base__TzPervasives.return_unit
                              end)
                        end))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        cleanup_old_operations state;
                        Tezos_base__TzPervasives.return_unit
                      end)
                end)
          end)
  end.

Definition create {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (preserved_levels : Z)
  (valid_blocks_stream :
    Lwt_stream.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_baking_alpha.Client_baking_blocks.block_info))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let process_block {O P Q R S T U : Type}
    (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (O * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (P * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (Q * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (R * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (S * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (T * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * U)))))))))))))))))))))))))
      * U) (state : state) (bi :
    Tezos_baking_alpha.Client_baking_blocks.block_info)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq (process_new_block cctxt state bi)
      (fun function_parameter =>
        match function_parameter with
        | inl tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_log_notice
              (fun f =>
                Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Block " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " registered" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Block %a registered" % string))
                    (Tag.DSL.t event "accuser_processed_block" % string))
                  (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                    (Client_baking_blocks.hash bi))))
            Tezos_base__TzPervasives._return
        | inr errs =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_log_error
              (fun f =>
                Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Error while processing block " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Force_newline
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))))
                          "Error while processing block %a@
%a" % string))
                      (Tag.DSL.t event "accuser_block_error" % string))
                    (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                      (hash bi)))
                  (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs)))
            Tezos_base__TzPervasives._return
        end) in
  let state_maker {O : Type} (function_parameter : O)
    : Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
    match function_parameter with
    | _ =>
      Tezos_base__TzPervasives.op_gt_gt_eq (create_state preserved_levels)
        Tezos_base__TzPervasives._return
    end in
  Tezos_baking_alpha.Client_baking_scheduling.main "accuser" % string cctxt
    valid_blocks_stream state_maker
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ =>
            fun function_parameter =>
              match function_parameter with
              | _ => Tezos_base__TzPervasives.return_unit
              end
          end
      end)
    (fun function_parameter =>
      match function_parameter with
      | _ => Tezos_base__TzPervasives.Lwt_utils.never_ending tt
      end)
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ =>
            fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_unit
              end
          end
      end) process_block.
src/proto_alpha/lib_delegate/client_baking_denunciation.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val create :
  #Protocol_client_context.full ->
  preserved_levels:int ->
  Client_baking_blocks.block_info tzresult Lwt_stream.t ->
  unit tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_denunciation.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter create : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Z ->
    (Lwt_stream.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_baking_alpha.Client_baking_blocks.block_info)) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_delegate/client_baking_endorsement.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

open Protocol
open Alpha_context
open Protocol_client_context

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.endorsement"
end)

open Logging

let get_signing_slots cctxt ~chain ~block delegate level =
  Alpha_services.Delegate.Endorsing_rights.get
    cctxt
    ~levels:[level]
    ~delegates:[delegate]
    (chain, block)
  >>=? function [{slots; _}] -> return_some slots | _ -> return_none

let inject_endorsement (cctxt : #Protocol_client_context.full) ?async ~chain
    ~block hash level delegate_sk delegate_pkh =
  Alpha_services.Forge.endorsement cctxt (chain, block) ~branch:hash ~level ()
  >>=? fun bytes ->
  let wallet = (cctxt :> Client_context.wallet) in
  (* Double-check the right to inject an endorsement *)
  let open Client_baking_highwatermarks in
  wallet#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Endorsement
      >>=? fun endorsement_location ->
      may_inject_endorsement
        cctxt
        endorsement_location
        ~delegate:delegate_pkh
        level
      >>=? function
      | true ->
          record_endorsement
            cctxt
            endorsement_location
            ~delegate:delegate_pkh
            level
          >>=? fun () -> return_true
      | false ->
          return_false)
  >>=? fun is_allowed_to_endorse ->
  if is_allowed_to_endorse then
    Chain_services.chain_id cctxt ~chain ()
    >>=? fun chain_id ->
    Client_keys.append
      cctxt
      delegate_sk
      ~watermark:(Endorsement chain_id)
      bytes
    >>=? fun signed_bytes ->
    Shell_services.Injection.operation cctxt ?async ~chain signed_bytes
    >>=? fun oph -> return oph
  else
    lwt_log_error
      Tag.DSL.(
        fun f ->
          f "Level %a : previously endorsed."
          -% t event "double_endorsement_near_miss"
          -% a level_tag level)
    >>= fun () -> fail (Level_previously_endorsed level)

let forge_endorsement (cctxt : #Protocol_client_context.full) ?async ~chain
    ~block ~src_sk src_pk =
  let src_pkh = Signature.Public_key.hash src_pk in
  Alpha_block_services.metadata cctxt ~chain ~block ()
  >>=? fun {protocol_data = {level = {level; _}; _}; _} ->
  Shell_services.Blocks.hash cctxt ~chain ~block ()
  >>=? fun hash ->
  inject_endorsement cctxt ?async ~chain ~block hash level src_sk src_pkh
  >>=? fun oph ->
  Client_keys.get_key cctxt src_pkh
  >>=? fun (name, _pk, _sk) ->
  lwt_log_notice
    Tag.DSL.(
      fun f ->
        f "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
        -% t event "injected_endorsement"
        -% a Block_hash.Logging.tag hash
        -% a level_tag level
        -% s Client_keys.Logging.tag name
        -% t Signature.Public_key_hash.Logging.tag src_pkh
        -% a Operation_hash.Logging.tag oph)
  >>= fun () -> return oph

(** Worker *)

type state = {
  delegates : public_key_hash list;
  delay : int64;
  mutable pending : endorsements option;
}

and endorsements = {
  time : Time.Protocol.t;
  delegates : public_key_hash list;
  block : Client_baking_blocks.block_info;
}

let create_state delegates delay = {delegates; delay; pending = None}

let get_delegates cctxt state =
  match state.delegates with
  | [] ->
      Client_keys.get_keys cctxt
      >>=? fun keys ->
      let delegates = List.map (fun (_, pkh, _, _) -> pkh) keys in
      return Signature.Public_key_hash.Set.(delegates |> of_list |> elements)
  | _ :: _ as delegates ->
      return delegates

let endorse_for_delegate cctxt block delegate_pkh =
  let {Client_baking_blocks.hash; level; chain_id; _} = block in
  Client_keys.get_key cctxt delegate_pkh
  >>=? fun (name, _pk, delegate_sk) ->
  lwt_debug
    Tag.DSL.(
      fun f ->
        f "Endorsing %a for %s (level %a)!"
        -% t event "endorsing"
        -% a Block_hash.Logging.tag hash
        -% s Client_keys.Logging.tag name
        -% a level_tag level)
  >>= fun () ->
  let chain = `Hash chain_id in
  let block = `Hash (hash, 0) in
  inject_endorsement cctxt ~chain ~block hash level delegate_sk delegate_pkh
  >>=? fun oph ->
  lwt_log_notice
    Tag.DSL.(
      fun f ->
        f "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
        -% t event "injected_endorsement"
        -% a Block_hash.Logging.tag hash
        -% a level_tag level
        -% s Client_keys.Logging.tag name
        -% t Signature.Public_key_hash.Logging.tag delegate_pkh
        -% a Operation_hash.Logging.tag oph)
  >>= fun () -> return_unit

let allowed_to_endorse cctxt bi delegate =
  Client_keys.Public_key_hash.name cctxt delegate
  >>=? fun name ->
  lwt_debug
    Tag.DSL.(
      fun f ->
        f "Checking if allowed to endorse block %a for %s"
        -% t event "check_endorsement_ok"
        -% a Block_hash.Logging.tag bi.Client_baking_blocks.hash
        -% s Client_keys.Logging.tag name)
  >>= fun () ->
  let chain = `Hash bi.chain_id in
  let block = `Hash (bi.hash, 0) in
  let level = bi.level in
  get_signing_slots cctxt ~chain ~block delegate level
  >>=? function
  | None | Some [] ->
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "No slot found for %a/%s"
            -% t event "endorsement_no_slots_found"
            -% a Block_hash.Logging.tag bi.hash
            -% s Client_keys.Logging.tag name)
      >>= fun () -> return_false
  | Some (_ :: _ as slots) -> (
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "Found slots for %a/%s (%a)"
            -% t event "endorsement_slots_found"
            -% a Block_hash.Logging.tag bi.hash
            -% s Client_keys.Logging.tag name
            -% a endorsement_slots_tag slots)
      >>= fun () ->
      cctxt#with_lock (fun () ->
          Client_baking_files.resolve_location cctxt ~chain `Endorsement
          >>=? fun endorsement_location ->
          Client_baking_highwatermarks.may_inject_endorsement
            cctxt
            endorsement_location
            ~delegate
            level)
      >>=? function
      | false ->
          lwt_debug
            Tag.DSL.(
              fun f ->
                f "Level %a (or higher) previously endorsed: do not endorse."
                -% t event "previously_endorsed"
                -% a level_tag level)
          >>= fun () -> return_false
      | true ->
          return_true )

let prepare_endorsement ~(max_past : int64) ()
    (cctxt : #Protocol_client_context.full) state bi =
  let past =
    Time.Protocol.diff
      (Time.System.to_protocol (Systime_os.now ()))
      bi.Client_baking_blocks.timestamp
  in
  if past > max_past then
    lwt_log_info
      Tag.DSL.(
        fun f ->
          f "Ignore block %a: forged too far the past"
          -% t event "endorsement_stale_block"
          -% a Block_hash.Logging.tag bi.hash)
    >>= fun () -> return_unit
  else
    lwt_log_info
      Tag.DSL.(
        fun f ->
          f "Received new block %a"
          -% t event "endorsement_got_block"
          -% a Block_hash.Logging.tag bi.hash)
    >>= fun () ->
    let time =
      Time.Protocol.add
        (Time.System.to_protocol (Systime_os.now ()))
        state.delay
    in
    get_delegates cctxt state
    >>=? fun delegates ->
    filter_p (allowed_to_endorse cctxt bi) delegates
    >>=? fun delegates ->
    state.pending <- Some {time; block = bi; delegates} ;
    return_unit

let compute_timeout state =
  match state.pending with
  | None ->
      Lwt_utils.never_ending ()
  | Some {time; block; delegates} -> (
    match Client_baking_scheduling.sleep_until time with
    | None ->
        Lwt.return (block, delegates)
    | Some timeout ->
        let timespan =
          let timespan =
            Ptime.diff (Time.System.of_protocol_exn time) (Systime_os.now ())
          in
          if Ptime.Span.compare timespan Ptime.Span.zero > 0 then timespan
          else Ptime.Span.zero
        in
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "Waiting until %a (%a) to inject endorsements"
              -% t event "wait_before_injecting"
              -% a timestamp_tag (Time.System.of_protocol_exn time)
              -% a timespan_tag timespan)
        >>= fun () -> timeout >>= fun () -> Lwt.return (block, delegates) )

let create (cctxt : #Protocol_client_context.full) ?(max_past = 110L) ~delay
    delegates block_stream =
  let state_maker _ =
    let state = create_state delegates (Int64.of_int delay) in
    return state
  in
  let timeout_k cctxt state (block, delegates) =
    state.pending <- None ;
    iter_s
      (fun delegate ->
        endorse_for_delegate cctxt block delegate
        >>= function
        | Ok () ->
            return_unit
        | Error errs ->
            lwt_log_error
              Tag.DSL.(
                fun f ->
                  f
                    "@[<v 2>Error while injecting endorsement for delegate %a \
                     : @[%a@]@]@."
                  -% t event "error_while_endorsing"
                  -% a Signature.Public_key_hash.Logging.tag delegate
                  -% a errs_tag errs)
            >>= fun () ->
            (* We continue anyway *)
            return_unit)
      delegates
  in
  let event_k cctxt state bi =
    state.pending <- None ;
    prepare_endorsement ~max_past () cctxt state bi
  in
  Client_baking_scheduling.main
    ~name:"endorser"
    ~cctxt
    ~stream:block_stream
    ~state_maker
    ~pre_loop:(prepare_endorsement ~max_past ())
    ~compute_timeout
    ~timeout_k
    ~event_k
src/proto_alpha/lib_delegate/client_baking_endorsement.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_baking_alpha.Logging.

Definition get_signing_slots {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
  (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (option (list Z))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Endorsing_rights.get
      cctxt (Some (cons level [])) None (Some (cons delegate [])) (chain, block))
    (fun function_parameter =>
      match function_parameter with
      | cons {| slots := slots |} [] =>
        Tezos_base__TzPervasives.return_some slots
      | _ => Tezos_base__TzPervasives.return_none
      end).

Definition inject_endorsement {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (async : option bool)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (hash :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
  (delegate_sk : Tezos_client_base.Client_keys.sk_uri)
  (delegate_pkh : Tezos_base__TzPervasives.Signature.public_key_hash)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Operation_hash.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Forge.endorsement cctxt
      (chain, block) hash level tt)
    (fun bytes =>
      let wallet := cctxt in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (send
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_baking_alpha.Client_baking_files.resolve_location cctxt
                  chain variant)
                (fun endorsement_location =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_baking_alpha.Client_baking_highwatermarks.may_inject_endorsement
                      cctxt endorsement_location delegate_pkh level)
                    (fun function_parameter =>
                      match function_parameter with
                      | true =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_baking_alpha.Client_baking_highwatermarks.record_endorsement
                            cctxt endorsement_location delegate_pkh level)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_true
                            end)
                      | false => Tezos_base__TzPervasives.return_false
                      end))
            end))
        (fun is_allowed_to_endorse =>
          if is_allowed_to_endorse then
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_shell_services.Chain_services.chain_id cctxt (Some chain)
                tt)
              (fun chain_id =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_client_base.Client_keys.append cctxt
                    (Some (Endorsement chain_id)) delegate_sk string)
                  (fun signed_bytes =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_shell_services.Shell_services.Injection.operation
                        cctxt async (Some chain) signed_bytes)
                      (fun oph => Tezos_base__TzPervasives._return oph)))
          else
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_log_error
                (fun f =>
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Level " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " : previously endorsed." % string
                                CamlinternalFormatBasics.End_of_format)))
                          "Level %a : previously endorsed." % string))
                      (Tag.DSL.t event "double_endorsement_near_miss" % string))
                    (Tag.DSL.a Tezos_baking_alpha.Logging.level_tag level)))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.fail
                    (Level_previously_endorsed level)
                end))).

Definition forge_endorsement {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (async : option bool)
  (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (src_pk : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Operation_hash.t) :=
  let src_pkh := Tezos_base__TzPervasives.Signature.Public_key.hash src_pk in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.metadata
      cctxt (Some chain) (Some block) tt)
    (fun function_parameter =>
      match function_parameter with
      | {| protocol_data := {| level := {| level := level |} |} |} =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_shell_services.Shell_services.Blocks.hash cctxt (Some chain)
            (Some block) tt)
          (fun hash =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (inject_endorsement cctxt async chain block hash level src_sk
                src_pkh)
              (fun oph =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_client_base.Client_keys.get_key cctxt src_pkh)
                  (fun function_parameter =>
                    match function_parameter with
                    | (name, _pk, _sk) =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (lwt_log_notice
                          (fun f =>
                            Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (Tag.DSL.op_minus_percent
                                        (f
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Injected endorsement for block '"
                                                % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  "' (level " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.String_literal
                                                      ", contract " % string
                                                      (CamlinternalFormatBasics.String
                                                        CamlinternalFormatBasics.No_padding
                                                        (CamlinternalFormatBasics.String_literal
                                                          ") '" % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Char_literal
                                                              "'" % char
                                                              CamlinternalFormatBasics.End_of_format)))))))))
                                            "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
                                              % string))
                                        (Tag.DSL.t event
                                          "injected_endorsement" % string))
                                      (Tag.DSL.a
                                        Tezos_base__TzPervasives.Block_hash.Logging.tag
                                        hash))
                                    (Tag.DSL.a
                                      Tezos_baking_alpha.Logging.level_tag level))
                                  (Tag.DSL.s
                                    Tezos_client_base.Client_keys.Logging.tag
                                    name))
                                (Tag.DSL.t
                                  Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                                  src_pkh))
                              (Tag.DSL.a
                                Tezos_base__TzPervasives.Operation_hash.Logging.tag
                                oph)))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives._return oph
                          end)
                    end)))
      end).

.

Definition create_state
  (delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (delay : int64) : state :=
  {| delegates := delegates; delay := delay; pending := None |}.

Definition get_delegates {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (state : state)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_base__TzPervasives.Signature.Public_key_hash.Set.elt)) :=
  match delegates state with
  | [] =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_client_base.Client_keys.get_keys cctxt)
      (fun keys =>
        let delegates :=
          Tezos_base__TzPervasives.List.map
            (fun function_parameter =>
              match function_parameter with
              | (_, pkh, _, _) => pkh
              end) keys in
        Tezos_base__TzPervasives._return
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply delegates
              Tezos_base__TzPervasives.Signature.Public_key_hash.Set.of_list)
            Tezos_base__TzPervasives.Signature.Public_key_hash.Set.elements))
  | (cons _ _) as delegates => Tezos_base__TzPervasives._return delegates
  end.

Definition endorse_for_delegate {E F H J L M N a b c i o p q : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                      variant
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q
                      i o) ->
                      (Tezos_shell_services.Shell_services.chain *
                        Tezos_shell_services.Shell_services.block) ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (E * q * i * o)) *
                      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                        variant
                        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          * a) q i o) ->
                        (Tezos_shell_services.Shell_services.chain *
                          Tezos_shell_services.Shell_services.block) ->
                          a ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (F * a * q * i * o)) *
                        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                          variant
                          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            * a) * b) q i o) ->
                          (Tezos_shell_services.Shell_services.chain *
                            Tezos_shell_services.Shell_services.block) ->
                            a ->
                              b ->
                                q ->
                                  i ->
                                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                        o)) * (H * a * b * q * i * o)) *
                          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                            variant
                            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                              * a) * b) * c) q i o) ->
                            (Tezos_shell_services.Shell_services.chain *
                              Tezos_shell_services.Shell_services.block) ->
                              a ->
                                b ->
                                  c ->
                                    q ->
                                      i ->
                                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                            o)) * (J * a * b * c * q * i * o)) *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (L * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (M * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((float -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (Uri.t *
          (Tezos_shell_services.Shell_services.block *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (E * q * i * o)) *
              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q
                i o) ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  a ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (F * a * q * i * o)) *
                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                  variant
                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                  ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                    * b) q i o) ->
                  (Tezos_shell_services.Shell_services.chain *
                    Tezos_shell_services.Shell_services.block) ->
                    a ->
                      b ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (H * a * b * q * i * o)) *
                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                    variant
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                    (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
                      a) * b) * c) q i o) ->
                    (Tezos_shell_services.Shell_services.chain *
                      Tezos_shell_services.Shell_services.block) ->
                      a ->
                        b ->
                          c ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (J * a * b * c * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) * N)))))))))))))))))))))
  (block : Tezos_baking_alpha.Client_baking_blocks.block_info)
  (delegate_pkh : Tezos_client_base.Client_keys.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match block with
  | {|
    Client_baking_blocks.hash := hash;
      Client_baking_blocks.chain_id := chain_id;
      Client_baking_blocks.level := level
      |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_client_base.Client_keys.get_key cctxt delegate_pkh)
      (fun function_parameter =>
        match function_parameter with
        | (name, _pk, delegate_sk) =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_debug
              (fun f =>
                Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Endorsing " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " for " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String_literal
                                      " (level " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          ")!" % string
                                          CamlinternalFormatBasics.End_of_format)))))))
                            "Endorsing %a for %s (level %a)!" % string))
                        (Tag.DSL.t event "endorsing" % string))
                      (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                        hash))
                    (Tag.DSL.s Tezos_client_base.Client_keys.Logging.tag name))
                  (Tag.DSL.a Tezos_baking_alpha.Logging.level_tag level)))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let chain := variant in
                let block := variant in
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (inject_endorsement cctxt None chain block hash level
                    delegate_sk delegate_pkh)
                  (fun oph =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (lwt_log_notice
                        (fun f =>
                          Tag.DSL.op_minus_percent
                            (Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Injected endorsement for block '" %
                                              string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                "' (level " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.String_literal
                                                    ", contract " % string
                                                    (CamlinternalFormatBasics.String
                                                      CamlinternalFormatBasics.No_padding
                                                      (CamlinternalFormatBasics.String_literal
                                                        ") '" % string
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.Char_literal
                                                            "'" % char
                                                            CamlinternalFormatBasics.End_of_format)))))))))
                                          "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
                                            % string))
                                      (Tag.DSL.t event
                                        "injected_endorsement" % string))
                                    (Tag.DSL.a
                                      Tezos_base__TzPervasives.Block_hash.Logging.tag
                                      hash))
                                  (Tag.DSL.a
                                    Tezos_baking_alpha.Logging.level_tag level))
                                (Tag.DSL.s
                                  Tezos_client_base.Client_keys.Logging.tag name))
                              (Tag.DSL.t
                                Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                                delegate_pkh))
                            (Tag.DSL.a
                              Tezos_base__TzPervasives.Operation_hash.Logging.tag
                              oph)))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_base__TzPervasives.return_unit
                        end))
              end)
        end)
  end.

Definition allowed_to_endorse {E F H J L M N a b c i o p q : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                Tezos_protocol_environment_alpha__Environment.RPC_context.t q i
                o) ->
                (variant * variant) ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (E * q * i * o)) *
                ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                  variant
                  Tezos_protocol_environment_alpha__Environment.RPC_context.t
                  (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                    a) q i o) ->
                  (variant * variant) ->
                    a ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (F * a * q * i * o)) *
                  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                    variant
                    Tezos_protocol_environment_alpha__Environment.RPC_context.t
                    ((Tezos_protocol_environment_alpha__Environment.RPC_context.t
                      * a) * b) q i o) ->
                    (variant * variant) ->
                      a ->
                        b ->
                          q ->
                            i ->
                              Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                  o)) * (H * a * b * q * i * o)) *
                    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                      variant
                      Tezos_protocol_environment_alpha__Environment.RPC_context.t
                      (((Tezos_protocol_environment_alpha__Environment.RPC_context.t
                        * a) * b) * c) q i o) ->
                      (variant * variant) ->
                        a ->
                          b ->
                            c ->
                              q ->
                                i ->
                                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                      o)) * (J * a * b * c * q * i * o)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) *
                        (Uri.t *
                          (Tezos_shell_services.Shell_services.block *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (L * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (M * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((float -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (variant * variant) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (variant * variant) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (variant * variant) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (variant * variant) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) * N)))))))))))))))))))))
  (bi : Tezos_baking_alpha.Client_baking_blocks.block_info)
  (delegate : Tezos_client_base.Client_keys.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_base.Client_keys.Public_key_hash.name cctxt delegate)
    (fun name =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (lwt_debug
          (fun f =>
            Tag.DSL.op_minus_percent
              (Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Checking if allowed to endorse block " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " for " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))))
                      "Checking if allowed to endorse block %a for %s" % string))
                  (Tag.DSL.t event "check_endorsement_ok" % string))
                (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                  (Client_baking_blocks.hash bi)))
              (Tag.DSL.s Tezos_client_base.Client_keys.Logging.tag name)))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            let chain := variant in
            let block := variant in
            let level := level bi in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (get_signing_slots cctxt chain block delegate level)
              (fun function_parameter =>
                match function_parameter with
                | None | Some [] =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_debug
                      (fun f =>
                        Tag.DSL.op_minus_percent
                          (Tag.DSL.op_minus_percent
                            (Tag.DSL.op_minus_percent
                              (f
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "No slot found for " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        "/" % char
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))))
                                  "No slot found for %a/%s" % string))
                              (Tag.DSL.t event
                                "endorsement_no_slots_found" % string))
                            (Tag.DSL.a
                              Tezos_base__TzPervasives.Block_hash.Logging.tag
                              (hash bi)))
                          (Tag.DSL.s Tezos_client_base.Client_keys.Logging.tag
                            name)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_false
                      end)
                | Some ((cons _ _) as slots) =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_debug
                      (fun f =>
                        Tag.DSL.op_minus_percent
                          (Tag.DSL.op_minus_percent
                            (Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Found slots for " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "/" % char
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              " (" % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  ")" % char
                                                  CamlinternalFormatBasics.End_of_format)))))))
                                    "Found slots for %a/%s (%a)" % string))
                                (Tag.DSL.t event
                                  "endorsement_slots_found" % string))
                              (Tag.DSL.a
                                Tezos_base__TzPervasives.Block_hash.Logging.tag
                                (hash bi)))
                            (Tag.DSL.s Tezos_client_base.Client_keys.Logging.tag
                              name))
                          (Tag.DSL.a
                            Tezos_baking_alpha.Logging.endorsement_slots_tag
                            slots)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (send
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_baking_alpha.Client_baking_files.resolve_location
                                    cctxt chain variant)
                                  (fun endorsement_location =>
                                    Tezos_baking_alpha.Client_baking_highwatermarks.may_inject_endorsement
                                      cctxt endorsement_location delegate level)
                              end))
                          (fun function_parameter =>
                            match function_parameter with
                            | false =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (lwt_debug
                                  (fun f =>
                                    Tag.DSL.op_minus_percent
                                      (Tag.DSL.op_minus_percent
                                        (f
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Level " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  " (or higher) previously endorsed: do not endorse."
                                                    % string
                                                  CamlinternalFormatBasics.End_of_format)))
                                            "Level %a (or higher) previously endorsed: do not endorse."
                                              % string))
                                        (Tag.DSL.t event
                                          "previously_endorsed" % string))
                                      (Tag.DSL.a
                                        Tezos_baking_alpha.Logging.level_tag
                                        level)))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_false
                                  end)
                            | true => Tezos_base__TzPervasives.return_true
                            end)
                      end)
                end)
          end)).

Definition prepare_endorsement {D F H J L M N a b c i o p q : Type}
  (max_past : int64) (function_parameter : unit)
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    state ->
      Tezos_baking_alpha.Client_baking_blocks.block_info ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | tt =>
    fun cctxt =>
      fun state =>
        fun bi =>
          let past :=
            Tezos_base__TzPervasives.Time.Protocol.diff
              (Tezos_base__TzPervasives.Time.System.to_protocol
                (Tezos_stdlib_unix.Systime_os.now tt))
              (Client_baking_blocks.timestamp bi) in
          if OCaml.Stdlib.gt past max_past then
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_log_info
                (fun f =>
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Ignore block " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                ": forged too far the past" % string
                                CamlinternalFormatBasics.End_of_format)))
                          "Ignore block %a: forged too far the past" % string))
                      (Tag.DSL.t event "endorsement_stale_block" % string))
                    (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                      (hash bi))))
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives.return_unit
                end)
          else
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_log_info
                (fun f =>
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Received new block " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "Received new block %a" % string))
                      (Tag.DSL.t event "endorsement_got_block" % string))
                    (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                      (hash bi))))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  let time :=
                    Tezos_base__TzPervasives.Time.Protocol.add
                      (Tezos_base__TzPervasives.Time.System.to_protocol
                        (Tezos_stdlib_unix.Systime_os.now tt)) (delay state) in
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (get_delegates cctxt state)
                    (fun delegates =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_base__TzPervasives.filter_p
                          (allowed_to_endorse cctxt bi) delegates)
                        (fun delegates =>
                          set_field;
                          Tezos_base__TzPervasives.return_unit))
                end)
  end.

Definition compute_timeout (state : state)
  : Lwt.t
    (Tezos_baking_alpha.Client_baking_blocks.block_info *
      (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)) :=
  match pending state with
  | None => Tezos_base__TzPervasives.Lwt_utils.never_ending tt
  | Some {| time := time; delegates := delegates; block := block |} =>
    match Tezos_baking_alpha.Client_baking_scheduling.sleep_until time with
    | None => Lwt._return (block, delegates)
    | Some timeout =>
      let timespan :=
        let timespan :=
          Ptime.diff (Tezos_base__TzPervasives.Time.System.of_protocol_exn time)
            (Tezos_stdlib_unix.Systime_os.now tt) in
        if OCaml.Stdlib.gt (Ptime.Span.compare timespan Ptime.Span.zero) 0 then
          timespan
        else
          Ptime.Span.zero in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (lwt_log_info
          (fun f =>
            Tag.DSL.op_minus_percent
              (Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Waiting until " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal " (" % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                ") to inject endorsements" % string
                                CamlinternalFormatBasics.End_of_format)))))
                      "Waiting until %a (%a) to inject endorsements" % string))
                  (Tag.DSL.t event "wait_before_injecting" % string))
                (Tag.DSL.a Tezos_baking_alpha.Logging.timestamp_tag
                  (Tezos_base__TzPervasives.Time.System.of_protocol_exn time)))
              (Tag.DSL.a Tezos_baking_alpha.Logging.timespan_tag timespan)))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.op_gt_gt_eq timeout
              (fun function_parameter =>
                match function_parameter with
                | tt => Lwt._return (block, delegates)
                end)
          end)
    end
  end.

Definition create {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (op_star_o_p_t_star : option int64)
  : Z ->
    (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
      (Lwt_stream.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_baking_alpha.Client_baking_blocks.block_info)) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let max_past :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 110
    end in
  fun delay =>
    fun delegates =>
      fun block_stream =>
        let state_maker {O : Type} (function_parameter : O)
          : Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
          match function_parameter with
          | _ =>
            let state := create_state delegates (Stdlib.Int64.of_int delay) in
            Tezos_base__TzPervasives._return state
          end in
        let timeout_k {O P Q R S T U : Type}
          (cctxt :
          ((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      (Uri.t *
                        (Tezos_shell_services.Shell_services.block *
                          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                            variant
                            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            q i o) ->
                            (Tezos_shell_services.Shell_services.chain *
                              Tezos_shell_services.Shell_services.block) ->
                              q ->
                                i ->
                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                      o)) * (O * q * i * o)) *
                            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                              variant
                              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                              (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                * a) q i o) ->
                              (Tezos_shell_services.Shell_services.chain *
                                Tezos_shell_services.Shell_services.block) ->
                                a ->
                                  q ->
                                    i ->
                                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                          o)) * (P * a * q * i * o)) *
                              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                variant
                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                  * a) * b) q i o) ->
                                (Tezos_shell_services.Shell_services.chain *
                                  Tezos_shell_services.Shell_services.block) ->
                                  a ->
                                    b ->
                                      q ->
                                        i ->
                                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                              o)) * (Q * a * b * q * i * o)) *
                                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                  variant
                                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                  (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                    * a) * b) * c) q i o) ->
                                  (Tezos_shell_services.Shell_services.chain *
                                    Tezos_shell_services.Shell_services.block)
                                    ->
                                    a ->
                                      b ->
                                        c ->
                                          q ->
                                            i ->
                                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                  o)) *
                                  (R * a * b * c * q * i * o)) *
                                  ((((Tezos_rpc.RPC_service.t variant unit p q i
                                    o) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              o)) * (S * p * q * i * o)) *
                                    ((((Tezos_rpc.RPC_service.t variant unit p q
                                      i o) ->
                                      (o -> unit) ->
                                        (unit -> unit) ->
                                          p ->
                                            q ->
                                              i ->
                                                Lwt.t
                                                  (Tezos_error_monad.Error_monad.tzresult
                                                    (unit -> unit))) *
                                      (T * p * q * i * o)) *
                                      (Tezos_shell_services.Shell_services.chain
                                        *
                                        ((option Z) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a b) -> a) * (a * b)) *
                                            ((Tezos_rpc.RPC_service.meth ->
                                              (option
                                                Tezos_data_encoding.Data_encoding.json)
                                                ->
                                                Uri.t ->
                                                  Lwt.t
                                                    (Tezos_rpc.RPC_context.rest_result
                                                      Tezos_data_encoding.Data_encoding.json
                                                      (option
                                                        Tezos_data_encoding.Data_encoding.json)))
                                              *
                                              (((string ->
                                                (Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((unit -> Ptime.t) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a
                                                      (Tezos_base__TzPervasives.tzresult
                                                        string)) -> a) * (a)) *
                                                      ((((Tezos_client_base.Client_context.lwt_format
                                                        a
                                                        (Tezos_base__TzPervasives.tzresult
                                                          Bigstring.t)) -> a) *
                                                        (a)) *
                                                        ((float -> Lwt.t unit) *
                                                          ((((Tezos_client_base.Client_context.lwt_format
                                                            a unit) -> a) * (a))
                                                            * U)))))))))))))))))))))))))
            *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                    variant
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i
                    o) ->
                    (Tezos_shell_services.Shell_services.chain *
                      Tezos_shell_services.Shell_services.block) ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (O * q * i * o)) *
                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                      variant
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
                        a) q i o) ->
                      (Tezos_shell_services.Shell_services.chain *
                        Tezos_shell_services.Shell_services.block) ->
                        a ->
                          q ->
                            i ->
                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                  o)) * (P * a * q * i * o)) *
                      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                        variant
                        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          * a) * b) q i o) ->
                        (Tezos_shell_services.Shell_services.chain *
                          Tezos_shell_services.Shell_services.block) ->
                          a ->
                            b ->
                              q ->
                                i ->
                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                      o)) * (Q * a * b * q * i * o)) *
                        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                          variant
                          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            * a) * b) * c) q i o) ->
                          (Tezos_shell_services.Shell_services.chain *
                            Tezos_shell_services.Shell_services.block) ->
                            a ->
                              b ->
                                c ->
                                  q ->
                                    i ->
                                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                          o)) * (R * a * b * c * q * i * o)) *
                          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult o))
                            * (S * p * q * i * o)) *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              (o -> unit) ->
                                (unit -> unit) ->
                                  p ->
                                    q ->
                                      i ->
                                        Lwt.t
                                          (Tezos_error_monad.Error_monad.tzresult
                                            (unit -> unit))) *
                              (T * p * q * i * o)) *
                              (Tezos_shell_services.Shell_services.chain *
                                ((option Z) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a b) -> a) * (a * b)) *
                                    ((Tezos_rpc.RPC_service.meth ->
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)
                                        ->
                                        Uri.t ->
                                          Lwt.t
                                            (Tezos_rpc.RPC_context.rest_result
                                              Tezos_data_encoding.Data_encoding.json
                                              (option
                                                Tezos_data_encoding.Data_encoding.json)))
                                      *
                                      (((string ->
                                        (Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((unit -> Ptime.t) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) -> a) * (a)) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  Bigstring.t)) -> a) * (a)) *
                                                ((float -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) * U)))))))))))))))))))))
          (state : state) (function_parameter :
          Tezos_baking_alpha.Client_baking_blocks.block_info *
            (list Tezos_client_base.Client_keys.Public_key_hash.t))
          : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
          match function_parameter with
          | (block, delegates) =>
            set_field;
            Tezos_base__TzPervasives.iter_s
              (fun delegate =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (endorse_for_delegate cctxt block delegate)
                  (fun function_parameter =>
                    match function_parameter with
                    | inl tt => Tezos_base__TzPervasives.return_unit
                    | inr errs =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (lwt_log_error
                          (fun f =>
                            Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 2>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 2>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Error while injecting endorsement for delegate "
                                            % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " : " % string
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_box
                                                  (CamlinternalFormatBasics.Format
                                                    CamlinternalFormatBasics.End_of_format
                                                    "" % string))
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Close_box
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Flush_newline
                                                        CamlinternalFormatBasics.End_of_format)))))))))
                                      "@[<v 2>Error while injecting endorsement for delegate %a : @[%a@]@]@."
                                        % string))
                                  (Tag.DSL.t event
                                    "error_while_endorsing" % string))
                                (Tag.DSL.a
                                  Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                                  delegate))
                              (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs)))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives.return_unit
                          end)
                    end)) delegates
          end in
        let event_k {O P Q R S T U : Type}
          (cctxt :
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (O * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i
              o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (P * a * q * i * o)) *
              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                  b) q i o) ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  a ->
                    b ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (Q * a * b * q * i * o)) *
                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                  variant
                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                  (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                    * b) * c) q i o) ->
                  (Tezos_shell_services.Shell_services.chain *
                    Tezos_shell_services.Shell_services.block) ->
                    a ->
                      b ->
                        c ->
                          q ->
                            i ->
                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                  o)) * (R * a * b * c * q * i * o)) *
                  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                    * (a)) *
                    (Uri.t *
                      (Tezos_shell_services.Shell_services.block *
                        ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                          * (S * p * q * i * o)) *
                          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                            (o -> unit) ->
                              (unit -> unit) ->
                                p ->
                                  q ->
                                    i ->
                                      Lwt.t
                                        (Tezos_error_monad.Error_monad.tzresult
                                          (unit -> unit))) * (T * p * q * i * o))
                            *
                            (Tezos_shell_services.Shell_services.chain *
                              ((option Z) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a b) -> a) * (a * b)) *
                                  ((Tezos_rpc.RPC_service.meth ->
                                    (option
                                      Tezos_data_encoding.Data_encoding.json) ->
                                      Uri.t ->
                                        Lwt.t
                                          (Tezos_rpc.RPC_context.rest_result
                                            Tezos_data_encoding.Data_encoding.json
                                            (option
                                              Tezos_data_encoding.Data_encoding.json)))
                                    *
                                    (((string ->
                                      a ->
                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                          a) ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult a))
                                      * (a)) *
                                      ((option (Lwt_stream.t string)) *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((string ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        string)) *
                                                    ((float -> Lwt.t unit) *
                                                      ((((Tezos_client_base.Client_context.lwt_format
                                                        a unit) -> a) * (a)) *
                                                        ((((unit -> Lwt.t a) ->
                                                          Lwt.t a) * (a)) *
                                                          (((string ->
                                                            a ->
                                                              (Tezos_base__TzPervasives.Data_encoding.encoding
                                                                a) ->
                                                                Lwt.t
                                                                  (Tezos_base__TzPervasives.tzresult
                                                                    unit)) * (a))
                                                            * U)))))))))))))))))))))))))
            * U) (state : state) (bi :
          Tezos_baking_alpha.Client_baking_blocks.block_info)
          : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
          set_field;
          prepare_endorsement max_past tt cctxt state bi in
        Tezos_baking_alpha.Client_baking_scheduling.main "endorser" % string
          cctxt block_stream state_maker (prepare_endorsement max_past tt)
          compute_timeout timeout_k event_k.
src/proto_alpha/lib_delegate/client_baking_endorsement.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

(** [forge_endorsement cctxt blk ~src_sk src_pk] emits an endorsement
    operation for the block [blk]
*)
val forge_endorsement :
  #Protocol_client_context.full ->
  ?async:bool ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  src_sk:Client_keys.sk_uri ->
  public_key ->
  Operation_hash.t tzresult Lwt.t

val create :
  #Protocol_client_context.full ->
  ?max_past:int64 (* number of seconds *) ->
  delay:int ->
  public_key_hash list ->
  Client_baking_blocks.block_info tzresult Lwt_stream.t ->
  unit tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_endorsement.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter forge_endorsement : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (option bool) ->
    Tezos_shell_services.Chain_services.chain ->
      Tezos_shell_services.Block_services.block ->
        Tezos_client_base.Client_keys.sk_uri ->
          Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_base__TzPervasives.Operation_hash.t).

Parameter create : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (option int64) ->
    Z ->
      (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
        (Lwt_stream.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_baking_alpha.Client_baking_blocks.block_info)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_delegate/client_baking_files.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type _ location = {filename : string; chain : Chain_services.chain}

let resolve_location (cctxt : #Client_context.full) ~chain (kind : 'a) :
    'a location tzresult Lwt.t =
  let basename =
    match kind with
    | `Block ->
        "block"
    | `Endorsement ->
        "endorsement"
    | `Nonce ->
        "nonce"
  in
  let test_filename chain_id =
    Format.kasprintf return "test_%a_%s" Chain_id.pp_short chain_id basename
  in
  ( match chain with
  | `Main ->
      return basename
  | `Test ->
      Chain_services.chain_id cctxt ~chain:`Test ()
      >>=? fun chain_id -> test_filename chain_id
  | `Hash chain_id ->
      Chain_services.chain_id cctxt ~chain:`Main ()
      >>=? fun main_chain_id ->
      if Chain_id.(chain_id = main_chain_id) then return basename
      else test_filename chain_id )
  >>=? fun filename -> return {filename; chain}

let filename {filename; _} = filename

let chain {chain; _} = chain
src/proto_alpha/lib_delegate/client_baking_files.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record location {_ : Type} := {
  filename : string;
  chain : Tezos_shell_services.Chain_services.chain }.
Arguments location : clear implicits.

Definition resolve_location {F G I a b i o p q : Type}
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (chain : Tezos_shell_services.Chain_services.chain) (kind : variant)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (location variant)) :=
  let basename :=
    match kind with
    | Block => "block" % string
    | Endorsement => "endorsement" % string
    | Nonce => "nonce" % string
    end in
  let test_filename (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    Stdlib.Format.kasprintf Tezos_base__TzPervasives._return
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "test_" % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "_" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)))) "test_%a_%s" % string)
      Tezos_base__TzPervasives.Chain_id.pp_short chain_id basename in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match chain with
    | Main => Tezos_base__TzPervasives._return basename
    | Test =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell_services.Chain_services.chain_id cctxt (Some variant) tt)
        (fun chain_id => test_filename chain_id)
    | Hash chain_id =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell_services.Chain_services.chain_id cctxt (Some variant) tt)
        (fun main_chain_id =>
          if Tezos_base__TzPervasives.Chain_id.op_eq chain_id main_chain_id then
            Tezos_base__TzPervasives._return basename
          else
            test_filename chain_id)
    end
    (fun filename =>
      Tezos_base__TzPervasives._return
        {| filename := filename; chain := chain |}).

Definition filename {A : Type} (function_parameter : location A) : string :=
  match function_parameter with
  | {| filename := filename |} => filename
  end.

Definition chain {A : Type} (function_parameter : location A)
  : Tezos_shell_services.Chain_services.chain :=
  match function_parameter with
  | {| chain := chain |} => chain
  end.
src/proto_alpha/lib_delegate/client_baking_files.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type _ location

val resolve_location :
  #Client_context.full ->
  chain:Chain_services.chain ->
  ([< `Block | `Endorsement | `Nonce] as 'kind) ->
  'kind location tzresult Lwt.t

val filename : _ location -> string

val chain : _ location -> Chain_services.chain
src/proto_alpha/lib_delegate/client_baking_files.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter location : forall (_ : Type), Type.

Parameter resolve_location : forall {_ a b i o p q variant : Type},
(((float -> Lwt.t unit) *
  ((unit -> Ptime.t) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      (Uri.t *
        (Tezos_shell_services.Shell_services.block *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              (Tezos_shell_services.Shell_services.chain *
                ((option Z) *
                  ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                    (a * b)) *
                    ((Tezos_rpc.RPC_service.meth ->
                      (option Tezos_data_encoding.Data_encoding.json) ->
                        Uri.t ->
                          Lwt.t
                            (Tezos_rpc.RPC_context.rest_result
                              Tezos_data_encoding.Data_encoding.json
                              (option Tezos_data_encoding.Data_encoding.json)))
                      *
                      (((string ->
                        a ->
                          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a))
                        *
                        ((option (Lwt_stream.t string)) *
                          (((string ->
                            (Tezos_client_base.Client_context.lwt_format a unit)
                              -> a) * (a)) *
                            ((((Tezos_client_base.Client_context.lwt_format a
                              unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                (Tezos_base__TzPervasives.tzresult string)) -> a)
                                * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a
                                  (Tezos_base__TzPervasives.tzresult Bigstring.t))
                                  -> a) * (a)) *
                                  ((string ->
                                    Lwt.t
                                      (Tezos_base__TzPervasives.tzresult string))
                                    *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                                        (((string ->
                                          a ->
                                            (Tezos_base__TzPervasives.Data_encoding.encoding
                                              a) ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  unit)) * (a)) * _)))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    variant -> Lwt.t (Tezos_base__TzPervasives.tzresult (location variant)).

Parameter filename : forall {_ : Type}, (location _) -> string.

Parameter chain : forall {_ : Type},
(location _) -> Tezos_shell_services.Chain_services.chain.
src/proto_alpha/lib_delegate/client_baking_forge.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Protocol_client_context

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.forge"
end)

open Logging

(* Just proving a point *)
let[@warning "-32"] time_protocol__is__protocol_time :
    Alpha_context.Timestamp.t -> Time.Protocol.t =
 fun x -> x

(* The index of the different components of the protocol's validation passes *)
(* TODO: ideally, we would like this to be more abstract and possibly part of
   the protocol, while retaining the generality of lists *)
(* Hypothesis : we suppose [List.length Protocol.Main.validation_passes = 4] *)
let endorsements_index = 0

let votes_index = 1

let anonymous_index = 2

let managers_index = 3

let default_max_priority = 64

let default_minimal_fees =
  match Tez.of_mutez 100L with None -> assert false | Some t -> t

let default_minimal_nanotez_per_gas_unit = Z.of_int 100

let default_minimal_nanotez_per_byte = Z.of_int 1000

type slot =
  Time.Protocol.t * (Client_baking_blocks.block_info * int * public_key_hash)

type state = {
  context_path : string;
  mutable index : Context.index;
  (* Nonces file location *)
  nonces_location : [`Nonce] Client_baking_files.location;
  (* see [get_delegates] below to find delegates when the list is empty *)
  delegates : public_key_hash list;
  (* lazy-initialisation with retry-on-error *)
  constants : Constants.t;
  (* Minimal operation fee required to include an operation in a block *)
  minimal_fees : Tez.t;
  (* Minimal operation fee per gas required to include an operation in a block *)
  minimal_nanotez_per_gas_unit : Z.t;
  (* Minimal operation fee per byte required to include an operation in a block *)
  minimal_nanotez_per_byte : Z.t;
  (* truly mutable *)
  mutable best_slot : slot option;
}

let create_state ?(minimal_fees = default_minimal_fees)
    ?(minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit)
    ?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) context_path
    index nonces_location delegates constants =
  {
    context_path;
    index;
    nonces_location;
    delegates;
    constants;
    minimal_fees;
    minimal_nanotez_per_gas_unit;
    minimal_nanotez_per_byte;
    best_slot = None;
  }

let get_delegates cctxt state =
  match state.delegates with
  | [] ->
      Client_keys.get_keys cctxt
      >>=? fun keys -> return (List.map (fun (_, pkh, _, _) -> pkh) keys)
  | _ ->
      return state.delegates

let generate_seed_nonce () =
  match Nonce.of_bytes (Rand.generate Constants.nonce_length) with
  | Error _errs ->
      assert false
  | Ok nonce ->
      nonce

let forge_block_header (cctxt : #Protocol_client_context.full) ~chain block
    delegate_sk shell priority seed_nonce_hash =
  Client_baking_pow.mine cctxt chain block shell (fun proof_of_work_nonce ->
      {Block_header.priority; seed_nonce_hash; proof_of_work_nonce})
  >>=? fun contents ->
  let unsigned_header =
    Data_encoding.Binary.to_bytes_exn
      Alpha_context.Block_header.unsigned_encoding
      (shell, contents)
  in
  Shell_services.Chain.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Client_keys.append
    cctxt
    delegate_sk
    ~watermark:(Block_header chain_id)
    unsigned_header

let forge_faked_protocol_data ~priority ~seed_nonce_hash =
  Alpha_context.Block_header.
    {
      contents =
        {
          priority;
          seed_nonce_hash;
          proof_of_work_nonce = Client_baking_pow.empty_proof_of_work_nonce;
        };
      signature = Signature.zero;
    }

let assert_valid_operations_hash shell_header operations =
  let operations_hash =
    Operation_list_list_hash.compute
      (List.map
         Operation_list_hash.compute
         (List.map (List.map Tezos_base.Operation.hash) operations))
  in
  fail_unless
    (Operation_list_list_hash.equal
       operations_hash
       shell_header.Tezos_base.Block_header.operations_hash)
    (failure "Client_baking_forge.inject_block: inconsistent header.")

let compute_endorsing_power cctxt ~chain ~block operations =
  Shell_services.Chain.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  fold_left_s
    (fun sum -> function
      | { Alpha_context.protocol_data =
            Operation_data {contents = Single (Endorsement _); _};
          _ } as op ->
          Delegate_services.Endorsing_power.get
            cctxt
            (chain, block)
            op
            chain_id
          >>=? fun power -> return (sum + power) | _ -> return sum)
    0
    operations

let inject_block cctxt ?(force = false) ?seed_nonce_hash ~chain ~shell_header
    ~priority ~delegate_pkh ~delegate_sk ~level operations =
  assert_valid_operations_hash shell_header operations
  >>=? fun () ->
  let block = `Hash (shell_header.Tezos_base.Block_header.predecessor, 0) in
  forge_block_header
    cctxt
    ~chain
    block
    delegate_sk
    shell_header
    priority
    seed_nonce_hash
  >>=? fun signed_header ->
  (* Record baked blocks to prevent double baking  *)
  let open Client_baking_highwatermarks in
  cctxt#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Block
      >>=? fun block_location ->
      may_inject_block cctxt block_location ~delegate:delegate_pkh level
      >>=? function
      | true ->
          record_block cctxt block_location ~delegate:delegate_pkh level
          >>=? fun () -> return_true
      | false ->
          lwt_log_error
            Tag.DSL.(
              fun f ->
                f "Level %a : previously baked"
                -% t event "double_bake_near_miss"
                -% a level_tag level)
          >>= fun () -> return force)
  >>=? function
  | false ->
      fail (Level_previously_baked level)
  | true ->
      Shell_services.Injection.block
        cctxt
        ~force
        ~chain
        signed_header
        operations
      >>=? fun block_hash ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "Client_baking_forge.inject_block: inject %a"
            -% t event "inject_baked_block"
            -% a Block_hash.Logging.tag block_hash
            -% t signed_header_tag signed_header
            -% t operations_tag operations)
      >>= fun () -> return block_hash

type error += Failed_to_preapply of Tezos_base.Operation.t * error list

type error += Forking_test_chain

let () =
  register_error_kind
    `Permanent
    ~id:"Client_baking_forge.failed_to_preapply"
    ~title:"Fail to preapply an operation"
    ~description:""
    ~pp:(fun ppf (op, err) ->
      let h = Tezos_base.Operation.hash op in
      Format.fprintf
        ppf
        "@[Failed to preapply %a:@ @[<v 4>%a@]@]"
        Operation_hash.pp_short
        h
        pp_print_error
        err)
    Data_encoding.(
      obj2
        (req "operation" (dynamic_size Tezos_base.Operation.encoding))
        (req "error" RPC_error.encoding))
    (function Failed_to_preapply (hash, err) -> Some (hash, err) | _ -> None)
    (fun (hash, err) -> Failed_to_preapply (hash, err))

let get_manager_operation_gas_and_fee op =
  let {protocol_data = Operation_data {contents; _}; _} = op in
  let open Operation in
  let l = to_list (Contents_list contents) in
  fold_left_s
    (fun ((total_fee, total_gas) as acc) -> function
      | Contents (Manager_operation {fee; gas_limit; _}) ->
          (Lwt.return @@ Environment.wrap_error @@ Tez.(total_fee +? fee))
          >>=? fun total_fee -> return (total_fee, Z.add total_gas gas_limit)
      | _ -> return acc)
    (Tez.zero, Z.zero)
    l

(* Sort operation consisdering potential gas and storage usage.
   Weight = fee / (max ( (size/size_total), (gas/gas_total))) *)
let sort_manager_operations ~max_size ~hard_gas_limit_per_block ~minimal_fees
    ~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte
    (operations : packed_operation list) =
  let compute_weight op (fee, gas) =
    let size = Data_encoding.Binary.length Operation.encoding op in
    let size_f = Q.of_int size in
    let gas_f = Q.of_bigint gas in
    let fee_f = Q.of_int64 (Tez.to_mutez fee) in
    let size_ratio = Q.(size_f / Q.of_int max_size) in
    let gas_ratio = Q.(gas_f / Q.of_bigint hard_gas_limit_per_block) in
    (size, gas, Q.(fee_f / max size_ratio gas_ratio))
  in
  filter_map_s
    (fun op ->
      get_manager_operation_gas_and_fee op
      >>=? fun (fee, gas) ->
      if Tez.(fee < minimal_fees) then return_none
      else
        let ((size, gas, _ratio) as weight) = compute_weight op (fee, gas) in
        let open Environment in
        let fees_in_nanotez =
          Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
        in
        let enough_fees_for_gas =
          let minimal_fees_in_nanotez =
            Z.mul minimal_nanotez_per_gas_unit gas
          in
          Z.compare minimal_fees_in_nanotez fees_in_nanotez <= 0
        in
        let enough_fees_for_size =
          let minimal_fees_in_nanotez =
            Z.mul minimal_nanotez_per_byte (Z.of_int size)
          in
          Z.compare minimal_fees_in_nanotez fees_in_nanotez <= 0
        in
        if enough_fees_for_size && enough_fees_for_gas then
          return_some (op, weight)
        else return_none)
    operations
  >>=? fun operations ->
  (* We sort by the biggest weight *)
  return
    (List.sort
       (fun (_, (_, _, w)) (_, (_, _, w')) -> Q.compare w' w)
       operations)

let retain_operations_up_to_quota operations quota =
  let {Tezos_protocol_environment.max_op; max_size} = quota in
  let operations =
    match max_op with Some n -> List.sub operations n | None -> operations
  in
  let exception Full of packed_operation list in
  let operations =
    try
      List.fold_left
        (fun (ops, size) op ->
          let operation_size =
            Data_encoding.Binary.length Alpha_context.Operation.encoding op
          in
          let new_size = size + operation_size in
          if new_size > max_size then raise (Full ops)
          else (op :: ops, new_size))
        ([], 0)
        operations
      |> fst
    with Full ops -> ops
  in
  List.rev operations

let trim_manager_operations ~max_size ~hard_gas_limit_per_block
    manager_operations =
  map_s
    (fun op ->
      get_manager_operation_gas_and_fee op
      >>=? fun (_fee, gas) ->
      let size = Data_encoding.Binary.length Operation.encoding op in
      return (op, (size, gas)))
    manager_operations
  >>=? fun manager_operations ->
  List.fold_left
    (fun (total_size, total_gas, (good_ops, bad_ops)) (op, (size, gas)) ->
      let new_size = total_size + size in
      let new_gas = Z.(total_gas + gas) in
      if new_size > max_size || Z.gt new_gas hard_gas_limit_per_block then
        (new_size, new_gas, (good_ops, op :: bad_ops))
      else (new_size, new_gas, (op :: good_ops, bad_ops)))
    (0, Z.zero, ([], []))
    manager_operations
  |> fun (_, _, (good_ops, bad_ops)) ->
  (* We keep the overflowing operations, it may be used for client-side validation *)
  return (List.rev good_ops, List.rev bad_ops)

(* We classify operations, sort managers operation by interest and add bad ones at the end *)
(* Hypothesis : we suppose that the received manager operations have a valid gas_limit *)

(** [classify_operations] classify the operation in 4 lists indexed as such :
    - 0 -> Endorsements
    - 1 -> Votes and proposals
    - 2 -> Anonymous operations
    - 3 -> High-priority manager operations.
    Returns two list :
    - A desired set of operations to be included
    - Potentially overflowing operations *)
let classify_operations (cctxt : #Protocol_client_context.full) ~chain ~block
    ~hard_gas_limit_per_block ~minimal_fees ~minimal_nanotez_per_gas_unit
    ~minimal_nanotez_per_byte (ops : packed_operation list) =
  Alpha_block_services.live_blocks cctxt ~chain ~block ()
  >>=? fun live_blocks ->
  (* Remove operations that are too old *)
  let ops =
    List.filter
      (fun {shell = {branch; _}; _} -> Block_hash.Set.mem branch live_blocks)
      ops
  in
  let validation_passes_len = List.length Main.validation_passes in
  let t = Array.make validation_passes_len [] in
  List.iter
    (fun (op : packed_operation) ->
      List.iter
        (fun pass -> t.(pass) <- op :: t.(pass))
        (Main.acceptable_passes op))
    ops ;
  let t = Array.map List.rev t in
  (* Retrieve the optimist maximum paying manager operations *)
  let manager_operations = t.(managers_index) in
  let {Environment.Updater.max_size; _} =
    List.nth Main.validation_passes managers_index
  in
  sort_manager_operations
    ~max_size
    ~hard_gas_limit_per_block
    ~minimal_fees
    ~minimal_nanotez_per_gas_unit
    ~minimal_nanotez_per_byte
    manager_operations
  >>=? fun ordered_operations ->
  (* Greedy heuristic *)
  trim_manager_operations
    ~max_size
    ~hard_gas_limit_per_block
    (List.map fst ordered_operations)
  >>=? fun (desired_manager_operations, overflowing_manager_operations) ->
  t.(managers_index) <- desired_manager_operations ;
  return (Array.to_list t, overflowing_manager_operations)

let forge (op : Operation.packed) : Operation.raw =
  {
    shell = op.shell;
    proto =
      Data_encoding.Binary.to_bytes_exn
        Alpha_context.Operation.protocol_data_encoding
        op.protocol_data;
  }

let ops_of_mempool (ops : Alpha_block_services.Mempool.t) =
  (* We only retain the applied, unprocessed and delayed operations *)
  List.rev
    ( Operation_hash.Map.fold (fun _ op acc -> op :: acc) ops.unprocessed
    @@ Operation_hash.Map.fold
         (fun _ (op, _) acc -> op :: acc)
         ops.branch_delayed
    @@ List.rev_map (fun (_, op) -> op) ops.applied )

let unopt_operations cctxt chain mempool = function
  | None -> (
    match mempool with
    | None ->
        Alpha_block_services.Mempool.pending_operations cctxt ~chain ()
        >>=? fun mpool ->
        let ops = ops_of_mempool mpool in
        return ops
    | Some file ->
        Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file
        >>=? fun json ->
        let mpool =
          Data_encoding.Json.destruct
            Alpha_block_services.S.Mempool.encoding
            json
        in
        let ops = ops_of_mempool mpool in
        return ops )
  | Some operations ->
      return operations

let all_ops_valid (results : error Preapply_result.t list) =
  let open Operation_hash.Map in
  List.for_all
    (fun (result : error Preapply_result.t) ->
      is_empty result.refused
      && is_empty result.branch_refused
      && is_empty result.branch_delayed)
    results

let decode_priority cctxt chain block ~priority ~endorsing_power =
  match priority with
  | `Set priority ->
      Alpha_services.Delegate.Minimal_valid_time.get
        cctxt
        (chain, block)
        priority
        endorsing_power
      >>=? fun minimal_timestamp -> return (priority, minimal_timestamp)
  | `Auto (src_pkh, max_priority) -> (
      Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
      >>=? fun {level; _} ->
      Alpha_services.Delegate.Baking_rights.get
        cctxt
        ?max_priority
        ~levels:[level]
        ~delegates:[src_pkh]
        (chain, block)
      >>=? fun possibilities ->
      try
        let {Alpha_services.Delegate.Baking_rights.priority = prio; _} =
          List.find
            (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level)
            possibilities
        in
        Alpha_services.Delegate.Minimal_valid_time.get
          cctxt
          (chain, block)
          prio
          endorsing_power
        >>=? fun minimal_timestamp -> return (prio, minimal_timestamp)
      with Not_found ->
        failwith "No slot found at level %a" Raw_level.pp level )

let unopt_timestamp ?(force = false) timestamp minimal_timestamp =
  let timestamp =
    match timestamp with
    | None ->
        minimal_timestamp
    | Some timestamp ->
        timestamp
  in
  if (not force) && timestamp < minimal_timestamp then
    failwith
      "Proposed timestamp %a is earlier than minimal timestamp %a"
      Time.Protocol.pp_hum
      timestamp
      Time.Protocol.pp_hum
      minimal_timestamp
  else return timestamp

let merge_preapps (old : error Preapply_result.t)
    (neu : error Preapply_result.t) =
  let merge _ a b =
    (* merge ops *)
    match (a, b) with
    | (None, None) ->
        None
    | (Some x, None) ->
        Some x
    | (_, Some y) ->
        Some y
  in
  let merge = Operation_hash.Map.merge merge in
  (* merge op maps *)
  (* merge preapplies *)
  {
    Preapply_result.applied = [];
    refused = merge old.refused neu.refused;
    branch_refused = merge old.branch_refused neu.branch_refused;
    branch_delayed = merge old.branch_delayed neu.branch_delayed;
  }

let error_of_op (result : error Preapply_result.t) op =
  let op = forge op in
  let h = Tezos_base.Operation.hash op in
  try
    Some
      (Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.refused))
  with Not_found -> (
    try
      Some
        (Failed_to_preapply
           (op, snd @@ Operation_hash.Map.find h result.branch_refused))
    with Not_found -> (
      try
        Some
          (Failed_to_preapply
             (op, snd @@ Operation_hash.Map.find h result.branch_delayed))
      with Not_found -> None ) )

let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority
    ?protocol_data
    ((operations : packed_operation list list), overflowing_operations) =
  (* Retrieve the minimal valid time for when the block can be baked with 0 endorsements *)
  Delegate_services.Minimal_valid_time.get cctxt (chain, block) priority 0
  >>=? fun min_valid_timestamp ->
  let open Client_baking_simulator in
  lwt_debug
    Tag.DSL.(
      fun f ->
        f "starting client-side validation after %a"
        -% t event "baking_local_validation_start"
        -% a Block_hash.Logging.tag block_info.Client_baking_blocks.hash)
  >>= fun () ->
  begin_construction
    ~timestamp:min_valid_timestamp
    ?protocol_data
    state.index
    block_info
  >>= (function
        | Ok inc ->
            return inc
        | Error errs ->
            lwt_log_error
              Tag.DSL.(
                fun f ->
                  f "Error while fetching current context : %a"
                  -% t event "context_fetch_error"
                  -% a errs_tag errs)
            >>= fun () ->
            lwt_log_notice
              Tag.DSL.(
                fun f ->
                  f "Retrying to open the context" -% t event "reopen_context")
            >>= fun () ->
            Client_baking_simulator.load_context
              ~context_path:state.context_path
            >>= fun index ->
            begin_construction
              ~timestamp:min_valid_timestamp
              ?protocol_data
              index
              block_info
            >>=? fun inc ->
            state.index <- index ;
            return inc)
  >>=? fun initial_inc ->
  let endorsements = List.nth operations endorsements_index in
  let votes = List.nth operations votes_index in
  let anonymous = List.nth operations anonymous_index in
  let managers = List.nth operations managers_index in
  let validate_operation inc op =
    add_operation inc op
    >>= function
    | Error errs ->
        lwt_debug
          Tag.DSL.(
            fun f ->
              f
                "@[<v 4>Client-side validation: invalid operation filtered %a@\n\
                 %a@]"
              -% t event "baking_rejected_invalid_operation"
              -% a Operation_hash.Logging.tag (Operation.hash_packed op)
              -% a errs_tag errs)
        >>= fun () -> Lwt.return_none
    | Ok (resulting_state, _receipt) ->
        Lwt.return_some resulting_state
  in
  let filter_valid_operations inc ops =
    Lwt_list.fold_left_s
      (fun (inc, acc) op ->
        validate_operation inc op
        >>= function
        | None ->
            Lwt.return (inc, acc)
        | Some inc' ->
            Lwt.return (inc', op :: acc))
      (inc, [])
      ops
  in
  (* First pass : we filter out invalid operations by applying them in the correct order *)
  filter_valid_operations initial_inc endorsements
  >>= fun (inc, endorsements) ->
  filter_valid_operations inc votes
  >>= fun (inc, votes) ->
  filter_valid_operations inc anonymous
  >>= fun (manager_inc, anonymous) ->
  (* Retrieve the correct index order *)
  let managers = List.sort Protocol.compare_operations managers in
  let overflowing_operations =
    List.sort Protocol.compare_operations overflowing_operations
  in
  filter_valid_operations manager_inc (managers @ overflowing_operations)
  >>= fun (inc, managers) ->
  finalize_construction inc
  >>=? fun _ ->
  let quota : Environment.Updater.quota list = Main.validation_passes in
  let {Constants.hard_gas_limit_per_block; _} = state.constants.parametric in
  let votes =
    retain_operations_up_to_quota (List.rev votes) (List.nth quota votes_index)
  in
  let anonymous =
    retain_operations_up_to_quota
      (List.rev anonymous)
      (List.nth quota anonymous_index)
  in
  trim_manager_operations
    ~max_size:(List.nth quota managers_index).max_size
    ~hard_gas_limit_per_block
    managers
  >>=? fun (accepted_managers, _overflowing_managers) ->
  (* Retrieve the correct index order *)
  let accepted_managers =
    List.sort Protocol.compare_operations accepted_managers
  in
  (* Second pass : make sure we only keep valid operations *)
  filter_valid_operations manager_inc accepted_managers
  >>= fun (_, accepted_managers) ->
  (* Put the operations back in order *)
  let operations =
    List.map List.rev [endorsements; votes; anonymous; accepted_managers]
  in
  (* Construct a context with the valid operations and a correct timestamp *)
  compute_endorsing_power cctxt ~chain ~block endorsements
  >>=? fun current_endorsing_power ->
  Delegate_services.Minimal_valid_time.get
    cctxt
    (chain, block)
    priority
    current_endorsing_power
  >>=? fun expected_validity ->
  (* Finally, we construct a block with the minimal possible timestamp
     given the endorsing power *)
  begin_construction
    ~timestamp:expected_validity
    ?protocol_data
    state.index
    block_info
  >>=? fun inc ->
  fold_left_s
    (fun inc op -> add_operation inc op >>=? fun (inc, _receipt) -> return inc)
    inc
    (List.flatten operations)
  >>=? fun final_inc ->
  finalize_construction final_inc
  >>=? fun (validation_result, metadata) ->
  return
    (final_inc, (validation_result, metadata), operations, expected_validity)

(* Build the block header : mimics node prevalidation *)
let finalize_block_header shell_header ~timestamp validation_result operations
    =
  let {Tezos_protocol_environment.context; fitness; message; _} =
    validation_result
  in
  let validation_passes = List.length Main.validation_passes in
  let operations_hash : Operation_list_list_hash.t =
    Operation_list_list_hash.compute
      (List.map
         (fun sl ->
           Operation_list_hash.compute (List.map Operation.hash_packed sl))
         operations)
  in
  let context = Shell_context.unwrap_disk_context context in
  Context.get_test_chain context
  >>= (function
        | Not_running ->
            return context
        | Running {expiration; _} ->
            if Time.Protocol.(expiration <= timestamp) then
              Context.set_test_chain context Not_running
              >>= fun context -> return context
            else return context
        | Forking _ ->
            fail Forking_test_chain)
  >>=? fun context ->
  let context = Context.hash ~time:timestamp ?message context in
  let header =
    Tezos_base.Block_header.
      {
        shell_header with
        level = Int32.succ shell_header.level;
        validation_passes;
        operations_hash;
        fitness;
        context;
      }
  in
  return header

let forge_block cctxt ?force ?operations ?(best_effort = operations = None)
    ?(sort = best_effort) ?(minimal_fees = default_minimal_fees)
    ?(minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit)
    ?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) ?timestamp
    ?mempool ?context_path ?seed_nonce_hash ~chain ~priority ~delegate_pkh
    ~delegate_sk block =
  (* making the arguments usable *)
  unopt_operations cctxt chain mempool operations
  >>=? fun operations_arg ->
  compute_endorsing_power cctxt ~chain ~block operations_arg
  >>=? fun endorsing_power ->
  decode_priority cctxt chain block ~priority ~endorsing_power
  >>=? fun (priority, minimal_timestamp) ->
  unopt_timestamp ?force timestamp minimal_timestamp
  >>=? fun timestamp ->
  (* get basic building blocks *)
  let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
  Alpha_services.Constants.all cctxt (chain, block)
  >>=? fun Constants.
             { parametric = {hard_gas_limit_per_block; endorsers_per_block; _};
               _ } ->
  classify_operations
    cctxt
    ~chain
    ~hard_gas_limit_per_block
    ~block
    ~minimal_fees
    ~minimal_nanotez_per_gas_unit
    ~minimal_nanotez_per_byte
    operations_arg
  >>=? fun (operations, overflowing_ops) ->
  (* Ensure that we retain operations up to the quota *)
  let quota : Environment.Updater.quota list = Main.validation_passes in
  let endorsements =
    List.sub (List.nth operations endorsements_index) endorsers_per_block
  in
  let votes =
    retain_operations_up_to_quota
      (List.nth operations votes_index)
      (List.nth quota votes_index)
  in
  let anonymous =
    retain_operations_up_to_quota
      (List.nth operations anonymous_index)
      (List.nth quota anonymous_index)
  in
  (* Size/Gas check already occured in classify operations *)
  let managers = List.nth operations managers_index in
  let operations = [endorsements; votes; anonymous; managers] in
  ( match context_path with
  | None ->
      Alpha_block_services.Helpers.Preapply.block
        cctxt
        ~chain
        ~block
        ~timestamp
        ~sort
        ~protocol_data
        operations
      >>=? fun (shell_header, result) ->
      let operations =
        List.map (fun l -> List.map snd l.Preapply_result.applied) result
      in
      (* everything went well (or we don't care about errors): GO! *)
      if best_effort || all_ops_valid result then
        return (shell_header, operations)
        (* some errors (and we care about them) *)
      else
        let result =
          List.fold_left merge_preapps Preapply_result.empty result
        in
        Lwt.return_error @@ List.filter_map (error_of_op result) operations_arg
  | Some context_path ->
      assert sort ;
      assert best_effort ;
      Context.init ~readonly:true context_path
      >>= fun index ->
      Client_baking_blocks.info cctxt ~chain block
      >>=? fun bi ->
      Alpha_services.Constants.all cctxt (chain, `Head 0)
      >>=? fun constants ->
      Client_baking_files.resolve_location cctxt ~chain `Nonce
      >>=? fun nonces_location ->
      let state =
        {
          context_path;
          index;
          nonces_location;
          constants;
          delegates = [];
          best_slot = None;
          minimal_fees = default_minimal_fees;
          minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit;
          minimal_nanotez_per_byte = default_minimal_nanotez_per_byte;
        }
      in
      filter_and_apply_operations
        cctxt
        state
        ~chain
        ~block
        ~priority
        ~protocol_data
        bi
        (operations, overflowing_ops)
      >>=? fun ( final_context,
                 (validation_result, _),
                 operations,
                 min_valid_timestamp ) ->
      let current_protocol = bi.next_protocol in
      let context =
        Shell_context.unwrap_disk_context validation_result.context
      in
      Context.get_protocol context
      >>= fun next_protocol ->
      if Protocol_hash.equal current_protocol next_protocol then
        finalize_block_header
          final_context.header
          ~timestamp:min_valid_timestamp
          validation_result
          operations
        >>= function
        | Error (Forking_test_chain :: _) ->
            Alpha_block_services.Helpers.Preapply.block
              cctxt
              ~chain
              ~block
              ~timestamp:min_valid_timestamp
              ~sort
              ~protocol_data
              operations
            >>=? fun (shell_header, _result) ->
            return (shell_header, List.map (List.map forge) operations)
        | Error _ as errs ->
            Lwt.return errs
        | Ok shell_header ->
            return (shell_header, List.map (List.map forge) operations)
      else
        lwt_log_notice
          Tag.DSL.(
            fun f ->
              f "New protocol detected: using shell validation"
              -% t event "shell_prevalidation_notice")
        >>= fun () ->
        Alpha_block_services.Helpers.Preapply.block
          cctxt
          ~chain
          ~block
          ~timestamp:min_valid_timestamp
          ~sort
          ~protocol_data
          operations
        >>=? fun (shell_header, _result) ->
        return (shell_header, List.map (List.map forge) operations) )
  >>=? fun (shell_header, operations) ->
  (* Now for some logging *)
  let total_op_count = List.length operations_arg in
  let valid_op_count = List.length (List.concat operations) in
  lwt_log_notice
    Tag.DSL.(
      fun f ->
        f
          "found %d valid operations (%d refused) for timestamp %a (fitness %a)"
        -% t event "found_valid_operations"
        -% s valid_ops valid_op_count
        -% s refused_ops (total_op_count - valid_op_count)
        -% a timestamp_tag (Time.System.of_protocol_exn timestamp)
        -% a fitness_tag shell_header.fitness)
  >>= fun () ->
  ( match Environment.wrap_error (Raw_level.of_int32 shell_header.level) with
  | Ok level ->
      return level
  | Error errs as err ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Error on raw_level conversion : %a"
            -% t event "block_injection_failed"
            -% a errs_tag errs)
      >>= fun () -> Lwt.return err )
  >>=? fun level ->
  inject_block
    cctxt
    ?force
    ~chain
    ~shell_header
    ~priority
    ?seed_nonce_hash
    ~delegate_pkh
    ~delegate_sk
    ~level
    operations
  >>= function
  | Ok hash ->
      return hash
  | Error errs as error ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f
              "@[<v 4>Error while injecting block@ @[Included operations : \
               %a@]@ %a@]"
            -% t event "block_injection_failed"
            -% a raw_operations_tag (List.concat operations)
            -% a errs_tag errs)
      >>= fun () -> Lwt.return error

let shell_prevalidation (cctxt : #Protocol_client_context.full) ~chain ~block
    ~timestamp seed_nonce_hash operations
    ((_, (bi, priority, delegate)) as _slot) =
  let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
  Alpha_block_services.Helpers.Preapply.block
    cctxt
    ~chain
    ~block
    ~timestamp
    ~sort:true
    ~protocol_data
    operations
  >>= function
  | Error errs ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f
              "Shell-side validation: error while prevalidating operations:@\n\
               %a"
            -% t event "built_invalid_block_error"
            -% a errs_tag errs)
      >>= fun () -> return_none
  | Ok (shell_header, operations) ->
      let raw_ops =
        List.map (fun l -> List.map snd l.Preapply_result.applied) operations
      in
      return_some
        (bi, priority, shell_header, raw_ops, delegate, seed_nonce_hash)

let filter_outdated_endorsements expected_level ops =
  List.filter
    (function
      | { Alpha_context.protocol_data =
            Operation_data {contents = Single (Endorsement {level; _}); _};
          _ } ->
          Raw_level.equal expected_level level
      | _ ->
          true)
    ops

(** [fetch_operations] retrieve the operations present in the
    mempool. If no endorsements are present in the initial set, it
    waits until it's able to build a valid block. *)
let fetch_operations (cctxt : #Protocol_client_context.full) ~chain
    (_, (head, priority, _delegate)) =
  Alpha_block_services.Mempool.monitor_operations
    cctxt
    ~chain
    ~applied:true
    ~branch_delayed:true
    ~refused:false
    ~branch_refused:false
    ()
  >>=? fun (operation_stream, _stop) ->
  (* Hypothesis : the first call to the stream returns instantly, even if the mempool is empty. *)
  Lwt_stream.get operation_stream
  >>= function
  | None ->
      (* New head received : aborting block construction *)
      return_none
  | Some current_mempool ->
      let block = `Hash (head.Client_baking_blocks.hash, 0) in
      let operations =
        ref (filter_outdated_endorsements head.level current_mempool)
      in
      (* Actively request our peers' for missing operations *)
      Shell_services.Mempool.request_operations cctxt ~chain ()
      >>=? fun () ->
      let compute_minimal_valid_time () =
        compute_endorsing_power cctxt ~chain ~block !operations
        >>=? fun current_endorsing_power ->
        Delegate_services.Minimal_valid_time.get
          cctxt
          (chain, block)
          priority
          current_endorsing_power
      in
      let compute_timeout () =
        compute_minimal_valid_time ()
        >>=? fun expected_validity ->
        match Client_baking_scheduling.sleep_until expected_validity with
        | None ->
            return_unit
        | Some timeout ->
            timeout >>= fun () -> return_unit
      in
      let last_get_event = ref None in
      let get_event () =
        match !last_get_event with
        | None ->
            let t = Lwt_stream.get operation_stream in
            last_get_event := Some t ;
            t
        | Some t ->
            t
      in
      let rec loop () =
        Lwt.choose
          [ (compute_timeout () >|= fun _ -> `Timeout);
            (get_event () >|= fun e -> `Event e) ]
        >>= function
        | `Event (Some op_list) ->
            last_get_event := None ;
            let op_list = filter_outdated_endorsements head.level op_list in
            operations := op_list @ !operations ;
            loop ()
        | `Timeout ->
            (* Retrieve the remaining operations present in the stream
               before block construction *)
            let remaining_operations =
              filter_outdated_endorsements
                head.level
                (List.flatten (Lwt_stream.get_available operation_stream))
            in
            operations := remaining_operations @ !operations ;
            compute_minimal_valid_time ()
            >>=? fun expected_validity ->
            return_some (!operations, expected_validity)
        | `Event None ->
            (* Got new head while waiting:
               - not enough endorsements received ;
               - late at baking *)
            return_none
      in
      loop ()

(** Given a delegate baking slot [build_block] constructs a full block
    with consistent operations that went through the client-side
    validation *)
let build_block cctxt state seed_nonce_hash
    ((slot_timestamp, (bi, priority, delegate)) as slot) =
  let chain = `Hash bi.Client_baking_blocks.chain_id in
  let block = `Hash (bi.hash, 0) in
  Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
  >>=? fun next_level ->
  let seed_nonce_hash =
    if next_level.Level.expected_commitment then Some seed_nonce_hash else None
  in
  Client_keys.Public_key_hash.name cctxt delegate
  >>=? fun name ->
  lwt_debug
    Tag.DSL.(
      fun f ->
        f "Try baking after %a (slot %d) for %s (%a)"
        -% t event "try_baking"
        -% a Block_hash.Logging.tag bi.hash
        -% s bake_priority_tag priority
        -% s Client_keys.Logging.tag name
        -% a timestamp_tag (Time.System.of_protocol_exn slot_timestamp))
  >>= fun () ->
  fetch_operations cctxt ~chain slot
  >>=? function
  | None ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f
              "Received a new head while waiting for operations. Aborting \
               this block."
            -% t event "new_head_received")
      >>= fun () -> return_none
  | Some (operations, timestamp) -> (
      let hard_gas_limit_per_block =
        state.constants.parametric.hard_gas_limit_per_block
      in
      classify_operations
        cctxt
        ~chain
        ~hard_gas_limit_per_block
        ~minimal_fees:state.minimal_fees
        ~minimal_nanotez_per_gas_unit:state.minimal_nanotez_per_gas_unit
        ~minimal_nanotez_per_byte:state.minimal_nanotez_per_byte
        ~block
        operations
      >>=? fun (operations, overflowing_ops) ->
      let next_version =
        match
          Tezos_base.Block_header.get_forced_protocol_upgrade
            ~level:(Raw_level.to_int32 next_level.Level.level)
        with
        | None ->
            bi.next_protocol
        | Some hash ->
            hash
      in
      if Protocol_hash.(Protocol.hash <> next_version) then
        (* Let the shell validate this *)
        shell_prevalidation
          cctxt
          ~chain
          ~block
          ~timestamp
          seed_nonce_hash
          operations
          slot
      else
        let protocol_data =
          forge_faked_protocol_data ~priority ~seed_nonce_hash
        in
        filter_and_apply_operations
          cctxt
          state
          ~chain
          ~block
          ~priority
          ~protocol_data
          bi
          (operations, overflowing_ops)
        >>= function
        | Error errs ->
            lwt_log_error
              Tag.DSL.(
                fun f ->
                  f
                    "Client-side validation: error while filtering invalid \
                     operations :@\n\
                     @[<v 4>%a@]"
                  -% t event "client_side_validation_error"
                  -% a errs_tag errs)
            >>= fun () ->
            lwt_log_notice
              Tag.DSL.(
                fun f ->
                  f "Building a block using shell validation"
                  -% t event "shell_prevalidation_notice")
            >>= fun () ->
            shell_prevalidation
              cctxt
              ~chain
              ~block
              ~timestamp
              seed_nonce_hash
              operations
              slot
        | Ok
            (final_context, (validation_result, _), operations, valid_timestamp)
          ->
            ( if
              Time.System.(Systime_os.now () < of_protocol_exn valid_timestamp)
            then
              lwt_log_notice
                Tag.DSL.(
                  fun f ->
                    f "[%a] not ready to inject yet, waiting until %a"
                    -% a timestamp_tag (Systime_os.now ())
                    -% a
                         timestamp_tag
                         (Time.System.of_protocol_exn valid_timestamp)
                    -% t event "waiting_before_injection")
              >>= fun () ->
              match Client_baking_scheduling.sleep_until valid_timestamp with
              | None ->
                  Lwt.return_unit
              | Some timeout ->
                  timeout
            else Lwt.return_unit )
            >>= fun () ->
            lwt_debug
              Tag.DSL.(
                fun f ->
                  f
                    "Try forging locally the block header for %a (slot %d) \
                     for %s (%a)"
                  -% t event "try_forging"
                  -% a Block_hash.Logging.tag bi.hash
                  -% s bake_priority_tag priority
                  -% s Client_keys.Logging.tag name
                  -% a timestamp_tag (Time.System.of_protocol_exn timestamp))
            >>= fun () ->
            let current_protocol = bi.next_protocol in
            let context =
              Shell_context.unwrap_disk_context validation_result.context
            in
            Context.get_protocol context
            >>= fun next_protocol ->
            if Protocol_hash.equal current_protocol next_protocol then
              finalize_block_header
                final_context.header
                ~timestamp:valid_timestamp
                validation_result
                operations
              >>= function
              | Error (Forking_test_chain :: _) ->
                  shell_prevalidation
                    cctxt
                    ~chain
                    ~block
                    ~timestamp
                    seed_nonce_hash
                    operations
                    slot
              | Error _ as errs ->
                  Lwt.return errs
              | Ok shell_header ->
                  let raw_ops = List.map (List.map forge) operations in
                  return_some
                    ( bi,
                      priority,
                      shell_header,
                      raw_ops,
                      delegate,
                      seed_nonce_hash )
            else
              lwt_log_notice
                Tag.DSL.(
                  fun f ->
                    f "New protocol detected: using shell validation"
                    -% t event "shell_prevalidation_notice")
              >>= fun () ->
              shell_prevalidation
                cctxt
                ~chain
                ~block
                ~timestamp
                seed_nonce_hash
                operations
                slot )

(** [bake cctxt state] create a single block when woken up to do
    so. All the necessary information is available in the
    [state.best_slot]. *)
let bake (cctxt : #Protocol_client_context.full) ~chain state =
  ( match state.best_slot with
  | None ->
      assert false (* unreachable *)
  | Some slot ->
      return slot )
  >>=? fun slot ->
  let seed_nonce = generate_seed_nonce () in
  let seed_nonce_hash = Nonce.hash seed_nonce in
  build_block cctxt state seed_nonce_hash slot
  >>=? function
  | Some (head, priority, shell_header, operations, delegate, seed_nonce_hash)
    -> (
      let level = Raw_level.succ head.level in
      Client_keys.Public_key_hash.name cctxt delegate
      >>=? fun name ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "Injecting block (priority %d, fitness %a) for %s after %a..."
            -% t event "start_injecting_block"
            -% s bake_priority_tag priority
            -% a fitness_tag shell_header.fitness
            -% s Client_keys.Logging.tag name
            -% a Block_hash.Logging.predecessor_tag shell_header.predecessor
            -% t Signature.Public_key_hash.Logging.tag delegate)
      >>= fun () ->
      Client_keys.get_key cctxt delegate
      >>=? fun (_, _, delegate_sk) ->
      inject_block
        cctxt
        ~chain
        ~force:false
        ~shell_header
        ~priority
        ?seed_nonce_hash
        ~delegate_pkh:delegate
        ~delegate_sk
        ~level
        operations
      >>= function
      | Error errs ->
          lwt_log_error
            Tag.DSL.(
              fun f ->
                f
                  "@[<v 4>Error while injecting block@ @[Included operations \
                   : %a@]@ %a@]"
                -% t event "block_injection_failed"
                -% a raw_operations_tag (List.concat operations)
                -% a errs_tag errs)
          >>= fun () -> return_unit
      | Ok block_hash ->
          lwt_log_notice
            Tag.DSL.(
              fun f ->
                f
                  "Injected block %a for %s after %a (level %a, priority %d, \
                   fitness %a, operations %a)."
                -% t event "injected_block"
                -% a Block_hash.Logging.tag block_hash
                -% s Client_keys.Logging.tag name
                -% a Block_hash.Logging.tag shell_header.predecessor
                -% a level_tag level
                -% s bake_priority_tag priority
                -% a fitness_tag shell_header.fitness
                -% a operations_tag operations)
          >>= fun () ->
          ( if seed_nonce_hash <> None then
            cctxt#with_lock (fun () ->
                let open Client_baking_nonces in
                load cctxt state.nonces_location
                >>=? fun nonces ->
                let nonces = add nonces block_hash seed_nonce in
                save cctxt state.nonces_location nonces)
            |> trace_exn (Failure "Error while recording nonce")
          else return_unit )
          >>=? fun () -> return_unit )
  | None ->
      return_unit

(** [get_baking_slots] calls the node via RPC to retrieve the potential
    slots for the given delegates within a given range of priority *)
let get_baking_slots cctxt ?(max_priority = default_max_priority) new_head
    delegates =
  let chain = `Hash new_head.Client_baking_blocks.chain_id in
  let block = `Hash (new_head.hash, 0) in
  let level = Raw_level.succ new_head.level in
  Alpha_services.Delegate.Baking_rights.get
    cctxt
    ~max_priority
    ~levels:[level]
    ~delegates
    (chain, block)
  >>= function
  | Error errs ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Error while fetching baking possibilities:\n%a"
            -% t event "baking_slot_fetch_errors"
            -% a errs_tag errs)
      >>= fun () -> Lwt.return_nil
  | Ok [] ->
      Lwt.return_nil
  | Ok slots ->
      let slots =
        List.filter_map
          (function
            | {Alpha_services.Delegate.Baking_rights.timestamp = None; _} ->
                None
            | {timestamp = Some timestamp; priority; delegate; _} ->
                Some (timestamp, (new_head, priority, delegate)))
          slots
      in
      Lwt.return slots

(** [compute_best_slot_on_current_level] retrieves, among the given
    delegates, the highest priority slot for the current level. Then,
    it registers this slot in the state so the timeout knows when to
    wake up. *)
let compute_best_slot_on_current_level ?max_priority
    (cctxt : #Protocol_client_context.full) state new_head =
  get_delegates cctxt state
  >>=? fun delegates ->
  let level = Raw_level.succ new_head.Client_baking_blocks.level in
  get_baking_slots cctxt ?max_priority new_head delegates
  >>= function
  | [] ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            let max_priority =
              Option.unopt ~default:default_max_priority max_priority
            in
            f "No slot found at level %a (max_priority = %d)"
            -% t event "no_slot_found" -% a level_tag level
            -% s bake_priority_tag max_priority)
      >>= fun () -> return_none
      (* No slot found *)
  | h :: t ->
      (* One or more slot found, fetching the best (lowest) priority.
         We do not suppose that the received slots are sorted. *)
      let ((timestamp, (_, priority, delegate)) as best_slot) =
        List.fold_left
          (fun ((_, (_, priority, _)) as acc) ((_, (_, priority', _)) as slot) ->
            if priority < priority' then acc else slot)
          h
          t
      in
      Client_keys.Public_key_hash.name cctxt delegate
      >>=? fun name ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f
              "New baking slot found (level %a, priority %d) at %a for %s \
               after %a."
            -% t event "have_baking_slot" -% a level_tag level
            -% s bake_priority_tag priority
            -% a timestamp_tag (Time.System.of_protocol_exn timestamp)
            -% s Client_keys.Logging.tag name
            -% a Block_hash.Logging.tag new_head.hash
            -% t Signature.Public_key_hash.Logging.tag delegate)
      >>= fun () ->
      (* Found at least a slot *)
      return_some best_slot

(** [reveal_potential_nonces] reveal registered nonces *)
let reveal_potential_nonces (cctxt : #Client_context.full) constants ~chain
    ~block =
  cctxt#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Nonce
      >>=? fun nonces_location ->
      Client_baking_nonces.load cctxt nonces_location
      >>= function
      | Error err ->
          lwt_log_error
            Tag.DSL.(
              fun f ->
                f "Cannot read nonces: %a" -% t event "read_nonce_fail"
                -% a errs_tag err)
          >>= fun () -> return_unit
      | Ok nonces -> (
          Client_baking_nonces.get_unrevealed_nonces
            cctxt
            nonces_location
            nonces
          >>= function
          | Error err ->
              lwt_log_error
                Tag.DSL.(
                  fun f ->
                    f "Cannot retrieve unrevealed nonces: %a"
                    -% t event "nonce_retrieval_fail"
                    -% a errs_tag err)
              >>= fun () -> return_unit
          | Ok [] ->
              return_unit
          | Ok nonces_to_reveal -> (
              Client_baking_revelation.inject_seed_nonce_revelation
                cctxt
                ~chain
                ~block
                nonces_to_reveal
              >>= function
              | Error err ->
                  lwt_log_error
                    Tag.DSL.(
                      fun f ->
                        f "Cannot inject nonces: %a"
                        -% t event "nonce_injection_fail"
                        -% a errs_tag err)
                  >>= fun () -> return_unit
              | Ok () ->
                  (* If some nonces are to be revealed it means:
                   - We entered a new cycle and we can clear old nonces ;
                   - A revelation was not included yet in the cycle beggining.
                   So, it is safe to only filter outdated_nonces there *)
                  Client_baking_nonces.filter_outdated_nonces
                    cctxt
                    ~constants
                    nonces_location
                    nonces
                  >>=? fun live_nonces ->
                  Client_baking_nonces.save cctxt nonces_location live_nonces
                  >>=? fun () -> return_unit ) ))

(** [create] starts the main loop of the baker. The loop monitors new blocks and
    starts individual baking operations when baking-slots are available to any of
    the [delegates] *)
let create (cctxt : #Protocol_client_context.full) ?minimal_fees
    ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?max_priority
    ~chain ~context_path delegates block_stream =
  let state_maker bi =
    Alpha_services.Constants.all cctxt (chain, `Head 0)
    >>=? fun constants ->
    Client_baking_simulator.load_context ~context_path
    >>= fun index ->
    Client_baking_simulator.check_context_consistency
      index
      bi.Client_baking_blocks.context
    >>=? fun () ->
    Client_baking_files.resolve_location cctxt ~chain `Nonce
    >>=? fun nonces_location ->
    let state =
      create_state
        ?minimal_fees
        ?minimal_nanotez_per_gas_unit
        ?minimal_nanotez_per_byte
        context_path
        index
        nonces_location
        delegates
        constants
    in
    return state
  in
  let event_k cctxt state new_head =
    reveal_potential_nonces
      cctxt
      state.constants
      ~chain
      ~block:(`Hash (new_head.Client_baking_blocks.hash, 0))
    >>= fun _ignore_nonce_err ->
    compute_best_slot_on_current_level ?max_priority cctxt state new_head
    >>=? fun slot ->
    state.best_slot <- slot ;
    return_unit
  in
  let compute_timeout state =
    match state.best_slot with
    | None ->
        (* No slot, just wait for new blocks which will give more info *)
        Lwt_utils.never_ending ()
    | Some (timestamp, _) -> (
      match Client_baking_scheduling.sleep_until timestamp with
      | None ->
          Lwt.return_unit
      | Some timeout ->
          timeout )
  in
  let timeout_k cctxt state () =
    bake cctxt ~chain state
    >>=? fun () ->
    (* Stopping the timeout and waiting for the next block *)
    state.best_slot <- None ;
    return_unit
  in
  Client_baking_scheduling.main
    ~name:"baker"
    ~cctxt
    ~stream:block_stream
    ~state_maker
    ~pre_loop:event_k
    ~compute_timeout
    ~timeout_k
    ~event_k
src/proto_alpha/lib_delegate/client_baking_forge.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_baking_alpha.Logging.

Definition time_protocol__is__protocol_time
  (x : Tezos_protocol_alpha.Protocol.Alpha_context.Timestamp.t)
  : Tezos_base__TzPervasives.Time.Protocol.t := x.

Definition endorsements_index : Z := 0.

Definition votes_index : Z := 1.

Definition anonymous_index : Z := 2.

Definition managers_index : Z := 3.

Definition default_max_priority : Z := 64.

Definition default_minimal_fees
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
  match Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez 100 with
  | None => false
  | Some t => t
  end.

Definition default_minimal_nanotez_per_gas_unit : Z.t := Z.of_int 100.

Definition default_minimal_nanotez_per_byte : Z.t := Z.of_int 1000.

Definition slot :=
  Tezos_base__TzPervasives.Time.Protocol.t *
    (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
      Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash).

Record state := {
  context_path : string;
  index : Tezos_storage.Context.index;
  nonces_location : Tezos_baking_alpha.Client_baking_files.location variant;
  delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
  constants : Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t;
  minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  minimal_nanotez_per_gas_unit : Z.t;
  minimal_nanotez_per_byte : Z.t;
  best_slot : option slot }.

Definition create_state
  (op_star_o_p_t_star :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : (option Z.t) ->
    (option Z.t) ->
      string ->
        Tezos_storage.Context.index ->
          (Tezos_baking_alpha.Client_baking_files.location variant) ->
            (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
              ->
              Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t -> state :=
  let minimal_fees :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => default_minimal_fees
    end in
  fun op_star_o_p_t_star =>
    let minimal_nanotez_per_gas_unit :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_minimal_nanotez_per_gas_unit
      end in
    fun op_star_o_p_t_star =>
      let minimal_nanotez_per_byte :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => default_minimal_nanotez_per_byte
        end in
      fun context_path =>
        fun index =>
          fun nonces_location =>
            fun delegates =>
              fun constants =>
                {| context_path := context_path; index := index;
                  nonces_location := nonces_location; delegates := delegates;
                  constants := constants; minimal_fees := minimal_fees;
                  minimal_nanotez_per_gas_unit := minimal_nanotez_per_gas_unit;
                  minimal_nanotez_per_byte := minimal_nanotez_per_byte;
                  best_slot := None |}.

Definition get_delegates {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (state : state)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_client_base.Client_keys.Public_key_hash.t)) :=
  match delegates state with
  | [] =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_client_base.Client_keys.get_keys cctxt)
      (fun keys =>
        Tezos_base__TzPervasives._return
          (Tezos_base__TzPervasives.List.map
            (fun function_parameter =>
              match function_parameter with
              | (_, pkh, _, _) => pkh
              end) keys))
  | _ => Tezos_base__TzPervasives._return (delegates state)
  end.

Definition generate_seed_nonce (function_parameter : unit)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  match function_parameter with
  | tt =>
    match
      Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.of_bytes
        (Tezos_base__TzPervasives.Rand.generate
          Tezos_protocol_alpha.Protocol.Alpha_context.Constants.nonce_length)
      with
    | inr _errs => false
    | inl nonce => nonce
    end
  end.

Definition forge_block_header {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (delegate_sk : Tezos_client_base.Client_keys.sk_uri)
  (shell : Tezos_base__TzPervasives.Block_header.shell_header) (priority : Z)
  (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_baking_alpha.Client_baking_pow.mine cctxt chain block shell
      (fun proof_of_work_nonce =>
        {| Block_header.priority := priority;
          Block_header.seed_nonce_hash := seed_nonce_hash;
          Block_header.proof_of_work_nonce := proof_of_work_nonce |}))
    (fun contents =>
      let unsigned_header :=
        Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
          Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.unsigned_encoding
          (shell, contents) in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_shell_services.Shell_services.Chain.chain_id cctxt (Some chain)
          tt)
        (fun chain_id =>
          Tezos_client_base.Client_keys.append cctxt
            (Some (Block_header chain_id)) delegate_sk unsigned_header)).

Definition forge_faked_protocol_data
  (priority : Z)
  (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.protocol_data :=
  {|
    contents :=
      {| priority := priority; seed_nonce_hash := seed_nonce_hash;
        proof_of_work_nonce :=
          Tezos_baking_alpha.Client_baking_pow.empty_proof_of_work_nonce |};
    signature := Tezos_base__TzPervasives.Signature.zero |}.

Definition assert_valid_operations_hash
  (shell_header : Tezos_base.Block_header.shell_header)
  (operations : list (list Tezos_base.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let operations_hash :=
    Tezos_base__TzPervasives.Operation_list_list_hash.compute
      (Tezos_base__TzPervasives.List.map
        Tezos_base__TzPervasives.Operation_list_hash.compute
        (Tezos_base__TzPervasives.List.map
          (Tezos_base__TzPervasives.List.map Tezos_base.Operation.hash)
          operations)) in
  Tezos_base__TzPervasives.fail_unless
    (Tezos_base__TzPervasives.Operation_list_list_hash.equal operations_hash
      (Tezos_base.Block_header.operations_hash shell_header))
    (Tezos_base__TzPervasives.failure
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Client_baking_forge.inject_block: inconsistent header." % string
          CamlinternalFormatBasics.End_of_format)
        "Client_baking_forge.inject_block: inconsistent header." % string)).

Definition compute_endorsing_power {E F G I K M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.Chain.chain * F) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (G * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (Tezos_shell_services.Shell_services.Chain.chain * F) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (I * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (Tezos_shell_services.Shell_services.Chain.chain * F) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (K * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.Chain.chain * F) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (M * a * b * c * q * i * o)) * N))))) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.Chain.chain * F) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (G * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (Tezos_shell_services.Shell_services.Chain.chain * F) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (I * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (Tezos_shell_services.Shell_services.Chain.chain * F) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (K * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.Chain.chain * F) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (M * a * b * c * q * i * o)) * N)))))
  (chain : Tezos_shell_services.Shell_services.Chain.chain) (block : F)
  (operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell_services.Shell_services.Chain.chain_id cctxt (Some chain) tt)
    (fun chain_id =>
      Tezos_base__TzPervasives.fold_left_s
        (fun sum =>
          fun function_parameter =>
            match function_parameter with
            |
              {|
                Alpha_context.protocol_data :=
                  Operation_data {| contents := Single (Endorsement _) |}
                  |} as op =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_power.get
                  cctxt (chain, block) op chain_id)
                (fun power => Tezos_base__TzPervasives._return (Z.add sum power))
            | _ => Tezos_base__TzPervasives._return sum
            end) 0 operations).

Definition inject_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (op_star_o_p_t_star : option bool)
  : (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
    Tezos_shell_services.Shell_services.chain ->
      Tezos_base.Block_header.shell_header ->
        Z ->
          Tezos_base__TzPervasives.Signature.public_key_hash ->
            Tezos_client_base.Client_keys.sk_uri ->
              Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
                (list (list Tezos_base.Operation.t)) ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      Tezos_base__TzPervasives.Block_hash.t) :=
  let force :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun seed_nonce_hash =>
    fun chain =>
      fun shell_header =>
        fun priority =>
          fun delegate_pkh =>
            fun delegate_sk =>
              fun level =>
                fun operations =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (assert_valid_operations_hash shell_header operations)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        let block := variant in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (forge_block_header cctxt chain block delegate_sk
                            shell_header priority seed_nonce_hash)
                          (fun signed_header =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (send
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (Tezos_baking_alpha.Client_baking_files.resolve_location
                                        cctxt chain variant)
                                      (fun block_location =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_baking_alpha.Client_baking_highwatermarks.may_inject_block
                                            cctxt block_location delegate_pkh
                                            level)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | true =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_baking_alpha.Client_baking_highwatermarks.record_block
                                                  cctxt block_location
                                                  delegate_pkh level)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.return_true
                                                  end)
                                            | false =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                (lwt_log_error
                                                  (fun f =>
                                                    Tag.DSL.op_minus_percent
                                                      (Tag.DSL.op_minus_percent
                                                        (f
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "Level " % string
                                                              (CamlinternalFormatBasics.Alpha
                                                                (CamlinternalFormatBasics.String_literal
                                                                  " : previously baked"
                                                                    % string
                                                                  CamlinternalFormatBasics.End_of_format)))
                                                            "Level %a : previously baked"
                                                              % string))
                                                        (Tag.DSL.t event
                                                          "double_bake_near_miss"
                                                            % string))
                                                      (Tag.DSL.a
                                                        Tezos_baking_alpha.Logging.level_tag
                                                        level)))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives._return
                                                      force
                                                  end)
                                            end))
                                  end))
                              (fun function_parameter =>
                                match function_parameter with
                                | false =>
                                  Tezos_base__TzPervasives.fail
                                    (Level_previously_baked level)
                                | true =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_shell_services.Shell_services.Injection.block
                                      cctxt None (Some force) (Some chain)
                                      signed_header operations)
                                    (fun block_hash =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (lwt_log_info
                                          (fun f =>
                                            Tag.DSL.op_minus_percent
                                              (Tag.DSL.op_minus_percent
                                                (Tag.DSL.op_minus_percent
                                                  (Tag.DSL.op_minus_percent
                                                    (f
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Client_baking_forge.inject_block: inject "
                                                            % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            CamlinternalFormatBasics.End_of_format))
                                                        "Client_baking_forge.inject_block: inject %a"
                                                          % string))
                                                    (Tag.DSL.t event
                                                      "inject_baked_block" %
                                                        string))
                                                  (Tag.DSL.a
                                                    Tezos_base__TzPervasives.Block_hash.Logging.tag
                                                    block_hash))
                                                (Tag.DSL.t
                                                  Tezos_baking_alpha.Logging.signed_header_tag
                                                  signed_header))
                                              (Tag.DSL.t
                                                Tezos_baking_alpha.Logging.operations_tag
                                                operations)))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives._return
                                              block_hash
                                          end))
                                end))
                      end).

Definition get_manager_operation_gas_and_fee
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)) :=
  match op with
  | {| protocol_data := Operation_data {| contents := contents |} |} =>
    let l :=
      Tezos_protocol_alpha.Protocol.Alpha_context.Operation.to_list
        (Contents_list contents) in
    Tezos_base__TzPervasives.fold_left_s
      (fun function_parameter =>
        match function_parameter with
        | (total_fee, total_gas) as acc =>
          fun function_parameter =>
            match function_parameter with
            |
              Contents
                (Manager_operation {| fee := fee; gas_limit := gas_limit |}) =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (apply Lwt._return
                  (apply Tezos_protocol_alpha.Protocol.Environment.wrap_error
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                      total_fee fee)))
                (fun total_fee =>
                  Tezos_base__TzPervasives._return
                    (total_fee, (Z.add total_gas gas_limit)))
            | _ => Tezos_base__TzPervasives._return acc
            end
        end) (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero, Z.zero) l
  end.

Definition sort_manager_operations
  (max_size : Z) (hard_gas_limit_per_block : Z.t)
  (minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (minimal_nanotez_per_gas_unit : Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (minimal_nanotez_per_byte : Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation *
          (Z * Tezos_protocol_alpha.Protocol.Environment.Z.t * Q.t)))) :=
  let compute_weight
    (op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
    (function_parameter :
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)
    : Z * Z.t * Q.t :=
    match function_parameter with
    | (fee, gas) =>
      let size :=
        Tezos_base__TzPervasives.Data_encoding.Binary.length
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.encoding op in
      let size_f := Q.of_int size in
      let gas_f := Q.of_bigint gas in
      let fee_f :=
        Q.of_int64
          (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez fee) in
      let size_ratio := Q.op_div size_f (Q.of_int max_size) in
      let gas_ratio := Q.op_div gas_f (Q.of_bigint hard_gas_limit_per_block) in
      (size, gas, (Q.op_div fee_f (Q.max size_ratio gas_ratio)))
    end in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.filter_map_s
      (fun op =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (get_manager_operation_gas_and_fee op)
          (fun function_parameter =>
            match function_parameter with
            | (fee, gas) =>
              if
                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_lt fee
                  minimal_fees then
                Tezos_base__TzPervasives.return_none
              else
                match compute_weight op (fee, gas) with
                | (size, gas, _ratio) as weight =>
                  let fees_in_nanotez :=
                    Tezos_protocol_alpha.Protocol.Environment.Z.mul
                      (Tezos_protocol_alpha.Protocol.Environment.Z.of_int64
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez
                          fee))
                      (Tezos_protocol_alpha.Protocol.Environment.Z.of_int 1000)
                    in
                  let enough_fees_for_gas :=
                    let minimal_fees_in_nanotez :=
                      Tezos_protocol_alpha.Protocol.Environment.Z.mul
                        minimal_nanotez_per_gas_unit gas in
                    OCaml.Stdlib.le
                      (Tezos_protocol_alpha.Protocol.Environment.Z.compare
                        minimal_fees_in_nanotez fees_in_nanotez) 0 in
                  let enough_fees_for_size :=
                    let minimal_fees_in_nanotez :=
                      Tezos_protocol_alpha.Protocol.Environment.Z.mul
                        minimal_nanotez_per_byte
                        (Tezos_protocol_alpha.Protocol.Environment.Z.of_int size)
                      in
                    OCaml.Stdlib.le
                      (Tezos_protocol_alpha.Protocol.Environment.Z.compare
                        minimal_fees_in_nanotez fees_in_nanotez) 0 in
                  if andb enough_fees_for_size enough_fees_for_gas then
                    Tezos_base__TzPervasives.return_some (op, weight)
                  else
                    Tezos_base__TzPervasives.return_none
                end
            end)) operations)
    (fun operations =>
      Tezos_base__TzPervasives._return
        (Tezos_base__TzPervasives.List.sort
          (fun function_parameter =>
            match function_parameter with
            | (_, (_, _, w)) =>
              fun function_parameter =>
                match function_parameter with
                | (_, (_, _, w')) => Q.compare w' w
                end
            end) operations)).

Definition retain_operations_up_to_quota
  (operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  (quota : Tezos_protocol_environment.quota)
  : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation :=
  match quota with
  | {|
    Tezos_protocol_environment.max_size := max_size;
      Tezos_protocol_environment.max_op := max_op
      |} =>
    let operations :=
      match max_op with
      | Some n => Tezos_base__TzPervasives.List.sub operations n
      | None => operations
      end in
    let_exception
  end.

Definition trim_manager_operations
  (max_size : Z) (hard_gas_limit_per_block : Z.t)
  (manager_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) *
        (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_base__TzPervasives.map_s
      (fun op =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (get_manager_operation_gas_and_fee op)
          (fun function_parameter =>
            match function_parameter with
            | (_fee, gas) =>
              let size :=
                Tezos_base__TzPervasives.Data_encoding.Binary.length
                  Tezos_protocol_alpha.Protocol.Alpha_context.Operation.encoding
                  op in
              Tezos_base__TzPervasives._return (op, (size, gas))
            end)) manager_operations)
    (fun manager_operations =>
      OCaml.Stdlib.reverse_apply
        (Tezos_base__TzPervasives.List.fold_left
          (fun function_parameter =>
            match function_parameter with
            | (total_size, total_gas, (good_ops, bad_ops)) =>
              fun function_parameter =>
                match function_parameter with
                | (op, (size, gas)) =>
                  let new_size := Z.add total_size size in
                  let new_gas := Z.op_plus total_gas gas in
                  if
                    orb (OCaml.Stdlib.gt new_size max_size)
                      (Z.gt new_gas hard_gas_limit_per_block) then
                    (new_size, new_gas, (good_ops, (cons op bad_ops)))
                  else
                    (new_size, new_gas, ((cons op good_ops), bad_ops))
                end
            end) (0, Z.zero, ([], [])) manager_operations)
        (fun function_parameter =>
          match function_parameter with
          | (_, _, (good_ops, bad_ops)) =>
            Tezos_base__TzPervasives._return
              ((Tezos_base__TzPervasives.List.rev good_ops),
                (Tezos_base__TzPervasives.List.rev bad_ops))
          end)).

Definition classify_operations {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block)
  (hard_gas_limit_per_block : Z.t)
  (minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (minimal_nanotez_per_gas_unit : Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (minimal_nanotez_per_byte : Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (ops : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((list (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))
        * (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.live_blocks
      cctxt (Some chain) (Some block) tt)
    (fun live_blocks =>
      let ops :=
        Tezos_base__TzPervasives.List.filter
          (fun function_parameter =>
            match function_parameter with
            | {| shell := {| branch := branch |} |} =>
              Tezos_base__TzPervasives.Block_hash.Set.mem branch live_blocks
            end) ops in
      let validation_passes_len :=
        Tezos_base__TzPervasives.List.length
          Tezos_protocol_alpha.Protocol.Main.validation_passes in
      let t := Stdlib.Array.make validation_passes_len [] in
      Tezos_base__TzPervasives.List.iter
        (fun op =>
          Tezos_base__TzPervasives.List.iter
            (fun pass =>
              Stdlib.Array.set t pass (cons op (Stdlib.Array.get t pass)))
            (Tezos_protocol_alpha.Protocol.Main.acceptable_passes op)) ops;
      let t := Stdlib.Array.map Tezos_base__TzPervasives.List.rev t in
      let manager_operations := Stdlib.Array.get t managers_index in
      match
        Tezos_base__TzPervasives.List.nth
          Tezos_protocol_alpha.Protocol.Main.validation_passes managers_index
        with
      | {| Environment.Updater.max_size := max_size |} =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (sort_manager_operations max_size hard_gas_limit_per_block
            minimal_fees minimal_nanotez_per_gas_unit minimal_nanotez_per_byte
            manager_operations)
          (fun ordered_operations =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (trim_manager_operations max_size hard_gas_limit_per_block
                (Tezos_base__TzPervasives.List.map fst ordered_operations))
              (fun function_parameter =>
                match function_parameter with
                | (desired_manager_operations, overflowing_manager_operations)
                  =>
                  Stdlib.Array.set t managers_index desired_manager_operations;
                  Tezos_base__TzPervasives._return
                    ((Stdlib.Array.to_list t), overflowing_manager_operations)
                end))
      end).

Definition forge
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw :=
  {| shell := shell op;
    proto :=
      Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
        Tezos_protocol_alpha.Protocol.Alpha_context.Operation.protocol_data_encoding
        (protocol_data op) |}.

Definition ops_of_mempool
  (ops :
    Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Mempool.t)
  : list Tezos_protocol_alpha.Protocol.operation :=
  Tezos_base__TzPervasives.List.rev
    (apply
      (Tezos_base__TzPervasives.Operation_hash.Map.fold
        (fun function_parameter =>
          match function_parameter with
          | _ => fun op => fun acc => cons op acc
          end) (unprocessed ops))
      (apply
        (Tezos_base__TzPervasives.Operation_hash.Map.fold
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              fun function_parameter =>
                match function_parameter with
                | (op, _) => fun acc => cons op acc
                end
            end) (branch_delayed ops))
        (Tezos_base__TzPervasives.List.rev_map
          (fun function_parameter =>
            match function_parameter with
            | (_, op) => op
            end) (applied ops)))).

Definition unopt_operations {E F i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (chain : Tezos_shell_services__Block_services.chain) (mempool : option string)
  (function_parameter : option (list Tezos_protocol_alpha.Protocol.operation))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_protocol_alpha.Protocol.operation)) :=
  match function_parameter with
  | None =>
    match mempool with
    | None =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Mempool.pending_operations
          cctxt (Some chain) tt)
        (fun mpool =>
          let ops := ops_of_mempool mpool in
          Tezos_base__TzPervasives._return ops)
    | Some file =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file)
        (fun json =>
          let mpool :=
            Tezos_base__TzPervasives.Data_encoding.Json.destruct
              Tezos_client_alpha.Protocol_client_context.Alpha_block_services.S.Mempool.encoding
              json in
          let ops := ops_of_mempool mpool in
          Tezos_base__TzPervasives._return ops)
    end
  | Some operations => Tezos_base__TzPervasives._return operations
  end.

Definition all_ops_valid
  (results :
    list
      (Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error))
  : bool :=
  Tezos_base__TzPervasives.List.for_all
    (fun result =>
      andb
        (Tezos_base__TzPervasives.Operation_hash.Map.is_empty (refused result))
        (andb
          (Tezos_base__TzPervasives.Operation_hash.Map.is_empty
            (branch_refused result))
          (Tezos_base__TzPervasives.Operation_hash.Map.is_empty
            (branch_delayed result)))) results.

Definition decode_priority {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E) (priority : variant)
  (endorsing_power : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Z * Tezos_protocol_environment_alpha__Environment.Time.t)) :=
  match priority with
  | Set priority =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Minimal_valid_time.get
        cctxt (chain, block) priority endorsing_power)
      (fun minimal_timestamp =>
        Tezos_base__TzPervasives._return (priority, minimal_timestamp))
  | Auto (src_pkh, max_priority) =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level cctxt
        (Some 1) (chain, block))
      (fun function_parameter =>
        match function_parameter with
        | {| level := level |} =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Baking_rights.get
              cctxt (Some (cons level [])) None (Some (cons src_pkh [])) None
              max_priority (chain, block)) (fun possibilities => try)
        end)
  end.

Definition unopt_timestamp (op_star_o_p_t_star : option bool)
  : (option Tezos_base__TzPervasives.Time.Protocol.t) ->
    Tezos_base__TzPervasives.Time.Protocol.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Time.Protocol.t) :=
  let force :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun timestamp =>
    fun minimal_timestamp =>
      let timestamp :=
        match timestamp with
        | None => minimal_timestamp
        | Some timestamp => timestamp
        end in
      if andb (negb force) (OCaml.Stdlib.lt timestamp minimal_timestamp) then
        Tezos_base__TzPervasives.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Proposed timestamp " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  " is earlier than minimal timestamp " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))))
            "Proposed timestamp %a is earlier than minimal timestamp %a" %
              string) Tezos_base__TzPervasives.Time.Protocol.pp_hum timestamp
          Tezos_base__TzPervasives.Time.Protocol.pp_hum minimal_timestamp
      else
        Tezos_base__TzPervasives._return timestamp.

Definition merge_preapps
  (old :
    Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
  (neu :
    Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
  : Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error :=
  let merge {A B : Type} (function_parameter : A)
    : (option B) -> (option B) -> option B :=
    match function_parameter with
    | _ =>
      fun a =>
        fun b =>
          match (a, b) with
          | (None, None) => None
          | (Some x, None) => Some x
          | (_, Some y) => Some y
          end
    end in
  let merge := Tezos_base__TzPervasives.Operation_hash.Map.merge merge in
  {| Preapply_result.applied := [];
    Preapply_result.refused := merge (refused old) (refused neu);
    Preapply_result.branch_refused :=
      merge (branch_refused old) (branch_refused neu);
    Preapply_result.branch_delayed :=
      merge (branch_delayed old) (branch_delayed neu) |}.

Definition error_of_op
  (result :
    Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  : option Tezos_base__TzPervasives.error :=
  let op := forge op in
  let h := Tezos_base.Operation.hash op in
  try.

Definition filter_and_apply_operations {D E G I K M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.Chain.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Shell_services.Chain.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Shell_services.Chain.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Shell_services.Chain.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
              (M * p * q * i * o)) * N))))) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (M * p * q * i * o)) * N) *
      (Tezos_shell_services.Shell_services.Chain.chain * D)) (state : state)
  (chain : Tezos_shell_services.Shell_services.Chain.chain) (block : D)
  (block_info : Tezos_baking_alpha.Client_baking_blocks.block_info)
  (priority : Z)
  (protocol_data : option Tezos_protocol_alpha.Protocol.block_header_data)
  (function_parameter :
    (list (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)) *
      (list Tezos_protocol_alpha.Protocol.operation))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_baking_alpha.Client_baking_simulator.incremental *
        (Tezos_protocol_environment.validation_result *
          Tezos_protocol_alpha.Protocol.block_header_metadata) *
        (list
          (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)) *
        Tezos_protocol_environment_alpha__Environment.Time.t)) :=
  match function_parameter with
  | (_ as operations, overflowing_operations) =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_protocol_alpha.Protocol.Delegate_services.Minimal_valid_time.get
        cctxt (chain, block) priority 0)
      (fun min_valid_timestamp =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_debug
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "starting client-side validation after " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))
                      "starting client-side validation after %a" % string))
                  (Tag.DSL.t event "baking_local_validation_start" % string))
                (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag
                  (Client_baking_blocks.hash block_info))))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_base__TzPervasives.op_gt_gt_eq
                  (Tezos_baking_alpha.Client_baking_simulator.begin_construction
                    min_valid_timestamp protocol_data (index state) block_info)
                  (fun function_parameter =>
                    match function_parameter with
                    | inl inc => Tezos_base__TzPervasives._return inc
                    | inr errs =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (lwt_log_error
                          (fun f =>
                            Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Error while fetching current context : "
                                        % string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))
                                    "Error while fetching current context : %a"
                                      % string))
                                (Tag.DSL.t event "context_fetch_error" % string))
                              (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs)))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (lwt_log_notice
                                (fun f =>
                                  Tag.DSL.op_minus_percent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Retrying to open the context" %
                                            string
                                          CamlinternalFormatBasics.End_of_format)
                                        "Retrying to open the context" % string))
                                    (Tag.DSL.t event "reopen_context" % string)))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (Tezos_baking_alpha.Client_baking_simulator.load_context
                                      (context_path state))
                                    (fun index =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                        (Tezos_baking_alpha.Client_baking_simulator.begin_construction
                                          min_valid_timestamp protocol_data
                                          index block_info)
                                        (fun inc =>
                                          set_field;
                                          Tezos_base__TzPervasives._return inc))
                                end)
                          end)
                    end))
                (fun initial_inc =>
                  let endorsements :=
                    Tezos_base__TzPervasives.List.nth operations
                      endorsements_index in
                  let votes :=
                    Tezos_base__TzPervasives.List.nth operations votes_index in
                  let anonymous :=
                    Tezos_base__TzPervasives.List.nth operations anonymous_index
                    in
                  let managers :=
                    Tezos_base__TzPervasives.List.nth operations managers_index
                    in
                  let validate_operation
                    (inc :
                    Tezos_baking_alpha.Client_baking_simulator.incremental) (op
                    :
                    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
                    : Lwt.t
                      (option
                        Tezos_baking_alpha.Client_baking_simulator.incremental) :=
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (Tezos_baking_alpha.Client_baking_simulator.add_operation
                        inc op)
                      (fun function_parameter =>
                        match function_parameter with
                        | inr errs =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (lwt_debug
                              (fun f =>
                                Tag.DSL.op_minus_percent
                                  (Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Formatting_gen
                                            (CamlinternalFormatBasics.Open_box
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "<v 4>" % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "<v 4>" % string))
                                            (CamlinternalFormatBasics.String_literal
                                              "Client-side validation: invalid operation filtered "
                                                % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Force_newline
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Close_box
                                                      CamlinternalFormatBasics.End_of_format))))))
                                          "@[<v 4>Client-side validation: invalid operation filtered %a@
%a@]"
                                            % string))
                                      (Tag.DSL.t event
                                        "baking_rejected_invalid_operation" %
                                          string))
                                    (Tag.DSL.a
                                      Tezos_base__TzPervasives.Operation_hash.Logging.tag
                                      (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash_packed
                                        op)))
                                  (Tag.DSL.a Tezos_base__TzPervasives.errs_tag
                                    errs)))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => Lwt.return_none
                              end)
                        | inl (resulting_state, _receipt) =>
                          Lwt.return_some resulting_state
                        end) in
                  let filter_valid_operations
                    (inc :
                    Tezos_baking_alpha.Client_baking_simulator.incremental) (ops
                    :
                    list
                      Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
                    : Lwt.t
                      (Tezos_baking_alpha.Client_baking_simulator.incremental *
                        (list
                          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)) :=
                    Lwt_list.fold_left_s
                      (fun function_parameter =>
                        match function_parameter with
                        | (inc, acc) =>
                          fun op =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (validate_operation inc op)
                              (fun function_parameter =>
                                match function_parameter with
                                | None => Lwt._return (inc, acc)
                                | Some inc' => Lwt._return (inc', (cons op acc))
                                end)
                        end) (inc, []) ops in
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (filter_valid_operations initial_inc endorsements)
                    (fun function_parameter =>
                      match function_parameter with
                      | (inc, endorsements) =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (filter_valid_operations inc votes)
                          (fun function_parameter =>
                            match function_parameter with
                            | (inc, votes) =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (filter_valid_operations inc anonymous)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (manager_inc, anonymous) =>
                                    let managers :=
                                      Tezos_base__TzPervasives.List.sort
                                        Tezos_protocol_alpha.Protocol.compare_operations
                                        managers in
                                    let overflowing_operations :=
                                      Tezos_base__TzPervasives.List.sort
                                        Tezos_protocol_alpha.Protocol.compare_operations
                                        overflowing_operations in
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (filter_valid_operations manager_inc
                                        (OCaml.Stdlib.app managers
                                          overflowing_operations))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (inc, managers) =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            (Tezos_baking_alpha.Client_baking_simulator.finalize_construction
                                              inc)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | _ =>
                                                let quota :=
                                                  Tezos_protocol_alpha.Protocol.Main.validation_passes
                                                  in
                                                match
                                                  parametric (constants state)
                                                  with
                                                | {|
                                                  Constants.hard_gas_limit_per_block := hard_gas_limit_per_block
                                                    |} =>
                                                  let votes :=
                                                    retain_operations_up_to_quota
                                                      (Tezos_base__TzPervasives.List.rev
                                                        votes)
                                                      (Tezos_base__TzPervasives.List.nth
                                                        quota votes_index) in
                                                  let anonymous :=
                                                    retain_operations_up_to_quota
                                                      (Tezos_base__TzPervasives.List.rev
                                                        anonymous)
                                                      (Tezos_base__TzPervasives.List.nth
                                                        quota anonymous_index)
                                                    in
                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                    (trim_manager_operations
                                                      (max_size
                                                        (Tezos_base__TzPervasives.List.nth
                                                          quota managers_index))
                                                      hard_gas_limit_per_block
                                                      managers)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      |
                                                        (accepted_managers,
                                                          _overflowing_managers)
                                                        =>
                                                        let accepted_managers :=
                                                          Tezos_base__TzPervasives.List.sort
                                                            Tezos_protocol_alpha.Protocol.compare_operations
                                                            accepted_managers in
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (filter_valid_operations
                                                            manager_inc
                                                            accepted_managers)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            |
                                                              (_,
                                                                accepted_managers)
                                                              =>
                                                              let operations :=
                                                                Tezos_base__TzPervasives.List.map
                                                                  Tezos_base__TzPervasives.List.rev
                                                                  (cons
                                                                    endorsements
                                                                    (cons votes
                                                                      (cons
                                                                        anonymous
                                                                        (cons
                                                                          accepted_managers
                                                                          []))))
                                                                in
                                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                (compute_endorsing_power
                                                                  cctxt chain
                                                                  block
                                                                  endorsements)
                                                                (fun
                                                                  current_endorsing_power
                                                                  =>
                                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                    (Tezos_protocol_alpha.Protocol.Delegate_services.Minimal_valid_time.get
                                                                      cctxt
                                                                      (chain,
                                                                        block)
                                                                      priority
                                                                      current_endorsing_power)
                                                                    (fun
                                                                      expected_validity
                                                                      =>
                                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                        (Tezos_baking_alpha.Client_baking_simulator.begin_construction
                                                                          expected_validity
                                                                          protocol_data
                                                                          (index
                                                                            state)
                                                                          block_info)
                                                                        (fun inc
                                                                          =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                            (Tezos_base__TzPervasives.fold_left_s
                                                                              (fun
                                                                                inc
                                                                                =>
                                                                                fun
                                                                                  op
                                                                                  =>
                                                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                    (Tezos_baking_alpha.Client_baking_simulator.add_operation
                                                                                      inc
                                                                                      op)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        (inc,
                                                                                          _receipt)
                                                                                        =>
                                                                                        Tezos_base__TzPervasives._return
                                                                                          inc
                                                                                      end))
                                                                              inc
                                                                              (Tezos_base__TzPervasives.List.flatten
                                                                                operations))
                                                                            (fun
                                                                              final_inc
                                                                              =>
                                                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                (Tezos_baking_alpha.Client_baking_simulator.finalize_construction
                                                                                  final_inc)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    (validation_result,
                                                                                      metadata)
                                                                                    =>
                                                                                    Tezos_base__TzPervasives._return
                                                                                      (final_inc,
                                                                                        (validation_result,
                                                                                          metadata),
                                                                                        operations,
                                                                                        expected_validity)
                                                                                  end)))))
                                                            end)
                                                      end)
                                                end
                                              end)
                                        end)
                                  end)
                            end)
                      end))
            end))
  end.

Definition finalize_block_header
  (shell_header : Tezos_base.Block_header.shell_header)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  (validation_result : Tezos_protocol_environment.validation_result)
  (operations :
    list (list Tezos_raw_protocol_alpha__Alpha_context.packed_operation))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base.Block_header.shell_header) :=
  match validation_result with
  | {|
    Tezos_protocol_environment.context := context;
      Tezos_protocol_environment.fitness := fitness;
      Tezos_protocol_environment.message := message
      |} =>
    let validation_passes :=
      Tezos_base__TzPervasives.List.length
        Tezos_protocol_alpha.Protocol.Main.validation_passes in
    let operations_hash :=
      Tezos_base__TzPervasives.Operation_list_list_hash.compute
        (Tezos_base__TzPervasives.List.map
          (fun sl =>
            Tezos_base__TzPervasives.Operation_list_hash.compute
              (Tezos_base__TzPervasives.List.map
                Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash_packed
                sl)) operations) in
    let context := Tezos_shell_context.Shell_context.unwrap_disk_context context
      in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_storage.Context.get_test_chain context)
        (fun function_parameter =>
          match function_parameter with
          | Not_running => Tezos_base__TzPervasives._return context
          | Running {| expiration := expiration |} =>
            if
              Tezos_base__TzPervasives.Time.Protocol.op_lt_eq expiration
                timestamp then
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Tezos_storage.Context.set_test_chain context Not_running)
                (fun context => Tezos_base__TzPervasives._return context)
            else
              Tezos_base__TzPervasives._return context
          | Forking _ => Tezos_base__TzPervasives.fail Forking_test_chain
          end))
      (fun context =>
        let context := Tezos_storage.Context.hash timestamp message context in
        let header := record in
        Tezos_base__TzPervasives._return header)
  end.

Definition forge_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (force : option bool)
  (operations :
    option (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))
  (op_star_o_p_t_star : option bool)
  : (option bool) ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
      (option Tezos_protocol_alpha.Protocol.Environment.Z.t) ->
        (option Tezos_protocol_alpha.Protocol.Environment.Z.t) ->
          (option Tezos_base__TzPervasives.Time.Protocol.t) ->
            (option string) ->
              (option string) ->
                (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
                  Tezos_shell_services__Block_services.chain ->
                    variant ->
                      Tezos_base__TzPervasives.Signature.public_key_hash ->
                        Tezos_client_base.Client_keys.sk_uri ->
                          Tezos_shell_services.Shell_services.block ->
                            Lwt.t
                              (Tezos_base__TzPervasives.tzresult
                                Tezos_base__TzPervasives.Block_hash.t) :=
  let best_effort :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => equiv_decb operations None
    end in
  fun op_star_o_p_t_star =>
    let sort :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => best_effort
      end in
    fun op_star_o_p_t_star =>
      let minimal_fees :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => default_minimal_fees
        end in
      fun op_star_o_p_t_star =>
        let minimal_nanotez_per_gas_unit :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => default_minimal_nanotez_per_gas_unit
          end in
        fun op_star_o_p_t_star =>
          let minimal_nanotez_per_byte :=
            match op_star_o_p_t_star with
            | Some op_star_s_t_h_star => op_star_s_t_h_star
            | None => default_minimal_nanotez_per_byte
            end in
          fun timestamp =>
            fun mempool =>
              fun context_path =>
                fun seed_nonce_hash =>
                  fun chain =>
                    fun priority =>
                      fun delegate_pkh =>
                        fun delegate_sk =>
                          fun block =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (unopt_operations cctxt chain mempool operations)
                              (fun operations_arg =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (compute_endorsing_power cctxt chain block
                                    operations_arg)
                                  (fun endorsing_power =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                      (decode_priority cctxt chain block
                                        priority endorsing_power)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (priority, minimal_timestamp) =>
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            (unopt_timestamp force timestamp
                                              minimal_timestamp)
                                            (fun timestamp =>
                                              let protocol_data :=
                                                forge_faked_protocol_data
                                                  priority seed_nonce_hash in
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all
                                                  cctxt (chain, block))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | {|
                                                    parametric := {|
                                                      endorsers_per_block :=
                                                        endorsers_per_block;
                                                        hard_gas_limit_per_block
                                                          :=
                                                          hard_gas_limit_per_block
                                                        |}
                                                      |} =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                      (classify_operations cctxt
                                                        chain block
                                                        hard_gas_limit_per_block
                                                        minimal_fees
                                                        minimal_nanotez_per_gas_unit
                                                        minimal_nanotez_per_byte
                                                        operations_arg)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        |
                                                          (operations,
                                                            overflowing_ops) =>
                                                          let quota :=
                                                            Tezos_protocol_alpha.Protocol.Main.validation_passes
                                                            in
                                                          let endorsements :=
                                                            Tezos_base__TzPervasives.List.sub
                                                              (Tezos_base__TzPervasives.List.nth
                                                                operations
                                                                endorsements_index)
                                                              endorsers_per_block
                                                            in
                                                          let votes :=
                                                            retain_operations_up_to_quota
                                                              (Tezos_base__TzPervasives.List.nth
                                                                operations
                                                                votes_index)
                                                              (Tezos_base__TzPervasives.List.nth
                                                                quota
                                                                votes_index) in
                                                          let anonymous :=
                                                            retain_operations_up_to_quota
                                                              (Tezos_base__TzPervasives.List.nth
                                                                operations
                                                                anonymous_index)
                                                              (Tezos_base__TzPervasives.List.nth
                                                                quota
                                                                anonymous_index)
                                                            in
                                                          let managers :=
                                                            Tezos_base__TzPervasives.List.nth
                                                              operations
                                                              managers_index in
                                                          let operations :=
                                                            cons endorsements
                                                              (cons votes
                                                                (cons anonymous
                                                                  (cons managers
                                                                    []))) in
                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                            match context_path
                                                              with
                                                            | None =>
                                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Helpers.Preapply.block
                                                                  cctxt
                                                                  (Some chain)
                                                                  (Some block)
                                                                  (Some sort)
                                                                  (Some
                                                                    timestamp)
                                                                  protocol_data
                                                                  operations)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  |
                                                                    (shell_header,
                                                                      result) =>
                                                                    let
                                                                      operations :=
                                                                      Tezos_base__TzPervasives.List.map
                                                                        (fun l
                                                                          =>
                                                                          Tezos_base__TzPervasives.List.map
                                                                            snd
                                                                            (Preapply_result.applied
                                                                              l))
                                                                        result
                                                                      in
                                                                    if
                                                                      orb
                                                                        best_effort
                                                                        (all_ops_valid
                                                                          result)
                                                                      then
                                                                      Tezos_base__TzPervasives._return
                                                                        (shell_header,
                                                                          operations)
                                                                    else
                                                                      let
                                                                        result :=
                                                                        Tezos_base__TzPervasives.List.fold_left
                                                                          merge_preapps
                                                                          Tezos_base__TzPervasives.Preapply_result.empty
                                                                          result
                                                                        in
                                                                      apply
                                                                        Lwt.return_error
                                                                        (Tezos_base__TzPervasives.List.filter_map
                                                                          (error_of_op
                                                                            result)
                                                                          operations_arg)
                                                                  end)
                                                            | Some context_path
                                                              =>
                                                              sort;
                                                              best_effort;
                                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                                (Tezos_storage.Context.init
                                                                  None None
                                                                  (Some true)
                                                                  context_path)
                                                                (fun index =>
                                                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                    (Tezos_baking_alpha.Client_baking_blocks.info
                                                                      cctxt
                                                                      (Some
                                                                        chain)
                                                                      block)
                                                                    (fun bi =>
                                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                        (Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all
                                                                          cctxt
                                                                          (chain,
                                                                            variant))
                                                                        (fun
                                                                          constants
                                                                          =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                            (Tezos_baking_alpha.Client_baking_files.resolve_location
                                                                              cctxt
                                                                              chain
                                                                              variant)
                                                                            (fun
                                                                              nonces_location
                                                                              =>
                                                                              let
                                                                                state :=
                                                                                {|
                                                                                  context_path :=
                                                                                    context_path;
                                                                                  index :=
                                                                                    index;
                                                                                  nonces_location :=
                                                                                    nonces_location;
                                                                                  delegates :=
                                                                                    [];
                                                                                  constants :=
                                                                                    constants;
                                                                                  minimal_fees :=
                                                                                    default_minimal_fees;
                                                                                  minimal_nanotez_per_gas_unit :=
                                                                                    default_minimal_nanotez_per_gas_unit;
                                                                                  minimal_nanotez_per_byte :=
                                                                                    default_minimal_nanotez_per_byte;
                                                                                  best_slot :=
                                                                                    None
                                                                                  |}
                                                                                in
                                                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                (filter_and_apply_operations
                                                                                  cctxt
                                                                                  state
                                                                                  chain
                                                                                  block
                                                                                  bi
                                                                                  priority
                                                                                  (Some
                                                                                    protocol_data)
                                                                                  (operations,
                                                                                    overflowing_ops))
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    (final_context,
                                                                                      (validation_result,
                                                                                        _),
                                                                                      operations,
                                                                                      min_valid_timestamp)
                                                                                    =>
                                                                                    let
                                                                                      current_protocol :=
                                                                                      next_protocol
                                                                                        bi
                                                                                      in
                                                                                    let
                                                                                      context :=
                                                                                      Tezos_shell_context.Shell_context.unwrap_disk_context
                                                                                        (context
                                                                                          validation_result)
                                                                                      in
                                                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                      (Tezos_storage.Context.get_protocol
                                                                                        context)
                                                                                      (fun
                                                                                        next_protocol
                                                                                        =>
                                                                                        if
                                                                                          Tezos_base__TzPervasives.Protocol_hash.equal
                                                                                            current_protocol
                                                                                            next_protocol
                                                                                          then
                                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                            (finalize_block_header
                                                                                              (header
                                                                                                final_context)
                                                                                              min_valid_timestamp
                                                                                              validation_result
                                                                                              operations)
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                inr
                                                                                                  (cons
                                                                                                    Forking_test_chain
                                                                                                    _)
                                                                                                =>
                                                                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                                  (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Helpers.Preapply.block
                                                                                                    cctxt
                                                                                                    (Some
                                                                                                      chain)
                                                                                                    (Some
                                                                                                      block)
                                                                                                    (Some
                                                                                                      sort)
                                                                                                    (Some
                                                                                                      min_valid_timestamp)
                                                                                                    protocol_data
                                                                                                    operations)
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    match
                                                                                                      function_parameter
                                                                                                      with
                                                                                                    |
                                                                                                      (shell_header,
                                                                                                        _result)
                                                                                                      =>
                                                                                                      Tezos_base__TzPervasives._return
                                                                                                        (shell_header,
                                                                                                          (Tezos_base__TzPervasives.List.map
                                                                                                            (Tezos_base__TzPervasives.List.map
                                                                                                              forge)
                                                                                                            operations))
                                                                                                    end)
                                                                                              |
                                                                                                (inr
                                                                                                  _)
                                                                                                  as
                                                                                                  errs
                                                                                                =>
                                                                                                Lwt._return
                                                                                                  errs
                                                                                              |
                                                                                                inl
                                                                                                  shell_header
                                                                                                =>
                                                                                                Tezos_base__TzPervasives._return
                                                                                                  (shell_header,
                                                                                                    (Tezos_base__TzPervasives.List.map
                                                                                                      (Tezos_base__TzPervasives.List.map
                                                                                                        forge)
                                                                                                      operations))
                                                                                              end)
                                                                                        else
                                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                            (lwt_log_notice
                                                                                              (fun
                                                                                                f
                                                                                                =>
                                                                                                Tag.DSL.op_minus_percent
                                                                                                  (f
                                                                                                    (CamlinternalFormatBasics.Format
                                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                                        "New protocol detected: using shell validation"
                                                                                                          %
                                                                                                          string
                                                                                                        CamlinternalFormatBasics.End_of_format)
                                                                                                      "New protocol detected: using shell validation"
                                                                                                        %
                                                                                                        string))
                                                                                                  (Tag.DSL.t
                                                                                                    event
                                                                                                    "shell_prevalidation_notice"
                                                                                                      %
                                                                                                      string)))
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              match
                                                                                                function_parameter
                                                                                                with
                                                                                              |
                                                                                                tt
                                                                                                =>
                                                                                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                                                  (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Helpers.Preapply.block
                                                                                                    cctxt
                                                                                                    (Some
                                                                                                      chain)
                                                                                                    (Some
                                                                                                      block)
                                                                                                    (Some
                                                                                                      sort)
                                                                                                    (Some
                                                                                                      min_valid_timestamp)
                                                                                                    protocol_data
                                                                                                    operations)
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    match
                                                                                                      function_parameter
                                                                                                      with
                                                                                                    |
                                                                                                      (shell_header,
                                                                                                        _result)
                                                                                                      =>
                                                                                                      Tezos_base__TzPervasives._return
                                                                                                        (shell_header,
                                                                                                          (Tezos_base__TzPervasives.List.map
                                                                                                            (Tezos_base__TzPervasives.List.map
                                                                                                              forge)
                                                                                                            operations))
                                                                                                    end)
                                                                                              end))
                                                                                  end)))))
                                                            end
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              |
                                                                (shell_header,
                                                                  operations) =>
                                                                let
                                                                  total_op_count :=
                                                                  Tezos_base__TzPervasives.List.length
                                                                    operations_arg
                                                                  in
                                                                let
                                                                  valid_op_count :=
                                                                  Tezos_base__TzPervasives.List.length
                                                                    (Tezos_base__TzPervasives.List.concat
                                                                      operations)
                                                                  in
                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                  (lwt_log_notice
                                                                    (fun f =>
                                                                      Tag.DSL.op_minus_percent
                                                                        (Tag.DSL.op_minus_percent
                                                                          (Tag.DSL.op_minus_percent
                                                                            (Tag.DSL.op_minus_percent
                                                                              (Tag.DSL.op_minus_percent
                                                                                (f
                                                                                  (CamlinternalFormatBasics.Format
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      "found "
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Int
                                                                                        CamlinternalFormatBasics.Int_d
                                                                                        CamlinternalFormatBasics.No_padding
                                                                                        CamlinternalFormatBasics.No_precision
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          " valid operations ("
                                                                                            %
                                                                                            string
                                                                                          (CamlinternalFormatBasics.Int
                                                                                            CamlinternalFormatBasics.Int_d
                                                                                            CamlinternalFormatBasics.No_padding
                                                                                            CamlinternalFormatBasics.No_precision
                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                              " refused) for timestamp "
                                                                                                %
                                                                                                string
                                                                                              (CamlinternalFormatBasics.Alpha
                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                  " (fitness "
                                                                                                    %
                                                                                                    string
                                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                                    (CamlinternalFormatBasics.Char_literal
                                                                                                      ")"
                                                                                                        %
                                                                                                        char
                                                                                                      CamlinternalFormatBasics.End_of_format)))))))))
                                                                                    "found %d valid operations (%d refused) for timestamp %a (fitness %a)"
                                                                                      %
                                                                                      string))
                                                                                (Tag.DSL.t
                                                                                  event
                                                                                  "found_valid_operations"
                                                                                    %
                                                                                    string))
                                                                              (Tag.DSL.s
                                                                                Tezos_baking_alpha.Logging.valid_ops
                                                                                valid_op_count))
                                                                            (Tag.DSL.s
                                                                              Tezos_baking_alpha.Logging.refused_ops
                                                                              (Z.sub
                                                                                total_op_count
                                                                                valid_op_count)))
                                                                          (Tag.DSL.a
                                                                            Tezos_baking_alpha.Logging.timestamp_tag
                                                                            (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                                                                              timestamp)))
                                                                        (Tag.DSL.a
                                                                          Tezos_baking_alpha.Logging.fitness_tag
                                                                          (fitness
                                                                            shell_header))))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | tt =>
                                                                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                                        match
                                                                          Tezos_protocol_alpha.Protocol.Environment.wrap_error
                                                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.of_int32
                                                                              (level
                                                                                shell_header))
                                                                          with
                                                                        |
                                                                          inl
                                                                            level
                                                                          =>
                                                                          Tezos_base__TzPervasives._return
                                                                            level
                                                                        |
                                                                          (inr
                                                                            errs)
                                                                            as
                                                                            err
                                                                          =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                            (lwt_log_error
                                                                              (fun
                                                                                f
                                                                                =>
                                                                                Tag.DSL.op_minus_percent
                                                                                  (Tag.DSL.op_minus_percent
                                                                                    (f
                                                                                      (CamlinternalFormatBasics.Format
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          "Error on raw_level conversion : "
                                                                                            %
                                                                                            string
                                                                                          (CamlinternalFormatBasics.Alpha
                                                                                            CamlinternalFormatBasics.End_of_format))
                                                                                        "Error on raw_level conversion : %a"
                                                                                          %
                                                                                          string))
                                                                                    (Tag.DSL.t
                                                                                      event
                                                                                      "block_injection_failed"
                                                                                        %
                                                                                        string))
                                                                                  (Tag.DSL.a
                                                                                    Tezos_base__TzPervasives.errs_tag
                                                                                    errs)))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                Lwt._return
                                                                                  err
                                                                              end)
                                                                        end
                                                                        (fun
                                                                          level
                                                                          =>
                                                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                                                            (inject_block
                                                                              cctxt
                                                                              force
                                                                              seed_nonce_hash
                                                                              chain
                                                                              shell_header
                                                                              priority
                                                                              delegate_pkh
                                                                              delegate_sk
                                                                              level
                                                                              operations)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                inl
                                                                                  hash
                                                                                =>
                                                                                Tezos_base__TzPervasives._return
                                                                                  hash
                                                                              |
                                                                                (inr
                                                                                  errs)
                                                                                  as
                                                                                  error
                                                                                =>
                                                                                Tezos_base__TzPervasives.op_gt_gt_eq
                                                                                  (lwt_log_error
                                                                                    (fun
                                                                                      f
                                                                                      =>
                                                                                      Tag.DSL.op_minus_percent
                                                                                        (Tag.DSL.op_minus_percent
                                                                                          (Tag.DSL.op_minus_percent
                                                                                            (f
                                                                                              (CamlinternalFormatBasics.Format
                                                                                                (CamlinternalFormatBasics.Formatting_gen
                                                                                                  (CamlinternalFormatBasics.Open_box
                                                                                                    (CamlinternalFormatBasics.Format
                                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                                        "<v 4>"
                                                                                                          %
                                                                                                          string
                                                                                                        CamlinternalFormatBasics.End_of_format)
                                                                                                      "<v 4>"
                                                                                                        %
                                                                                                        string))
                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                    "Error while injecting block"
                                                                                                      %
                                                                                                      string
                                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                                      (CamlinternalFormatBasics.Break
                                                                                                        "@ "
                                                                                                          %
                                                                                                          string
                                                                                                        1
                                                                                                        0)
                                                                                                      (CamlinternalFormatBasics.Formatting_gen
                                                                                                        (CamlinternalFormatBasics.Open_box
                                                                                                          (CamlinternalFormatBasics.Format
                                                                                                            CamlinternalFormatBasics.End_of_format
                                                                                                            ""
                                                                                                              %
                                                                                                              string))
                                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                                          "Included operations : "
                                                                                                            %
                                                                                                            string
                                                                                                          (CamlinternalFormatBasics.Alpha
                                                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                                                              CamlinternalFormatBasics.Close_box
                                                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                                                (CamlinternalFormatBasics.Break
                                                                                                                  "@ "
                                                                                                                    %
                                                                                                                    string
                                                                                                                  1
                                                                                                                  0)
                                                                                                                (CamlinternalFormatBasics.Alpha
                                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                                    CamlinternalFormatBasics.Close_box
                                                                                                                    CamlinternalFormatBasics.End_of_format))))))))))
                                                                                                "@[<v 4>Error while injecting block@ @[Included operations : %a@]@ %a@]"
                                                                                                  %
                                                                                                  string))
                                                                                            (Tag.DSL.t
                                                                                              event
                                                                                              "block_injection_failed"
                                                                                                %
                                                                                                string))
                                                                                          (Tag.DSL.a
                                                                                            Tezos_baking_alpha.Logging.raw_operations_tag
                                                                                            (Tezos_base__TzPervasives.List.concat
                                                                                              operations)))
                                                                                        (Tag.DSL.a
                                                                                          Tezos_base__TzPervasives.errs_tag
                                                                                          errs)))
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      Lwt._return
                                                                                        error
                                                                                    end)
                                                                              end))
                                                                    end)
                                                              end)
                                                        end)
                                                  end))
                                        end))).

Definition shell_prevalidation {D F H J L M N O P Q a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
  (operations : list (list Tezos_protocol_alpha.Protocol.operation))
  (function_parameter : O * (P * Z * Q))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        (P * Z * Tezos_base__TzPervasives.Block_header.shell_header *
          (list (list Tezos_base.Operation.t)) * Q *
          (option Tezos_raw_protocol_alpha.Nonce_hash.t)))) :=
  match function_parameter with
  | (_, (bi, priority, delegate)) as _slot =>
    let protocol_data := forge_faked_protocol_data priority seed_nonce_hash in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Helpers.Preapply.block
        cctxt (Some chain) (Some block) (Some true) (Some timestamp)
        protocol_data operations)
      (fun function_parameter =>
        match function_parameter with
        | inr errs =>
          Tezos_base__TzPervasives.op_gt_gt_eq
            (lwt_log_error
              (fun f =>
                Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Shell-side validation: error while prevalidating operations:"
                            % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Force_newline
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)))
                        "Shell-side validation: error while prevalidating operations:@
%a"
                          % string))
                    (Tag.DSL.t event "built_invalid_block_error" % string))
                  (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs)))
            (fun function_parameter =>
              match function_parameter with
              | tt => Tezos_base__TzPervasives.return_none
              end)
        | inl (shell_header, operations) =>
          let raw_ops :=
            Tezos_base__TzPervasives.List.map
              (fun l =>
                Tezos_base__TzPervasives.List.map snd
                  (Preapply_result.applied l)) operations in
          Tezos_base__TzPervasives.return_some
            (bi, priority, shell_header, raw_ops, delegate, seed_nonce_hash)
        end)
  end.

Definition filter_outdated_endorsements
  (expected_level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  (ops : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation :=
  Tezos_base__TzPervasives.List.filter
    (fun function_parameter =>
      match function_parameter with
      | {|
        Alpha_context.protocol_data :=
          Operation_data {|
            contents := Single (Endorsement {| level := level |})
              |}
          |} =>
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.equal
          expected_level level
      | _ => true
      end) ops.

Definition fetch_operations {D F H J L M N O P a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (function_parameter :
    O * (Tezos_baking_alpha.Client_baking_blocks.block_info * Z * P))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        ((list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) *
          Tezos_protocol_environment_alpha__Environment.Time.t))) :=
  match function_parameter with
  | (_, (head, priority, _delegate)) =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Mempool.monitor_operations
        cctxt (Some chain) (Some true) (Some true) (Some false) (Some false) tt)
      (fun function_parameter =>
        match function_parameter with
        | (operation_stream, _stop) =>
          Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_stream.get operation_stream)
            (fun function_parameter =>
              match function_parameter with
              | None => Tezos_base__TzPervasives.return_none
              | Some current_mempool =>
                let block := variant in
                let operations :=
                  Stdlib.ref
                    (filter_outdated_endorsements (level head) current_mempool)
                  in
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_shell_services.Shell_services.Mempool.request_operations
                    cctxt (Some chain) tt)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      let compute_minimal_valid_time (function_parameter : unit)
                        : Lwt.t
                          (Tezos_base__TzPervasives.tzresult
                            Tezos_protocol_environment_alpha__Environment.Time.t) :=
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (compute_endorsing_power cctxt chain block
                              (Stdlib.op_exclamation operations))
                            (fun current_endorsing_power =>
                              Tezos_protocol_alpha.Protocol.Delegate_services.Minimal_valid_time.get
                                cctxt (chain, block) priority
                                current_endorsing_power)
                        end in
                      let compute_timeout (function_parameter : unit)
                        : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (compute_minimal_valid_time tt)
                            (fun expected_validity =>
                              match
                                Tezos_baking_alpha.Client_baking_scheduling.sleep_until
                                  expected_validity with
                              | None => Tezos_base__TzPervasives.return_unit
                              | Some timeout =>
                                Tezos_base__TzPervasives.op_gt_gt_eq timeout
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end)
                              end)
                        end in
                      let last_get_event := Stdlib.ref None in
                      let get_event (function_parameter : unit)
                        : Lwt.t
                          (option (list Tezos_protocol_alpha.Protocol.operation)) :=
                        match function_parameter with
                        | tt =>
                          match Stdlib.op_exclamation last_get_event with
                          | None =>
                            let t := Lwt_stream.get operation_stream in
                            Stdlib.op_colon_eq last_get_event (Some t);
                            t
                          | Some t => t
                          end
                        end in
                      let fix loop (function_parameter : unit)
                        : Lwt.t
                          (Tezos_base__TzPervasives.tzresult
                            (option
                              ((list
                                Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
                                *
                                Tezos_protocol_environment_alpha__Environment.Time.t))) :=
                        match function_parameter with
                        | tt =>
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Lwt.choose
                              (cons
                                (Tezos_base__TzPervasives.op_gt_pipe_eq
                                  (compute_timeout tt)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ => variant
                                    end))
                                (cons
                                  (Tezos_base__TzPervasives.op_gt_pipe_eq
                                    (get_event tt) (fun e => variant)) [])))
                            (fun function_parameter =>
                              match function_parameter with
                              | Event (Some op_list) =>
                                Stdlib.op_colon_eq last_get_event None;
                                let op_list :=
                                  filter_outdated_endorsements (level head)
                                    op_list in
                                Stdlib.op_colon_eq operations
                                  (OCaml.Stdlib.app op_list
                                    (Stdlib.op_exclamation operations));
                                loop tt
                              | Timeout =>
                                let remaining_operations :=
                                  filter_outdated_endorsements (level head)
                                    (Tezos_base__TzPervasives.List.flatten
                                      (Lwt_stream.get_available operation_stream))
                                  in
                                Stdlib.op_colon_eq operations
                                  (OCaml.Stdlib.app remaining_operations
                                    (Stdlib.op_exclamation operations));
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (compute_minimal_valid_time tt)
                                  (fun expected_validity =>
                                    Tezos_base__TzPervasives.return_some
                                      ((Stdlib.op_exclamation operations),
                                        expected_validity))
                              | Event None =>
                                Tezos_base__TzPervasives.return_none
                              end)
                        end in
                      loop tt
                    end)
              end)
        end)
  end.

Definition build_block {E F H J L M N a b c i o p q : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                Tezos_protocol_environment_alpha__Environment.RPC_context.t q i
                o) ->
                (variant * variant) ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (E * q * i * o)) *
                ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                  variant
                  Tezos_protocol_environment_alpha__Environment.RPC_context.t
                  (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                    a) q i o) ->
                  (variant * variant) ->
                    a ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (F * a * q * i * o)) *
                  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                    variant
                    Tezos_protocol_environment_alpha__Environment.RPC_context.t
                    ((Tezos_protocol_environment_alpha__Environment.RPC_context.t
                      * a) * b) q i o) ->
                    (variant * variant) ->
                      a ->
                        b ->
                          q ->
                            i ->
                              Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                  o)) * (H * a * b * q * i * o)) *
                    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                      variant
                      Tezos_protocol_environment_alpha__Environment.RPC_context.t
                      (((Tezos_protocol_environment_alpha__Environment.RPC_context.t
                        * a) * b) * c) q i o) ->
                      (variant * variant) ->
                        a ->
                          b ->
                            c ->
                              q ->
                                i ->
                                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                      o)) * (J * a * b * c * q * i * o)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) *
                        (Uri.t *
                          (Tezos_shell_services.Shell_services.block *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (L * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (M * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((float -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) * N)))))))))))))))))))))))))
      *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        ((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  (Uri.t *
                    (Tezos_shell_services.Shell_services.block *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                        * (L * p * q * i * o)) *
                        ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                          (o -> unit) ->
                            (unit -> unit) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult
                                        (unit -> unit))) * (M * p * q * i * o))
                          *
                          (Tezos_shell_services.Shell_services.chain *
                            ((option Z) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                b) -> a) * (a * b)) *
                                ((Tezos_rpc.RPC_service.meth ->
                                  (option Tezos_data_encoding.Data_encoding.json)
                                    ->
                                    Uri.t ->
                                      Lwt.t
                                        (Tezos_rpc.RPC_context.rest_result
                                          Tezos_data_encoding.Data_encoding.json
                                          (option
                                            Tezos_data_encoding.Data_encoding.json)))
                                  *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) * N)))))))))))))))))))))
      * (variant * variant)) (state : state)
  (seed_nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t)
  (function_parameter :
    Tezos_base__Time.Protocol.t *
      (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
        Tezos_client_base.Client_keys.Public_key_hash.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
          Tezos_base__TzPervasives.Block_header.shell_header *
          (list (list Tezos_base.Operation.t)) *
          Tezos_client_base.Client_keys.Public_key_hash.t *
          (option Tezos_raw_protocol_alpha.Nonce_hash.t)))) :=
  match function_parameter with
  | (slot_timestamp, (bi, priority, delegate)) as slot =>
    let chain := variant in
    let block := variant in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level cctxt
        (Some 1) (chain, block))
      (fun next_level =>
        let seed_nonce_hash :=
          if Level.expected_commitment next_level then
            Some seed_nonce_hash
          else
            None in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_client_base.Client_keys.Public_key_hash.name cctxt delegate)
          (fun name =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_debug
                (fun f =>
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (Tag.DSL.op_minus_percent
                        (Tag.DSL.op_minus_percent
                          (Tag.DSL.op_minus_percent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Try baking after " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " (slot " % string
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.String_literal
                                          ") for " % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              " (" % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  ")" % char
                                                  CamlinternalFormatBasics.End_of_format)))))))))
                                "Try baking after %a (slot %d) for %s (%a)" %
                                  string))
                            (Tag.DSL.t event "try_baking" % string))
                          (Tag.DSL.a
                            Tezos_base__TzPervasives.Block_hash.Logging.tag
                            (hash bi)))
                        (Tag.DSL.s Tezos_baking_alpha.Logging.bake_priority_tag
                          priority))
                      (Tag.DSL.s Tezos_client_base.Client_keys.Logging.tag name))
                    (Tag.DSL.a Tezos_baking_alpha.Logging.timestamp_tag
                      (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                        slot_timestamp))))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (fetch_operations cctxt chain slot)
                    (fun function_parameter =>
                      match function_parameter with
                      | None =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (lwt_log_notice
                            (fun f =>
                              Tag.DSL.op_minus_percent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Received a new head while waiting for operations. Aborting this block."
                                        % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "Received a new head while waiting for operations. Aborting this block."
                                      % string))
                                (Tag.DSL.t event "new_head_received" % string)))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_none
                            end)
                      | Some (operations, timestamp) =>
                        let hard_gas_limit_per_block :=
                          hard_gas_limit_per_block
                            (parametric (constants state)) in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (classify_operations cctxt chain block
                            hard_gas_limit_per_block (minimal_fees state)
                            (minimal_nanotez_per_gas_unit state)
                            (minimal_nanotez_per_byte state) operations)
                          (fun function_parameter =>
                            match function_parameter with
                            | (operations, overflowing_ops) =>
                              let next_version :=
                                match
                                  Tezos_base.Block_header.get_forced_protocol_upgrade
                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
                                      (Level.level next_level)) with
                                | None => next_protocol bi
                                | Some hash => hash
                                end in
                              if
                                Tezos_base__TzPervasives.Protocol_hash.op_lt_gt
                                  Tezos_protocol_alpha.Protocol.hash
                                  next_version then
                                shell_prevalidation cctxt chain block timestamp
                                  seed_nonce_hash operations slot
                              else
                                let protocol_data :=
                                  forge_faked_protocol_data priority
                                    seed_nonce_hash in
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (filter_and_apply_operations cctxt state chain
                                    block bi priority (Some protocol_data)
                                    (operations, overflowing_ops))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | inr errs =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (lwt_log_error
                                          (fun f =>
                                            Tag.DSL.op_minus_percent
                                              (Tag.DSL.op_minus_percent
                                                (f
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Client-side validation: error while filtering invalid operations :"
                                                        % string
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Force_newline
                                                        (CamlinternalFormatBasics.Formatting_gen
                                                          (CamlinternalFormatBasics.Open_box
                                                            (CamlinternalFormatBasics.Format
                                                              (CamlinternalFormatBasics.String_literal
                                                                "<v 4>" % string
                                                                CamlinternalFormatBasics.End_of_format)
                                                              "<v 4>" % string))
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Close_box
                                                              CamlinternalFormatBasics.End_of_format)))))
                                                    "Client-side validation: error while filtering invalid operations :@
@[<v 4>%a@]"
                                                      % string))
                                                (Tag.DSL.t event
                                                  "client_side_validation_error"
                                                    % string))
                                              (Tag.DSL.a
                                                Tezos_base__TzPervasives.errs_tag
                                                errs)))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (lwt_log_notice
                                                (fun f =>
                                                  Tag.DSL.op_minus_percent
                                                    (f
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Building a block using shell validation"
                                                            % string
                                                          CamlinternalFormatBasics.End_of_format)
                                                        "Building a block using shell validation"
                                                          % string))
                                                    (Tag.DSL.t event
                                                      "shell_prevalidation_notice"
                                                        % string)))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  shell_prevalidation cctxt
                                                    chain block timestamp
                                                    seed_nonce_hash operations
                                                    slot
                                                end)
                                          end)
                                    |
                                      inl
                                        (final_context, (validation_result, _),
                                          operations, valid_timestamp) =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (if
                                          Tezos_base__TzPervasives.Time.System.op_lt
                                            (Tezos_stdlib_unix.Systime_os.now tt)
                                            (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                                              valid_timestamp) then
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (lwt_log_notice
                                              (fun f =>
                                                Tag.DSL.op_minus_percent
                                                  (Tag.DSL.op_minus_percent
                                                    (Tag.DSL.op_minus_percent
                                                      (f
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.Char_literal
                                                            "[" % char
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.String_literal
                                                                "] not ready to inject yet, waiting until "
                                                                  % string
                                                                (CamlinternalFormatBasics.Alpha
                                                                  CamlinternalFormatBasics.End_of_format))))
                                                          "[%a] not ready to inject yet, waiting until %a"
                                                            % string))
                                                      (Tag.DSL.a
                                                        Tezos_baking_alpha.Logging.timestamp_tag
                                                        (Tezos_stdlib_unix.Systime_os.now
                                                          tt)))
                                                    (Tag.DSL.a
                                                      Tezos_baking_alpha.Logging.timestamp_tag
                                                      (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                                                        valid_timestamp)))
                                                  (Tag.DSL.t event
                                                    "waiting_before_injection" %
                                                      string)))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                match
                                                  Tezos_baking_alpha.Client_baking_scheduling.sleep_until
                                                    valid_timestamp with
                                                | None => Lwt.return_unit
                                                | Some timeout => timeout
                                                end
                                              end)
                                        else
                                          Lwt.return_unit)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq
                                              (lwt_debug
                                                (fun f =>
                                                  Tag.DSL.op_minus_percent
                                                    (Tag.DSL.op_minus_percent
                                                      (Tag.DSL.op_minus_percent
                                                        (Tag.DSL.op_minus_percent
                                                          (Tag.DSL.op_minus_percent
                                                            (f
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "Try forging locally the block header for "
                                                                    % string
                                                                  (CamlinternalFormatBasics.Alpha
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      " (slot "
                                                                        % string
                                                                      (CamlinternalFormatBasics.Int
                                                                        CamlinternalFormatBasics.Int_d
                                                                        CamlinternalFormatBasics.No_padding
                                                                        CamlinternalFormatBasics.No_precision
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          ") for "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.String
                                                                            CamlinternalFormatBasics.No_padding
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              " ("
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Alpha
                                                                                (CamlinternalFormatBasics.Char_literal
                                                                                  ")"
                                                                                    %
                                                                                    char
                                                                                  CamlinternalFormatBasics.End_of_format)))))))))
                                                                "Try forging locally the block header for %a (slot %d) for %s (%a)"
                                                                  % string))
                                                            (Tag.DSL.t event
                                                              "try_forging" %
                                                                string))
                                                          (Tag.DSL.a
                                                            Tezos_base__TzPervasives.Block_hash.Logging.tag
                                                            (hash bi)))
                                                        (Tag.DSL.s
                                                          Tezos_baking_alpha.Logging.bake_priority_tag
                                                          priority))
                                                      (Tag.DSL.s
                                                        Tezos_client_base.Client_keys.Logging.tag
                                                        name))
                                                    (Tag.DSL.a
                                                      Tezos_baking_alpha.Logging.timestamp_tag
                                                      (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                                                        timestamp))))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  let current_protocol :=
                                                    next_protocol bi in
                                                  let context :=
                                                    Tezos_shell_context.Shell_context.unwrap_disk_context
                                                      (context validation_result)
                                                    in
                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                    (Tezos_storage.Context.get_protocol
                                                      context)
                                                    (fun next_protocol =>
                                                      if
                                                        Tezos_base__TzPervasives.Protocol_hash.equal
                                                          current_protocol
                                                          next_protocol then
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (finalize_block_header
                                                            (header
                                                              final_context)
                                                            valid_timestamp
                                                            validation_result
                                                            operations)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            |
                                                              inr
                                                                (cons
                                                                  Forking_test_chain
                                                                  _) =>
                                                              shell_prevalidation
                                                                cctxt chain
                                                                block timestamp
                                                                seed_nonce_hash
                                                                operations slot
                                                            | (inr _) as errs =>
                                                              Lwt._return errs
                                                            | inl shell_header
                                                              =>
                                                              let raw_ops :=
                                                                Tezos_base__TzPervasives.List.map
                                                                  (Tezos_base__TzPervasives.List.map
                                                                    forge)
                                                                  operations in
                                                              Tezos_base__TzPervasives.return_some
                                                                (bi, priority,
                                                                  shell_header,
                                                                  raw_ops,
                                                                  delegate,
                                                                  seed_nonce_hash)
                                                            end)
                                                      else
                                                        Tezos_base__TzPervasives.op_gt_gt_eq
                                                          (lwt_log_notice
                                                            (fun f =>
                                                              Tag.DSL.op_minus_percent
                                                                (f
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "New protocol detected: using shell validation"
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "New protocol detected: using shell validation"
                                                                      % string))
                                                                (Tag.DSL.t event
                                                                  "shell_prevalidation_notice"
                                                                    % string)))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              shell_prevalidation
                                                                cctxt chain
                                                                block timestamp
                                                                seed_nonce_hash
                                                                operations slot
                                                            end))
                                                end)
                                          end)
                                    end)
                            end)
                      end)
                end)))
  end.

Definition bake {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain) (state : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match best_slot state with
    | None => false
    | Some slot => Tezos_base__TzPervasives._return slot
    end
    (fun slot =>
      let seed_nonce := generate_seed_nonce tt in
      let seed_nonce_hash :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.hash seed_nonce in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (build_block cctxt state seed_nonce_hash slot)
        (fun function_parameter =>
          match function_parameter with
          |
            Some
              (head, priority, shell_header, operations, delegate,
                seed_nonce_hash) =>
            let level :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.succ
                (level head) in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_client_base.Client_keys.Public_key_hash.name cctxt delegate)
              (fun name =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (lwt_log_info
                    (fun f =>
                      Tag.DSL.op_minus_percent
                        (Tag.DSL.op_minus_percent
                          (Tag.DSL.op_minus_percent
                            (Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Injecting block (priority " % string
                                        (CamlinternalFormatBasics.Int
                                          CamlinternalFormatBasics.Int_d
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.No_precision
                                          (CamlinternalFormatBasics.String_literal
                                            ", fitness " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                ") for " % string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.String_literal
                                                    " after " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        "..." % string
                                                        CamlinternalFormatBasics.End_of_format)))))))))
                                      "Injecting block (priority %d, fitness %a) for %s after %a..."
                                        % string))
                                  (Tag.DSL.t event
                                    "start_injecting_block" % string))
                                (Tag.DSL.s
                                  Tezos_baking_alpha.Logging.bake_priority_tag
                                  priority))
                              (Tag.DSL.a Tezos_baking_alpha.Logging.fitness_tag
                                (fitness shell_header)))
                            (Tag.DSL.s Tezos_client_base.Client_keys.Logging.tag
                              name))
                          (Tag.DSL.a
                            Tezos_base__TzPervasives.Block_hash.Logging.predecessor_tag
                            (predecessor shell_header)))
                        (Tag.DSL.t
                          Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                          delegate)))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_client_base.Client_keys.get_key cctxt delegate)
                        (fun function_parameter =>
                          match function_parameter with
                          | (_, _, delegate_sk) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (inject_block cctxt (Some false) seed_nonce_hash
                                chain shell_header priority delegate delegate_sk
                                level operations)
                              (fun function_parameter =>
                                match function_parameter with
                                | inr errs =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (lwt_log_error
                                      (fun f =>
                                        Tag.DSL.op_minus_percent
                                          (Tag.DSL.op_minus_percent
                                            (Tag.DSL.op_minus_percent
                                              (f
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.Formatting_gen
                                                    (CamlinternalFormatBasics.Open_box
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "<v 4>" % string
                                                          CamlinternalFormatBasics.End_of_format)
                                                        "<v 4>" % string))
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Error while injecting block"
                                                        % string
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@ " % string 1 0)
                                                        (CamlinternalFormatBasics.Formatting_gen
                                                          (CamlinternalFormatBasics.Open_box
                                                            (CamlinternalFormatBasics.Format
                                                              CamlinternalFormatBasics.End_of_format
                                                              "" % string))
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Included operations : "
                                                              % string
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                CamlinternalFormatBasics.Close_box
                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                  (CamlinternalFormatBasics.Break
                                                                    "@ " %
                                                                      string 1 0)
                                                                  (CamlinternalFormatBasics.Alpha
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      CamlinternalFormatBasics.Close_box
                                                                      CamlinternalFormatBasics.End_of_format))))))))))
                                                  "@[<v 4>Error while injecting block@ @[Included operations : %a@]@ %a@]"
                                                    % string))
                                              (Tag.DSL.t event
                                                "block_injection_failed" %
                                                  string))
                                            (Tag.DSL.a
                                              Tezos_baking_alpha.Logging.raw_operations_tag
                                              (Tezos_base__TzPervasives.List.concat
                                                operations)))
                                          (Tag.DSL.a
                                            Tezos_base__TzPervasives.errs_tag
                                            errs)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.return_unit
                                      end)
                                | inl block_hash =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (lwt_log_notice
                                      (fun f =>
                                        Tag.DSL.op_minus_percent
                                          (Tag.DSL.op_minus_percent
                                            (Tag.DSL.op_minus_percent
                                              (Tag.DSL.op_minus_percent
                                                (Tag.DSL.op_minus_percent
                                                  (Tag.DSL.op_minus_percent
                                                    (Tag.DSL.op_minus_percent
                                                      (Tag.DSL.op_minus_percent
                                                        (f
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "Injected block "
                                                                % string
                                                              (CamlinternalFormatBasics.Alpha
                                                                (CamlinternalFormatBasics.String_literal
                                                                  " for " %
                                                                    string
                                                                  (CamlinternalFormatBasics.String
                                                                    CamlinternalFormatBasics.No_padding
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      " after "
                                                                        % string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          " (level "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.Alpha
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              ", priority "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Int
                                                                                CamlinternalFormatBasics.Int_d
                                                                                CamlinternalFormatBasics.No_padding
                                                                                CamlinternalFormatBasics.No_precision
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  ", fitness "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      ", operations "
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          ")."
                                                                                            %
                                                                                            string
                                                                                          CamlinternalFormatBasics.End_of_format)))))))))))))))
                                                            "Injected block %a for %s after %a (level %a, priority %d, fitness %a, operations %a)."
                                                              % string))
                                                        (Tag.DSL.t event
                                                          "injected_block" %
                                                            string))
                                                      (Tag.DSL.a
                                                        Tezos_base__TzPervasives.Block_hash.Logging.tag
                                                        block_hash))
                                                    (Tag.DSL.s
                                                      Tezos_client_base.Client_keys.Logging.tag
                                                      name))
                                                  (Tag.DSL.a
                                                    Tezos_base__TzPervasives.Block_hash.Logging.tag
                                                    (predecessor shell_header)))
                                                (Tag.DSL.a
                                                  Tezos_baking_alpha.Logging.level_tag
                                                  level))
                                              (Tag.DSL.s
                                                Tezos_baking_alpha.Logging.bake_priority_tag
                                                priority))
                                            (Tag.DSL.a
                                              Tezos_baking_alpha.Logging.fitness_tag
                                              (fitness shell_header)))
                                          (Tag.DSL.a
                                            Tezos_baking_alpha.Logging.operations_tag
                                            operations)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (if nequiv_decb seed_nonce_hash None
                                            then
                                            OCaml.Stdlib.reverse_apply
                                              (send
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                      (Tezos_baking_alpha.Client_baking_nonces.load
                                                        cctxt
                                                        (nonces_location state))
                                                      (fun nonces =>
                                                        let nonces :=
                                                          Tezos_baking_alpha.Client_baking_nonces.add
                                                            nonces block_hash
                                                            seed_nonce in
                                                        Tezos_baking_alpha.Client_baking_nonces.save
                                                          cctxt
                                                          (nonces_location state)
                                                          nonces)
                                                  end))
                                              (Tezos_base__TzPervasives.trace_exn
                                                (OCaml.Failure
                                                  "Error while recording nonce"
                                                    % string))
                                          else
                                            Tezos_base__TzPervasives.return_unit)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_base__TzPervasives.return_unit
                                            end)
                                      end)
                                end)
                          end)
                    end))
          | None => Tezos_base__TzPervasives.return_unit
          end)).

Definition get_baking_slots {D F H J K a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (variant * variant) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (variant * variant) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (variant * variant) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (variant * variant) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) * K)))) * K *
      (variant * variant)) (op_star_o_p_t_star : option Z)
  : Tezos_baking_alpha.Client_baking_blocks.block_info ->
    (list
      Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
      ->
      Lwt.t
        (list
          (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t *
            (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))) :=
  let max_priority :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => default_max_priority
    end in
  fun new_head =>
    fun delegates =>
      let chain := variant in
      let block := variant in
      let level :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.succ
          (level new_head) in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Baking_rights.get
          cctxt (Some (cons level [])) None (Some delegates) None
          (Some max_priority) (chain, block))
        (fun function_parameter =>
          match function_parameter with
          | inr errs =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_log_error
                (fun f =>
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Error while fetching baking possibilities:
" %
                              string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "Error while fetching baking possibilities:
%a" %
                            string))
                      (Tag.DSL.t event "baking_slot_fetch_errors" % string))
                    (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs)))
              (fun function_parameter =>
                match function_parameter with
                | tt => Lwt.return_nil
                end)
          | inl [] => Lwt.return_nil
          | inl slots =>
            let slots :=
              Tezos_base__TzPervasives.List.filter_map
                (fun function_parameter =>
                  match function_parameter with
                  | {|
                    Alpha_services.Delegate.Baking_rights.timestamp := None
                      |} => None
                  | {|
                    delegate := delegate;
                      priority := priority;
                      timestamp := Some timestamp
                      |} => Some (timestamp, (new_head, priority, delegate))
                  end) slots in
            Lwt._return slots
          end).

Definition compute_best_slot_on_current_level
  {D F H J L M N a b c i o p q : Type}
  (max_priority : option Z)
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (state : state)
  (new_head : Tezos_baking_alpha.Client_baking_blocks.block_info)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t *
          (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (get_delegates cctxt state)
    (fun delegates =>
      let level :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.succ
          (Client_baking_blocks.level new_head) in
      Tezos_base__TzPervasives.op_gt_gt_eq
        (get_baking_slots cctxt max_priority new_head delegates)
        (fun function_parameter =>
          match function_parameter with
          | [] =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_log_notice
                (fun f =>
                  let max_priority :=
                    Tezos_base__TzPervasives.Option.unopt default_max_priority
                      max_priority in
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (Tag.DSL.op_minus_percent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "No slot found at level " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " (max_priority = " % string
                                  (CamlinternalFormatBasics.Int
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.Char_literal
                                      ")" % char
                                      CamlinternalFormatBasics.End_of_format)))))
                            "No slot found at level %a (max_priority = %d)" %
                              string))
                        (Tag.DSL.t event "no_slot_found" % string))
                      (Tag.DSL.a Tezos_baking_alpha.Logging.level_tag level))
                    (Tag.DSL.s Tezos_baking_alpha.Logging.bake_priority_tag
                      max_priority)))
              (fun function_parameter =>
                match function_parameter with
                | tt => Tezos_base__TzPervasives.return_none
                end)
          | cons h t =>
            match
              Tezos_base__TzPervasives.List.fold_left
                (fun function_parameter =>
                  match function_parameter with
                  | (_, (_, priority, _)) as acc =>
                    fun function_parameter =>
                      match function_parameter with
                      | (_, (_, priority', _)) as slot =>
                        if OCaml.Stdlib.lt priority priority' then
                          acc
                        else
                          slot
                      end
                  end) h t with
            | (timestamp, (_, priority, delegate)) as best_slot =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_client_base.Client_keys.Public_key_hash.name cctxt
                  delegate)
                (fun name =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_log_notice
                      (fun f =>
                        Tag.DSL.op_minus_percent
                          (Tag.DSL.op_minus_percent
                            (Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "New baking slot found (level " %
                                              string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                ", priority " % string
                                                (CamlinternalFormatBasics.Int
                                                  CamlinternalFormatBasics.Int_d
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.No_precision
                                                  (CamlinternalFormatBasics.String_literal
                                                    ") at " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        " for " % string
                                                        (CamlinternalFormatBasics.String
                                                          CamlinternalFormatBasics.No_padding
                                                          (CamlinternalFormatBasics.String_literal
                                                            " after " % string
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.Char_literal
                                                                "." % char
                                                                CamlinternalFormatBasics.End_of_format)))))))))))
                                          "New baking slot found (level %a, priority %d) at %a for %s after %a."
                                            % string))
                                      (Tag.DSL.t event
                                        "have_baking_slot" % string))
                                    (Tag.DSL.a
                                      Tezos_baking_alpha.Logging.level_tag level))
                                  (Tag.DSL.s
                                    Tezos_baking_alpha.Logging.bake_priority_tag
                                    priority))
                                (Tag.DSL.a
                                  Tezos_baking_alpha.Logging.timestamp_tag
                                  (Tezos_base__TzPervasives.Time.System.of_protocol_exn
                                    timestamp)))
                              (Tag.DSL.s
                                Tezos_client_base.Client_keys.Logging.tag name))
                            (Tag.DSL.a
                              Tezos_base__TzPervasives.Block_hash.Logging.tag
                              (hash new_head)))
                          (Tag.DSL.t
                            Tezos_base__TzPervasives.Signature.Public_key_hash.Logging.tag
                            delegate)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_some best_slot
                      end))
            end
          end)).

Definition reveal_potential_nonces {F G I J K M N a b c i o p q : Type}
  (cctxt :
    ((float -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) *
                                              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                variant
                                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                q i o) ->
                                                (Tezos_shell_services.Shell_services.chain
                                                  *
                                                  Tezos_shell_services.Shell_services.block)
                                                  ->
                                                  q ->
                                                    i ->
                                                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                          o)) * (I * q * i * o))
                                                *
                                                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                  variant
                                                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                  (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                    * a) q i o) ->
                                                  (Tezos_shell_services.Shell_services.chain
                                                    *
                                                    Tezos_shell_services.Shell_services.block)
                                                    ->
                                                    a ->
                                                      q ->
                                                        i ->
                                                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                              o)) *
                                                  (J * a * q * i * o)) *
                                                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                    variant
                                                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                    ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                      * a) * b) q i o) ->
                                                    (Tezos_shell_services.Shell_services.chain
                                                      *
                                                      Tezos_shell_services.Shell_services.block)
                                                      ->
                                                      a ->
                                                        b ->
                                                          q ->
                                                            i ->
                                                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                                  o)) *
                                                    (K * a * b * q * i * o)) *
                                                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                      variant
                                                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                      (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                        * a) * b) * c) q i o) ->
                                                      (Tezos_shell_services.Shell_services.chain
                                                        *
                                                        Tezos_shell_services.Shell_services.block)
                                                        ->
                                                        a ->
                                                          b ->
                                                            c ->
                                                              q ->
                                                                i ->
                                                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                                      o)) *
                                                      (M * a * b * c * q * i * o))
                                                      * N)))))))))))))))))))))))))
      *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (I * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (J * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (K * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (M * a * b * c * q * i * o)) * N)))))
  (constants : Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  send
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_baking_alpha.Client_baking_files.resolve_location cctxt chain
            variant)
          (fun nonces_location =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (Tezos_baking_alpha.Client_baking_nonces.load cctxt
                nonces_location)
              (fun function_parameter =>
                match function_parameter with
                | inr err =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (lwt_log_error
                      (fun f =>
                        Tag.DSL.op_minus_percent
                          (Tag.DSL.op_minus_percent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Cannot read nonces: " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))
                                "Cannot read nonces: %a" % string))
                            (Tag.DSL.t event "read_nonce_fail" % string))
                          (Tag.DSL.a Tezos_base__TzPervasives.errs_tag err)))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                | inl nonces =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_baking_alpha.Client_baking_nonces.get_unrevealed_nonces
                      cctxt nonces_location nonces)
                    (fun function_parameter =>
                      match function_parameter with
                      | inr err =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (lwt_log_error
                            (fun f =>
                              Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Cannot retrieve unrevealed nonces: " %
                                          string
                                        (CamlinternalFormatBasics.Alpha
                                          CamlinternalFormatBasics.End_of_format))
                                      "Cannot retrieve unrevealed nonces: %a" %
                                        string))
                                  (Tag.DSL.t event
                                    "nonce_retrieval_fail" % string))
                                (Tag.DSL.a Tezos_base__TzPervasives.errs_tag err)))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => Tezos_base__TzPervasives.return_unit
                            end)
                      | inl [] => Tezos_base__TzPervasives.return_unit
                      | inl nonces_to_reveal =>
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_baking_alpha.Client_baking_revelation.inject_seed_nonce_revelation
                            cctxt chain block None nonces_to_reveal)
                          (fun function_parameter =>
                            match function_parameter with
                            | inr err =>
                              Tezos_base__TzPervasives.op_gt_gt_eq
                                (lwt_log_error
                                  (fun f =>
                                    Tag.DSL.op_minus_percent
                                      (Tag.DSL.op_minus_percent
                                        (f
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Cannot inject nonces: " % string
                                              (CamlinternalFormatBasics.Alpha
                                                CamlinternalFormatBasics.End_of_format))
                                            "Cannot inject nonces: %a" % string))
                                        (Tag.DSL.t event
                                          "nonce_injection_fail" % string))
                                      (Tag.DSL.a
                                        Tezos_base__TzPervasives.errs_tag err)))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt => Tezos_base__TzPervasives.return_unit
                                  end)
                            | inl tt =>
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (Tezos_baking_alpha.Client_baking_nonces.filter_outdated_nonces
                                  cctxt (Some constants) nonces_location nonces)
                                (fun live_nonces =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                                    (Tezos_baking_alpha.Client_baking_nonces.save
                                      cctxt nonces_location live_nonces)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.return_unit
                                      end))
                            end)
                      end)
                end))
      end).

Definition create {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N)
  (minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (minimal_nanotez_per_gas_unit : option Z.t)
  (minimal_nanotez_per_byte : option Z.t) (max_priority : option Z)
  (chain : Tezos_shell_services.Shell_services.chain) (context_path : string)
  (delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (block_stream :
    Lwt_stream.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_baking_alpha.Client_baking_blocks.block_info))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let state_maker (bi : Tezos_baking_alpha.Client_baking_blocks.block_info)
    : Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all cctxt
        (chain, variant))
      (fun constants =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_baking_alpha.Client_baking_simulator.load_context context_path)
          (fun index =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_baking_alpha.Client_baking_simulator.check_context_consistency
                index (Client_baking_blocks.context bi))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_baking_alpha.Client_baking_files.resolve_location
                      cctxt chain variant)
                    (fun nonces_location =>
                      let state :=
                        create_state minimal_fees minimal_nanotez_per_gas_unit
                          minimal_nanotez_per_byte context_path index
                          nonces_location delegates constants in
                      Tezos_base__TzPervasives._return state)
                end))) in
  let event_k {O P Q R S T U : Type}
    (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (O * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (P * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (Q * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (R * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (S * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (T * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * U)))))))))))))))))))))))))
      * U) (state : state) (new_head :
    Tezos_baking_alpha.Client_baking_blocks.block_info)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (reveal_potential_nonces cctxt (constants state) chain variant)
      (fun _ignore_nonce_err =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (compute_best_slot_on_current_level max_priority cctxt state new_head)
          (fun slot =>
            set_field;
            Tezos_base__TzPervasives.return_unit)) in
  let compute_timeout (state : state) : Lwt.t unit :=
    match best_slot state with
    | None => Tezos_base__TzPervasives.Lwt_utils.never_ending tt
    | Some (timestamp, _) =>
      match Tezos_baking_alpha.Client_baking_scheduling.sleep_until timestamp
        with
      | None => Lwt.return_unit
      | Some timeout => timeout
      end
    end in
  let timeout_k {O P Q R S T U : Type}
    (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (O * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (P * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (Q * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (R * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (S * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (T * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * U)))))))))))))))))))))))))
      * U) (state : state) (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question (bake cctxt chain state)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            set_field;
            Tezos_base__TzPervasives.return_unit
          end)
    end in
  Tezos_baking_alpha.Client_baking_scheduling.main "baker" % string cctxt
    block_stream state_maker event_k compute_timeout timeout_k event_k.
src/proto_alpha/lib_delegate/client_baking_forge.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

(** [generate_seed_nonce ()] is a random nonce that is typically used
    in block headers. When baking, bakers generate random nonces whose
    hash is commited in the block they bake. They will typically
    reveal the aforementionned nonce during the next cycle. *)
val generate_seed_nonce : unit -> Nonce.t

(** [inject_block cctxt blk ?force ~priority ~timestamp ~fitness
    ~seed_nonce ~src_sk ops] tries to inject a block in the node. If
    [?force] is set, the fitness check will be bypassed. [priority]
    will be used to compute the baking slot (level is
    precomputed). [src_sk] is used to sign the block header. *)
val inject_block :
  #Protocol_client_context.full ->
  ?force:bool ->
  ?seed_nonce_hash:Nonce_hash.t ->
  chain:Chain_services.chain ->
  shell_header:Block_header.shell_header ->
  priority:int ->
  delegate_pkh:Signature.Public_key_hash.t ->
  delegate_sk:Client_keys.sk_uri ->
  level:Raw_level.t ->
  Operation.raw list list ->
  Block_hash.t tzresult Lwt.t

type error += Failed_to_preapply of Tezos_base.Operation.t * error list

(** [forge_block cctxt ?fee_threshold ?force ?operations ?best_effort
    ?sort ?timestamp ?max_priority ?priority ~seed_nonce ~src_sk
    pk_hash parent_blk] injects a block in the node. In addition of inject_block,
    it will:

    * Operations: If [?operations] is [None], it will get pending
      operations and add them to the block. Otherwise, provided
      operations will be used. In both cases, they will be validated.

    * Baking priority: If [`Auto] is used, it will be computed from
      the public key hash of the specified contract, optionally capped
      to a maximum value, and optionnaly restricting for free baking slot.

    * Timestamp: If [?timestamp] is set, and is compatible with the
      computed baking priority, it will be used. Otherwise, it will be
      set at the best baking priority.

    * Fee Threshold: If [?fee_threshold] is given, operations with fees lower than it
      are not added to the block.
*)
val forge_block :
  #Protocol_client_context.full ->
  ?force:bool ->
  ?operations:Operation.packed list ->
  ?best_effort:bool ->
  ?sort:bool ->
  ?minimal_fees:Tez.t ->
  ?minimal_nanotez_per_gas_unit:Z.t ->
  ?minimal_nanotez_per_byte:Z.t ->
  ?timestamp:Time.Protocol.t ->
  ?mempool:string ->
  ?context_path:string ->
  ?seed_nonce_hash:Nonce_hash.t ->
  chain:Chain_services.chain ->
  priority:[`Set of int | `Auto of public_key_hash * int option] ->
  delegate_pkh:Signature.Public_key_hash.t ->
  delegate_sk:Client_keys.sk_uri ->
  Block_services.block ->
  Block_hash.t tzresult Lwt.t

val create :
  #Protocol_client_context.full ->
  ?minimal_fees:Tez.t ->
  ?minimal_nanotez_per_gas_unit:Z.t ->
  ?minimal_nanotez_per_byte:Z.t ->
  ?max_priority:int ->
  chain:Chain_services.chain ->
  context_path:string ->
  public_key_hash list ->
  Client_baking_blocks.block_info tzresult Lwt_stream.t ->
  unit tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_forge.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter generate_seed_nonce :
unit -> Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.

Parameter inject_block : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (option bool) ->
    (option Tezos_protocol_alpha.Protocol.Nonce_hash.t) ->
      Tezos_shell_services.Chain_services.chain ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.shell_header ->
          Z ->
            Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
              Tezos_client_base.Client_keys.sk_uri ->
                Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
                  (list
                    (list
                      Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw))
                    ->
                    Lwt.t
                      (Tezos_base__TzPervasives.tzresult
                        Tezos_base__TzPervasives.Block_hash.t).

extensible_type

Parameter forge_block : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (option bool) ->
    (option (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed))
      ->
      (option bool) ->
        (option bool) ->
          (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
            (option Z.t) ->
              (option Z.t) ->
                (option Tezos_base__TzPervasives.Time.Protocol.t) ->
                  (option string) ->
                    (option string) ->
                      (option Tezos_protocol_alpha.Protocol.Nonce_hash.t) ->
                        Tezos_shell_services.Chain_services.chain ->
                          variant ->
                            Tezos_base__TzPervasives.Signature.Public_key_hash.t
                              ->
                              Tezos_client_base.Client_keys.sk_uri ->
                                Tezos_shell_services.Block_services.block ->
                                  Lwt.t
                                    (Tezos_base__TzPervasives.tzresult
                                      Tezos_base__TzPervasives.Block_hash.t).

Parameter create : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
    (option Z.t) ->
      (option Z.t) ->
        (option Z) ->
          Tezos_shell_services.Chain_services.chain ->
            string ->
              (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
                ->
                (Lwt_stream.t
                  (Tezos_base__TzPervasives.tzresult
                    Tezos_baking_alpha.Client_baking_blocks.block_info)) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context

type error += Level_previously_endorsed of Raw_level.t

type error += Level_previously_baked of Raw_level.t

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"highwatermarks.block_already_baked"
    ~title:"Block already baked"
    ~description:"Trying to bake a block for a level that was previously done"
    ~pp:(fun ppf level ->
      Format.fprintf ppf "Level %a previously baked " Raw_level.pp level)
    (obj1 (req "level" Raw_level.encoding))
    (function Level_previously_baked level -> Some level | _ -> None)
    (fun level -> Level_previously_baked level) ;
  register_error_kind
    `Permanent
    ~id:"highwatermarks.block_already_endorsed"
    ~title:"Fail to preapply an operation"
    ~description:
      "Trying to endorse a block for a level that was previously done"
    ~pp:(fun ppf level ->
      Format.fprintf ppf "Level %a previously endorsed " Raw_level.pp level)
    (obj1 (req "level" Raw_level.encoding))
    (function Level_previously_endorsed level -> Some level | _ -> None)
    (fun level -> Level_previously_endorsed level)

type t = (string * Raw_level.t) list

let encoding =
  let open Data_encoding in
  def "highwatermarks" @@ assoc Raw_level.encoding

let empty = []

(* We do not lock these functions. The caller will be already locked. *)
let load_highwatermarks (cctxt : #Protocol_client_context.full) filename :
    t tzresult Lwt.t =
  cctxt#load filename encoding ~default:empty

let save_highwatermarks (cctxt : #Protocol_client_context.full) filename
    highwatermarks : unit tzresult Lwt.t =
  cctxt#write filename highwatermarks encoding

let retrieve_highwatermark cctxt filename = load_highwatermarks cctxt filename

let may_inject (cctxt : #Protocol_client_context.full) location ~delegate level
    =
  retrieve_highwatermark cctxt (Client_baking_files.filename location)
  >>=? fun highwatermark ->
  let delegate = Signature.Public_key_hash.to_short_b58check delegate in
  List.find_opt
    (fun (delegate', _) -> String.compare delegate delegate' = 0)
    highwatermark
  |> function
  | None ->
      return_true
  | Some (_, past_level) ->
      return Raw_level.(past_level < level)

let may_inject_block = may_inject

let may_inject_endorsement = may_inject

let record (cctxt : #Protocol_client_context.full) location ~delegate level =
  let filename = Client_baking_files.filename location in
  let delegate = Signature.Public_key_hash.to_short_b58check delegate in
  load_highwatermarks cctxt filename
  >>=? fun highwatermarks ->
  let level =
    match List.assoc_opt delegate highwatermarks with
    | None ->
        level
    | Some lower_prev_level when level >= lower_prev_level ->
        level
    | Some higher_prev_level ->
        higher_prev_level
    (* should only happen in `forced` mode *)
  in
  save_highwatermarks
    cctxt
    filename
    ( (delegate, level)
    :: List.filter
         (fun (delegate', _) -> String.compare delegate delegate' <> 0)
         highwatermarks )

let record_block = record

let record_endorsement = record
src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition t :=
  list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t).

Definition encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    (list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)) :=
  apply
    (let arg :=
      Tezos_base__TzPervasives.Data_encoding.def "highwatermarks" % string in
    fun eta => arg None None eta)
    (Tezos_base__TzPervasives.Data_encoding.assoc
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.encoding).

Definition empty {A : Type} : list A := [].

Definition load_highwatermarks {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (filename : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  send filename empty encoding.

Definition save_highwatermarks {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (filename : string)
  (highwatermarks :
    list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  send filename highwatermarks encoding.

Definition retrieve_highwatermark {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (filename : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  load_highwatermarks cctxt filename.

Definition may_inject {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (location : Tezos_baking_alpha.Client_baking_files.location O)
  (delegate : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (retrieve_highwatermark cctxt
      (Tezos_baking_alpha.Client_baking_files.filename location))
    (fun highwatermark =>
      let delegate :=
        Tezos_base__TzPervasives.Signature.Public_key_hash.to_short_b58check
          delegate in
      OCaml.Stdlib.reverse_apply
        (Tezos_base__TzPervasives.List.find_opt
          (fun function_parameter =>
            match function_parameter with
            | (delegate', _) =>
              equiv_decb
                (Tezos_base__TzPervasives.String.compare delegate delegate') 0
            end) highwatermark)
        (fun function_parameter =>
          match function_parameter with
          | None => Tezos_base__TzPervasives.return_true
          | Some (_, past_level) =>
            Tezos_base__TzPervasives._return
              (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.op_lt
                past_level level)
          end)).

Definition may_inject_block {D F H J L M N O a b c i o p q : Type}
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    (Tezos_baking_alpha.Client_baking_files.location O) ->
      Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult bool) := may_inject.

Definition may_inject_endorsement {D F H J L M N O a b c i o p q : Type}
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    (Tezos_baking_alpha.Client_baking_files.location O) ->
      Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult bool) := may_inject.

Definition record {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (location : Tezos_baking_alpha.Client_baking_files.location O)
  (delegate : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let filename := Tezos_baking_alpha.Client_baking_files.filename location in
  let delegate :=
    Tezos_base__TzPervasives.Signature.Public_key_hash.to_short_b58check
      delegate in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (load_highwatermarks cctxt filename)
    (fun highwatermarks =>
      let level :=
        match Tezos_base__TzPervasives.List.assoc_opt delegate highwatermarks
          with
        | None => level
        | Some higher_prev_level => higher_prev_level
        end in
      save_highwatermarks cctxt filename
        (cons (delegate, level)
          (Tezos_base__TzPervasives.List.filter
            (fun function_parameter =>
              match function_parameter with
              | (delegate', _) =>
                nequiv_decb
                  (Tezos_base__TzPervasives.String.compare delegate delegate') 0
              end) highwatermarks))).

Definition record_block {D F H J L M N O a b c i o p q : Type}
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    (Tezos_baking_alpha.Client_baking_files.location O) ->
      Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit) := record.

Definition record_endorsement {D F H J L M N O a b c i o p q : Type}
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    (Tezos_baking_alpha.Client_baking_files.location O) ->
      Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit) := record.
src/proto_alpha/lib_delegate/client_baking_highwatermarks.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type error += Level_previously_endorsed of Raw_level.t

type error += Level_previously_baked of Raw_level.t

type t

val encoding : t Data_encoding.t

val may_inject_block :
  #Protocol_client_context.full ->
  [`Block] Client_baking_files.location ->
  delegate:Signature.public_key_hash ->
  Raw_level.t ->
  bool tzresult Lwt.t

val may_inject_endorsement :
  #Protocol_client_context.full ->
  [`Endorsement] Client_baking_files.location ->
  delegate:Signature.public_key_hash ->
  Raw_level.t ->
  bool tzresult Lwt.t

val record_block :
  #Protocol_client_context.full ->
  [`Block] Client_baking_files.location ->
  delegate:Signature.public_key_hash ->
  Raw_level.t ->
  unit tzresult Lwt.t

val record_endorsement :
  #Protocol_client_context.full ->
  [`Endorsement] Client_baking_files.location ->
  delegate:Signature.public_key_hash ->
  Raw_level.t ->
  unit tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_highwatermarks.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

extensible_type

Parameter t : Type.

Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.

Parameter may_inject_block : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (Tezos_baking_alpha.Client_baking_files.location variant) ->
    Tezos_base__TzPervasives.Signature.public_key_hash ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult bool).

Parameter may_inject_endorsement : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (Tezos_baking_alpha.Client_baking_files.location variant) ->
    Tezos_base__TzPervasives.Signature.public_key_hash ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult bool).

Parameter record_block : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (Tezos_baking_alpha.Client_baking_files.location variant) ->
    Tezos_base__TzPervasives.Signature.public_key_hash ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter record_endorsement : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (Tezos_baking_alpha.Client_baking_files.location variant) ->
    Tezos_base__TzPervasives.Signature.public_key_hash ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_delegate/client_baking_lib.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

let bake_block (cctxt : #Protocol_client_context.full) ?minimal_fees
    ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force
    ?max_priority ?(minimal_timestamp = false) ?mempool ?context_path ?src_sk
    ~chain ~head delegate =
  ( match src_sk with
  | None ->
      Client_keys.get_key cctxt delegate
      >>=? fun (_, _, src_sk) -> return src_sk
  | Some sk ->
      return sk )
  >>=? fun src_sk ->
  Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, head)
  >>=? fun level ->
  let (seed_nonce, seed_nonce_hash) =
    if level.expected_commitment then
      let seed_nonce = Client_baking_forge.generate_seed_nonce () in
      let seed_nonce_hash = Nonce.hash seed_nonce in
      (Some seed_nonce, Some seed_nonce_hash)
    else (None, None)
  in
  let timestamp =
    if minimal_timestamp then None
    else Some Time.System.(to_protocol (Systime_os.now ()))
  in
  Client_baking_forge.forge_block
    cctxt
    ?force
    ?minimal_fees
    ?minimal_nanotez_per_gas_unit
    ?minimal_nanotez_per_byte
    ?timestamp
    ?seed_nonce_hash
    ?mempool
    ?context_path
    ~chain
    ~priority:(`Auto (delegate, max_priority))
    ~delegate_pkh:delegate
    ~delegate_sk:src_sk
    head
  >>=? fun block_hash ->
  ( match seed_nonce with
  | None ->
      return_unit
  | Some seed_nonce ->
      cctxt#with_lock (fun () ->
          let open Client_baking_nonces in
          Client_baking_files.resolve_location cctxt ~chain `Nonce
          >>=? fun nonces_location ->
          load cctxt nonces_location
          >>=? fun nonces ->
          let nonces = add nonces block_hash seed_nonce in
          save cctxt nonces_location nonces)
      |> trace_exn (Failure "Error while recording block") )
  >>=? fun () ->
  cctxt#message "Injected block %a" Block_hash.pp_short block_hash
  >>= fun () -> return_unit

let endorse_block cctxt ~chain delegate =
  Client_keys.get_key cctxt delegate
  >>=? fun (_src_name, src_pk, src_sk) ->
  Client_baking_endorsement.forge_endorsement
    cctxt
    ~chain
    ~block:cctxt#block
    ~src_sk
    src_pk
  >>=? fun oph ->
  cctxt#answer "Operation successfully injected in the node."
  >>= fun () ->
  cctxt#answer "Operation hash is '%a'." Operation_hash.pp oph
  >>= fun () -> return_unit

let get_predecessor_cycle (cctxt : #Client_context.printer) cycle =
  match Cycle.pred cycle with
  | None ->
      if Cycle.(cycle = root) then
        cctxt#error "No predecessor for the first cycle"
      else
        cctxt#error "Cannot compute the predecessor of cycle %a" Cycle.pp cycle
  | Some cycle ->
      Lwt.return cycle

let do_reveal cctxt ~chain ~block nonces =
  Client_baking_revelation.inject_seed_nonce_revelation
    cctxt
    ~chain
    ~block
    nonces
  >>=? fun () -> return_unit

let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block
    block_hashes =
  cctxt#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Nonce
      >>=? fun nonces_location ->
      Client_baking_nonces.load cctxt nonces_location)
  >>=? fun nonces ->
  Lwt_list.filter_map_p
    (fun hash ->
      Lwt.catch
        (fun () ->
          Client_baking_blocks.info cctxt (`Hash (hash, 0))
          >>= function
          | Ok bi -> Lwt.return_some bi | Error _ -> Lwt.fail Not_found)
        (fun _ ->
          cctxt#warning
            "Cannot find block %a in the chain. (ignoring)@."
            Block_hash.pp_short
            hash
          >>= fun () -> Lwt.return_none))
    block_hashes
  >>= fun block_infos ->
  filter_map_s
    (fun (bi : Client_baking_blocks.block_info) ->
      match Client_baking_nonces.find_opt nonces bi.hash with
      | None ->
          cctxt#warning
            "Cannot find nonces for block %a (ignoring)@."
            Block_hash.pp_short
            bi.hash
          >>= fun () -> return_none
      | Some nonce ->
          return_some (bi.hash, (bi.level, nonce)))
    block_infos
  >>=? fun nonces ->
  let nonces = List.map snd nonces in
  do_reveal cctxt ~chain ~block nonces

let reveal_nonces (cctxt : #Protocol_client_context.full) ~chain ~block () =
  let open Client_baking_nonces in
  cctxt#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Nonce
      >>=? fun nonces_location ->
      load cctxt nonces_location
      >>=? fun nonces ->
      get_unrevealed_nonces cctxt nonces_location nonces
      >>=? fun nonces_to_reveal ->
      do_reveal cctxt ~chain ~block nonces_to_reveal
      >>=? fun () ->
      filter_outdated_nonces cctxt nonces_location nonces
      >>=? fun nonces ->
      save cctxt nonces_location nonces >>=? fun () -> return_unit)
src/proto_alpha/lib_delegate/client_baking_lib.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition bake_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N)
  (minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (minimal_nanotez_per_gas_unit : option Z.t)
  (minimal_nanotez_per_byte : option Z.t) (force : option bool)
  (max_priority : option Z) (op_star_o_p_t_star : option bool)
  : (option string) ->
    (option string) ->
      (option Tezos_client_base.Client_keys.sk_uri) ->
        Tezos_shell_services.Shell_services.chain ->
          Tezos_shell_services.Shell_services.block ->
            Tezos_client_base.Client_keys.Public_key_hash.t ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let minimal_timestamp :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun mempool =>
    fun context_path =>
      fun src_sk =>
        fun chain =>
          fun head =>
            fun delegate =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                match src_sk with
                | None =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_client_base.Client_keys.get_key cctxt delegate)
                    (fun function_parameter =>
                      match function_parameter with
                      | (_, _, src_sk) =>
                        Tezos_base__TzPervasives._return src_sk
                      end)
                | Some sk => Tezos_base__TzPervasives._return sk
                end
                (fun src_sk =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level
                      cctxt (Some 1) (chain, head))
                    (fun level =>
                      match
                        if expected_commitment level then
                          let seed_nonce :=
                            Tezos_baking_alpha.Client_baking_forge.generate_seed_nonce
                              tt in
                          let seed_nonce_hash :=
                            Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.hash
                              seed_nonce in
                          ((Some seed_nonce), (Some seed_nonce_hash))
                        else
                          (None, None) with
                      | (seed_nonce, seed_nonce_hash) =>
                        let timestamp :=
                          if minimal_timestamp then
                            None
                          else
                            Some
                              (Tezos_base__TzPervasives.Time.System.to_protocol
                                (Tezos_stdlib_unix.Systime_os.now tt)) in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_baking_alpha.Client_baking_forge.forge_block
                            cctxt force None None None minimal_fees
                            minimal_nanotez_per_gas_unit
                            minimal_nanotez_per_byte timestamp mempool
                            context_path seed_nonce_hash chain variant delegate
                            src_sk head)
                          (fun block_hash =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              match seed_nonce with
                              | None => Tezos_base__TzPervasives.return_unit
                              | Some seed_nonce =>
                                OCaml.Stdlib.reverse_apply
                                  (send
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                                          (Tezos_baking_alpha.Client_baking_files.resolve_location
                                            cctxt chain variant)
                                          (fun nonces_location =>
                                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                                              (Tezos_baking_alpha.Client_baking_nonces.load
                                                cctxt nonces_location)
                                              (fun nonces =>
                                                let nonces :=
                                                  Tezos_baking_alpha.Client_baking_nonces.add
                                                    nonces block_hash seed_nonce
                                                  in
                                                Tezos_baking_alpha.Client_baking_nonces.save
                                                  cctxt nonces_location nonces))
                                      end))
                                  (Tezos_base__TzPervasives.trace_exn
                                    (OCaml.Failure
                                      "Error while recording block" % string))
                              end
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Injected block " % string
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))
                                        "Injected block %a" % string)
                                      Tezos_base__TzPervasives.Block_hash.pp_short
                                      block_hash)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.return_unit
                                      end)
                                end))
                      end)).

Definition endorse_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (delegate : Tezos_client_base.Client_keys.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_base.Client_keys.get_key cctxt delegate)
    (fun function_parameter =>
      match function_parameter with
      | (_src_name, src_pk, src_sk) =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_baking_alpha.Client_baking_endorsement.forge_endorsement cctxt
            None chain send src_sk src_pk)
          (fun oph =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Operation successfully injected in the node." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Operation successfully injected in the node." % string))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Operation hash is '" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              "'." % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Operation hash is '%a'." % string)
                      Tezos_base__TzPervasives.Operation_hash.pp oph)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_unit
                      end)
                end))
      end).

Definition get_predecessor_cycle {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (cycle : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle)
  : Lwt.t Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle :=
  match Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.pred cycle with
  | None =>
    if
      Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.op_eq cycle
        Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.root then
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "No predecessor for the first cycle" % string
            CamlinternalFormatBasics.End_of_format)
          "No predecessor for the first cycle" % string)
    else
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cannot compute the predecessor of cycle " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "Cannot compute the predecessor of cycle %a" % string)
        Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.pp cycle
  | Some cycle => Lwt._return cycle
  end.

Definition do_reveal {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (nonces :
    list
      (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t *
        Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_baking_alpha.Client_baking_revelation.inject_seed_nonce_revelation
      cctxt chain block None nonces)
    (fun function_parameter =>
      match function_parameter with
      | tt => Tezos_base__TzPervasives.return_unit
      end).

Definition reveal_block_nonces {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (block_hashes : list Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (send
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_baking_alpha.Client_baking_files.resolve_location cctxt chain
              variant)
            (fun nonces_location =>
              Tezos_baking_alpha.Client_baking_nonces.load cctxt nonces_location)
        end))
    (fun nonces =>
      Tezos_base__TzPervasives.op_gt_gt_eq
        (Lwt_list.filter_map_p
          (fun hash =>
            Lwt.catch
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (Tezos_baking_alpha.Client_baking_blocks.info cctxt None
                      variant)
                    (fun function_parameter =>
                      match function_parameter with
                      | inl bi => Lwt.return_some bi
                      | inr _ => Lwt.fail OCaml.Not_found
                      end)
                end)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Cannot find block " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " in the chain. (ignoring)" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                CamlinternalFormatBasics.End_of_format))))
                        "Cannot find block %a in the chain. (ignoring)@." %
                          string) Tezos_base__TzPervasives.Block_hash.pp_short
                      hash)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Lwt.return_none
                      end)
                end)) block_hashes)
        (fun block_infos =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_base__TzPervasives.filter_map_s
              (fun bi =>
                match
                  Tezos_baking_alpha.Client_baking_nonces.find_opt nonces
                    (hash bi) with
                | None =>
                  Tezos_base__TzPervasives.op_gt_gt_eq
                    (send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Cannot find nonces for block " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " (ignoring)" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                CamlinternalFormatBasics.End_of_format))))
                        "Cannot find nonces for block %a (ignoring)@." % string)
                      Tezos_base__TzPervasives.Block_hash.pp_short (hash bi))
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Tezos_base__TzPervasives.return_none
                      end)
                | Some nonce =>
                  Tezos_base__TzPervasives.return_some
                    ((hash bi), ((level bi), nonce))
                end) block_infos)
            (fun nonces =>
              let nonces := Tezos_base__TzPervasives.List.map snd nonces in
              do_reveal cctxt chain block nonces))).

Definition reveal_nonces {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | tt =>
    send
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_baking_alpha.Client_baking_files.resolve_location cctxt chain
              variant)
            (fun nonces_location =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_baking_alpha.Client_baking_nonces.load cctxt
                  nonces_location)
                (fun nonces =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_baking_alpha.Client_baking_nonces.get_unrevealed_nonces
                      cctxt nonces_location nonces)
                    (fun nonces_to_reveal =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (do_reveal cctxt chain block nonces_to_reveal)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_baking_alpha.Client_baking_nonces.filter_outdated_nonces
                                cctxt None nonces_location nonces)
                              (fun nonces =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_baking_alpha.Client_baking_nonces.save
                                    cctxt nonces_location nonces)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end))
                          end))))
        end)
  end.
src/proto_alpha/lib_delegate/client_baking_lib.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

(** Mine a block *)
val bake_block :
  #Protocol_client_context.full ->
  ?minimal_fees:Tez.t ->
  ?minimal_nanotez_per_gas_unit:Z.t ->
  ?minimal_nanotez_per_byte:Z.t ->
  ?force:bool ->
  ?max_priority:int ->
  ?minimal_timestamp:bool ->
  ?mempool:string ->
  ?context_path:string ->
  ?src_sk:Client_keys.sk_uri ->
  chain:Chain_services.chain ->
  head:Block_services.block ->
  public_key_hash ->
  unit tzresult Lwt.t

(** Endorse a block *)
val endorse_block :
  #Protocol_client_context.full ->
  chain:Chain_services.chain ->
  Client_keys.Public_key_hash.t ->
  unit Error_monad.tzresult Lwt.t

(** Get the previous cycle of the given cycle *)
val get_predecessor_cycle :
  #Protocol_client_context.full -> Cycle.t -> Cycle.t Lwt.t

(** Reveal the nonces used to bake each block in the given list *)
val reveal_block_nonces :
  #Protocol_client_context.full ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  Block_hash.t list ->
  unit Error_monad.tzresult Lwt.t

(** Reveal all unrevealed nonces *)
val reveal_nonces :
  #Protocol_client_context.full ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  unit ->
  unit Error_monad.tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_lib.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter bake_block : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
    (option Z.t) ->
      (option Z.t) ->
        (option bool) ->
          (option Z) ->
            (option bool) ->
              (option string) ->
                (option string) ->
                  (option Tezos_client_base.Client_keys.sk_uri) ->
                    Tezos_shell_services.Chain_services.chain ->
                      Tezos_shell_services.Block_services.block ->
                        Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash
                          -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter endorse_block : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_client_base.Client_keys.Public_key_hash.t ->
      Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit).

Parameter get_predecessor_cycle : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.t ->
    Lwt.t Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.t.

Parameter reveal_block_nonces : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      (list Tezos_base__TzPervasives.Block_hash.t) ->
        Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit).

Parameter reveal_nonces : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      unit -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit).
src/proto_alpha/lib_delegate/client_baking_nonces.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.nonces"
end)

type t = Nonce.t Block_hash.Map.t

let empty = Block_hash.Map.empty

let encoding =
  let open Data_encoding in
  def "seed_nonce"
  @@ conv
       (fun m ->
         Block_hash.Map.fold (fun hash nonce acc -> (hash, nonce) :: acc) m [])
       (fun l ->
         List.fold_left
           (fun map (hash, nonce) -> Block_hash.Map.add hash nonce map)
           Block_hash.Map.empty
           l)
  @@ list (obj2 (req "block" Block_hash.encoding) (req "nonce" Nonce.encoding))

let load (wallet : #Client_context.wallet) location =
  wallet#load (Client_baking_files.filename location) ~default:empty encoding

let save (wallet : #Client_context.wallet) location nonces =
  wallet#write (Client_baking_files.filename location) nonces encoding

let mem nonces hash = Block_hash.Map.mem hash nonces

let find_opt nonces hash = Block_hash.Map.find_opt hash nonces

let add nonces hash nonce = Block_hash.Map.add hash nonce nonces

let add_all nonces nonces_to_add =
  Block_hash.Map.fold
    (fun hash nonce acc -> add acc hash nonce)
    nonces_to_add
    nonces

let remove nonces hash = Block_hash.Map.remove hash nonces

let remove_all nonces nonces_to_remove =
  Block_hash.Map.fold
    (fun hash _ acc -> remove acc hash)
    nonces_to_remove
    nonces

let get_block_level_opt cctxt ~chain ~block =
  Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
  >>= function
  | Ok {level; _} ->
      Lwt.return_some level
  | Error errs ->
      lwt_warn
        Tag.DSL.(
          fun f ->
            f
              "@[<v 2>Cannot retrieve block %a header associated to nonce:@ \
               @[%a@]@]@."
            -% t event "cannot_retrieve_block_header"
            -% a Logging.block_tag block -% a errs_tag errs)
      >>= fun () -> Lwt.return_none

let get_outdated_nonces cctxt ?constants ~chain nonces =
  ( match constants with
  | None ->
      Alpha_services.Constants.all cctxt (chain, `Head 0)
  | Some constants ->
      return constants )
  >>=? fun {Constants.parametric = {blocks_per_cycle; preserved_cycles; _}; _} ->
  get_block_level_opt cctxt ~chain ~block:(`Head 0)
  >>= function
  | None ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Cannot fetch chain's head level. Aborting nonces filtering."
            -% t event "cannot_retrieve_head_level")
      >>= fun () -> return (empty, empty)
  | Some current_level ->
      let current_cycle = Int32.(div current_level blocks_per_cycle) in
      let is_older_than_preserved_cycles block_level =
        let block_cycle = Int32.(div block_level blocks_per_cycle) in
        Int32.sub current_cycle block_cycle > Int32.of_int preserved_cycles
      in
      Block_hash.Map.fold
        (fun hash nonce acc ->
          acc
          >>=? fun (orphans, outdated) ->
          get_block_level_opt cctxt ~chain ~block:(`Hash (hash, 0))
          >>= function
          | Some level ->
              if is_older_than_preserved_cycles level then
                return (orphans, add outdated hash nonce)
              else acc
          | None ->
              return (add orphans hash nonce, outdated))
        nonces
        (return (empty, empty))

let filter_outdated_nonces cctxt ?constants location nonces =
  let chain = Client_baking_files.chain location in
  get_outdated_nonces cctxt ?constants ~chain nonces
  >>=? fun (orphans, outdated_nonces) ->
  ( if Block_hash.Map.cardinal orphans >= 50 then
    lwt_warn
      Tag.DSL.(
        fun f ->
          f
            "Found too many nonces associated to blocks unknown by the node \
             in '$TEZOS_CLIENT/%s'. After checking that these blocks were \
             never included in the chain (e.g. via a block explorer), \
             consider using `tezos-client filter orphan nonces` to clear them."
          -% s
               Logging.filename_tag
               (Client_baking_files.filename location ^ "s")
          -% t event "too_many_orphans")
    >>= fun () -> Lwt.return_unit
  else Lwt.return_unit )
  >>= fun () -> return (remove_all nonces outdated_nonces)

let get_unrevealed_nonces cctxt location nonces =
  let chain = Client_baking_files.chain location in
  Client_baking_blocks.blocks_from_current_cycle
    cctxt
    ~chain
    (`Head 0)
    ~offset:(-1l)
    ()
  >>=? fun blocks ->
  filter_map_s
    (fun hash ->
      match find_opt nonces hash with
      | None ->
          return_none
      | Some nonce -> (
          get_block_level_opt cctxt ~chain ~block:(`Hash (hash, 0))
          >>= function
          | Some level -> (
              Lwt.return (Environment.wrap_error (Raw_level.of_int32 level))
              >>=? fun level ->
              Alpha_services.Nonce.get cctxt (chain, `Head 0) level
              >>=? function
              | Missing nonce_hash when Nonce.check_hash nonce nonce_hash ->
                  lwt_log_notice
                    Tag.DSL.(
                      fun f ->
                        f "Found nonce to reveal for %a (level: %a)"
                        -% t event "found_nonce"
                        -% a Block_hash.Logging.tag hash
                        -% a Logging.level_tag level)
                  >>= fun () -> return_some (level, nonce)
              | Missing _nonce_hash ->
                  lwt_log_error
                    Tag.DSL.(
                      fun f ->
                        f "Incoherent nonce for level %a"
                        -% t event "bad_nonce" -% a Logging.level_tag level)
                  >>= fun () -> return_none
              | Forgotten ->
                  return_none
              | Revealed _ ->
                  return_none )
          | None ->
              return_none ))
    blocks
src/proto_alpha/lib_delegate/client_baking_nonces.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition t :=
  Tezos_base__TzPervasives.Block_hash.Map.t
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.

Definition empty {A : Type} : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Tezos_base__TzPervasives.Block_hash.Map.empty.

Definition encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    (Tezos_base__TzPervasives.Block_hash.Map.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce) :=
  apply
    (let arg := Tezos_base__TzPervasives.Data_encoding.def "seed_nonce" % string
      in
    fun eta => arg None None eta)
    (apply
      (let arg :=
        Tezos_base__TzPervasives.Data_encoding.conv
          (fun m =>
            Tezos_base__TzPervasives.Block_hash.Map.fold
              (fun hash => fun nonce => fun acc => cons (hash, nonce) acc) m [])
          (fun l =>
            Tezos_base__TzPervasives.List.fold_left
              (fun map =>
                fun function_parameter =>
                  match function_parameter with
                  | (hash, nonce) =>
                    Tezos_base__TzPervasives.Block_hash.Map.add hash nonce map
                  end) Tezos_base__TzPervasives.Block_hash.Map.empty l) in
      fun eta => arg None eta)
      (Tezos_base__TzPervasives.Data_encoding.list None
        (Tezos_base__TzPervasives.Data_encoding.obj2
          (Tezos_base__TzPervasives.Data_encoding.req None None "block" % string
            Tezos_base__TzPervasives.Block_hash.encoding)
          (Tezos_base__TzPervasives.Data_encoding.req None None "nonce" % string
            Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.encoding)))).

Definition load {B C a : Type}
  (wallet :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (location : Tezos_baking_alpha.Client_baking_files.location C)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_hash.Map.t
        Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)) :=
  send (Tezos_baking_alpha.Client_baking_files.filename location) empty encoding.

Definition save {B C a : Type}
  (wallet :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (location : Tezos_baking_alpha.Client_baking_files.location C)
  (nonces :
    Tezos_base__TzPervasives.Block_hash.Map.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  send (Tezos_baking_alpha.Client_baking_files.filename location) nonces
    encoding.

Definition mem {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (hash : Tezos_base__TzPervasives.Block_hash.Map.key) : bool :=
  Tezos_base__TzPervasives.Block_hash.Map.mem hash nonces.

Definition find_opt {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (hash : Tezos_base__TzPervasives.Block_hash.Map.key) : option A :=
  Tezos_base__TzPervasives.Block_hash.Map.find_opt hash nonces.

Definition add {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (hash : Tezos_base__TzPervasives.Block_hash.Map.key) (nonce : A)
  : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Tezos_base__TzPervasives.Block_hash.Map.add hash nonce nonces.

Definition add_all {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (nonces_to_add : Tezos_base__TzPervasives.Block_hash.Map.t A)
  : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Tezos_base__TzPervasives.Block_hash.Map.fold
    (fun hash => fun nonce => fun acc => add acc hash nonce) nonces_to_add
    nonces.

Definition remove {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (hash : Tezos_base__TzPervasives.Block_hash.Map.key)
  : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Tezos_base__TzPervasives.Block_hash.Map.remove hash nonces.

Definition remove_all {A B : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (nonces_to_remove : Tezos_base__TzPervasives.Block_hash.Map.t B)
  : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Tezos_base__TzPervasives.Block_hash.Map.fold
    (fun hash =>
      fun function_parameter =>
        match function_parameter with
        | _ => fun acc => remove acc hash
        end) nonces_to_remove nonces.

Definition get_block_level_opt {E F i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block)
  : Lwt.t (option Stdlib.Int32.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_shell_services.Shell_services.Blocks.Header.shell_header cctxt
      (Some chain) (Some block) tt)
    (fun function_parameter =>
      match function_parameter with
      | inl {| level := level |} => Lwt.return_some level
      | inr errs =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_warn
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (Tag.DSL.op_minus_percent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "Cannot retrieve block " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " header associated to nonce:" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        CamlinternalFormatBasics.End_of_format
                                        "" % string))
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Flush_newline
                                            CamlinternalFormatBasics.End_of_format))))))))))
                        "@[<v 2>Cannot retrieve block %a header associated to nonce:@ @[%a@]@]@."
                          % string))
                    (Tag.DSL.t event "cannot_retrieve_block_header" % string))
                  (Tag.DSL.a Tezos_baking_alpha.Logging.block_tag block))
                (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs)))
          (fun function_parameter =>
            match function_parameter with
            | tt => Lwt.return_none
            end)
      end).

Definition get_outdated_nonces {E F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (Tezos_shell_services__Block_services.chain * variant) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (F * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (Tezos_shell_services__Block_services.chain * variant) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (H * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (Tezos_shell_services__Block_services.chain * variant) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (Tezos_shell_services__Block_services.chain * variant) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (L * a * b * c * q * i * o)) * M))))) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * M) *
      (Tezos_shell_services__Block_services.chain * variant))
  (constants : option Tezos_raw_protocol_alpha.Alpha_context.Constants.t)
  (chain : Tezos_shell_services__Block_services.chain)
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t N)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_base__TzPervasives.Block_hash.Map.t N) *
        (Tezos_base__TzPervasives.Block_hash.Map.t N))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match constants with
    | None =>
      Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all cctxt
        (chain, variant)
    | Some constants => Tezos_base__TzPervasives._return constants
    end
    (fun function_parameter =>
      match function_parameter with
      | {|
        Constants.parametric := {|
          preserved_cycles := preserved_cycles;
            blocks_per_cycle := blocks_per_cycle
            |}
          |} =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (get_block_level_opt cctxt chain variant)
          (fun function_parameter =>
            match function_parameter with
            | None =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (lwt_log_error
                  (fun f =>
                    Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Cannot fetch chain's head level. Aborting nonces filtering."
                              % string CamlinternalFormatBasics.End_of_format)
                          "Cannot fetch chain's head level. Aborting nonces filtering."
                            % string))
                      (Tag.DSL.t event "cannot_retrieve_head_level" % string)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives._return (empty, empty)
                  end)
            | Some current_level =>
              let current_cycle :=
                Stdlib.Int32.div current_level blocks_per_cycle in
              let is_older_than_preserved_cycles (block_level : int32) : bool :=
                let block_cycle := Stdlib.Int32.div block_level blocks_per_cycle
                  in
                OCaml.Stdlib.gt (Stdlib.Int32.sub current_cycle block_cycle)
                  (Stdlib.Int32.of_int preserved_cycles) in
              Tezos_base__TzPervasives.Block_hash.Map.fold
                (fun hash =>
                  fun nonce =>
                    fun acc =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question acc
                        (fun function_parameter =>
                          match function_parameter with
                          | (orphans, outdated) =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (get_block_level_opt cctxt chain variant)
                              (fun function_parameter =>
                                match function_parameter with
                                | Some level =>
                                  if is_older_than_preserved_cycles level then
                                    Tezos_base__TzPervasives._return
                                      (orphans, (add outdated hash nonce))
                                  else
                                    acc
                                | None =>
                                  Tezos_base__TzPervasives._return
                                    ((add orphans hash nonce), outdated)
                                end)
                          end)) nonces
                (Tezos_base__TzPervasives._return (empty, empty))
            end)
      end).

Definition filter_outdated_nonces {E F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (Tezos_shell_services__Block_services.chain * variant) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (F * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (Tezos_shell_services__Block_services.chain * variant) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (H * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (Tezos_shell_services__Block_services.chain * variant) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (Tezos_shell_services__Block_services.chain * variant) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (L * a * b * c * q * i * o)) * M))))) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * M) *
      (Tezos_shell_services__Block_services.chain * variant))
  (constants : option Tezos_raw_protocol_alpha.Alpha_context.Constants.t)
  (location : Tezos_baking_alpha.Client_baking_files.location N)
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t O)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_hash.Map.t O)) :=
  let chain := Tezos_baking_alpha.Client_baking_files.chain location in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (get_outdated_nonces cctxt constants chain nonces)
    (fun function_parameter =>
      match function_parameter with
      | (orphans, outdated_nonces) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (if
            OCaml.Stdlib.ge
              (Tezos_base__TzPervasives.Block_hash.Map.cardinal orphans) 50 then
            Tezos_base__TzPervasives.op_gt_gt_eq
              (lwt_warn
                (fun f =>
                  Tag.DSL.op_minus_percent
                    (Tag.DSL.op_minus_percent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Found too many nonces associated to blocks unknown by the node in '$TEZOS_CLIENT/"
                              % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                "'. After checking that these blocks were never included in the chain (e.g. via a block explorer), consider using `tezos-client filter orphan nonces` to clear them."
                                  % string
                                CamlinternalFormatBasics.End_of_format)))
                          "Found too many nonces associated to blocks unknown by the node in '$TEZOS_CLIENT/%s'. After checking that these blocks were never included in the chain (e.g. via a block explorer), consider using `tezos-client filter orphan nonces` to clear them."
                            % string))
                      (Tag.DSL.s Tezos_baking_alpha.Logging.filename_tag
                        (String.append
                          (Tezos_baking_alpha.Client_baking_files.filename
                            location) "s" % string)))
                    (Tag.DSL.t event "too_many_orphans" % string)))
              (fun function_parameter =>
                match function_parameter with
                | tt => Lwt.return_unit
                end)
          else
            Lwt.return_unit)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives._return
                (remove_all nonces outdated_nonces)
            end)
      end).

Definition get_unrevealed_nonces {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (location : Tezos_baking_alpha.Client_baking_files.location O)
  (nonces :
    Tezos_base__TzPervasives.Block_hash.Map.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.raw_level *
          Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce))) :=
  let chain := Tezos_baking_alpha.Client_baking_files.chain location in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_baking_alpha.Client_baking_blocks.blocks_from_current_cycle cctxt
      (Some chain) variant (Some (-1)) tt)
    (fun blocks =>
      Tezos_base__TzPervasives.filter_map_s
        (fun hash =>
          match find_opt nonces hash with
          | None => Tezos_base__TzPervasives.return_none
          | Some nonce =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (get_block_level_opt cctxt chain variant)
              (fun function_parameter =>
                match function_parameter with
                | Some level =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Lwt._return
                      (Tezos_protocol_alpha.Protocol.Environment.wrap_error
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.of_int32
                          level)))
                    (fun level =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.get
                          cctxt (chain, variant) level)
                        (fun function_parameter =>
                          match function_parameter with
                          | Missing nonce_hash =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (lwt_log_notice
                                (fun f =>
                                  Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (Tag.DSL.op_minus_percent
                                        (f
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Found nonce to reveal for " %
                                                string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  " (level: " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Char_literal
                                                      ")" % char
                                                      CamlinternalFormatBasics.End_of_format)))))
                                            "Found nonce to reveal for %a (level: %a)"
                                              % string))
                                        (Tag.DSL.t event "found_nonce" % string))
                                      (Tag.DSL.a
                                        Tezos_base__TzPervasives.Block_hash.Logging.tag
                                        hash))
                                    (Tag.DSL.a
                                      Tezos_baking_alpha.Logging.level_tag level)))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_base__TzPervasives.return_some
                                    (level, nonce)
                                end)
                          | Missing _nonce_hash =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (lwt_log_error
                                (fun f =>
                                  Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Incoherent nonce for level " %
                                              string
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format))
                                          "Incoherent nonce for level %a" %
                                            string))
                                      (Tag.DSL.t event "bad_nonce" % string))
                                    (Tag.DSL.a
                                      Tezos_baking_alpha.Logging.level_tag level)))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_none
                                end)
                          | Forgotten => Tezos_base__TzPervasives.return_none
                          | Revealed _ => Tezos_base__TzPervasives.return_none
                          end))
                | None => Tezos_base__TzPervasives.return_none
                end)
          end) blocks).
src/proto_alpha/lib_delegate/client_baking_nonces.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type t = Nonce.t Block_hash.Map.t

val encoding : t Data_encoding.t

val empty : t

val load :
  #Client_context.wallet ->
  [`Nonce] Client_baking_files.location ->
  t tzresult Lwt.t

val save :
  #Client_context.wallet ->
  [`Nonce] Client_baking_files.location ->
  t ->
  unit tzresult Lwt.t

val mem : t -> Block_hash.t -> bool

val find_opt : t -> Block_hash.t -> Nonce.t option

val add : t -> Block_hash.t -> Nonce.t -> t

val add_all : t -> t -> t

val remove : t -> Block_hash.t -> t

val remove_all : t -> t -> t

(** [get_outdated_nonces] returns the nonces that cannot be associated
    to blocks (orphans) and the nonces that are older than 5 cycles. *)
val get_outdated_nonces :
  #Protocol_client_context.full ->
  ?constants:Constants.t ->
  chain:Block_services.chain ->
  t ->
  (t * t) tzresult Lwt.t

(** [filter_outdated_nonces] filters nonces older than 5 cycles in the
    nonce file. *)
val filter_outdated_nonces :
  #Protocol_client_context.full ->
  ?constants:Constants.t ->
  [`Nonce] Client_baking_files.location ->
  t ->
  t tzresult Lwt.t

(** [get_unrevealed_nonces] retrieve registered nonces *)
val get_unrevealed_nonces :
  #Protocol_client_context.full ->
  [`Nonce] Client_baking_files.location ->
  t ->
  (Raw_level.t * Nonce.t) list tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_nonces.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t :=
  Tezos_base__TzPervasives.Block_hash.Map.t
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.

Parameter encoding : Tezos_base__TzPervasives.Data_encoding.t t.

Parameter empty : t.

Parameter load : forall {_ a variant : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  (Tezos_baking_alpha.Client_baking_files.location variant) ->
    Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter save : forall {_ a variant : Type},
(((option (Lwt_stream.t string)) *
  ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
    ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        (((string ->
          a ->
            (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _))))) *
  _) ->
  (Tezos_baking_alpha.Client_baking_files.location variant) ->
    t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter mem : t -> Tezos_base__TzPervasives.Block_hash.t -> bool.

Parameter find_opt :
t ->
  Tezos_base__TzPervasives.Block_hash.t ->
    option Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.

Parameter add :
t ->
  Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t -> t.

Parameter add_all : t -> t -> t.

Parameter remove : t -> Tezos_base__TzPervasives.Block_hash.t -> t.

Parameter remove_all : t -> t -> t.

Parameter get_outdated_nonces : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (option Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t) ->
    Tezos_shell_services.Block_services.chain ->
      t -> Lwt.t (Tezos_base__TzPervasives.tzresult (t * t)).

Parameter filter_outdated_nonces : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (option Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t) ->
    (Tezos_baking_alpha.Client_baking_files.location variant) ->
      t -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter get_unrevealed_nonces : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  (Tezos_baking_alpha.Client_baking_files.location variant) ->
    t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list
            (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t *
              Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t))).
src/proto_alpha/lib_delegate/client_baking_pow.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let default_constant = "\x00\x00\x00\x05"

let is_updated_constant =
  let commit_hash =
    if TzString.is_hex Tezos_version.Current_git_info.commit_hash then
      Hex.to_string (`Hex Tezos_version.Current_git_info.commit_hash)
    else Tezos_version.Current_git_info.commit_hash
  in
  if String.length commit_hash >= 4 then String.sub commit_hash 0 4
  else default_constant

let is_updated_constant_len = String.length is_updated_constant

(* add a version to the pow *)
let init_proof_of_work_nonce () =
  let buf =
    Bytes.make Alpha_context.Constants.proof_of_work_nonce_size '\000'
  in
  Bytes.blit_string is_updated_constant 0 buf 0 is_updated_constant_len ;
  let max_z_len =
    Alpha_context.Constants.proof_of_work_nonce_size - is_updated_constant_len
  in
  let rec aux z =
    let z_len = (Z.numbits z + 7) / 8 in
    if z_len > max_z_len then Seq.Nil
    else (
      Bytes.blit_string (Z.to_bits z) 0 buf is_updated_constant_len z_len ;
      Seq.Cons (buf, fun () -> aux (Z.succ z)) )
  in
  aux Z.zero

(* This was used before November 2018 *)
(* (\* Random proof of work *\)
 * let generate_proof_of_work_nonce () =
 *   Rand.generate Alpha_context.Constants.proof_of_work_nonce_size *)

let empty_proof_of_work_nonce =
  Bytes.make Constants_repr.proof_of_work_nonce_size '\000'

let mine cctxt chain block shell builder =
  Alpha_services.Constants.all cctxt (chain, block)
  >>=? fun constants ->
  let threshold = constants.parametric.proof_of_work_threshold in
  let rec loop nonce_seq =
    match nonce_seq with
    | Seq.Nil ->
        failwith
          "Client_baking_pow.mine: couldn't find nonce for required proof of \
           work"
    | Seq.Cons (nonce, seq) ->
        let block = builder nonce in
        if Baking.check_header_proof_of_work_stamp shell block threshold then
          return block
        else loop (seq ())
  in
  loop (init_proof_of_work_nonce ())
src/proto_alpha/lib_delegate/client_baking_pow.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition default_constant : string := "" % string.

Definition is_updated_constant : string :=
  let commit_hash :=
    if
      Tezos_base__TzPervasives.TzString.is_hex
        Tezos_version.Current_git_info.commit_hash then
      Hex.to_string variant
    else
      Tezos_version.Current_git_info.commit_hash in
  if OCaml.Stdlib.ge (Tezos_base__TzPervasives.String.length commit_hash) 4 then
    Tezos_base__TzPervasives.String.sub commit_hash 0 4
  else
    default_constant.

Definition is_updated_constant_len : Z :=
  Tezos_base__TzPervasives.String.length is_updated_constant.

Definition init_proof_of_work_nonce (function_parameter : unit)
  : Stdlib.Seq.node string :=
  match function_parameter with
  | tt =>
    let buf :=
      Stdlib.Bytes.make
        Tezos_protocol_alpha.Protocol.Alpha_context.Constants.proof_of_work_nonce_size
        "000" % char in
    Stdlib.Bytes.blit_string is_updated_constant 0 buf 0 is_updated_constant_len;
    let max_z_len :=
      Z.sub
        Tezos_protocol_alpha.Protocol.Alpha_context.Constants.proof_of_work_nonce_size
        is_updated_constant_len in
    let fix aux (z : Z.t) : Stdlib.Seq.node string :=
      let z_len := Z.div (Z.add (Z.numbits z) 7) 8 in
      if OCaml.Stdlib.gt z_len max_z_len then
        Seq.Nil
      else
        Stdlib.Bytes.blit_string (Z.to_bits z) 0 buf is_updated_constant_len
          z_len;
        Seq.Cons buf
          (fun function_parameter =>
            match function_parameter with
            | tt => aux (Z.succ z)
            end) in
    aux Z.zero
  end.

Definition empty_proof_of_work_nonce : string :=
  Stdlib.Bytes.make
    Tezos_protocol_alpha.Protocol.Constants_repr.proof_of_work_nonce_size
    "000" % char.

Definition mine {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (shell : Tezos_raw_protocol_alpha.Alpha_context.Block_header.shell_header)
  (builder :
    string -> Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all cctxt
      (chain, block))
    (fun constants =>
      let threshold := proof_of_work_threshold (parametric constants) in
      let fix loop (nonce_seq : Stdlib.Seq.node string)
        : Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents) :=
        match nonce_seq with
        | Seq.Nil =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Client_baking_pow.mine: couldn't find nonce for required proof of work"
                  % string CamlinternalFormatBasics.End_of_format)
              "Client_baking_pow.mine: couldn't find nonce for required proof of work"
                % string)
        | Seq.Cons nonce seq =>
          let block := builder nonce in
          if
            Tezos_protocol_alpha.Protocol.Baking.check_header_proof_of_work_stamp
              shell block threshold then
            Tezos_base__TzPervasives._return block
          else
            loop (seq tt)
        end in
      loop (init_proof_of_work_nonce tt)).
src/proto_alpha/lib_delegate/client_baking_pow.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

(** A null proof-of-work nonce. This should only be used to non-sensical blocks
    of the correct size and shape. *)
val empty_proof_of_work_nonce : Bytes.t

(** [mine cctxt chain block header builder] returns a block with a valid
    proof-of-work nonce. The function [builder], provided by the caller, is used
    to make the block. All the internal logic of generating nonces and checking
    for the proof-of-work threshold is handled by [mine]. *)
val mine :
  #Protocol_client_context.full ->
  Shell_services.chain ->
  Block_services.block ->
  Block_header.shell_header ->
  (Bytes.t -> Alpha_context.Block_header.contents) ->
  Alpha_context.Block_header.contents tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_pow.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter empty_proof_of_work_nonce : Stdlib.Bytes.t.

Parameter mine : forall {_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Shell_services.chain ->
    Tezos_shell_services.Block_services.block ->
      Tezos_base__TzPervasives.Block_header.shell_header ->
        (Stdlib.Bytes.t ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents).
src/proto_alpha/lib_delegate/client_baking_revelation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.nonce_revelation"
end)

let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain
    ~block ?async nonces =
  Shell_services.Blocks.hash cctxt ~chain ~block ()
  >>=? fun hash ->
  match nonces with
  | [] ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "Nothing to reveal for block %a"
            -% t event "no_nonce_reveal"
            -% a Block_hash.Logging.tag hash)
      >>= fun () -> return_unit
  | _ ->
      iter_s
        (fun (level, nonce) ->
          Alpha_services.Forge.seed_nonce_revelation
            cctxt
            (chain, block)
            ~branch:hash
            ~level
            ~nonce
            ()
          >>=? fun bytes ->
          let bytes = Signature.concat bytes Signature.zero in
          Shell_services.Injection.operation cctxt ?async ~chain bytes
          >>=? fun oph ->
          lwt_log_notice
            Tag.DSL.(
              fun f ->
                f
                  "Revealing nonce %a from level %a for chain %a, block %a \
                   with operation %a"
                -% t event "reveal_nonce" -% a Logging.nonce_tag nonce
                -% a Logging.level_tag level -% a Logging.chain_tag chain
                -% a Logging.block_tag block
                -% a Operation_hash.Logging.tag oph)
          >>= fun () -> return_unit)
        nonces
src/proto_alpha/lib_delegate/client_baking_revelation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition inject_seed_nonce_revelation {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block) (async : option bool)
  (nonces :
    list
      (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
        Tezos_raw_protocol_alpha.Alpha_context.Nonce.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_shell_services.Shell_services.Blocks.hash cctxt (Some chain)
      (Some block) tt)
    (fun hash =>
      match nonces with
      | [] =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_notice
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Nothing to reveal for block " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))
                      "Nothing to reveal for block %a" % string))
                  (Tag.DSL.t event "no_nonce_reveal" % string))
                (Tag.DSL.a Tezos_base__TzPervasives.Block_hash.Logging.tag hash)))
          (fun function_parameter =>
            match function_parameter with
            | tt => Tezos_base__TzPervasives.return_unit
            end)
      | _ =>
        Tezos_base__TzPervasives.iter_s
          (fun function_parameter =>
            match function_parameter with
            | (level, nonce) =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_protocol_alpha.Protocol.Alpha_services.Forge.seed_nonce_revelation
                  cctxt (chain, block) hash level nonce tt)
                (fun bytes =>
                  let bytes :=
                    Tezos_base__TzPervasives.Signature.concat string
                      Tezos_base__TzPervasives.Signature.zero in
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_shell_services.Shell_services.Injection.operation
                      cctxt async (Some chain) string)
                    (fun oph =>
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (lwt_log_notice
                          (fun f =>
                            Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (Tag.DSL.op_minus_percent
                                  (Tag.DSL.op_minus_percent
                                    (Tag.DSL.op_minus_percent
                                      (Tag.DSL.op_minus_percent
                                        (f
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Revealing nonce " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  " from level " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.String_literal
                                                      " for chain " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.String_literal
                                                          ", block " % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.String_literal
                                                              " with operation "
                                                                % string
                                                              (CamlinternalFormatBasics.Alpha
                                                                CamlinternalFormatBasics.End_of_format))))))))))
                                            "Revealing nonce %a from level %a for chain %a, block %a with operation %a"
                                              % string))
                                        (Tag.DSL.t event "reveal_nonce" % string))
                                      (Tag.DSL.a
                                        Tezos_baking_alpha.Logging.nonce_tag
                                        nonce))
                                    (Tag.DSL.a
                                      Tezos_baking_alpha.Logging.level_tag level))
                                  (Tag.DSL.a
                                    Tezos_baking_alpha.Logging.chain_tag chain))
                                (Tag.DSL.a Tezos_baking_alpha.Logging.block_tag
                                  block))
                              (Tag.DSL.a
                                Tezos_base__TzPervasives.Operation_hash.Logging.tag
                                oph)))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => Tezos_base__TzPervasives.return_unit
                          end)))
            end) nonces
      end).
src/proto_alpha/lib_delegate/client_baking_revelation.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

val inject_seed_nonce_revelation :
  #Protocol_client_context.full ->
  chain:Chain_services.chain ->
  block:Block_services.block ->
  ?async:bool ->
  (Raw_level.t * Nonce.t) list ->
  unit tzresult Lwt.t
src/proto_alpha/lib_delegate/client_baking_revelation.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter inject_seed_nonce_revelation : forall
{_ a b c i o p q variant : Type},
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
  (Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block) ->
    q ->
      i ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      a ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i o)
      ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) * c)
        q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((unit -> Ptime.t) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((float -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * _)))))))))))))))))))))))))
  * _) ->
  Tezos_shell_services.Chain_services.chain ->
    Tezos_shell_services.Block_services.block ->
      (option bool) ->
        (list
          (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t *
            Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_delegate/client_baking_scheduling.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.scheduling"
end)

open Logging

let sleep_until time =
  (* Sleeping is a system op, baking is a protocol op, this is where we convert *)
  let time = Time.System.of_protocol_exn time in
  let delay = Ptime.diff time (Tezos_stdlib_unix.Systime_os.now ()) in
  if Ptime.Span.compare delay Ptime.Span.zero < 0 then None
  else Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay))

let rec wait_for_first_event ~name stream =
  Lwt_stream.get stream
  >>= function
  | None | Some (Error _) ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "Can't fetch the current event. Waiting for new event."
            -% t event "cannot_fetch_event"
            -% t worker_tag name)
      >>= fun () ->
      (* NOTE: this is not a tight loop because of Lwt_stream.get *)
      wait_for_first_event ~name stream
  | Some (Ok bi) ->
      Lwt.return bi

let log_errors_and_continue ~name p =
  p
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error errs ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Error while baking:@\n%a"
            -% t event "daemon_error" -% t worker_tag name -% a errs_tag errs)

let main ~(name : string) ~(cctxt : #Protocol_client_context.full)
    ~(stream : 'event tzresult Lwt_stream.t)
    ~(state_maker : 'event -> 'state tzresult Lwt.t)
    ~(pre_loop :
       #Protocol_client_context.full -> 'state -> 'event -> unit tzresult Lwt.t)
    ~(compute_timeout : 'state -> 'timesup Lwt.t)
    ~(timeout_k :
       #Protocol_client_context.full ->
       'state ->
       'timesup ->
       unit tzresult Lwt.t)
    ~(event_k :
       #Protocol_client_context.full -> 'state -> 'event -> unit tzresult Lwt.t)
    =
  lwt_log_info
    Tag.DSL.(
      fun f ->
        f "Setting up before the %s can start."
        -% t event "daemon_setup" -% s worker_tag name)
  >>= fun () ->
  wait_for_first_event ~name stream
  >>= fun first_event ->
  (* statefulness *)
  let last_get_event = ref None in
  let get_event () =
    match !last_get_event with
    | None ->
        let t = Lwt_stream.get stream in
        last_get_event := Some t ;
        t
    | Some t ->
        t
  in
  state_maker first_event
  >>=? fun state ->
  log_errors_and_continue ~name @@ pre_loop cctxt state first_event
  >>= fun () ->
  (* main loop *)
  let rec worker_loop () =
    (* event construction *)
    let timeout = compute_timeout state in
    Lwt.choose
      [ (Lwt_exit.termination_thread >|= fun _ -> `Termination);
        (timeout >|= fun timesup -> `Timeout timesup);
        (get_event () >|= fun e -> `Event e) ]
    >>= function
    (* event matching *)
    | `Termination ->
        return_unit
    | `Event (None | Some (Error _)) ->
        (* exit when the node is unavailable *)
        last_get_event := None ;
        lwt_log_error
          Tag.DSL.(
            fun f ->
              f "Connection to node lost, %s exiting."
              -% t event "daemon_connection_lost"
              -% s worker_tag name)
        >>= fun () -> return_unit
    | `Event (Some (Ok event)) ->
        (* new event: cancel everything and execute callback *)
        last_get_event := None ;
        (* TODO: pretty-print events (requires passing a pp as argument) *)
        log_errors_and_continue ~name @@ event_k cctxt state event
        >>= fun () -> worker_loop ()
    | `Timeout timesup ->
        (* main event: it's time *)
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "Waking up for %s." -% t event "daemon_wakeup"
              -% s worker_tag name)
        >>= fun () ->
        (* core functionality *)
        log_errors_and_continue ~name @@ timeout_k cctxt state timesup
        >>= fun () -> worker_loop ()
  in
  (* ignition *)
  lwt_log_info
    Tag.DSL.(
      fun f ->
        f "Starting %s daemon" -% t event "daemon_start" -% s worker_tag name)
  >>= fun () -> worker_loop ()
src/proto_alpha/lib_delegate/client_baking_scheduling.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_baking_alpha.Logging.

Definition sleep_until (time : Tezos_base__Time.Protocol.t)
  : option (Lwt.t unit) :=
  let time := Tezos_base__TzPervasives.Time.System.of_protocol_exn time in
  let delay := Ptime.diff time (Tezos_stdlib_unix.Systime_os.now tt) in
  if OCaml.Stdlib.lt (Ptime.Span.compare delay Ptime.Span.zero) 0 then
    None
  else
    Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay)).

Fixpoint wait_for_first_event {A B : Type}
  (name : string) (stream : Lwt_stream.t (sum A B)) : Lwt.t A :=
  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_stream.get stream)
    (fun function_parameter =>
      match function_parameter with
      | None | Some (inr _) =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (lwt_log_info
            (fun f =>
              Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Can't fetch the current event. Waiting for new event."
                          % string CamlinternalFormatBasics.End_of_format)
                      "Can't fetch the current event. Waiting for new event." %
                        string)) (Tag.DSL.t event "cannot_fetch_event" % string))
                (Tag.DSL.t Tezos_baking_alpha.Logging.worker_tag name)))
          (fun function_parameter =>
            match function_parameter with
            | tt => wait_for_first_event name stream
            end)
      | Some (inl bi) => Lwt._return bi
      end).

Definition log_errors_and_continue
  (name : string) (p : Lwt.t (sum unit (list Tezos_base__TzPervasives.error)))
  : Lwt.t unit :=
  Tezos_base__TzPervasives.op_gt_gt_eq p
    (fun function_parameter =>
      match function_parameter with
      | inl tt => Lwt.return_unit
      | inr errs =>
        lwt_log_error
          (fun f =>
            Tag.DSL.op_minus_percent
              (Tag.DSL.op_minus_percent
                (Tag.DSL.op_minus_percent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Error while baking:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)))
                      "Error while baking:@
%a" % string))
                  (Tag.DSL.t event "daemon_error" % string))
                (Tag.DSL.t Tezos_baking_alpha.Logging.worker_tag name))
              (Tag.DSL.a Tezos_base__TzPervasives.errs_tag errs))
      end).

Definition main
  {D F H J L M N Q R S T U V X Y Z [ \ ] ^ _ ` a b c event i o p q state timesup
  : Type}
  (name : string)
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (stream : Lwt_stream.t (Tezos_base__TzPervasives.tzresult event))
  (state_maker : event -> Lwt.t (Tezos_base__TzPervasives.tzresult state))
  (pre_loop :
    (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (Q * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (R * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (S * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (T * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (U * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (V * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) -> state -> event -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (compute_timeout : state -> Lwt.t timesup)
  (timeout_k :
    (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (X * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (Y * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (Z * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * ([ * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (\ * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (] * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) -> state -> timesup -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (event_k :
    (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (^ * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (` * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (a * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (b * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (c * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) -> state -> event -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (lwt_log_info
      (fun f =>
        Tag.DSL.op_minus_percent
          (Tag.DSL.op_minus_percent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Setting up before the " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " can start." % string
                      CamlinternalFormatBasics.End_of_format)))
                "Setting up before the %s can start." % string))
            (Tag.DSL.t event "daemon_setup" % string))
          (Tag.DSL.s Tezos_baking_alpha.Logging.worker_tag name)))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq (wait_for_first_event name stream)
          (fun first_event =>
            let last_get_event := Stdlib.ref None in
            let get_event (function_parameter : unit)
              : Lwt.t (option (Tezos_base__TzPervasives.tzresult event)) :=
              match function_parameter with
              | tt =>
                match Stdlib.op_exclamation last_get_event with
                | None =>
                  let t := Lwt_stream.get stream in
                  Stdlib.op_colon_eq last_get_event (Some t);
                  t
                | Some t => t
                end
              end in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (state_maker first_event)
              (fun state =>
                Tezos_base__TzPervasives.op_gt_gt_eq
                  (apply (log_errors_and_continue name)
                    (pre_loop cctxt state first_event))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      let fix worker_loop (function_parameter : unit)
                        : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                        match function_parameter with
                        | tt =>
                          let timeout := compute_timeout state in
                          Tezos_base__TzPervasives.op_gt_gt_eq
                            (Lwt.choose
                              (cons
                                (Tezos_base__TzPervasives.op_gt_pipe_eq
                                  Tezos_stdlib_unix.Lwt_exit.termination_thread
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ => variant
                                    end))
                                (cons
                                  (Tezos_base__TzPervasives.op_gt_pipe_eq
                                    timeout (fun timesup => variant))
                                  (cons
                                    (Tezos_base__TzPervasives.op_gt_pipe_eq
                                      (get_event tt) (fun e => variant)) []))))
                            (fun function_parameter =>
                              match function_parameter with
                              | Termination =>
                                Tezos_base__TzPervasives.return_unit
                              | Event (None | Some (inr _)) =>
                                Stdlib.op_colon_eq last_get_event None;
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (lwt_log_error
                                    (fun f =>
                                      Tag.DSL.op_minus_percent
                                        (Tag.DSL.op_minus_percent
                                          (f
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Connection to node lost, " %
                                                  string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.String_literal
                                                    " exiting." % string
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "Connection to node lost, %s exiting."
                                                % string))
                                          (Tag.DSL.t event
                                            "daemon_connection_lost" % string))
                                        (Tag.DSL.s
                                          Tezos_baking_alpha.Logging.worker_tag
                                          name)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end)
                              | Event (Some (inl event)) =>
                                Stdlib.op_colon_eq last_get_event None;
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (apply (log_errors_and_continue name)
                                    (event_k cctxt state event))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => worker_loop tt
                                    end)
                              | Timeout timesup =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (lwt_debug
                                    (fun f =>
                                      Tag.DSL.op_minus_percent
                                        (Tag.DSL.op_minus_percent
                                          (f
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Waking up for " % string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.Char_literal
                                                    "." % char
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "Waking up for %s." % string))
                                          (Tag.DSL.t event
                                            "daemon_wakeup" % string))
                                        (Tag.DSL.s
                                          Tezos_baking_alpha.Logging.worker_tag
                                          name)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_base__TzPervasives.op_gt_gt_eq
                                        (apply (log_errors_and_continue name)
                                          (timeout_k cctxt state timesup))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt => worker_loop tt
                                          end)
                                    end)
                              end)
                        end in
                      Tezos_base__TzPervasives.op_gt_gt_eq
                        (lwt_log_info
                          (fun f =>
                            Tag.DSL.op_minus_percent
                              (Tag.DSL.op_minus_percent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Starting " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.String_literal
                                          " daemon" % string
                                          CamlinternalFormatBasics.End_of_format)))
                                    "Starting %s daemon" % string))
                                (Tag.DSL.t event "daemon_start" % string))
                              (Tag.DSL.s Tezos_baking_alpha.Logging.worker_tag
                                name)))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt => worker_loop tt
                          end)
                    end)))
      end).
src/proto_alpha/lib_delegate/client_baking_scheduling.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val sleep_until : Time.Protocol.t -> unit Lwt.t option

val wait_for_first_event :
  name:string -> 'event tzresult Lwt_stream.t -> 'event Lwt.t

val main :
  name:string ->
  cctxt:(#Protocol_client_context.full as 'a) ->
  stream:'event tzresult Lwt_stream.t ->
  state_maker:('event -> 'state tzresult Lwt.t) ->
  pre_loop:('a -> 'state -> 'event -> unit tzresult Lwt.t) ->
  compute_timeout:('state -> 'timesup Lwt.t) ->
  timeout_k:('a -> 'state -> 'timesup -> unit tzresult Lwt.t) ->
  event_k:('a -> 'state -> 'event -> unit tzresult Lwt.t) ->
  unit tzresult Lwt.t

(** [main ~name ~cctxt ~stream ~state_maker ~pre_loop ~timeout_maker ~timeout_k
    ~event_k] is an infinitely running loop that
    monitors new events arriving on [stream]. The loop exits when the
    [stream] gives an error.

    The function [pre_loop] is called before the loop starts.

    The loop maintains a state (of type ['state]) initialized by [state_maker]
    and passed to the callbacks [timeout_maker] (used to set up waking-up
    timeouts), [timeout_k] (when a computed timeout happens), and [event_k]
    (when a new event arrives on the stream).
*)
src/proto_alpha/lib_delegate/client_baking_scheduling.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter sleep_until :
Tezos_base__TzPervasives.Time.Protocol.t -> option (Lwt.t unit).

Parameter wait_for_first_event : forall {event : Type},
string ->
  (Lwt_stream.t (Tezos_base__TzPervasives.tzresult event)) -> Lwt.t event.

Parameter main : forall {_ a b c event i o p q state timesup variant : Type},
string ->
  (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (_ * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (_ * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * a)))))))))))))))))))))))))
    * a) ->
    (Lwt_stream.t (Tezos_base__TzPervasives.tzresult event)) ->
      (event -> Lwt.t (Tezos_base__TzPervasives.tzresult state)) ->
        ((((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
            ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * b * q * i * o)) *
              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                  * b) * c) q i o) ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (_ * a * b * c * q * i * o)) *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  (Uri.t *
                    (Tezos_shell_services.Shell_services.block *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                        * (_ * p * q * i * o)) *
                        ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                          (o -> unit) ->
                            (unit -> unit) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult
                                        (unit -> unit))) * (_ * p * q * i * o))
                          *
                          (Tezos_shell_services.Shell_services.chain *
                            ((option Z) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                b) -> a) * (a * b)) *
                                ((Tezos_rpc.RPC_service.meth ->
                                  (option Tezos_data_encoding.Data_encoding.json)
                                    ->
                                    Uri.t ->
                                      Lwt.t
                                        (Tezos_rpc.RPC_context.rest_result
                                          Tezos_data_encoding.Data_encoding.json
                                          (option
                                            Tezos_data_encoding.Data_encoding.json)))
                                  *
                                  (((string ->
                                    a ->
                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                        a) ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult a))
                                    * (a)) *
                                    ((option (Lwt_stream.t string)) *
                                      (((string ->
                                        (Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((unit -> Ptime.t) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) -> a) * (a)) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  Bigstring.t)) -> a) * (a)) *
                                                ((string ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      string)) *
                                                  ((float -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) *
                                                      ((((unit -> Lwt.t a) ->
                                                        Lwt.t a) * (a)) *
                                                        (((string ->
                                                          a ->
                                                            (Tezos_base__TzPervasives.Data_encoding.encoding
                                                              a) ->
                                                              Lwt.t
                                                                (Tezos_base__TzPervasives.tzresult
                                                                  unit)) * (a))
                                                          * a)))))))))))))))))))))))))
          * a) ->
          state -> event -> Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
          (state -> Lwt.t timesup) ->
            ((((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
              variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (_ * q * i * o)) *
              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q
                i o) ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  a ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * q * i * o)) *
                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                  variant
                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                  ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                    * b) q i o) ->
                  (Tezos_shell_services.Shell_services.chain *
                    Tezos_shell_services.Shell_services.block) ->
                    a ->
                      b ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (_ * a * b * q * i * o)) *
                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                    variant
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                    (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
                      a) * b) * c) q i o) ->
                    (Tezos_shell_services.Shell_services.chain *
                      Tezos_shell_services.Shell_services.block) ->
                      a ->
                        b ->
                          c ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (_ * a * b * c * q * i * o)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      (Uri.t *
                        (Tezos_shell_services.Shell_services.block *
                          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult o))
                            * (_ * p * q * i * o)) *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              (o -> unit) ->
                                (unit -> unit) ->
                                  p ->
                                    q ->
                                      i ->
                                        Lwt.t
                                          (Tezos_error_monad.Error_monad.tzresult
                                            (unit -> unit))) *
                              (_ * p * q * i * o)) *
                              (Tezos_shell_services.Shell_services.chain *
                                ((option Z) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a b) -> a) * (a * b)) *
                                    ((Tezos_rpc.RPC_service.meth ->
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)
                                        ->
                                        Uri.t ->
                                          Lwt.t
                                            (Tezos_rpc.RPC_context.rest_result
                                              Tezos_data_encoding.Data_encoding.json
                                              (option
                                                Tezos_data_encoding.Data_encoding.json)))
                                      *
                                      (((string ->
                                        a ->
                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                            a) ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                a)) * (a)) *
                                        ((option (Lwt_stream.t string)) *
                                          (((string ->
                                            (Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((unit -> Ptime.t) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) -> a) * (a)) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a
                                                    (Tezos_base__TzPervasives.tzresult
                                                      Bigstring.t)) -> a) * (a))
                                                    *
                                                    ((string ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          string)) *
                                                      ((float -> Lwt.t unit) *
                                                        ((((Tezos_client_base.Client_context.lwt_format
                                                          a unit) -> a) * (a)) *
                                                          ((((unit -> Lwt.t a)
                                                            -> Lwt.t a) * (a)) *
                                                            (((string ->
                                                              a ->
                                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                                  a) ->
                                                                  Lwt.t
                                                                    (Tezos_base__TzPervasives.tzresult
                                                                      unit)) *
                                                              (a)) * a)))))))))))))))))))))))))
              * a) ->
              state -> timesup -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
              ->
              ((((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o)
                ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (_ * q * i * o)) *
                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                  variant
                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                  (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                  q i o) ->
                  (Tezos_shell_services.Shell_services.chain *
                    Tezos_shell_services.Shell_services.block) ->
                    a ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (_ * a * q * i * o)) *
                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                    variant
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                    ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
                      a) * b) q i o) ->
                    (Tezos_shell_services.Shell_services.chain *
                      Tezos_shell_services.Shell_services.block) ->
                      a ->
                        b ->
                          q ->
                            i ->
                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                  o)) * (_ * a * b * q * i * o)) *
                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                      variant
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                      (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                        * a) * b) * c) q i o) ->
                      (Tezos_shell_services.Shell_services.chain *
                        Tezos_shell_services.Shell_services.block) ->
                        a ->
                          b ->
                            c ->
                              q ->
                                i ->
                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                      o)) * (_ * a * b * c * q * i * o)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) *
                        (Uri.t *
                          (Tezos_shell_services.Shell_services.block *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (_ * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (_ * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          a ->
                                            (Tezos_base__TzPervasives.Data_encoding.encoding
                                              a) ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  a)) * (a)) *
                                          ((option (Lwt_stream.t string)) *
                                            (((string ->
                                              (Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((unit -> Ptime.t) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a
                                                    (Tezos_base__TzPervasives.tzresult
                                                      string)) -> a) * (a)) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a
                                                      (Tezos_base__TzPervasives.tzresult
                                                        Bigstring.t)) -> a) *
                                                      (a)) *
                                                      ((string ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            string)) *
                                                        ((float -> Lwt.t unit) *
                                                          ((((Tezos_client_base.Client_context.lwt_format
                                                            a unit) -> a) * (a))
                                                            *
                                                            ((((unit -> Lwt.t a)
                                                              -> Lwt.t a) * (a))
                                                              *
                                                              (((string ->
                                                                a ->
                                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                                    a) ->
                                                                    Lwt.t
                                                                      (Tezos_base__TzPervasives.tzresult
                                                                        unit)) *
                                                                (a)) * a)))))))))))))))))))))))))
                * a) ->
                state -> event -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
                -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
src/proto_alpha/lib_delegate/client_baking_simulator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context

type error += Failed_to_checkout_context

type error += Invalid_context

let ( >>=?? ) x k = x >>= fun x -> Lwt.return (Environment.wrap_error x) >>=? k

let () =
  register_error_kind
    `Permanent
    ~id:"Client_baking_simulator.failed_to_checkout_context"
    ~title:"Failed to checkout context"
    ~description:"The given context hash does not exists in the context."
    ~pp:(fun ppf () -> Format.fprintf ppf "Failed to checkout the context")
    Data_encoding.unit
    (function Failed_to_checkout_context -> Some () | _ -> None)
    (fun () -> Failed_to_checkout_context) ;
  register_error_kind
    `Permanent
    ~id:"Client_baking_simulator.invalid_context"
    ~title:"Invalid context"
    ~description:"Occurs when the context is inconsistent."
    ~pp:(fun ppf () -> Format.fprintf ppf "The given context is invalid.")
    Data_encoding.unit
    (function Invalid_context -> Some () | _ -> None)
    (fun () -> Invalid_context)

type incremental = {
  predecessor : Client_baking_blocks.block_info;
  context : Tezos_protocol_environment.Context.t;
  state : Protocol.validation_state;
  rev_operations : Operation.packed list;
  header : Tezos_base.Block_header.shell_header;
}

let load_context ~context_path = Context.init ~readonly:true context_path

let check_context_consistency index context_hash =
  (* Hypothesis : the version key exists *)
  let version_key = ["version"] in
  Context.checkout index context_hash
  >>= function
  | None ->
      fail Failed_to_checkout_context
  | Some context -> (
      Context.mem context version_key
      >>= function true -> return_unit | false -> fail Invalid_context )

let begin_construction ~timestamp ?protocol_data index predecessor =
  let {Client_baking_blocks.context; _} = predecessor in
  Shell_context.checkout index context
  >>= function
  | None ->
      fail Failed_to_checkout_context
  | Some context ->
      let header : Tezos_base.Block_header.shell_header =
        Tezos_base.Block_header.
          {
            predecessor = predecessor.hash;
            proto_level = predecessor.proto_level;
            validation_passes = 0;
            fitness = predecessor.fitness;
            timestamp;
            level = Raw_level.to_int32 predecessor.level;
            context = Context_hash.zero;
            operations_hash = Operation_list_list_hash.zero;
          }
      in
      Protocol.begin_construction
        ~chain_id:predecessor.chain_id
        ~predecessor_context:context
        ~predecessor_timestamp:predecessor.timestamp
        ~predecessor_fitness:predecessor.fitness
        ~predecessor_level:(Raw_level.to_int32 predecessor.level)
        ~predecessor:predecessor.hash
        ?protocol_data
        ~timestamp
        ()
      >>=?? fun state ->
      return {predecessor; context; state; rev_operations = []; header}

let add_operation st (op : Operation.packed) =
  Protocol.apply_operation st.state op
  >>=?? fun (state, receipt) ->
  return ({st with state; rev_operations = op :: st.rev_operations}, receipt)

let finalize_construction inc = Protocol.finalize_block inc.state >>=?? return
src/proto_alpha/lib_delegate/client_baking_simulator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_alpha.Protocol_client_context.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition op_gt_gt_eq_question_question {A B : Type}
  (x : Lwt.t (Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult A))
  (k : A -> Lwt.t (Tezos_base__TzPervasives.tzresult B))
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  Tezos_base__TzPervasives.op_gt_gt_eq x
    (fun x =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Lwt._return (Tezos_protocol_alpha.Protocol.Environment.wrap_error x)) k).

Record incremental := {
  predecessor : Tezos_baking_alpha.Client_baking_blocks.block_info;
  context : Tezos_protocol_environment.Context.t;
  state : Tezos_protocol_alpha.Protocol.validation_state;
  rev_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
  header : Tezos_base.Block_header.shell_header }.

Definition load_context (context_path : string)
  : Lwt.t Tezos_storage.Context.index :=
  Tezos_storage.Context.init None None (Some true) context_path.

Definition check_context_consistency
  (index : Tezos_storage.Context.index)
  (context_hash : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let version_key := cons "version" % string [] in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_storage.Context.checkout index context_hash)
    (fun function_parameter =>
      match function_parameter with
      | None => Tezos_base__TzPervasives.fail Failed_to_checkout_context
      | Some context =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (Tezos_storage.Context.mem context version_key)
          (fun function_parameter =>
            match function_parameter with
            | true => Tezos_base__TzPervasives.return_unit
            | false => Tezos_base__TzPervasives.fail Invalid_context
            end)
      end).

Definition begin_construction
  (timestamp : Tezos_base.Time.Protocol.t)
  (protocol_data : option Tezos_protocol_alpha.Protocol.block_header_data)
  (index : Tezos_storage.Context.index)
  (predecessor : Tezos_baking_alpha.Client_baking_blocks.block_info)
  : Lwt.t (Tezos_base__TzPervasives.tzresult incremental) :=
  match predecessor with
  | {| Client_baking_blocks.context := context |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_shell_context.Shell_context.checkout index context)
      (fun function_parameter =>
        match function_parameter with
        | None => Tezos_base__TzPervasives.fail Failed_to_checkout_context
        | Some context =>
          let header :=
            {|
              level :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
                  (level predecessor); proto_level := proto_level predecessor;
              predecessor := hash predecessor; timestamp := timestamp;
              validation_passes := 0;
              operations_hash :=
                Tezos_base__TzPervasives.Operation_list_list_hash.zero;
              fitness := fitness predecessor;
              context := Tezos_base__TzPervasives.Context_hash.zero |} in
          op_gt_gt_eq_question_question
            (Tezos_protocol_alpha.Protocol.begin_construction
              (chain_id predecessor) context (timestamp predecessor)
              (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
                (level predecessor)) (fitness predecessor) (hash predecessor)
              timestamp protocol_data tt)
            (fun state =>
              Tezos_base__TzPervasives._return
                {| predecessor := predecessor; context := context;
                  state := state; rev_operations := []; header := header |})
        end)
  end.

Definition add_operation
  (st : incremental)
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (incremental * Tezos_protocol_alpha.Protocol.operation_receipt)) :=
  op_gt_gt_eq_question_question
    (Tezos_protocol_alpha.Protocol.apply_operation (state st) op)
    (fun function_parameter =>
      match function_parameter with
      | (state, receipt) => Tezos_base__TzPervasives._return (record, receipt)
      end).

Definition finalize_construction (inc : incremental)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Updater.validation_result *
        Tezos_protocol_alpha.Protocol.block_header_metadata)) :=
  op_gt_gt_eq_question_question
    (Tezos_protocol_alpha.Protocol.finalize_block (state inc))
    Tezos_base__TzPervasives._return.
src/proto_alpha/lib_delegate/client_baking_simulator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type incremental = {
  predecessor : Client_baking_blocks.block_info;
  context : Tezos_protocol_environment.Context.t;
  state : validation_state;
  rev_operations : Operation.packed list;
  header : Tezos_base.Block_header.shell_header;
}

val load_context : context_path:string -> Context.index Lwt.t

(** Make sure that the given context is consistent by trying to read in it *)
val check_context_consistency :
  Context.index -> Context_hash.t -> unit tzresult Lwt.t

val begin_construction :
  timestamp:Time.Protocol.t ->
  ?protocol_data:block_header_data ->
  Context.index ->
  Client_baking_blocks.block_info ->
  incremental tzresult Lwt.t

val add_operation :
  incremental ->
  Operation.packed ->
  (incremental * operation_receipt) tzresult Lwt.t

val finalize_construction :
  incremental ->
  (Tezos_protocol_environment.validation_result * block_header_metadata)
  tzresult
  Lwt.t
src/proto_alpha/lib_delegate/client_baking_simulator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record incremental := {
  predecessor : Tezos_baking_alpha.Client_baking_blocks.block_info;
  context : Tezos_protocol_environment.Context.t;
  state : Tezos_protocol_alpha.Protocol.validation_state;
  rev_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
  header : Tezos_base.Block_header.shell_header }.

Parameter load_context : string -> Lwt.t Tezos_storage.Context.index.

Parameter check_context_consistency :
Tezos_storage.Context.index ->
  Tezos_base__TzPervasives.Context_hash.t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit).

Parameter begin_construction :
Tezos_base__TzPervasives.Time.Protocol.t ->
  (option Tezos_protocol_alpha.Protocol.block_header_data) ->
    Tezos_storage.Context.index ->
      Tezos_baking_alpha.Client_baking_blocks.block_info ->
        Lwt.t (Tezos_base__TzPervasives.tzresult incremental).

Parameter add_operation :
incremental ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (incremental * Tezos_protocol_alpha.Protocol.operation_receipt)).

Parameter finalize_construction :
incremental ->
  Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment.validation_result *
        Tezos_protocol_alpha.Protocol.block_header_metadata)).
src/proto_alpha/lib_delegate/client_daemon.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let rec retry (cctxt : #Protocol_client_context.full) ~delay ~tries f x =
  f x
  >>= function
  | Ok _ as r ->
      Lwt.return r
  | Error
      (RPC_client_errors.Request_failed {error = Connection_failed _; _} :: _)
    as err
    when tries > 0 -> (
      cctxt#message "Connection refused, retrying in %.2f seconds..." delay
      >>= fun () ->
      Lwt.pick
        [ (Lwt_unix.sleep delay >|= fun () -> `Continue);
          (Lwt_exit.termination_thread >|= fun _ -> `Killed) ]
      >>= function
      | `Killed ->
          Lwt.return err
      | `Continue ->
          retry cctxt ~delay:(delay *. 1.5) ~tries:(tries - 1) f x )
  | Error _ as err ->
      Lwt.return err

let await_bootstrapped_node (cctxt : #Protocol_client_context.full) =
  (* Waiting for the node to be synchronized *)
  cctxt#message "Waiting for the node to be synchronized with its peers..."
  >>= fun () ->
  retry cctxt ~tries:5 ~delay:1. Shell_services.Monitor.bootstrapped cctxt
  >>=? fun _ -> cctxt#message "Node synchronized." >>= fun () -> return_unit

let monitor_fork_testchain (cctxt : #Protocol_client_context.full)
    ~cleanup_nonces =
  (* Waiting for the node to be synchronized *)
  cctxt#message "Waiting for the test chain to be forked..."
  >>= fun () ->
  Shell_services.Monitor.active_chains cctxt
  >>=? fun (stream, _) ->
  let rec loop () =
    Lwt_stream.next stream
    >>= fun l ->
    let testchain =
      List.find_opt
        (function Shell_services.Monitor.Active_test _ -> true | _ -> false)
        l
    in
    match testchain with
    | Some (Active_test {protocol; expiration_date; _})
      when Protocol_hash.equal Protocol.hash protocol ->
        let abort_daemon () =
          cctxt#message
            "Test chain's expiration date reached (%a)... Stopping the \
             daemon.@."
            Time.Protocol.pp_hum
            expiration_date
          >>= fun () ->
          if cleanup_nonces then
            (* Clean-up existing nonces *)
            cctxt#with_lock (fun () ->
                Client_baking_files.resolve_location cctxt ~chain:`Test `Nonce
                >>=? fun nonces_location ->
                Client_baking_nonces.(save cctxt nonces_location empty))
          else return_unit >>=? fun () -> exit 0
        in
        let canceler = Lwt_canceler.create () in
        Lwt_canceler.on_cancel canceler (fun () ->
            abort_daemon () >>= function _ -> Lwt.return_unit) ;
        let now = Time.System.(to_protocol (Systime_os.now ())) in
        let delay = Int64.to_int (Time.Protocol.diff expiration_date now) in
        if delay <= 0 then (* Testchain already expired... Retrying. *)
          loop ()
        else
          let timeout =
            Lwt_timeout.create delay (fun () ->
                Lwt_canceler.cancel canceler |> ignore)
          in
          Lwt_timeout.start timeout ; return_unit
    | None ->
        loop ()
    | Some _ ->
        loop ()
    (* Got a testchain for a different protocol, skipping *)
  in
  Lwt.pick
    [ (Lwt_exit.termination_thread >>= fun _ -> failwith "Interrupted...");
      loop () ]
  >>=? fun () -> cctxt#message "Test chain forked." >>= fun () -> return_unit

module Endorser = struct
  let run (cctxt : #Protocol_client_context.full) ~chain ~delay delegates =
    await_bootstrapped_node cctxt
    >>=? fun _ ->
    ( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:false
    else return_unit )
    >>=? fun () ->
    Client_baking_blocks.monitor_heads
      ~next_protocols:(Some [Protocol.hash])
      cctxt
      chain
    >>=? fun block_stream ->
    cctxt#message "Endorser started."
    >>= fun () ->
    Client_baking_endorsement.create cctxt ~delay delegates block_stream
end

module Baker = struct
  let run (cctxt : #Protocol_client_context.full) ?minimal_fees
      ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?max_priority
      ~chain ~context_path delegates =
    await_bootstrapped_node cctxt
    >>=? fun _ ->
    ( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:true
    else return_unit )
    >>=? fun () ->
    Client_baking_blocks.monitor_heads
      ~next_protocols:(Some [Protocol.hash])
      cctxt
      chain
    >>=? fun block_stream ->
    cctxt#message "Baker started."
    >>= fun () ->
    Client_baking_forge.create
      cctxt
      ?minimal_fees
      ?minimal_nanotez_per_gas_unit
      ?minimal_nanotez_per_byte
      ?max_priority
      ~chain
      ~context_path
      delegates
      block_stream
end

module Accuser = struct
  let run (cctxt : #Protocol_client_context.full) ~chain ~preserved_levels =
    await_bootstrapped_node cctxt
    >>=? fun _ ->
    ( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:true
    else return_unit )
    >>=? fun () ->
    Client_baking_blocks.monitor_valid_blocks
      ~next_protocols:(Some [Protocol.hash])
      cctxt
      ~chains:[chain]
      ()
    >>=? fun valid_blocks_stream ->
    cctxt#message "Accuser started."
    >>= fun () ->
    Client_baking_denunciation.create
      cctxt
      ~preserved_levels
      valid_blocks_stream
end
src/proto_alpha/lib_delegate/client_daemon.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Fixpoint retry {D F H J L M N O P a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (delay : float) (tries : Z)
  (f : O -> Lwt.t (sum P (list Tezos_base__TzPervasives.error))) (x : O)
  : Lwt.t (sum P (list Tezos_base__TzPervasives.error)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq (f x)
    (fun function_parameter =>
      match function_parameter with
      | (inl _) as r => Lwt._return r
      |
        (inr
          (cons
            (RPC_client_errors.Request_failed {| error := Connection_failed _ |})
            _)) as err =>
        Tezos_base__TzPervasives.op_gt_gt_eq
          (send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Connection refused, retrying in " % string
                (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Lit_precision 2)
                  (CamlinternalFormatBasics.String_literal
                    " seconds..." % string
                    CamlinternalFormatBasics.End_of_format)))
              "Connection refused, retrying in %.2f seconds..." % string) delay)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (Lwt.pick
                  (cons
                    (Tezos_base__TzPervasives.op_gt_pipe_eq
                      (Lwt_unix.sleep delay)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => variant
                        end))
                    (cons
                      (Tezos_base__TzPervasives.op_gt_pipe_eq
                        Tezos_stdlib_unix.Lwt_exit.termination_thread
                        (fun function_parameter =>
                          match function_parameter with
                          | _ => variant
                          end)) [])))
                (fun function_parameter =>
                  match function_parameter with
                  | Killed => Lwt._return err
                  | Continue =>
                    retry cctxt (Stdlib.op_star_point delay 1) (Z.sub tries 1) f
                      x
                  end)
            end)
      | (inr _) as err => Lwt._return err
      end).

Definition await_bootstrapped_node {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Waiting for the node to be synchronized with its peers..." % string
          CamlinternalFormatBasics.End_of_format)
        "Waiting for the node to be synchronized with its peers..." % string))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (retry cctxt 1 5
            Tezos_shell_services.Shell_services.Monitor.bootstrapped cctxt)
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              Tezos_base__TzPervasives.op_gt_gt_eq
                (send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Node synchronized." % string
                      CamlinternalFormatBasics.End_of_format)
                    "Node synchronized." % string))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => Tezos_base__TzPervasives.return_unit
                  end)
            end)
      end).

Definition monitor_fork_testchain {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((float -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (cleanup_nonces : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Waiting for the test chain to be forked..." % string
          CamlinternalFormatBasics.End_of_format)
        "Waiting for the test chain to be forked..." % string))
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_shell_services.Shell_services.Monitor.active_chains cctxt)
          (fun function_parameter =>
            match function_parameter with
            | (stream, _) =>
              let fix loop (function_parameter : unit)
                : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq (Lwt_stream.next stream)
                    (fun l =>
                      let testchain :=
                        Tezos_base__TzPervasives.List.find_opt
                          (fun function_parameter =>
                            match function_parameter with
                            | Shell_services.Monitor.Active_test _ => true
                            | _ => false
                            end) l in
                      match testchain with
                      | None => loop tt
                      | Some _ => loop tt
                      end)
                end in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Lwt.pick
                  (cons
                    (Tezos_base__TzPervasives.op_gt_gt_eq
                      Tezos_stdlib_unix.Lwt_exit.termination_thread
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          Tezos_base__TzPervasives.failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Interrupted..." % string
                                CamlinternalFormatBasics.End_of_format)
                              "Interrupted..." % string)
                        end)) (cons (loop tt) [])))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Test chain forked." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Test chain forked." % string))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => Tezos_base__TzPervasives.return_unit
                        end)
                  end)
            end)
      end).

Module Endorser.
  Definition run {D F H J L M N a b c i o p q : Type}
    (cctxt :
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  a ->
                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                      a) ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult a)) *
                                  (a)) *
                                  ((option (Lwt_stream.t string)) *
                                    (((string ->
                                      (Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                        ((unit -> Ptime.t) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                Bigstring.t)) -> a) * (a)) *
                                              ((string ->
                                                Lwt.t
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) *
                                                ((float -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) *
                                                    ((((unit -> Lwt.t a) ->
                                                      Lwt.t a) * (a)) *
                                                      (((string ->
                                                        a ->
                                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                                            a) ->
                                                            Lwt.t
                                                              (Tezos_base__TzPervasives.tzresult
                                                                unit)) * (a)) *
                                                        N)))))))))))))))))))))))))
        * N) (chain : variant) (delay : Z)
    (delegates :
      list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (await_bootstrapped_node cctxt)
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (if equiv_decb chain variant then
              monitor_fork_testchain cctxt false
            else
              Tezos_base__TzPervasives.return_unit)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_baking_alpha.Client_baking_blocks.monitor_heads cctxt
                    (Some (cons Tezos_protocol_alpha.Protocol.hash [])) chain)
                  (fun block_stream =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Endorser started." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Endorser started." % string))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_baking_alpha.Client_baking_endorsement.create
                            cctxt None delay delegates block_stream
                        end))
              end)
        end).
End Endorser.

Module Baker.
  Definition run {D F H J L M N a b c i o p q : Type}
    (cctxt :
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  a ->
                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                      a) ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult a)) *
                                  (a)) *
                                  ((option (Lwt_stream.t string)) *
                                    (((string ->
                                      (Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                        ((unit -> Ptime.t) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                Bigstring.t)) -> a) * (a)) *
                                              ((string ->
                                                Lwt.t
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) *
                                                ((float -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) *
                                                    ((((unit -> Lwt.t a) ->
                                                      Lwt.t a) * (a)) *
                                                      (((string ->
                                                        a ->
                                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                                            a) ->
                                                            Lwt.t
                                                              (Tezos_base__TzPervasives.tzresult
                                                                unit)) * (a)) *
                                                        N)))))))))))))))))))))))))
        * N)
    (minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
    (minimal_nanotez_per_gas_unit : option Z.t)
    (minimal_nanotez_per_byte : option Z.t) (max_priority : option Z)
    (chain : variant) (context_path : string)
    (delegates :
      list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (await_bootstrapped_node cctxt)
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (if equiv_decb chain variant then
              monitor_fork_testchain cctxt true
            else
              Tezos_base__TzPervasives.return_unit)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_baking_alpha.Client_baking_blocks.monitor_heads cctxt
                    (Some (cons Tezos_protocol_alpha.Protocol.hash [])) chain)
                  (fun block_stream =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Baker started." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Baker started." % string))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_baking_alpha.Client_baking_forge.create cctxt
                            minimal_fees minimal_nanotez_per_gas_unit
                            minimal_nanotez_per_byte max_priority chain
                            context_path delegates block_stream
                        end))
              end)
        end).
End Baker.

Module Accuser.
  Definition run {D F H J L M N a b c i o p q : Type}
    (cctxt :
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  a ->
                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                      a) ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult a)) *
                                  (a)) *
                                  ((option (Lwt_stream.t string)) *
                                    (((string ->
                                      (Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                        ((unit -> Ptime.t) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                Bigstring.t)) -> a) * (a)) *
                                              ((string ->
                                                Lwt.t
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) *
                                                ((float -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) *
                                                    ((((unit -> Lwt.t a) ->
                                                      Lwt.t a) * (a)) *
                                                      (((string ->
                                                        a ->
                                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                                            a) ->
                                                            Lwt.t
                                                              (Tezos_base__TzPervasives.tzresult
                                                                unit)) * (a)) *
                                                        N)))))))))))))))))))))))))
        * N) (chain : variant) (preserved_levels : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (await_bootstrapped_node cctxt)
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (if equiv_decb chain variant then
              monitor_fork_testchain cctxt true
            else
              Tezos_base__TzPervasives.return_unit)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_baking_alpha.Client_baking_blocks.monitor_valid_blocks
                    cctxt (Some (cons chain [])) None
                    (Some (cons Tezos_protocol_alpha.Protocol.hash [])) tt)
                  (fun valid_blocks_stream =>
                    Tezos_base__TzPervasives.op_gt_gt_eq
                      (send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Accuser started." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Accuser started." % string))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_baking_alpha.Client_baking_denunciation.create
                            cctxt preserved_levels valid_blocks_stream
                        end))
              end)
        end).
End Accuser.
src/proto_alpha/lib_delegate/client_daemon.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

module Endorser : sig
  val run :
    #Protocol_client_context.full ->
    chain:Chain_services.chain ->
    delay:int ->
    public_key_hash list ->
    unit tzresult Lwt.t
end

module Baker : sig
  val run :
    #Protocol_client_context.full ->
    ?minimal_fees:Tez.t ->
    ?minimal_nanotez_per_gas_unit:Z.t ->
    ?minimal_nanotez_per_byte:Z.t ->
    ?max_priority:int ->
    chain:Chain_services.chain ->
    context_path:string ->
    public_key_hash list ->
    unit tzresult Lwt.t
end

module Accuser : sig
  val run :
    #Protocol_client_context.full ->
    chain:Chain_services.chain ->
    preserved_levels:int ->
    unit tzresult Lwt.t
end
src/proto_alpha/lib_delegate/client_daemon.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Endorser.
  Parameter run : forall {_ a b c i o p q variant : Type}, (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
    variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (_ * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (_ * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * _)))))))))))))))))))))))))
    * _) ->
    Tezos_shell_services.Chain_services.chain ->
      Z ->
        (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit).
End Endorser.

Module Baker.
  Parameter run : forall {_ a b c i o p q variant : Type}, (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
    variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (_ * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (_ * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * _)))))))))))))))))))))))))
    * _) ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
      (option Z.t) ->
        (option Z.t) ->
          (option Z) ->
            Tezos_shell_services.Chain_services.chain ->
              string ->
                (list
                  Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
                  -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
End Baker.

Module Accuser.
  Parameter run : forall {_ a b c i o p q variant : Type}, (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
    variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (_ * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (_ * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((float -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * _)))))))))))))))))))))))))
    * _) ->
    Tezos_shell_services.Chain_services.chain ->
      Z -> Lwt.t (Tezos_base__TzPervasives.tzresult unit).
End Accuser.
src/proto_alpha/lib_delegate/delegate_commands.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_proto_args
open Client_baking_lib

let group =
  {Clic.name = "delegate"; title = "Commands related to delegate operations."}

let directory_parameter =
  Clic.parameter (fun _ p ->
      if not (Sys.file_exists p && Sys.is_directory p) then
        failwith "Directory doesn't exist: '%s'" p
      else return p)

let mempool_arg =
  Clic.arg
    ~long:"mempool"
    ~placeholder:"file"
    ~doc:
      "When used the client will read the mempool in the provided file \
       instead of querying the node through an RPC (useful for debugging \
       only)."
    string_parameter

let context_path_arg =
  Clic.arg
    ~long:"context"
    ~placeholder:"path"
    ~doc:
      "When use the client will read in the local context at the provided \
       path in order to build the block, instead of relying on the 'preapply' \
       RPC."
    string_parameter

let pidfile_arg =
  Clic.arg
    ~doc:"write process id in file"
    ~short:'P'
    ~long:"pidfile"
    ~placeholder:"filename"
    (Clic.parameter (fun _ s -> return s))

let may_lock_pidfile = function
  | None ->
      return_unit
  | Some pidfile ->
      trace (failure "Failed to create the pidfile: %s" pidfile)
      @@ Lwt_lock_file.create ~unlink_on_exit:true pidfile

let block_param t =
  Clic.param
    ~name:"block"
    ~desc:"commitment blocks whose nonce should be revealed"
    (Clic.parameter (fun _ str -> Lwt.return (Block_hash.of_b58check str)))
    t

let delegate_commands () =
  let open Clic in
  [ command
      ~group
      ~desc:"Forge and inject block using the delegate rights."
      (args8
         max_priority_arg
         minimal_fees_arg
         minimal_nanotez_per_gas_unit_arg
         minimal_nanotez_per_byte_arg
         force_switch
         minimal_timestamp_switch
         mempool_arg
         context_path_arg)
      ( prefixes ["bake"; "for"]
      @@ Client_keys.Public_key_hash.source_param
           ~name:"baker"
           ~desc:"name of the delegate owning the baking right"
      @@ stop )
      (fun ( max_priority,
             minimal_fees,
             minimal_nanotez_per_gas_unit,
             minimal_nanotez_per_byte,
             force,
             minimal_timestamp,
             mempool,
             context_path )
           delegate
           cctxt ->
        bake_block
          cctxt
          ~minimal_fees
          ~minimal_nanotez_per_gas_unit
          ~minimal_nanotez_per_byte
          ~force
          ?max_priority
          ~minimal_timestamp
          ?mempool
          ?context_path
          ~chain:cctxt#chain
          ~head:cctxt#block
          delegate);
    command
      ~group
      ~desc:"Forge and inject a seed-nonce revelation operation."
      no_options
      (prefixes ["reveal"; "nonce"; "for"] @@ seq_of_param block_param)
      (fun () block_hashes cctxt ->
        reveal_block_nonces
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          block_hashes);
    command
      ~group
      ~desc:
        "Forge and inject all the possible seed-nonce revelation operations."
      no_options
      (prefixes ["reveal"; "nonces"] @@ stop)
      (fun () cctxt ->
        reveal_nonces ~chain:cctxt#chain ~block:cctxt#block cctxt ());
    command
      ~group
      ~desc:"Forge and inject an endorsement operation."
      no_options
      ( prefixes ["endorse"; "for"]
      @@ Client_keys.Public_key_hash.source_param
           ~name:"baker"
           ~desc:"name of the delegate owning the endorsement right"
      @@ stop )
      (fun () delegate cctxt ->
        endorse_block cctxt ~chain:cctxt#chain delegate);
    command
      ~group
      ~desc:
        "Clear the nonces file by removing the nonces which blocks cannot be \
         found on the chain."
      no_options
      (prefixes ["filter"; "orphan"; "nonces"] @@ stop)
      (fun () (cctxt : #Protocol_client_context.full) ->
        cctxt#with_lock (fun () ->
            let chain = cctxt#chain in
            Client_baking_files.resolve_location cctxt ~chain `Nonce
            >>=? fun nonces_location ->
            let open Client_baking_nonces in
            (* Filtering orphan nonces *)
            load cctxt nonces_location
            >>=? fun nonces ->
            Block_hash.Map.fold
              (fun block nonce acc ->
                acc
                >>= fun acc ->
                Shell_services.Blocks.Header.shell_header
                  cctxt
                  ~chain
                  ~block:(`Hash (block, 0))
                  ()
                >>= function
                | Ok _ ->
                    Lwt.return acc
                | Error _ ->
                    Lwt.return (Block_hash.Map.add block nonce acc))
              nonces
              (Lwt.return empty)
            >>= fun orphans ->
            if Block_hash.Map.cardinal orphans = 0 then
              cctxt#message "No orphan nonces found." >>= fun () -> return_unit
            else
              (* "Backup-ing" orphan nonces *)
              let orphan_nonces_file = "orphan_nonce" in
              cctxt#load orphan_nonces_file ~default:empty encoding
              >>=? fun orphan_nonces ->
              let orphan_nonces = add_all orphan_nonces orphans in
              cctxt#write orphan_nonces_file orphan_nonces encoding
              >>=? fun () ->
              (* Don't forget the 's'. *)
              let orphan_nonces_file = orphan_nonces_file ^ "s" in
              cctxt#message
                "Successfully filtered %d orphan nonces and moved them to \
                 '$TEZOS_CLIENT/%s'."
                (Block_hash.Map.cardinal orphans)
                orphan_nonces_file
              >>= fun () ->
              let filtered_nonces =
                Client_baking_nonces.remove_all nonces orphans
              in
              save cctxt nonces_location filtered_nonces
              >>=? fun () -> return_unit));
    command
      ~group
      ~desc:"List orphan nonces."
      no_options
      (prefixes ["list"; "orphan"; "nonces"] @@ stop)
      (fun () (cctxt : #Protocol_client_context.full) ->
        cctxt#with_lock (fun () ->
            let open Client_baking_nonces in
            let orphan_nonces_file = "orphan_nonce" in
            cctxt#load orphan_nonces_file ~default:empty encoding
            >>=? fun orphan_nonces ->
            let block_hashes =
              List.map fst (Block_hash.Map.bindings orphan_nonces)
            in
            cctxt#message
              "@[<v 2>Found %d orphan nonces associated to the potentially \
               unknown following blocks:@ %a@]"
              (Block_hash.Map.cardinal orphan_nonces)
              (Format.pp_print_list ~pp_sep:Format.pp_print_cut Block_hash.pp)
              block_hashes
            >>= fun () -> return_unit)) ]

let baker_commands () =
  let open Clic in
  let group =
    {
      Clic.name = "delegate.baker";
      title = "Commands related to the baker daemon.";
    }
  in
  [ command
      ~group
      ~desc:"Launch the baker daemon."
      (args5
         pidfile_arg
         max_priority_arg
         minimal_fees_arg
         minimal_nanotez_per_gas_unit_arg
         minimal_nanotez_per_byte_arg)
      ( prefixes ["run"; "with"; "local"; "node"]
      @@ param
           ~name:"context_path"
           ~desc:"Path to the node data directory (e.g. $HOME/.tezos-node)"
           directory_parameter
      @@ seq_of_param Client_keys.Public_key_hash.alias_param )
      (fun ( pidfile,
             max_priority,
             minimal_fees,
             minimal_nanotez_per_gas_unit,
             minimal_nanotez_per_byte )
           node_path
           delegates
           cctxt ->
        may_lock_pidfile pidfile
        >>=? fun () ->
        Tezos_signer_backends.Encrypted.decrypt_list
          cctxt
          (List.map fst delegates)
        >>=? fun () ->
        Client_daemon.Baker.run
          cctxt
          ~chain:cctxt#chain
          ~minimal_fees
          ~minimal_nanotez_per_gas_unit
          ~minimal_nanotez_per_byte
          ?max_priority
          ~context_path:(Filename.concat node_path "context")
          (List.map snd delegates)) ]

let endorser_commands () =
  let open Clic in
  let group =
    {
      Clic.name = "delegate.endorser";
      title = "Commands related to endorser daemon.";
    }
  in
  [ command
      ~group
      ~desc:"Launch the endorser daemon"
      (args2 pidfile_arg endorsement_delay_arg)
      (prefixes ["run"] @@ seq_of_param Client_keys.Public_key_hash.alias_param)
      (fun (pidfile, endorsement_delay) delegates cctxt ->
        may_lock_pidfile pidfile
        >>=? fun () ->
        Tezos_signer_backends.Encrypted.decrypt_list
          cctxt
          (List.map fst delegates)
        >>=? fun () ->
        let delegates = List.map snd delegates in
        let delegates_no_duplicates =
          Signature.Public_key_hash.Set.(delegates |> of_list |> elements)
        in
        ( if List.length delegates <> List.length delegates_no_duplicates then
          cctxt#message
            "Warning: the list of public key hash aliases contains duplicate \
             hashes, which are ignored"
        else Lwt.return () )
        >>= fun () ->
        Client_daemon.Endorser.run
          cctxt
          ~chain:cctxt#chain
          ~delay:endorsement_delay
          delegates_no_duplicates) ]

let accuser_commands () =
  let open Clic in
  let group =
    {
      Clic.name = "delegate.accuser";
      title = "Commands related to the accuser daemon.";
    }
  in
  [ command
      ~group
      ~desc:"Launch the accuser daemon"
      (args2 pidfile_arg preserved_levels_arg)
      (prefixes ["run"] @@ stop)
      (fun (pidfile, preserved_levels) cctxt ->
        may_lock_pidfile pidfile
        >>=? fun () ->
        Client_daemon.Accuser.run ~chain:cctxt#chain ~preserved_levels cctxt)
  ]
src/proto_alpha/lib_delegate/delegate_commands.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_client_alpha.Client_proto_args.

Import Tezos_baking_alpha.Client_baking_lib.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "delegate" % string;
    Clic.title := "Commands related to delegate operations." % string |}.

Definition directory_parameter
  : Tezos_base__TzPervasives.Clic.parameter string
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun p =>
          if negb (andb (Stdlib.Sys.file_exists p) (Stdlib.Sys.is_directory p))
            then
            Tezos_base__TzPervasives.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Directory doesn't exist: '" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal "'" % char
                      CamlinternalFormatBasics.End_of_format)))
                "Directory doesn't exist: '%s'" % string) p
          else
            Tezos_base__TzPervasives._return p
      end).

Definition mempool_arg
  : Tezos_base__TzPervasives.Clic.arg (option string)
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.arg
    "When used the client will read the mempool in the provided file instead of querying the node through an RPC (useful for debugging only)."
      % string None "mempool" % string "file" % string
    Tezos_client_alpha.Client_proto_args.string_parameter.

Definition context_path_arg
  : Tezos_base__TzPervasives.Clic.arg (option string)
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.arg
    "When use the client will read in the local context at the provided path in order to build the block, instead of relying on the 'preapply' RPC."
      % string None "context" % string "path" % string
    Tezos_client_alpha.Client_proto_args.string_parameter.

Definition pidfile_arg
  : Tezos_base__TzPervasives.Clic.arg (option string)
    Tezos_client_alpha.Protocol_client_context.full :=
  Tezos_base__TzPervasives.Clic.arg "write process id in file" % string
    (Some "P" % char) "pidfile" % string "filename" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ => fun s => Tezos_base__TzPervasives._return s
        end)).

Definition may_lock_pidfile (function_parameter : option string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | None => Tezos_base__TzPervasives.return_unit
  | Some pidfile =>
    apply
      (Tezos_base__TzPervasives.trace
        (Tezos_base__TzPervasives.failure
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Failed to create the pidfile: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Failed to create the pidfile: %s" % string) pidfile))
      (Tezos_stdlib_unix.Lwt_lock_file.create None (Some true) pidfile)
  end.

Definition block_param {A B : Type}
  (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.Block_hash.t -> A) B :=
  Tezos_base__TzPervasives.Clic.param "block" % string
    "commitment blocks whose nonce should be revealed" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun str =>
            Lwt._return (Tezos_base__TzPervasives.Block_hash.of_b58check str)
        end)) t.

Definition delegate_commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  match function_parameter with
  | tt =>
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Forge and inject block using the delegate rights." % string
        (Tezos_base__TzPervasives.Clic.args8
          Tezos_client_alpha.Client_proto_args.max_priority_arg
          Tezos_client_alpha.Client_proto_args.minimal_fees_arg
          Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
          Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg
          Tezos_client_alpha.Client_proto_args.force_switch
          Tezos_client_alpha.Client_proto_args.minimal_timestamp_switch
          mempool_arg context_path_arg)
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "bake" % string (cons "for" % string [])))
          (apply
            (Tezos_client_base.Client_keys.Public_key_hash.source_param
              (Some "baker" % string)
              (Some "name of the delegate owning the baking right" % string))
            Tezos_base__TzPervasives.Clic.stop))
        (fun function_parameter =>
          match function_parameter with
          |
            (max_priority, minimal_fees, minimal_nanotez_per_gas_unit,
              minimal_nanotez_per_byte, force, minimal_timestamp, mempool,
              context_path) =>
            fun delegate =>
              fun cctxt =>
                Tezos_baking_alpha.Client_baking_lib.bake_block cctxt
                  (Some minimal_fees) (Some minimal_nanotez_per_gas_unit)
                  (Some minimal_nanotez_per_byte) (Some force) max_priority
                  (Some minimal_timestamp) mempool context_path None send send
                  delegate
          end))
      (cons
        (Tezos_base__TzPervasives.Clic.command (Some group)
          "Forge and inject a seed-nonce revelation operation." % string
          Tezos_base__TzPervasives.Clic.no_options
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "reveal" % string
                (cons "nonce" % string (cons "for" % string []))))
            (Tezos_base__TzPervasives.Clic.seq_of_param block_param))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              fun block_hashes =>
                fun cctxt =>
                  Tezos_baking_alpha.Client_baking_lib.reveal_block_nonces cctxt
                    send send block_hashes
            end))
        (cons
          (Tezos_base__TzPervasives.Clic.command (Some group)
            "Forge and inject all the possible seed-nonce revelation operations."
              % string Tezos_base__TzPervasives.Clic.no_options
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "reveal" % string (cons "nonces" % string [])))
              Tezos_base__TzPervasives.Clic.stop)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                fun cctxt =>
                  Tezos_baking_alpha.Client_baking_lib.reveal_nonces cctxt send
                    send tt
              end))
          (cons
            (Tezos_base__TzPervasives.Clic.command (Some group)
              "Forge and inject an endorsement operation." % string
              Tezos_base__TzPervasives.Clic.no_options
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "endorse" % string (cons "for" % string [])))
                (apply
                  (Tezos_client_base.Client_keys.Public_key_hash.source_param
                    (Some "baker" % string)
                    (Some
                      "name of the delegate owning the endorsement right" %
                        string)) Tezos_base__TzPervasives.Clic.stop))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  fun delegate =>
                    fun cctxt =>
                      Tezos_baking_alpha.Client_baking_lib.endorse_block cctxt
                        send delegate
                end))
            (cons
              (Tezos_base__TzPervasives.Clic.command (Some group)
                "Clear the nonces file by removing the nonces which blocks cannot be found on the chain."
                  % string Tezos_base__TzPervasives.Clic.no_options
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "filter" % string
                      (cons "orphan" % string (cons "nonces" % string []))))
                  Tezos_base__TzPervasives.Clic.stop)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    fun cctxt =>
                      send
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            let chain := send in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Tezos_baking_alpha.Client_baking_files.resolve_location
                                cctxt chain variant)
                              (fun nonces_location =>
                                Tezos_base__TzPervasives.op_gt_gt_eq_question
                                  (Tezos_baking_alpha.Client_baking_nonces.load
                                    cctxt nonces_location)
                                  (fun nonces =>
                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                      (Tezos_base__TzPervasives.Block_hash.Map.fold
                                        (fun block =>
                                          fun nonce =>
                                            fun acc =>
                                              Tezos_base__TzPervasives.op_gt_gt_eq
                                                acc
                                                (fun acc =>
                                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                                    (Tezos_shell_services.Shell_services.Blocks.Header.shell_header
                                                      cctxt (Some chain)
                                                      (Some variant) tt)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | inl _ => Lwt._return acc
                                                      | inr _ =>
                                                        Lwt._return
                                                          (Tezos_base__TzPervasives.Block_hash.Map.add
                                                            block nonce acc)
                                                      end))) nonces
                                        (Lwt._return
                                          Tezos_baking_alpha.Client_baking_nonces.empty))
                                      (fun orphans =>
                                        if
                                          equiv_decb
                                            (Tezos_base__TzPervasives.Block_hash.Map.cardinal
                                              orphans) 0 then
                                          Tezos_base__TzPervasives.op_gt_gt_eq
                                            (send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "No orphan nonces found." %
                                                    string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "No orphan nonces found." %
                                                  string))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_base__TzPervasives.return_unit
                                              end)
                                        else
                                          let orphan_nonces_file :=
                                            "orphan_nonce" % string in
                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                            (send orphan_nonces_file
                                              Tezos_baking_alpha.Client_baking_nonces.empty
                                              Tezos_baking_alpha.Client_baking_nonces.encoding)
                                            (fun orphan_nonces =>
                                              let orphan_nonces :=
                                                Tezos_baking_alpha.Client_baking_nonces.add_all
                                                  orphan_nonces orphans in
                                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                (send orphan_nonces_file
                                                  orphan_nonces
                                                  Tezos_baking_alpha.Client_baking_nonces.encoding)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    let orphan_nonces_file :=
                                                      String.append
                                                        orphan_nonces_file
                                                        "s" % string in
                                                    Tezos_base__TzPervasives.op_gt_gt_eq
                                                      (send
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Successfully filtered "
                                                              % string
                                                            (CamlinternalFormatBasics.Int
                                                              CamlinternalFormatBasics.Int_d
                                                              CamlinternalFormatBasics.No_padding
                                                              CamlinternalFormatBasics.No_precision
                                                              (CamlinternalFormatBasics.String_literal
                                                                " orphan nonces and moved them to '$TEZOS_CLIENT/"
                                                                  % string
                                                                (CamlinternalFormatBasics.String
                                                                  CamlinternalFormatBasics.No_padding
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "'." %
                                                                      string
                                                                    CamlinternalFormatBasics.End_of_format)))))
                                                          "Successfully filtered %d orphan nonces and moved them to '$TEZOS_CLIENT/%s'."
                                                            % string)
                                                        (Tezos_base__TzPervasives.Block_hash.Map.cardinal
                                                          orphans)
                                                        orphan_nonces_file)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          let filtered_nonces :=
                                                            Tezos_baking_alpha.Client_baking_nonces.remove_all
                                                              nonces orphans in
                                                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                                                            (Tezos_baking_alpha.Client_baking_nonces.save
                                                              cctxt
                                                              nonces_location
                                                              filtered_nonces)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_base__TzPervasives.return_unit
                                                              end)
                                                        end)
                                                  end)))))
                          end)
                  end))
              (cons
                (Tezos_base__TzPervasives.Clic.command (Some group)
                  "List orphan nonces." % string
                  Tezos_base__TzPervasives.Clic.no_options
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "list" % string
                        (cons "orphan" % string (cons "nonces" % string []))))
                    Tezos_base__TzPervasives.Clic.stop)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      fun cctxt =>
                        send
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              let orphan_nonces_file := "orphan_nonce" % string
                                in
                              Tezos_base__TzPervasives.op_gt_gt_eq_question
                                (send orphan_nonces_file
                                  Tezos_baking_alpha.Client_baking_nonces.empty
                                  Tezos_baking_alpha.Client_baking_nonces.encoding)
                                (fun orphan_nonces =>
                                  let block_hashes :=
                                    Tezos_base__TzPervasives.List.map fst
                                      (Tezos_base__TzPervasives.Block_hash.Map.bindings
                                        orphan_nonces) in
                                  Tezos_base__TzPervasives.op_gt_gt_eq
                                    (send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.Formatting_gen
                                          (CamlinternalFormatBasics.Open_box
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "<v 2>" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "<v 2>" % string))
                                          (CamlinternalFormatBasics.String_literal
                                            "Found " % string
                                            (CamlinternalFormatBasics.Int
                                              CamlinternalFormatBasics.Int_d
                                              CamlinternalFormatBasics.No_padding
                                              CamlinternalFormatBasics.No_precision
                                              (CamlinternalFormatBasics.String_literal
                                                " orphan nonces associated to the potentially unknown following blocks:"
                                                  % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@ " % string 1 0)
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Close_box
                                                      CamlinternalFormatBasics.End_of_format)))))))
                                        "@[<v 2>Found %d orphan nonces associated to the potentially unknown following blocks:@ %a@]"
                                          % string)
                                      (Tezos_base__TzPervasives.Block_hash.Map.cardinal
                                        orphan_nonces)
                                      (Stdlib.Format.pp_print_list
                                        (Some Stdlib.Format.pp_print_cut)
                                        Tezos_base__TzPervasives.Block_hash.pp)
                                      block_hashes)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_base__TzPervasives.return_unit
                                      end))
                            end)
                    end)) [])))))
  end.

Definition baker_commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  match function_parameter with
  | tt =>
    let group :=
      {| Clic.name := "delegate.baker" % string;
        Clic.title := "Commands related to the baker daemon." % string |} in
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Launch the baker daemon." % string
        (Tezos_base__TzPervasives.Clic.args5 pidfile_arg
          Tezos_client_alpha.Client_proto_args.max_priority_arg
          Tezos_client_alpha.Client_proto_args.minimal_fees_arg
          Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_gas_unit_arg
          Tezos_client_alpha.Client_proto_args.minimal_nanotez_per_byte_arg)
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "run" % string
              (cons "with" % string
                (cons "local" % string (cons "node" % string [])))))
          (apply
            (Tezos_base__TzPervasives.Clic.param "context_path" % string
              "Path to the node data directory (e.g. $HOME/.tezos-node)" %
                string directory_parameter)
            (Tezos_base__TzPervasives.Clic.seq_of_param
              (let arg :=
                Tezos_client_base.Client_keys.Public_key_hash.alias_param in
              fun eta => arg None None eta))))
        (fun function_parameter =>
          match function_parameter with
          |
            (pidfile, max_priority, minimal_fees, minimal_nanotez_per_gas_unit,
              minimal_nanotez_per_byte) =>
            fun node_path =>
              fun delegates =>
                fun cctxt =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (may_lock_pidfile pidfile)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_signer_backends.Encrypted.decrypt_list cctxt
                            (Tezos_base__TzPervasives.List.map fst delegates))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_baking_alpha.Client_daemon.Baker.run cctxt
                                (Some minimal_fees)
                                (Some minimal_nanotez_per_gas_unit)
                                (Some minimal_nanotez_per_byte) max_priority
                                send
                                (Stdlib.Filename.concat node_path
                                  "context" % string)
                                (Tezos_base__TzPervasives.List.map snd delegates)
                            end)
                      end)
          end)) []
  end.

Definition endorser_commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  match function_parameter with
  | tt =>
    let group :=
      {| Clic.name := "delegate.endorser" % string;
        Clic.title := "Commands related to endorser daemon." % string |} in
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Launch the endorser daemon" % string
        (Tezos_base__TzPervasives.Clic.args2 pidfile_arg
          Tezos_client_alpha.Client_proto_args.endorsement_delay_arg)
        (apply (Tezos_base__TzPervasives.Clic.prefixes (cons "run" % string []))
          (Tezos_base__TzPervasives.Clic.seq_of_param
            (let arg :=
              Tezos_client_base.Client_keys.Public_key_hash.alias_param in
            fun eta => arg None None eta)))
        (fun function_parameter =>
          match function_parameter with
          | (pidfile, endorsement_delay) =>
            fun delegates =>
              fun cctxt =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (may_lock_pidfile pidfile)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_signer_backends.Encrypted.decrypt_list cctxt
                          (Tezos_base__TzPervasives.List.map fst delegates))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            let delegates :=
                              Tezos_base__TzPervasives.List.map snd delegates in
                            let delegates_no_duplicates :=
                              OCaml.Stdlib.reverse_apply
                                (OCaml.Stdlib.reverse_apply delegates
                                  Tezos_base__TzPervasives.Signature.Public_key_hash.Set.of_list)
                                Tezos_base__TzPervasives.Signature.Public_key_hash.Set.elements
                              in
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (if
                                nequiv_decb
                                  (Tezos_base__TzPervasives.List.length
                                    delegates)
                                  (Tezos_base__TzPervasives.List.length
                                    delegates_no_duplicates) then
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Warning: the list of public key hash aliases contains duplicate hashes, which are ignored"
                                        % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "Warning: the list of public key hash aliases contains duplicate hashes, which are ignored"
                                      % string)
                              else
                                Lwt._return tt)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_baking_alpha.Client_daemon.Endorser.run
                                    cctxt send endorsement_delay
                                    delegates_no_duplicates
                                end)
                          end)
                    end)
          end)) []
  end.

Definition accuser_commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  match function_parameter with
  | tt =>
    let group :=
      {| Clic.name := "delegate.accuser" % string;
        Clic.title := "Commands related to the accuser daemon." % string |} in
    cons
      (Tezos_base__TzPervasives.Clic.command (Some group)
        "Launch the accuser daemon" % string
        (Tezos_base__TzPervasives.Clic.args2 pidfile_arg
          Tezos_client_alpha.Client_proto_args.preserved_levels_arg)
        (apply (Tezos_base__TzPervasives.Clic.prefixes (cons "run" % string []))
          Tezos_base__TzPervasives.Clic.stop)
        (fun function_parameter =>
          match function_parameter with
          | (pidfile, preserved_levels) =>
            fun cctxt =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (may_lock_pidfile pidfile)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_baking_alpha.Client_daemon.Accuser.run cctxt send
                      preserved_levels
                  end)
          end)) []
  end.
src/proto_alpha/lib_delegate/delegate_commands.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val delegate_commands : unit -> Protocol_client_context.full Clic.command list

val baker_commands : unit -> Protocol_client_context.full Clic.command list

val endorser_commands : unit -> Protocol_client_context.full Clic.command list

val accuser_commands : unit -> Protocol_client_context.full Clic.command list
src/proto_alpha/lib_delegate/delegate_commands.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter delegate_commands :
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full).

Parameter baker_commands :
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full).

Parameter endorser_commands :
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full).

Parameter accuser_commands :
unit ->
  list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full).
src/proto_alpha/lib_delegate/delegate_commands_registration.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Client_commands.register Protocol.hash
  @@ fun _network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Delegate_commands.delegate_commands ()
src/proto_alpha/lib_delegate/delegate_commands_registration.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/proto_alpha/lib_delegate/logging.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

let timestamp_tag =
  Tag.def ~doc:"Timestamp when event occurred" "timestamp" Time.System.pp_hum

let valid_ops = Tag.def ~doc:"Valid Operations" "valid_ops" Format.pp_print_int

let op_count =
  Tag.def ~doc:"Number of operations" "op_count" Format.pp_print_int

let refused_ops =
  Tag.def ~doc:"Refused Operations" "refused_ops" Format.pp_print_int

let bake_priority_tag =
  Tag.def ~doc:"Baking priority" "bake_priority" Format.pp_print_int

let fitness_tag = Tag.def ~doc:"Fitness" "fitness" Fitness.pp

let current_slots_tag =
  Tag.def
    ~doc:"Number of baking slots that can be baked at this time"
    "current_slots"
    Format.pp_print_int

let future_slots_tag =
  Tag.def
    ~doc:
      "Number of baking slots in the foreseeable future but not yet bakeable"
    "future_slots"
    Format.pp_print_int

let timespan_tag = Tag.def ~doc:"Timespan in seconds" "timespan" Ptime.Span.pp

let filename_tag = Tag.def ~doc:"Filename" "filename" Format.pp_print_text

let signed_header_tag =
  Tag.def ~doc:"Signed header" "signed_header" (fun fmt x ->
      Hex.pp fmt (Hex.of_bytes x))

let signed_operation_tag =
  Tag.def ~doc:"Signed operation" "signed_operation" (fun fmt x ->
      Hex.pp fmt (Hex.of_bytes x))

let operations_tag =
  Tag.def
    ~doc:"Block Operations"
    "operations"
    (Format.pp_print_list
       ~pp_sep:(fun ppf () -> Format.fprintf ppf "+")
       (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations)))

let raw_operations_tag =
  Tag.def ~doc:"Raw operations" "raw_operations" (fun fmt raw_ops ->
      let pp_op fmt op =
        let json = Data_encoding.Json.construct Operation.raw_encoding op in
        Format.fprintf fmt "%a" Data_encoding.Json.pp json
      in
      Format.fprintf
        fmt
        "@[<v>%a@]"
        (Format.pp_print_list ~pp_sep:Format.pp_print_cut pp_op)
        raw_ops)

let bake_op_count_tag =
  Tag.def ~doc:"Bake Operation Count" "operation_count" Format.pp_print_int

let endorsement_slot_tag =
  Tag.def ~doc:"Endorsement Slot" "endorsement_slot" Format.pp_print_int

let endorsement_slots_tag =
  Tag.def
    ~doc:"Endorsement Slots"
    "endorsement_slots"
    Format.(fun ppf v -> pp_print_int ppf (List.length v))

let denounced_endorsements_slots_tag =
  Tag.def
    ~doc:"Endorsement Slots"
    "denounced_endorsement_slots"
    Format.(pp_print_list pp_print_int)

let denouncement_source_tag =
  Tag.def ~doc:"Denounce Source" "source" Format.pp_print_text

let level_tag = Tag.def ~doc:"Level" "level" Raw_level.pp

let nonce_tag =
  Tag.def
    ~doc:"Nonce"
    "nonce"
    Data_encoding.Json.(
      fun ppf nonce -> pp ppf (construct Nonce.encoding nonce))

let chain_tag =
  Tag.def
    ~doc:"Chain selector"
    "chain"
    Format.(
      fun ppf chain ->
        pp_print_string ppf @@ Block_services.chain_to_string chain)

let block_tag =
  Tag.def
    ~doc:"Block selector"
    "block"
    Format.(
      fun ppf block -> pp_print_string ppf @@ Block_services.to_string block)

let worker_tag =
  Tag.def ~doc:"Worker in which event occurred" "worker" Format.pp_print_text

let block_header_tag =
  Tag.def ~doc:"Raw block header" "block_header" (fun ppf _ ->
      Format.fprintf ppf "[raw block header]")

let conflicting_endorsements_tag =
  Tag.def
    ~doc:"Two conflicting endorsements signed by the same key"
    "conflicting_endorsements"
    Format.(
      fun ppf (a, b) ->
        fprintf
          ppf
          "%a / %a"
          Operation_hash.pp
          (Operation.hash a)
          Operation_hash.pp
          (Operation.hash b))
src/proto_alpha/lib_delegate/logging.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition timestamp_tag
  : Tezos_base__TzPervasives.Tag.def Tezos_base__TzPervasives.Time.System.t :=
  Tezos_base__TzPervasives.Tag.def
    (Some "Timestamp when event occurred" % string) "timestamp" % string
    Tezos_base__TzPervasives.Time.System.pp_hum.

Definition valid_ops : Tezos_base__TzPervasives.Tag.def Z :=
  Tezos_base__TzPervasives.Tag.def (Some "Valid Operations" % string)
    "valid_ops" % string Stdlib.Format.pp_print_int.

Definition op_count : Tezos_base__TzPervasives.Tag.def Z :=
  Tezos_base__TzPervasives.Tag.def (Some "Number of operations" % string)
    "op_count" % string Stdlib.Format.pp_print_int.

Definition refused_ops : Tezos_base__TzPervasives.Tag.def Z :=
  Tezos_base__TzPervasives.Tag.def (Some "Refused Operations" % string)
    "refused_ops" % string Stdlib.Format.pp_print_int.

Definition bake_priority_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tezos_base__TzPervasives.Tag.def (Some "Baking priority" % string)
    "bake_priority" % string Stdlib.Format.pp_print_int.

Definition fitness_tag
  : Tezos_base__TzPervasives.Tag.def
    Tezos_protocol_alpha.Protocol.Alpha_context.Fitness.t :=
  Tezos_base__TzPervasives.Tag.def (Some "Fitness" % string) "fitness" % string
    Tezos_protocol_alpha.Protocol.Alpha_context.Fitness.pp.

Definition current_slots_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tezos_base__TzPervasives.Tag.def
    (Some "Number of baking slots that can be baked at this time" % string)
    "current_slots" % string Stdlib.Format.pp_print_int.

Definition future_slots_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tezos_base__TzPervasives.Tag.def
    (Some
      "Number of baking slots in the foreseeable future but not yet bakeable" %
        string) "future_slots" % string Stdlib.Format.pp_print_int.

Definition timespan_tag : Tezos_base__TzPervasives.Tag.def Ptime.span :=
  Tezos_base__TzPervasives.Tag.def (Some "Timespan in seconds" % string)
    "timespan" % string Ptime.Span.pp.

Definition filename_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tezos_base__TzPervasives.Tag.def (Some "Filename" % string)
    "filename" % string Stdlib.Format.pp_print_text.

Definition signed_header_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tezos_base__TzPervasives.Tag.def (Some "Signed header" % string)
    "signed_header" % string
    (fun fmt => fun x => Hex.pp fmt (Hex.of_bytes None x)).

Definition signed_operation_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tezos_base__TzPervasives.Tag.def (Some "Signed operation" % string)
    "signed_operation" % string
    (fun fmt => fun x => Hex.pp fmt (Hex.of_bytes None x)).

Definition operations_tag {A : Type}
  : Tezos_base__TzPervasives.Tag.def (list (list A)) :=
  Tezos_base__TzPervasives.Tag.def (Some "Block Operations" % string)
    "operations" % string
    (Stdlib.Format.pp_print_list
      (Some
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Stdlib.Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Char_literal "+" % char
                    CamlinternalFormatBasics.End_of_format) "+" % string)
            end))
      (fun ppf =>
        fun operations =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                CamlinternalFormatBasics.End_of_format) "%d" % string)
            (Tezos_base__TzPervasives.List.length operations))).

Definition raw_operations_tag
  : Tezos_base__TzPervasives.Tag.def
    (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw) :=
  Tezos_base__TzPervasives.Tag.def (Some "Raw operations" % string)
    "raw_operations" % string
    (fun fmt =>
      fun raw_ops =>
        let pp_op
          (fmt : Stdlib.Format.formatter) (op :
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw) : unit :=
          let json :=
            Tezos_base__TzPervasives.Data_encoding.Json.construct
              Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw_encoding
              op in
          Stdlib.Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Tezos_base__TzPervasives.Data_encoding.Json.pp json in
        Stdlib.Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v>" % string
                    CamlinternalFormatBasics.End_of_format) "<v>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format))) "@[<v>%a@]" % string)
          (Stdlib.Format.pp_print_list (Some Stdlib.Format.pp_print_cut) pp_op)
          raw_ops).

Definition bake_op_count_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tezos_base__TzPervasives.Tag.def (Some "Bake Operation Count" % string)
    "operation_count" % string Stdlib.Format.pp_print_int.

Definition endorsement_slot_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tezos_base__TzPervasives.Tag.def (Some "Endorsement Slot" % string)
    "endorsement_slot" % string Stdlib.Format.pp_print_int.

Definition endorsement_slots_tag {A : Type}
  : Tezos_base__TzPervasives.Tag.def (list A) :=
  Tezos_base__TzPervasives.Tag.def (Some "Endorsement Slots" % string)
    "endorsement_slots" % string
    (fun ppf =>
      fun v =>
        Stdlib.Format.pp_print_int ppf (Tezos_base__TzPervasives.List.length v)).

Definition denounced_endorsements_slots_tag
  : Tezos_base__TzPervasives.Tag.def (list Z) :=
  Tezos_base__TzPervasives.Tag.def (Some "Endorsement Slots" % string)
    "denounced_endorsement_slots" % string
    (Stdlib.Format.pp_print_list None Stdlib.Format.pp_print_int).

Definition denouncement_source_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tezos_base__TzPervasives.Tag.def (Some "Denounce Source" % string)
    "source" % string Stdlib.Format.pp_print_text.

Definition level_tag
  : Tezos_base__TzPervasives.Tag.def
    Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t :=
  Tezos_base__TzPervasives.Tag.def (Some "Level" % string) "level" % string
    Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.pp.

Definition nonce_tag
  : Tezos_base__TzPervasives.Tag.def
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  Tezos_base__TzPervasives.Tag.def (Some "Nonce" % string) "nonce" % string
    (fun ppf =>
      fun nonce =>
        Tezos_base__TzPervasives.Data_encoding.Json.pp ppf
          (Tezos_base__TzPervasives.Data_encoding.Json.construct
            Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.encoding nonce)).

Definition chain_tag
  : Tezos_base__TzPervasives.Tag.def Tezos_shell_services.Block_services.chain :=
  Tezos_base__TzPervasives.Tag.def (Some "Chain selector" % string)
    "chain" % string
    (fun ppf =>
      fun chain =>
        apply (Stdlib.Format.pp_print_string ppf)
          (Tezos_shell_services.Block_services.chain_to_string chain)).

Definition block_tag
  : Tezos_base__TzPervasives.Tag.def Tezos_shell_services.Block_services.block :=
  Tezos_base__TzPervasives.Tag.def (Some "Block selector" % string)
    "block" % string
    (fun ppf =>
      fun block =>
        apply (Stdlib.Format.pp_print_string ppf)
          (Tezos_shell_services.Block_services.to_string block)).

Definition worker_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tezos_base__TzPervasives.Tag.def
    (Some "Worker in which event occurred" % string) "worker" % string
    Stdlib.Format.pp_print_text.

Definition block_header_tag {A : Type} : Tezos_base__TzPervasives.Tag.def A :=
  Tezos_base__TzPervasives.Tag.def (Some "Raw block header" % string)
    "block_header" % string
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "[raw block header]" % string
                CamlinternalFormatBasics.End_of_format)
              "[raw block header]" % string)
        end).

Definition conflicting_endorsements_tag {A B : Type}
  : Tezos_base__TzPervasives.Tag.def
    ((Tezos_raw_protocol_alpha__Alpha_context.operation A) *
      (Tezos_raw_protocol_alpha__Alpha_context.operation B)) :=
  Tezos_base__TzPervasives.Tag.def
    (Some "Two conflicting endorsements signed by the same key" % string)
    "conflicting_endorsements" % string
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | (a, b) =>
          Stdlib.Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " / " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))) "%a / %a" % string)
            Tezos_base__TzPervasives.Operation_hash.pp
            (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash a)
            Tezos_base__TzPervasives.Operation_hash.pp
            (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash b)
        end).
src/proto_alpha/lib_delegate/logging.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

val timestamp_tag : Time.System.t Tag.def

val valid_ops : int Tag.def

val op_count : int Tag.def

val refused_ops : int Tag.def

val bake_priority_tag : int Tag.def

val fitness_tag : Fitness.t Tag.def

val current_slots_tag : int Tag.def

val future_slots_tag : int Tag.def

val timespan_tag : Time.System.Span.t Tag.def

val filename_tag : string Tag.def

val signed_header_tag : Bytes.t Tag.def

val signed_operation_tag : Bytes.t Tag.def

val operations_tag : Tezos_base.Operation.t list list Tag.def

val raw_operations_tag : Operation.raw list Tag.def

val bake_op_count_tag : int Tag.def

val endorsement_slot_tag : int Tag.def

val endorsement_slots_tag : int list Tag.def

val denounced_endorsements_slots_tag : int list Tag.def

val denouncement_source_tag : string Tag.def

val level_tag : Raw_level.t Tag.def

val nonce_tag : Nonce.t Tag.def

val chain_tag : Block_services.chain Tag.def

val block_tag : Block_services.block Tag.def

val worker_tag : string Tag.def

val block_header_tag : Block_header.t Tag.def

val conflicting_endorsements_tag :
  (Kind.endorsement operation * Kind.endorsement operation) Tag.def
src/proto_alpha/lib_delegate/logging.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter timestamp_tag :
Tezos_base__TzPervasives.Tag.def Tezos_base__TzPervasives.Time.System.t.

Parameter valid_ops : Tezos_base__TzPervasives.Tag.def Z.

Parameter op_count : Tezos_base__TzPervasives.Tag.def Z.

Parameter refused_ops : Tezos_base__TzPervasives.Tag.def Z.

Parameter bake_priority_tag : Tezos_base__TzPervasives.Tag.def Z.

Parameter fitness_tag :
Tezos_base__TzPervasives.Tag.def
  Tezos_protocol_alpha.Protocol.Alpha_context.Fitness.t.

Parameter current_slots_tag : Tezos_base__TzPervasives.Tag.def Z.

Parameter future_slots_tag : Tezos_base__TzPervasives.Tag.def Z.

Parameter timespan_tag :
Tezos_base__TzPervasives.Tag.def Tezos_base__TzPervasives.Time.System.Span.t.

Parameter filename_tag : Tezos_base__TzPervasives.Tag.def string.

Parameter signed_header_tag : Tezos_base__TzPervasives.Tag.def Stdlib.Bytes.t.

Parameter signed_operation_tag :
Tezos_base__TzPervasives.Tag.def Stdlib.Bytes.t.

Parameter operations_tag :
Tezos_base__TzPervasives.Tag.def (list (list Tezos_base.Operation.t)).

Parameter raw_operations_tag :
Tezos_base__TzPervasives.Tag.def
  (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw).

Parameter bake_op_count_tag : Tezos_base__TzPervasives.Tag.def Z.

Parameter endorsement_slot_tag : Tezos_base__TzPervasives.Tag.def Z.

Parameter endorsement_slots_tag : Tezos_base__TzPervasives.Tag.def (list Z).

Parameter denounced_endorsements_slots_tag :
Tezos_base__TzPervasives.Tag.def (list Z).

Parameter denouncement_source_tag : Tezos_base__TzPervasives.Tag.def string.

Parameter level_tag :
Tezos_base__TzPervasives.Tag.def
  Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t.

Parameter nonce_tag :
Tezos_base__TzPervasives.Tag.def
  Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.

Parameter chain_tag :
Tezos_base__TzPervasives.Tag.def Tezos_shell_services.Block_services.chain.

Parameter block_tag :
Tezos_base__TzPervasives.Tag.def Tezos_shell_services.Block_services.block.

Parameter worker_tag : Tezos_base__TzPervasives.Tag.def string.

Parameter block_header_tag :
Tezos_base__TzPervasives.Tag.def
  Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t.

Parameter conflicting_endorsements_tag :
Tezos_base__TzPervasives.Tag.def
  ((Tezos_protocol_alpha.Protocol.Alpha_context.operation
    Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement) *
    (Tezos_protocol_alpha.Protocol.Alpha_context.operation
      Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)).
src/proto_alpha/lib_mempool/filter.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Development. <contact@tezcore.com>             *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
module Proto = Registerer.Registered

type nanotez = Z.t

let nanotez_enc =
  Data_encoding.def
    "nanotez"
    ~title:"Thousandths of tez"
    ~description:"One thousand nanotez make a tez"
    Data_encoding.z

type config = {
  minimal_fees : Tez.t;
  minimal_nanotez_per_gas_unit : nanotez;
  minimal_nanotez_per_byte : nanotez;
  allow_script_failure : bool;
}

let default_minimal_fees =
  match Tez.of_mutez 100L with None -> assert false | Some t -> t

let default_minimal_nanotez_per_gas_unit = Z.of_int 100

let default_minimal_nanotez_per_byte = Z.of_int 1000

let config_encoding : config Data_encoding.t =
  let open Data_encoding in
  conv
    (fun { minimal_fees;
           minimal_nanotez_per_gas_unit;
           minimal_nanotez_per_byte;
           allow_script_failure } ->
      ( minimal_fees,
        minimal_nanotez_per_gas_unit,
        minimal_nanotez_per_byte,
        allow_script_failure ))
    (fun ( minimal_fees,
           minimal_nanotez_per_gas_unit,
           minimal_nanotez_per_byte,
           allow_script_failure ) ->
      {
        minimal_fees;
        minimal_nanotez_per_gas_unit;
        minimal_nanotez_per_byte;
        allow_script_failure;
      })
    (obj4
       (dft "minimal_fees" Tez.encoding default_minimal_fees)
       (dft
          "minimal_nanotez_per_gas_unit"
          nanotez_enc
          default_minimal_nanotez_per_gas_unit)
       (dft
          "minimal_nanotez_per_byte"
          nanotez_enc
          default_minimal_nanotez_per_byte)
       (dft "allow_script_failure" bool true))

let default_config =
  {
    minimal_fees = default_minimal_fees;
    minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit;
    minimal_nanotez_per_byte = default_minimal_nanotez_per_byte;
    allow_script_failure = true;
  }

let get_manager_operation_gas_and_fee contents =
  let open Operation in
  let l = to_list (Contents_list contents) in
  List.fold_left
    (fun acc -> function
      | Contents (Manager_operation {fee; gas_limit; _}) -> (
        match acc with
        | Error _ as e ->
            e
        | Ok (total_fee, total_gas) -> (
          match Tez.(total_fee +? fee) with
          | Ok total_fee ->
              Ok (total_fee, Z.add total_gas gas_limit)
          | Error _ as e ->
              e ) ) | _ -> acc)
    (Ok (Tez.zero, Z.zero))
    l

let pre_filter_manager :
    type t. config -> t Kind.manager contents_list -> int -> bool =
 fun config op size ->
  match get_manager_operation_gas_and_fee op with
  | Error _ ->
      false
  | Ok (fee, gas) ->
      let fees_in_nanotez =
        Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
      in
      let minimal_fees_in_nanotez =
        Z.mul (Z.of_int64 (Tez.to_mutez config.minimal_fees)) (Z.of_int 1000)
      in
      let minimal_fees_for_gas_in_nanotez =
        Z.mul config.minimal_nanotez_per_gas_unit gas
      in
      let minimal_fees_for_size_in_nanotez =
        Z.mul config.minimal_nanotez_per_byte (Z.of_int size)
      in
      Z.compare
        fees_in_nanotez
        (Z.add
           minimal_fees_in_nanotez
           (Z.add
              minimal_fees_for_gas_in_nanotez
              minimal_fees_for_size_in_nanotez))
      >= 0

let pre_filter config
    (Operation_data {contents; _} as op : Operation.packed_protocol_data) =
  let bytes =
    Data_encoding.Binary.fixed_length_exn
      Tezos_base.Operation.shell_header_encoding
    + Data_encoding.Binary.length Operation.protocol_data_encoding op
  in
  match contents with
  | Single (Endorsement _) ->
      true
  | Single (Seed_nonce_revelation _) ->
      true
  | Single (Double_endorsement_evidence _) ->
      true
  | Single (Double_baking_evidence _) ->
      true
  | Single (Activate_account _) ->
      true
  | Single (Proposals _) ->
      true
  | Single (Ballot _) ->
      true
  | Single (Manager_operation _) as op ->
      pre_filter_manager config op bytes
  | Cons (Manager_operation _, _) as op ->
      pre_filter_manager config op bytes

open Apply_results

let rec post_filter_manager :
    type t.
    Alpha_context.t ->
    t Kind.manager contents_result_list ->
    config ->
    bool Lwt.t =
 fun ctxt op config ->
  match op with
  | Single_result (Manager_operation_result {operation_result; _}) -> (
    match operation_result with
    | Applied _ ->
        Lwt.return_true
    | Skipped _ | Failed _ | Backtracked _ ->
        Lwt.return config.allow_script_failure )
  | Cons_result (Manager_operation_result res, rest) -> (
      post_filter_manager
        ctxt
        (Single_result (Manager_operation_result res))
        config
      >>= function
      | false ->
          Lwt.return_false
      | true ->
          post_filter_manager ctxt rest config )

let post_filter config ~validation_state_before:_
    ~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) =
  match receipt with
  | No_operation_metadata ->
      assert false (* only for multipass validator *)
  | Operation_metadata {contents} -> (
    match contents with
    | Single_result (Endorsement_result _) ->
        Lwt.return_true
    | Single_result (Seed_nonce_revelation_result _) ->
        Lwt.return_true
    | Single_result (Double_endorsement_evidence_result _) ->
        Lwt.return_true
    | Single_result (Double_baking_evidence_result _) ->
        Lwt.return_true
    | Single_result (Activate_account_result _) ->
        Lwt.return_true
    | Single_result Proposals_result ->
        Lwt.return_true
    | Single_result Ballot_result ->
        Lwt.return_true
    | Single_result (Manager_operation_result _) as op ->
        post_filter_manager ctxt op config
    | Cons_result (Manager_operation_result _, _) as op ->
        post_filter_manager ctxt op config )
src/proto_alpha/lib_mempool/filter.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Proto.

End Proto.

Definition nanotez_enc {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star "nanotez" % string
    "Thousandths of tez" % string "One thousand nanotez make a tez" % string
    op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition default_minimal_fees {A : Type} : A :=
  match op_star_t_y_p_e_minus_e_r_r_o_r_star 100 with
  | None => false
  | Some t => t
  end.

Definition default_minimal_nanotez_per_gas_unit {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star 100.

Definition default_minimal_nanotez_per_byte {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star 1000.

Definition default_config {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition get_manager_operation_gas_and_fee {A B : Type} (contents : A) : B :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition pre_filter {A B : Type} (config : A) (function_parameter : B)
  : bool :=
  match function_parameter with
  | _ =>
    let bytes :=
      Z.add
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star)
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star) in
    match op_star_t_y_p_e_minus_e_r_r_o_r_star with
    | _ => true
    | _ => true
    | _ => true
    | _ => true
    | _ => true
    | _ => true
    | _ => true
    | _ =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star config
        op_star_t_y_p_e_minus_e_r_r_o_r_star string
    | _ =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star config
        op_star_t_y_p_e_minus_e_r_r_o_r_star string
    end
  end.

Definition post_filter {A B C D E F : Type}
  (config : A) (function_parameter : B) : C -> (D * E) -> F :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | (_op, receipt) =>
            match receipt with
            | _ => false
            | _ =>
              match op_star_t_y_p_e_minus_e_r_r_o_r_star with
              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star
              | _ =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star config
              | _ =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star config
              end
            end
          end
      end
  end.
src/proto_alpha/lib_parameters/default_parameters.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let constants_mainnet =
  Constants_repr.
    {
      preserved_cycles = 5;
      blocks_per_cycle = 4096l;
      blocks_per_commitment = 32l;
      blocks_per_roll_snapshot = 256l;
      blocks_per_voting_period = 32768l;
      time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 40L];
      endorsers_per_block = 32;
      hard_gas_limit_per_operation = Z.of_int 800_000;
      hard_gas_limit_per_block = Z.of_int 8_000_000;
      proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L);
      tokens_per_roll = Tez_repr.(mul_exn one 8_000);
      michelson_maximum_type_size = 1000;
      seed_nonce_revelation_tip =
        (match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false);
      origination_size = 257;
      block_security_deposit = Tez_repr.(mul_exn one 512);
      endorsement_security_deposit = Tez_repr.(mul_exn one 64);
      block_reward = Tez_repr.(mul_exn one 16);
      endorsement_reward = Tez_repr.(mul_exn one 2);
      hard_storage_limit_per_operation = Z.of_int 60_000;
      cost_per_byte = Tez_repr.of_mutez_exn 1_000L;
      test_chain_duration = Int64.mul 32768L 60L;
      quorum_min = 20_00l;
      (* quorum is in centile of a percentage *)
      quorum_max = 70_00l;
      min_proposal_quorum = 5_00l;
      initial_endorsers = 24;
      delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L;
    }

let constants_sandbox =
  Constants_repr.
    {
      constants_mainnet with
      preserved_cycles = 2;
      blocks_per_cycle = 8l;
      blocks_per_commitment = 4l;
      blocks_per_roll_snapshot = 4l;
      blocks_per_voting_period = 64l;
      time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
      proof_of_work_threshold = Int64.of_int (-1);
      initial_endorsers = 1;
      delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L;
    }

let constants_test =
  Constants_repr.
    {
      constants_mainnet with
      blocks_per_cycle = 128l;
      blocks_per_commitment = 4l;
      blocks_per_roll_snapshot = 32l;
      blocks_per_voting_period = 256l;
      time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
      proof_of_work_threshold = Int64.of_int (-1);
      initial_endorsers = 1;
      delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L;
    }

let bootstrap_accounts_strings =
  [ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav";
    "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9";
    "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV";
    "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU";
    "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ]

let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L

let bootstrap_accounts =
  List.map
    (fun s ->
      let public_key = Signature.Public_key.of_b58check_exn s in
      let public_key_hash = Signature.Public_key.hash public_key in
      Parameters_repr.
        {
          public_key_hash;
          public_key = Some public_key;
          amount = boostrap_balance;
        })
    bootstrap_accounts_strings

(* TODO this could be generated from OCaml together with the faucet
   for now these are harcoded values in the tests *)
let commitments =
  let json_result =
    Data_encoding.Json.from_string
      {json|
  [
    [ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ],
    [ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ],
    [ "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428348" ],
    [ "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ],
    [ "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ],
    [ "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ],
    [ "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ],
    [ "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ],
    [ "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ],
    [ "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ]
  ]|json}
  in
  match json_result with
  | Error err ->
      raise (Failure err)
  | Ok json ->
      Data_encoding.Json.destruct
        (Data_encoding.list Commitment_repr.encoding)
        json

let make_bootstrap_account (pkh, pk, amount) =
  Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount}

let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts)
    ?(bootstrap_contracts = []) ?(with_commitments = false) constants =
  let commitments = if with_commitments then commitments else [] in
  Parameters_repr.
    {
      bootstrap_accounts;
      bootstrap_contracts;
      commitments;
      constants;
      security_deposit_ramp_up_cycles = None;
      no_reward_cycles = None;
    }

let json_of_parameters parameters =
  Data_encoding.Json.construct Parameters_repr.encoding parameters
src/proto_alpha/lib_parameters/default_parameters.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_base__TzPervasives.Protocol.

Definition constants_mainnet {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition constants_sandbox {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition constants_test {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition bootstrap_accounts_strings : list string :=
  cons "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" % string
    (cons "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" % string
      (cons "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV" % string
        (cons "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU" % string
          (cons
            "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" % string [])))).

Definition boostrap_balance {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star 4000000000000.

Definition bootstrap_accounts {A : Type} : list A :=
  Tezos_base__TzPervasives.List.map
    (fun s =>
      let public_key :=
        Tezos_base__TzPervasives.Signature.Public_key.of_b58check_exn s in
      let public_key_hash :=
        Tezos_base__TzPervasives.Signature.Public_key.hash public_key in
      op_star_t_y_p_e_minus_e_r_r_o_r_star) bootstrap_accounts_strings.

Definition commitments {A : Type} : list A :=
  let json_result :=
    Tezos_base__TzPervasives.Data_encoding.Json.from_string
      "
  [
    [ ""btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa"", ""23932454669343"" ],
    [ ""btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv"", ""72954577464032"" ],
    [ ""btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw"", ""217487035428348"" ],
    [ ""btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy"", ""4092742372031"" ],
    [ ""btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r"", ""17590039016550"" ],
    [ ""btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT"", ""26322312350555"" ],
    [ ""btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP"", ""244951387881443"" ],
    [ ""btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1"", ""80065050465525"" ],
    [ ""btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD"", ""3569618927693"" ],
    [ ""btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy"", ""9034781424478"" ]
  ]"
        % string in
  match json_result with
  | inr err => Stdlib.raise (OCaml.Failure err)
  | inl json =>
    Tezos_base__TzPervasives.Data_encoding.Json.destruct
      (Tezos_base__TzPervasives.Data_encoding.list None
        op_star_t_y_p_e_minus_e_r_r_o_r_star) json
  end.

Definition make_bootstrap_account {A B C D : Type}
  (function_parameter : A * B * C) : D :=
  match function_parameter with
  | (pkh, pk, amount) => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition parameters_of_constants {A B C D : Type}
  (op_star_o_p_t_star : option (list A))
  : (option (list B)) -> (option bool) -> C -> D :=
  let bootstrap_accounts :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => bootstrap_accounts
    end in
  fun op_star_o_p_t_star =>
    let bootstrap_contracts :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun op_star_o_p_t_star =>
      let with_commitments :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => false
        end in
      fun constants =>
        let commitments :=
          if with_commitments then
            commitments
          else
            [] in
        op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition json_of_parameters {A : Type} (parameters : A)
  : Tezos_base__TzPervasives.Data_encoding.Json.json :=
  Tezos_base__TzPervasives.Data_encoding.Json.construct
    op_star_t_y_p_e_minus_e_r_r_o_r_star parameters.
src/proto_alpha/lib_parameters/default_parameters.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

val constants_mainnet : Constants_repr.parametric

val constants_sandbox : Constants_repr.parametric

val constants_test : Constants_repr.parametric

val make_bootstrap_account :
  Signature.public_key_hash * Signature.public_key * Tez_repr.t ->
  Parameters_repr.bootstrap_account

val parameters_of_constants :
  ?bootstrap_accounts:Parameters_repr.bootstrap_account list ->
  ?bootstrap_contracts:Parameters_repr.bootstrap_contract list ->
  ?with_commitments:bool ->
  Constants_repr.parametric ->
  Parameters_repr.t

val json_of_parameters : Parameters_repr.t -> Data_encoding.json
src/proto_alpha/lib_parameters/default_parameters.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/proto_alpha/lib_parameters/gen.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Prints the json encoding of the parametric constants of protocol alpha.
   $ dune utop src/proto_alpha/lib_protocol/test/helpers/ constants.ml
*)

let () =
  let print_usage_and_fail s =
    Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ;
    raise (Invalid_argument s)
  in
  let dump parameters file =
    let str =
      Data_encoding.Json.to_string
        (Default_parameters.json_of_parameters parameters)
    in
    let fd = open_out file in
    output_string fd str ; close_out fd
  in
  if Array.length Sys.argv < 2 then print_usage_and_fail ""
  else
    match Sys.argv.(1) with
    | "--sandbox" ->
        dump
          Default_parameters.(parameters_of_constants constants_sandbox)
          "sandbox-parameters.json"
    | "--test" ->
        dump
          Default_parameters.(
            parameters_of_constants ~with_commitments:true constants_sandbox)
          "test-parameters.json"
    | "--mainnet" ->
        dump
          Default_parameters.(
            parameters_of_constants ~with_commitments:true constants_mainnet)
          "mainnet-parameters.json"
    | s ->
        print_usage_and_fail s
src/proto_alpha/lib_parameters/gen.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/proto_alpha/lib_protocol/alpha_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Raw_context.t

type context = t

module type BASIC_DATA = sig
  type t

  include Compare.S with type t := t

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

module Tez = Tez_repr
module Period = Period_repr

module Timestamp = struct
  include Time_repr

  let current = Raw_context.current_timestamp
end

include Operation_repr

module Operation = struct
  type 'kind t = 'kind operation = {
    shell : Operation.shell_header;
    protocol_data : 'kind protocol_data;
  }

  type packed = packed_operation

  let unsigned_encoding = unsigned_operation_encoding

  include Operation_repr
end

module Block_header = Block_header_repr

module Vote = struct
  include Vote_repr
  include Vote_storage
end

module Raw_level = Raw_level_repr
module Cycle = Cycle_repr
module Script_int = Script_int_repr

module Script_timestamp = struct
  include Script_timestamp_repr

  let now ctxt =
    let {Constants_repr.time_between_blocks; _} = Raw_context.constants ctxt in
    match time_between_blocks with
    | [] ->
        failwith
          "Internal error: 'time_between_block' constants is an empty list."
    | first_delay :: _ ->
        let current_timestamp = Raw_context.predecessor_timestamp ctxt in
        Time.add current_timestamp (Period_repr.to_seconds first_delay)
        |> Timestamp.to_seconds |> of_int64
end

module Script = struct
  include Michelson_v1_primitives
  include Script_repr

  let force_decode ctxt lexpr =
    Lwt.return
      ( Script_repr.force_decode lexpr
      >>? fun (v, cost) ->
      Raw_context.consume_gas ctxt cost >|? fun ctxt -> (v, ctxt) )

  let force_bytes ctxt lexpr =
    Lwt.return
      ( Script_repr.force_bytes lexpr
      >>? fun (b, cost) ->
      Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt) )

  module Legacy_support = Legacy_script_support_repr
end

module Fees = Fees_storage

type public_key = Signature.Public_key.t

type public_key_hash = Signature.Public_key_hash.t

type signature = Signature.t

module Constants = struct
  include Constants_repr
  include Constants_storage
end

module Voting_period = Voting_period_repr

module Gas = struct
  include Gas_limit_repr

  type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high

  let check_limit = Raw_context.check_gas_limit

  let set_limit = Raw_context.set_gas_limit

  let set_unlimited = Raw_context.set_gas_unlimited

  let consume = Raw_context.consume_gas

  let check_enough = Raw_context.check_enough_gas

  let level = Raw_context.gas_level

  let consumed = Raw_context.gas_consumed

  let block_level = Raw_context.block_gas_level
end

module Level = struct
  include Level_repr
  include Level_storage
end

module Contract = struct
  include Contract_repr
  include Contract_storage

  let originate c contract ~balance ~script ~delegate =
    originate c contract ~balance ~script ~delegate

  let init_origination_nonce = Raw_context.init_origination_nonce

  let unset_origination_nonce = Raw_context.unset_origination_nonce
end

module Big_map = struct
  type id = Z.t

  let fresh = Storage.Big_map.Next.incr

  let fresh_temporary = Raw_context.fresh_temporary_big_map

  let mem c m k = Storage.Big_map.Contents.mem (c, m) k

  let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k

  let rpc_arg = Storage.Big_map.rpc_arg

  let cleanup_temporary c =
    Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c
    >>= fun c -> Lwt.return (Raw_context.reset_temporary_big_map c)

  let exists c id =
    Lwt.return
      (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
    >>=? fun c ->
    Storage.Big_map.Key_type.get_option c id
    >>=? fun kt ->
    match kt with
    | None ->
        return (c, None)
    | Some kt ->
        Storage.Big_map.Value_type.get c id
        >>=? fun kv -> return (c, Some (kt, kv))
end

module Delegate = Delegate_storage

module Roll = struct
  include Roll_repr
  include Roll_storage
end

module Nonce = Nonce_storage

module Seed = struct
  include Seed_repr
  include Seed_storage
end

module Fitness = struct
  include Fitness_repr
  include Fitness

  type fitness = t

  include Fitness_storage
end

module Bootstrap = Bootstrap_storage

module Commitment = struct
  include Commitment_repr
  include Commitment_storage
end

module Global = struct
  let get_block_priority = Storage.Block_priority.get

  let set_block_priority = Storage.Block_priority.set
end

let prepare_first_block = Init_storage.prepare_first_block

let prepare = Init_storage.prepare

let finalize ?commit_message:message c =
  let fitness = Fitness.from_int64 (Fitness.current c) in
  let context = Raw_context.recover c in
  {
    Updater.context;
    fitness;
    message;
    max_operations_ttl = 60;
    last_allowed_fork_level =
      Raw_level.to_int32 @@ Level.last_allowed_fork_level c;
  }

let activate = Raw_context.activate

let fork_test_chain = Raw_context.fork_test_chain

let record_endorsement = Raw_context.record_endorsement

let allowed_endorsements = Raw_context.allowed_endorsements

let init_endorsements = Raw_context.init_endorsements

let included_endorsements = Raw_context.included_endorsements

let reset_internal_nonce = Raw_context.reset_internal_nonce

let fresh_internal_nonce = Raw_context.fresh_internal_nonce

let record_internal_nonce = Raw_context.record_internal_nonce

let internal_nonce_already_recorded =
  Raw_context.internal_nonce_already_recorded

let add_deposit = Raw_context.add_deposit

let add_fees = Raw_context.add_fees

let add_rewards = Raw_context.add_rewards

let get_deposits = Raw_context.get_deposits

let get_fees = Raw_context.get_fees

let get_rewards = Raw_context.get_rewards

let description = Raw_context.description
src/proto_alpha/lib_protocol/alpha_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_raw_protocol_alpha.Raw_context.t.

Definition context := t.

Module BASIC_DATA.
  Record signature {t : Type} := {
    t := t;
    include;
    encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
    pp : Tezos_protocol_environment_alpha__Environment.Format.formatter ->
      t -> unit;
  }.
  Arguments signature : clear implicits.
End BASIC_DATA.

Module Timestamp.
  Definition current
    : Tezos_raw_protocol_alpha.Raw_context.context ->
      Tezos_protocol_environment_alpha__Environment.Time.t :=
    Tezos_raw_protocol_alpha.Raw_context.current_timestamp.
End Timestamp.

Module Operation.
  Record t {kind : Type} := {
    shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
    protocol_data : protocol_data kind }.
  Arguments t : clear implicits.
  
  Definition packed := packed_operation.
  
  Definition unsigned_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
      (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
        packed_contents_list) := unsigned_operation_encoding.
End Operation.

Module Vote.

End Vote.

Module Script_timestamp.
  Definition now (ctxt : Tezos_raw_protocol_alpha.Raw_context.context) : t :=
    match Tezos_raw_protocol_alpha.Raw_context.constants ctxt with
    | {| Constants_repr.time_between_blocks := time_between_blocks |} =>
      match time_between_blocks with
      | [] =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
          "Internal error: 'time_between_block' constants is an empty list." %
            string
      | cons first_delay _ =>
        let current_timestamp :=
          Tezos_raw_protocol_alpha.Raw_context.predecessor_timestamp ctxt in
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
            (Tezos_protocol_environment_alpha__Environment.Time.add
              current_timestamp
              (Tezos_raw_protocol_alpha.Period_repr.to_seconds first_delay))
            Timestamp.to_seconds) of_int64
      end
    end.
End Script_timestamp.

Module Script.
  Definition force_decode
    (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
    (lexpr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Script_repr.expr *
          Tezos_raw_protocol_alpha.Raw_context.context)) :=
    Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_repr.force_decode lexpr)
        (fun function_parameter =>
          match function_parameter with
          | (v, cost) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Raw_context.consume_gas ctxt cost)
              (fun ctxt => (v, ctxt))
          end)).
  
  Definition force_bytes
    (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
    (lexpr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_protocol_environment_alpha__Environment.MBytes.t *
          Tezos_raw_protocol_alpha.Raw_context.context)) :=
    Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_repr.force_bytes lexpr)
        (fun function_parameter =>
          match function_parameter with
          | (b, cost) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Raw_context.consume_gas ctxt cost)
              (fun ctxt => (b, ctxt))
          end)).
End Script.

Definition public_key :=
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t.

Definition public_key_hash :=
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t.

Definition signature :=
  Tezos_protocol_environment_alpha__Environment.Signature.t.

Module Constants.

End Constants.

Module Gas.
  Definition check_limit
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
    Tezos_raw_protocol_alpha.Raw_context.check_gas_limit.
  
  Definition set_limit
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_raw_protocol_alpha.Raw_context.t :=
    Tezos_raw_protocol_alpha.Raw_context.set_gas_limit.
  
  Definition set_unlimited
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Raw_context.t :=
    Tezos_raw_protocol_alpha.Raw_context.set_gas_unlimited.
  
  Definition consume
    : Tezos_raw_protocol_alpha.Raw_context.context ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.context :=
    Tezos_raw_protocol_alpha.Raw_context.consume_gas.
  
  Definition check_enough
    : Tezos_raw_protocol_alpha.Raw_context.context ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
    Tezos_raw_protocol_alpha.Raw_context.check_enough_gas.
  
  Definition level
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.t :=
    Tezos_raw_protocol_alpha.Raw_context.gas_level.
  
  Definition consumed
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Raw_context.t ->
        Tezos_protocol_environment_alpha__Environment.Z.t :=
    Tezos_raw_protocol_alpha.Raw_context.gas_consumed.
  
  Definition block_level
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    Tezos_raw_protocol_alpha.Raw_context.block_gas_level.
End Gas.

Module Level.

End Level.

Module Contract.
  Definition originate
    (c : Tezos_raw_protocol_alpha.Raw_context.t)
    (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
    (balance : Tezos_raw_protocol_alpha.Tez_repr.t)
    (script : Tezos_raw_protocol_alpha.Script_repr.t * (option big_map_diff))
    (delegate :
      option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    originate c None contract balance script delegate.
  
  Definition init_origination_nonce
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        -> Tezos_raw_protocol_alpha.Raw_context.t :=
    Tezos_raw_protocol_alpha.Raw_context.init_origination_nonce.
  
  Definition unset_origination_nonce
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Raw_context.t :=
    Tezos_raw_protocol_alpha.Raw_context.unset_origination_nonce.
End Contract.

Module Big_map.
  Definition id := Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Definition fresh
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t *
            Tezos_protocol_environment_alpha__Environment.Z.t)) :=
    Tezos_raw_protocol_alpha.Storage.Big_map.Next.incr.
  
  Definition fresh_temporary
    : Tezos_raw_protocol_alpha.Raw_context.context ->
      Tezos_raw_protocol_alpha.Raw_context.context *
        Tezos_protocol_environment_alpha__Environment.Z.t :=
    Tezos_raw_protocol_alpha.Raw_context.fresh_temporary_big_map.
  
  Definition mem
    (c : Tezos_raw_protocol_alpha.Raw_context.t)
    (m : Tezos_protocol_environment_alpha__Environment.Z.t)
    (k : Tezos_raw_protocol_alpha.Storage.Big_map.Contents.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t * bool)) :=
    Tezos_raw_protocol_alpha.Storage.Big_map.Contents.mem (c, m) k.
  
  Definition get_opt
    (c : Tezos_raw_protocol_alpha.Raw_context.t)
    (m : Tezos_protocol_environment_alpha__Environment.Z.t)
    (k : Tezos_raw_protocol_alpha.Storage.Big_map.Contents.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t *
          (option Tezos_raw_protocol_alpha.Storage.Big_map.Contents.value))) :=
    Tezos_raw_protocol_alpha.Storage.Big_map.Contents.get_option (c, m) k.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.t
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    Tezos_raw_protocol_alpha.Storage.Big_map.rpc_arg.
  
  Definition cleanup_temporary
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      Tezos_raw_protocol_alpha.Raw_context.context :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
      (Tezos_raw_protocol_alpha.Raw_context.temporary_big_maps c
        Tezos_raw_protocol_alpha.Storage.Big_map.remove_rec c)
      (fun c =>
        Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Raw_context.reset_temporary_big_map c)).
  
  Definition _exists
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (id : Tezos_raw_protocol_alpha.Storage.Big_map.Key_type.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.context *
          (option
            (Tezos_raw_protocol_alpha.Storage.Big_map.Key_type.value *
              Tezos_raw_protocol_alpha.Storage.Big_map.Value_type.value)))) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Raw_context.consume_gas c
          (Tezos_raw_protocol_alpha.Gas_limit_repr.read_bytes_cost
            Tezos_protocol_environment_alpha__Environment.Z.zero)))
      (fun c =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Big_map.Key_type.get_option c id)
          (fun kt =>
            match kt with
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (c, None)
            | Some kt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Big_map.Value_type.get c id)
                (fun kv =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (c, (Some (kt, kv))))
            end)).
End Big_map.

Module Roll.

End Roll.

Module Seed.

End Seed.

Module Fitness.
  Definition fitness := t.
End Fitness.

Module Commitment.

End Commitment.

Module Global.
  Definition get_block_priority
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
    Tezos_raw_protocol_alpha.Storage.Block_priority.get.
  
  Definition set_block_priority
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Z ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t) :=
    Tezos_raw_protocol_alpha.Storage.Block_priority.set.
End Global.

Definition prepare_first_block
  : Tezos_protocol_environment_alpha__Environment.Context.t ->
    (Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Script_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_repr.t *
              (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
              Tezos_raw_protocol_alpha.Raw_context.t))) ->
      int32 ->
        Tezos_protocol_environment_alpha__Environment.Time.t ->
          Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t)
            ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Init_storage.prepare_first_block.

Definition prepare
  : Tezos_protocol_environment_alpha__Environment.Context.t ->
    Tezos_protocol_environment_alpha__Environment.Int32.t ->
      Tezos_protocol_environment_alpha__Environment.Time.t ->
        Tezos_protocol_environment_alpha__Environment.Time.t ->
          Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t)
            ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                Tezos_raw_protocol_alpha.Raw_context.context) :=
  Tezos_raw_protocol_alpha.Init_storage.prepare.

Definition finalize
  (message : option string) (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Updater.validation_result :=
  let fitness := Fitness.from_int64 (Fitness.current c) in
  let context := Tezos_raw_protocol_alpha.Raw_context.recover c in
  {| Updater.context := context; Updater.fitness := fitness;
    Updater.message := message; Updater.max_operations_ttl := 60;
    Updater.last_allowed_fork_level :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Raw_level.to_int32 (Level.last_allowed_fork_level c) |}.

Definition activate
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t :=
  Tezos_raw_protocol_alpha.Raw_context.activate.

Definition fork_test_chain
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      ->
      Tezos_protocol_environment_alpha__Environment.Time.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t :=
  Tezos_raw_protocol_alpha.Raw_context.fork_test_chain.

Definition record_endorsement
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_raw_protocol_alpha.Raw_context.context :=
  Tezos_raw_protocol_alpha.Raw_context.record_endorsement.

Definition allowed_endorsements
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
        (list Z) * bool) :=
  Tezos_raw_protocol_alpha.Raw_context.allowed_endorsements.

Definition init_endorsements
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
        (list Z) * bool)) -> Tezos_raw_protocol_alpha.Raw_context.context :=
  Tezos_raw_protocol_alpha.Raw_context.init_endorsements.

Definition included_endorsements
  : Tezos_raw_protocol_alpha.Raw_context.context -> Z :=
  Tezos_raw_protocol_alpha.Raw_context.included_endorsements.

Definition reset_internal_nonce
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Raw_context.context :=
  Tezos_raw_protocol_alpha.Raw_context.reset_internal_nonce.

Definition fresh_internal_nonce
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.context * Z) :=
  Tezos_raw_protocol_alpha.Raw_context.fresh_internal_nonce.

Definition record_internal_nonce
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Z -> Tezos_raw_protocol_alpha.Raw_context.context :=
  Tezos_raw_protocol_alpha.Raw_context.record_internal_nonce.

Definition internal_nonce_already_recorded
  : Tezos_raw_protocol_alpha.Raw_context.context -> Z -> bool :=
  Tezos_raw_protocol_alpha.Raw_context.internal_nonce_already_recorded.

Definition add_deposit
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_raw_protocol_alpha.Tez_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.context) :=
  Tezos_raw_protocol_alpha.Raw_context.add_deposit.

Definition add_fees
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.context) :=
  Tezos_raw_protocol_alpha.Raw_context.add_fees.

Definition add_rewards
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.context) :=
  Tezos_raw_protocol_alpha.Raw_context.add_rewards.

Definition get_deposits
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      Tezos_raw_protocol_alpha.Tez_repr.t :=
  Tezos_raw_protocol_alpha.Raw_context.get_deposits.

Definition get_fees
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Tez_repr.t :=
  Tezos_raw_protocol_alpha.Raw_context.get_fees.

Definition get_rewards
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Tez_repr.t :=
  Tezos_raw_protocol_alpha.Raw_context.get_rewards.

Definition description
  : Tezos_raw_protocol_alpha.Storage_description.t
    Tezos_raw_protocol_alpha.Raw_context.context :=
  Tezos_raw_protocol_alpha.Raw_context.description.
src/proto_alpha/lib_protocol/alpha_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type BASIC_DATA = sig
  type t

  include Compare.S with type t := t

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

type t

type context = t

type public_key = Signature.Public_key.t

type public_key_hash = Signature.Public_key_hash.t

type signature = Signature.t

module Tez : sig
  include BASIC_DATA

  type tez = t

  val zero : tez

  val one_mutez : tez

  val one_cent : tez

  val fifty_cents : tez

  val one : tez

  val ( -? ) : tez -> tez -> tez tzresult

  val ( +? ) : tez -> tez -> tez tzresult

  val ( *? ) : tez -> int64 -> tez tzresult

  val ( /? ) : tez -> int64 -> tez tzresult

  val of_string : string -> tez option

  val to_string : tez -> string

  val of_mutez : int64 -> tez option

  val to_mutez : tez -> int64
end

module Period : sig
  include BASIC_DATA

  type period = t

  val rpc_arg : period RPC_arg.arg

  val of_seconds : int64 -> period tzresult

  val to_seconds : period -> int64

  val mult : int32 -> period -> period tzresult

  val zero : period

  val one_second : period

  val one_minute : period

  val one_hour : period
end

module Timestamp : sig
  include BASIC_DATA with type t = Time.t

  type time = t

  val ( +? ) : time -> Period.t -> time tzresult

  val ( -? ) : time -> time -> Period.t tzresult

  val of_notation : string -> time option

  val to_notation : time -> string

  val of_seconds : string -> time option

  val to_seconds_string : time -> string

  val current : context -> time
end

module Raw_level : sig
  include BASIC_DATA

  type raw_level = t

  val rpc_arg : raw_level RPC_arg.arg

  val diff : raw_level -> raw_level -> int32

  val root : raw_level

  val succ : raw_level -> raw_level

  val pred : raw_level -> raw_level option

  val to_int32 : raw_level -> int32

  val of_int32 : int32 -> raw_level tzresult
end

module Cycle : sig
  include BASIC_DATA

  type cycle = t

  val rpc_arg : cycle RPC_arg.arg

  val root : cycle

  val succ : cycle -> cycle

  val pred : cycle -> cycle option

  val add : cycle -> int -> cycle

  val sub : cycle -> int -> cycle option

  val to_int32 : cycle -> int32

  module Map : S.MAP with type key = cycle
end

module Gas : sig
  type t = private Unaccounted | Limited of {remaining : Z.t}

  val encoding : t Data_encoding.encoding

  val pp : Format.formatter -> t -> unit

  type cost

  val cost_encoding : cost Data_encoding.encoding

  val pp_cost : Format.formatter -> cost -> unit

  type error += Block_quota_exceeded (* `Temporary *)

  type error += Operation_quota_exceeded (* `Temporary *)

  type error += Gas_limit_too_high (* `Permanent *)

  val free : cost

  val atomic_step_cost : int -> cost

  val step_cost : int -> cost

  val alloc_cost : int -> cost

  val alloc_bytes_cost : int -> cost

  val alloc_mbytes_cost : int -> cost

  val alloc_bits_cost : int -> cost

  val read_bytes_cost : Z.t -> cost

  val write_bytes_cost : Z.t -> cost

  val ( *@ ) : int -> cost -> cost

  val ( +@ ) : cost -> cost -> cost

  val check_limit : context -> Z.t -> unit tzresult

  val set_limit : context -> Z.t -> context

  val set_unlimited : context -> context

  val consume : context -> cost -> context tzresult

  val check_enough : context -> cost -> unit tzresult

  val level : context -> t

  val consumed : since:context -> until:context -> Z.t

  val block_level : context -> Z.t
end

module Script_int : module type of Script_int_repr

module Script_timestamp : sig
  open Script_int

  type t

  val compare : t -> t -> int

  val to_string : t -> string

  val to_notation : t -> string option

  val to_num_str : t -> string

  val of_string : string -> t option

  val diff : t -> t -> z num

  val add_delta : t -> z num -> t

  val sub_delta : t -> z num -> t

  val now : context -> t

  val to_zint : t -> Z.t

  val of_zint : Z.t -> t
end

module Script : sig
  type prim = Michelson_v1_primitives.prim =
    | K_parameter
    | K_storage
    | K_code
    | D_False
    | D_Elt
    | D_Left
    | D_None
    | D_Pair
    | D_Right
    | D_Some
    | D_True
    | D_Unit
    | I_PACK
    | I_UNPACK
    | I_BLAKE2B
    | I_SHA256
    | I_SHA512
    | I_ABS
    | I_ADD
    | I_AMOUNT
    | I_AND
    | I_BALANCE
    | I_CAR
    | I_CDR
    | I_CHAIN_ID
    | I_CHECK_SIGNATURE
    | I_COMPARE
    | I_CONCAT
    | I_CONS
    | I_CREATE_ACCOUNT
    | I_CREATE_CONTRACT
    | I_IMPLICIT_ACCOUNT
    | I_DIP
    | I_DROP
    | I_DUP
    | I_EDIV
    | I_EMPTY_BIG_MAP
    | I_EMPTY_MAP
    | I_EMPTY_SET
    | I_EQ
    | I_EXEC
    | I_APPLY
    | I_FAILWITH
    | I_GE
    | I_GET
    | I_GT
    | I_HASH_KEY
    | I_IF
    | I_IF_CONS
    | I_IF_LEFT
    | I_IF_NONE
    | I_INT
    | I_LAMBDA
    | I_LE
    | I_LEFT
    | I_LOOP
    | I_LSL
    | I_LSR
    | I_LT
    | I_MAP
    | I_MEM
    | I_MUL
    | I_NEG
    | I_NEQ
    | I_NIL
    | I_NONE
    | I_NOT
    | I_NOW
    | I_OR
    | I_PAIR
    | I_PUSH
    | I_RIGHT
    | I_SIZE
    | I_SOME
    | I_SOURCE
    | I_SENDER
    | I_SELF
    | I_SLICE
    | I_STEPS_TO_QUOTA
    | I_SUB
    | I_SWAP
    | I_TRANSFER_TOKENS
    | I_SET_DELEGATE
    | I_UNIT
    | I_UPDATE
    | I_XOR
    | I_ITER
    | I_LOOP_LEFT
    | I_ADDRESS
    | I_CONTRACT
    | I_ISNAT
    | I_CAST
    | I_RENAME
    | I_DIG
    | I_DUG
    | T_bool
    | T_contract
    | T_int
    | T_key
    | T_key_hash
    | T_lambda
    | T_list
    | T_map
    | T_big_map
    | T_nat
    | T_option
    | T_or
    | T_pair
    | T_set
    | T_signature
    | T_string
    | T_bytes
    | T_mutez
    | T_timestamp
    | T_unit
    | T_operation
    | T_address
    | T_chain_id

  type location = Micheline.canonical_location

  type annot = Micheline.annot

  type expr = prim Micheline.canonical

  type lazy_expr = expr Data_encoding.lazy_t

  val lazy_expr : expr -> lazy_expr

  type node = (location, prim) Micheline.node

  type t = {code : lazy_expr; storage : lazy_expr}

  val location_encoding : location Data_encoding.t

  val expr_encoding : expr Data_encoding.t

  val prim_encoding : prim Data_encoding.t

  val encoding : t Data_encoding.t

  val lazy_expr_encoding : lazy_expr Data_encoding.t

  val deserialized_cost : expr -> Gas.cost

  val serialized_cost : MBytes.t -> Gas.cost

  val traversal_cost : node -> Gas.cost

  val node_cost : node -> Gas.cost

  val int_node_cost : Z.t -> Gas.cost

  val int_node_cost_of_numbits : int -> Gas.cost

  val string_node_cost : string -> Gas.cost

  val string_node_cost_of_length : int -> Gas.cost

  val bytes_node_cost : MBytes.t -> Gas.cost

  val bytes_node_cost_of_length : int -> Gas.cost

  val prim_node_cost_nonrec : expr list -> annot -> Gas.cost

  val prim_node_cost_nonrec_of_length : int -> annot -> Gas.cost

  val seq_node_cost_nonrec : expr list -> Gas.cost

  val seq_node_cost_nonrec_of_length : int -> Gas.cost

  val minimal_deserialize_cost : lazy_expr -> Gas.cost

  val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t

  val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t

  val unit_parameter : lazy_expr

  module Legacy_support : sig
    val manager_script_code : lazy_expr

    val add_do :
      manager_pkh:Signature.Public_key_hash.t ->
      script_code:lazy_expr ->
      script_storage:lazy_expr ->
      (lazy_expr * lazy_expr) tzresult Lwt.t

    val add_set_delegate :
      manager_pkh:Signature.Public_key_hash.t ->
      script_code:lazy_expr ->
      script_storage:lazy_expr ->
      (lazy_expr * lazy_expr) tzresult Lwt.t

    val has_default_entrypoint : lazy_expr -> bool

    val add_root_entrypoint : script_code:lazy_expr -> lazy_expr tzresult Lwt.t
  end
end

module Constants : sig
  (** Fixed constants *)
  type fixed = {
    proof_of_work_nonce_size : int;
    nonce_length : int;
    max_revelations_per_block : int;
    max_operation_data_length : int;
    max_proposals_per_delegate : int;
  }

  val fixed_encoding : fixed Data_encoding.t

  val fixed : fixed

  val proof_of_work_nonce_size : int

  val nonce_length : int

  val max_revelations_per_block : int

  val max_operation_data_length : int

  val max_proposals_per_delegate : int

  (** Constants parameterized by context *)
  type parametric = {
    preserved_cycles : int;
    blocks_per_cycle : int32;
    blocks_per_commitment : int32;
    blocks_per_roll_snapshot : int32;
    blocks_per_voting_period : int32;
    time_between_blocks : Period.t list;
    endorsers_per_block : int;
    hard_gas_limit_per_operation : Z.t;
    hard_gas_limit_per_block : Z.t;
    proof_of_work_threshold : int64;
    tokens_per_roll : Tez.t;
    michelson_maximum_type_size : int;
    seed_nonce_revelation_tip : Tez.t;
    origination_size : int;
    block_security_deposit : Tez.t;
    endorsement_security_deposit : Tez.t;
    block_reward : Tez.t;
    endorsement_reward : Tez.t;
    cost_per_byte : Tez.t;
    hard_storage_limit_per_operation : Z.t;
    test_chain_duration : int64;
    quorum_min : int32;
    quorum_max : int32;
    min_proposal_quorum : int32;
    initial_endorsers : int;
    delay_per_missing_endorsement : Period.t;
  }

  val parametric_encoding : parametric Data_encoding.t

  val parametric : context -> parametric

  val preserved_cycles : context -> int

  val blocks_per_cycle : context -> int32

  val blocks_per_commitment : context -> int32

  val blocks_per_roll_snapshot : context -> int32

  val blocks_per_voting_period : context -> int32

  val time_between_blocks : context -> Period.t list

  val endorsers_per_block : context -> int

  val initial_endorsers : context -> int

  val delay_per_missing_endorsement : context -> Period.t

  val hard_gas_limit_per_operation : context -> Z.t

  val hard_gas_limit_per_block : context -> Z.t

  val cost_per_byte : context -> Tez.t

  val hard_storage_limit_per_operation : context -> Z.t

  val proof_of_work_threshold : context -> int64

  val tokens_per_roll : context -> Tez.t

  val michelson_maximum_type_size : context -> int

  val block_reward : context -> Tez.t

  val endorsement_reward : context -> Tez.t

  val seed_nonce_revelation_tip : context -> Tez.t

  val origination_size : context -> int

  val block_security_deposit : context -> Tez.t

  val endorsement_security_deposit : context -> Tez.t

  val test_chain_duration : context -> int64

  val quorum_min : context -> int32

  val quorum_max : context -> int32

  val min_proposal_quorum : context -> int32

  (** All constants: fixed and parametric *)
  type t = {fixed : fixed; parametric : parametric}

  val encoding : t Data_encoding.t
end

module Voting_period : sig
  include BASIC_DATA

  type voting_period = t

  val rpc_arg : voting_period RPC_arg.arg

  val root : voting_period

  val succ : voting_period -> voting_period

  type kind = Proposal | Testing_vote | Testing | Promotion_vote

  val kind_encoding : kind Data_encoding.encoding

  val to_int32 : voting_period -> int32
end

module Level : sig
  type t = private {
    level : Raw_level.t;
    level_position : int32;
    cycle : Cycle.t;
    cycle_position : int32;
    voting_period : Voting_period.t;
    voting_period_position : int32;
    expected_commitment : bool;
  }

  include BASIC_DATA with type t := t

  val pp_full : Format.formatter -> t -> unit

  type level = t

  val root : context -> level

  val succ : context -> level -> level

  val pred : context -> level -> level option

  val from_raw : context -> ?offset:int32 -> Raw_level.t -> level

  val diff : level -> level -> int32

  val current : context -> level

  val last_level_in_cycle : context -> Cycle.t -> level

  val levels_in_cycle : context -> Cycle.t -> level list

  val levels_in_current_cycle : context -> ?offset:int32 -> unit -> level list

  val last_allowed_fork_level : context -> Raw_level.t
end

module Fitness : sig
  include module type of Fitness

  type fitness = t

  val increase : ?gap:int -> context -> context

  val current : context -> int64

  val to_int64 : fitness -> int64 tzresult
end

module Nonce : sig
  type t

  type nonce = t

  val encoding : nonce Data_encoding.t

  type unrevealed = {
    nonce_hash : Nonce_hash.t;
    delegate : public_key_hash;
    rewards : Tez.t;
    fees : Tez.t;
  }

  val record_hash : context -> unrevealed -> context tzresult Lwt.t

  val reveal : context -> Level.t -> nonce -> context tzresult Lwt.t

  type status = Unrevealed of unrevealed | Revealed of nonce

  val get : context -> Level.t -> status tzresult Lwt.t

  val of_bytes : MBytes.t -> nonce tzresult

  val hash : nonce -> Nonce_hash.t

  val check_hash : nonce -> Nonce_hash.t -> bool
end

module Seed : sig
  type seed

  type error +=
    | Unknown of {oldest : Cycle.t; cycle : Cycle.t; latest : Cycle.t}

  val for_cycle : context -> Cycle.t -> seed tzresult Lwt.t

  val cycle_end :
    context -> Cycle.t -> (context * Nonce.unrevealed list) tzresult Lwt.t

  val seed_encoding : seed Data_encoding.t
end

module Big_map : sig
  type id = Z.t

  val fresh : context -> (context * id) tzresult Lwt.t

  val fresh_temporary : context -> context * id

  val mem :
    context -> id -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t

  val get_opt :
    context ->
    id ->
    Script_expr_hash.t ->
    (context * Script.expr option) tzresult Lwt.t

  val rpc_arg : id RPC_arg.t

  val cleanup_temporary : context -> context Lwt.t

  val exists :
    context ->
    id ->
    (context * (Script.expr * Script.expr) option) tzresult Lwt.t
end

module Contract : sig
  include BASIC_DATA

  type contract = t

  val rpc_arg : contract RPC_arg.arg

  val to_b58check : contract -> string

  val of_b58check : string -> contract tzresult

  val implicit_contract : public_key_hash -> contract

  val is_implicit : contract -> public_key_hash option

  val exists : context -> contract -> bool tzresult Lwt.t

  val must_exist : context -> contract -> unit tzresult Lwt.t

  val allocated : context -> contract -> bool tzresult Lwt.t

  val must_be_allocated : context -> contract -> unit tzresult Lwt.t

  val list : context -> contract list Lwt.t

  val get_manager_key : context -> public_key_hash -> public_key tzresult Lwt.t

  val is_manager_key_revealed :
    context -> public_key_hash -> bool tzresult Lwt.t

  val reveal_manager_key :
    context -> public_key_hash -> public_key -> context tzresult Lwt.t

  val get_script_code :
    context -> contract -> (context * Script.lazy_expr option) tzresult Lwt.t

  val get_script :
    context -> contract -> (context * Script.t option) tzresult Lwt.t

  val get_storage :
    context -> contract -> (context * Script.expr option) tzresult Lwt.t

  val get_counter : context -> public_key_hash -> Z.t tzresult Lwt.t

  val get_balance : context -> contract -> Tez.t tzresult Lwt.t

  val init_origination_nonce : context -> Operation_hash.t -> context

  val unset_origination_nonce : context -> context

  val fresh_contract_from_current_nonce :
    context -> (context * t) tzresult Lwt.t

  val originated_from_current_nonce :
    since:context -> until:context -> contract list tzresult Lwt.t

  type big_map_diff_item =
    | Update of {
        big_map : Big_map.id;
        diff_key : Script.expr;
        diff_key_hash : Script_expr_hash.t;
        diff_value : Script.expr option;
      }
    | Clear of Big_map.id
    | Copy of Big_map.id * Big_map.id
    | Alloc of {
        big_map : Big_map.id;
        key_type : Script.expr;
        value_type : Script.expr;
      }

  type big_map_diff = big_map_diff_item list

  val big_map_diff_encoding : big_map_diff Data_encoding.t

  val originate :
    context ->
    contract ->
    balance:Tez.t ->
    script:Script.t * big_map_diff option ->
    delegate:public_key_hash option ->
    context tzresult Lwt.t

  type error += Balance_too_low of contract * Tez.t * Tez.t

  val spend : context -> contract -> Tez.t -> context tzresult Lwt.t

  val credit : context -> contract -> Tez.t -> context tzresult Lwt.t

  val update_script_storage :
    context ->
    contract ->
    Script.expr ->
    big_map_diff option ->
    context tzresult Lwt.t

  val used_storage_space : context -> t -> Z.t tzresult Lwt.t

  val increment_counter : context -> public_key_hash -> context tzresult Lwt.t

  val check_counter_increment :
    context -> public_key_hash -> Z.t -> unit tzresult Lwt.t

  (**/**)

  (* Only for testing *)
  type origination_nonce

  val initial_origination_nonce : Operation_hash.t -> origination_nonce

  val originated_contract : origination_nonce -> contract
end

module Delegate : sig
  type balance =
    | Contract of Contract.t
    | Rewards of Signature.Public_key_hash.t * Cycle.t
    | Fees of Signature.Public_key_hash.t * Cycle.t
    | Deposits of Signature.Public_key_hash.t * Cycle.t

  type balance_update = Debited of Tez.t | Credited of Tez.t

  type balance_updates = (balance * balance_update) list

  val balance_updates_encoding : balance_updates Data_encoding.t

  val cleanup_balance_updates : balance_updates -> balance_updates

  val get : context -> Contract.t -> public_key_hash option tzresult Lwt.t

  val set :
    context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t

  val fold :
    context -> init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val list : context -> public_key_hash list Lwt.t

  val freeze_deposit :
    context -> public_key_hash -> Tez.t -> context tzresult Lwt.t

  val freeze_rewards :
    context -> public_key_hash -> Tez.t -> context tzresult Lwt.t

  val freeze_fees :
    context -> public_key_hash -> Tez.t -> context tzresult Lwt.t

  val cycle_end :
    context ->
    Cycle.t ->
    Nonce.unrevealed list ->
    (context * balance_updates * Signature.Public_key_hash.t list) tzresult
    Lwt.t

  type frozen_balance = {deposit : Tez.t; fees : Tez.t; rewards : Tez.t}

  val punish :
    context ->
    public_key_hash ->
    Cycle.t ->
    (context * frozen_balance) tzresult Lwt.t

  val full_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t

  val has_frozen_balance :
    context -> public_key_hash -> Cycle.t -> bool tzresult Lwt.t

  val frozen_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t

  val frozen_balance_encoding : frozen_balance Data_encoding.t

  val frozen_balance_by_cycle_encoding :
    frozen_balance Cycle.Map.t Data_encoding.t

  val frozen_balance_by_cycle :
    context -> Signature.Public_key_hash.t -> frozen_balance Cycle.Map.t Lwt.t

  val staking_balance :
    context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t

  val delegated_contracts :
    context -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t

  val delegated_balance :
    context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t

  val deactivated :
    context -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

  val grace_period :
    context -> Signature.Public_key_hash.t -> Cycle.t tzresult Lwt.t
end

module Vote : sig
  type proposal = Protocol_hash.t

  val record_proposal :
    context -> Protocol_hash.t -> public_key_hash -> context tzresult Lwt.t

  val get_proposals : context -> int32 Protocol_hash.Map.t tzresult Lwt.t

  val clear_proposals : context -> context Lwt.t

  val recorded_proposal_count_for_delegate :
    context -> public_key_hash -> int tzresult Lwt.t

  val listings_encoding :
    (Signature.Public_key_hash.t * int32) list Data_encoding.t

  val freeze_listings : context -> context tzresult Lwt.t

  val clear_listings : context -> context tzresult Lwt.t

  val listing_size : context -> int32 tzresult Lwt.t

  val in_listings : context -> public_key_hash -> bool Lwt.t

  val get_listings : context -> (public_key_hash * int32) list Lwt.t

  type ballot = Yay | Nay | Pass

  val ballot_encoding : ballot Data_encoding.t

  type ballots = {yay : int32; nay : int32; pass : int32}

  val ballots_encoding : ballots Data_encoding.t

  val has_recorded_ballot : context -> public_key_hash -> bool Lwt.t

  val record_ballot :
    context -> public_key_hash -> ballot -> context tzresult Lwt.t

  val get_ballots : context -> ballots tzresult Lwt.t

  val get_ballot_list :
    context -> (Signature.Public_key_hash.t * ballot) list Lwt.t

  val clear_ballots : context -> context Lwt.t

  val get_current_period_kind : context -> Voting_period.kind tzresult Lwt.t

  val set_current_period_kind :
    context -> Voting_period.kind -> context tzresult Lwt.t

  val get_current_quorum : context -> int32 tzresult Lwt.t

  val get_participation_ema : context -> int32 tzresult Lwt.t

  val set_participation_ema : context -> int32 -> context tzresult Lwt.t

  val get_current_proposal : context -> proposal tzresult Lwt.t

  val init_current_proposal : context -> proposal -> context tzresult Lwt.t

  val clear_current_proposal : context -> context tzresult Lwt.t
end

module Block_header : sig
  type t = {shell : Block_header.shell_header; protocol_data : protocol_data}

  and protocol_data = {contents : contents; signature : Signature.t}

  and contents = {
    priority : int;
    seed_nonce_hash : Nonce_hash.t option;
    proof_of_work_nonce : MBytes.t;
  }

  type block_header = t

  type raw = Block_header.t

  type shell_header = Block_header.shell_header

  val raw : block_header -> raw

  val hash : block_header -> Block_hash.t

  val hash_raw : raw -> Block_hash.t

  val encoding : block_header Data_encoding.encoding

  val raw_encoding : raw Data_encoding.t

  val contents_encoding : contents Data_encoding.t

  val unsigned_encoding : (shell_header * contents) Data_encoding.t

  val protocol_data_encoding : protocol_data Data_encoding.encoding

  val shell_header_encoding : shell_header Data_encoding.encoding

  (** The maximum size of block headers in bytes *)
  val max_header_length : int
end

module Kind : sig
  type seed_nonce_revelation = Seed_nonce_revelation_kind

  type double_endorsement_evidence = Double_endorsement_evidence_kind

  type double_baking_evidence = Double_baking_evidence_kind

  type activate_account = Activate_account_kind

  type endorsement = Endorsement_kind

  type proposals = Proposals_kind

  type ballot = Ballot_kind

  type reveal = Reveal_kind

  type transaction = Transaction_kind

  type origination = Origination_kind

  type delegation = Delegation_kind

  type 'a manager =
    | Reveal_manager_kind : reveal manager
    | Transaction_manager_kind : transaction manager
    | Origination_manager_kind : origination manager
    | Delegation_manager_kind : delegation manager
end

type 'kind operation = {
  shell : Operation.shell_header;
  protocol_data : 'kind protocol_data;
}

and 'kind protocol_data = {
  contents : 'kind contents_list;
  signature : Signature.t option;
}

and _ contents_list =
  | Single : 'kind contents -> 'kind contents_list
  | Cons :
      'kind Kind.manager contents * 'rest Kind.manager contents_list
      -> ('kind * 'rest) Kind.manager contents_list

and _ contents =
  | Endorsement : {level : Raw_level.t} -> Kind.endorsement contents
  | Seed_nonce_revelation : {
      level : Raw_level.t;
      nonce : Nonce.t;
    }
      -> Kind.seed_nonce_revelation contents
  | Double_endorsement_evidence : {
      op1 : Kind.endorsement operation;
      op2 : Kind.endorsement operation;
    }
      -> Kind.double_endorsement_evidence contents
  | Double_baking_evidence : {
      bh1 : Block_header.t;
      bh2 : Block_header.t;
    }
      -> Kind.double_baking_evidence contents
  | Activate_account : {
      id : Ed25519.Public_key_hash.t;
      activation_code : Blinded_public_key_hash.activation_code;
    }
      -> Kind.activate_account contents
  | Proposals : {
      source : Signature.Public_key_hash.t;
      period : Voting_period.t;
      proposals : Protocol_hash.t list;
    }
      -> Kind.proposals contents
  | Ballot : {
      source : Signature.Public_key_hash.t;
      period : Voting_period.t;
      proposal : Protocol_hash.t;
      ballot : Vote.ballot;
    }
      -> Kind.ballot contents
  | Manager_operation : {
      source : Signature.Public_key_hash.t;
      fee : Tez.tez;
      counter : counter;
      operation : 'kind manager_operation;
      gas_limit : Z.t;
      storage_limit : Z.t;
    }
      -> 'kind Kind.manager contents

and _ manager_operation =
  | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
  | Transaction : {
      amount : Tez.tez;
      parameters : Script.lazy_expr;
      entrypoint : string;
      destination : Contract.contract;
    }
      -> Kind.transaction manager_operation
  | Origination : {
      delegate : Signature.Public_key_hash.t option;
      script : Script.t;
      credit : Tez.tez;
      preorigination : Contract.t option;
    }
      -> Kind.origination manager_operation
  | Delegation :
      Signature.Public_key_hash.t option
      -> Kind.delegation manager_operation

and counter = Z.t

type 'kind internal_operation = {
  source : Contract.contract;
  operation : 'kind manager_operation;
  nonce : int;
}

type packed_manager_operation =
  | Manager : 'kind manager_operation -> packed_manager_operation

type packed_contents = Contents : 'kind contents -> packed_contents

type packed_contents_list =
  | Contents_list : 'kind contents_list -> packed_contents_list

type packed_protocol_data =
  | Operation_data : 'kind protocol_data -> packed_protocol_data

type packed_operation = {
  shell : Operation.shell_header;
  protocol_data : packed_protocol_data;
}

type packed_internal_operation =
  | Internal_operation : 'kind internal_operation -> packed_internal_operation

val manager_kind : 'kind manager_operation -> 'kind Kind.manager

module Fees : sig
  val origination_burn : context -> (context * Tez.t) tzresult Lwt.t

  val record_paid_storage_space :
    context -> Contract.t -> (context * Z.t * Z.t * Tez.t) tzresult Lwt.t

  val start_counting_storage_fees : context -> context

  val burn_storage_fees :
    context -> storage_limit:Z.t -> payer:Contract.t -> context tzresult Lwt.t

  type error += Cannot_pay_storage_fee (* `Temporary *)

  type error += Operation_quota_exceeded (* `Temporary *)

  type error += Storage_limit_too_high (* `Permanent *)

  val check_storage_limit : context -> storage_limit:Z.t -> unit tzresult
end

module Operation : sig
  type nonrec 'kind contents = 'kind contents

  type nonrec packed_contents = packed_contents

  val contents_encoding : packed_contents Data_encoding.t

  type nonrec 'kind protocol_data = 'kind protocol_data

  type nonrec packed_protocol_data = packed_protocol_data

  val protocol_data_encoding : packed_protocol_data Data_encoding.t

  val unsigned_encoding :
    (Operation.shell_header * packed_contents_list) Data_encoding.t

  type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}

  val raw_encoding : raw Data_encoding.t

  val contents_list_encoding : packed_contents_list Data_encoding.t

  type 'kind t = 'kind operation = {
    shell : Operation.shell_header;
    protocol_data : 'kind protocol_data;
  }

  type nonrec packed = packed_operation

  val encoding : packed Data_encoding.t

  val raw : _ operation -> raw

  val hash : _ operation -> Operation_hash.t

  val hash_raw : raw -> Operation_hash.t

  val hash_packed : packed_operation -> Operation_hash.t

  val acceptable_passes : packed_operation -> int list

  type error += Missing_signature (* `Permanent *)

  type error += Invalid_signature (* `Permanent *)

  val check_signature :
    public_key -> Chain_id.t -> _ operation -> unit tzresult Lwt.t

  val check_signature_sync :
    public_key -> Chain_id.t -> _ operation -> unit tzresult

  val internal_operation_encoding : packed_internal_operation Data_encoding.t

  val pack : 'kind operation -> packed_operation

  type ('a, 'b) eq = Eq : ('a, 'a) eq

  val equal : 'a operation -> 'b operation -> ('a, 'b) eq option

  module Encoding : sig
    type 'b case =
      | Case : {
          tag : int;
          name : string;
          encoding : 'a Data_encoding.t;
          select : packed_contents -> 'b contents option;
          proj : 'b contents -> 'a;
          inj : 'a -> 'b contents;
        }
          -> 'b case

    val endorsement_case : Kind.endorsement case

    val seed_nonce_revelation_case : Kind.seed_nonce_revelation case

    val double_endorsement_evidence_case :
      Kind.double_endorsement_evidence case

    val double_baking_evidence_case : Kind.double_baking_evidence case

    val activate_account_case : Kind.activate_account case

    val proposals_case : Kind.proposals case

    val ballot_case : Kind.ballot case

    val reveal_case : Kind.reveal Kind.manager case

    val transaction_case : Kind.transaction Kind.manager case

    val origination_case : Kind.origination Kind.manager case

    val delegation_case : Kind.delegation Kind.manager case

    module Manager_operations : sig
      type 'b case =
        | MCase : {
            tag : int;
            name : string;
            encoding : 'a Data_encoding.t;
            select :
              packed_manager_operation -> 'kind manager_operation option;
            proj : 'kind manager_operation -> 'a;
            inj : 'a -> 'kind manager_operation;
          }
            -> 'kind case

      val reveal_case : Kind.reveal case

      val transaction_case : Kind.transaction case

      val origination_case : Kind.origination case

      val delegation_case : Kind.delegation case
    end
  end

  val of_list : packed_contents list -> packed_contents_list

  val to_list : packed_contents_list -> packed_contents list
end

module Roll : sig
  type t = private int32

  type roll = t

  val encoding : roll Data_encoding.t

  val snapshot_rolls : context -> context tzresult Lwt.t

  val cycle_end : context -> Cycle.t -> context tzresult Lwt.t

  val baking_rights_owner :
    context -> Level.t -> priority:int -> public_key tzresult Lwt.t

  val endorsement_rights_owner :
    context -> Level.t -> slot:int -> public_key tzresult Lwt.t

  val delegate_pubkey : context -> public_key_hash -> public_key tzresult Lwt.t

  val get_rolls :
    context -> Signature.Public_key_hash.t -> roll list tzresult Lwt.t

  val get_change :
    context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t
end

module Commitment : sig
  type t = {
    blinded_public_key_hash : Blinded_public_key_hash.t;
    amount : Tez.tez;
  }

  val get_opt :
    context -> Blinded_public_key_hash.t -> Tez.t option tzresult Lwt.t

  val delete : context -> Blinded_public_key_hash.t -> context tzresult Lwt.t
end

module Bootstrap : sig
  val cycle_end : context -> Cycle.t -> context tzresult Lwt.t
end

module Global : sig
  val get_block_priority : context -> int tzresult Lwt.t

  val set_block_priority : context -> int -> context tzresult Lwt.t
end

val prepare_first_block :
  Context.t ->
  typecheck:(context ->
            Script.t ->
            ((Script.t * Contract.big_map_diff option) * context) tzresult
            Lwt.t) ->
  level:Int32.t ->
  timestamp:Time.t ->
  fitness:Fitness.t ->
  context tzresult Lwt.t

val prepare :
  Context.t ->
  level:Int32.t ->
  predecessor_timestamp:Time.t ->
  timestamp:Time.t ->
  fitness:Fitness.t ->
  context tzresult Lwt.t

val finalize : ?commit_message:string -> context -> Updater.validation_result

val activate : context -> Protocol_hash.t -> context Lwt.t

val fork_test_chain : context -> Protocol_hash.t -> Time.t -> context Lwt.t

val record_endorsement : context -> Signature.Public_key_hash.t -> context

val allowed_endorsements :
  context ->
  (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t

val init_endorsements :
  context ->
  (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ->
  context

val included_endorsements : context -> int

val reset_internal_nonce : context -> context

val fresh_internal_nonce : context -> (context * int) tzresult

val record_internal_nonce : context -> int -> context

val internal_nonce_already_recorded : context -> int -> bool

val add_fees : context -> Tez.t -> context tzresult Lwt.t

val add_rewards : context -> Tez.t -> context tzresult Lwt.t

val add_deposit :
  context -> Signature.Public_key_hash.t -> Tez.t -> context tzresult Lwt.t

val get_fees : context -> Tez.t

val get_rewards : context -> Tez.t

val get_deposits : context -> Tez.t Signature.Public_key_hash.Map.t

val description : context Storage_description.t
src/proto_alpha/lib_protocol/alpha_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

module_type

Parameter t : Type.

Definition context := t.

Definition public_key :=
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t.

Definition public_key_hash :=
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t.

Definition signature :=
  Tezos_protocol_environment_alpha__Environment.Signature.t.

Module Tez.
  include
  
  Definition tez := t.
  
  Parameter zero : tez.
  
  Parameter one_mutez : tez.
  
  Parameter one_cent : tez.
  
  Parameter fifty_cents : tez.
  
  Parameter one : tez.
  
  Parameter op_minus_question : tez ->
    tez ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult tez.
  
  Parameter op_plus_question : tez ->
    tez ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult tez.
  
  Parameter op_star_question : tez ->
    int64 ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult tez.
  
  Parameter op_div_question : tez ->
    int64 ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult tez.
  
  Parameter of_string : string -> option tez.
  
  Parameter to_string : tez -> string.
  
  Parameter of_mutez : int64 -> option tez.
  
  Parameter to_mutez : tez -> int64.
End Tez.

Module Period.
  include
  
  Definition period := t.
  
  Parameter rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg
    period.
  
  Parameter of_seconds : int64 ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult period.
  
  Parameter to_seconds : period -> int64.
  
  Parameter mult : int32 ->
    period ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult period.
  
  Parameter zero : period.
  
  Parameter one_second : period.
  
  Parameter one_minute : period.
  
  Parameter one_hour : period.
End Period.

Module Timestamp.
  include
  
  Definition time := t.
  
  Parameter op_plus_question : time ->
    Period.t ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult time.
  
  Parameter op_minus_question : time ->
    time ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Period.t.
  
  Parameter of_notation : string -> option time.
  
  Parameter to_notation : time -> string.
  
  Parameter of_seconds : string -> option time.
  
  Parameter to_seconds_string : time -> string.
  
  Parameter current : context -> time.
End Timestamp.

Module Raw_level.
  include
  
  Definition raw_level := t.
  
  Parameter rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg
    raw_level.
  
  Parameter diff : raw_level -> raw_level -> int32.
  
  Parameter root : raw_level.
  
  Parameter succ : raw_level -> raw_level.
  
  Parameter pred : raw_level -> option raw_level.
  
  Parameter to_int32 : raw_level -> int32.
  
  Parameter of_int32 : int32 ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult raw_level.
End Raw_level.

Module Cycle.
  include
  
  Definition cycle := t.
  
  Parameter rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg
    cycle.
  
  Parameter root : cycle.
  
  Parameter succ : cycle -> cycle.
  
  Parameter pred : cycle -> option cycle.
  
  Parameter add : cycle -> Z -> cycle.
  
  Parameter sub : cycle -> Z -> option cycle.
  
  Parameter to_int32 : cycle -> int32.
  
  unhandled_module
End Cycle.

Module Gas.
  Inductive t : Type :=
  | Unaccounted : t
  | Limited : Tezos_protocol_environment_alpha__Environment.Z.t -> t.
  
  Parameter encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    t.
  
  Parameter pp : Tezos_protocol_environment_alpha__Environment.Format.formatter
    -> t -> unit.
  
  Parameter cost : Type.
  
  Parameter cost_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    cost.
  
  Parameter pp_cost : Tezos_protocol_environment_alpha__Environment.Format.formatter
    -> cost -> unit.
  
  extensible_type
  
  extensible_type
  
  extensible_type
  
  Parameter free : cost.
  
  Parameter atomic_step_cost : Z -> cost.
  
  Parameter step_cost : Z -> cost.
  
  Parameter alloc_cost : Z -> cost.
  
  Parameter alloc_bytes_cost : Z -> cost.
  
  Parameter alloc_mbytes_cost : Z -> cost.
  
  Parameter alloc_bits_cost : Z -> cost.
  
  Parameter read_bytes_cost : Tezos_protocol_environment_alpha__Environment.Z.t
    -> cost.
  
  Parameter write_bytes_cost : Tezos_protocol_environment_alpha__Environment.Z.t
    -> cost.
  
  Parameter op_star_at : Z -> cost -> cost.
  
  Parameter op_plus_at : cost -> cost -> cost.
  
  Parameter check_limit : context ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.
  
  Parameter set_limit : context ->
    Tezos_protocol_environment_alpha__Environment.Z.t -> context.
  
  Parameter set_unlimited : context -> context.
  
  Parameter consume : context ->
    cost ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult context.
  
  Parameter check_enough : context ->
    cost ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.
  
  Parameter level : context -> t.
  
  Parameter consumed : context ->
    context -> Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Parameter block_level : context ->
    Tezos_protocol_environment_alpha__Environment.Z.t.
End Gas.

unhandled_module

Module Script_timestamp.
  Parameter t : Type.
  
  Parameter compare : t -> t -> Z.
  
  Parameter to_string : t -> string.
  
  Parameter to_notation : t -> option string.
  
  Parameter to_num_str : t -> string.
  
  Parameter of_string : string -> option t.
  
  Parameter diff : t -> t -> Script_int.num Script_int.z.
  
  Parameter add_delta : t -> (Script_int.num Script_int.z) -> t.
  
  Parameter sub_delta : t -> (Script_int.num Script_int.z) -> t.
  
  Parameter now : context -> t.
  
  Parameter to_zint : t -> Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Parameter of_zint : Tezos_protocol_environment_alpha__Environment.Z.t -> t.
End Script_timestamp.

Module Script.
  Inductive prim : Type :=
  | K_parameter : prim
  | K_storage : prim
  | K_code : prim
  | D_False : prim
  | D_Elt : prim
  | D_Left : prim
  | D_None : prim
  | D_Pair : prim
  | D_Right : prim
  | D_Some : prim
  | D_True : prim
  | D_Unit : prim
  | I_PACK : prim
  | I_UNPACK : prim
  | I_BLAKE2B : prim
  | I_SHA256 : prim
  | I_SHA512 : prim
  | I_ABS : prim
  | I_ADD : prim
  | I_AMOUNT : prim
  | I_AND : prim
  | I_BALANCE : prim
  | I_CAR : prim
  | I_CDR : prim
  | I_CHAIN_ID : prim
  | I_CHECK_SIGNATURE : prim
  | I_COMPARE : prim
  | I_CONCAT : prim
  | I_CONS : prim
  | I_CREATE_ACCOUNT : prim
  | I_CREATE_CONTRACT : prim
  | I_IMPLICIT_ACCOUNT : prim
  | I_DIP : prim
  | I_DROP : prim
  | I_DUP : prim
  | I_EDIV : prim
  | I_EMPTY_BIG_MAP : prim
  | I_EMPTY_MAP : prim
  | I_EMPTY_SET : prim
  | I_EQ : prim
  | I_EXEC : prim
  | I_APPLY : prim
  | I_FAILWITH : prim
  | I_GE : prim
  | I_GET : prim
  | I_GT : prim
  | I_HASH_KEY : prim
  | I_IF : prim
  | I_IF_CONS : prim
  | I_IF_LEFT : prim
  | I_IF_NONE : prim
  | I_INT : prim
  | I_LAMBDA : prim
  | I_LE : prim
  | I_LEFT : prim
  | I_LOOP : prim
  | I_LSL : prim
  | I_LSR : prim
  | I_LT : prim
  | I_MAP : prim
  | I_MEM : prim
  | I_MUL : prim
  | I_NEG : prim
  | I_NEQ : prim
  | I_NIL : prim
  | I_NONE : prim
  | I_NOT : prim
  | I_NOW : prim
  | I_OR : prim
  | I_PAIR : prim
  | I_PUSH : prim
  | I_RIGHT : prim
  | I_SIZE : prim
  | I_SOME : prim
  | I_SOURCE : prim
  | I_SENDER : prim
  | I_SELF : prim
  | I_SLICE : prim
  | I_STEPS_TO_QUOTA : prim
  | I_SUB : prim
  | I_SWAP : prim
  | I_TRANSFER_TOKENS : prim
  | I_SET_DELEGATE : prim
  | I_UNIT : prim
  | I_UPDATE : prim
  | I_XOR : prim
  | I_ITER : prim
  | I_LOOP_LEFT : prim
  | I_ADDRESS : prim
  | I_CONTRACT : prim
  | I_ISNAT : prim
  | I_CAST : prim
  | I_RENAME : prim
  | I_DIG : prim
  | I_DUG : prim
  | T_bool : prim
  | T_contract : prim
  | T_int : prim
  | T_key : prim
  | T_key_hash : prim
  | T_lambda : prim
  | T_list : prim
  | T_map : prim
  | T_big_map : prim
  | T_nat : prim
  | T_option : prim
  | T_or : prim
  | T_pair : prim
  | T_set : prim
  | T_signature : prim
  | T_string : prim
  | T_bytes : prim
  | T_mutez : prim
  | T_timestamp : prim
  | T_unit : prim
  | T_operation : prim
  | T_address : prim
  | T_chain_id : prim.
  
  Definition location :=
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location.
  
  Definition annot :=
    Tezos_protocol_environment_alpha__Environment.Micheline.annot.
  
  Definition expr :=
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim.
  
  Definition lazy_expr :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t expr.
  
  Parameter lazy_expr : expr -> lazy_expr.
  
  Definition node :=
    Tezos_protocol_environment_alpha__Environment.Micheline.node location prim.
  
  Record t := {
    code : lazy_expr;
    storage : lazy_expr }.
  
  Parameter location_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    location.
  
  Parameter expr_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    expr.
  
  Parameter prim_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    prim.
  
  Parameter encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    t.
  
  Parameter lazy_expr_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    lazy_expr.
  
  Parameter deserialized_cost : expr -> Gas.cost.
  
  Parameter serialized_cost : Tezos_protocol_environment_alpha__Environment.MBytes.t
    -> Gas.cost.
  
  Parameter traversal_cost : node -> Gas.cost.
  
  Parameter node_cost : node -> Gas.cost.
  
  Parameter int_node_cost : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Gas.cost.
  
  Parameter int_node_cost_of_numbits : Z -> Gas.cost.
  
  Parameter string_node_cost : string -> Gas.cost.
  
  Parameter string_node_cost_of_length : Z -> Gas.cost.
  
  Parameter bytes_node_cost : Tezos_protocol_environment_alpha__Environment.MBytes.t
    -> Gas.cost.
  
  Parameter bytes_node_cost_of_length : Z -> Gas.cost.
  
  Parameter prim_node_cost_nonrec : (list expr) -> annot -> Gas.cost.
  
  Parameter prim_node_cost_nonrec_of_length : Z -> annot -> Gas.cost.
  
  Parameter seq_node_cost_nonrec : (list expr) -> Gas.cost.
  
  Parameter seq_node_cost_nonrec_of_length : Z -> Gas.cost.
  
  Parameter minimal_deserialize_cost : lazy_expr -> Gas.cost.
  
  Parameter force_decode : context ->
    lazy_expr ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (expr * context)).
  
  Parameter force_bytes : context ->
    lazy_expr ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_protocol_environment_alpha__Environment.MBytes.t * context)).
  
  Parameter unit_parameter : lazy_expr.
  
  Module Legacy_support.
    Parameter manager_script_code : lazy_expr.
    
    Parameter add_do : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
      ->
      lazy_expr ->
        lazy_expr ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (lazy_expr * lazy_expr)).
    
    Parameter add_set_delegate : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
      ->
      lazy_expr ->
        lazy_expr ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (lazy_expr * lazy_expr)).
    
    Parameter has_default_entrypoint : lazy_expr -> bool.
    
    Parameter add_root_entrypoint : lazy_expr ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          lazy_expr).
  End Legacy_support.
End Script.

Module Constants.
  Record fixed := {
    proof_of_work_nonce_size : Z;
    nonce_length : Z;
    max_revelations_per_block : Z;
    max_operation_data_length : Z;
    max_proposals_per_delegate : Z }.
  
  Parameter fixed_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    fixed.
  
  Parameter fixed : fixed.
  
  Parameter proof_of_work_nonce_size : Z.
  
  Parameter nonce_length : Z.
  
  Parameter max_revelations_per_block : Z.
  
  Parameter max_operation_data_length : Z.
  
  Parameter max_proposals_per_delegate : Z.
  
  Record parametric := {
    preserved_cycles : Z;
    blocks_per_cycle : int32;
    blocks_per_commitment : int32;
    blocks_per_roll_snapshot : int32;
    blocks_per_voting_period : int32;
    time_between_blocks : list Period.t;
    endorsers_per_block : Z;
    hard_gas_limit_per_operation :
      Tezos_protocol_environment_alpha__Environment.Z.t;
    hard_gas_limit_per_block : Tezos_protocol_environment_alpha__Environment.Z.t;
    proof_of_work_threshold : int64;
    tokens_per_roll : Tez.t;
    michelson_maximum_type_size : Z;
    seed_nonce_revelation_tip : Tez.t;
    origination_size : Z;
    block_security_deposit : Tez.t;
    endorsement_security_deposit : Tez.t;
    block_reward : Tez.t;
    endorsement_reward : Tez.t;
    cost_per_byte : Tez.t;
    hard_storage_limit_per_operation :
      Tezos_protocol_environment_alpha__Environment.Z.t;
    test_chain_duration : int64;
    quorum_min : int32;
    quorum_max : int32;
    min_proposal_quorum : int32;
    initial_endorsers : Z;
    delay_per_missing_endorsement : Period.t }.
  
  Parameter parametric_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    parametric.
  
  Parameter parametric : context -> parametric.
  
  Parameter preserved_cycles : context -> Z.
  
  Parameter blocks_per_cycle : context -> int32.
  
  Parameter blocks_per_commitment : context -> int32.
  
  Parameter blocks_per_roll_snapshot : context -> int32.
  
  Parameter blocks_per_voting_period : context -> int32.
  
  Parameter time_between_blocks : context -> list Period.t.
  
  Parameter endorsers_per_block : context -> Z.
  
  Parameter initial_endorsers : context -> Z.
  
  Parameter delay_per_missing_endorsement : context -> Period.t.
  
  Parameter hard_gas_limit_per_operation : context ->
    Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Parameter hard_gas_limit_per_block : context ->
    Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Parameter cost_per_byte : context -> Tez.t.
  
  Parameter hard_storage_limit_per_operation : context ->
    Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Parameter proof_of_work_threshold : context -> int64.
  
  Parameter tokens_per_roll : context -> Tez.t.
  
  Parameter michelson_maximum_type_size : context -> Z.
  
  Parameter block_reward : context -> Tez.t.
  
  Parameter endorsement_reward : context -> Tez.t.
  
  Parameter seed_nonce_revelation_tip : context -> Tez.t.
  
  Parameter origination_size : context -> Z.
  
  Parameter block_security_deposit : context -> Tez.t.
  
  Parameter endorsement_security_deposit : context -> Tez.t.
  
  Parameter test_chain_duration : context -> int64.
  
  Parameter quorum_min : context -> int32.
  
  Parameter quorum_max : context -> int32.
  
  Parameter min_proposal_quorum : context -> int32.
  
  Record t := {
    fixed : fixed;
    parametric : parametric }.
  
  Parameter encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    t.
End Constants.

Module Voting_period.
  include
  
  Definition voting_period := t.
  
  Parameter rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg
    voting_period.
  
  Parameter root : voting_period.
  
  Parameter succ : voting_period -> voting_period.
  
  Inductive kind : Type :=
  | Proposal : kind
  | Testing_vote : kind
  | Testing : kind
  | Promotion_vote : kind.
  
  Parameter kind_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    kind.
  
  Parameter to_int32 : voting_period -> int32.
End Voting_period.

Module Level.
  Record t := {
    level : Raw_level.t;
    level_position : int32;
    cycle : Cycle.t;
    cycle_position : int32;
    voting_period : Voting_period.t;
    voting_period_position : int32;
    expected_commitment : bool }.
  
  include
  
  Parameter pp_full : Tezos_protocol_environment_alpha__Environment.Format.formatter
    -> t -> unit.
  
  Definition level := t.
  
  Parameter root : context -> level.
  
  Parameter succ : context -> level -> level.
  
  Parameter pred : context -> level -> option level.
  
  Parameter from_raw : context -> (option int32) -> Raw_level.t -> level.
  
  Parameter diff : level -> level -> int32.
  
  Parameter current : context -> level.
  
  Parameter last_level_in_cycle : context -> Cycle.t -> level.
  
  Parameter levels_in_cycle : context -> Cycle.t -> list level.
  
  Parameter levels_in_current_cycle : context ->
    (option int32) -> unit -> list level.
  
  Parameter last_allowed_fork_level : context -> Raw_level.t.
End Level.

Module Fitness.
  include
  
  Definition fitness := t.
  
  Parameter increase : (option Z) -> context -> context.
  
  Parameter current : context -> int64.
  
  Parameter to_int64 : fitness ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64.
End Fitness.

Module Nonce.
  Parameter t : Type.
  
  Definition nonce := t.
  
  Parameter encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    nonce.
  
  Record unrevealed := {
    nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
    delegate : public_key_hash;
    rewards : Tez.t;
    fees : Tez.t }.
  
  Parameter record_hash : context ->
    unrevealed ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
  
  Parameter reveal : context ->
    Level.t ->
      nonce ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Inductive status : Type :=
  | Unrevealed : unrevealed -> status
  | Revealed : nonce -> status.
  
  Parameter get : context ->
    Level.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          status).
  
  Parameter of_bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult nonce.
  
  Parameter hash : nonce -> Tezos_raw_protocol_alpha.Nonce_hash.t.
  
  Parameter check_hash : nonce -> Tezos_raw_protocol_alpha.Nonce_hash.t -> bool.
End Nonce.

Module Seed.
  Parameter seed : Type.
  
  extensible_type
  
  Parameter for_cycle : context ->
    Cycle.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult seed).
  
  Parameter cycle_end : context ->
    Cycle.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (context * (list Nonce.unrevealed))).
  
  Parameter seed_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    seed.
End Seed.

Module Big_map.
  Definition id := Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Parameter fresh : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (context * id)).
  
  Parameter fresh_temporary : context -> context * id.
  
  Parameter mem : context ->
    id ->
      Tezos_raw_protocol_alpha.Script_expr_hash.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (context * bool)).
  
  Parameter get_opt : context ->
    id ->
      Tezos_raw_protocol_alpha.Script_expr_hash.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (context * (option Script.expr))).
  
  Parameter rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.t id.
  
  Parameter cleanup_temporary : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t context.
  
  Parameter _exists : context ->
    id ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (context * (option (Script.expr * Script.expr)))).
End Big_map.

Module Contract.
  include
  
  Definition contract := t.
  
  Parameter rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg
    contract.
  
  Parameter to_b58check : contract -> string.
  
  Parameter of_b58check : string ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult contract.
  
  Parameter implicit_contract : public_key_hash -> contract.
  
  Parameter is_implicit : contract -> option public_key_hash.
  
  Parameter _exists : context ->
    contract ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).
  
  Parameter must_exist : context ->
    contract ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).
  
  Parameter allocated : context ->
    contract ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).
  
  Parameter must_be_allocated : context ->
    contract ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).
  
  Parameter list : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t (list contract).
  
  Parameter get_manager_key : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          public_key).
  
  Parameter is_manager_key_revealed : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).
  
  Parameter reveal_manager_key : context ->
    public_key_hash ->
      public_key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter get_script_code : context ->
    contract ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (context * (option Script.lazy_expr))).
  
  Parameter get_script : context ->
    contract ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (context * (option Script.t))).
  
  Parameter get_storage : context ->
    contract ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (context * (option Script.expr))).
  
  Parameter get_counter : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Z.t).
  
  Parameter get_balance : context ->
    contract ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tez.t).
  
  Parameter init_origination_nonce : context ->
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      -> context.
  
  Parameter unset_origination_nonce : context -> context.
  
  Parameter fresh_contract_from_current_nonce : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (context * t)).
  
  Parameter originated_from_current_nonce : context ->
    context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list contract)).
  
  Inductive big_map_diff_item : Type :=
  | Update : Big_map.id -> Script.expr ->
    Tezos_raw_protocol_alpha.Script_expr_hash.t -> (option Script.expr) ->
    big_map_diff_item
  | Clear : Big_map.id -> big_map_diff_item
  | Copy : Big_map.id -> Big_map.id -> big_map_diff_item
  | Alloc : Big_map.id -> Script.expr -> Script.expr -> big_map_diff_item.
  
  Definition big_map_diff := list big_map_diff_item.
  
  Parameter big_map_diff_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    big_map_diff.
  
  Parameter originate : context ->
    contract ->
      Tez.t ->
        (Script.t * (option big_map_diff)) ->
          (option public_key_hash) ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                context).
  
  extensible_type
  
  Parameter spend : context ->
    contract ->
      Tez.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter credit : context ->
    contract ->
      Tez.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter update_script_storage : context ->
    contract ->
      Script.expr ->
        (option big_map_diff) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context).
  
  Parameter used_storage_space : context ->
    t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Z.t).
  
  Parameter increment_counter : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
  
  Parameter check_counter_increment : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            unit).
  
  Parameter origination_nonce : Type.
  
  Parameter initial_origination_nonce : Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    -> origination_nonce.
  
  Parameter originated_contract : origination_nonce -> contract.
End Contract.

Module Delegate.
  Inductive balance : Type :=
  | Contract : Contract.t -> balance
  | Rewards :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Cycle.t -> balance
  | Fees :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Cycle.t -> balance
  | Deposits :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Cycle.t -> balance.
  
  Inductive balance_update : Type :=
  | Debited : Tez.t -> balance_update
  | Credited : Tez.t -> balance_update.
  
  Definition balance_updates := list (balance * balance_update).
  
  Parameter balance_updates_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    balance_updates.
  
  Parameter cleanup_balance_updates : balance_updates -> balance_updates.
  
  Parameter get : context ->
    Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option public_key_hash)).
  
  Parameter set : context ->
    Contract.t ->
      (option public_key_hash) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter fold : forall {a : Type}, context ->
    a ->
      (public_key_hash ->
        a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t a.
  
  Parameter list : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t (list public_key_hash).
  
  Parameter freeze_deposit : context ->
    public_key_hash ->
      Tez.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter freeze_rewards : context ->
    public_key_hash ->
      Tez.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter freeze_fees : context ->
    public_key_hash ->
      Tez.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter cycle_end : context ->
    Cycle.t ->
      (list Nonce.unrevealed) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (context * balance_updates *
              (list
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))).
  
  Record frozen_balance := {
    deposit : Tez.t;
    fees : Tez.t;
    rewards : Tez.t }.
  
  Parameter punish : context ->
    public_key_hash ->
      Cycle.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (context * frozen_balance)).
  
  Parameter full_balance : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tez.t).
  
  Parameter has_frozen_balance : context ->
    public_key_hash ->
      Cycle.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            bool).
  
  Parameter frozen_balance : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tez.t).
  
  Parameter frozen_balance_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    frozen_balance.
  
  Parameter frozen_balance_by_cycle_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    (Cycle.Map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
      frozen_balance).
  
  Parameter frozen_balance_by_cycle : context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Cycle.Map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
          frozen_balance).
  
  Parameter staking_balance : context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tez.t).
  
  Parameter delegated_contracts : context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (list Tezos_raw_protocol_alpha.Contract_repr.t).
  
  Parameter delegated_balance : context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tez.t).
  
  Parameter deactivated : context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).
  
  Parameter grace_period : context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Cycle.t).
End Delegate.

Module Vote.
  Definition proposal :=
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).
  
  Parameter record_proposal : context ->
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      ->
      public_key_hash ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter get_proposals : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32)).
  
  Parameter clear_proposals : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t context.
  
  Parameter recorded_proposal_count_for_delegate : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z).
  
  Parameter listings_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    (list
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * int32)).
  
  Parameter freeze_listings : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        context).
  
  Parameter clear_listings : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        context).
  
  Parameter listing_size : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32).
  
  Parameter in_listings : context ->
    public_key_hash -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool.
  
  Parameter get_listings : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list (public_key_hash * int32)).
  
  Inductive ballot : Type :=
  | Yay : ballot
  | Nay : ballot
  | Pass : ballot.
  
  Parameter ballot_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    ballot.
  
  Record ballots := {
    yay : int32;
    nay : int32;
    pass : int32 }.
  
  Parameter ballots_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    ballots.
  
  Parameter has_recorded_ballot : context ->
    public_key_hash -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool.
  
  Parameter record_ballot : context ->
    public_key_hash ->
      ballot ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  Parameter get_ballots : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ballots).
  
  Parameter get_ballot_list : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * ballot)).
  
  Parameter clear_ballots : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t context.
  
  Parameter get_current_period_kind : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Voting_period.kind).
  
  Parameter set_current_period_kind : context ->
    Voting_period.kind ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
  
  Parameter get_current_quorum : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32).
  
  Parameter get_participation_ema : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32).
  
  Parameter set_participation_ema : context ->
    int32 ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
  
  Parameter get_current_proposal : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        proposal).
  
  Parameter init_current_proposal : context ->
    proposal ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
  
  Parameter clear_current_proposal : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        context).
End Vote.

Module Block_header.
  .
  
  Definition block_header := t.
  
  Definition raw :=
    Tezos_protocol_environment_alpha__Environment.Block_header.t.
  
  Definition shell_header :=
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header.
  
  Parameter raw : block_header -> raw.
  
  Parameter hash : block_header ->
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).
  
  Parameter hash_raw : raw ->
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).
  
  Parameter encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    block_header.
  
  Parameter raw_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    raw.
  
  Parameter contents_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    contents.
  
  Parameter unsigned_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    (shell_header * contents).
  
  Parameter protocol_data_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    protocol_data.
  
  Parameter shell_header_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    shell_header.
  
  Parameter max_header_length : Z.
End Block_header.

Module Kind.
  Inductive seed_nonce_revelation : Type :=
  | Seed_nonce_revelation_kind : seed_nonce_revelation.
  
  Inductive double_endorsement_evidence : Type :=
  | Double_endorsement_evidence_kind : double_endorsement_evidence.
  
  Inductive double_baking_evidence : Type :=
  | Double_baking_evidence_kind : double_baking_evidence.
  
  Inductive activate_account : Type :=
  | Activate_account_kind : activate_account.
  
  Inductive endorsement : Type :=
  | Endorsement_kind : endorsement.
  
  Inductive proposals : Type :=
  | Proposals_kind : proposals.
  
  Inductive ballot : Type :=
  | Ballot_kind : ballot.
  
  Inductive reveal : Type :=
  | Reveal_kind : reveal.
  
  Inductive transaction : Type :=
  | Transaction_kind : transaction.
  
  Inductive origination : Type :=
  | Origination_kind : origination.
  
  Inductive delegation : Type :=
  | Delegation_kind : delegation.
  
  Inductive manager : forall (a : Type), Type :=
  | Reveal_manager_kind : manager reveal
  | Transaction_manager_kind : manager transaction
  | Origination_manager_kind : manager origination
  | Delegation_manager_kind : manager delegation.
End Kind.

Reserved Notation "'counter".

Inductive contents_list : forall (_ : Type), Type :=
| Single : forall {kind : Type}, (contents kind) -> contents_list kind
| Cons : forall {kind rest : Type}, (contents (Kind.manager kind)) ->
  (contents_list (Kind.manager rest)) ->
  contents_list (Kind.manager (kind * rest))

with contents : forall (_ : Type), Type :=
| Endorsement : Raw_level.t -> contents Kind.endorsement
| Seed_nonce_revelation : Raw_level.t -> Nonce.t ->
  contents Kind.seed_nonce_revelation
| Double_endorsement_evidence : (operation Kind.endorsement) ->
  (operation Kind.endorsement) -> contents Kind.double_endorsement_evidence
| Double_baking_evidence : Block_header.t -> Block_header.t ->
  contents Kind.double_baking_evidence
| Activate_account :
  Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code ->
  contents Kind.activate_account
| Proposals :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Voting_period.t ->
  (list
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  -> contents Kind.proposals
| Ballot :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Voting_period.t ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> Vote.ballot -> contents Kind.ballot
| Manager_operation : forall {kind : Type},
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tez.tez -> 'counter -> (manager_operation kind) ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  contents (Kind.manager kind)

with manager_operation : forall (_ : Type), Type :=
| Reveal : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t
  -> manager_operation Kind.reveal
| Transaction : Tez.tez -> Script.lazy_expr -> string -> Contract.contract ->
  manager_operation Kind.transaction
| Origination :
  (option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  -> Script.t -> Tez.tez -> (option Contract.t) ->
  manager_operation Kind.origination
| Delegation :
  (option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  -> manager_operation Kind.delegation

where "'counter" := ( Tezos_protocol_environment_alpha__Environment.Z.t).

Definition counter := 'counter.

Record internal_operation {kind : Type} := {
  source : Contract.contract;
  operation : manager_operation kind;
  nonce : Z }.
Arguments internal_operation : clear implicits.

Inductive packed_manager_operation : Type :=
| Manager : forall {kind : Type}, (manager_operation kind) ->
  packed_manager_operation.

Inductive packed_contents : Type :=
| Contents : forall {kind : Type}, (contents kind) -> packed_contents.

Inductive packed_contents_list : Type :=
| Contents_list : forall {kind : Type}, (contents_list kind) ->
  packed_contents_list.

Inductive packed_protocol_data : Type :=
| Operation_data : forall {kind : Type}, (protocol_data kind) ->
  packed_protocol_data.

Record packed_operation := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  protocol_data : packed_protocol_data }.

Inductive packed_internal_operation : Type :=
| Internal_operation : forall {kind : Type}, (internal_operation kind) ->
  packed_internal_operation.

Parameter manager_kind : forall {kind : Type},
(manager_operation kind) -> Kind.manager kind.

Module Fees.
  Parameter origination_burn : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (context * Tez.t)).
  
  Parameter record_paid_storage_space : context ->
    Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (context * Tezos_protocol_environment_alpha__Environment.Z.t *
            Tezos_protocol_environment_alpha__Environment.Z.t * Tez.t)).
  
  Parameter start_counting_storage_fees : context -> context.
  
  Parameter burn_storage_fees : context ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Contract.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context).
  
  extensible_type
  
  extensible_type
  
  extensible_type
  
  Parameter check_storage_limit : context ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.
End Fees.

Module Operation.
  Definition contents (kind : Type) := contents kind.
  
  Definition packed_contents := packed_contents.
  
  Parameter contents_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    packed_contents.
  
  Definition protocol_data (kind : Type) := protocol_data kind.
  
  Definition packed_protocol_data := packed_protocol_data.
  
  Parameter protocol_data_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    packed_protocol_data.
  
  Parameter unsigned_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
      packed_contents_list).
  
  Record raw := {
    shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
    proto : Tezos_protocol_environment_alpha__Environment.MBytes.t }.
  
  Parameter raw_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    raw.
  
  Parameter contents_list_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    packed_contents_list.
  
  Record t {kind : Type} := {
    shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
    protocol_data : protocol_data kind }.
  Arguments t : clear implicits.
  
  Definition packed := packed_operation.
  
  Parameter encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    packed.
  
  Parameter raw : forall {_ : Type}, (operation _) -> raw.
  
  Parameter hash : forall {_ : Type}, (operation _) ->
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).
  
  Parameter hash_raw : raw ->
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).
  
  Parameter hash_packed : packed_operation ->
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).
  
  Parameter acceptable_passes : packed_operation -> list Z.
  
  extensible_type
  
  extensible_type
  
  Parameter check_signature : forall {_ : Type}, public_key ->
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      ->
      (operation _) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            unit).
  
  Parameter check_signature_sync : forall {_ : Type}, public_key ->
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      ->
      (operation _) ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.
  
  Parameter internal_operation_encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    packed_internal_operation.
  
  Parameter pack : forall {kind : Type}, (operation kind) -> packed_operation.
  
  Inductive eq (a : Type) : forall (b : Type), Type :=
  | Eq : eq a a.
  
  Arguments Eq {_}.
  
  Parameter equal : forall {a b : Type}, (operation a) ->
    (operation b) -> option (eq a b).
  
  Module Encoding.
    Inductive case (b : Type) : Type :=
    | Case : forall {a : Type}, Z -> string ->
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
      (packed_contents -> option (contents b)) -> ((contents b) -> a) ->
      (a -> contents b) -> case b.
    
    Arguments Case {_}.
    
    Parameter endorsement_case : case Kind.endorsement.
    
    Parameter seed_nonce_revelation_case : case Kind.seed_nonce_revelation.
    
    Parameter double_endorsement_evidence_case : case
      Kind.double_endorsement_evidence.
    
    Parameter double_baking_evidence_case : case Kind.double_baking_evidence.
    
    Parameter activate_account_case : case Kind.activate_account.
    
    Parameter proposals_case : case Kind.proposals.
    
    Parameter ballot_case : case Kind.ballot.
    
    Parameter reveal_case : case (Kind.manager Kind.reveal).
    
    Parameter transaction_case : case (Kind.manager Kind.transaction).
    
    Parameter origination_case : case (Kind.manager Kind.origination).
    
    Parameter delegation_case : case (Kind.manager Kind.delegation).
    
    Module Manager_operations.
      Inductive case : forall (b : Type), Type :=
      | MCase : forall {a kind : Type}, Z -> string ->
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
        (packed_manager_operation -> option (manager_operation kind)) ->
        ((manager_operation kind) -> a) -> (a -> manager_operation kind) ->
        case kind.
      
      Parameter reveal_case : case Kind.reveal.
      
      Parameter transaction_case : case Kind.transaction.
      
      Parameter origination_case : case Kind.origination.
      
      Parameter delegation_case : case Kind.delegation.
    End Manager_operations.
  End Encoding.
  
  Parameter of_list : (list packed_contents) -> packed_contents_list.
  
  Parameter to_list : packed_contents_list -> list packed_contents.
End Operation.

Module Roll.
  Definition t := int32.
  
  Definition roll := t.
  
  Parameter encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    roll.
  
  Parameter snapshot_rolls : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        context).
  
  Parameter cycle_end : context ->
    Cycle.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
  
  Parameter baking_rights_owner : context ->
    Level.t ->
      Z ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            public_key).
  
  Parameter endorsement_rights_owner : context ->
    Level.t ->
      Z ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            public_key).
  
  Parameter delegate_pubkey : context ->
    public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          public_key).
  
  Parameter get_rolls : context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list roll)).
  
  Parameter get_change : context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tez.t).
End Roll.

Module Commitment.
  Record t := {
    blinded_public_key_hash : Tezos_raw_protocol_alpha.Blinded_public_key_hash.t;
    amount : Tez.tez }.
  
  Parameter get_opt : context ->
    Tezos_raw_protocol_alpha.Blinded_public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option Tez.t)).
  
  Parameter delete : context ->
    Tezos_raw_protocol_alpha.Blinded_public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
End Commitment.

Module Bootstrap.
  Parameter cycle_end : context ->
    Cycle.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
End Bootstrap.

Module Global.
  Parameter get_block_priority : context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z).
  
  Parameter set_block_priority : context ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).
End Global.

Parameter prepare_first_block :
Tezos_protocol_environment_alpha__Environment.Context.t ->
  (context ->
    Script.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((Script.t * (option Contract.big_map_diff)) * context))) ->
    Tezos_protocol_environment_alpha__Environment.Int32.t ->
      Tezos_protocol_environment_alpha__Environment.Time.t ->
        Fitness.t ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context).

Parameter prepare :
Tezos_protocol_environment_alpha__Environment.Context.t ->
  Tezos_protocol_environment_alpha__Environment.Int32.t ->
    Tezos_protocol_environment_alpha__Environment.Time.t ->
      Tezos_protocol_environment_alpha__Environment.Time.t ->
        Fitness.t ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context).

Parameter finalize :
(option string) ->
  context ->
    Tezos_protocol_environment_alpha__Environment.Updater.validation_result.

Parameter activate :
context ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    -> Tezos_protocol_environment_alpha__Environment.Lwt.t context.

Parameter fork_test_chain :
context ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_alpha__Environment.Time.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t context.

Parameter record_endorsement :
context ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    context.

Parameter allowed_endorsements :
context ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
      (list Z) * bool).

Parameter init_endorsements :
context ->
  (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
      (list Z) * bool)) -> context.

Parameter included_endorsements : context -> Z.

Parameter reset_internal_nonce : context -> context.

Parameter fresh_internal_nonce :
context ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (context * Z).

Parameter record_internal_nonce : context -> Z -> context.

Parameter internal_nonce_already_recorded : context -> Z -> bool.

Parameter add_fees :
context ->
  Tez.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        context).

Parameter add_rewards :
context ->
  Tez.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        context).

Parameter add_deposit :
context ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tez.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).

Parameter get_fees : context -> Tez.t.

Parameter get_rewards : context -> Tez.t.

Parameter get_deposits :
context ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    Tez.t.

Parameter description : Tezos_raw_protocol_alpha.Storage_description.t context.
src/proto_alpha/lib_protocol/alpha_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root = RPC_path.open_root

module Seed = struct
  module S = struct
    open Data_encoding

    let seed =
      RPC_service.post_service
        ~description:"Seed of the cycle to which the block belongs."
        ~query:RPC_query.empty
        ~input:empty
        ~output:Seed.seed_encoding
        RPC_path.(custom_root / "context" / "seed")
  end

  let () =
    let open Services_registration in
    register0 S.seed (fun ctxt () () ->
        let l = Level.current ctxt in
        Seed.for_cycle ctxt l.cycle)

  let get ctxt block = RPC_context.make_call0 S.seed ctxt block () ()
end

module Nonce = struct
  type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten

  let info_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Revealed"
          (obj1 (req "nonce" Nonce.encoding))
          (function Revealed nonce -> Some nonce | _ -> None)
          (fun nonce -> Revealed nonce);
        case
          (Tag 1)
          ~title:"Missing"
          (obj1 (req "hash" Nonce_hash.encoding))
          (function Missing nonce -> Some nonce | _ -> None)
          (fun nonce -> Missing nonce);
        case
          (Tag 2)
          ~title:"Forgotten"
          empty
          (function Forgotten -> Some () | _ -> None)
          (fun () -> Forgotten) ]

  module S = struct
    let get =
      RPC_service.get_service
        ~description:"Info about the nonce of a previous block."
        ~query:RPC_query.empty
        ~output:info_encoding
        RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg)
  end

  let register () =
    let open Services_registration in
    register1 S.get (fun ctxt raw_level () () ->
        let level = Level.from_raw ctxt raw_level in
        Nonce.get ctxt level
        >>= function
        | Ok (Revealed nonce) ->
            return (Revealed nonce)
        | Ok (Unrevealed {nonce_hash; _}) ->
            return (Missing nonce_hash)
        | Error _ ->
            return Forgotten)

  let get ctxt block level =
    RPC_context.make_call1 S.get ctxt block level () ()
end

module Contract = Contract_services
module Constants = Constants_services
module Delegate = Delegate_services
module Helpers = Helpers_services
module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services

let register () =
  Contract.register () ;
  Constants.register () ;
  Delegate.register () ;
  Helpers.register () ;
  Nonce.register () ;
  Voting.register ()
src/proto_alpha/lib_protocol/alpha_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Definition custom_root {A : Type}
  : Tezos_protocol_environment_alpha__Environment.RPC_path.context A :=
  Tezos_protocol_environment_alpha__Environment.RPC_path.open_root.

Module Seed.
  Module S.
    Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
    
    Definition seed
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        unit Tezos_raw_protocol_alpha.Alpha_context.Seed.seed :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Seed of the cycle to which the block belongs." % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        Tezos_protocol_environment_alpha__Environment.Data_encoding.empty
        Tezos_raw_protocol_alpha.Alpha_context.Seed.seed_encoding
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
          (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
            custom_root "context" % string) "seed" % string).
  End S.
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Seed.seed) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0 S.seed
      ctxt block tt tt.
End Seed.

Module Nonce.
  Inductive info : Type :=
  | Revealed : Tezos_raw_protocol_alpha.Alpha_context.Nonce.t -> info
  | Missing : Tezos_raw_protocol_alpha.Nonce_hash.t -> info
  | Forgotten : info.
  
  Definition info_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Revealed" % string None (Tag 0)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "nonce" % string
              Tezos_raw_protocol_alpha.Alpha_context.Nonce.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Revealed nonce => Some nonce
            | _ => None
            end) (fun nonce => Revealed nonce))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "Missing" % string None (Tag 1)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "hash" % string
                Tezos_raw_protocol_alpha.Nonce_hash.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Missing nonce => Some nonce
              | _ => None
              end) (fun nonce => Missing nonce))
          (cons
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
              "Forgotten" % string None (Tag 2)
              Tezos_protocol_environment_alpha__Environment.Data_encoding.empty
              (fun function_parameter =>
                match function_parameter with
                | Forgotten => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | tt => Forgotten
                end)) []))).
  
  Module S.
    Definition get
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.raw_level) unit unit
        info :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
        (Some "Info about the nonce of a previous block." % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        info_encoding
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
            (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
              custom_root "context" % string) "nonces" % string)
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.rpc_arg).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Tezos_raw_protocol_alpha.Services_registration.register1 S.get
        (fun ctxt =>
          fun raw_level =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    let level :=
                      Tezos_raw_protocol_alpha.Alpha_context.Level.from_raw ctxt
                        None raw_level in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                      (Tezos_raw_protocol_alpha.Alpha_context.Nonce.get ctxt
                        level)
                      (fun function_parameter =>
                        match function_parameter with
                        | inl (Revealed nonce) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (Revealed nonce)
                        | inl (Unrevealed {| nonce_hash := nonce_hash |}) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (Missing nonce_hash)
                        | inr _ =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            Forgotten
                        end)
                  end
              end)
    end.
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.raw_level)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        info) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1 S.get
      ctxt block level tt tt.
End Nonce.

Definition register (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    Contract.register tt;
    Constants.register tt;
    Delegate.register tt;
    Helpers.register tt;
    Nonce.register tt;
    Voting.register tt
  end.
src/proto_alpha/lib_protocol/alpha_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

module Seed : sig
  val get : 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t
end

module Nonce : sig
  type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten

  val get :
    'a #RPC_context.simple -> 'a -> Raw_level.t -> info shell_tzresult Lwt.t
end

module Contract = Contract_services
module Constants = Constants_services
module Delegate = Delegate_services
module Helpers = Helpers_services
module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services

val register : unit -> unit
src/proto_alpha/lib_protocol/alpha_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Seed.
  Parameter get : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Seed.seed).
End Seed.

Module Nonce.
  Inductive info : Type :=
  | Revealed : Tezos_raw_protocol_alpha.Alpha_context.Nonce.t -> info
  | Missing : Tezos_raw_protocol_alpha.Nonce_hash.t -> info
  | Forgotten : info.
  
  Parameter get : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            info).
End Nonce.

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

Parameter register : unit -> unit.
src/proto_alpha/lib_protocol/amendment.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

(** Returns the proposal submitted by the most delegates.
    Returns None in case of a tie, if proposal quorum is below required
    minimum or if there are no proposals. *)
let select_winning_proposal ctxt =
  Vote.get_proposals ctxt
  >>=? fun proposals ->
  let merge proposal vote winners =
    match winners with
    | None ->
        Some ([proposal], vote)
    | Some (winners, winners_vote) as previous ->
        if Compare.Int32.(vote = winners_vote) then
          Some (proposal :: winners, winners_vote)
        else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote)
        else previous
  in
  match Protocol_hash.Map.fold merge proposals None with
  | Some ([proposal], vote) ->
      Vote.listing_size ctxt
      >>=? fun max_vote ->
      let min_proposal_quorum = Constants.min_proposal_quorum ctxt in
      let min_vote_to_pass =
        Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l
      in
      if Compare.Int32.(vote >= min_vote_to_pass) then return_some proposal
      else return_none
  | _ ->
      return_none

(* in case of a tie, let's do nothing. *)

(** A proposal is approved if it has supermajority and the participation reaches
    the current quorum.
    Supermajority means the yays are more 8/10 of casted votes.
    The participation is the ratio of all received votes, including passes, with
    respect to the number of possible votes.
    The participation EMA (exponential moving average) uses the last
    participation EMA and the current participation./
    The expected quorum is calculated using the last participation EMA, capped
    by the min/max quorum protocol constants. *)
let check_approval_and_update_participation_ema ctxt =
  Vote.get_ballots ctxt
  >>=? fun ballots ->
  Vote.listing_size ctxt
  >>=? fun maximum_vote ->
  Vote.get_participation_ema ctxt
  >>=? fun participation_ema ->
  Vote.get_current_quorum ctxt
  >>=? fun expected_quorum ->
  (* Note overflows: considering a maximum of 8e8 tokens, with roll size as
     small as 1e3, there is a maximum of 8e5 rolls and thus votes.
     In 'participation' an Int64 is used because in the worst case 'all_votes is
     8e5 and after the multiplication is 8e9, making it potentially overflow a
     signed Int32 which is 2e9. *)
  let casted_votes = Int32.add ballots.yay ballots.nay in
  let all_votes = Int32.add casted_votes ballots.pass in
  let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in
  let participation =
    (* in centile of percentage *)
    Int64.(
      to_int32 (div (mul (of_int32 all_votes) 100_00L) (of_int32 maximum_vote)))
  in
  let outcome =
    Compare.Int32.(
      participation >= expected_quorum && ballots.yay >= supermajority)
  in
  let new_participation_ema =
    Int32.(div (add (mul 8l participation_ema) (mul 2l participation)) 10l)
  in
  Vote.set_participation_ema ctxt new_participation_ema
  >>=? fun ctxt -> return (ctxt, outcome)

(** Implements the state machine of the amendment procedure.
    Note that [freeze_listings], that computes the vote weight of each delegate,
    is run at the beginning of each voting period.
*)
let start_new_voting_period ctxt =
  Vote.get_current_period_kind ctxt
  >>=? function
  | Proposal -> (
      select_winning_proposal ctxt
      >>=? fun proposal ->
      Vote.clear_proposals ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      match proposal with
      | None ->
          Vote.freeze_listings ctxt >>=? fun ctxt -> return ctxt
      | Some proposal ->
          Vote.init_current_proposal ctxt proposal
          >>=? fun ctxt ->
          Vote.freeze_listings ctxt
          >>=? fun ctxt ->
          Vote.set_current_period_kind ctxt Testing_vote
          >>=? fun ctxt -> return ctxt )
  | Testing_vote ->
      check_approval_and_update_participation_ema ctxt
      >>=? fun (ctxt, approved) ->
      Vote.clear_ballots ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      if approved then
        let expiration =
          (* in two days maximum... *)
          Time.add
            (Timestamp.current ctxt)
            (Constants.test_chain_duration ctxt)
        in
        Vote.get_current_proposal ctxt
        >>=? fun proposal ->
        fork_test_chain ctxt proposal expiration
        >>= fun ctxt ->
        Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> return ctxt
      else
        Vote.clear_current_proposal ctxt
        >>=? fun ctxt ->
        Vote.freeze_listings ctxt
        >>=? fun ctxt ->
        Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt
  | Testing ->
      Vote.freeze_listings ctxt
      >>=? fun ctxt ->
      Vote.set_current_period_kind ctxt Promotion_vote
      >>=? fun ctxt -> return ctxt
  | Promotion_vote ->
      check_approval_and_update_participation_ema ctxt
      >>=? fun (ctxt, approved) ->
      ( if approved then
        Vote.get_current_proposal ctxt
        >>=? fun proposal -> activate ctxt proposal >>= fun ctxt -> return ctxt
      else return ctxt )
      >>=? fun ctxt ->
      Vote.clear_ballots ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      Vote.clear_current_proposal ctxt
      >>=? fun ctxt ->
      Vote.freeze_listings ctxt
      >>=? fun ctxt ->
      Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt

type error +=
  | (* `Branch *)
      Invalid_proposal
  | Unexpected_proposal
  | Unauthorized_proposal
  | Too_many_proposals
  | Empty_proposal
  | Unexpected_ballot
  | Unauthorized_ballot

let () =
  let open Data_encoding in
  (* Invalid proposal *)
  register_error_kind
    `Branch
    ~id:"invalid_proposal"
    ~title:"Invalid proposal"
    ~description:"Ballot provided for a proposal that is not the current one."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid proposal")
    empty
    (function Invalid_proposal -> Some () | _ -> None)
    (fun () -> Invalid_proposal) ;
  (* Unexpected proposal *)
  register_error_kind
    `Branch
    ~id:"unexpected_proposal"
    ~title:"Unexpected proposal"
    ~description:"Proposal recorded outside of a proposal period."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected proposal")
    empty
    (function Unexpected_proposal -> Some () | _ -> None)
    (fun () -> Unexpected_proposal) ;
  (* Unauthorized proposal *)
  register_error_kind
    `Branch
    ~id:"unauthorized_proposal"
    ~title:"Unauthorized proposal"
    ~description:
      "The delegate provided for the proposal is not in the voting listings."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal")
    empty
    (function Unauthorized_proposal -> Some () | _ -> None)
    (fun () -> Unauthorized_proposal) ;
  (* Unexpected ballot *)
  register_error_kind
    `Branch
    ~id:"unexpected_ballot"
    ~title:"Unexpected ballot"
    ~description:"Ballot recorded outside of a voting period."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected ballot")
    empty
    (function Unexpected_ballot -> Some () | _ -> None)
    (fun () -> Unexpected_ballot) ;
  (* Unauthorized ballot *)
  register_error_kind
    `Branch
    ~id:"unauthorized_ballot"
    ~title:"Unauthorized ballot"
    ~description:
      "The delegate provided for the ballot is not in the voting listings."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot")
    empty
    (function Unauthorized_ballot -> Some () | _ -> None)
    (fun () -> Unauthorized_ballot) ;
  (* Too many proposals *)
  register_error_kind
    `Branch
    ~id:"too_many_proposals"
    ~title:"Too many proposals"
    ~description:
      "The delegate reached the maximum number of allowed proposals."
    ~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals")
    empty
    (function Too_many_proposals -> Some () | _ -> None)
    (fun () -> Too_many_proposals) ;
  (* Empty proposal *)
  register_error_kind
    `Branch
    ~id:"empty_proposal"
    ~title:"Empty proposal"
    ~description:"Proposal lists cannot be empty."
    ~pp:(fun ppf () -> Format.fprintf ppf "Empty proposal")
    empty
    (function Empty_proposal -> Some () | _ -> None)
    (fun () -> Empty_proposal)

(* @return [true] if [List.length l] > [n] w/o computing length *)
let rec longer_than l n =
  if Compare.Int.(n < 0) then assert false
  else
    match l with
    | [] ->
        false
    | _ :: rest ->
        if Compare.Int.(n = 0) then true
        else (* n > 0 *)
          longer_than rest (n - 1)

let record_proposals ctxt delegate proposals =
  (match proposals with [] -> fail Empty_proposal | _ :: _ -> return_unit)
  >>=? fun () ->
  Vote.get_current_period_kind ctxt
  >>=? function
  | Proposal ->
      Vote.in_listings ctxt delegate
      >>= fun in_listings ->
      if in_listings then
        Vote.recorded_proposal_count_for_delegate ctxt delegate
        >>=? fun count ->
        fail_when
          (longer_than proposals (Constants.max_proposals_per_delegate - count))
          Too_many_proposals
        >>=? fun () ->
        fold_left_s
          (fun ctxt proposal -> Vote.record_proposal ctxt proposal delegate)
          ctxt
          proposals
        >>=? fun ctxt -> return ctxt
      else fail Unauthorized_proposal
  | Testing_vote | Testing | Promotion_vote ->
      fail Unexpected_proposal

let record_ballot ctxt delegate proposal ballot =
  Vote.get_current_period_kind ctxt
  >>=? function
  | Testing_vote | Promotion_vote ->
      Vote.get_current_proposal ctxt
      >>=? fun current_proposal ->
      fail_unless
        (Protocol_hash.equal proposal current_proposal)
        Invalid_proposal
      >>=? fun () ->
      Vote.has_recorded_ballot ctxt delegate
      >>= fun has_ballot ->
      fail_when has_ballot Unauthorized_ballot
      >>=? fun () ->
      Vote.in_listings ctxt delegate
      >>= fun in_listings ->
      if in_listings then Vote.record_ballot ctxt delegate ballot
      else fail Unauthorized_ballot
  | Testing | Proposal ->
      fail Unexpected_ballot

let last_of_a_voting_period ctxt l =
  Compare.Int32.(
    Int32.succ l.Level.voting_period_position
    = Constants.blocks_per_voting_period ctxt)

let may_start_new_voting_period ctxt =
  let level = Level.current ctxt in
  if last_of_a_voting_period ctxt level then start_new_voting_period ctxt
  else return ctxt
src/proto_alpha/lib_protocol/amendment.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Definition select_winning_proposal
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.key)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_proposals ctxt)
    (fun proposals =>
      let merge {A : Type}
        (proposal : A) (vote :
        Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
        (winners :
        option
          ((list A) *
            Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)))
        : option
          ((list A) *
            Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
        match winners with
        | None => Some ((cons proposal []), vote)
        | (Some (winners, winners_vote)) as previous =>
          if
            Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              vote winners_vote then
            Some ((cons proposal winners), winners_vote)
          else
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                vote winners_vote then
              Some ((cons proposal []), vote)
            else
              previous
        end in
      match
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.fold
          merge proposals None with
      | Some (cons proposal [], vote) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Vote.listing_size ctxt)
          (fun max_vote =>
            let min_proposal_quorum :=
              Tezos_raw_protocol_alpha.Alpha_context.Constants.min_proposal_quorum
                ctxt in
            let min_vote_to_pass :=
              Tezos_protocol_environment_alpha__Environment.Int32.div
                (Tezos_protocol_environment_alpha__Environment.Int32.mul
                  min_proposal_quorum max_vote) 10000 in
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                vote min_vote_to_pass then
              Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                proposal
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.return_none)
      | _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
      end).

Definition check_approval_and_update_participation_ema
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha__Alpha_context.context * bool)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_ballots ctxt)
    (fun ballots =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Alpha_context.Vote.listing_size ctxt)
        (fun maximum_vote =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_participation_ema
              ctxt)
            (fun participation_ema =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_quorum
                  ctxt)
                (fun expected_quorum =>
                  let casted_votes :=
                    Tezos_protocol_environment_alpha__Environment.Int32.add
                      (yay ballots) (nay ballots) in
                  let all_votes :=
                    Tezos_protocol_environment_alpha__Environment.Int32.add
                      casted_votes (pass ballots) in
                  let supermajority :=
                    Tezos_protocol_environment_alpha__Environment.Int32.div
                      (Tezos_protocol_environment_alpha__Environment.Int32.mul 8
                        casted_votes) 10 in
                  let participation :=
                    Tezos_protocol_environment_alpha__Environment.Int64.to_int32
                      (Tezos_protocol_environment_alpha__Environment.Int64.div
                        (Tezos_protocol_environment_alpha__Environment.Int64.mul
                          (Tezos_protocol_environment_alpha__Environment.Int64.of_int32
                            all_votes) 10000)
                        (Tezos_protocol_environment_alpha__Environment.Int64.of_int32
                          maximum_vote)) in
                  let outcome :=
                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                      (Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                        participation expected_quorum)
                      (Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                        (yay ballots) supermajority) in
                  let new_participation_ema :=
                    Tezos_protocol_environment_alpha__Environment.Int32.div
                      (Tezos_protocol_environment_alpha__Environment.Int32.add
                        (Tezos_protocol_environment_alpha__Environment.Int32.mul
                          8 participation_ema)
                        (Tezos_protocol_environment_alpha__Environment.Int32.mul
                          2 participation)) 10 in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Vote.set_participation_ema
                      ctxt new_participation_ema)
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        (ctxt, outcome)))))).

Definition start_new_voting_period
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_period_kind ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Proposal =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (select_winning_proposal ctxt)
          (fun proposal =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
              (Tezos_raw_protocol_alpha.Alpha_context.Vote.clear_proposals ctxt)
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Alpha_context.Vote.clear_listings
                    ctxt)
                  (fun ctxt =>
                    match proposal with
                    | None =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Alpha_context.Vote.freeze_listings
                          ctxt)
                        (fun ctxt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            ctxt)
                    | Some proposal =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Alpha_context.Vote.init_current_proposal
                          ctxt proposal)
                        (fun ctxt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Alpha_context.Vote.freeze_listings
                              ctxt)
                            (fun ctxt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Alpha_context.Vote.set_current_period_kind
                                  ctxt Testing_vote)
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                    ctxt)))
                    end)))
      | Testing_vote =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_approval_and_update_participation_ema ctxt)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, approved) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Alpha_context.Vote.clear_ballots ctxt)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Vote.clear_listings
                      ctxt)
                    (fun ctxt =>
                      if approved then
                        let expiration :=
                          Tezos_protocol_environment_alpha__Environment.Time.add
                            (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.current
                              ctxt)
                            (Tezos_raw_protocol_alpha.Alpha_context.Constants.test_chain_duration
                              ctxt) in
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_proposal
                            ctxt)
                          (fun proposal =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (Tezos_raw_protocol_alpha.Alpha_context.fork_test_chain
                                ctxt proposal expiration)
                              (fun ctxt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_raw_protocol_alpha.Alpha_context.Vote.set_current_period_kind
                                    ctxt Testing)
                                  (fun ctxt =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                      ctxt)))
                      else
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Vote.clear_current_proposal
                            ctxt)
                          (fun ctxt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Alpha_context.Vote.freeze_listings
                                ctxt)
                              (fun ctxt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_raw_protocol_alpha.Alpha_context.Vote.set_current_period_kind
                                    ctxt Proposal)
                                  (fun ctxt =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                      ctxt)))))
            end)
      | Testing =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Vote.freeze_listings ctxt)
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Alpha_context.Vote.set_current_period_kind
                ctxt Promotion_vote)
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ctxt))
      | Promotion_vote =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_approval_and_update_participation_ema ctxt)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, approved) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (if approved then
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_proposal
                      ctxt)
                    (fun proposal =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                        (Tezos_raw_protocol_alpha.Alpha_context.activate ctxt
                          proposal)
                        (fun ctxt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            ctxt))
                else
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (Tezos_raw_protocol_alpha.Alpha_context.Vote.clear_ballots
                      ctxt)
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Alpha_context.Vote.clear_listings
                          ctxt)
                        (fun ctxt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Alpha_context.Vote.clear_current_proposal
                              ctxt)
                            (fun ctxt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Alpha_context.Vote.freeze_listings
                                  ctxt)
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Alpha_context.Vote.set_current_period_kind
                                      ctxt Proposal)
                                    (fun ctxt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                        ctxt))))))
            end)
      end).

Fixpoint longer_than {A : Type}
  (l : list A)
  (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : bool :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      n 0 then
    false
  else
    match l with
    | [] => false
    | cons _ rest =>
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          n 0 then
        true
      else
        longer_than rest
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus n 1)
    end.

Definition record_proposals
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (delegate : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  (proposals :
    list
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    match proposals with
    | [] =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
        Empty_proposal
    | cons _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
    end
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_period_kind
            ctxt)
          (fun function_parameter =>
            match function_parameter with
            | Proposal =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Alpha_context.Vote.in_listings ctxt
                  delegate)
                (fun in_listings =>
                  if in_listings then
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Vote.recorded_proposal_count_for_delegate
                        ctxt delegate)
                      (fun count =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_when
                            (longer_than proposals
                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                Tezos_raw_protocol_alpha.Alpha_context.Constants.max_proposals_per_delegate
                                count)) Too_many_proposals)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                  (fun ctxt =>
                                    fun proposal =>
                                      Tezos_raw_protocol_alpha.Alpha_context.Vote.record_proposal
                                        ctxt proposal delegate) ctxt proposals)
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                    ctxt)
                            end))
                  else
                    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                      Unauthorized_proposal)
            | Testing_vote | Testing | Promotion_vote =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                Unexpected_proposal
            end)
      end).

Definition record_ballot
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (delegate : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  (proposal :
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ballot : Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_period_kind ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Testing_vote | Promotion_vote =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_proposal ctxt)
          (fun current_proposal =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                (Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                  proposal current_proposal) Invalid_proposal)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (Tezos_raw_protocol_alpha.Alpha_context.Vote.has_recorded_ballot
                      ctxt delegate)
                    (fun has_ballot =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_when
                          has_ballot Unauthorized_ballot)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (Tezos_raw_protocol_alpha.Alpha_context.Vote.in_listings
                                ctxt delegate)
                              (fun in_listings =>
                                if in_listings then
                                  Tezos_raw_protocol_alpha.Alpha_context.Vote.record_ballot
                                    ctxt delegate ballot
                                else
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                    Unauthorized_ballot)
                          end))
                end))
      | Testing | Proposal =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          Unexpected_ballot
      end).

Definition last_of_a_voting_period
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (l : Tezos_raw_protocol_alpha.Alpha_context.Level.t) : bool :=
  Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
    (Tezos_protocol_environment_alpha__Environment.Int32.succ
      (Level.voting_period_position l))
    (Tezos_raw_protocol_alpha.Alpha_context.Constants.blocks_per_voting_period
      ctxt).

Definition may_start_new_voting_period
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  let level := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
  if last_of_a_voting_period ctxt level then
    start_new_voting_period ctxt
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt.
src/proto_alpha/lib_protocol/amendment.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**
   Only delegates with at least one roll take part in the amendment procedure.
   It works as follows:
   - Proposal period: delegates can submit protocol amendment proposals using
     the proposal operation. At the end of a proposal period, the proposal with
     most supporters is selected and we move to a testing_vote period.
     If there are no proposals, or a tie between proposals, a new proposal
     period starts.
   - Testing_vote period: delegates can cast votes to test or not the winning
     proposal using the ballot operation.
     At the end of a testing_vote period if participation reaches the quorum
     and the proposal has a supermajority in favor, we proceed to a testing
     period. Otherwise we go back to a proposal period.
     In any case, if there is enough participation the quorum is updated.
   - Testing period: a test chain is forked for the lengh of the period.
     At the end of a testing period we move to a promotion_vote period.
   - Promotion_vote period: delegates can cast votes to promote or not the
     tested proposal using the ballot operation.
     At the end of a promotion_vote period if participation reaches the quorum
     and the tested proposal has a supermajority in favor, it is activated as
     the new protocol. Otherwise we go back to a proposal period.
     In any case, if there is enough participation the quorum is updated.
*)

open Alpha_context

(** If at the end of a voting period, moves to the next one following
    the state machine of the amendment procedure. *)
val may_start_new_voting_period : context -> context tzresult Lwt.t

type error +=
  | Unexpected_proposal
  | Unauthorized_proposal
  | Too_many_proposals
  | Empty_proposal

(** Records a list of proposals for a delegate.
    @raise Unexpected_proposal if [ctxt] is not in a proposal period.
    @raise Unauthorized_proposal if [delegate] is not in the listing. *)
val record_proposals :
  context -> public_key_hash -> Protocol_hash.t list -> context tzresult Lwt.t

type error += Invalid_proposal | Unexpected_ballot | Unauthorized_ballot

val record_ballot :
  context ->
  public_key_hash ->
  Protocol_hash.t ->
  Vote.ballot ->
  context tzresult Lwt.t
src/proto_alpha/lib_protocol/amendment.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter may_start_new_voting_period :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context).

extensible_type

Parameter record_proposals :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
    (list
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Alpha_context.context).

extensible_type

Parameter record_ballot :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      ->
      Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Alpha_context.context).
src/proto_alpha/lib_protocol/apply.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Main Entry Points *)

open Alpha_context

type error += Wrong_voting_period of Voting_period.t * Voting_period.t

(* `Temporary *)

type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t

(* `Temporary *)

type error += Duplicate_endorsement of Signature.Public_key_hash.t

(* `Branch *)

type error += Invalid_endorsement_level

type error += Invalid_commitment of {expected : bool}

type error += Internal_operation_replay of packed_internal_operation

type error += Invalid_double_endorsement_evidence (* `Permanent *)

type error +=
  | Inconsistent_double_endorsement_evidence of {
      delegate1 : Signature.Public_key_hash.t;
      delegate2 : Signature.Public_key_hash.t;
    }

(* `Permanent *)

type error += Unrequired_double_endorsement_evidence (* `Branch*)

type error +=
  | Too_early_double_endorsement_evidence of {
      level : Raw_level.t;
      current : Raw_level.t;
    }

(* `Temporary *)

type error +=
  | Outdated_double_endorsement_evidence of {
      level : Raw_level.t;
      last : Raw_level.t;
    }

(* `Permanent *)

type error +=
  | Invalid_double_baking_evidence of {
      hash1 : Block_hash.t;
      level1 : Int32.t;
      hash2 : Block_hash.t;
      level2 : Int32.t;
    }

(* `Permanent *)

type error +=
  | Inconsistent_double_baking_evidence of {
      delegate1 : Signature.Public_key_hash.t;
      delegate2 : Signature.Public_key_hash.t;
    }

(* `Permanent *)

type error += Unrequired_double_baking_evidence (* `Branch*)

type error +=
  | Too_early_double_baking_evidence of {
      level : Raw_level.t;
      current : Raw_level.t;
    }

(* `Temporary *)

type error +=
  | Outdated_double_baking_evidence of {
      level : Raw_level.t;
      last : Raw_level.t;
    }

(* `Permanent *)

type error += Invalid_activation of {pkh : Ed25519.Public_key_hash.t}

type error += Multiple_revelation

type error += Gas_quota_exceeded_init_deserialize (* Permanent *)

type error +=
  | Not_enough_endorsements_for_priority of {
      required : int;
      priority : int;
      endorsements : int;
      timestamp : Time.t;
    }

let () =
  register_error_kind
    `Temporary
    ~id:"operation.wrong_endorsement_predecessor"
    ~title:"Wrong endorsement predecessor"
    ~description:
      "Trying to include an endorsement in a block that is not the successor \
       of the endorsed one"
    ~pp:(fun ppf (e, p) ->
      Format.fprintf
        ppf
        "Wrong predecessor %a, expected %a"
        Block_hash.pp
        p
        Block_hash.pp
        e)
    Data_encoding.(
      obj2
        (req "expected" Block_hash.encoding)
        (req "provided" Block_hash.encoding))
    (function
      | Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None)
    (fun (e, p) -> Wrong_endorsement_predecessor (e, p)) ;
  register_error_kind
    `Temporary
    ~id:"operation.wrong_voting_period"
    ~title:"Wrong voting period"
    ~description:
      "Trying to onclude a proposal or ballot meant for another voting period"
    ~pp:(fun ppf (e, p) ->
      Format.fprintf
        ppf
        "Wrong voting period %a, current is %a"
        Voting_period.pp
        p
        Voting_period.pp
        e)
    Data_encoding.(
      obj2
        (req "current" Voting_period.encoding)
        (req "provided" Voting_period.encoding))
    (function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None)
    (fun (e, p) -> Wrong_voting_period (e, p)) ;
  register_error_kind
    `Branch
    ~id:"operation.duplicate_endorsement"
    ~title:"Duplicate endorsement"
    ~description:"Two endorsements received from same delegate"
    ~pp:(fun ppf k ->
      Format.fprintf
        ppf
        "Duplicate endorsement from delegate %a (possible replay attack)."
        Signature.Public_key_hash.pp_short
        k)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function Duplicate_endorsement k -> Some k | _ -> None)
    (fun k -> Duplicate_endorsement k) ;
  register_error_kind
    `Temporary
    ~id:"operation.invalid_endorsement_level"
    ~title:"Unexpected level in endorsement"
    ~description:
      "The level of an endorsement is inconsistent with the  provided block \
       hash."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected level in endorsement.")
    Data_encoding.unit
    (function Invalid_endorsement_level -> Some () | _ -> None)
    (fun () -> Invalid_endorsement_level) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_commitment"
    ~title:"Invalid commitment in block header"
    ~description:"The block header has invalid commitment."
    ~pp:(fun ppf expected ->
      if expected then
        Format.fprintf ppf "Missing seed's nonce commitment in block header."
      else
        Format.fprintf
          ppf
          "Unexpected seed's nonce commitment in block header.")
    Data_encoding.(obj1 (req "expected" bool))
    (function Invalid_commitment {expected} -> Some expected | _ -> None)
    (fun expected -> Invalid_commitment {expected}) ;
  register_error_kind
    `Permanent
    ~id:"internal_operation_replay"
    ~title:"Internal operation replay"
    ~description:"An internal operation was emitted twice by a script"
    ~pp:(fun ppf (Internal_operation {nonce; _}) ->
      Format.fprintf
        ppf
        "Internal operation %d was emitted twice by a script"
        nonce)
    Operation.internal_operation_encoding
    (function Internal_operation_replay op -> Some op | _ -> None)
    (fun op -> Internal_operation_replay op) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_double_endorsement_evidence"
    ~title:"Invalid double endorsement evidence"
    ~description:"A double-endorsement evidence is malformed"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Malformed double-endorsement evidence")
    Data_encoding.empty
    (function Invalid_double_endorsement_evidence -> Some () | _ -> None)
    (fun () -> Invalid_double_endorsement_evidence) ;
  register_error_kind
    `Permanent
    ~id:"block.inconsistent_double_endorsement_evidence"
    ~title:"Inconsistent double endorsement evidence"
    ~description:
      "A double-endorsement evidence is inconsistent  (two distinct delegates)"
    ~pp:(fun ppf (delegate1, delegate2) ->
      Format.fprintf
        ppf
        "Inconsistent double-endorsement evidence  (distinct delegate: %a and \
         %a)"
        Signature.Public_key_hash.pp_short
        delegate1
        Signature.Public_key_hash.pp_short
        delegate2)
    Data_encoding.(
      obj2
        (req "delegate1" Signature.Public_key_hash.encoding)
        (req "delegate2" Signature.Public_key_hash.encoding))
    (function
      | Inconsistent_double_endorsement_evidence {delegate1; delegate2} ->
          Some (delegate1, delegate2)
      | _ ->
          None)
    (fun (delegate1, delegate2) ->
      Inconsistent_double_endorsement_evidence {delegate1; delegate2}) ;
  register_error_kind
    `Branch
    ~id:"block.unrequired_double_endorsement_evidence"
    ~title:"Unrequired double endorsement evidence"
    ~description:"A double-endorsement evidence is unrequired"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "A valid double-endorsement operation cannot  be applied: the \
         associated delegate  has previously been denunciated in this cycle.")
    Data_encoding.empty
    (function Unrequired_double_endorsement_evidence -> Some () | _ -> None)
    (fun () -> Unrequired_double_endorsement_evidence) ;
  register_error_kind
    `Temporary
    ~id:"block.too_early_double_endorsement_evidence"
    ~title:"Too early double endorsement evidence"
    ~description:"A double-endorsement evidence is in the future"
    ~pp:(fun ppf (level, current) ->
      Format.fprintf
        ppf
        "A double-endorsement evidence is in the future  (current level: %a, \
         endorsement level: %a)"
        Raw_level.pp
        current
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
    (function
      | Too_early_double_endorsement_evidence {level; current} ->
          Some (level, current)
      | _ ->
          None)
    (fun (level, current) ->
      Too_early_double_endorsement_evidence {level; current}) ;
  register_error_kind
    `Permanent
    ~id:"block.outdated_double_endorsement_evidence"
    ~title:"Outdated double endorsement evidence"
    ~description:"A double-endorsement evidence is outdated."
    ~pp:(fun ppf (level, last) ->
      Format.fprintf
        ppf
        "A double-endorsement evidence is outdated  (last acceptable level: \
         %a, endorsement level: %a)"
        Raw_level.pp
        last
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
    (function
      | Outdated_double_endorsement_evidence {level; last} ->
          Some (level, last)
      | _ ->
          None)
    (fun (level, last) -> Outdated_double_endorsement_evidence {level; last}) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_double_baking_evidence"
    ~title:"Invalid double baking evidence"
    ~description:
      "A double-baking evidence is inconsistent  (two distinct level)"
    ~pp:(fun ppf (hash1, level1, hash2, level2) ->
      Format.fprintf
        ppf
        "Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)"
        Block_hash.pp
        hash1
        Block_hash.pp
        hash2
        level1
        level2)
    Data_encoding.(
      obj4
        (req "hash1" Block_hash.encoding)
        (req "level1" int32)
        (req "hash2" Block_hash.encoding)
        (req "level2" int32))
    (function
      | Invalid_double_baking_evidence {hash1; level1; hash2; level2} ->
          Some (hash1, level1, hash2, level2)
      | _ ->
          None)
    (fun (hash1, level1, hash2, level2) ->
      Invalid_double_baking_evidence {hash1; level1; hash2; level2}) ;
  register_error_kind
    `Permanent
    ~id:"block.inconsistent_double_baking_evidence"
    ~title:"Inconsistent double baking evidence"
    ~description:
      "A double-baking evidence is inconsistent  (two distinct delegates)"
    ~pp:(fun ppf (delegate1, delegate2) ->
      Format.fprintf
        ppf
        "Inconsistent double-baking evidence  (distinct delegate: %a and %a)"
        Signature.Public_key_hash.pp_short
        delegate1
        Signature.Public_key_hash.pp_short
        delegate2)
    Data_encoding.(
      obj2
        (req "delegate1" Signature.Public_key_hash.encoding)
        (req "delegate2" Signature.Public_key_hash.encoding))
    (function
      | Inconsistent_double_baking_evidence {delegate1; delegate2} ->
          Some (delegate1, delegate2)
      | _ ->
          None)
    (fun (delegate1, delegate2) ->
      Inconsistent_double_baking_evidence {delegate1; delegate2}) ;
  register_error_kind
    `Branch
    ~id:"block.unrequired_double_baking_evidence"
    ~title:"Unrequired double baking evidence"
    ~description:"A double-baking evidence is unrequired"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "A valid double-baking operation cannot  be applied: the associated \
         delegate  has previously been denunciated in this cycle.")
    Data_encoding.empty
    (function Unrequired_double_baking_evidence -> Some () | _ -> None)
    (fun () -> Unrequired_double_baking_evidence) ;
  register_error_kind
    `Temporary
    ~id:"block.too_early_double_baking_evidence"
    ~title:"Too early double baking evidence"
    ~description:"A double-baking evidence is in the future"
    ~pp:(fun ppf (level, current) ->
      Format.fprintf
        ppf
        "A double-baking evidence is in the future  (current level: %a, \
         baking level: %a)"
        Raw_level.pp
        current
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
    (function
      | Too_early_double_baking_evidence {level; current} ->
          Some (level, current)
      | _ ->
          None)
    (fun (level, current) -> Too_early_double_baking_evidence {level; current}) ;
  register_error_kind
    `Permanent
    ~id:"block.outdated_double_baking_evidence"
    ~title:"Outdated double baking evidence"
    ~description:"A double-baking evidence is outdated."
    ~pp:(fun ppf (level, last) ->
      Format.fprintf
        ppf
        "A double-baking evidence is outdated  (last acceptable level: %a, \
         baking level: %a)"
        Raw_level.pp
        last
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
    (function
      | Outdated_double_baking_evidence {level; last} ->
          Some (level, last)
      | _ ->
          None)
    (fun (level, last) -> Outdated_double_baking_evidence {level; last}) ;
  register_error_kind
    `Permanent
    ~id:"operation.invalid_activation"
    ~title:"Invalid activation"
    ~description:
      "The given key and secret do not correspond to any existing \
       preallocated contract"
    ~pp:(fun ppf pkh ->
      Format.fprintf
        ppf
        "Invalid activation. The public key %a does not match any commitment."
        Ed25519.Public_key_hash.pp
        pkh)
    Data_encoding.(obj1 (req "pkh" Ed25519.Public_key_hash.encoding))
    (function Invalid_activation {pkh} -> Some pkh | _ -> None)
    (fun pkh -> Invalid_activation {pkh}) ;
  register_error_kind
    `Permanent
    ~id:"block.multiple_revelation"
    ~title:"Multiple revelations were included in a manager operation"
    ~description:
      "A manager operation should not contain more than one revelation"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Multiple revelations were included in a manager operation")
    Data_encoding.empty
    (function Multiple_revelation -> Some () | _ -> None)
    (fun () -> Multiple_revelation) ;
  register_error_kind
    `Permanent
    ~id:"gas_exhausted.init_deserialize"
    ~title:"Not enough gas for initial deserialization of script expresions"
    ~description:
      "Gas limit was not high enough to deserialize the transaction \
       parameters or origination script code or initial storage, making the \
       operation impossible to parse within the provided gas bounds."
    Data_encoding.empty
    (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None)
    (fun () -> Gas_quota_exceeded_init_deserialize) ;
  register_error_kind
    `Permanent
    ~id:"operation.not_enought_endorsements_for_priority"
    ~title:"Not enough endorsements for priority"
    ~description:
      "The block being validated does not include the required minimum number \
       of endorsements for this priority."
    ~pp:(fun ppf (required, endorsements, priority, timestamp) ->
      Format.fprintf
        ppf
        "Wrong number of endorsements (%i) for priority (%i), %i are expected \
         at %a"
        endorsements
        priority
        required
        Time.pp_hum
        timestamp)
    Data_encoding.(
      obj4
        (req "required" int31)
        (req "endorsements" int31)
        (req "priority" int31)
        (req "timestamp" Time.encoding))
    (function
      | Not_enough_endorsements_for_priority
          {required; endorsements; priority; timestamp} ->
          Some (required, endorsements, priority, timestamp)
      | _ ->
          None)
    (fun (required, endorsements, priority, timestamp) ->
      Not_enough_endorsements_for_priority
        {required; endorsements; priority; timestamp})

open Apply_results

let apply_manager_operation_content :
    type kind.
    Alpha_context.t ->
    Script_ir_translator.unparsing_mode ->
    payer:Contract.t ->
    source:Contract.t ->
    chain_id:Chain_id.t ->
    internal:bool ->
    kind manager_operation ->
    ( context
    * kind successful_manager_operation_result
    * packed_internal_operation list )
    tzresult
    Lwt.t =
 fun ctxt mode ~payer ~source ~chain_id ~internal operation ->
  let before_operation =
    (* This context is not used for backtracking. Only to compute
         gas consumption and originations for the operation result. *)
    ctxt
  in
  Contract.must_exist ctxt source
  >>=? fun () ->
  Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation)
  >>=? fun ctxt ->
  match operation with
  | Reveal _ ->
      return
        (* No-op: action already performed by `precheck_manager_contents`. *)
        ( ctxt,
          ( Reveal_result
              {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}
            : kind successful_manager_operation_result ),
          [] )
  | Transaction {amount; parameters; destination; entrypoint} -> (
      Contract.spend ctxt source amount
      >>=? fun ctxt ->
      ( match Contract.is_implicit destination with
      | None ->
          return (ctxt, [], false)
      | Some _ -> (
          Contract.allocated ctxt destination
          >>=? function
          | true ->
              return (ctxt, [], false)
          | false ->
              Fees.origination_burn ctxt
              >>=? fun (ctxt, origination_burn) ->
              return
                ( ctxt,
                  [(Delegate.Contract payer, Delegate.Debited origination_burn)],
                  true ) ) )
      >>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract)
               ->
      Contract.credit ctxt destination amount
      >>=? fun ctxt ->
      Contract.get_script ctxt destination
      >>=? fun (ctxt, script) ->
      match script with
      | None ->
          ( match entrypoint with
          | "default" ->
              return ()
          | entrypoint ->
              fail (Script_tc_errors.No_such_entrypoint entrypoint) )
          >>=? (fun () ->
                 Script.force_decode ctxt parameters
                 >>=? fun (arg, ctxt) ->
                 (* see [note] *)
                 (* [note]: for toplevel ops, cost is nil since the
               lazy value has already been forced at precheck, so
               we compute and consume the full cost again *)
                 let cost_arg = Script.deserialized_cost arg in
                 Lwt.return (Gas.consume ctxt cost_arg)
                 >>=? fun ctxt ->
                 match Micheline.root arg with
                 | Prim (_, D_Unit, [], _) ->
                     (* Allow [Unit] parameter to non-scripted contracts. *)
                     return ctxt
                 | _ ->
                     fail
                       (Script_interpreter.Bad_contract_parameter destination))
          >>=? fun ctxt ->
          let result =
            Transaction_result
              {
                storage = None;
                big_map_diff = None;
                balance_updates =
                  Delegate.cleanup_balance_updates
                    ( [ (Delegate.Contract source, Delegate.Debited amount);
                        (Contract destination, Credited amount) ]
                    @ maybe_burn_balance_update );
                originated_contracts = [];
                consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
                storage_size = Z.zero;
                paid_storage_size_diff = Z.zero;
                allocated_destination_contract;
              }
          in
          return (ctxt, result, [])
      | Some script ->
          Script.force_decode ctxt parameters
          >>=? fun (parameter, ctxt) ->
          (* see [note] *)
          let cost_parameter = Script.deserialized_cost parameter in
          Lwt.return (Gas.consume ctxt cost_parameter)
          >>=? fun ctxt ->
          let step_constants =
            let open Script_interpreter in
            {source; payer; self = destination; amount; chain_id}
          in
          Script_interpreter.execute
            ctxt
            mode
            step_constants
            ~script
            ~parameter
            ~entrypoint
          >>=? fun {ctxt; storage; big_map_diff; operations} ->
          Contract.update_script_storage ctxt destination storage big_map_diff
          >>=? fun ctxt ->
          Fees.record_paid_storage_space ctxt destination
          >>=? fun (ctxt, new_size, paid_storage_size_diff, fees) ->
          Contract.originated_from_current_nonce
            ~since:before_operation
            ~until:ctxt
          >>=? fun originated_contracts ->
          let result =
            Transaction_result
              {
                storage = Some storage;
                big_map_diff;
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract payer, Debited fees);
                      (Contract source, Debited amount);
                      (Contract destination, Credited amount) ];
                originated_contracts;
                consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
                storage_size = new_size;
                paid_storage_size_diff;
                allocated_destination_contract;
              }
          in
          return (ctxt, result, operations) )
  | Origination {delegate; script; preorigination; credit} ->
      Script.force_decode ctxt script.storage
      >>=? fun (unparsed_storage, ctxt) ->
      (* see [note] *)
      Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage))
      >>=? fun ctxt ->
      Script.force_decode ctxt script.code
      >>=? fun (unparsed_code, ctxt) ->
      (* see [note] *)
      Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code))
      >>=? fun ctxt ->
      Script_ir_translator.parse_script ctxt ~legacy:false script
      >>=? fun (Ex_script parsed_script, ctxt) ->
      Script_ir_translator.collect_big_maps
        ctxt
        parsed_script.storage_type
        parsed_script.storage
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = Script_ir_translator.no_big_map_id in
      Script_ir_translator.extract_big_map_diff
        ctxt
        Optimized
        parsed_script.storage_type
        parsed_script.storage
        ~to_duplicate
        ~to_update
        ~temporary:false
      >>=? fun (storage, big_map_diff, ctxt) ->
      Script_ir_translator.unparse_data
        ctxt
        Optimized
        parsed_script.storage_type
        storage
      >>=? fun (storage, ctxt) ->
      let storage = Script.lazy_expr (Micheline.strip_locations storage) in
      let script = {script with storage} in
      Contract.spend ctxt source credit
      >>=? fun ctxt ->
      ( match preorigination with
      | Some contract ->
          assert internal ;
          (* The preorigination field is only used to early return
                 the address of an originated contract in Michelson.
                 It cannot come from the outside. *)
          return (ctxt, contract)
      | None ->
          Contract.fresh_contract_from_current_nonce ctxt )
      >>=? fun (ctxt, contract) ->
      Contract.originate
        ctxt
        contract
        ~delegate
        ~balance:credit
        ~script:(script, big_map_diff)
      >>=? fun ctxt ->
      Fees.origination_burn ctxt
      >>=? fun (ctxt, origination_burn) ->
      Fees.record_paid_storage_space ctxt contract
      >>=? fun (ctxt, size, paid_storage_size_diff, fees) ->
      let result =
        Origination_result
          {
            big_map_diff;
            balance_updates =
              Delegate.cleanup_balance_updates
                [ (Contract payer, Debited fees);
                  (Contract payer, Debited origination_burn);
                  (Contract source, Debited credit);
                  (Contract contract, Credited credit) ];
            originated_contracts = [contract];
            consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
            storage_size = size;
            paid_storage_size_diff;
          }
      in
      return (ctxt, result, [])
  | Delegation delegate ->
      Delegate.set ctxt source delegate
      >>=? fun ctxt ->
      return
        ( ctxt,
          Delegation_result
            {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt},
          [] )

let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops =
  let rec apply ctxt applied worklist =
    match worklist with
    | [] ->
        Lwt.return (`Success ctxt, List.rev applied)
    | Internal_operation ({source; operation; nonce} as op) :: rest -> (
        ( if internal_nonce_already_recorded ctxt nonce then
          fail (Internal_operation_replay (Internal_operation op))
        else
          let ctxt = record_internal_nonce ctxt nonce in
          apply_manager_operation_content
            ctxt
            mode
            ~source
            ~payer
            ~chain_id
            ~internal:true
            operation )
        >>= function
        | Error errors ->
            let result =
              Internal_operation_result
                (op, Failed (manager_kind op.operation, errors))
            in
            let skipped =
              List.rev_map
                (fun (Internal_operation op) ->
                  Internal_operation_result
                    (op, Skipped (manager_kind op.operation)))
                rest
            in
            Lwt.return (`Failure, List.rev (skipped @ (result :: applied)))
        | Ok (ctxt, result, emitted) ->
            apply
              ctxt
              (Internal_operation_result (op, Applied result) :: applied)
              (rest @ emitted) )
  in
  apply ctxt [] ops

let precheck_manager_contents (type kind) ctxt chain_id raw_operation
    (op : kind Kind.manager contents) : context tzresult Lwt.t =
  let (Manager_operation
        {source; fee; counter; operation; gas_limit; storage_limit}) =
    op
  in
  Lwt.return (Gas.check_limit ctxt gas_limit)
  >>=? fun () ->
  let ctxt = Gas.set_limit ctxt gas_limit in
  Lwt.return (Fees.check_storage_limit ctxt storage_limit)
  >>=? fun () ->
  Contract.must_be_allocated ctxt (Contract.implicit_contract source)
  >>=? fun () ->
  Contract.check_counter_increment ctxt source counter
  >>=? fun () ->
  ( match operation with
  | Reveal pk ->
      Contract.reveal_manager_key ctxt source pk
  | Transaction {parameters; _} ->
      (* Fail quickly if not enough gas for minimal deserialization cost *)
      Lwt.return
      @@ record_trace Gas_quota_exceeded_init_deserialize
      @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters)
      >>=? fun () ->
      (* Fail if not enough gas for complete deserialization cost *)
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt parameters
      >>|? fun (_arg, ctxt) -> ctxt
  | Origination {script; _} ->
      (* Fail quickly if not enough gas for minimal deserialization cost *)
      Lwt.return
      @@ record_trace Gas_quota_exceeded_init_deserialize
      @@ ( Gas.consume ctxt (Script.minimal_deserialize_cost script.code)
         >>? fun ctxt ->
         Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)
         )
      >>=? fun () ->
      (* Fail if not enough gas for complete deserialization cost *)
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt script.code
      >>=? fun (_code, ctxt) ->
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt script.storage
      >>|? fun (_storage, ctxt) -> ctxt
  | _ ->
      return ctxt )
  >>=? fun ctxt ->
  Contract.get_manager_key ctxt source
  >>=? fun public_key ->
  (* Currently, the `raw_operation` only contains one signature, so
     all operations are required to be from the same manager. This may
     change in the future, allowing several managers to group-sign a
     sequence of transactions.  *)
  Operation.check_signature public_key chain_id raw_operation
  >>=? fun () ->
  Contract.increment_counter ctxt source
  >>=? fun ctxt ->
  Contract.spend ctxt (Contract.implicit_contract source) fee
  >>=? fun ctxt -> add_fees ctxt fee >>=? fun ctxt -> return ctxt

let apply_manager_contents (type kind) ctxt mode chain_id
    (op : kind Kind.manager contents) :
    ( [`Success of context | `Failure]
    * kind manager_operation_result
    * packed_internal_operation_result list )
    Lwt.t =
  let (Manager_operation {source; operation; gas_limit; storage_limit}) = op in
  let ctxt = Gas.set_limit ctxt gas_limit in
  let ctxt = Fees.start_counting_storage_fees ctxt in
  let source = Contract.implicit_contract source in
  apply_manager_operation_content
    ctxt
    mode
    ~source
    ~payer:source
    ~internal:false
    ~chain_id
    operation
  >>= function
  | Ok (ctxt, operation_results, internal_operations) -> (
      apply_internal_manager_operations
        ctxt
        mode
        ~payer:source
        ~chain_id
        internal_operations
      >>= function
      | (`Success ctxt, internal_operations_results) -> (
          Fees.burn_storage_fees ctxt ~storage_limit ~payer:source
          >>= function
          | Ok ctxt ->
              Lwt.return
                ( `Success ctxt,
                  Applied operation_results,
                  internal_operations_results )
          | Error errors ->
              Lwt.return
                ( `Failure,
                  Backtracked (operation_results, Some errors),
                  internal_operations_results ) )
      | (`Failure, internal_operations_results) ->
          Lwt.return
            (`Failure, Applied operation_results, internal_operations_results)
      )
  | Error errors ->
      Lwt.return (`Failure, Failed (manager_kind operation, errors), [])

let skipped_operation_result :
    type kind. kind manager_operation -> kind manager_operation_result =
  function
  | operation -> (
    match operation with
    | Reveal _ ->
        Applied
          ( Reveal_result {consumed_gas = Z.zero}
            : kind successful_manager_operation_result )
    | _ ->
        Skipped (manager_kind operation) )

let rec mark_skipped :
    type kind.
    baker:Signature.Public_key_hash.t ->
    Level.t ->
    kind Kind.manager contents_list ->
    kind Kind.manager contents_result_list =
 fun ~baker level -> function
  | Single (Manager_operation {source; fee; operation}) ->
      let source = Contract.implicit_contract source in
      Single_result
        (Manager_operation_result
           {
             balance_updates =
               Delegate.cleanup_balance_updates
                 [ (Contract source, Debited fee);
                   (Fees (baker, level.cycle), Credited fee) ];
             operation_result = skipped_operation_result operation;
             internal_operation_results = [];
           })
  | Cons (Manager_operation {source; fee; operation}, rest) ->
      let source = Contract.implicit_contract source in
      Cons_result
        ( Manager_operation_result
            {
              balance_updates =
                Delegate.cleanup_balance_updates
                  [ (Contract source, Debited fee);
                    (Fees (baker, level.cycle), Credited fee) ];
              operation_result = skipped_operation_result operation;
              internal_operation_results = [];
            },
          mark_skipped ~baker level rest )

let rec precheck_manager_contents_list :
    type kind.
    Alpha_context.t ->
    Chain_id.t ->
    _ Operation.t ->
    kind Kind.manager contents_list ->
    context tzresult Lwt.t =
 fun ctxt chain_id raw_operation contents_list ->
  match contents_list with
  | Single (Manager_operation _ as op) ->
      precheck_manager_contents ctxt chain_id raw_operation op
  | Cons ((Manager_operation _ as op), rest) ->
      precheck_manager_contents ctxt chain_id raw_operation op
      >>=? fun ctxt ->
      precheck_manager_contents_list ctxt chain_id raw_operation rest

let rec apply_manager_contents_list_rec :
    type kind.
    Alpha_context.t ->
    Script_ir_translator.unparsing_mode ->
    public_key_hash ->
    Chain_id.t ->
    kind Kind.manager contents_list ->
    ([`Success of context | `Failure] * kind Kind.manager contents_result_list)
    Lwt.t =
 fun ctxt mode baker chain_id contents_list ->
  let level = Level.current ctxt in
  match contents_list with
  | Single (Manager_operation {source; fee; _} as op) ->
      let source = Contract.implicit_contract source in
      apply_manager_contents ctxt mode chain_id op
      >>= fun (ctxt_result, operation_result, internal_operation_results) ->
      let result =
        Manager_operation_result
          {
            balance_updates =
              Delegate.cleanup_balance_updates
                [ (Contract source, Debited fee);
                  (Fees (baker, level.cycle), Credited fee) ];
            operation_result;
            internal_operation_results;
          }
      in
      Lwt.return (ctxt_result, Single_result result)
  | Cons ((Manager_operation {source; fee; _} as op), rest) -> (
      let source = Contract.implicit_contract source in
      apply_manager_contents ctxt mode chain_id op
      >>= function
      | (`Failure, operation_result, internal_operation_results) ->
          let result =
            Manager_operation_result
              {
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract source, Debited fee);
                      (Fees (baker, level.cycle), Credited fee) ];
                operation_result;
                internal_operation_results;
              }
          in
          Lwt.return
            (`Failure, Cons_result (result, mark_skipped ~baker level rest))
      | (`Success ctxt, operation_result, internal_operation_results) ->
          let result =
            Manager_operation_result
              {
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract source, Debited fee);
                      (Fees (baker, level.cycle), Credited fee) ];
                operation_result;
                internal_operation_results;
              }
          in
          apply_manager_contents_list_rec ctxt mode baker chain_id rest
          >>= fun (ctxt_result, results) ->
          Lwt.return (ctxt_result, Cons_result (result, results)) )

let mark_backtracked results =
  let rec mark_contents_list :
      type kind.
      kind Kind.manager contents_result_list ->
      kind Kind.manager contents_result_list = function
    | Single_result (Manager_operation_result op) ->
        Single_result
          (Manager_operation_result
             {
               balance_updates = op.balance_updates;
               operation_result =
                 mark_manager_operation_result op.operation_result;
               internal_operation_results =
                 List.map
                   mark_internal_operation_results
                   op.internal_operation_results;
             })
    | Cons_result (Manager_operation_result op, rest) ->
        Cons_result
          ( Manager_operation_result
              {
                balance_updates = op.balance_updates;
                operation_result =
                  mark_manager_operation_result op.operation_result;
                internal_operation_results =
                  List.map
                    mark_internal_operation_results
                    op.internal_operation_results;
              },
            mark_contents_list rest )
  and mark_internal_operation_results
      (Internal_operation_result (kind, result)) =
    Internal_operation_result (kind, mark_manager_operation_result result)
  and mark_manager_operation_result :
      type kind. kind manager_operation_result -> kind manager_operation_result
      = function
    | (Failed _ | Skipped _ | Backtracked _) as result ->
        result
    | Applied (Reveal_result _) as result ->
        result
    | Applied result ->
        Backtracked (result, None)
  in
  mark_contents_list results

let apply_manager_contents_list ctxt mode baker chain_id contents_list =
  apply_manager_contents_list_rec ctxt mode baker chain_id contents_list
  >>= fun (ctxt_result, results) ->
  match ctxt_result with
  | `Failure ->
      Lwt.return (ctxt (* backtracked *), mark_backtracked results)
  | `Success ctxt ->
      Big_map.cleanup_temporary ctxt >>= fun ctxt -> Lwt.return (ctxt, results)

let apply_contents_list (type kind) ctxt chain_id mode pred_block baker
    (operation : kind operation) (contents_list : kind contents_list) :
    (context * kind contents_result_list) tzresult Lwt.t =
  match contents_list with
  | Single (Endorsement {level}) ->
      let block = operation.shell.branch in
      fail_unless
        (Block_hash.equal block pred_block)
        (Wrong_endorsement_predecessor (pred_block, block))
      >>=? fun () ->
      let current_level = (Level.current ctxt).level in
      fail_unless
        Raw_level.(succ level = current_level)
        Invalid_endorsement_level
      >>=? fun () ->
      Baking.check_endorsement_rights ctxt chain_id operation
      >>=? fun (delegate, slots, used) ->
      if used then fail (Duplicate_endorsement delegate)
      else
        let ctxt = record_endorsement ctxt delegate in
        let gap = List.length slots in
        Lwt.return
          Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap)
        >>=? fun deposit ->
        Delegate.freeze_deposit ctxt delegate deposit
        >>=? fun ctxt ->
        Global.get_block_priority ctxt
        >>=? fun block_priority ->
        Baking.endorsing_reward ctxt ~block_priority gap
        >>=? fun reward ->
        Delegate.freeze_rewards ctxt delegate reward
        >>=? fun ctxt ->
        let level = Level.from_raw ctxt level in
        return
          ( ctxt,
            Single_result
              (Endorsement_result
                 {
                   balance_updates =
                     Delegate.cleanup_balance_updates
                       [ ( Contract (Contract.implicit_contract delegate),
                           Debited deposit );
                         (Deposits (delegate, level.cycle), Credited deposit);
                         (Rewards (delegate, level.cycle), Credited reward) ];
                   delegate;
                   slots;
                 }) )
  | Single (Seed_nonce_revelation {level; nonce}) ->
      let level = Level.from_raw ctxt level in
      Nonce.reveal ctxt level nonce
      >>=? fun ctxt ->
      let seed_nonce_revelation_tip =
        Constants.seed_nonce_revelation_tip ctxt
      in
      add_rewards ctxt seed_nonce_revelation_tip
      >>=? fun ctxt ->
      return
        ( ctxt,
          Single_result
            (Seed_nonce_revelation_result
               [ ( Rewards (baker, level.cycle),
                   Credited seed_nonce_revelation_tip ) ]) )
  | Single (Double_endorsement_evidence {op1; op2}) -> (
    match (op1.protocol_data.contents, op2.protocol_data.contents) with
    | (Single (Endorsement e1), Single (Endorsement e2))
      when Raw_level.(e1.level = e2.level)
           && not (Block_hash.equal op1.shell.branch op2.shell.branch) ->
        let level = Level.from_raw ctxt e1.level in
        let oldest_level = Level.last_allowed_fork_level ctxt in
        fail_unless
          Level.(level < Level.current ctxt)
          (Too_early_double_endorsement_evidence
             {level = level.level; current = (Level.current ctxt).level})
        >>=? fun () ->
        fail_unless
          Raw_level.(oldest_level <= level.level)
          (Outdated_double_endorsement_evidence
             {level = level.level; last = oldest_level})
        >>=? fun () ->
        Baking.check_endorsement_rights ctxt chain_id op1
        >>=? fun (delegate1, _, _) ->
        Baking.check_endorsement_rights ctxt chain_id op2
        >>=? fun (delegate2, _, _) ->
        fail_unless
          (Signature.Public_key_hash.equal delegate1 delegate2)
          (Inconsistent_double_endorsement_evidence {delegate1; delegate2})
        >>=? fun () ->
        Delegate.has_frozen_balance ctxt delegate1 level.cycle
        >>=? fun valid ->
        fail_unless valid Unrequired_double_endorsement_evidence
        >>=? fun () ->
        Delegate.punish ctxt delegate1 level.cycle
        >>=? fun (ctxt, balance) ->
        Lwt.return Tez.(balance.deposit +? balance.fees)
        >>=? fun burned ->
        let reward =
          match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
        in
        add_rewards ctxt reward
        >>=? fun ctxt ->
        let current_cycle = (Level.current ctxt).cycle in
        return
          ( ctxt,
            Single_result
              (Double_endorsement_evidence_result
                 (Delegate.cleanup_balance_updates
                    [ ( Deposits (delegate1, level.cycle),
                        Debited balance.deposit );
                      (Fees (delegate1, level.cycle), Debited balance.fees);
                      ( Rewards (delegate1, level.cycle),
                        Debited balance.rewards );
                      (Rewards (baker, current_cycle), Credited reward) ])) )
    | (_, _) ->
        fail Invalid_double_endorsement_evidence )
  | Single (Double_baking_evidence {bh1; bh2}) ->
      let hash1 = Block_header.hash bh1 in
      let hash2 = Block_header.hash bh2 in
      fail_unless
        ( Compare.Int32.(bh1.shell.level = bh2.shell.level)
        && not (Block_hash.equal hash1 hash2) )
        (Invalid_double_baking_evidence
           {hash1; level1 = bh1.shell.level; hash2; level2 = bh2.shell.level})
      >>=? fun () ->
      Lwt.return (Raw_level.of_int32 bh1.shell.level)
      >>=? fun raw_level ->
      let oldest_level = Level.last_allowed_fork_level ctxt in
      fail_unless
        Raw_level.(raw_level < (Level.current ctxt).level)
        (Too_early_double_baking_evidence
           {level = raw_level; current = (Level.current ctxt).level})
      >>=? fun () ->
      fail_unless
        Raw_level.(oldest_level <= raw_level)
        (Outdated_double_baking_evidence
           {level = raw_level; last = oldest_level})
      >>=? fun () ->
      let level = Level.from_raw ctxt raw_level in
      Roll.baking_rights_owner
        ctxt
        level
        ~priority:bh1.protocol_data.contents.priority
      >>=? fun delegate1 ->
      Baking.check_signature bh1 chain_id delegate1
      >>=? fun () ->
      Roll.baking_rights_owner
        ctxt
        level
        ~priority:bh2.protocol_data.contents.priority
      >>=? fun delegate2 ->
      Baking.check_signature bh2 chain_id delegate2
      >>=? fun () ->
      fail_unless
        (Signature.Public_key.equal delegate1 delegate2)
        (Inconsistent_double_baking_evidence
           {
             delegate1 = Signature.Public_key.hash delegate1;
             delegate2 = Signature.Public_key.hash delegate2;
           })
      >>=? fun () ->
      let delegate = Signature.Public_key.hash delegate1 in
      Delegate.has_frozen_balance ctxt delegate level.cycle
      >>=? fun valid ->
      fail_unless valid Unrequired_double_baking_evidence
      >>=? fun () ->
      Delegate.punish ctxt delegate level.cycle
      >>=? fun (ctxt, balance) ->
      Lwt.return Tez.(balance.deposit +? balance.fees)
      >>=? fun burned ->
      let reward =
        match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
      in
      add_rewards ctxt reward
      >>=? fun ctxt ->
      let current_cycle = (Level.current ctxt).cycle in
      return
        ( ctxt,
          Single_result
            (Double_baking_evidence_result
               (Delegate.cleanup_balance_updates
                  [ (Deposits (delegate, level.cycle), Debited balance.deposit);
                    (Fees (delegate, level.cycle), Debited balance.fees);
                    (Rewards (delegate, level.cycle), Debited balance.rewards);
                    (Rewards (baker, current_cycle), Credited reward) ])) )
  | Single (Activate_account {id = pkh; activation_code}) -> (
      let blinded_pkh =
        Blinded_public_key_hash.of_ed25519_pkh activation_code pkh
      in
      Commitment.get_opt ctxt blinded_pkh
      >>=? function
      | None ->
          fail (Invalid_activation {pkh})
      | Some amount ->
          Commitment.delete ctxt blinded_pkh
          >>=? fun ctxt ->
          let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in
          Contract.(credit ctxt contract amount)
          >>=? fun ctxt ->
          return
            ( ctxt,
              Single_result
                (Activate_account_result [(Contract contract, Credited amount)])
            ) )
  | Single (Proposals {source; period; proposals}) ->
      Roll.delegate_pubkey ctxt source
      >>=? fun delegate ->
      Operation.check_signature delegate chain_id operation
      >>=? fun () ->
      let level = Level.current ctxt in
      fail_unless
        Voting_period.(level.voting_period = period)
        (Wrong_voting_period (level.voting_period, period))
      >>=? fun () ->
      Amendment.record_proposals ctxt source proposals
      >>=? fun ctxt -> return (ctxt, Single_result Proposals_result)
  | Single (Ballot {source; period; proposal; ballot}) ->
      Roll.delegate_pubkey ctxt source
      >>=? fun delegate ->
      Operation.check_signature delegate chain_id operation
      >>=? fun () ->
      let level = Level.current ctxt in
      fail_unless
        Voting_period.(level.voting_period = period)
        (Wrong_voting_period (level.voting_period, period))
      >>=? fun () ->
      Amendment.record_ballot ctxt source proposal ballot
      >>=? fun ctxt -> return (ctxt, Single_result Ballot_result)
  | Single (Manager_operation _) as op ->
      precheck_manager_contents_list ctxt chain_id operation op
      >>=? fun ctxt ->
      apply_manager_contents_list ctxt mode baker chain_id op
      >>= fun (ctxt, result) -> return (ctxt, result)
  | Cons (Manager_operation _, _) as op ->
      precheck_manager_contents_list ctxt chain_id operation op
      >>=? fun ctxt ->
      apply_manager_contents_list ctxt mode baker chain_id op
      >>= fun (ctxt, result) -> return (ctxt, result)

let apply_operation ctxt chain_id mode pred_block baker hash operation =
  let ctxt = Contract.init_origination_nonce ctxt hash in
  apply_contents_list
    ctxt
    chain_id
    mode
    pred_block
    baker
    operation
    operation.protocol_data.contents
  >>=? fun (ctxt, result) ->
  let ctxt = Gas.set_unlimited ctxt in
  let ctxt = Contract.unset_origination_nonce ctxt in
  return (ctxt, {contents = result})

let may_snapshot_roll ctxt =
  let level = Alpha_context.Level.current ctxt in
  let blocks_per_roll_snapshot = Constants.blocks_per_roll_snapshot ctxt in
  if
    Compare.Int32.equal
      (Int32.rem level.cycle_position blocks_per_roll_snapshot)
      (Int32.pred blocks_per_roll_snapshot)
  then Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt -> return ctxt
  else return ctxt

let may_start_new_cycle ctxt =
  Baking.dawn_of_a_new_cycle ctxt
  >>=? function
  | None ->
      return (ctxt, [], [])
  | Some last_cycle ->
      Seed.cycle_end ctxt last_cycle
      >>=? fun (ctxt, unrevealed) ->
      Roll.cycle_end ctxt last_cycle
      >>=? fun ctxt ->
      Delegate.cycle_end ctxt last_cycle unrevealed
      >>=? fun (ctxt, update_balances, deactivated) ->
      Bootstrap.cycle_end ctxt last_cycle
      >>=? fun ctxt -> return (ctxt, update_balances, deactivated)

let begin_full_construction ctxt pred_timestamp protocol_data =
  Alpha_context.Global.set_block_priority
    ctxt
    protocol_data.Block_header.priority
  >>=? fun ctxt ->
  Baking.check_baking_rights ctxt protocol_data pred_timestamp
  >>=? fun (delegate_pk, block_delay) ->
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return (ctxt, protocol_data, delegate_pk, block_delay)

let begin_partial_construction ctxt =
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return ctxt

let begin_application ctxt chain_id block_header pred_timestamp =
  Alpha_context.Global.set_block_priority
    ctxt
    block_header.Block_header.protocol_data.contents.priority
  >>=? fun ctxt ->
  let current_level = Alpha_context.Level.current ctxt in
  Baking.check_proof_of_work_stamp ctxt block_header
  >>=? fun () ->
  Baking.check_fitness_gap ctxt block_header
  >>=? fun () ->
  Baking.check_baking_rights
    ctxt
    block_header.protocol_data.contents
    pred_timestamp
  >>=? fun (delegate_pk, block_delay) ->
  Baking.check_signature block_header chain_id delegate_pk
  >>=? fun () ->
  let has_commitment =
    match block_header.protocol_data.contents.seed_nonce_hash with
    | None ->
        false
    | Some _ ->
        true
  in
  fail_unless
    Compare.Bool.(has_commitment = current_level.expected_commitment)
    (Invalid_commitment {expected = current_level.expected_commitment})
  >>=? fun () ->
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return (ctxt, delegate_pk, block_delay)

let check_minimum_endorsements ctxt protocol_data block_delay
    included_endorsements =
  let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in
  let timestamp = Timestamp.current ctxt in
  fail_unless
    Compare.Int.(included_endorsements >= minimum)
    (Not_enough_endorsements_for_priority
       {
         required = minimum;
         priority = protocol_data.Block_header.priority;
         endorsements = included_endorsements;
         timestamp;
       })

let finalize_application ctxt protocol_data delegate ~block_delay =
  let included_endorsements = included_endorsements ctxt in
  check_minimum_endorsements
    ctxt
    protocol_data
    block_delay
    included_endorsements
  >>=? fun () ->
  let deposit = Constants.block_security_deposit ctxt in
  add_deposit ctxt delegate deposit
  >>=? fun ctxt ->
  Baking.baking_reward
    ctxt
    ~block_priority:protocol_data.priority
    ~included_endorsements
  >>=? fun reward ->
  add_rewards ctxt reward
  >>=? fun ctxt ->
  Signature.Public_key_hash.Map.fold
    (fun delegate deposit ctxt ->
      ctxt >>=? fun ctxt -> Delegate.freeze_deposit ctxt delegate deposit)
    (get_deposits ctxt)
    (return ctxt)
  >>=? fun ctxt ->
  (* end of level (from this point nothing should fail) *)
  let fees = Alpha_context.get_fees ctxt in
  Delegate.freeze_fees ctxt delegate fees
  >>=? fun ctxt ->
  let rewards = Alpha_context.get_rewards ctxt in
  Delegate.freeze_rewards ctxt delegate rewards
  >>=? fun ctxt ->
  ( match protocol_data.Block_header.seed_nonce_hash with
  | None ->
      return ctxt
  | Some nonce_hash ->
      Nonce.record_hash ctxt {nonce_hash; delegate; rewards; fees} )
  >>=? fun ctxt ->
  (* end of cycle *)
  may_snapshot_roll ctxt
  >>=? fun ctxt ->
  may_start_new_cycle ctxt
  >>=? fun (ctxt, balance_updates, deactivated) ->
  Amendment.may_start_new_voting_period ctxt
  >>=? fun ctxt ->
  let cycle = (Level.current ctxt).cycle in
  let balance_updates =
    Delegate.(
      cleanup_balance_updates
        ( [ (Contract (Contract.implicit_contract delegate), Debited deposit);
            (Deposits (delegate, cycle), Credited deposit);
            (Rewards (delegate, cycle), Credited reward) ]
        @ balance_updates ))
  in
  let consumed_gas =
    Z.sub
      (Constants.hard_gas_limit_per_block ctxt)
      (Alpha_context.Gas.block_level ctxt)
  in
  Alpha_context.Vote.get_current_period_kind ctxt
  >>=? fun voting_period_kind ->
  let receipt =
    Apply_results.
      {
        baker = delegate;
        level = Level.current ctxt;
        voting_period_kind;
        nonce_hash = protocol_data.seed_nonce_hash;
        consumed_gas;
        deactivated;
        balance_updates;
      }
  in
  return (ctxt, receipt)
src/proto_alpha/lib_protocol/apply.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_raw_protocol_alpha.Apply_results.

Definition apply_manager_operation_content {kind : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (internal : bool)
  (operation : Tezos_raw_protocol_alpha.Alpha_context.manager_operation kind)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        (Tezos_raw_protocol_alpha.Apply_results.successful_manager_operation_result
          kind) *
        (list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation))) :=
  let before_operation := ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.Contract.must_exist ctxt source)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Tezos_raw_protocol_alpha.Michelson_v1_gas.Cost_of.manager_operation))
          (fun ctxt =>
            match operation with
            | Reveal _ =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt,
                  (Reveal_result
                    {|
                      consumed_gas :=
                        Tezos_raw_protocol_alpha.Alpha_context.Gas.consumed
                          before_operation ctxt |}), [])
            |
              Transaction {|
                amount := amount;
                  parameters := parameters;
                  entrypoint := entrypoint;
                  destination := destination
                  |} =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Alpha_context.Contract.spend ctxt
                  source amount)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    match
                      Tezos_raw_protocol_alpha.Alpha_context.Contract.is_implicit
                        destination with
                    | None =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        (ctxt, [], false)
                    | Some _ =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Alpha_context.Contract.allocated
                          ctxt destination)
                        (fun function_parameter =>
                          match function_parameter with
                          | true =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              (ctxt, [], false)
                          | false =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Alpha_context.Fees.origination_burn
                                ctxt)
                              (fun function_parameter =>
                                match function_parameter with
                                | (ctxt, origination_burn) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                    (ctxt,
                                      (cons
                                        ((Delegate.Contract payer),
                                          (Delegate.Debited origination_burn))
                                        []), true)
                                end)
                          end)
                    end
                    (fun function_parameter =>
                      match function_parameter with
                      |
                        (ctxt, maybe_burn_balance_update,
                          allocated_destination_contract) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Contract.credit
                            ctxt destination amount)
                          (fun ctxt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script
                                ctxt destination)
                              (fun function_parameter =>
                                match function_parameter with
                                | (ctxt, script) =>
                                  match script with
                                  | None =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        match entrypoint with
                                        | "default" % string =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                            tt
                                        | entrypoint =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                            (Script_tc_errors.No_such_entrypoint
                                              entrypoint)
                                        end
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                                ctxt parameters)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (arg, ctxt) =>
                                                  let cost_arg :=
                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.deserialized_cost
                                                      arg in
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                                        ctxt cost_arg))
                                                    (fun ctxt =>
                                                      match
                                                        Tezos_protocol_environment_alpha__Environment.Micheline.root
                                                          arg with
                                                      | Prim _ D_Unit [] _ =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                          ctxt
                                                      | _ =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                                          (Script_interpreter.Bad_contract_parameter
                                                            destination)
                                                      end)
                                                end)
                                          end))
                                      (fun ctxt =>
                                        let result :=
                                          Transaction_result
                                            {| storage := None;
                                              big_map_diff := None;
                                              balance_updates :=
                                                Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                                    (cons
                                                      ((Delegate.Contract source),
                                                        (Delegate.Debited amount))
                                                      (cons
                                                        ((Contract destination),
                                                          (Credited amount)) []))
                                                    maybe_burn_balance_update);
                                              originated_contracts := [];
                                              consumed_gas :=
                                                Tezos_raw_protocol_alpha.Alpha_context.Gas.consumed
                                                  before_operation ctxt;
                                              storage_size :=
                                                Tezos_protocol_environment_alpha__Environment.Z.zero;
                                              paid_storage_size_diff :=
                                                Tezos_protocol_environment_alpha__Environment.Z.zero;
                                              allocated_destination_contract :=
                                                allocated_destination_contract
                                              |} in
                                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                          (ctxt, result, []))
                                  | Some script =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                        ctxt parameters)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (parameter, ctxt) =>
                                          let cost_parameter :=
                                            Tezos_raw_protocol_alpha.Alpha_context.Script.deserialized_cost
                                              parameter in
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                                ctxt cost_parameter))
                                            (fun ctxt =>
                                              let step_constants :=
                                                {| source := source;
                                                  payer := payer;
                                                  self := destination;
                                                  amount := amount;
                                                  chain_id := chain_id |} in
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_raw_protocol_alpha.Script_interpreter.execute
                                                  ctxt mode step_constants
                                                  script entrypoint parameter)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | {|
                                                    ctxt := ctxt;
                                                      storage := storage;
                                                      big_map_diff :=
                                                        big_map_diff;
                                                      operations := operations
                                                      |} =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (Tezos_raw_protocol_alpha.Alpha_context.Contract.update_script_storage
                                                        ctxt destination storage
                                                        big_map_diff)
                                                      (fun ctxt =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (Tezos_raw_protocol_alpha.Alpha_context.Fees.record_paid_storage_space
                                                            ctxt destination)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            |
                                                              (ctxt, new_size,
                                                                paid_storage_size_diff,
                                                                fees) =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (Tezos_raw_protocol_alpha.Alpha_context.Contract.originated_from_current_nonce
                                                                  before_operation
                                                                  ctxt)
                                                                (fun
                                                                  originated_contracts
                                                                  =>
                                                                  let result :=
                                                                    Transaction_result
                                                                      {|
                                                                        storage :=
                                                                          Some
                                                                            storage;
                                                                        big_map_diff :=
                                                                          big_map_diff;
                                                                        balance_updates :=
                                                                          Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                                                                            (cons
                                                                              ((Contract
                                                                                payer),
                                                                                (Debited
                                                                                  fees))
                                                                              (cons
                                                                                ((Contract
                                                                                  source),
                                                                                  (Debited
                                                                                    amount))
                                                                                (cons
                                                                                  ((Contract
                                                                                    destination),
                                                                                    (Credited
                                                                                      amount))
                                                                                  [])));
                                                                        originated_contracts :=
                                                                          originated_contracts;
                                                                        consumed_gas :=
                                                                          Tezos_raw_protocol_alpha.Alpha_context.Gas.consumed
                                                                            before_operation
                                                                            ctxt;
                                                                        storage_size :=
                                                                          new_size;
                                                                        paid_storage_size_diff :=
                                                                          paid_storage_size_diff;
                                                                        allocated_destination_contract :=
                                                                          allocated_destination_contract
                                                                        |} in
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                                    (ctxt,
                                                                      result,
                                                                      operations))
                                                            end))
                                                  end))
                                        end)
                                  end
                                end))
                      end))
            |
              Origination {|
                delegate := delegate;
                  script := script;
                  credit := credit;
                  preorigination := preorigination
                  |} =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode ctxt
                  (storage script))
                (fun function_parameter =>
                  match function_parameter with
                  | (unparsed_storage, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                          (Tezos_raw_protocol_alpha.Alpha_context.Script.deserialized_cost
                            unparsed_storage)))
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                            ctxt (code script))
                          (fun function_parameter =>
                            match function_parameter with
                            | (unparsed_code, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                    ctxt
                                    (Tezos_raw_protocol_alpha.Alpha_context.Script.deserialized_cost
                                      unparsed_code)))
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Script_ir_translator.parse_script
                                      None ctxt false script)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (Ex_script parsed_script, ctxt) =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Script_ir_translator.collect_big_maps
                                            ctxt (storage_type parsed_script)
                                            (storage parsed_script))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (to_duplicate, ctxt) =>
                                              let to_update :=
                                                Tezos_raw_protocol_alpha.Script_ir_translator.no_big_map_id
                                                in
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_raw_protocol_alpha.Script_ir_translator.extract_big_map_diff
                                                  ctxt Optimized false
                                                  to_duplicate to_update
                                                  (storage_type parsed_script)
                                                  (storage parsed_script))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  |
                                                    (storage, big_map_diff, ctxt)
                                                    =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data
                                                        ctxt Optimized
                                                        (storage_type
                                                          parsed_script) storage)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | (storage, ctxt) =>
                                                          let storage :=
                                                            Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                                storage) in
                                                          let script := record
                                                            in
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Contract.spend
                                                              ctxt source credit)
                                                            (fun ctxt =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                match
                                                                  preorigination
                                                                  with
                                                                | Some contract
                                                                  =>
                                                                  internal;
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                                    (ctxt,
                                                                      contract)
                                                                | None =>
                                                                  Tezos_raw_protocol_alpha.Alpha_context.Contract.fresh_contract_from_current_nonce
                                                                    ctxt
                                                                end
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  |
                                                                    (ctxt,
                                                                      contract)
                                                                    =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                      (Tezos_raw_protocol_alpha.Alpha_context.Contract.originate
                                                                        ctxt
                                                                        contract
                                                                        credit
                                                                        (script,
                                                                          big_map_diff)
                                                                        delegate)
                                                                      (fun ctxt
                                                                        =>
                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                          (Tezos_raw_protocol_alpha.Alpha_context.Fees.origination_burn
                                                                            ctxt)
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            |
                                                                              (ctxt,
                                                                                origination_burn)
                                                                              =>
                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                (Tezos_raw_protocol_alpha.Alpha_context.Fees.record_paid_storage_space
                                                                                  ctxt
                                                                                  contract)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    (ctxt,
                                                                                      size,
                                                                                      paid_storage_size_diff,
                                                                                      fees)
                                                                                    =>
                                                                                    let
                                                                                      result :=
                                                                                      Origination_result
                                                                                        {|
                                                                                          big_map_diff :=
                                                                                            big_map_diff;
                                                                                          balance_updates :=
                                                                                            Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                                                                                              (cons
                                                                                                ((Contract
                                                                                                  payer),
                                                                                                  (Debited
                                                                                                    fees))
                                                                                                (cons
                                                                                                  ((Contract
                                                                                                    payer),
                                                                                                    (Debited
                                                                                                      origination_burn))
                                                                                                  (cons
                                                                                                    ((Contract
                                                                                                      source),
                                                                                                      (Debited
                                                                                                        credit))
                                                                                                    (cons
                                                                                                      ((Contract
                                                                                                        contract),
                                                                                                        (Credited
                                                                                                          credit))
                                                                                                      []))));
                                                                                          originated_contracts :=
                                                                                            cons
                                                                                              contract
                                                                                              [];
                                                                                          consumed_gas :=
                                                                                            Tezos_raw_protocol_alpha.Alpha_context.Gas.consumed
                                                                                              before_operation
                                                                                              ctxt;
                                                                                          storage_size :=
                                                                                            size;
                                                                                          paid_storage_size_diff :=
                                                                                            paid_storage_size_diff
                                                                                          |}
                                                                                      in
                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                                                      (ctxt,
                                                                                        result,
                                                                                        [])
                                                                                  end)
                                                                            end))
                                                                  end))
                                                        end)
                                                  end)
                                            end)
                                      end))
                            end))
                  end)
            | Delegation delegate =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.set ctxt source
                  delegate)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (ctxt,
                      (Delegation_result
                        {|
                          consumed_gas :=
                            Tezos_raw_protocol_alpha.Alpha_context.Gas.consumed
                              before_operation ctxt |}), []))
            end)
      end).

Definition apply_internal_manager_operations
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ops : list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (variant *
      (list
        Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
  let fix apply
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (applied :
    list Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)
    (worklist :
    list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (variant *
        (list
          Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
    match worklist with
    | [] =>
      Tezos_protocol_environment_alpha__Environment.Lwt._return
        (variant,
          (Tezos_protocol_environment_alpha__Environment.List.rev applied))
    |
      cons
        (Internal_operation
          ({| source := source; operation := operation; nonce := nonce |} as op))
        rest =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (if
          Tezos_raw_protocol_alpha.Alpha_context.internal_nonce_already_recorded
            ctxt nonce then
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Internal_operation_replay (Internal_operation op))
        else
          let ctxt :=
            Tezos_raw_protocol_alpha.Alpha_context.record_internal_nonce ctxt
              nonce in
          apply_manager_operation_content ctxt mode payer source chain_id true
            operation)
        (fun function_parameter =>
          match function_parameter with
          | inr errors =>
            let result :=
              Internal_operation_result op
                (Failed
                  (Tezos_raw_protocol_alpha.Alpha_context.manager_kind
                    (operation op)) errors) in
            let skipped :=
              Tezos_protocol_environment_alpha__Environment.List.rev_map
                (fun function_parameter =>
                  match function_parameter with
                  | Internal_operation op =>
                    Internal_operation_result op
                      (Skipped
                        (Tezos_raw_protocol_alpha.Alpha_context.manager_kind
                          (operation op)))
                  end) rest in
            Tezos_protocol_environment_alpha__Environment.Lwt._return
              (variant,
                (Tezos_protocol_environment_alpha__Environment.List.rev
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                    skipped (cons result applied))))
          | inl (ctxt, result, emitted) =>
            apply ctxt
              (cons (Internal_operation_result op (Applied result)) applied)
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                rest emitted)
          end)
    end in
  apply ctxt [] ops.

Definition precheck_manager_contents {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (raw_operation : Tezos_raw_protocol_alpha__Alpha_context.operation A)
  (op :
    Tezos_raw_protocol_alpha.Alpha_context.contents
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager B))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  match op with
  |
    Manager_operation {|
      source := source;
        fee := fee;
        counter := counter;
        operation := operation;
        gas_limit := gas_limit;
        storage_limit := storage_limit
        |} =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.check_limit ctxt gas_limit))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let ctxt :=
            Tezos_raw_protocol_alpha.Alpha_context.Gas.set_limit ctxt gas_limit
            in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Lwt._return
              (Tezos_raw_protocol_alpha.Alpha_context.Fees.check_storage_limit
                ctxt storage_limit))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Alpha_context.Contract.must_be_allocated
                    ctxt
                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract
                      source))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Alpha_context.Contract.check_counter_increment
                          ctxt source counter)
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              match operation with
                              | Reveal pk =>
                                Tezos_raw_protocol_alpha.Alpha_context.Contract.reveal_manager_key
                                  ctxt source pk
                              | Transaction {| parameters := parameters |} =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                    Tezos_protocol_environment_alpha__Environment.Lwt._return
                                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
                                        Gas_quota_exceeded_init_deserialize)
                                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.check_enough
                                        ctxt
                                        (Tezos_raw_protocol_alpha.Alpha_context.Script.minimal_deserialize_cost
                                          parameters))))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                            Gas_quota_exceeded_init_deserialize)
                                          (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                            ctxt parameters))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (_arg, ctxt) => ctxt
                                          end)
                                    end)
                              | Origination {| script := script |} =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                    Tezos_protocol_environment_alpha__Environment.Lwt._return
                                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
                                        Gas_quota_exceeded_init_deserialize)
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                          ctxt
                                          (Tezos_raw_protocol_alpha.Alpha_context.Script.minimal_deserialize_cost
                                            (code script)))
                                        (fun ctxt =>
                                          Tezos_raw_protocol_alpha.Alpha_context.Gas.check_enough
                                            ctxt
                                            (Tezos_raw_protocol_alpha.Alpha_context.Script.minimal_deserialize_cost
                                              (storage script))))))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                            Gas_quota_exceeded_init_deserialize)
                                          (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                            ctxt (code script)))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (_code, ctxt) =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                                  Gas_quota_exceeded_init_deserialize)
                                                (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                                  ctxt (storage script)))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (_storage, ctxt) => ctxt
                                                end)
                                          end)
                                    end)
                              | _ =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  ctxt
                              end
                              (fun ctxt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_manager_key
                                    ctxt source)
                                  (fun public_key =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_raw_protocol_alpha.Alpha_context.Operation.check_signature
                                        public_key chain_id raw_operation)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (Tezos_raw_protocol_alpha.Alpha_context.Contract.increment_counter
                                              ctxt source)
                                            (fun ctxt =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_raw_protocol_alpha.Alpha_context.Contract.spend
                                                  ctxt
                                                  (Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract
                                                    source) fee)
                                                (fun ctxt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_raw_protocol_alpha.Alpha_context.add_fees
                                                      ctxt fee)
                                                    (fun ctxt =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                        ctxt)))
                                        end)))
                          end)
                    end)
              end)
        end)
  end.

Definition apply_manager_contents {A : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (op :
    Tezos_raw_protocol_alpha.Alpha_context.contents
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (variant *
      (Tezos_raw_protocol_alpha.Apply_results.manager_operation_result A) *
      (list
        Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
  match op with
  |
    Manager_operation {|
      source := source;
        operation := operation;
        gas_limit := gas_limit;
        storage_limit := storage_limit
        |} =>
    let ctxt :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.set_limit ctxt gas_limit in
    let ctxt :=
      Tezos_raw_protocol_alpha.Alpha_context.Fees.start_counting_storage_fees
        ctxt in
    let source :=
      Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract source
      in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
      (apply_manager_operation_content ctxt mode source source chain_id false
        operation)
      (fun function_parameter =>
        match function_parameter with
        | inl (ctxt, operation_results, internal_operations) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (apply_internal_manager_operations ctxt mode source chain_id
              internal_operations)
            (fun function_parameter =>
              match function_parameter with
              | (Success ctxt, internal_operations_results) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_raw_protocol_alpha.Alpha_context.Fees.burn_storage_fees
                    ctxt storage_limit source)
                  (fun function_parameter =>
                    match function_parameter with
                    | inl ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (variant, (Applied operation_results),
                          internal_operations_results)
                    | inr errors =>
                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (variant, (Backtracked operation_results (Some errors)),
                          internal_operations_results)
                    end)
              | (Failure, internal_operations_results) =>
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (variant, (Applied operation_results),
                    internal_operations_results)
              end)
        | inr errors =>
          Tezos_protocol_environment_alpha__Environment.Lwt._return
            (variant,
              (Failed
                (Tezos_raw_protocol_alpha.Alpha_context.manager_kind operation)
                errors), [])
        end)
  end.

Definition skipped_operation_result {kind : Type}
  (operation : Tezos_raw_protocol_alpha.Alpha_context.manager_operation kind)
  : Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind :=
  match operation with
  | Reveal _ =>
    Applied
      (Reveal_result
        {| consumed_gas := Tezos_protocol_environment_alpha__Environment.Z.zero
          |})
  | _ => Skipped (Tezos_raw_protocol_alpha.Alpha_context.manager_kind operation)
  end.

Fixpoint mark_skipped {kind : Type}
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (level : Tezos_raw_protocol_alpha.Alpha_context.Level.t)
  (function_parameter :
    Tezos_raw_protocol_alpha.Alpha_context.contents_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  : Tezos_raw_protocol_alpha.Apply_results.contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) :=
  match function_parameter with
  |
    Single
      (Manager_operation {|
        source := source; fee := fee; operation := operation |}) =>
    let source :=
      Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract source
      in
    Single_result
      (Manager_operation_result
        {|
          balance_updates :=
            Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
              (cons ((Contract source), (Debited fee))
                (cons ((Fees baker (cycle level)), (Credited fee)) []));
          operation_result := skipped_operation_result operation;
          internal_operation_results := [] |})
  |
    Cons
      (Manager_operation {|
        source := source; fee := fee; operation := operation |}) rest =>
    let source :=
      Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract source
      in
    Cons_result
      (Manager_operation_result
        {|
          balance_updates :=
            Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
              (cons ((Contract source), (Debited fee))
                (cons ((Fees baker (cycle level)), (Credited fee)) []));
          operation_result := skipped_operation_result operation;
          internal_operation_results := [] |}) (mark_skipped baker level rest)
  end.

Fixpoint precheck_manager_contents_list {A kind : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (raw_operation : Tezos_raw_protocol_alpha.Alpha_context.Operation.t A)
  (contents_list :
    Tezos_raw_protocol_alpha.Alpha_context.contents_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  match contents_list with
  | Single ((Manager_operation _) as op) =>
    precheck_manager_contents ctxt chain_id raw_operation op
  | Cons ((Manager_operation _) as op) rest =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (precheck_manager_contents ctxt chain_id raw_operation op)
      (fun ctxt =>
        precheck_manager_contents_list ctxt chain_id raw_operation rest)
  end.

Fixpoint apply_manager_contents_list_rec {kind : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (baker : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (contents_list :
    Tezos_raw_protocol_alpha.Alpha_context.contents_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (variant *
      (Tezos_raw_protocol_alpha.Apply_results.contents_result_list
        (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))) :=
  let level := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
  match contents_list with
  | Single ((Manager_operation {| source := source; fee := fee |}) as op) =>
    let source :=
      Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract source
      in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
      (apply_manager_contents ctxt mode chain_id op)
      (fun function_parameter =>
        match function_parameter with
        | (ctxt_result, operation_result, internal_operation_results) =>
          let result :=
            Manager_operation_result
              {|
                balance_updates :=
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                    (cons ((Contract source), (Debited fee))
                      (cons ((Fees baker (cycle level)), (Credited fee)) []));
                operation_result := operation_result;
                internal_operation_results := internal_operation_results |} in
          Tezos_protocol_environment_alpha__Environment.Lwt._return
            (ctxt_result, (Single_result result))
        end)
  | Cons ((Manager_operation {| source := source; fee := fee |}) as op) rest =>
    let source :=
      Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract source
      in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
      (apply_manager_contents ctxt mode chain_id op)
      (fun function_parameter =>
        match function_parameter with
        | (Failure, operation_result, internal_operation_results) =>
          let result :=
            Manager_operation_result
              {|
                balance_updates :=
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                    (cons ((Contract source), (Debited fee))
                      (cons ((Fees baker (cycle level)), (Credited fee)) []));
                operation_result := operation_result;
                internal_operation_results := internal_operation_results |} in
          Tezos_protocol_environment_alpha__Environment.Lwt._return
            (variant, (Cons_result result (mark_skipped baker level rest)))
        | (Success ctxt, operation_result, internal_operation_results) =>
          let result :=
            Manager_operation_result
              {|
                balance_updates :=
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                    (cons ((Contract source), (Debited fee))
                      (cons ((Fees baker (cycle level)), (Credited fee)) []));
                operation_result := operation_result;
                internal_operation_results := internal_operation_results |} in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (apply_manager_contents_list_rec ctxt mode baker chain_id rest)
            (fun function_parameter =>
              match function_parameter with
              | (ctxt_result, results) =>
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (ctxt_result, (Cons_result result results))
              end)
        end)
  end.

Definition mark_backtracked {A : Type}
  (results :
    Tezos_raw_protocol_alpha.Apply_results.contents_result_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
  : Tezos_raw_protocol_alpha.Apply_results.contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A) :=
  let fix mark_contents_list {kind : Type}
    (function_parameter :
    Tezos_raw_protocol_alpha.Apply_results.contents_result_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
    : Tezos_raw_protocol_alpha.Apply_results.contents_result_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) :=
    match function_parameter with
    | Single_result (Manager_operation_result op) =>
      Single_result
        (Manager_operation_result
          {| balance_updates := balance_updates op;
            operation_result :=
              mark_manager_operation_result (operation_result op);
            internal_operation_results :=
              Tezos_protocol_environment_alpha__Environment.List.map
                mark_internal_operation_results (internal_operation_results op)
            |})
    | Cons_result (Manager_operation_result op) rest =>
      Cons_result
        (Manager_operation_result
          {| balance_updates := balance_updates op;
            operation_result :=
              mark_manager_operation_result (operation_result op);
            internal_operation_results :=
              Tezos_protocol_environment_alpha__Environment.List.map
                mark_internal_operation_results (internal_operation_results op)
            |}) (mark_contents_list rest)
    end
  with mark_internal_operation_results
    (function_parameter :
    Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)
    : Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result :=
    match function_parameter with
    | Internal_operation_result kind result =>
      Internal_operation_result kind (mark_manager_operation_result result)
    end
  with mark_manager_operation_result {kind : Type}
    (function_parameter :
    Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind)
    : Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind :=
    match function_parameter with
    | (Failed _ _ | Skipped _ | Backtracked _ _) as result => result
    | (Applied (Reveal_result _)) as result => result
    | Applied result => Backtracked result None
    end in
  mark_contents_list results.

Definition apply_manager_contents_list {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (baker : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (contents_list :
    Tezos_raw_protocol_alpha.Alpha_context.contents_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_raw_protocol_alpha.Alpha_context.t *
      (Tezos_raw_protocol_alpha.Apply_results.contents_result_list
        (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (apply_manager_contents_list_rec ctxt mode baker chain_id contents_list)
    (fun function_parameter =>
      match function_parameter with
      | (ctxt_result, results) =>
        match ctxt_result with
        | Failure =>
          Tezos_protocol_environment_alpha__Environment.Lwt._return
            (ctxt, (mark_backtracked results))
        | Success ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Alpha_context.Big_map.cleanup_temporary
              ctxt)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Lwt._return
                (ctxt, results))
        end
      end).

Definition apply_contents_list {A : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (pred_block :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (operation : Tezos_raw_protocol_alpha.Alpha_context.operation A)
  (contents_list : Tezos_raw_protocol_alpha.Alpha_context.contents_list A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        (Tezos_raw_protocol_alpha.Apply_results.contents_result_list A))) :=
  match contents_list with
  | Single (Endorsement {| level := level |}) =>
    let block := branch (shell operation) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
        (Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
          block pred_block) (Wrong_endorsement_predecessor pred_block block))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          let current_level :=
            level (Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt) in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
              (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.op_eq
                (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.succ level)
                current_level) Invalid_endorsement_level)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Baking.check_endorsement_rights ctxt
                    chain_id operation)
                  (fun function_parameter =>
                    match function_parameter with
                    | (delegate, slots, used) =>
                      if used then
                        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                          (Duplicate_endorsement delegate)
                      else
                        let ctxt :=
                          Tezos_raw_protocol_alpha.Alpha_context.record_endorsement
                            ctxt delegate in
                        let gap :=
                          Tezos_protocol_environment_alpha__Environment.List.length
                            slots in
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_protocol_environment_alpha__Environment.Lwt._return
                            (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_star_question
                              (Tezos_raw_protocol_alpha.Alpha_context.Constants.endorsement_security_deposit
                                ctxt)
                              (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                gap)))
                          (fun deposit =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Alpha_context.Delegate.freeze_deposit
                                ctxt delegate deposit)
                              (fun ctxt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_raw_protocol_alpha.Alpha_context.Global.get_block_priority
                                    ctxt)
                                  (fun block_priority =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_raw_protocol_alpha.Baking.endorsing_reward
                                        ctxt block_priority gap)
                                      (fun reward =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Alpha_context.Delegate.freeze_rewards
                                            ctxt delegate reward)
                                          (fun ctxt =>
                                            let level :=
                                              Tezos_raw_protocol_alpha.Alpha_context.Level.from_raw
                                                ctxt None level in
                                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                              (ctxt,
                                                (Single_result
                                                  (Endorsement_result
                                                    {|
                                                      balance_updates :=
                                                        Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                                                          (cons
                                                            ((Contract
                                                              (Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract
                                                                delegate)),
                                                              (Debited deposit))
                                                            (cons
                                                              ((Deposits
                                                                delegate
                                                                (cycle level)),
                                                                (Credited
                                                                  deposit))
                                                              (cons
                                                                ((Rewards
                                                                  delegate
                                                                  (cycle level)),
                                                                  (Credited
                                                                    reward)) [])));
                                                      delegate := delegate;
                                                      slots := slots |}))))))))
                    end)
              end)
        end)
  | Single (Seed_nonce_revelation {| level := level; nonce := nonce |}) =>
    let level :=
      Tezos_raw_protocol_alpha.Alpha_context.Level.from_raw ctxt None level in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.Nonce.reveal ctxt level nonce)
      (fun ctxt =>
        let seed_nonce_revelation_tip :=
          Tezos_raw_protocol_alpha.Alpha_context.Constants.seed_nonce_revelation_tip
            ctxt in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.add_rewards ctxt
            seed_nonce_revelation_tip)
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (ctxt,
                (Single_result
                  (Seed_nonce_revelation_result
                    (cons
                      ((Rewards baker (cycle level)),
                        (Credited seed_nonce_revelation_tip)) []))))))
  | Single (Double_endorsement_evidence {| op1 := op1; op2 := op2 |}) =>
    match ((contents (protocol_data op1)), (contents (protocol_data op2))) with
    | (_, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
        Invalid_double_endorsement_evidence
    end
  | Single (Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |}) =>
    let hash1 := Tezos_raw_protocol_alpha.Alpha_context.Block_header.hash bh1 in
    let hash2 := Tezos_raw_protocol_alpha.Alpha_context.Block_header.hash bh2 in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
          (Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (level (shell bh1)) (level (shell bh2)))
          (Tezos_protocol_environment_alpha__Environment.Pervasives.not
            (Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
              hash1 hash2)))
        (Invalid_double_baking_evidence
          {| hash1 := hash1; level1 := level (shell bh1); hash2 := hash2;
            level2 := level (shell bh2) |}))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Lwt._return
              (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.of_int32
                (level (shell bh1))))
            (fun raw_level =>
              let oldest_level :=
                Tezos_raw_protocol_alpha.Alpha_context.Level.last_allowed_fork_level
                  ctxt in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                  (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.op_lt
                    raw_level
                    (level
                      (Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt)))
                  (Too_early_double_baking_evidence
                    {| level := raw_level;
                      current :=
                        level
                          (Tezos_raw_protocol_alpha.Alpha_context.Level.current
                            ctxt) |}))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                        (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.op_lt_eq
                          oldest_level raw_level)
                        (Outdated_double_baking_evidence
                          {| level := raw_level; last := oldest_level |}))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let level :=
                            Tezos_raw_protocol_alpha.Alpha_context.Level.from_raw
                              ctxt None raw_level in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Alpha_context.Roll.baking_rights_owner
                              ctxt level
                              (priority (contents (protocol_data bh1))))
                            (fun delegate1 =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Baking.check_signature
                                  bh1 chain_id delegate1)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_raw_protocol_alpha.Alpha_context.Roll.baking_rights_owner
                                        ctxt level
                                        (priority (contents (protocol_data bh2))))
                                      (fun delegate2 =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Baking.check_signature
                                            bh2 chain_id delegate2)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                                                  (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.equal
                                                    delegate1 delegate2)
                                                  (Inconsistent_double_baking_evidence
                                                    {|
                                                      delegate1 :=
                                                        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                                                          delegate1;
                                                      delegate2 :=
                                                        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                                                          delegate2 |}))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    let delegate :=
                                                      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                                                        delegate1 in
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (Tezos_raw_protocol_alpha.Alpha_context.Delegate.has_frozen_balance
                                                        ctxt delegate
                                                        (cycle level))
                                                      (fun valid =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                                                            valid
                                                            Unrequired_double_baking_evidence)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.punish
                                                                  ctxt delegate
                                                                  (cycle level))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  |
                                                                    (ctxt,
                                                                      balance)
                                                                    =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                        (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_plus_question
                                                                          (deposit
                                                                            balance)
                                                                          (fees
                                                                            balance)))
                                                                      (fun
                                                                        burned
                                                                        =>
                                                                        let
                                                                          reward :=
                                                                          match
                                                                            Tezos_raw_protocol_alpha.Alpha_context.Tez.op_div_question
                                                                              burned
                                                                              2
                                                                            with
                                                                          |
                                                                            inl
                                                                              v
                                                                            => v
                                                                          |
                                                                            inr
                                                                              _
                                                                            =>
                                                                            Tezos_raw_protocol_alpha.Alpha_context.Tez.zero
                                                                          end in
                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                          (Tezos_raw_protocol_alpha.Alpha_context.add_rewards
                                                                            ctxt
                                                                            reward)
                                                                          (fun
                                                                            ctxt
                                                                            =>
                                                                            let
                                                                              current_cycle :=
                                                                              cycle
                                                                                (Tezos_raw_protocol_alpha.Alpha_context.Level.current
                                                                                  ctxt)
                                                                              in
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                                              (ctxt,
                                                                                (Single_result
                                                                                  (Double_baking_evidence_result
                                                                                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                                                                                      (cons
                                                                                        ((Deposits
                                                                                          delegate
                                                                                          (cycle
                                                                                            level)),
                                                                                          (Debited
                                                                                            (deposit
                                                                                              balance)))
                                                                                        (cons
                                                                                          ((Fees
                                                                                            delegate
                                                                                            (cycle
                                                                                              level)),
                                                                                            (Debited
                                                                                              (fees
                                                                                                balance)))
                                                                                          (cons
                                                                                            ((Rewards
                                                                                              delegate
                                                                                              (cycle
                                                                                                level)),
                                                                                              (Debited
                                                                                                (rewards
                                                                                                  balance)))
                                                                                            (cons
                                                                                              ((Rewards
                                                                                                baker
                                                                                                current_cycle),
                                                                                                (Credited
                                                                                                  reward))
                                                                                              []))))))))))
                                                                  end)
                                                            end))
                                                  end)
                                            end))
                                  end))
                        end)
                  end))
        end)
  |
    Single
      (Activate_account {| id := pkh; activation_code := activation_code |}) =>
    let blinded_pkh :=
      Tezos_raw_protocol_alpha.Blinded_public_key_hash.of_ed25519_pkh
        activation_code pkh in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.Commitment.get_opt ctxt
        blinded_pkh)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_activation {| pkh := pkh |})
        | Some amount =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Alpha_context.Commitment.delete ctxt
              blinded_pkh)
            (fun ctxt =>
              let contract :=
                Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract
                  (Signature.Ed25519 pkh) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Alpha_context.Contract.credit ctxt
                  contract amount)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (ctxt,
                      (Single_result
                        (Activate_account_result
                          (cons ((Contract contract), (Credited amount)) []))))))
        end)
  |
    Single
      (Proposals {|
        source := source; period := period; proposals := proposals |}) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.Roll.delegate_pubkey ctxt source)
      (fun delegate =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Operation.check_signature
            delegate chain_id operation)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let level :=
                Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                  (Tezos_raw_protocol_alpha.Alpha_context.Voting_period.op_eq
                    (voting_period level) period)
                  (Wrong_voting_period (voting_period level) period))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Amendment.record_proposals ctxt
                        source proposals)
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (ctxt, (Single_result Proposals_result)))
                  end)
            end))
  |
    Single
      (Ballot {|
        source := source;
          period := period;
          proposal := proposal;
          ballot := ballot
          |}) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.Roll.delegate_pubkey ctxt source)
      (fun delegate =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Operation.check_signature
            delegate chain_id operation)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let level :=
                Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                  (Tezos_raw_protocol_alpha.Alpha_context.Voting_period.op_eq
                    (voting_period level) period)
                  (Wrong_voting_period (voting_period level) period))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Amendment.record_ballot ctxt
                        source proposal ballot)
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (ctxt, (Single_result Ballot_result)))
                  end)
            end))
  | (Single (Manager_operation _)) as op =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (precheck_manager_contents_list ctxt chain_id operation op)
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
          (apply_manager_contents_list ctxt mode baker chain_id op)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, result) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, result)
            end))
  | (Cons (Manager_operation _) _) as op =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (precheck_manager_contents_list ctxt chain_id operation op)
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
          (apply_manager_contents_list ctxt mode baker chain_id op)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, result) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, result)
            end))
  end.

Definition apply_operation {A : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (pred_block :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (hash :
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (operation : Tezos_raw_protocol_alpha.Alpha_context.operation A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha__Alpha_context.context *
        (Tezos_raw_protocol_alpha.Apply_results.operation_metadata A))) :=
  let ctxt :=
    Tezos_raw_protocol_alpha.Alpha_context.Contract.init_origination_nonce ctxt
      hash in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (apply_contents_list ctxt chain_id mode pred_block baker operation
      (contents (protocol_data operation)))
    (fun function_parameter =>
      match function_parameter with
      | (ctxt, result) =>
        let ctxt :=
          Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited ctxt in
        let ctxt :=
          Tezos_raw_protocol_alpha.Alpha_context.Contract.unset_origination_nonce
            ctxt in
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (ctxt, {| contents := result |})
      end).

Definition may_snapshot_roll
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  let level := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
  let blocks_per_roll_snapshot :=
    Tezos_raw_protocol_alpha.Alpha_context.Constants.blocks_per_roll_snapshot
      ctxt in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
      (Tezos_protocol_environment_alpha__Environment.Int32.rem
        (cycle_position level) blocks_per_roll_snapshot)
      (Tezos_protocol_environment_alpha__Environment.Int32.pred
        blocks_per_roll_snapshot) then
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.Roll.snapshot_rolls ctxt)
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt)
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt.

Definition may_start_new_cycle
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates *
        (list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Baking.dawn_of_a_new_cycle ctxt)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (ctxt, [], [])
      | Some last_cycle =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Seed.cycle_end ctxt last_cycle)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, unrevealed) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Alpha_context.Roll.cycle_end ctxt
                  last_cycle)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.cycle_end
                      ctxt last_cycle unrevealed)
                    (fun function_parameter =>
                      match function_parameter with
                      | (ctxt, update_balances, deactivated) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Bootstrap.cycle_end
                            ctxt last_cycle)
                          (fun ctxt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              (ctxt, update_balances, deactivated))
                      end))
            end)
      end).

Definition begin_full_construction
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (pred_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents *
        Tezos_raw_protocol_alpha.Alpha_context.public_key *
        Tezos_raw_protocol_alpha.Alpha_context.Period.t)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.Global.set_block_priority ctxt
      (Block_header.priority protocol_data))
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Baking.check_baking_rights ctxt protocol_data
          pred_timestamp)
        (fun function_parameter =>
          match function_parameter with
          | (delegate_pk, block_delay) =>
            let ctxt :=
              Tezos_raw_protocol_alpha.Alpha_context.Fitness.increase None ctxt
              in
            match
              Tezos_raw_protocol_alpha.Alpha_context.Level.pred ctxt
                (Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt) with
            | None => false
            | Some pred_level =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Baking.endorsement_rights ctxt
                  pred_level)
                (fun rights =>
                  let ctxt :=
                    Tezos_raw_protocol_alpha.Alpha_context.init_endorsements
                      ctxt rights in
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (ctxt, protocol_data, delegate_pk, block_delay))
            end
          end)).

Definition begin_partial_construction
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let ctxt := Tezos_raw_protocol_alpha.Alpha_context.Fitness.increase None ctxt
    in
  match
    Tezos_raw_protocol_alpha.Alpha_context.Level.pred ctxt
      (Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt) with
  | None => false
  | Some pred_level =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Baking.endorsement_rights ctxt pred_level)
      (fun rights =>
        let ctxt :=
          Tezos_raw_protocol_alpha.Alpha_context.init_endorsements ctxt rights
          in
        Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt)
  end.

Definition begin_application
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  (pred_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        Tezos_raw_protocol_alpha.Alpha_context.public_key *
        Tezos_raw_protocol_alpha.Alpha_context.Period.t)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.Global.set_block_priority ctxt
      (priority (contents (Block_header.protocol_data block_header))))
    (fun ctxt =>
      let current_level :=
        Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Baking.check_proof_of_work_stamp ctxt
          block_header)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Baking.check_fitness_gap ctxt
                block_header)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Baking.check_baking_rights ctxt
                      (contents (protocol_data block_header)) pred_timestamp)
                    (fun function_parameter =>
                      match function_parameter with
                      | (delegate_pk, block_delay) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Baking.check_signature
                            block_header chain_id delegate_pk)
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              let has_commitment :=
                                match
                                  seed_nonce_hash
                                    (contents (protocol_data block_header)) with
                                | None => false
                                | Some _ => true
                                end in
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                                  (Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                                    has_commitment
                                    (expected_commitment current_level))
                                  (Invalid_commitment
                                    {|
                                      expected :=
                                        expected_commitment current_level |}))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    let ctxt :=
                                      Tezos_raw_protocol_alpha.Alpha_context.Fitness.increase
                                        None ctxt in
                                    match
                                      Tezos_raw_protocol_alpha.Alpha_context.Level.pred
                                        ctxt
                                        (Tezos_raw_protocol_alpha.Alpha_context.Level.current
                                          ctxt) with
                                    | None => false
                                    | Some pred_level =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_raw_protocol_alpha.Baking.endorsement_rights
                                          ctxt pred_level)
                                        (fun rights =>
                                          let ctxt :=
                                            Tezos_raw_protocol_alpha.Alpha_context.init_endorsements
                                              ctxt rights in
                                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                            (ctxt, delegate_pk, block_delay))
                                    end
                                  end)
                            end)
                      end)
                end)
          end)).

Definition check_minimum_endorsements
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
  (included_endorsements :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let minimum :=
    Tezos_raw_protocol_alpha.Baking.minimum_allowed_endorsements ctxt
      block_delay in
  let timestamp := Tezos_raw_protocol_alpha.Alpha_context.Timestamp.current ctxt
    in
  Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
    (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
      included_endorsements minimum)
    (Not_enough_endorsements_for_priority
      {| required := minimum; priority := Block_header.priority protocol_data;
        endorsements := included_endorsements; timestamp := timestamp |}).

Definition finalize_application
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        Tezos_raw_protocol_alpha.Apply_results.block_metadata)) :=
  let included_endorsements :=
    Tezos_raw_protocol_alpha.Alpha_context.included_endorsements ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (check_minimum_endorsements ctxt protocol_data block_delay
      included_endorsements)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let deposit :=
          Tezos_raw_protocol_alpha.Alpha_context.Constants.block_security_deposit
            ctxt in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.add_deposit ctxt delegate
            deposit)
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Baking.baking_reward ctxt
                (priority protocol_data) included_endorsements)
              (fun reward =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Alpha_context.add_rewards ctxt
                    reward)
                  (fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.fold
                        (fun delegate =>
                          fun deposit =>
                            fun ctxt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                ctxt
                                (fun ctxt =>
                                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.freeze_deposit
                                    ctxt delegate deposit))
                        (Tezos_raw_protocol_alpha.Alpha_context.get_deposits
                          ctxt)
                        (Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          ctxt))
                      (fun ctxt =>
                        let fees :=
                          Tezos_raw_protocol_alpha.Alpha_context.get_fees ctxt
                          in
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Delegate.freeze_fees
                            ctxt delegate fees)
                          (fun ctxt =>
                            let rewards :=
                              Tezos_raw_protocol_alpha.Alpha_context.get_rewards
                                ctxt in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Alpha_context.Delegate.freeze_rewards
                                ctxt delegate rewards)
                              (fun ctxt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  match
                                    Block_header.seed_nonce_hash protocol_data
                                    with
                                  | None =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                      ctxt
                                  | Some nonce_hash =>
                                    Tezos_raw_protocol_alpha.Alpha_context.Nonce.record_hash
                                      ctxt
                                      {| nonce_hash := nonce_hash;
                                        delegate := delegate;
                                        rewards := rewards; fees := fees |}
                                  end
                                  (fun ctxt =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (may_snapshot_roll ctxt)
                                      (fun ctxt =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (may_start_new_cycle ctxt)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              (ctxt, balance_updates,
                                                deactivated) =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_raw_protocol_alpha.Amendment.may_start_new_voting_period
                                                  ctxt)
                                                (fun ctxt =>
                                                  let cycle :=
                                                    cycle
                                                      (Tezos_raw_protocol_alpha.Alpha_context.Level.current
                                                        ctxt) in
                                                  let balance_updates :=
                                                    Tezos_raw_protocol_alpha.Alpha_context.Delegate.cleanup_balance_updates
                                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                                        (cons
                                                          ((Contract
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract
                                                              delegate)),
                                                            (Debited deposit))
                                                          (cons
                                                            ((Deposits delegate
                                                              cycle),
                                                              (Credited deposit))
                                                            (cons
                                                              ((Rewards delegate
                                                                cycle),
                                                                (Credited reward))
                                                              [])))
                                                        balance_updates) in
                                                  let consumed_gas :=
                                                    Tezos_protocol_environment_alpha__Environment.Z.sub
                                                      (Tezos_raw_protocol_alpha.Alpha_context.Constants.hard_gas_limit_per_block
                                                        ctxt)
                                                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.block_level
                                                        ctxt) in
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_period_kind
                                                      ctxt)
                                                    (fun voting_period_kind =>
                                                      let receipt :=
                                                        {| baker := delegate;
                                                          level :=
                                                            Tezos_raw_protocol_alpha.Alpha_context.Level.current
                                                              ctxt;
                                                          voting_period_kind :=
                                                            voting_period_kind;
                                                          nonce_hash :=
                                                            seed_nonce_hash
                                                              protocol_data;
                                                          consumed_gas :=
                                                            consumed_gas;
                                                          deactivated :=
                                                            deactivated;
                                                          balance_updates :=
                                                            balance_updates |}
                                                        in
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                        (ctxt, receipt)))
                                            end)))))))))
      end).
src/proto_alpha/lib_protocol/apply_results.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Data_encoding

let error_encoding =
  def
    "error"
    ~description:
      "The full list of RPC errors would be too long to include.\n\
       It is available at RPC `/errors` (GET).\n\
       Errors specific to protocol Alpha have an id that starts with \
       `proto.alpha`."
  @@ splitted
       ~json:
         (conv
            (fun err ->
              Data_encoding.Json.construct Error_monad.error_encoding err)
            (fun json ->
              Data_encoding.Json.destruct Error_monad.error_encoding json)
            json)
       ~binary:Error_monad.error_encoding

type _ successful_manager_operation_result =
  | Reveal_result : {
      consumed_gas : Z.t;
    }
      -> Kind.reveal successful_manager_operation_result
  | Transaction_result : {
      storage : Script.expr option;
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
      allocated_destination_contract : bool;
    }
      -> Kind.transaction successful_manager_operation_result
  | Origination_result : {
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
    }
      -> Kind.origination successful_manager_operation_result
  | Delegation_result : {
      consumed_gas : Z.t;
    }
      -> Kind.delegation successful_manager_operation_result

type packed_successful_manager_operation_result =
  | Successful_manager_result :
      'kind successful_manager_operation_result
      -> packed_successful_manager_operation_result

type 'kind manager_operation_result =
  | Applied of 'kind successful_manager_operation_result
  | Backtracked of
      'kind successful_manager_operation_result * error list option
  | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
  | Skipped : 'kind Kind.manager -> 'kind manager_operation_result

type packed_internal_operation_result =
  | Internal_operation_result :
      'kind internal_operation * 'kind manager_operation_result
      -> packed_internal_operation_result

module Manager_result = struct
  type 'kind case =
    | MCase : {
        op_case : 'kind Operation.Encoding.Manager_operations.case;
        encoding : 'a Data_encoding.t;
        kind : 'kind Kind.manager;
        iselect :
          packed_internal_operation_result ->
          ('kind internal_operation * 'kind manager_operation_result) option;
        select :
          packed_successful_manager_operation_result ->
          'kind successful_manager_operation_result option;
        proj : 'kind successful_manager_operation_result -> 'a;
        inj : 'a -> 'kind successful_manager_operation_result;
        t : 'kind manager_operation_result Data_encoding.t;
      }
        -> 'kind case

  let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj =
    let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in
    let t =
      def (Format.asprintf "operation.alpha.operation_result.%s" name)
      @@ union
           ~tag_size:`Uint8
           [ case
               (Tag 0)
               ~title:"Applied"
               (merge_objs (obj1 (req "status" (constant "applied"))) encoding)
               (fun o ->
                 match o with
                 | Skipped _ | Failed _ | Backtracked _ ->
                     None
                 | Applied o -> (
                   match select (Successful_manager_result o) with
                   | None ->
                       None
                   | Some o ->
                       Some ((), proj o) ))
               (fun ((), x) -> Applied (inj x));
             case
               (Tag 1)
               ~title:"Failed"
               (obj2
                  (req "status" (constant "failed"))
                  (req "errors" (list error_encoding)))
               (function Failed (_, errs) -> Some ((), errs) | _ -> None)
               (fun ((), errs) -> Failed (kind, errs));
             case
               (Tag 2)
               ~title:"Skipped"
               (obj1 (req "status" (constant "skipped")))
               (function Skipped _ -> Some () | _ -> None)
               (fun () -> Skipped kind);
             case
               (Tag 3)
               ~title:"Backtracked"
               (merge_objs
                  (obj2
                     (req "status" (constant "backtracked"))
                     (opt "errors" (list error_encoding)))
                  encoding)
               (fun o ->
                 match o with
                 | Skipped _ | Failed _ | Applied _ ->
                     None
                 | Backtracked (o, errs) -> (
                   match select (Successful_manager_result o) with
                   | None ->
                       None
                   | Some o ->
                       Some (((), errs), proj o) ))
               (fun (((), errs), x) -> Backtracked (inj x, errs)) ]
    in
    MCase {op_case; encoding; kind; iselect; select; proj; inj; t}

  let reveal_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.reveal_case
      ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
      ~iselect:(function
        | Internal_operation_result (({operation = Reveal _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Reveal_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Reveal_manager_kind
      ~proj:(function Reveal_result {consumed_gas} -> consumed_gas)
      ~inj:(fun consumed_gas -> Reveal_result {consumed_gas})

  let transaction_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.transaction_case
      ~encoding:
        (obj8
           (opt "storage" Script.expr_encoding)
           (opt "big_map_diff" Contract.big_map_diff_encoding)
           (dft "balance_updates" Delegate.balance_updates_encoding [])
           (dft "originated_contracts" (list Contract.encoding) [])
           (dft "consumed_gas" z Z.zero)
           (dft "storage_size" z Z.zero)
           (dft "paid_storage_size_diff" z Z.zero)
           (dft "allocated_destination_contract" bool false))
      ~iselect:(function
        | Internal_operation_result
            (({operation = Transaction _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Transaction_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Transaction_manager_kind
      ~proj:(function
        | Transaction_result
            { storage;
              big_map_diff;
              balance_updates;
              originated_contracts;
              consumed_gas;
              storage_size;
              paid_storage_size_diff;
              allocated_destination_contract } ->
            ( storage,
              big_map_diff,
              balance_updates,
              originated_contracts,
              consumed_gas,
              storage_size,
              paid_storage_size_diff,
              allocated_destination_contract ))
      ~inj:
        (fun ( storage,
               big_map_diff,
               balance_updates,
               originated_contracts,
               consumed_gas,
               storage_size,
               paid_storage_size_diff,
               allocated_destination_contract ) ->
        Transaction_result
          {
            storage;
            big_map_diff;
            balance_updates;
            originated_contracts;
            consumed_gas;
            storage_size;
            paid_storage_size_diff;
            allocated_destination_contract;
          })

  let origination_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.origination_case
      ~encoding:
        (obj6
           (opt "big_map_diff" Contract.big_map_diff_encoding)
           (dft "balance_updates" Delegate.balance_updates_encoding [])
           (dft "originated_contracts" (list Contract.encoding) [])
           (dft "consumed_gas" z Z.zero)
           (dft "storage_size" z Z.zero)
           (dft "paid_storage_size_diff" z Z.zero))
      ~iselect:(function
        | Internal_operation_result
            (({operation = Origination _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Origination_result _ as op) ->
            Some op
        | _ ->
            None)
      ~proj:(function
        | Origination_result
            { big_map_diff;
              balance_updates;
              originated_contracts;
              consumed_gas;
              storage_size;
              paid_storage_size_diff } ->
            ( big_map_diff,
              balance_updates,
              originated_contracts,
              consumed_gas,
              storage_size,
              paid_storage_size_diff ))
      ~kind:Kind.Origination_manager_kind
      ~inj:
        (fun ( big_map_diff,
               balance_updates,
               originated_contracts,
               consumed_gas,
               storage_size,
               paid_storage_size_diff ) ->
        Origination_result
          {
            big_map_diff;
            balance_updates;
            originated_contracts;
            consumed_gas;
            storage_size;
            paid_storage_size_diff;
          })

  let delegation_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.delegation_case
      ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
      ~iselect:(function
        | Internal_operation_result (({operation = Delegation _; _} as op), res)
          ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Delegation_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Delegation_manager_kind
      ~proj:(function Delegation_result {consumed_gas} -> consumed_gas)
      ~inj:(fun consumed_gas -> Delegation_result {consumed_gas})
end

let internal_operation_result_encoding :
    packed_internal_operation_result Data_encoding.t =
  let make (type kind)
      (Manager_result.MCase res_case : kind Manager_result.case) =
    let (Operation.Encoding.Manager_operations.MCase op_case) =
      res_case.op_case
    in
    case
      (Tag op_case.tag)
      ~title:op_case.name
      (merge_objs
         (obj3
            (req "kind" (constant op_case.name))
            (req "source" Contract.encoding)
            (req "nonce" uint16))
         (merge_objs op_case.encoding (obj1 (req "result" res_case.t))))
      (fun op ->
        match res_case.iselect op with
        | Some (op, res) ->
            Some (((), op.source, op.nonce), (op_case.proj op.operation, res))
        | None ->
            None)
      (fun (((), source, nonce), (op, res)) ->
        let op = {source; operation = op_case.inj op; nonce} in
        Internal_operation_result (op, res))
  in
  def "operation.alpha.internal_operation_result"
  @@ union
       [ make Manager_result.reveal_case;
         make Manager_result.transaction_case;
         make Manager_result.origination_case;
         make Manager_result.delegation_case ]

type 'kind contents_result =
  | Endorsement_result : {
      balance_updates : Delegate.balance_updates;
      delegate : Signature.Public_key_hash.t;
      slots : int list;
    }
      -> Kind.endorsement contents_result
  | Seed_nonce_revelation_result :
      Delegate.balance_updates
      -> Kind.seed_nonce_revelation contents_result
  | Double_endorsement_evidence_result :
      Delegate.balance_updates
      -> Kind.double_endorsement_evidence contents_result
  | Double_baking_evidence_result :
      Delegate.balance_updates
      -> Kind.double_baking_evidence contents_result
  | Activate_account_result :
      Delegate.balance_updates
      -> Kind.activate_account contents_result
  | Proposals_result : Kind.proposals contents_result
  | Ballot_result : Kind.ballot contents_result
  | Manager_operation_result : {
      balance_updates : Delegate.balance_updates;
      operation_result : 'kind manager_operation_result;
      internal_operation_results : packed_internal_operation_result list;
    }
      -> 'kind Kind.manager contents_result

type packed_contents_result =
  | Contents_result : 'kind contents_result -> packed_contents_result

type packed_contents_and_result =
  | Contents_and_result :
      'kind Operation.contents * 'kind contents_result
      -> packed_contents_and_result

type ('a, 'b) eq = Eq : ('a, 'a) eq

let equal_manager_kind :
    type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option =
 fun ka kb ->
  match (ka, kb) with
  | (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) ->
      Some Eq
  | (Kind.Reveal_manager_kind, _) ->
      None
  | (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) ->
      Some Eq
  | (Kind.Transaction_manager_kind, _) ->
      None
  | (Kind.Origination_manager_kind, Kind.Origination_manager_kind) ->
      Some Eq
  | (Kind.Origination_manager_kind, _) ->
      None
  | (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) ->
      Some Eq
  | (Kind.Delegation_manager_kind, _) ->
      None

module Encoding = struct
  type 'kind case =
    | Case : {
        op_case : 'kind Operation.Encoding.case;
        encoding : 'a Data_encoding.t;
        select : packed_contents_result -> 'kind contents_result option;
        mselect :
          packed_contents_and_result ->
          ('kind contents * 'kind contents_result) option;
        proj : 'kind contents_result -> 'a;
        inj : 'a -> 'kind contents_result;
      }
        -> 'kind case

  let tagged_case tag name args proj inj =
    let open Data_encoding in
    case
      tag
      ~title:(String.capitalize_ascii name)
      (merge_objs (obj1 (req "kind" (constant name))) args)
      (fun x -> match proj x with None -> None | Some x -> Some ((), x))
      (fun ((), x) -> inj x)

  let endorsement_case =
    Case
      {
        op_case = Operation.Encoding.endorsement_case;
        encoding =
          obj3
            (req "balance_updates" Delegate.balance_updates_encoding)
            (req "delegate" Signature.Public_key_hash.encoding)
            (req "slots" (list uint8));
        select =
          (function
          | Contents_result (Endorsement_result _ as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Endorsement _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj =
          (function
          | Endorsement_result {balance_updates; delegate; slots} ->
              (balance_updates, delegate, slots));
        inj =
          (fun (balance_updates, delegate, slots) ->
            Endorsement_result {balance_updates; delegate; slots});
      }

  let seed_nonce_revelation_case =
    Case
      {
        op_case = Operation.Encoding.seed_nonce_revelation_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Seed_nonce_revelation_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Seed_nonce_revelation _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Seed_nonce_revelation_result bus) -> bus);
        inj = (fun bus -> Seed_nonce_revelation_result bus);
      }

  let double_endorsement_evidence_case =
    Case
      {
        op_case = Operation.Encoding.double_endorsement_evidence_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Double_endorsement_evidence_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Double_endorsement_evidence _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Double_endorsement_evidence_result bus) -> bus);
        inj = (fun bus -> Double_endorsement_evidence_result bus);
      }

  let double_baking_evidence_case =
    Case
      {
        op_case = Operation.Encoding.double_baking_evidence_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Double_baking_evidence_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Double_baking_evidence _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Double_baking_evidence_result bus) -> bus);
        inj = (fun bus -> Double_baking_evidence_result bus);
      }

  let activate_account_case =
    Case
      {
        op_case = Operation.Encoding.activate_account_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Activate_account_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Activate_account _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Activate_account_result bus) -> bus);
        inj = (fun bus -> Activate_account_result bus);
      }

  let proposals_case =
    Case
      {
        op_case = Operation.Encoding.proposals_case;
        encoding = Data_encoding.empty;
        select =
          (function
          | Contents_result (Proposals_result as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Proposals _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun Proposals_result -> ());
        inj = (fun () -> Proposals_result);
      }

  let ballot_case =
    Case
      {
        op_case = Operation.Encoding.ballot_case;
        encoding = Data_encoding.empty;
        select =
          (function
          | Contents_result (Ballot_result as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Ballot _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun Ballot_result -> ());
        inj = (fun () -> Ballot_result);
      }

  let make_manager_case (type kind)
      (Operation.Encoding.Case op_case :
        kind Kind.manager Operation.Encoding.case)
      (Manager_result.MCase res_case : kind Manager_result.case) mselect =
    Case
      {
        op_case = Operation.Encoding.Case op_case;
        encoding =
          obj3
            (req "balance_updates" Delegate.balance_updates_encoding)
            (req "operation_result" res_case.t)
            (dft
               "internal_operation_results"
               (list internal_operation_result_encoding)
               []);
        select =
          (function
          | Contents_result
              (Manager_operation_result
                ({operation_result = Applied res; _} as op)) -> (
            match res_case.select (Successful_manager_result res) with
            | Some res ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Applied res})
            | None ->
                None )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Backtracked (res, errs); _} as op)) -> (
            match res_case.select (Successful_manager_result res) with
            | Some res ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Backtracked (res, errs)})
            | None ->
                None )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Skipped kind; _} as op)) -> (
            match equal_manager_kind kind res_case.kind with
            | None ->
                None
            | Some Eq ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Skipped kind}) )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Failed (kind, errs); _} as op)) -> (
            match equal_manager_kind kind res_case.kind with
            | None ->
                None
            | Some Eq ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Failed (kind, errs)}) )
          | Contents_result Ballot_result ->
              None
          | Contents_result (Endorsement_result _) ->
              None
          | Contents_result (Seed_nonce_revelation_result _) ->
              None
          | Contents_result (Double_endorsement_evidence_result _) ->
              None
          | Contents_result (Double_baking_evidence_result _) ->
              None
          | Contents_result (Activate_account_result _) ->
              None
          | Contents_result Proposals_result ->
              None);
        mselect;
        proj =
          (fun (Manager_operation_result
                 { balance_updates = bus;
                   operation_result = r;
                   internal_operation_results = rs }) ->
            (bus, r, rs));
        inj =
          (fun (bus, r, rs) ->
            Manager_operation_result
              {
                balance_updates = bus;
                operation_result = r;
                internal_operation_results = rs;
              });
      }

  let reveal_case =
    make_manager_case
      Operation.Encoding.reveal_case
      Manager_result.reveal_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Reveal _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let transaction_case =
    make_manager_case
      Operation.Encoding.transaction_case
      Manager_result.transaction_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Transaction _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let origination_case =
    make_manager_case
      Operation.Encoding.origination_case
      Manager_result.origination_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Origination _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let delegation_case =
    make_manager_case
      Operation.Encoding.delegation_case
      Manager_result.delegation_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Delegation _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
end

let contents_result_encoding =
  let open Encoding in
  let make
      (Case
        { op_case = Operation.Encoding.Case {tag; name; _};
          encoding;
          mselect = _;
          select;
          proj;
          inj }) =
    let proj x =
      match select x with None -> None | Some x -> Some (proj x)
    in
    let inj x = Contents_result (inj x) in
    tagged_case (Tag tag) name encoding proj inj
  in
  def "operation.alpha.contents_result"
  @@ union
       [ make endorsement_case;
         make seed_nonce_revelation_case;
         make double_endorsement_evidence_case;
         make double_baking_evidence_case;
         make activate_account_case;
         make proposals_case;
         make ballot_case;
         make reveal_case;
         make transaction_case;
         make origination_case;
         make delegation_case ]

let contents_and_result_encoding =
  let open Encoding in
  let make
      (Case
        { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _};
          mselect;
          encoding = meta_encoding;
          proj = meta_proj;
          inj = meta_inj;
          _ }) =
    let proj c =
      match mselect c with
      | Some (op, res) ->
          Some (proj op, meta_proj res)
      | _ ->
          None
    in
    let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
    let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in
    tagged_case (Tag tag) name encoding proj inj
  in
  def "operation.alpha.operation_contents_and_result"
  @@ union
       [ make endorsement_case;
         make seed_nonce_revelation_case;
         make double_endorsement_evidence_case;
         make double_baking_evidence_case;
         make activate_account_case;
         make proposals_case;
         make ballot_case;
         make reveal_case;
         make transaction_case;
         make origination_case;
         make delegation_case ]

type 'kind contents_result_list =
  | Single_result : 'kind contents_result -> 'kind contents_result_list
  | Cons_result :
      'kind Kind.manager contents_result
      * 'rest Kind.manager contents_result_list
      -> ('kind * 'rest) Kind.manager contents_result_list

type packed_contents_result_list =
  | Contents_result_list :
      'kind contents_result_list
      -> packed_contents_result_list

let contents_result_list_encoding =
  let rec to_list = function
    | Contents_result_list (Single_result o) ->
        [Contents_result o]
    | Contents_result_list (Cons_result (o, os)) ->
        Contents_result o :: to_list (Contents_result_list os)
  in
  let rec of_list = function
    | [] ->
        Pervasives.failwith "cannot decode empty operation result"
    | [Contents_result o] ->
        Contents_result_list (Single_result o)
    | Contents_result o :: os -> (
        let (Contents_result_list os) = of_list os in
        match (o, os) with
        | ( Manager_operation_result _,
            Single_result (Manager_operation_result _) ) ->
            Contents_result_list (Cons_result (o, os))
        | (Manager_operation_result _, Cons_result _) ->
            Contents_result_list (Cons_result (o, os))
        | _ ->
            Pervasives.failwith "cannot decode ill-formed operation result" )
  in
  def "operation.alpha.contents_list_result"
  @@ conv to_list of_list (list contents_result_encoding)

type 'kind contents_and_result_list =
  | Single_and_result :
      'kind Alpha_context.contents * 'kind contents_result
      -> 'kind contents_and_result_list
  | Cons_and_result :
      'kind Kind.manager Alpha_context.contents
      * 'kind Kind.manager contents_result
      * 'rest Kind.manager contents_and_result_list
      -> ('kind * 'rest) Kind.manager contents_and_result_list

type packed_contents_and_result_list =
  | Contents_and_result_list :
      'kind contents_and_result_list
      -> packed_contents_and_result_list

let contents_and_result_list_encoding =
  let rec to_list = function
    | Contents_and_result_list (Single_and_result (op, res)) ->
        [Contents_and_result (op, res)]
    | Contents_and_result_list (Cons_and_result (op, res, rest)) ->
        Contents_and_result (op, res)
        :: to_list (Contents_and_result_list rest)
  in
  let rec of_list = function
    | [] ->
        Pervasives.failwith "cannot decode empty combined operation result"
    | [Contents_and_result (op, res)] ->
        Contents_and_result_list (Single_and_result (op, res))
    | Contents_and_result (op, res) :: rest -> (
        let (Contents_and_result_list rest) = of_list rest in
        match (op, rest) with
        | (Manager_operation _, Single_and_result (Manager_operation _, _)) ->
            Contents_and_result_list (Cons_and_result (op, res, rest))
        | (Manager_operation _, Cons_and_result (_, _, _)) ->
            Contents_and_result_list (Cons_and_result (op, res, rest))
        | _ ->
            Pervasives.failwith
              "cannot decode ill-formed combined operation result" )
  in
  conv to_list of_list (Variable.list contents_and_result_encoding)

type 'kind operation_metadata = {contents : 'kind contents_result_list}

type packed_operation_metadata =
  | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
  | No_operation_metadata : packed_operation_metadata

let operation_metadata_encoding =
  def "operation.alpha.result"
  @@ union
       [ case
           (Tag 0)
           ~title:"Operation_metadata"
           contents_result_list_encoding
           (function
             | Operation_metadata {contents} ->
                 Some (Contents_result_list contents)
             | _ ->
                 None)
           (fun (Contents_result_list contents) ->
             Operation_metadata {contents});
         case
           (Tag 1)
           ~title:"No_operation_metadata"
           empty
           (function No_operation_metadata -> Some () | _ -> None)
           (fun () -> No_operation_metadata) ]

let kind_equal :
    type kind kind2.
    kind contents -> kind2 contents_result -> (kind, kind2) eq option =
 fun op res ->
  match (op, res) with
  | (Endorsement _, Endorsement_result _) ->
      Some Eq
  | (Endorsement _, _) ->
      None
  | (Seed_nonce_revelation _, Seed_nonce_revelation_result _) ->
      Some Eq
  | (Seed_nonce_revelation _, _) ->
      None
  | (Double_endorsement_evidence _, Double_endorsement_evidence_result _) ->
      Some Eq
  | (Double_endorsement_evidence _, _) ->
      None
  | (Double_baking_evidence _, Double_baking_evidence_result _) ->
      Some Eq
  | (Double_baking_evidence _, _) ->
      None
  | (Activate_account _, Activate_account_result _) ->
      Some Eq
  | (Activate_account _, _) ->
      None
  | (Proposals _, Proposals_result) ->
      Some Eq
  | (Proposals _, _) ->
      None
  | (Ballot _, Ballot_result) ->
      Some Eq
  | (Ballot _, _) ->
      None
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result {operation_result = Applied (Reveal_result _); _}
    ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        {operation_result = Backtracked (Reveal_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        { operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _}
    ) ->
      Some Eq
  | (Manager_operation {operation = Reveal _; _}, _) ->
      None
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        {operation_result = Applied (Transaction_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        {operation_result = Backtracked (Transaction_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Transaction_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Transaction _; _}, _) ->
      None
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        {operation_result = Applied (Origination_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        {operation_result = Backtracked (Origination_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Origination_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Origination_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Origination _; _}, _) ->
      None
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        {operation_result = Applied (Delegation_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        {operation_result = Backtracked (Delegation_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Delegation_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Delegation _; _}, _) ->
      None

let rec kind_equal_list :
    type kind kind2.
    kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option
    =
 fun contents res ->
  match (contents, res) with
  | (Single op, Single_result res) -> (
    match kind_equal op res with None -> None | Some Eq -> Some Eq )
  | (Cons (op, ops), Cons_result (res, ress)) -> (
    match kind_equal op res with
    | None ->
        None
    | Some Eq -> (
      match kind_equal_list ops ress with None -> None | Some Eq -> Some Eq ) )
  | _ ->
      None

let rec pack_contents_list :
    type kind.
    kind contents_list ->
    kind contents_result_list ->
    kind contents_and_result_list =
 fun contents res ->
  match (contents, res) with
  | (Single op, Single_result res) ->
      Single_and_result (op, res)
  | (Cons (op, ops), Cons_result (res, ress)) ->
      Cons_and_result (op, res, pack_contents_list ops ress)
  | ( Single (Manager_operation _),
      Cons_result (Manager_operation_result _, Single_result _) ) ->
      .
  | ( Cons (_, _),
      Single_result (Manager_operation_result {operation_result = Failed _; _})
    ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Skipped _; _}) ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Applied _; _}) ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Backtracked _; _}) ) ->
      .
  | (Single _, Cons_result _) ->
      .

let rec unpack_contents_list :
    type kind.
    kind contents_and_result_list ->
    kind contents_list * kind contents_result_list = function
  | Single_and_result (op, res) ->
      (Single op, Single_result res)
  | Cons_and_result (op, res, rest) ->
      let (ops, ress) = unpack_contents_list rest in
      (Cons (op, ops), Cons_result (res, ress))

let rec to_list = function
  | Contents_result_list (Single_result o) ->
      [Contents_result o]
  | Contents_result_list (Cons_result (o, os)) ->
      Contents_result o :: to_list (Contents_result_list os)

let rec of_list = function
  | [] ->
      assert false
  | [Contents_result o] ->
      Contents_result_list (Single_result o)
  | Contents_result o :: os -> (
      let (Contents_result_list os) = of_list os in
      match (o, os) with
      | (Manager_operation_result _, Single_result (Manager_operation_result _))
        ->
          Contents_result_list (Cons_result (o, os))
      | (Manager_operation_result _, Cons_result _) ->
          Contents_result_list (Cons_result (o, os))
      | _ ->
          Pervasives.failwith
            "Operation result list of length > 1 should only contains manager \
             operations result." )

let operation_data_and_metadata_encoding =
  def "operation.alpha.operation_with_metadata"
  @@ union
       [ case
           (Tag 0)
           ~title:"Operation_with_metadata"
           (obj2
              (req "contents" (dynamic_size contents_and_result_list_encoding))
              (opt "signature" Signature.encoding))
           (function
             | (Operation_data _, No_operation_metadata) ->
                 None
             | (Operation_data op, Operation_metadata res) -> (
               match kind_equal_list op.contents res.contents with
               | None ->
                   Pervasives.failwith
                     "cannot decode inconsistent combined operation result"
               | Some Eq ->
                   Some
                     ( Contents_and_result_list
                         (pack_contents_list op.contents res.contents),
                       op.signature ) ))
           (fun (Contents_and_result_list contents, signature) ->
             let (op_contents, res_contents) = unpack_contents_list contents in
             ( Operation_data {contents = op_contents; signature},
               Operation_metadata {contents = res_contents} ));
         case
           (Tag 1)
           ~title:"Operation_without_metadata"
           (obj2
              (req "contents" (dynamic_size Operation.contents_list_encoding))
              (opt "signature" Signature.encoding))
           (function
             | (Operation_data op, No_operation_metadata) ->
                 Some (Contents_list op.contents, op.signature)
             | (Operation_data _, Operation_metadata _) ->
                 None)
           (fun (Contents_list contents, signature) ->
             (Operation_data {contents; signature}, No_operation_metadata)) ]

type block_metadata = {
  baker : Signature.Public_key_hash.t;
  level : Level.t;
  voting_period_kind : Voting_period.kind;
  nonce_hash : Nonce_hash.t option;
  consumed_gas : Z.t;
  deactivated : Signature.Public_key_hash.t list;
  balance_updates : Delegate.balance_updates;
}

let block_metadata_encoding =
  let open Data_encoding in
  def "block_header.alpha.metadata"
  @@ conv
       (fun { baker;
              level;
              voting_period_kind;
              nonce_hash;
              consumed_gas;
              deactivated;
              balance_updates } ->
         ( baker,
           level,
           voting_period_kind,
           nonce_hash,
           consumed_gas,
           deactivated,
           balance_updates ))
       (fun ( baker,
              level,
              voting_period_kind,
              nonce_hash,
              consumed_gas,
              deactivated,
              balance_updates ) ->
         {
           baker;
           level;
           voting_period_kind;
           nonce_hash;
           consumed_gas;
           deactivated;
           balance_updates;
         })
       (obj7
          (req "baker" Signature.Public_key_hash.encoding)
          (req "level" Level.encoding)
          (req "voting_period_kind" Voting_period.kind_encoding)
          (req "nonce_hash" (option Nonce_hash.encoding))
          (req "consumed_gas" (check_size 10 n))
          (req "deactivated" (list Signature.Public_key_hash.encoding))
          (req "balance_updates" Delegate.balance_updates_encoding))
src/proto_alpha/lib_protocol/apply_results.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_protocol_environment_alpha__Environment.Data_encoding.

Definition error_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "error" % string expected_argument
        (Some
          "The full list of RPC errors would be too long to include.
It is available at RPC `/errors` (GET).
Errors specific to protocol Alpha have an id that starts with `proto.alpha`."
            % string) in
    fun eta => arg None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.splitted
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
        (fun err =>
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Json.construct
            Tezos_protocol_environment_alpha__Environment.Error_monad.error_encoding
            err)
        (fun json =>
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Json.destruct
            Tezos_protocol_environment_alpha__Environment.Error_monad.error_encoding
            json) None
        Tezos_protocol_environment_alpha__Environment.Data_encoding.json)
      Tezos_protocol_environment_alpha__Environment.Error_monad.error_encoding).

Inductive successful_manager_operation_result : forall (_ : Type), Type :=
| Reveal_result : Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal
| Transaction_result :
  (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
  (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff) ->
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t -> bool ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction
| Origination_result :
  (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff) ->
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.origination
| Delegation_result : Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation.

Inductive packed_successful_manager_operation_result : Type :=
| Successful_manager_result : forall {kind : Type},
  (successful_manager_operation_result kind) ->
  packed_successful_manager_operation_result.

Inductive manager_operation_result (kind : Type) : Type :=
| Applied : (successful_manager_operation_result kind) ->
  manager_operation_result kind
| Backtracked : (successful_manager_operation_result kind) ->
  (option (list Tezos_protocol_environment_alpha__Environment.Error_monad.error))
  -> manager_operation_result kind
| Failed : (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
  (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) ->
  manager_operation_result kind
| Skipped : (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
  manager_operation_result kind.

Arguments Applied {_}.
Arguments Backtracked {_}.
Arguments Failed {_}.
Arguments Skipped {_}.

Inductive packed_internal_operation_result : Type :=
| Internal_operation_result : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.internal_operation kind) ->
  (manager_operation_result kind) -> packed_internal_operation_result.

Module Manager_result.
  Inductive case (kind : Type) : Type :=
  | MCase : forall {a : Type},
    (Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.case
      kind) -> (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a)
    -> (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
    (packed_internal_operation_result ->
      option
        ((Tezos_raw_protocol_alpha.Alpha_context.internal_operation kind) *
          (manager_operation_result kind))) ->
    (packed_successful_manager_operation_result ->
      option (successful_manager_operation_result kind)) ->
    ((successful_manager_operation_result kind) -> a) ->
    (a -> successful_manager_operation_result kind) ->
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.t
      (manager_operation_result kind)) -> case kind.
  
  Arguments MCase {_}.
  
  Definition make {A B : Type}
    (op_case :
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.case
        A)
    (encoding :
      Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding B)
    (kind : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)
    (iselect :
      packed_internal_operation_result ->
        option
          ((Tezos_raw_protocol_alpha.Alpha_context.internal_operation A) *
            (manager_operation_result A)))
    (select :
      packed_successful_manager_operation_result ->
        option (successful_manager_operation_result A))
    (proj : (successful_manager_operation_result A) -> B)
    (inj : B -> successful_manager_operation_result A) : case A :=
    match op_case with
    | Operation.Encoding.Manager_operations.MCase {| name := name |} =>
      let t :=
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          (let arg :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.def
              (Tezos_protocol_environment_alpha__Environment.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "operation.alpha.operation_result." % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "operation.alpha.operation_result.%s" % string) name) in
          fun eta => arg None None eta)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.union
            (Some variant)
            (cons
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
                "Applied" % string None (Tag 0)
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                      None None "status" % string
                      (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                        "applied" % string))) encoding)
                (fun o =>
                  match o with
                  | Skipped _ | Failed _ _ | Backtracked _ _ => None
                  | Applied o =>
                    match select (Successful_manager_result o) with
                    | None => None
                    | Some o => Some (tt, (proj o))
                    end
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (tt, x) => Applied (inj x)
                  end))
              (cons
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
                  "Failed" % string None (Tag 1)
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                      None None "status" % string
                      (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                        "failed" % string))
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                      None None "errors" % string
                      (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                        None error_encoding)))
                  (fun function_parameter =>
                    match function_parameter with
                    | Failed _ errs => Some (tt, errs)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | (tt, errs) => Failed kind errs
                    end))
                (cons
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
                    "Skipped" % string None (Tag 2)
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
                      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                        None None "status" % string
                        (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                          "skipped" % string)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Skipped _ => Some tt
                      | _ => None
                      end)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt => Skipped kind
                      end))
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
                      "Backtracked" % string None (Tag 3)
                      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
                        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
                          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                            None None "status" % string
                            (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                              "backtracked" % string))
                          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt
                            None None "errors" % string
                            (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                              None error_encoding))) encoding)
                      (fun o =>
                        match o with
                        | Skipped _ | Failed _ _ | Applied _ => None
                        | Backtracked o errs =>
                          match select (Successful_manager_result o) with
                          | None => None
                          | Some o => Some ((tt, errs), (proj o))
                          end
                        end)
                      (fun function_parameter =>
                        match function_parameter with
                        | ((tt, errs), x) => Backtracked (inj x) errs
                        end)) []))))) in
      MCase
        {| op_case := op_case; encoding := encoding; kind := kind;
          iselect := iselect; select := select; proj := proj; inj := inj; t := t
          |}
    end.
  
  Definition reveal_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal :=
    make
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.reveal_case
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "consumed_gas" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z
          Tezos_protocol_environment_alpha__Environment.Z.zero))
      Kind.Reveal_manager_kind
      (fun function_parameter =>
        match function_parameter with
        | Internal_operation_result ({| operation := Reveal _ |} as op) res =>
          Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Reveal_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Reveal_result {| consumed_gas := consumed_gas |} => consumed_gas
        end)
      (fun consumed_gas => Reveal_result {| consumed_gas := consumed_gas |}).
  
  Definition transaction_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction :=
    make
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.transaction_case
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj8
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "storage" % string
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "big_map_diff" % string
          Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "balance_updates" % string
          Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding
          [])
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "originated_contracts" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding) [])
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "consumed_gas" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z
          Tezos_protocol_environment_alpha__Environment.Z.zero)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "storage_size" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z
          Tezos_protocol_environment_alpha__Environment.Z.zero)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "paid_storage_size_diff" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z
          Tezos_protocol_environment_alpha__Environment.Z.zero)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "allocated_destination_contract" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.bool false))
      Kind.Transaction_manager_kind
      (fun function_parameter =>
        match function_parameter with
        | Internal_operation_result ({| operation := Transaction _ |} as op) res
          => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Transaction_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          Transaction_result {|
            storage := storage;
              big_map_diff := big_map_diff;
              balance_updates := balance_updates;
              originated_contracts := originated_contracts;
              consumed_gas := consumed_gas;
              storage_size := storage_size;
              paid_storage_size_diff := paid_storage_size_diff;
              allocated_destination_contract := allocated_destination_contract
              |} =>
          (storage, big_map_diff, balance_updates, originated_contracts,
            consumed_gas, storage_size, paid_storage_size_diff,
            allocated_destination_contract)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (storage, big_map_diff, balance_updates, originated_contracts,
            consumed_gas, storage_size, paid_storage_size_diff,
            allocated_destination_contract) =>
          Transaction_result
            {| storage := storage; big_map_diff := big_map_diff;
              balance_updates := balance_updates;
              originated_contracts := originated_contracts;
              consumed_gas := consumed_gas; storage_size := storage_size;
              paid_storage_size_diff := paid_storage_size_diff;
              allocated_destination_contract := allocated_destination_contract
              |}
        end).
  
  Definition origination_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.origination :=
    make
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.origination_case
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj6
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "big_map_diff" % string
          Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "balance_updates" % string
          Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding
          [])
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "originated_contracts" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding) [])
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "consumed_gas" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z
          Tezos_protocol_environment_alpha__Environment.Z.zero)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "storage_size" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z
          Tezos_protocol_environment_alpha__Environment.Z.zero)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "paid_storage_size_diff" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z
          Tezos_protocol_environment_alpha__Environment.Z.zero))
      Kind.Origination_manager_kind
      (fun function_parameter =>
        match function_parameter with
        | Internal_operation_result ({| operation := Origination _ |} as op) res
          => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Origination_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          Origination_result {|
            big_map_diff := big_map_diff;
              balance_updates := balance_updates;
              originated_contracts := originated_contracts;
              consumed_gas := consumed_gas;
              storage_size := storage_size;
              paid_storage_size_diff := paid_storage_size_diff
              |} =>
          (big_map_diff, balance_updates, originated_contracts, consumed_gas,
            storage_size, paid_storage_size_diff)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (big_map_diff, balance_updates, originated_contracts, consumed_gas,
            storage_size, paid_storage_size_diff) =>
          Origination_result
            {| big_map_diff := big_map_diff; balance_updates := balance_updates;
              originated_contracts := originated_contracts;
              consumed_gas := consumed_gas; storage_size := storage_size;
              paid_storage_size_diff := paid_storage_size_diff |}
        end).
  
  Definition delegation_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation :=
    make
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.delegation_case
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "consumed_gas" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z
          Tezos_protocol_environment_alpha__Environment.Z.zero))
      Kind.Delegation_manager_kind
      (fun function_parameter =>
        match function_parameter with
        | Internal_operation_result ({| operation := Delegation _ |} as op) res
          => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Delegation_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Delegation_result {| consumed_gas := consumed_gas |} => consumed_gas
        end)
      (fun consumed_gas => Delegation_result {| consumed_gas := consumed_gas |}).
End Manager_result.

Definition internal_operation_result_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    packed_internal_operation_result :=
  let make {A : Type} (function_parameter : Manager_result.case A)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
      packed_internal_operation_result :=
    match function_parameter with
    | Manager_result.MCase res_case =>
      match op_case res_case with
      | Operation.Encoding.Manager_operations.MCase op_case =>
        Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          (name op_case) None (Tag (tag op_case))
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "kind" % string
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                  (name op_case)))
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "source" % string
                Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "nonce" % string
                Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
              (encoding op_case)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "result" % string (t res_case)))))
          (fun op =>
            match (iselect res_case) op with
            | Some (op, res) =>
              Some
                ((tt, (source op), (nonce op)),
                  (((proj op_case) (operation op)), res))
            | None => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | ((tt, source, nonce), (op, res)) =>
              let op :=
                {| source := source; operation := (inj op_case) op;
                  nonce := nonce |} in
              Internal_operation_result op res
            end)
      end
    end in
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation.alpha.internal_operation_result" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
      (cons (make Manager_result.reveal_case)
        (cons (make Manager_result.transaction_case)
          (cons (make Manager_result.origination_case)
            (cons (make Manager_result.delegation_case) []))))).

Inductive contents_result : forall (kind : Type), Type :=
| Endorsement_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  (list Z) ->
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement
| Seed_nonce_revelation_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.seed_nonce_revelation
| Double_endorsement_evidence_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.double_endorsement_evidence
| Double_baking_evidence_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.double_baking_evidence
| Activate_account_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.activate_account
| Proposals_result :
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.proposals
| Ballot_result :
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.ballot
| Manager_operation_result : forall {kind : Type},
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (manager_operation_result kind) -> (list packed_internal_operation_result) ->
  contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind).

Inductive packed_contents_result : Type :=
| Contents_result : forall {kind : Type}, (contents_result kind) ->
  packed_contents_result.

Inductive packed_contents_and_result : Type :=
| Contents_and_result : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.Operation.contents kind) ->
  (contents_result kind) -> packed_contents_and_result.

Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.

Arguments Eq {_}.

Definition equal_manager_kind {a b : Type}
  (ka : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager a)
  (kb : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager b)
  : option (eq a b) :=
  match (ka, kb) with
  | (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) => Some Eq
  | (Kind.Reveal_manager_kind, _) => None
  | (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) => Some Eq
  | (Kind.Transaction_manager_kind, _) => None
  | (Kind.Origination_manager_kind, Kind.Origination_manager_kind) => Some Eq
  | (Kind.Origination_manager_kind, _) => None
  | (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) => Some Eq
  | (Kind.Delegation_manager_kind, _) => None
  end.

Module Encoding.
  Inductive case (kind : Type) : Type :=
  | Case : forall {a : Type},
    (Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.case kind) ->
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
    (packed_contents_result -> option (contents_result kind)) ->
    (packed_contents_and_result ->
      option
        ((Tezos_raw_protocol_alpha.Alpha_context.contents kind) *
          (contents_result kind))) -> ((contents_result kind) -> a) ->
    (a -> contents_result kind) -> case kind.
  
  Arguments Case {_}.
  
  Definition tagged_case {A B : Type}
    (tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
    (name : string)
    (args :
      Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding A)
    (proj : B -> option A) (inj : A -> B)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case B :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.case
      (Tezos_protocol_environment_alpha__Environment.String.capitalize_ascii
        name) None tag
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "kind" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
              name))) args)
      (fun x =>
        match proj x with
        | None => None
        | Some x => Some (tt, x)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (tt, x) => inj x
        end).
  
  Definition endorsement_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement :=
    Case
      {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.endorsement_case;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "balance_updates" % string
              Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "delegate" % string
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "slots" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                None
                Tezos_protocol_environment_alpha__Environment.Data_encoding.uint8));
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Endorsement_result _) as op) => Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Endorsement _) as op) res => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            |
              Endorsement_result {|
                balance_updates := balance_updates;
                  delegate := delegate;
                  slots := slots
                  |} => (balance_updates, delegate, slots)
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | (balance_updates, delegate, slots) =>
              Endorsement_result
                {| balance_updates := balance_updates; delegate := delegate;
                  slots := slots |}
            end |}.
  
  Definition seed_nonce_revelation_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.seed_nonce_revelation :=
    Case
      {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.seed_nonce_revelation_case;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "balance_updates" % string
              Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Seed_nonce_revelation_result _) as op) =>
              Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Seed_nonce_revelation _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Seed_nonce_revelation_result bus => bus
            end; inj := fun bus => Seed_nonce_revelation_result bus |}.
  
  Definition double_endorsement_evidence_case
    : case
      Tezos_raw_protocol_alpha.Alpha_context.Kind.double_endorsement_evidence :=
    Case
      {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.double_endorsement_evidence_case;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "balance_updates" % string
              Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Double_endorsement_evidence_result _) as op) =>
              Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Double_endorsement_evidence _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Double_endorsement_evidence_result bus => bus
            end; inj := fun bus => Double_endorsement_evidence_result bus |}.
  
  Definition double_baking_evidence_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.double_baking_evidence :=
    Case
      {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.double_baking_evidence_case;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "balance_updates" % string
              Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Double_baking_evidence_result _) as op) =>
              Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Double_baking_evidence _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Double_baking_evidence_result bus => bus
            end; inj := fun bus => Double_baking_evidence_result bus |}.
  
  Definition activate_account_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.activate_account :=
    Case
      {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.activate_account_case;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "balance_updates" % string
              Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Activate_account_result _) as op) => Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Activate_account _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Activate_account_result bus => bus
            end; inj := fun bus => Activate_account_result bus |}.
  
  Definition proposals_case
    : case Tezos_raw_protocol_alpha__Alpha_context.Kind.proposals :=
    Case
      {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.proposals_case;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.empty;
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result (Proposals_result as op) => Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Proposals _) as op) res => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Proposals_result => tt
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | tt => Proposals_result
            end |}.
  
  Definition ballot_case
    : case Tezos_raw_protocol_alpha__Alpha_context.Kind.ballot :=
    Case
      {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.ballot_case;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.empty;
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result (Ballot_result as op) => Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            | Contents_and_result ((Ballot _) as op) res => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Ballot_result => tt
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | tt => Ballot_result
            end |}.
  
  Definition make_manager_case {A : Type}
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.case
        (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
    : (Manager_result.case A) ->
      (packed_contents_and_result ->
        option
          ((Tezos_raw_protocol_alpha.Alpha_context.contents
            (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)) *
            (contents_result
              (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)))) ->
        case (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A) :=
    match function_parameter with
    | Operation.Encoding.Case op_case =>
      fun function_parameter =>
        match function_parameter with
        | Manager_result.MCase res_case =>
          fun mselect =>
            Case
              {| op_case := Operation.Encoding.Case op_case;
                encoding :=
                  Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                      None None "balance_updates" % string
                      Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding)
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                      None None "operation_result" % string (t res_case))
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft
                      None None "internal_operation_results" % string
                      (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                        None internal_operation_result_encoding) []);
                select :=
                  fun function_parameter =>
                    match function_parameter with
                    |
                      Contents_result
                        (Manager_operation_result
                          ({| operation_result := Applied res |} as op)) =>
                      match (select res_case) (Successful_manager_result res)
                        with
                      | Some res => Some (Manager_operation_result record)
                      | None => None
                      end
                    |
                      Contents_result
                        (Manager_operation_result
                          ({| operation_result := Backtracked res errs |} as op))
                      =>
                      match (select res_case) (Successful_manager_result res)
                        with
                      | Some res => Some (Manager_operation_result record)
                      | None => None
                      end
                    |
                      Contents_result
                        (Manager_operation_result
                          ({| operation_result := Skipped kind |} as op)) =>
                      match equal_manager_kind kind (kind res_case) with
                      | None => None
                      | Some Eq => Some (Manager_operation_result record)
                      end
                    |
                      Contents_result
                        (Manager_operation_result
                          ({| operation_result := Failed kind errs |} as op)) =>
                      match equal_manager_kind kind (kind res_case) with
                      | None => None
                      | Some Eq => Some (Manager_operation_result record)
                      end
                    | Contents_result Ballot_result => None
                    | Contents_result (Endorsement_result _) => None
                    | Contents_result (Seed_nonce_revelation_result _) => None
                    | Contents_result (Double_endorsement_evidence_result _) =>
                      None
                    | Contents_result (Double_baking_evidence_result _) => None
                    | Contents_result (Activate_account_result _) => None
                    | Contents_result Proposals_result => None
                    end; mselect := mselect;
                proj :=
                  fun function_parameter =>
                    match function_parameter with
                    |
                      Manager_operation_result {|
                        balance_updates := bus;
                          operation_result := r;
                          internal_operation_results := rs
                          |} => (bus, r, rs)
                    end;
                inj :=
                  fun function_parameter =>
                    match function_parameter with
                    | (bus, r, rs) =>
                      Manager_operation_result
                        {| balance_updates := bus; operation_result := r;
                          internal_operation_results := rs |}
                    end |}
        end
    end.
  
  Definition reveal_case
    : case
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
        Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal) :=
    make_manager_case
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.reveal_case
      Manager_result.reveal_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Manager_operation {| operation := Reveal _ |}) as op) res =>
          Some (op, res)
        | _ => None
        end).
  
  Definition transaction_case
    : case
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
        Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction) :=
    make_manager_case
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.transaction_case
      Manager_result.transaction_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Manager_operation {| operation := Transaction _ |}) as op) res =>
          Some (op, res)
        | _ => None
        end).
  
  Definition origination_case
    : case
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
        Tezos_raw_protocol_alpha.Alpha_context.Kind.origination) :=
    make_manager_case
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.origination_case
      Manager_result.origination_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Manager_operation {| operation := Origination _ |}) as op) res =>
          Some (op, res)
        | _ => None
        end).
  
  Definition delegation_case
    : case
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
        Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation) :=
    make_manager_case
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.delegation_case
      Manager_result.delegation_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Manager_operation {| operation := Delegation _ |}) as op) res =>
          Some (op, res)
        | _ => None
        end).
End Encoding.

Definition contents_result_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_result :=
  let make {A : Type} (function_parameter : Encoding.case A)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
      packed_contents_result :=
    match function_parameter with
    |
      Case {|
        op_case := Operation.Encoding.Case {| tag := tag; name := name |};
          encoding := encoding;
          select := select;
          mselect := _;
          proj := proj;
          inj := inj
          |} =>
      let proj (x : packed_contents_result) : option op_dollar_C_a_s_e___'_a :=
        match select x with
        | None => None
        | Some x => Some (proj x)
        end in
      let inj (x : op_dollar_C_a_s_e___'_a) : packed_contents_result :=
        Contents_result (inj x) in
      Encoding.tagged_case (Tag tag) name encoding proj inj
    end in
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation.alpha.contents_result" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
      (cons (make Encoding.endorsement_case)
        (cons (make Encoding.seed_nonce_revelation_case)
          (cons (make Encoding.double_endorsement_evidence_case)
            (cons (make Encoding.double_baking_evidence_case)
              (cons (make Encoding.activate_account_case)
                (cons (make Encoding.proposals_case)
                  (cons (make Encoding.ballot_case)
                    (cons (make Encoding.reveal_case)
                      (cons (make Encoding.transaction_case)
                        (cons (make Encoding.origination_case)
                          (cons (make Encoding.delegation_case) [])))))))))))).

Definition contents_and_result_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_and_result :=
  let make {A : Type} (function_parameter : Encoding.case A)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
      packed_contents_and_result :=
    match function_parameter with
    |
      Case {|
        op_case :=
          Operation.Encoding.Case {|
            tag := tag;
              name := name;
              encoding := encoding;
              proj := proj;
              inj := inj
              |};
          encoding := meta_encoding;
          mselect := mselect;
          proj := meta_proj;
          inj := meta_inj
          |} =>
      let proj (c : packed_contents_and_result)
        : option (op_dollar_C_a_s_e___'_a_1 * op_dollar_C_a_s_e___'_a) :=
        match mselect c with
        | Some (op, res) => Some ((proj op), (meta_proj res))
        | _ => None
        end in
      let inj
        (function_parameter :
        op_dollar_C_a_s_e___'_a_1 * op_dollar_C_a_s_e___'_a)
        : packed_contents_and_result :=
        match function_parameter with
        | (op, res) => Contents_and_result (inj op) (meta_inj res)
        end in
      let encoding :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
          encoding
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "metadata" % string meta_encoding)) in
      Encoding.tagged_case (Tag tag) name encoding proj inj
    end in
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation.alpha.operation_contents_and_result" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
      (cons (make Encoding.endorsement_case)
        (cons (make Encoding.seed_nonce_revelation_case)
          (cons (make Encoding.double_endorsement_evidence_case)
            (cons (make Encoding.double_baking_evidence_case)
              (cons (make Encoding.activate_account_case)
                (cons (make Encoding.proposals_case)
                  (cons (make Encoding.ballot_case)
                    (cons (make Encoding.reveal_case)
                      (cons (make Encoding.transaction_case)
                        (cons (make Encoding.origination_case)
                          (cons (make Encoding.delegation_case) [])))))))))))).

Inductive contents_result_list : forall (kind : Type), Type :=
| Single_result : forall {kind : Type}, (contents_result kind) ->
  contents_result_list kind
| Cons_result : forall {kind rest : Type},
  (contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  ->
  (contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager rest)) ->
  contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager (kind * rest)).

Inductive packed_contents_result_list : Type :=
| Contents_result_list : forall {kind : Type}, (contents_result_list kind) ->
  packed_contents_result_list.

Definition contents_result_list_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_result_list :=
  let fix to_list (function_parameter : packed_contents_result_list)
    : list packed_contents_result :=
    match function_parameter with
    | Contents_result_list (Single_result o) => cons (Contents_result o) []
    | Contents_result_list (Cons_result o os) =>
      cons (Contents_result o) (to_list (Contents_result_list os))
    end in
  let fix of_list (function_parameter : list packed_contents_result)
    : packed_contents_result_list :=
    match function_parameter with
    | [] =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
        "cannot decode empty operation result" % string
    | cons (Contents_result o) [] => Contents_result_list (Single_result o)
    | cons (Contents_result o) os =>
      match of_list os with
      | Contents_result_list os =>
        match (o, os) with
        |
          (Manager_operation_result _,
            Single_result (Manager_operation_result _)) =>
          Contents_result_list (Cons_result o os)
        | (Manager_operation_result _, Cons_result _ _) =>
          Contents_result_list (Cons_result o os)
        | _ =>
          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
            "cannot decode ill-formed operation result" % string
        end
      end
    end in
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation.alpha.contents_list_result" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv to_list
      of_list None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
        contents_result_encoding)).

Inductive contents_and_result_list : forall (kind : Type), Type :=
| Single_and_result : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.contents kind) ->
  (contents_result kind) -> contents_and_result_list kind
| Cons_and_result : forall {kind rest : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.contents
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind)) ->
  (contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  ->
  (contents_and_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager rest)) ->
  contents_and_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager (kind * rest)).

Inductive packed_contents_and_result_list : Type :=
| Contents_and_result_list : forall {kind : Type},
  (contents_and_result_list kind) -> packed_contents_and_result_list.

Definition contents_and_result_list_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_and_result_list :=
  let fix to_list (function_parameter : packed_contents_and_result_list)
    : list packed_contents_and_result :=
    match function_parameter with
    | Contents_and_result_list (Single_and_result op res) =>
      cons (Contents_and_result op res) []
    | Contents_and_result_list (Cons_and_result op res rest) =>
      cons (Contents_and_result op res)
        (to_list (Contents_and_result_list rest))
    end in
  let fix of_list (function_parameter : list packed_contents_and_result)
    : packed_contents_and_result_list :=
    match function_parameter with
    | [] =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
        "cannot decode empty combined operation result" % string
    | cons (Contents_and_result op res) [] =>
      Contents_and_result_list (Single_and_result op res)
    | cons (Contents_and_result op res) rest =>
      match of_list rest with
      | Contents_and_result_list rest =>
        match (op, rest) with
        | (Manager_operation _, Single_and_result (Manager_operation _) _) =>
          Contents_and_result_list (Cons_and_result op res rest)
        | (Manager_operation _, Cons_and_result _ _ _) =>
          Contents_and_result_list (Cons_and_result op res rest)
        | _ =>
          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
            "cannot decode ill-formed combined operation result" % string
        end
      end
    end in
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv to_list
    of_list None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.Variable.list
      None contents_and_result_encoding).

Record operation_metadata {kind : Type} := {
  contents : contents_result_list kind }.
Arguments operation_metadata : clear implicits.

Inductive packed_operation_metadata : Type :=
| Operation_metadata : forall {kind : Type}, (operation_metadata kind) ->
  packed_operation_metadata
| No_operation_metadata : packed_operation_metadata.

Definition operation_metadata_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_operation_metadata :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation.alpha.result" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Operation_metadata" % string None (Tag 0)
          contents_result_list_encoding
          (fun function_parameter =>
            match function_parameter with
            | Operation_metadata {| contents := contents |} =>
              Some (Contents_result_list contents)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | Contents_result_list contents =>
              Operation_metadata {| contents := contents |}
            end))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "No_operation_metadata" % string None (Tag 1)
            Tezos_protocol_environment_alpha__Environment.Data_encoding.empty
            (fun function_parameter =>
              match function_parameter with
              | No_operation_metadata => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => No_operation_metadata
              end)) []))).

Definition kind_equal {kind kind2 : Type}
  (op : Tezos_raw_protocol_alpha.Alpha_context.contents kind)
  (res : contents_result kind2) : option (eq kind kind2) :=
  match (op, res) with
  | (Endorsement _, Endorsement_result _) => Some Eq
  | (Endorsement _, _) => None
  | (Seed_nonce_revelation _, Seed_nonce_revelation_result _) => Some Eq
  | (Seed_nonce_revelation _, _) => None
  | (Double_endorsement_evidence _, Double_endorsement_evidence_result _) =>
    Some Eq
  | (Double_endorsement_evidence _, _) => None
  | (Double_baking_evidence _, Double_baking_evidence_result _) => Some Eq
  | (Double_baking_evidence _, _) => None
  | (Activate_account _, Activate_account_result _) => Some Eq
  | (Activate_account _, _) => None
  | (Proposals _, Proposals_result) => Some Eq
  | (Proposals _, _) => None
  | (Ballot _, Ballot_result) => Some Eq
  | (Ballot _, _) => None
  |
    (Manager_operation {| operation := Reveal _ |},
      Manager_operation_result {|
        operation_result := Applied (Reveal_result _) |}) => Some Eq
  |
    (Manager_operation {| operation := Reveal _ |},
      Manager_operation_result {|
        operation_result := Backtracked (Reveal_result _) _ |}) => Some Eq
  |
    (Manager_operation {| operation := Reveal _ |},
      Manager_operation_result {|
        operation_result := Failed Alpha_context.Kind.Reveal_manager_kind _
          |}) => Some Eq
  |
    (Manager_operation {| operation := Reveal _ |},
      Manager_operation_result {|
        operation_result := Skipped Alpha_context.Kind.Reveal_manager_kind
          |}) => Some Eq
  | (Manager_operation {| operation := Reveal _ |}, _) => None
  |
    (Manager_operation {| operation := Transaction _ |},
      Manager_operation_result {|
        operation_result := Applied (Transaction_result _) |}) => Some Eq
  |
    (Manager_operation {| operation := Transaction _ |},
      Manager_operation_result {|
        operation_result := Backtracked (Transaction_result _) _ |}) =>
    Some Eq
  |
    (Manager_operation {| operation := Transaction _ |},
      Manager_operation_result {|
        operation_result := Failed Alpha_context.Kind.Transaction_manager_kind _
          |}) => Some Eq
  |
    (Manager_operation {| operation := Transaction _ |},
      Manager_operation_result {|
        operation_result := Skipped Alpha_context.Kind.Transaction_manager_kind
          |}) => Some Eq
  | (Manager_operation {| operation := Transaction _ |}, _) => None
  |
    (Manager_operation {| operation := Origination _ |},
      Manager_operation_result {|
        operation_result := Applied (Origination_result _) |}) => Some Eq
  |
    (Manager_operation {| operation := Origination _ |},
      Manager_operation_result {|
        operation_result := Backtracked (Origination_result _) _ |}) =>
    Some Eq
  |
    (Manager_operation {| operation := Origination _ |},
      Manager_operation_result {|
        operation_result := Failed Alpha_context.Kind.Origination_manager_kind _
          |}) => Some Eq
  |
    (Manager_operation {| operation := Origination _ |},
      Manager_operation_result {|
        operation_result := Skipped Alpha_context.Kind.Origination_manager_kind
          |}) => Some Eq
  | (Manager_operation {| operation := Origination _ |}, _) => None
  |
    (Manager_operation {| operation := Delegation _ |},
      Manager_operation_result {|
        operation_result := Applied (Delegation_result _) |}) => Some Eq
  |
    (Manager_operation {| operation := Delegation _ |},
      Manager_operation_result {|
        operation_result := Backtracked (Delegation_result _) _ |}) =>
    Some Eq
  |
    (Manager_operation {| operation := Delegation _ |},
      Manager_operation_result {|
        operation_result := Failed Alpha_context.Kind.Delegation_manager_kind _
          |}) => Some Eq
  |
    (Manager_operation {| operation := Delegation _ |},
      Manager_operation_result {|
        operation_result := Skipped Alpha_context.Kind.Delegation_manager_kind
          |}) => Some Eq
  | (Manager_operation {| operation := Delegation _ |}, _) => None
  end.

Fixpoint kind_equal_list {kind kind2 : Type}
  (contents : Tezos_raw_protocol_alpha.Alpha_context.contents_list kind)
  (res : contents_result_list kind2) : option (eq kind kind2) :=
  match (contents, res) with
  | (Single op, Single_result res) =>
    match kind_equal op res with
    | None => None
    | Some Eq => Some Eq
    end
  | (Cons op ops, Cons_result res ress) =>
    match kind_equal op res with
    | None => None
    | Some Eq =>
      match kind_equal_list ops ress with
      | None => None
      | Some Eq => Some Eq
      end
    end
  | _ => None
  end.

Fixpoint pack_contents_list {kind : Type}
  (contents : Tezos_raw_protocol_alpha.Alpha_context.contents_list kind)
  (res : contents_result_list kind) : contents_and_result_list kind :=
  match (contents, res) with
  | (Single op, Single_result res) => Single_and_result op res
  | (Cons op ops, Cons_result res ress) =>
    Cons_and_result op res (pack_contents_list ops ress)
  |
    (Single (Manager_operation _),
      Cons_result (Manager_operation_result _) (Single_result _)) => unreachable
  |
    (Cons _ _,
      Single_result
        (Manager_operation_result {| operation_result := Failed _ _ |})) =>
    unreachable
  |
    (Cons _ _,
      Single_result
        (Manager_operation_result {| operation_result := Skipped _ |})) =>
    unreachable
  |
    (Cons _ _,
      Single_result
        (Manager_operation_result {| operation_result := Applied _ |})) =>
    unreachable
  |
    (Cons _ _,
      Single_result
        (Manager_operation_result {| operation_result := Backtracked _ _ |})) =>
    unreachable
  | (Single _, Cons_result _ _) => unreachable
  end.

Fixpoint unpack_contents_list {kind : Type}
  (function_parameter : contents_and_result_list kind)
  : (Tezos_raw_protocol_alpha.Alpha_context.contents_list kind) *
    (contents_result_list kind) :=
  match function_parameter with
  | Single_and_result op res => ((Single op), (Single_result res))
  | Cons_and_result op res rest =>
    match unpack_contents_list rest with
    | (ops, ress) => ((Cons op ops), (Cons_result res ress))
    end
  end.

Fixpoint to_list (function_parameter : packed_contents_result_list)
  : list packed_contents_result :=
  match function_parameter with
  | Contents_result_list (Single_result o) => cons (Contents_result o) []
  | Contents_result_list (Cons_result o os) =>
    cons (Contents_result o) (to_list (Contents_result_list os))
  end.

Fixpoint of_list (function_parameter : list packed_contents_result)
  : packed_contents_result_list :=
  match function_parameter with
  | [] => false
  | cons (Contents_result o) [] => Contents_result_list (Single_result o)
  | cons (Contents_result o) os =>
    match of_list os with
    | Contents_result_list os =>
      match (o, os) with
      | (Manager_operation_result _, Single_result (Manager_operation_result _))
        => Contents_result_list (Cons_result o os)
      | (Manager_operation_result _, Cons_result _ _) =>
        Contents_result_list (Cons_result o os)
      | _ =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
          "Operation result list of length > 1 should only contains manager operations result."
            % string
      end
    end
  end.

Definition operation_data_and_metadata_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_raw_protocol_alpha.Alpha_context.packed_protocol_data *
      packed_operation_metadata) :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation.alpha.operation_with_metadata" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Operation_with_metadata" % string None (Tag 0)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "contents" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                None contents_and_result_list_encoding))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt
              None None "signature" % string
              Tezos_protocol_environment_alpha__Environment.Signature.encoding))
          (fun function_parameter =>
            match function_parameter with
            | (Operation_data _, No_operation_metadata) => None
            | (Operation_data op, Operation_metadata res) =>
              match kind_equal_list (contents op) (contents res) with
              | None =>
                Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                  "cannot decode inconsistent combined operation result" %
                    string
              | Some Eq =>
                Some
                  ((Contents_and_result_list
                    (pack_contents_list (contents op) (contents res))),
                    (signature op))
              end
            end)
          (fun function_parameter =>
            match function_parameter with
            | (Contents_and_result_list contents, signature) =>
              match unpack_contents_list contents with
              | (op_contents, res_contents) =>
                ((Operation_data
                  {| contents := op_contents; signature := signature |}),
                  (Operation_metadata {| contents := res_contents |}))
              end
            end))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "Operation_without_metadata" % string None (Tag 1)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "contents" % string
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                  None
                  Tezos_raw_protocol_alpha.Alpha_context.Operation.contents_list_encoding))
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt
                None None "signature" % string
                Tezos_protocol_environment_alpha__Environment.Signature.encoding))
            (fun function_parameter =>
              match function_parameter with
              | (Operation_data op, No_operation_metadata) =>
                Some ((Contents_list (contents op)), (signature op))
              | (Operation_data _, Operation_metadata _) => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (Contents_list contents, signature) =>
                ((Operation_data
                  {| contents := contents; signature := signature |}),
                  No_operation_metadata)
              end)) []))).

Record block_metadata := {
  baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  level : Tezos_raw_protocol_alpha.Alpha_context.Level.t;
  voting_period_kind : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind;
  nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t;
  consumed_gas : Tezos_protocol_environment_alpha__Environment.Z.t;
  deactivated :
    list
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  balance_updates :
    Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates }.

Definition block_metadata_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    block_metadata :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "block_header.alpha.metadata" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          baker := baker;
            level := level;
            voting_period_kind := voting_period_kind;
            nonce_hash := nonce_hash;
            consumed_gas := consumed_gas;
            deactivated := deactivated;
            balance_updates := balance_updates
            |} =>
          (baker, level, voting_period_kind, nonce_hash, consumed_gas,
            deactivated, balance_updates)
        end)
      (fun function_parameter =>
        match function_parameter with
        |
          (baker, level, voting_period_kind, nonce_hash, consumed_gas,
            deactivated, balance_updates) =>
          {| baker := baker; level := level;
            voting_period_kind := voting_period_kind; nonce_hash := nonce_hash;
            consumed_gas := consumed_gas; deactivated := deactivated;
            balance_updates := balance_updates |}
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj7
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "baker" % string
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "level" % string
          Tezos_raw_protocol_alpha.Alpha_context.Level.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "voting_period_kind" % string
          Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "nonce_hash" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.option
            Tezos_raw_protocol_alpha.Nonce_hash.encoding))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "consumed_gas" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.check_size
            10 Tezos_protocol_environment_alpha__Environment.Data_encoding.n))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "deactivated" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "balance_updates" % string
          Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates_encoding))).
src/proto_alpha/lib_protocol/apply_results.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Result of applying an operation, can be used for experimenting
    with protocol updates, by clients to print out a summary of the
    operation at pre-injection simulation and at confirmation time,
    and by block explorers. *)

open Alpha_context

(** Result of applying a {!Operation.t}. Follows the same structure. *)
type 'kind operation_metadata = {contents : 'kind contents_result_list}

and packed_operation_metadata =
  | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
  | No_operation_metadata : packed_operation_metadata

(** Result of applying a {!Operation.contents_list}. Follows the same structure. *)
and 'kind contents_result_list =
  | Single_result : 'kind contents_result -> 'kind contents_result_list
  | Cons_result :
      'kind Kind.manager contents_result
      * 'rest Kind.manager contents_result_list
      -> ('kind * 'rest) Kind.manager contents_result_list

and packed_contents_result_list =
  | Contents_result_list :
      'kind contents_result_list
      -> packed_contents_result_list

(** Result of applying an {!Operation.contents}. Follows the same structure. *)
and 'kind contents_result =
  | Endorsement_result : {
      balance_updates : Delegate.balance_updates;
      delegate : Signature.Public_key_hash.t;
      slots : int list;
    }
      -> Kind.endorsement contents_result
  | Seed_nonce_revelation_result :
      Delegate.balance_updates
      -> Kind.seed_nonce_revelation contents_result
  | Double_endorsement_evidence_result :
      Delegate.balance_updates
      -> Kind.double_endorsement_evidence contents_result
  | Double_baking_evidence_result :
      Delegate.balance_updates
      -> Kind.double_baking_evidence contents_result
  | Activate_account_result :
      Delegate.balance_updates
      -> Kind.activate_account contents_result
  | Proposals_result : Kind.proposals contents_result
  | Ballot_result : Kind.ballot contents_result
  | Manager_operation_result : {
      balance_updates : Delegate.balance_updates;
      operation_result : 'kind manager_operation_result;
      internal_operation_results : packed_internal_operation_result list;
    }
      -> 'kind Kind.manager contents_result

and packed_contents_result =
  | Contents_result : 'kind contents_result -> packed_contents_result

(** The result of an operation in the queue. [Skipped] ones should
    always be at the tail, and after a single [Failed]. *)
and 'kind manager_operation_result =
  | Applied of 'kind successful_manager_operation_result
  | Backtracked of
      'kind successful_manager_operation_result * error list option
  | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
  | Skipped : 'kind Kind.manager -> 'kind manager_operation_result

(** Result of applying a {!manager_operation_content}, either internal
    or external. *)
and _ successful_manager_operation_result =
  | Reveal_result : {
      consumed_gas : Z.t;
    }
      -> Kind.reveal successful_manager_operation_result
  | Transaction_result : {
      storage : Script.expr option;
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
      allocated_destination_contract : bool;
    }
      -> Kind.transaction successful_manager_operation_result
  | Origination_result : {
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
    }
      -> Kind.origination successful_manager_operation_result
  | Delegation_result : {
      consumed_gas : Z.t;
    }
      -> Kind.delegation successful_manager_operation_result

and packed_successful_manager_operation_result =
  | Successful_manager_result :
      'kind successful_manager_operation_result
      -> packed_successful_manager_operation_result

and packed_internal_operation_result =
  | Internal_operation_result :
      'kind internal_operation * 'kind manager_operation_result
      -> packed_internal_operation_result

(** Serializer for {!packed_operation_result}. *)
val operation_metadata_encoding : packed_operation_metadata Data_encoding.t

val operation_data_and_metadata_encoding :
  (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t

type 'kind contents_and_result_list =
  | Single_and_result :
      'kind Alpha_context.contents * 'kind contents_result
      -> 'kind contents_and_result_list
  | Cons_and_result :
      'kind Kind.manager Alpha_context.contents
      * 'kind Kind.manager contents_result
      * 'rest Kind.manager contents_and_result_list
      -> ('kind * 'rest) Kind.manager contents_and_result_list

type packed_contents_and_result_list =
  | Contents_and_result_list :
      'kind contents_and_result_list
      -> packed_contents_and_result_list

val contents_and_result_list_encoding :
  packed_contents_and_result_list Data_encoding.t

val pack_contents_list :
  'kind contents_list ->
  'kind contents_result_list ->
  'kind contents_and_result_list

val unpack_contents_list :
  'kind contents_and_result_list ->
  'kind contents_list * 'kind contents_result_list

val to_list : packed_contents_result_list -> packed_contents_result list

val of_list : packed_contents_result list -> packed_contents_result_list

type ('a, 'b) eq = Eq : ('a, 'a) eq

val kind_equal_list :
  'kind contents_list ->
  'kind2 contents_result_list ->
  ('kind, 'kind2) eq option

type block_metadata = {
  baker : Signature.Public_key_hash.t;
  level : Level.t;
  voting_period_kind : Voting_period.kind;
  nonce_hash : Nonce_hash.t option;
  consumed_gas : Z.t;
  deactivated : Signature.Public_key_hash.t list;
  balance_updates : Delegate.balance_updates;
}

val block_metadata_encoding : block_metadata Data_encoding.encoding
src/proto_alpha/lib_protocol/apply_results.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive packed_operation_metadata : Type :=
| Operation_metadata : forall {kind : Type}, (operation_metadata kind) ->
  packed_operation_metadata
| No_operation_metadata : packed_operation_metadata

with contents_result_list : forall (kind : Type), Type :=
| Single_result : forall {kind : Type}, (contents_result kind) ->
  contents_result_list kind
| Cons_result : forall {kind rest : Type},
  (contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  ->
  (contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager rest)) ->
  contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager (kind * rest))

with packed_contents_result_list : Type :=
| Contents_result_list : forall {kind : Type}, (contents_result_list kind) ->
  packed_contents_result_list

with contents_result : forall (kind : Type), Type :=
| Endorsement_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  (list Z) ->
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement
| Seed_nonce_revelation_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.seed_nonce_revelation
| Double_endorsement_evidence_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.double_endorsement_evidence
| Double_baking_evidence_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.double_baking_evidence
| Activate_account_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.activate_account
| Proposals_result :
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.proposals
| Ballot_result :
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.ballot
| Manager_operation_result : forall {kind : Type},
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (manager_operation_result kind) -> (list packed_internal_operation_result) ->
  contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind)

with packed_contents_result : Type :=
| Contents_result : forall {kind : Type}, (contents_result kind) ->
  packed_contents_result

with manager_operation_result (kind : Type) : Type :=
| Applied : (successful_manager_operation_result kind) ->
  manager_operation_result kind
| Backtracked : (successful_manager_operation_result kind) ->
  (option (list Tezos_protocol_environment_alpha__Environment.Error_monad.error))
  -> manager_operation_result kind
| Failed : (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
  (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) ->
  manager_operation_result kind
| Skipped : (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
  manager_operation_result kind

with successful_manager_operation_result : forall (_ : Type), Type :=
| Reveal_result : Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal
| Transaction_result :
  (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
  (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff) ->
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t -> bool ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction
| Origination_result :
  (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff) ->
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.origination
| Delegation_result : Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation

with packed_successful_manager_operation_result : Type :=
| Successful_manager_result : forall {kind : Type},
  (successful_manager_operation_result kind) ->
  packed_successful_manager_operation_result

with packed_internal_operation_result : Type :=
| Internal_operation_result : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.internal_operation kind) ->
  (manager_operation_result kind) -> packed_internal_operation_result.

Arguments Applied {_}.
Arguments Backtracked {_}.
Arguments Failed {_}.
Arguments Skipped {_}.

Parameter operation_metadata_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  packed_operation_metadata.

Parameter operation_data_and_metadata_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data *
    packed_operation_metadata).

Inductive contents_and_result_list : forall (kind : Type), Type :=
| Single_and_result : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.contents kind) ->
  (contents_result kind) -> contents_and_result_list kind
| Cons_and_result : forall {kind rest : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.contents
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind)) ->
  (contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  ->
  (contents_and_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager rest)) ->
  contents_and_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager (kind * rest)).

Inductive packed_contents_and_result_list : Type :=
| Contents_and_result_list : forall {kind : Type},
  (contents_and_result_list kind) -> packed_contents_and_result_list.

Parameter contents_and_result_list_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  packed_contents_and_result_list.

Parameter pack_contents_list : forall {kind : Type},
(Tezos_raw_protocol_alpha.Alpha_context.contents_list kind) ->
  (contents_result_list kind) -> contents_and_result_list kind.

Parameter unpack_contents_list : forall {kind : Type},
(contents_and_result_list kind) ->
  (Tezos_raw_protocol_alpha.Alpha_context.contents_list kind) *
    (contents_result_list kind).

Parameter to_list : packed_contents_result_list -> list packed_contents_result.

Parameter of_list :
(list packed_contents_result) -> packed_contents_result_list.

Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.

Arguments Eq {_}.

Parameter kind_equal_list : forall {kind kind2 : Type},
(Tezos_raw_protocol_alpha.Alpha_context.contents_list kind) ->
  (contents_result_list kind2) -> option (eq kind kind2).

Record block_metadata := {
  baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  level : Tezos_raw_protocol_alpha.Alpha_context.Level.t;
  voting_period_kind : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind;
  nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t;
  consumed_gas : Tezos_protocol_environment_alpha__Environment.Z.t;
  deactivated :
    list
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  balance_updates :
    Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates }.

Parameter block_metadata_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
  block_metadata.
src/proto_alpha/lib_protocol/baking.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Misc

type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)

type error += Timestamp_too_early of Timestamp.t * Timestamp.t

(* `Permanent *)

type error += Unexpected_endorsement (* `Permanent *)

type error +=
  | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t

(* `Permanent *)

type error += Invalid_signature (* `Permanent *)

type error += Invalid_stamp (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"baking.timestamp_too_early"
    ~title:"Block forged too early"
    ~description:
      "The block timestamp is before the first slot for this baker at this \
       level"
    ~pp:(fun ppf (r, p) ->
      Format.fprintf
        ppf
        "Block forged too early (%a is before %a)"
        Time.pp_hum
        p
        Time.pp_hum
        r)
    Data_encoding.(
      obj2 (req "minimum" Time.encoding) (req "provided" Time.encoding))
    (function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None)
    (fun (r, p) -> Timestamp_too_early (r, p)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_fitness_gap"
    ~title:"Invalid fitness gap"
    ~description:"The gap of fitness is out of bounds"
    ~pp:(fun ppf (m, g) ->
      Format.fprintf ppf "The gap of fitness %Ld is not between 0 and %Ld" g m)
    Data_encoding.(obj2 (req "maximum" int64) (req "provided" int64))
    (function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None)
    (fun (m, g) -> Invalid_fitness_gap (m, g)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_block_signature"
    ~title:"Invalid block signature"
    ~description:"A block was not signed with the expected private key."
    ~pp:(fun ppf (block, pkh) ->
      Format.fprintf
        ppf
        "Invalid signature for block %a. Expected: %a."
        Block_hash.pp_short
        block
        Signature.Public_key_hash.pp_short
        pkh)
    Data_encoding.(
      obj2
        (req "block" Block_hash.encoding)
        (req "expected" Signature.Public_key_hash.encoding))
    (function
      | Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)
    (fun (block, pkh) -> Invalid_block_signature (block, pkh)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_signature"
    ~title:"Invalid block signature"
    ~description:"The block's signature is invalid"
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid block signature")
    Data_encoding.empty
    (function Invalid_signature -> Some () | _ -> None)
    (fun () -> Invalid_signature) ;
  register_error_kind
    `Permanent
    ~id:"baking.insufficient_proof_of_work"
    ~title:"Insufficient block proof-of-work stamp"
    ~description:"The block's proof-of-work stamp is insufficient"
    ~pp:(fun ppf () -> Format.fprintf ppf "Insufficient proof-of-work stamp")
    Data_encoding.empty
    (function Invalid_stamp -> Some () | _ -> None)
    (fun () -> Invalid_stamp) ;
  register_error_kind
    `Permanent
    ~id:"baking.unexpected_endorsement"
    ~title:"Endorsement from unexpected delegate"
    ~description:
      "The operation is signed by a delegate without endorsement rights."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "The endorsement is signed by a delegate without endorsement rights.")
    Data_encoding.unit
    (function Unexpected_endorsement -> Some () | _ -> None)
    (fun () -> Unexpected_endorsement)

let minimal_time c priority pred_timestamp =
  let priority = Int32.of_int priority in
  let rec cumsum_time_between_blocks acc durations p =
    if Compare.Int32.( <= ) p 0l then ok acc
    else
      match durations with
      | [] ->
          cumsum_time_between_blocks acc [Period.one_minute] p
      | [last] ->
          Period.mult p last >>? fun period -> Timestamp.(acc +? period)
      | first :: durations ->
          Timestamp.(acc +? first)
          >>? fun acc ->
          let p = Int32.pred p in
          cumsum_time_between_blocks acc durations p
  in
  Lwt.return
    (cumsum_time_between_blocks
       pred_timestamp
       (Constants.time_between_blocks c)
       (Int32.succ priority))

let earlier_predecessor_timestamp ctxt level =
  let current = Level.current ctxt in
  let current_timestamp = Timestamp.current ctxt in
  let gap = Level.diff level current in
  let step = List.hd (Constants.time_between_blocks ctxt) in
  if Compare.Int32.(gap < 1l) then
    failwith "Baking.earlier_block_timestamp: past block."
  else
    Lwt.return (Period.mult (Int32.pred gap) step)
    >>=? fun delay ->
    Lwt.return Timestamp.(current_timestamp +? delay)
    >>=? fun result -> return result

let check_timestamp c priority pred_timestamp =
  minimal_time c priority pred_timestamp
  >>=? fun minimal_time ->
  let timestamp = Alpha_context.Timestamp.current c in
  Lwt.return
    (record_trace
       (Timestamp_too_early (minimal_time, timestamp))
       Timestamp.(timestamp -? minimal_time))

let check_baking_rights c {Block_header.priority; _} pred_timestamp =
  let level = Level.current c in
  Roll.baking_rights_owner c level ~priority
  >>=? fun delegate ->
  check_timestamp c priority pred_timestamp
  >>=? fun block_delay -> return (delegate, block_delay)

type error += Incorrect_priority (* `Permanent *)

type error += Incorrect_number_of_endorsements (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"incorrect_priority"
    ~title:"Incorrect priority"
    ~description:"Block priority must be non-negative."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "The block priority must be non-negative.")
    Data_encoding.unit
    (function Incorrect_priority -> Some () | _ -> None)
    (fun () -> Incorrect_priority)

let () =
  let description =
    "The number of endorsements must be non-negative and at most the \
     endosers_per_block constant."
  in
  register_error_kind
    `Permanent
    ~id:"incorrect_number_of_endorsements"
    ~title:"Incorrect number of endorsements"
    ~description
    ~pp:(fun ppf () -> Format.fprintf ppf "%s" description)
    Data_encoding.unit
    (function Incorrect_number_of_endorsements -> Some () | _ -> None)
    (fun () -> Incorrect_number_of_endorsements)

let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo =
  fail_unless Compare.Int.(prio >= 0) Incorrect_priority
  >>=? fun () ->
  let max_endorsements = Constants.endorsers_per_block ctxt in
  fail_unless
    Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements)
    Incorrect_number_of_endorsements
  >>=? fun () ->
  let prio_factor_denominator = Int64.(succ (of_int prio)) in
  let endo_factor_numerator =
    Int64.of_int (8 + (2 * num_endo / max_endorsements))
  in
  let endo_factor_denominator = 10L in
  Lwt.return
    Tez.(
      Constants.block_reward ctxt *? endo_factor_numerator
      >>? fun val1 ->
      val1 /? endo_factor_denominator
      >>? fun val2 -> val2 /? prio_factor_denominator)

let endorsing_reward ctxt ~block_priority:prio n =
  if Compare.Int.(prio >= 0) then
    Lwt.return
      Tez.(Constants.endorsement_reward ctxt /? Int64.(succ (of_int prio)))
    >>=? fun tez -> Lwt.return Tez.(tez *? Int64.of_int n)
  else fail Incorrect_priority

let baking_priorities c level =
  let rec f priority =
    Roll.baking_rights_owner c level ~priority
    >>=? fun delegate -> return (LCons (delegate, fun () -> f (succ priority)))
  in
  f 0

let endorsement_rights c level =
  fold_left_s
    (fun acc slot ->
      Roll.endorsement_rights_owner c level ~slot
      >>=? fun pk ->
      let pkh = Signature.Public_key.hash pk in
      let right =
        match Signature.Public_key_hash.Map.find_opt pkh acc with
        | None ->
            (pk, [slot], false)
        | Some (pk, slots, used) ->
            (pk, slot :: slots, used)
      in
      return (Signature.Public_key_hash.Map.add pkh right acc))
    Signature.Public_key_hash.Map.empty
    (0 --> (Constants.endorsers_per_block c - 1))

let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t)
    =
  let current_level = Level.current ctxt in
  let (Single (Endorsement {level; _})) = op.protocol_data.contents in
  ( if Raw_level.(succ level = current_level.level) then
    return (Alpha_context.allowed_endorsements ctxt)
  else endorsement_rights ctxt (Level.from_raw ctxt level) )
  >>=? fun endorsements ->
  match
    Signature.Public_key_hash.Map.fold (* no find_first *)
      (fun pkh (pk, slots, used) acc ->
        match Operation.check_signature_sync pk chain_id op with
        | Error _ ->
            acc
        | Ok () ->
            Some (pkh, slots, used))
      endorsements
      None
  with
  | None ->
      fail Unexpected_endorsement
  | Some v ->
      return v

let select_delegate delegate delegate_list max_priority =
  let rec loop acc l n =
    if Compare.Int.(n >= max_priority) then return (List.rev acc)
    else
      let (LCons (pk, t)) = l in
      let acc =
        if
          Signature.Public_key_hash.equal
            delegate
            (Signature.Public_key.hash pk)
        then n :: acc
        else acc
      in
      t () >>=? fun t -> loop acc t (succ n)
  in
  loop [] delegate_list 0

let first_baking_priorities ctxt ?(max_priority = 32) delegate level =
  baking_priorities ctxt level
  >>=? fun delegate_list -> select_delegate delegate delegate_list max_priority

let check_hash hash stamp_threshold =
  let bytes = Block_hash.to_bytes hash in
  let word = MBytes.get_int64 bytes 0 in
  Compare.Uint64.(word <= stamp_threshold)

let check_header_proof_of_work_stamp shell contents stamp_threshold =
  let hash =
    Block_header.hash
      {shell; protocol_data = {contents; signature = Signature.zero}}
  in
  check_hash hash stamp_threshold

let check_proof_of_work_stamp ctxt block =
  let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in
  if
    check_header_proof_of_work_stamp
      block.Block_header.shell
      block.protocol_data.contents
      proof_of_work_threshold
  then return_unit
  else fail Invalid_stamp

let check_signature block chain_id key =
  let check_signature key
      {Block_header.shell; protocol_data = {contents; signature}} =
    let unsigned_header =
      Data_encoding.Binary.to_bytes_exn
        Block_header.unsigned_encoding
        (shell, contents)
    in
    Signature.check
      ~watermark:(Block_header chain_id)
      key
      signature
      unsigned_header
  in
  if check_signature key block then return_unit
  else
    fail
      (Invalid_block_signature
         (Block_header.hash block, Signature.Public_key.hash key))

let max_fitness_gap _ctxt = 1L

let check_fitness_gap ctxt (block : Block_header.t) =
  let current_fitness = Fitness.current ctxt in
  Lwt.return (Fitness.to_int64 block.shell.fitness)
  >>=? fun announced_fitness ->
  let gap = Int64.sub announced_fitness current_fitness in
  if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
    fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
  else return_unit

let last_of_a_cycle ctxt l =
  Compare.Int32.(
    Int32.succ l.Level.cycle_position = Constants.blocks_per_cycle ctxt)

let dawn_of_a_new_cycle ctxt =
  let level = Level.current ctxt in
  if last_of_a_cycle ctxt level then return_some level.cycle else return_none

let minimum_allowed_endorsements ctxt ~block_delay =
  let minimum = Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement =
    Int64.to_int
      (Period.to_seconds (Constants.delay_per_missing_endorsement ctxt))
  in
  let reduced_time_constraint =
    let delay = Int64.to_int (Period.to_seconds block_delay) in
    if Compare.Int.(delay_per_missing_endorsement = 0) then delay
    else delay / delay_per_missing_endorsement
  in
  Compare.Int.max 0 (minimum - reduced_time_constraint)

let minimal_valid_time ctxt ~priority ~endorsing_power =
  let predecessor_timestamp = Timestamp.current ctxt in
  minimal_time ctxt priority predecessor_timestamp
  >>=? fun minimal_time ->
  let minimal_required_endorsements = Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement =
    Constants.delay_per_missing_endorsement ctxt
  in
  let missing_endorsements =
    Compare.Int.max 0 (minimal_required_endorsements - endorsing_power)
  in
  match
    Period.mult
      (Int32.of_int missing_endorsements)
      delay_per_missing_endorsement
  with
  | Ok delay ->
      return (Time.add minimal_time (Period.to_seconds delay))
  | Error _ as err ->
      Lwt.return err
src/proto_alpha/lib_protocol/baking.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_raw_protocol_alpha.Misc.

Definition minimal_time
  (c : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
  (pred_timestamp : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) :=
  let priority :=
    Tezos_protocol_environment_alpha__Environment.Int32.of_int priority in
  let fix cumsum_time_between_blocks
    (acc : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) (durations :
    list Tezos_raw_protocol_alpha.Alpha_context.Period.period) (p :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
        p 0 then
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok acc
    else
      match durations with
      | [] =>
        cumsum_time_between_blocks acc
          (cons Tezos_raw_protocol_alpha.Alpha_context.Period.one_minute []) p
      | cons last [] =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Alpha_context.Period.mult p last)
          (fun period =>
            Tezos_raw_protocol_alpha.Alpha_context.Timestamp.op_plus_question
              acc period)
      | cons first durations =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.op_plus_question acc
            first)
          (fun acc =>
            let p := Tezos_protocol_environment_alpha__Environment.Int32.pred p
              in
            cumsum_time_between_blocks acc durations p)
      end in
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (cumsum_time_between_blocks pred_timestamp
      (Tezos_raw_protocol_alpha.Alpha_context.Constants.time_between_blocks c)
      (Tezos_protocol_environment_alpha__Environment.Int32.succ priority)).

Definition earlier_predecessor_timestamp
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (level : Tezos_raw_protocol_alpha.Alpha_context.Level.level)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) :=
  let current := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
  let current_timestamp :=
    Tezos_raw_protocol_alpha.Alpha_context.Timestamp.current ctxt in
  let gap := Tezos_raw_protocol_alpha.Alpha_context.Level.diff level current in
  let step :=
    Tezos_protocol_environment_alpha__Environment.List.hd
      (Tezos_raw_protocol_alpha.Alpha_context.Constants.time_between_blocks ctxt)
    in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      gap 1 then
    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
      "Baking.earlier_block_timestamp: past block." % string
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Period.mult
          (Tezos_protocol_environment_alpha__Environment.Int32.pred gap) step))
      (fun delay =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.op_plus_question
              current_timestamp delay))
          (fun result =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              result)).

Definition check_timestamp
  (c : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
  (pred_timestamp : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.Period.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (minimal_time c priority pred_timestamp)
    (fun minimal_time =>
      let timestamp :=
        Tezos_raw_protocol_alpha.Alpha_context.Timestamp.current c in
      Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
          (Timestamp_too_early minimal_time timestamp)
          (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.op_minus_question
            timestamp minimal_time))).

Definition check_baking_rights
  (c : Tezos_raw_protocol_alpha__Alpha_context.context)
  (function_parameter :
    Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha__Alpha_context.public_key *
          Tezos_raw_protocol_alpha__Alpha_context.Period.t)) :=
  match function_parameter with
  | {| Block_header.priority := priority |} =>
    fun pred_timestamp =>
      let level := Tezos_raw_protocol_alpha.Alpha_context.Level.current c in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Alpha_context.Roll.baking_rights_owner c level
          priority)
        (fun delegate =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (check_timestamp c priority pred_timestamp)
            (fun block_delay =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (delegate, block_delay)))
  end.

Definition baking_reward
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (prio :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (num_endo :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.tez) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
        prio 0) Incorrect_priority)
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        let max_endorsements :=
          Tezos_raw_protocol_alpha.Alpha_context.Constants.endorsers_per_block
            ctxt in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
              (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                num_endo 0)
              (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
                num_endo max_endorsements)) Incorrect_number_of_endorsements)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let prio_factor_denominator :=
                Tezos_protocol_environment_alpha__Environment.Int64.succ
                  (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                    prio) in
              let endo_factor_numerator :=
                Tezos_protocol_environment_alpha__Environment.Int64.of_int
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                    8
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
                        2 num_endo) max_endorsements)) in
              let endo_factor_denominator := 10 in
              Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_star_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Constants.block_reward
                      ctxt) endo_factor_numerator)
                  (fun val1 =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_div_question
                        val1 endo_factor_denominator)
                      (fun val2 =>
                        Tezos_raw_protocol_alpha.Alpha_context.Tez.op_div_question
                          val2 prio_factor_denominator)))
            end)
      end).

Definition endorsing_reward
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (prio :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (n : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.tez) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
      prio 0 then
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_div_question
          (Tezos_raw_protocol_alpha.Alpha_context.Constants.endorsement_reward
            ctxt)
          (Tezos_protocol_environment_alpha__Environment.Int64.succ
            (Tezos_protocol_environment_alpha__Environment.Int64.of_int prio))))
      (fun tez =>
        Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_star_question tez
            (Tezos_protocol_environment_alpha__Environment.Int64.of_int n)))
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
      Incorrect_priority.

Definition baking_priorities
  (c : Tezos_raw_protocol_alpha__Alpha_context.context)
  (level : Tezos_raw_protocol_alpha__Alpha_context.Level.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Misc.lazy_list_t
        Tezos_raw_protocol_alpha__Alpha_context.public_key)) :=
  let fix f (priority : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Misc.lazy_list_t
          Tezos_raw_protocol_alpha__Alpha_context.public_key)) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.Roll.baking_rights_owner c level
        priority)
      (fun delegate =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (LCons delegate
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                f
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.succ
                    priority)
              end))) in
  f 0.

Definition endorsement_rights
  (c : Tezos_raw_protocol_alpha__Alpha_context.context)
  (level : Tezos_raw_protocol_alpha__Alpha_context.Level.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
        (Tezos_raw_protocol_alpha__Alpha_context.public_key * (list Z) * bool))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
    (fun acc =>
      fun slot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Roll.endorsement_rights_owner
            c level slot)
          (fun pk =>
            let pkh :=
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                pk in
            let right :=
              match
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.find_opt
                  pkh acc with
              | None => (pk, (cons slot []), false)
              | Some (pk, slots, used) => (pk, (cons slot slots), used)
              end in
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.add
                pkh right acc)))
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.empty
    (Tezos_raw_protocol_alpha.Misc.op_minus_minus_gt 0
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
        (Tezos_raw_protocol_alpha.Alpha_context.Constants.endorsers_per_block c)
        1)).

Definition check_endorsement_rights
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (op :
    Tezos_raw_protocol_alpha.Alpha_context.Operation.t
      Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key
        * (list Z) * bool)) :=
  let current_level := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt
    in
  match contents (protocol_data op) with
  | Single (Endorsement {| level := level |}) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (if
        Tezos_raw_protocol_alpha.Alpha_context.Raw_level.op_eq
          (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.succ level)
          (level current_level) then
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (Tezos_raw_protocol_alpha.Alpha_context.allowed_endorsements ctxt)
      else
        endorsement_rights ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Level.from_raw ctxt None level))
      (fun endorsements =>
        match
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.fold
            (fun pkh =>
              fun function_parameter =>
                match function_parameter with
                | (pk, slots, used) =>
                  fun acc =>
                    match
                      Tezos_raw_protocol_alpha.Alpha_context.Operation.check_signature_sync
                        pk chain_id op with
                    | inr _ => acc
                    | inl tt => Some (pkh, slots, used)
                    end
                end) endorsements None with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            Unexpected_endorsement
        | Some v =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return v
        end)
  end.

Definition select_delegate
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (delegate_list :
    Tezos_raw_protocol_alpha.Misc.lazy_list_t
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (max_priority :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
  let fix loop
    (acc :
    list
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (l :
    Tezos_raw_protocol_alpha.Misc.lazy_list_t
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
        n max_priority then
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (Tezos_protocol_environment_alpha__Environment.List.rev acc)
    else
      match l with
      | LCons pk t =>
        let acc :=
          if
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
              delegate
              (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                pk) then
            cons n acc
          else
            acc in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (t tt)
          (fun t =>
            loop acc t
              (Tezos_protocol_environment_alpha__Environment.Pervasives.succ n))
      end in
  loop [] delegate_list 0.

Definition first_baking_priorities
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (op_star_o_p_t_star :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha__Alpha_context.Level.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
  let max_priority :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 32
    end in
  fun delegate =>
    fun level =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (baking_priorities ctxt level)
        (fun delegate_list =>
          select_delegate delegate delegate_list max_priority).

Definition check_hash
  (hash :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (stamp_threshold :
    Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : bool :=
  let bytes :=
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.to_bytes)
      hash in
  let word :=
    Tezos_protocol_environment_alpha__Environment.MBytes.get_int64 string 0 in
  Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
    word stamp_threshold.

Definition check_header_proof_of_work_stamp
  (shell :
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
  (contents : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  (stamp_threshold :
    Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : bool :=
  let hash :=
    Tezos_raw_protocol_alpha.Alpha_context.Block_header.hash
      {| shell := shell;
        protocol_data :=
          {| contents := contents;
            signature :=
              Tezos_protocol_environment_alpha__Environment.Signature.zero |} |}
    in
  check_hash hash stamp_threshold.

Definition check_proof_of_work_stamp
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let proof_of_work_threshold :=
    Tezos_raw_protocol_alpha.Alpha_context.Constants.proof_of_work_threshold
      ctxt in
  if
    check_header_proof_of_work_stamp (Block_header.shell block)
      (contents (protocol_data block)) proof_of_work_threshold then
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.fail Invalid_stamp.

Definition check_signature
  (block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let check_signature
    (key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
    (function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
    : bool :=
    match function_parameter with
    | {|
      Block_header.shell := shell;
        Block_header.protocol_data := {|
          contents := contents; signature := signature |}
        |} =>
      let unsigned_header :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
          Tezos_raw_protocol_alpha.Alpha_context.Block_header.unsigned_encoding
          (shell, contents) in
      Tezos_protocol_environment_alpha__Environment.Signature.check
        (Some (Block_header chain_id)) key signature unsigned_header
    end in
  if check_signature key block then
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
      (Invalid_block_signature
        (Tezos_raw_protocol_alpha.Alpha_context.Block_header.hash block)
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
          key)).

Definition max_fitness_gap {A : Type} (_ctxt : A) : int64 := 1.

Definition check_fitness_gap
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let current_fitness :=
    Tezos_raw_protocol_alpha.Alpha_context.Fitness.current ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Alpha_context.Fitness.to_int64
        (fitness (shell block))))
    (fun announced_fitness =>
      let gap :=
        Tezos_protocol_environment_alpha__Environment.Int64.sub
          announced_fitness current_fitness in
      if
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
          (Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
            gap 0)
          (Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
            (max_fitness_gap ctxt) gap) then
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_fitness_gap (max_fitness_gap ctxt) gap)
      else
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit).

Definition last_of_a_cycle
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (l : Tezos_raw_protocol_alpha.Alpha_context.Level.t) : bool :=
  Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
    (Tezos_protocol_environment_alpha__Environment.Int32.succ
      (Level.cycle_position l))
    (Tezos_raw_protocol_alpha.Alpha_context.Constants.blocks_per_cycle ctxt).

Definition dawn_of_a_new_cycle
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha__Alpha_context.Cycle.t)) :=
  let level := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
  if last_of_a_cycle ctxt level then
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
      (cycle level)
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_none.

Definition minimum_allowed_endorsements
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.period)
  : Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  let minimum :=
    Tezos_raw_protocol_alpha.Alpha_context.Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement :=
    Tezos_protocol_environment_alpha__Environment.Int64.to_int
      (Tezos_raw_protocol_alpha.Alpha_context.Period.to_seconds
        (Tezos_raw_protocol_alpha.Alpha_context.Constants.delay_per_missing_endorsement
          ctxt)) in
  let reduced_time_constraint :=
    let delay :=
      Tezos_protocol_environment_alpha__Environment.Int64.to_int
        (Tezos_raw_protocol_alpha.Alpha_context.Period.to_seconds block_delay)
      in
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        delay_per_missing_endorsement 0 then
      delay
    else
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_div delay
        delay_per_missing_endorsement in
  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
    0
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus minimum
      reduced_time_constraint).

Definition minimal_valid_time
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
  (endorsing_power : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Time.t) :=
  let predecessor_timestamp :=
    Tezos_raw_protocol_alpha.Alpha_context.Timestamp.current ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (minimal_time ctxt priority predecessor_timestamp)
    (fun minimal_time =>
      let minimal_required_endorsements :=
        Tezos_raw_protocol_alpha.Alpha_context.Constants.initial_endorsers ctxt
        in
      let delay_per_missing_endorsement :=
        Tezos_raw_protocol_alpha.Alpha_context.Constants.delay_per_missing_endorsement
          ctxt in
      let missing_endorsements :=
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
          0
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
            minimal_required_endorsements endorsing_power) in
      match
        Tezos_raw_protocol_alpha.Alpha_context.Period.mult
          (Tezos_protocol_environment_alpha__Environment.Int32.of_int
            missing_endorsements) delay_per_missing_endorsement with
      | inl delay =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (Tezos_protocol_environment_alpha__Environment.Time.add minimal_time
            (Tezos_raw_protocol_alpha.Alpha_context.Period.to_seconds delay))
      | (inr _) as err =>
        Tezos_protocol_environment_alpha__Environment.Lwt._return err
      end).
src/proto_alpha/lib_protocol/baking.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Misc

type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)

type error += Timestamp_too_early of Timestamp.t * Timestamp.t

(* `Permanent *)

type error +=
  | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t

(* `Permanent *)

type error += Unexpected_endorsement

type error += Invalid_signature (* `Permanent *)

type error += Invalid_stamp (* `Permanent *)

(** [minimal_time ctxt priority pred_block_time] returns the minimal
    time, given the predecessor block timestamp [pred_block_time],
    after which a baker with priority [priority] is allowed to
    bake. Fail with [Invalid_time_between_blocks_constant] if the minimal
    time cannot be computed. *)
val minimal_time : context -> int -> Time.t -> Time.t tzresult Lwt.t

(** [check_baking_rights ctxt block pred_timestamp] verifies that:
    * the contract that owned the roll at cycle start has the block signer as delegate.
    * the timestamp is coherent with the announced slot.
*)
val check_baking_rights :
  context ->
  Block_header.contents ->
  Time.t ->
  (public_key * Period.t) tzresult Lwt.t

(** For a given level computes who has the right to
    include an endorsement in the next block.
    The result can be stored in Alpha_context.allowed_endorsements *)
val endorsement_rights :
  context ->
  Level.t ->
  (public_key * int list * bool) Signature.Public_key_hash.Map.t tzresult Lwt.t

(** Check that the operation was signed by a delegate allowed
    to endorse at the level specified by the endorsement. *)
val check_endorsement_rights :
  context ->
  Chain_id.t ->
  Kind.endorsement Operation.t ->
  (public_key_hash * int list * bool) tzresult Lwt.t

(** Returns the baking reward calculated w.r.t a given priority [p] and a
    number [e] of included endorsements as follows:
      (block_reward / (p+1)) * (0.8 + 0.2 * e / endorsers_per_block)
*)
val baking_reward :
  context ->
  block_priority:int ->
  included_endorsements:int ->
  Tez.t tzresult Lwt.t

(** Returns the endorsing reward calculated w.r.t a given priority.  *)
val endorsing_reward :
  context -> block_priority:int -> int -> Tez.t tzresult Lwt.t

(** [baking_priorities ctxt level] is the lazy list of contract's
    public key hashes that are allowed to bake for [level]. *)
val baking_priorities : context -> Level.t -> public_key lazy_list

(** [first_baking_priorities ctxt ?max_priority contract_hash level]
    is a list of priorities of max [?max_priority] elements, where the
    delegate of [contract_hash] is allowed to bake for [level]. If
    [?max_priority] is [None], a sensible number of priorities is
    returned. *)
val first_baking_priorities :
  context ->
  ?max_priority:int ->
  public_key_hash ->
  Level.t ->
  int list tzresult Lwt.t

(** [check_signature ctxt chain_id block id] check if the block is
    signed with the given key, and belongs to the given [chain_id] *)
val check_signature :
  Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t

(** Checks if the header that would be built from the given components
    is valid for the given diffculty. The signature is not passed as it
    is does not impact the proof-of-work stamp. The stamp is checked on
    the hash of a block header whose signature has been zeroed-out. *)
val check_header_proof_of_work_stamp :
  Block_header.shell_header -> Block_header.contents -> int64 -> bool

(** verify if the proof of work stamp is valid *)
val check_proof_of_work_stamp :
  context -> Block_header.t -> unit tzresult Lwt.t

(** check if the gap between the fitness of the current context
    and the given block is within the protocol parameters *)
val check_fitness_gap : context -> Block_header.t -> unit tzresult Lwt.t

val dawn_of_a_new_cycle : context -> Cycle.t option tzresult Lwt.t

val earlier_predecessor_timestamp :
  context -> Level.t -> Timestamp.t tzresult Lwt.t

(** Since Emmy+

    A block is valid only if its timestamp has a minimal delay with
    respect to the previous block's timestamp, and this minimal delay
    depends not only on the block's priority but also on the number of
    endorsement operations included in the block.

    In Emmy+, blocks' fitness increases by one unit with each level.

    In this way, Emmy+ simplifies the optimal baking strategy: The
    bakers used to have to choose whether to wait for more endorsements
    to include in their block, or to publish the block immediately,
    without waiting. The incentive for including more endorsements was
    to increase the fitness and win against unknown blocks. However,
    when a block was produced too late in the priority period, there
    was the risk that the block did not reach endorsers before the
    block of next priority. In Emmy+, the baker does not need to take
    such a decision, because the baker cannot publish a block too
    early. *)

(** Given a delay of a block's timestamp with respect to the minimum
    time to bake at the block's priority (as returned by
    `minimum_time`), it returns the minimum number of endorsements that
    the block has to contain *)
val minimum_allowed_endorsements : context -> block_delay:Period.t -> int

(** This is the somehow the dual of the previous function. Given a
    block priority and a number of endorsement slots (given by the
    `endorsing_power` argument), it returns the minimum time at which
    the next block can be baked. *)
val minimal_valid_time :
  context -> priority:int -> endorsing_power:int -> Time.t tzresult Lwt.t
src/proto_alpha/lib_protocol/baking.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

Parameter minimal_time :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Z ->
    Tezos_protocol_environment_alpha__Environment.Time.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Time.t).

Parameter check_baking_rights :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents ->
    Tezos_protocol_environment_alpha__Environment.Time.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.public_key *
            Tezos_raw_protocol_alpha.Alpha_context.Period.t)).

Parameter endorsement_rights :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.Level.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
          (Tezos_raw_protocol_alpha.Alpha_context.public_key * (list Z) * bool))).

Parameter check_endorsement_rights :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    (Tezos_raw_protocol_alpha.Alpha_context.Operation.t
      Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * (list Z) *
            bool)).

Parameter baking_reward :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Z ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t).

Parameter endorsing_reward :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Z ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t).

Parameter baking_priorities :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.Level.t ->
    Tezos_raw_protocol_alpha.Misc.lazy_list
      Tezos_raw_protocol_alpha.Alpha_context.public_key.

Parameter first_baking_priorities :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  (option Z) ->
    Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
      Tezos_raw_protocol_alpha.Alpha_context.Level.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (list Z)).

Parameter check_signature :
Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
  Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    Tezos_raw_protocol_alpha.Alpha_context.public_key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).

Parameter check_header_proof_of_work_stamp :
Tezos_raw_protocol_alpha.Alpha_context.Block_header.shell_header ->
  Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents -> int64 -> bool.

Parameter check_proof_of_work_stamp :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).

Parameter check_fitness_gap :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).

Parameter dawn_of_a_new_cycle :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)).

Parameter earlier_predecessor_timestamp :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.Level.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t).

Parameter minimum_allowed_endorsements :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> Z.

Parameter minimal_valid_time :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Z ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Time.t).
src/proto_alpha/lib_protocol/blinded_public_key_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module H =
  Blake2B.Make
    (Base58)
    (struct
      let name = "Blinded public key hash"

      let title = "A blinded public key hash"

      let b58check_prefix = "\001\002\049\223"

      let size = Some Ed25519.Public_key_hash.size
    end)

include H

let () = Base58.check_encoded_prefix b58check_encoding "btz1" 37

let of_ed25519_pkh activation_code pkh =
  hash_bytes ~key:activation_code [Ed25519.Public_key_hash.to_bytes pkh]

type activation_code = MBytes.t

let activation_code_size = Ed25519.Public_key_hash.size

let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size

let activation_code_of_hex h =
  if Compare.Int.(String.length h <> activation_code_size * 2) then
    invalid_arg "Blinded_public_key_hash.activation_code_of_hex" ;
  MBytes.of_hex (`Hex h)

module Index = H
src/proto_alpha/lib_protocol/blinded_public_key_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition of_ed25519_pkh
  (activation_code : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  (pkh : Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t)
  : t :=
  hash_bytes (Some activation_code)
    (cons
      (Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.to_bytes
        pkh) []).

Definition activation_code :=
  Tezos_protocol_environment_alpha__Environment.MBytes.t.

Definition activation_code_size : Z :=
  Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.size.

Definition activation_code_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.Fixed.bytes
    activation_code_size.

Definition activation_code_of_hex (h : string)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_gt)
      (Tezos_protocol_environment_alpha__Environment.String.length h)
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
        activation_code_size 2) then
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "Blinded_public_key_hash.activation_code_of_hex" % string
  else
    tt;
  Tezos_protocol_environment_alpha__Environment.MBytes.of_hex variant.
src/proto_alpha/lib_protocol/blinded_public_key_hash.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include S.HASH

val encoding : t Data_encoding.t

val rpc_arg : t RPC_arg.t

type activation_code

val activation_code_encoding : activation_code Data_encoding.t

val of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t

val activation_code_of_hex : string -> activation_code

module Index : Storage_description.INDEX with type t = t
src/proto_alpha/lib_protocol/blinded_public_key_hash.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t t.

Parameter rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.t t.

Parameter activation_code : Type.

Parameter activation_code_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t activation_code.

Parameter of_ed25519_pkh :
activation_code ->
  Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t -> t.

Parameter activation_code_of_hex : string -> activation_code.

unhandled_module
src/proto_alpha/lib_protocol/block_header_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Block header *)

type t = {shell : Block_header.shell_header; protocol_data : protocol_data}

and protocol_data = {contents : contents; signature : Signature.t}

and contents = {
  priority : int;
  seed_nonce_hash : Nonce_hash.t option;
  proof_of_work_nonce : MBytes.t;
}

type block_header = t

type raw = Block_header.t

type shell_header = Block_header.shell_header

let raw_encoding = Block_header.encoding

let shell_header_encoding = Block_header.shell_header_encoding

let contents_encoding =
  let open Data_encoding in
  def "block_header.alpha.unsigned_contents"
  @@ conv
       (fun {priority; seed_nonce_hash; proof_of_work_nonce} ->
         (priority, proof_of_work_nonce, seed_nonce_hash))
       (fun (priority, proof_of_work_nonce, seed_nonce_hash) ->
         {priority; seed_nonce_hash; proof_of_work_nonce})
       (obj3
          (req "priority" uint16)
          (req
             "proof_of_work_nonce"
             (Fixed.bytes Constants_repr.proof_of_work_nonce_size))
          (opt "seed_nonce_hash" Nonce_hash.encoding))

let protocol_data_encoding =
  let open Data_encoding in
  def "block_header.alpha.signed_contents"
  @@ conv
       (fun {contents; signature} -> (contents, signature))
       (fun (contents, signature) -> {contents; signature})
       (merge_objs
          contents_encoding
          (obj1 (req "signature" Signature.encoding)))

let raw {shell; protocol_data} =
  let protocol_data =
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data
  in
  {Block_header.shell; protocol_data}

let unsigned_encoding =
  let open Data_encoding in
  merge_objs Block_header.shell_header_encoding contents_encoding

let encoding =
  let open Data_encoding in
  def "block_header.alpha.full_header"
  @@ conv
       (fun {shell; protocol_data} -> (shell, protocol_data))
       (fun (shell, protocol_data) -> {shell; protocol_data})
       (merge_objs Block_header.shell_header_encoding protocol_data_encoding)

(** Constants *)

let max_header_length =
  let fake_shell =
    {
      Block_header.level = 0l;
      proto_level = 0;
      predecessor = Block_hash.zero;
      timestamp = Time.of_seconds 0L;
      validation_passes = 0;
      operations_hash = Operation_list_list_hash.zero;
      fitness = Fitness_repr.from_int64 0L;
      context = Context_hash.zero;
    }
  and fake_contents =
    {
      priority = 0;
      proof_of_work_nonce =
        MBytes.create Constants_repr.proof_of_work_nonce_size;
      seed_nonce_hash = Some Nonce_hash.zero;
    }
  in
  Data_encoding.Binary.length
    encoding
    {
      shell = fake_shell;
      protocol_data = {contents = fake_contents; signature = Signature.zero};
    }

(** Header parsing entry point  *)

let hash_raw = Block_header.hash

let hash {shell; protocol_data} =
  Block_header.hash
    {
      shell;
      protocol_data =
        Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data;
    }
src/proto_alpha/lib_protocol/block_header_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

.

Definition block_header := t.

Definition raw := Tezos_protocol_environment_alpha__Environment.Block_header.t.

Definition shell_header :=
  Tezos_protocol_environment_alpha__Environment.Block_header.shell_header.

Definition raw_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_protocol_environment_alpha__Environment.Block_header.t :=
  Tezos_protocol_environment_alpha__Environment.Block_header.encoding.

Definition shell_header_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header :=
  Tezos_protocol_environment_alpha__Environment.Block_header.shell_header_encoding.

Definition contents_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    contents :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "block_header.alpha.unsigned_contents" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          priority := priority;
            seed_nonce_hash := seed_nonce_hash;
            proof_of_work_nonce := proof_of_work_nonce
            |} => (priority, proof_of_work_nonce, seed_nonce_hash)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (priority, proof_of_work_nonce, seed_nonce_hash) =>
          {| priority := priority; seed_nonce_hash := seed_nonce_hash;
            proof_of_work_nonce := proof_of_work_nonce |}
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "priority" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "proof_of_work_nonce" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Fixed.bytes
            Tezos_raw_protocol_alpha.Constants_repr.proof_of_work_nonce_size))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "seed_nonce_hash" % string
          Tezos_raw_protocol_alpha.Nonce_hash.encoding))).

Definition protocol_data_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    protocol_data :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "block_header.alpha.signed_contents" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| contents := contents; signature := signature |} =>
          (contents, signature)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (contents, signature) =>
          {| contents := contents; signature := signature |}
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        contents_encoding
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "signature" % string
            Tezos_protocol_environment_alpha__Environment.Signature.encoding)))).

Definition raw (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Block_header.t :=
  match function_parameter with
  | {| shell := shell; protocol_data := protocol_data |} =>
    let protocol_data :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
        protocol_data_encoding protocol_data in
    {| Block_header.shell := shell; Block_header.protocol_data := protocol_data
      |}
  end.

Definition unsigned_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_protocol_environment_alpha__Environment.Block_header.shell_header *
      contents) :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header_encoding
    contents_encoding.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "block_header.alpha.full_header" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| shell := shell; protocol_data := protocol_data |} =>
          (shell, protocol_data)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (shell, protocol_data) =>
          {| shell := shell; protocol_data := protocol_data |}
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        Tezos_protocol_environment_alpha__Environment.Block_header.shell_header_encoding
        protocol_data_encoding)).

Definition max_header_length : Z :=
  let fake_shell
    : Tezos_protocol_environment_alpha__Environment.Block_header.shell_header :=
    {| Block_header.level := 0; Block_header.proto_level := 0;
      Block_header.predecessor :=
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero);
      Block_header.timestamp :=
        Tezos_protocol_environment_alpha__Environment.Time.of_seconds 0;
      Block_header.validation_passes := 0;
      Block_header.operations_hash :=
        Tezos_protocol_environment_alpha__Environment.Operation_list_list_hash.(Tezos_protocol_environment_alpha__Environment.MERKLE_TREE.S.zero);
      Block_header.fitness := Tezos_raw_protocol_alpha.Fitness_repr.from_int64 0;
      Block_header.context :=
        Tezos_protocol_environment_alpha__Environment.Context_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
      |}
  with fake_contents : contents :=
    {| priority := 0;
      seed_nonce_hash := Some Tezos_raw_protocol_alpha.Nonce_hash.zero;
      proof_of_work_nonce :=
        Tezos_protocol_environment_alpha__Environment.MBytes.create
          Tezos_raw_protocol_alpha.Constants_repr.proof_of_work_nonce_size |} in
  Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.length
    encoding
    {| shell := fake_shell;
      protocol_data :=
        {| contents := fake_contents;
          signature :=
            Tezos_protocol_environment_alpha__Environment.Signature.zero |} |}.

Definition hash_raw
  : Tezos_protocol_environment_alpha__Environment.Block_header.t ->
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  Tezos_protocol_environment_alpha__Environment.Block_header.hash.

Definition hash (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  match function_parameter with
  | {| shell := shell; protocol_data := protocol_data |} =>
    Tezos_protocol_environment_alpha__Environment.Block_header.hash
      {| shell := shell;
        protocol_data :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
            protocol_data_encoding protocol_data |}
  end.
src/proto_alpha/lib_protocol/block_header_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {shell : Block_header.shell_header; protocol_data : protocol_data}

and protocol_data = {contents : contents; signature : Signature.t}

and contents = {
  priority : int;
  seed_nonce_hash : Nonce_hash.t option;
  proof_of_work_nonce : MBytes.t;
}

type block_header = t

type raw = Block_header.t

type shell_header = Block_header.shell_header

val raw : block_header -> raw

val encoding : block_header Data_encoding.encoding

val raw_encoding : raw Data_encoding.t

val contents_encoding : contents Data_encoding.t

val unsigned_encoding : (Block_header.shell_header * contents) Data_encoding.t

val protocol_data_encoding : protocol_data Data_encoding.encoding

val shell_header_encoding : shell_header Data_encoding.encoding

(** The maximum size of block headers in bytes *)
val max_header_length : int

val hash : block_header -> Block_hash.t

val hash_raw : raw -> Block_hash.t
src/proto_alpha/lib_protocol/block_header_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

.

Definition block_header := t.

Definition raw := Tezos_protocol_environment_alpha__Environment.Block_header.t.

Definition shell_header :=
  Tezos_protocol_environment_alpha__Environment.Block_header.shell_header.

Parameter raw : block_header -> raw.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
  block_header.

Parameter raw_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t raw.

Parameter contents_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t contents.

Parameter unsigned_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  (Tezos_protocol_environment_alpha__Environment.Block_header.shell_header *
    contents).

Parameter protocol_data_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
  protocol_data.

Parameter shell_header_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
  shell_header.

Parameter max_header_length : Z.

Parameter hash :
block_header ->
  Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).

Parameter hash_raw :
raw ->
  Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).
src/proto_alpha/lib_protocol/bootstrap_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

let init_account ctxt
    ({public_key_hash; public_key; amount} : Parameters_repr.bootstrap_account)
    =
  let contract = Contract_repr.implicit_contract public_key_hash in
  Contract_storage.credit ctxt contract amount
  >>=? fun ctxt ->
  match public_key with
  | Some public_key ->
      Contract_storage.reveal_manager_key ctxt public_key_hash public_key
      >>=? fun ctxt ->
      Delegate_storage.set ctxt contract (Some public_key_hash)
      >>=? fun ctxt -> return ctxt
  | None ->
      return ctxt

let init_contract ~typecheck ctxt
    ({delegate; amount; script} : Parameters_repr.bootstrap_contract) =
  Contract_storage.fresh_contract_from_current_nonce ctxt
  >>=? fun (ctxt, contract) ->
  typecheck ctxt script
  >>=? fun (script, ctxt) ->
  Contract_storage.originate
    ctxt
    contract
    ~balance:amount
    ~prepaid_bootstrap_storage:true
    ~script
    ~delegate:(Some delegate)
  >>=? fun ctxt -> return ctxt

let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts =
  let nonce =
    Operation_hash.hash_bytes [MBytes.of_string "Un festival de GADT."]
  in
  let ctxt = Raw_context.init_origination_nonce ctxt nonce in
  fold_left_s init_account ctxt accounts
  >>=? fun ctxt ->
  fold_left_s (init_contract ~typecheck) ctxt contracts
  >>=? fun ctxt ->
  ( match no_reward_cycles with
  | None ->
      return ctxt
  | Some cycles ->
      (* Store pending ramp ups. *)
      let constants = Raw_context.constants ctxt in
      (* Start without reward *)
      Raw_context.patch_constants ctxt (fun c ->
          {
            c with
            block_reward = Tez_repr.zero;
            endorsement_reward = Tez_repr.zero;
          })
      >>= fun ctxt ->
      (* Store the final reward. *)
      Storage.Ramp_up.Rewards.init
        ctxt
        (Cycle_repr.of_int32_exn (Int32.of_int cycles))
        (constants.block_reward, constants.endorsement_reward) )
  >>=? fun ctxt ->
  match ramp_up_cycles with
  | None ->
      return ctxt
  | Some cycles ->
      (* Store pending ramp ups. *)
      let constants = Raw_context.constants ctxt in
      Lwt.return
        Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles)
      >>=? fun block_step ->
      Lwt.return
        Tez_repr.(
          constants.endorsement_security_deposit /? Int64.of_int cycles)
      >>=? fun endorsement_step ->
      (* Start without security_deposit *)
      Raw_context.patch_constants ctxt (fun c ->
          {
            c with
            block_security_deposit = Tez_repr.zero;
            endorsement_security_deposit = Tez_repr.zero;
          })
      >>= fun ctxt ->
      fold_left_s
        (fun ctxt cycle ->
          Lwt.return Tez_repr.(block_step *? Int64.of_int cycle)
          >>=? fun block_security_deposit ->
          Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle)
          >>=? fun endorsement_security_deposit ->
          let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in
          Storage.Ramp_up.Security_deposits.init
            ctxt
            cycle
            (block_security_deposit, endorsement_security_deposit))
        ctxt
        (1 --> (cycles - 1))
      >>=? fun ctxt ->
      (* Store the final security deposits. *)
      Storage.Ramp_up.Security_deposits.init
        ctxt
        (Cycle_repr.of_int32_exn (Int32.of_int cycles))
        ( constants.block_security_deposit,
          constants.endorsement_security_deposit )
      >>=? fun ctxt -> return ctxt

let cycle_end ctxt last_cycle =
  let next_cycle = Cycle_repr.succ last_cycle in
  Storage.Ramp_up.Rewards.get_option ctxt next_cycle
  >>=? (function
         | None ->
             return ctxt
         | Some (block_reward, endorsement_reward) ->
             Storage.Ramp_up.Rewards.delete ctxt next_cycle
             >>=? fun ctxt ->
             Raw_context.patch_constants ctxt (fun c ->
                 {c with block_reward; endorsement_reward})
             >>= fun ctxt -> return ctxt)
  >>=? fun ctxt ->
  Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle
  >>=? function
  | None ->
      return ctxt
  | Some (block_security_deposit, endorsement_security_deposit) ->
      Storage.Ramp_up.Security_deposits.delete ctxt next_cycle
      >>=? fun ctxt ->
      Raw_context.patch_constants ctxt (fun c ->
          {c with block_security_deposit; endorsement_security_deposit})
      >>= fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/bootstrap_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Misc.

Definition init_account
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (function_parameter :
    Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_account)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match function_parameter with
  | {|
    public_key_hash := public_key_hash;
      public_key := public_key;
      amount := amount
      |} =>
    let contract :=
      Tezos_raw_protocol_alpha.Contract_repr.implicit_contract public_key_hash
      in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Contract_storage.credit ctxt contract amount)
      (fun ctxt =>
        match public_key with
        | Some public_key =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Contract_storage.reveal_manager_key ctxt
              public_key_hash public_key)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Delegate_storage.set ctxt contract
                  (Some public_key_hash))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt))
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt
        end)
  end.

Definition init_contract
  (typecheck :
    Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Script_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_repr.t *
              (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
              Tezos_raw_protocol_alpha.Raw_context.t)))
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (function_parameter :
    Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match function_parameter with
  | {| delegate := delegate; amount := amount; script := script |} =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Contract_storage.fresh_contract_from_current_nonce
        ctxt)
      (fun function_parameter =>
        match function_parameter with
        | (ctxt, contract) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (typecheck ctxt script)
            (fun function_parameter =>
              match function_parameter with
              | (script, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Contract_storage.originate ctxt
                    (Some true) contract amount script (Some delegate))
                  (fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      ctxt)
              end)
        end)
  end.

Definition init
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (typecheck :
    Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Script_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_repr.t *
              (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
              Tezos_raw_protocol_alpha.Raw_context.t)))
  (ramp_up_cycles : option Z) (no_reward_cycles : option Z)
  (accounts : list Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_account)
  (contracts : list Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let nonce :=
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.hash_bytes)
      None
      (cons
        (Tezos_protocol_environment_alpha__Environment.MBytes.of_string
          "Un festival de GADT." % string) []) in
  let ctxt :=
    Tezos_raw_protocol_alpha.Raw_context.init_origination_nonce ctxt nonce in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
      init_account ctxt accounts)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
          (init_contract typecheck) ctxt contracts)
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            match no_reward_cycles with
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ctxt
            | Some cycles =>
              let constants :=
                Tezos_raw_protocol_alpha.Raw_context.constants ctxt in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Raw_context.patch_constants ctxt
                  (fun c => record))
                (fun ctxt =>
                  Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.init ctxt
                    (Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn
                      (Tezos_protocol_environment_alpha__Environment.Int32.of_int
                        cycles))
                    ((block_reward constants), (endorsement_reward constants)))
            end
            (fun ctxt =>
              match ramp_up_cycles with
              | None =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ctxt
              | Some cycles =>
                let constants :=
                  Tezos_raw_protocol_alpha.Raw_context.constants ctxt in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_raw_protocol_alpha.Tez_repr.op_div_question
                      (block_security_deposit constants)
                      (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                        cycles)))
                  (fun block_step =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Tez_repr.op_div_question
                          (endorsement_security_deposit constants)
                          (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                            cycles)))
                      (fun endorsement_step =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                          (Tezos_raw_protocol_alpha.Raw_context.patch_constants
                            ctxt (fun c => record))
                          (fun ctxt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                (fun ctxt =>
                                  fun cycle =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (Tezos_raw_protocol_alpha.Tez_repr.op_star_question
                                          block_step
                                          (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                            cycle)))
                                      (fun block_security_deposit =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                            (Tezos_raw_protocol_alpha.Tez_repr.op_star_question
                                              endorsement_step
                                              (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                                cycle)))
                                          (fun endorsement_security_deposit =>
                                            let cycle :=
                                              Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn
                                                (Tezos_protocol_environment_alpha__Environment.Int32.of_int
                                                  cycle) in
                                            Tezos_raw_protocol_alpha.Storage.Ramp_up.Security_deposits.init
                                              ctxt cycle
                                              (block_security_deposit,
                                                endorsement_security_deposit))))
                                ctxt
                                (Tezos_raw_protocol_alpha.Misc.op_minus_minus_gt
                                  1
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                    cycles 1)))
                              (fun ctxt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_raw_protocol_alpha.Storage.Ramp_up.Security_deposits.init
                                    ctxt
                                    (Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn
                                      (Tezos_protocol_environment_alpha__Environment.Int32.of_int
                                        cycles))
                                    ((block_security_deposit constants),
                                      (endorsement_security_deposit constants)))
                                  (fun ctxt =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                      ctxt)))))
              end))).

Definition cycle_end
  (ctxt : Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.context)
  (last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.context) :=
  let next_cycle := Tezos_raw_protocol_alpha.Cycle_repr.succ last_cycle in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.get_option ctxt
        next_cycle)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt
        | Some (block_reward, endorsement_reward) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.delete ctxt
              next_cycle)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Raw_context.patch_constants ctxt
                  (fun c => record))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt))
        end))
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Ramp_up.Security_deposits.get_option
          ctxt next_cycle)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ctxt
          | Some (block_security_deposit, endorsement_security_deposit) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Storage.Ramp_up.Security_deposits.delete
                ctxt next_cycle)
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_raw_protocol_alpha.Raw_context.patch_constants ctxt
                    (fun c => record))
                  (fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      ctxt))
          end)).
src/proto_alpha/lib_protocol/bootstrap_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val init :
  Raw_context.t ->
  typecheck:(Raw_context.t ->
            Script_repr.t ->
            ( (Script_repr.t * Contract_storage.big_map_diff option)
            * Raw_context.t )
            tzresult
            Lwt.t) ->
  ?ramp_up_cycles:int ->
  ?no_reward_cycles:int ->
  Parameters_repr.bootstrap_account list ->
  Parameters_repr.bootstrap_contract list ->
  Raw_context.t tzresult Lwt.t

val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
src/proto_alpha/lib_protocol/bootstrap_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter init :
Tezos_raw_protocol_alpha.Raw_context.t ->
  (Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_raw_protocol_alpha.Script_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((Tezos_raw_protocol_alpha.Script_repr.t *
            (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
            Tezos_raw_protocol_alpha.Raw_context.t))) ->
    (option Z) ->
      (option Z) ->
        (list Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_account) ->
          (list Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_contract) ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                Tezos_raw_protocol_alpha.Raw_context.t).

Parameter cycle_end :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).
src/proto_alpha/lib_protocol/commitment_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  blinded_public_key_hash : Blinded_public_key_hash.t;
  amount : Tez_repr.t;
}

let encoding =
  let open Data_encoding in
  conv
    (fun {blinded_public_key_hash; amount} ->
      (blinded_public_key_hash, amount))
    (fun (blinded_public_key_hash, amount) ->
      {blinded_public_key_hash; amount})
    (tup2 Blinded_public_key_hash.encoding Tez_repr.encoding)
src/proto_alpha/lib_protocol/commitment_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  blinded_public_key_hash : Tezos_raw_protocol_alpha.Blinded_public_key_hash.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t }.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        blinded_public_key_hash := blinded_public_key_hash;
          amount := amount
          |} => (blinded_public_key_hash, amount)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (blinded_public_key_hash, amount) =>
        {| blinded_public_key_hash := blinded_public_key_hash; amount := amount
          |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
      Tezos_raw_protocol_alpha.Blinded_public_key_hash.encoding
      Tezos_raw_protocol_alpha.Tez_repr.encoding).
src/proto_alpha/lib_protocol/commitment_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  blinded_public_key_hash : Blinded_public_key_hash.t;
  amount : Tez_repr.t;
}

val encoding : t Data_encoding.t
src/proto_alpha/lib_protocol/commitment_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  blinded_public_key_hash : Tezos_raw_protocol_alpha.Blinded_public_key_hash.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t }.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t t.
src/proto_alpha/lib_protocol/commitment_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let get_opt = Storage.Commitments.get_option

let delete = Storage.Commitments.delete

let init ctxt commitments =
  let init_commitment ctxt Commitment_repr.{blinded_public_key_hash; amount} =
    Storage.Commitments.init ctxt blinded_public_key_hash amount
  in
  fold_left_s init_commitment ctxt commitments >>=? fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/commitment_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition get_opt
  : Tezos_raw_protocol_alpha.Storage.Commitments.context ->
    Tezos_raw_protocol_alpha.Storage.Commitments.key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option Tezos_raw_protocol_alpha.Storage.Commitments.value)) :=
  Tezos_raw_protocol_alpha.Storage.Commitments.get_option.

Definition delete
  : Tezos_raw_protocol_alpha.Storage.Commitments.context ->
    Tezos_raw_protocol_alpha.Storage.Commitments.key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Commitments.delete.

Definition init
  (ctxt : Tezos_raw_protocol_alpha.Storage.Commitments.context)
  (commitments : list Tezos_raw_protocol_alpha.Commitment_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Commitments.context) :=
  let init_commitment
    (ctxt : Tezos_raw_protocol_alpha.Storage.Commitments.context)
    (function_parameter : Tezos_raw_protocol_alpha.Commitment_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    match function_parameter with
    | {| blinded_public_key_hash := blinded_public_key_hash; amount := amount |}
      =>
      Tezos_raw_protocol_alpha.Storage.Commitments.init ctxt
        blinded_public_key_hash amount
    end in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
      init_commitment ctxt commitments)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt).
src/proto_alpha/lib_protocol/commitment_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val init :
  Raw_context.t -> Commitment_repr.t list -> Raw_context.t tzresult Lwt.t

val get_opt :
  Raw_context.t ->
  Blinded_public_key_hash.t ->
  Tez_repr.t option tzresult Lwt.t

val delete :
  Raw_context.t -> Blinded_public_key_hash.t -> Raw_context.t tzresult Lwt.t
src/proto_alpha/lib_protocol/commitment_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter init :
Tezos_raw_protocol_alpha.Raw_context.t ->
  (list Tezos_raw_protocol_alpha.Commitment_repr.t) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter get_opt :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Blinded_public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option Tezos_raw_protocol_alpha.Tez_repr.t)).

Parameter delete :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Blinded_public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).
src/proto_alpha/lib_protocol/constants_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let version_number_004 = "\000"

let version_number = "\001"

let proof_of_work_nonce_size = 8

let nonce_length = 32

let max_revelations_per_block = 32

let max_proposals_per_delegate = 20

let max_operation_data_length = 16 * 1024 (* 16kB *)

type fixed = {
  proof_of_work_nonce_size : int;
  nonce_length : int;
  max_revelations_per_block : int;
  max_operation_data_length : int;
  max_proposals_per_delegate : int;
}

let fixed_encoding =
  let open Data_encoding in
  conv
    (fun c ->
      ( c.proof_of_work_nonce_size,
        c.nonce_length,
        c.max_revelations_per_block,
        c.max_operation_data_length,
        c.max_proposals_per_delegate ))
    (fun ( proof_of_work_nonce_size,
           nonce_length,
           max_revelations_per_block,
           max_operation_data_length,
           max_proposals_per_delegate ) ->
      {
        proof_of_work_nonce_size;
        nonce_length;
        max_revelations_per_block;
        max_operation_data_length;
        max_proposals_per_delegate;
      })
    (obj5
       (req "proof_of_work_nonce_size" uint8)
       (req "nonce_length" uint8)
       (req "max_revelations_per_block" uint8)
       (req "max_operation_data_length" int31)
       (req "max_proposals_per_delegate" uint8))

let fixed =
  {
    proof_of_work_nonce_size;
    nonce_length;
    max_revelations_per_block;
    max_operation_data_length;
    max_proposals_per_delegate;
  }

type parametric = {
  preserved_cycles : int;
  blocks_per_cycle : int32;
  blocks_per_commitment : int32;
  blocks_per_roll_snapshot : int32;
  blocks_per_voting_period : int32;
  time_between_blocks : Period_repr.t list;
  endorsers_per_block : int;
  hard_gas_limit_per_operation : Z.t;
  hard_gas_limit_per_block : Z.t;
  proof_of_work_threshold : int64;
  tokens_per_roll : Tez_repr.t;
  michelson_maximum_type_size : int;
  seed_nonce_revelation_tip : Tez_repr.t;
  origination_size : int;
  block_security_deposit : Tez_repr.t;
  endorsement_security_deposit : Tez_repr.t;
  block_reward : Tez_repr.t;
  endorsement_reward : Tez_repr.t;
  cost_per_byte : Tez_repr.t;
  hard_storage_limit_per_operation : Z.t;
  test_chain_duration : int64;
  (* in seconds *)
  quorum_min : int32;
  quorum_max : int32;
  min_proposal_quorum : int32;
  initial_endorsers : int;
  delay_per_missing_endorsement : Period_repr.t;
}

let parametric_encoding =
  let open Data_encoding in
  conv
    (fun c ->
      ( ( c.preserved_cycles,
          c.blocks_per_cycle,
          c.blocks_per_commitment,
          c.blocks_per_roll_snapshot,
          c.blocks_per_voting_period,
          c.time_between_blocks,
          c.endorsers_per_block,
          c.hard_gas_limit_per_operation,
          c.hard_gas_limit_per_block ),
        ( ( c.proof_of_work_threshold,
            c.tokens_per_roll,
            c.michelson_maximum_type_size,
            c.seed_nonce_revelation_tip,
            c.origination_size,
            c.block_security_deposit,
            c.endorsement_security_deposit,
            c.block_reward ),
          ( c.endorsement_reward,
            c.cost_per_byte,
            c.hard_storage_limit_per_operation,
            c.test_chain_duration,
            c.quorum_min,
            c.quorum_max,
            c.min_proposal_quorum,
            c.initial_endorsers,
            c.delay_per_missing_endorsement ) ) ))
    (fun ( ( preserved_cycles,
             blocks_per_cycle,
             blocks_per_commitment,
             blocks_per_roll_snapshot,
             blocks_per_voting_period,
             time_between_blocks,
             endorsers_per_block,
             hard_gas_limit_per_operation,
             hard_gas_limit_per_block ),
           ( ( proof_of_work_threshold,
               tokens_per_roll,
               michelson_maximum_type_size,
               seed_nonce_revelation_tip,
               origination_size,
               block_security_deposit,
               endorsement_security_deposit,
               block_reward ),
             ( endorsement_reward,
               cost_per_byte,
               hard_storage_limit_per_operation,
               test_chain_duration,
               quorum_min,
               quorum_max,
               min_proposal_quorum,
               initial_endorsers,
               delay_per_missing_endorsement ) ) ) ->
      {
        preserved_cycles;
        blocks_per_cycle;
        blocks_per_commitment;
        blocks_per_roll_snapshot;
        blocks_per_voting_period;
        time_between_blocks;
        endorsers_per_block;
        hard_gas_limit_per_operation;
        hard_gas_limit_per_block;
        proof_of_work_threshold;
        tokens_per_roll;
        michelson_maximum_type_size;
        seed_nonce_revelation_tip;
        origination_size;
        block_security_deposit;
        endorsement_security_deposit;
        block_reward;
        endorsement_reward;
        cost_per_byte;
        hard_storage_limit_per_operation;
        test_chain_duration;
        quorum_min;
        quorum_max;
        min_proposal_quorum;
        initial_endorsers;
        delay_per_missing_endorsement;
      })
    (merge_objs
       (obj9
          (req "preserved_cycles" uint8)
          (req "blocks_per_cycle" int32)
          (req "blocks_per_commitment" int32)
          (req "blocks_per_roll_snapshot" int32)
          (req "blocks_per_voting_period" int32)
          (req "time_between_blocks" (list Period_repr.encoding))
          (req "endorsers_per_block" uint16)
          (req "hard_gas_limit_per_operation" z)
          (req "hard_gas_limit_per_block" z))
       (merge_objs
          (obj8
             (req "proof_of_work_threshold" int64)
             (req "tokens_per_roll" Tez_repr.encoding)
             (req "michelson_maximum_type_size" uint16)
             (req "seed_nonce_revelation_tip" Tez_repr.encoding)
             (req "origination_size" int31)
             (req "block_security_deposit" Tez_repr.encoding)
             (req "endorsement_security_deposit" Tez_repr.encoding)
             (req "block_reward" Tez_repr.encoding))
          (obj9
             (req "endorsement_reward" Tez_repr.encoding)
             (req "cost_per_byte" Tez_repr.encoding)
             (req "hard_storage_limit_per_operation" z)
             (req "test_chain_duration" int64)
             (req "quorum_min" int32)
             (req "quorum_max" int32)
             (req "min_proposal_quorum" int32)
             (req "initial_endorsers" uint16)
             (req "delay_per_missing_endorsement" Period_repr.encoding))))

type t = {fixed : fixed; parametric : parametric}

let encoding =
  let open Data_encoding in
  conv
    (fun {fixed; parametric} -> (fixed, parametric))
    (fun (fixed, parametric) -> {fixed; parametric})
    (merge_objs fixed_encoding parametric_encoding)
src/proto_alpha/lib_protocol/constants_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition version_number_004 : string := "" % string.

Definition version_number : string := "" % string.

Definition proof_of_work_nonce_size : Z := 8.

Definition nonce_length : Z := 32.

Definition max_revelations_per_block : Z := 32.

Definition max_proposals_per_delegate : Z := 20.

Definition max_operation_data_length : Z :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_star 16 1024.

Record fixed := {
  proof_of_work_nonce_size : Z;
  nonce_length : Z;
  max_revelations_per_block : Z;
  max_operation_data_length : Z;
  max_proposals_per_delegate : Z }.

Definition fixed_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding fixed :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun c =>
      ((proof_of_work_nonce_size c), (nonce_length c),
        (max_revelations_per_block c), (max_operation_data_length c),
        (max_proposals_per_delegate c)))
    (fun function_parameter =>
      match function_parameter with
      |
        (proof_of_work_nonce_size, nonce_length, max_revelations_per_block,
          max_operation_data_length, max_proposals_per_delegate) =>
        {| proof_of_work_nonce_size := proof_of_work_nonce_size;
          nonce_length := nonce_length;
          max_revelations_per_block := max_revelations_per_block;
          max_operation_data_length := max_operation_data_length;
          max_proposals_per_delegate := max_proposals_per_delegate |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj5
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "proof_of_work_nonce_size" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.uint8)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "nonce_length" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.uint8)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "max_revelations_per_block" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.uint8)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "max_operation_data_length" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int31)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "max_proposals_per_delegate" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.uint8)).

Definition fixed : fixed :=
  {| proof_of_work_nonce_size := proof_of_work_nonce_size;
    nonce_length := nonce_length;
    max_revelations_per_block := max_revelations_per_block;
    max_operation_data_length := max_operation_data_length;
    max_proposals_per_delegate := max_proposals_per_delegate |}.

Record parametric := {
  preserved_cycles : Z;
  blocks_per_cycle : int32;
  blocks_per_commitment : int32;
  blocks_per_roll_snapshot : int32;
  blocks_per_voting_period : int32;
  time_between_blocks : list Tezos_raw_protocol_alpha.Period_repr.t;
  endorsers_per_block : Z;
  hard_gas_limit_per_operation :
    Tezos_protocol_environment_alpha__Environment.Z.t;
  hard_gas_limit_per_block : Tezos_protocol_environment_alpha__Environment.Z.t;
  proof_of_work_threshold : int64;
  tokens_per_roll : Tezos_raw_protocol_alpha.Tez_repr.t;
  michelson_maximum_type_size : Z;
  seed_nonce_revelation_tip : Tezos_raw_protocol_alpha.Tez_repr.t;
  origination_size : Z;
  block_security_deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
  endorsement_security_deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
  block_reward : Tezos_raw_protocol_alpha.Tez_repr.t;
  endorsement_reward : Tezos_raw_protocol_alpha.Tez_repr.t;
  cost_per_byte : Tezos_raw_protocol_alpha.Tez_repr.t;
  hard_storage_limit_per_operation :
    Tezos_protocol_environment_alpha__Environment.Z.t;
  test_chain_duration : int64;
  quorum_min : int32;
  quorum_max : int32;
  min_proposal_quorum : int32;
  initial_endorsers : Z;
  delay_per_missing_endorsement : Tezos_raw_protocol_alpha.Period_repr.t }.

Definition parametric_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    parametric :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun c =>
      (((preserved_cycles c), (blocks_per_cycle c), (blocks_per_commitment c),
        (blocks_per_roll_snapshot c), (blocks_per_voting_period c),
        (time_between_blocks c), (endorsers_per_block c),
        (hard_gas_limit_per_operation c), (hard_gas_limit_per_block c)),
        (((proof_of_work_threshold c), (tokens_per_roll c),
          (michelson_maximum_type_size c), (seed_nonce_revelation_tip c),
          (origination_size c), (block_security_deposit c),
          (endorsement_security_deposit c), (block_reward c)),
          ((endorsement_reward c), (cost_per_byte c),
            (hard_storage_limit_per_operation c), (test_chain_duration c),
            (quorum_min c), (quorum_max c), (min_proposal_quorum c),
            (initial_endorsers c), (delay_per_missing_endorsement c)))))
    (fun function_parameter =>
      match function_parameter with
      |
        ((preserved_cycles, blocks_per_cycle, blocks_per_commitment,
          blocks_per_roll_snapshot, blocks_per_voting_period,
          time_between_blocks, endorsers_per_block,
          hard_gas_limit_per_operation, hard_gas_limit_per_block),
          ((proof_of_work_threshold, tokens_per_roll,
            michelson_maximum_type_size, seed_nonce_revelation_tip,
            origination_size, block_security_deposit,
            endorsement_security_deposit, block_reward),
            (endorsement_reward, cost_per_byte,
              hard_storage_limit_per_operation, test_chain_duration, quorum_min,
              quorum_max, min_proposal_quorum, initial_endorsers,
              delay_per_missing_endorsement))) =>
        {| preserved_cycles := preserved_cycles;
          blocks_per_cycle := blocks_per_cycle;
          blocks_per_commitment := blocks_per_commitment;
          blocks_per_roll_snapshot := blocks_per_roll_snapshot;
          blocks_per_voting_period := blocks_per_voting_period;
          time_between_blocks := time_between_blocks;
          endorsers_per_block := endorsers_per_block;
          hard_gas_limit_per_operation := hard_gas_limit_per_operation;
          hard_gas_limit_per_block := hard_gas_limit_per_block;
          proof_of_work_threshold := proof_of_work_threshold;
          tokens_per_roll := tokens_per_roll;
          michelson_maximum_type_size := michelson_maximum_type_size;
          seed_nonce_revelation_tip := seed_nonce_revelation_tip;
          origination_size := origination_size;
          block_security_deposit := block_security_deposit;
          endorsement_security_deposit := endorsement_security_deposit;
          block_reward := block_reward;
          endorsement_reward := endorsement_reward;
          cost_per_byte := cost_per_byte;
          hard_storage_limit_per_operation := hard_storage_limit_per_operation;
          test_chain_duration := test_chain_duration; quorum_min := quorum_min;
          quorum_max := quorum_max; min_proposal_quorum := min_proposal_quorum;
          initial_endorsers := initial_endorsers;
          delay_per_missing_endorsement := delay_per_missing_endorsement |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj9
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "preserved_cycles" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.uint8)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "blocks_per_cycle" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "blocks_per_commitment" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "blocks_per_roll_snapshot" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "blocks_per_voting_period" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "time_between_blocks" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            Tezos_raw_protocol_alpha.Period_repr.encoding))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "endorsers_per_block" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "hard_gas_limit_per_operation" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "hard_gas_limit_per_block" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z))
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj8
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "proof_of_work_threshold" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.int64)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "tokens_per_roll" % string
            Tezos_raw_protocol_alpha.Tez_repr.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "michelson_maximum_type_size" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "seed_nonce_revelation_tip" % string
            Tezos_raw_protocol_alpha.Tez_repr.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "origination_size" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.int31)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "block_security_deposit" % string
            Tezos_raw_protocol_alpha.Tez_repr.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "endorsement_security_deposit" % string
            Tezos_raw_protocol_alpha.Tez_repr.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "block_reward" % string
            Tezos_raw_protocol_alpha.Tez_repr.encoding))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj9
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "endorsement_reward" % string
            Tezos_raw_protocol_alpha.Tez_repr.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "cost_per_byte" % string
            Tezos_raw_protocol_alpha.Tez_repr.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "hard_storage_limit_per_operation" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "test_chain_duration" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.int64)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "quorum_min" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "quorum_max" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "min_proposal_quorum" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "initial_endorsers" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "delay_per_missing_endorsement" % string
            Tezos_raw_protocol_alpha.Period_repr.encoding)))).

Record t := {
  fixed : fixed;
  parametric : parametric }.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| fixed := fixed; parametric := parametric |} => (fixed, parametric)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (fixed, parametric) => {| fixed := fixed; parametric := parametric |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
      fixed_encoding parametric_encoding).
src/proto_alpha/lib_protocol/constants_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root =
  ( RPC_path.(open_root / "context" / "constants")
    : RPC_context.t RPC_path.context )

module S = struct
  open Data_encoding

  let errors =
    RPC_service.get_service
      ~description:"Schema for all the RPC errors from this protocol version"
      ~query:RPC_query.empty
      ~output:json_schema
      RPC_path.(custom_root / "errors")

  let all =
    RPC_service.get_service
      ~description:"All constants"
      ~query:RPC_query.empty
      ~output:Alpha_context.Constants.encoding
      custom_root
end

let register () =
  let open Services_registration in
  register0_noctxt S.errors (fun () () ->
      return Data_encoding.Json.(schema error_encoding)) ;
  register0 S.all (fun ctxt () () ->
      let open Constants in
      return {fixed; parametric = parametric ctxt})

let errors ctxt block = RPC_context.make_call0 S.errors ctxt block () ()

let all ctxt block = RPC_context.make_call0 S.all ctxt block () ()
src/proto_alpha/lib_protocol/constants_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Definition custom_root
  : Tezos_protocol_environment_alpha__Environment.RPC_path.context
    Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
  Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
    (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
      Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
      "context" % string) "constants" % string.

Module S.
  Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
  
  Definition errors
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
      Tezos_protocol_environment_alpha__Environment.Data_encoding.json_schema :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Schema for all the RPC errors from this protocol version" % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_protocol_environment_alpha__Environment.Data_encoding.json_schema
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div custom_root
        "errors" % string).
  
  Definition all
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Constants.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "All constants" % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Constants.encoding custom_root.
End S.

Definition register (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    Tezos_raw_protocol_alpha.Services_registration.register0_noctxt S.errors
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.Json.schema
                  None
                  Tezos_protocol_environment_alpha__Environment.Error_monad.error_encoding)
            end
        end);
    Tezos_raw_protocol_alpha.Services_registration.register0 S.all
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  {|
                    fixed :=
                      Tezos_raw_protocol_alpha.Alpha_context.Constants.fixed;
                    parametric :=
                      Tezos_raw_protocol_alpha.Alpha_context.Constants.parametric
                        ctxt |}
              end
          end)
  end.

Definition errors {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_protocol_environment_alpha__Environment.Data_encoding.json_schema) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0 S.errors
    ctxt block tt tt.

Definition all {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0 S.all
    ctxt block tt tt.
src/proto_alpha/lib_protocol/constants_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

val errors :
  'a #RPC_context.simple ->
  'a ->
  Data_encoding.json_schema shell_tzresult Lwt.t

(** Returns all the constants of the protocol *)
val all : 'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t

val register : unit -> unit
src/proto_alpha/lib_protocol/constants_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter errors : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.Data_encoding.json_schema).

Parameter all : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Constants.t).

Parameter register : unit -> unit.
src/proto_alpha/lib_protocol/constants_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let preserved_cycles c =
  let constants = Raw_context.constants c in
  constants.preserved_cycles

let blocks_per_cycle c =
  let constants = Raw_context.constants c in
  constants.blocks_per_cycle

let blocks_per_commitment c =
  let constants = Raw_context.constants c in
  constants.blocks_per_commitment

let blocks_per_roll_snapshot c =
  let constants = Raw_context.constants c in
  constants.blocks_per_roll_snapshot

let blocks_per_voting_period c =
  let constants = Raw_context.constants c in
  constants.blocks_per_voting_period

let time_between_blocks c =
  let constants = Raw_context.constants c in
  constants.time_between_blocks

let endorsers_per_block c =
  let constants = Raw_context.constants c in
  constants.endorsers_per_block

let initial_endorsers c =
  let constants = Raw_context.constants c in
  constants.initial_endorsers

let delay_per_missing_endorsement c =
  let constants = Raw_context.constants c in
  constants.delay_per_missing_endorsement

let hard_gas_limit_per_operation c =
  let constants = Raw_context.constants c in
  constants.hard_gas_limit_per_operation

let hard_gas_limit_per_block c =
  let constants = Raw_context.constants c in
  constants.hard_gas_limit_per_block

let cost_per_byte c =
  let constants = Raw_context.constants c in
  constants.cost_per_byte

let hard_storage_limit_per_operation c =
  let constants = Raw_context.constants c in
  constants.hard_storage_limit_per_operation

let proof_of_work_threshold c =
  let constants = Raw_context.constants c in
  constants.proof_of_work_threshold

let tokens_per_roll c =
  let constants = Raw_context.constants c in
  constants.tokens_per_roll

let michelson_maximum_type_size c =
  let constants = Raw_context.constants c in
  constants.michelson_maximum_type_size

let seed_nonce_revelation_tip c =
  let constants = Raw_context.constants c in
  constants.seed_nonce_revelation_tip

let origination_size c =
  let constants = Raw_context.constants c in
  constants.origination_size

let block_security_deposit c =
  let constants = Raw_context.constants c in
  constants.block_security_deposit

let endorsement_security_deposit c =
  let constants = Raw_context.constants c in
  constants.endorsement_security_deposit

let block_reward c =
  let constants = Raw_context.constants c in
  constants.block_reward

let endorsement_reward c =
  let constants = Raw_context.constants c in
  constants.endorsement_reward

let test_chain_duration c =
  let constants = Raw_context.constants c in
  constants.test_chain_duration

let quorum_min c =
  let constants = Raw_context.constants c in
  constants.quorum_min

let quorum_max c =
  let constants = Raw_context.constants c in
  constants.quorum_max

let min_proposal_quorum c =
  let constants = Raw_context.constants c in
  constants.min_proposal_quorum

let parametric c = Raw_context.constants c
src/proto_alpha/lib_protocol/constants_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition preserved_cycles (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Z :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  preserved_cycles constants.

Definition blocks_per_cycle (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : int32 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  blocks_per_cycle constants.

Definition blocks_per_commitment
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  blocks_per_commitment constants.

Definition blocks_per_roll_snapshot
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  blocks_per_roll_snapshot constants.

Definition blocks_per_voting_period
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  blocks_per_voting_period constants.

Definition time_between_blocks
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : list Tezos_raw_protocol_alpha.Period_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  time_between_blocks constants.

Definition endorsers_per_block
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  endorsers_per_block constants.

Definition initial_endorsers (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Z :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  initial_endorsers constants.

Definition delay_per_missing_endorsement
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Period_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  delay_per_missing_endorsement constants.

Definition hard_gas_limit_per_operation
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  hard_gas_limit_per_operation constants.

Definition hard_gas_limit_per_block
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  hard_gas_limit_per_block constants.

Definition cost_per_byte (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  cost_per_byte constants.

Definition hard_storage_limit_per_operation
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  hard_storage_limit_per_operation constants.

Definition proof_of_work_threshold
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int64 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  proof_of_work_threshold constants.

Definition tokens_per_roll (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  tokens_per_roll constants.

Definition michelson_maximum_type_size
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  michelson_maximum_type_size constants.

Definition seed_nonce_revelation_tip
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  seed_nonce_revelation_tip constants.

Definition origination_size (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Z :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  origination_size constants.

Definition block_security_deposit
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  block_security_deposit constants.

Definition endorsement_security_deposit
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  endorsement_security_deposit constants.

Definition block_reward (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  block_reward constants.

Definition endorsement_reward (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  endorsement_reward constants.

Definition test_chain_duration
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int64 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  test_chain_duration constants.

Definition quorum_min (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : int32 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  quorum_min constants.

Definition quorum_max (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : int32 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  quorum_max constants.

Definition min_proposal_quorum
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  min_proposal_quorum constants.

Definition parametric (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Constants_repr.parametric :=
  Tezos_raw_protocol_alpha.Raw_context.constants c.
src/proto_alpha/lib_protocol/contract_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* 20 *)
let contract_hash = "\002\090\121" (* KT1(36) *)

include Blake2B.Make
          (Base58)
          (struct
            let name = "Contract_hash"

            let title = "A contract ID"

            let b58check_prefix = contract_hash

            let size = Some 20
          end)

let () = Base58.check_encoded_prefix b58check_encoding "KT1" 36
src/proto_alpha/lib_protocol/contract_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition contract_hash : string := "Zy" % string.
src/proto_alpha/lib_protocol/contract_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t =
  | Implicit of Signature.Public_key_hash.t
  | Originated of Contract_hash.t

include Compare.Make (struct
  type nonrec t = t

  let compare l1 l2 =
    match (l1, l2) with
    | (Implicit pkh1, Implicit pkh2) ->
        Signature.Public_key_hash.compare pkh1 pkh2
    | (Originated h1, Originated h2) ->
        Contract_hash.compare h1 h2
    | (Implicit _, Originated _) ->
        -1
    | (Originated _, Implicit _) ->
        1
end)

type contract = t

type error += Invalid_contract_notation of string (* `Permanent *)

let to_b58check = function
  | Implicit pbk ->
      Signature.Public_key_hash.to_b58check pbk
  | Originated h ->
      Contract_hash.to_b58check h

let of_b58check s =
  match Base58.decode s with
  | Some (Ed25519.Public_key_hash.Data h) ->
      ok (Implicit (Signature.Ed25519 h))
  | Some (Secp256k1.Public_key_hash.Data h) ->
      ok (Implicit (Signature.Secp256k1 h))
  | Some (P256.Public_key_hash.Data h) ->
      ok (Implicit (Signature.P256 h))
  | Some (Contract_hash.Data h) ->
      ok (Originated h)
  | _ ->
      error (Invalid_contract_notation s)

let pp ppf = function
  | Implicit pbk ->
      Signature.Public_key_hash.pp ppf pbk
  | Originated h ->
      Contract_hash.pp ppf h

let pp_short ppf = function
  | Implicit pbk ->
      Signature.Public_key_hash.pp_short ppf pbk
  | Originated h ->
      Contract_hash.pp_short ppf h

let encoding =
  let open Data_encoding in
  def
    "contract_id"
    ~title:"A contract handle"
    ~description:
      "A contract notation as given to an RPC or inside scripts. Can be a \
       base58 implicit contract hash or a base58 originated contract hash."
  @@ splitted
       ~binary:
         (union
            ~tag_size:`Uint8
            [ case
                (Tag 0)
                ~title:"Implicit"
                Signature.Public_key_hash.encoding
                (function Implicit k -> Some k | _ -> None)
                (fun k -> Implicit k);
              case
                (Tag 1)
                (Fixed.add_padding Contract_hash.encoding 1)
                ~title:"Originated"
                (function Originated k -> Some k | _ -> None)
                (fun k -> Originated k) ])
       ~json:
         (conv
            to_b58check
            (fun s ->
              match of_b58check s with
              | Ok s ->
                  s
              | Error _ ->
                  Json.cannot_destruct "Invalid contract notation.")
            string)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"contract.invalid_contract_notation"
    ~title:"Invalid contract notation"
    ~pp:(fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x)
    ~description:
      "A malformed contract notation was given to an RPC or in a script."
    (obj1 (req "notation" string))
    (function Invalid_contract_notation loc -> Some loc | _ -> None)
    (fun loc -> Invalid_contract_notation loc)

let implicit_contract id = Implicit id

let is_implicit = function Implicit m -> Some m | Originated _ -> None

let is_originated = function Implicit _ -> None | Originated h -> Some h

type origination_nonce = {
  operation_hash : Operation_hash.t;
  origination_index : int32;
}

let origination_nonce_encoding =
  let open Data_encoding in
  conv
    (fun {operation_hash; origination_index} ->
      (operation_hash, origination_index))
    (fun (operation_hash, origination_index) ->
      {operation_hash; origination_index})
  @@ obj2 (req "operation" Operation_hash.encoding) (dft "index" int32 0l)

let originated_contract nonce =
  let data =
    Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce
  in
  Originated (Contract_hash.hash_bytes [data])

let originated_contracts
    ~since:{origination_index = first; operation_hash = first_hash}
    ~until:( {origination_index = last; operation_hash = last_hash} as
           origination_nonce ) =
  assert (Operation_hash.equal first_hash last_hash) ;
  let rec contracts acc origination_index =
    if Compare.Int32.(origination_index < first) then acc
    else
      let origination_nonce = {origination_nonce with origination_index} in
      let acc = originated_contract origination_nonce :: acc in
      contracts acc (Int32.pred origination_index)
  in
  contracts [] (Int32.pred last)

let initial_origination_nonce operation_hash =
  {operation_hash; origination_index = 0l}

let incr_origination_nonce nonce =
  let origination_index = Int32.succ nonce.origination_index in
  {nonce with origination_index}

let rpc_arg =
  let construct = to_b58check in
  let destruct hash =
    match of_b58check hash with
    | Error _ ->
        Error "Cannot parse contract id"
    | Ok contract ->
        Ok contract
  in
  RPC_arg.make
    ~descr:"A contract identifier encoded in b58check."
    ~name:"contract_id"
    ~construct
    ~destruct
    ()

module Index = struct
  type t = contract

  let path_length = 7

  let to_path c l =
    let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
    let (`Hex key) = MBytes.to_hex raw_key in
    let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
    String.sub index_key 0 2 :: String.sub index_key 2 2
    :: String.sub index_key 4 2 :: String.sub index_key 6 2
    :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: key :: l

  let of_path = function
    | []
    | [_]
    | [_; _]
    | [_; _; _]
    | [_; _; _; _]
    | [_; _; _; _; _]
    | [_; _; _; _; _; _]
    | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
        None
    | [index1; index2; index3; index4; index5; index6; key] ->
        let raw_key = MBytes.of_hex (`Hex key) in
        let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
        assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
        assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
        assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
        assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
        assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
        assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
        Data_encoding.Binary.of_bytes encoding raw_key

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
src/proto_alpha/lib_protocol/contract_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Implicit :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t -> t
| Originated : Tezos_raw_protocol_alpha.Contract_hash.t -> t.

Definition contract := t.

Definition to_b58check (function_parameter : t) : string :=
  match function_parameter with
  | Implicit pbk =>
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.to_b58check
      pbk
  | Originated h => Tezos_raw_protocol_alpha.Contract_hash.to_b58check h
  end.

Definition of_b58check (s : string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t :=
  match Tezos_protocol_environment_alpha__Environment.Base58.decode s with
  | Some (Ed25519.Public_key_hash.Data h) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      (Implicit (Signature.Ed25519 h))
  | Some (Secp256k1.Public_key_hash.Data h) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      (Implicit (Signature.Secp256k1 h))
  | Some (P256.Public_key_hash.Data h) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      (Implicit (Signature.P256 h))
  | Some (Contract_hash.Data h) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok (Originated h)
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      (Invalid_contract_notation s)
  end.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : t) : unit :=
  match function_parameter with
  | Implicit pbk =>
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.pp
      ppf pbk
  | Originated h => Tezos_raw_protocol_alpha.Contract_hash.pp ppf h
  end.

Definition pp_short
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : t) : unit :=
  match function_parameter with
  | Implicit pbk =>
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.pp_short
      ppf pbk
  | Originated h => Tezos_raw_protocol_alpha.Contract_hash.pp_short ppf h
  end.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.def
      "contract_id" % string (Some "A contract handle" % string)
      (Some
        "A contract notation as given to an RPC or inside scripts. Can be a base58 implicit contract hash or a base58 originated contract hash."
          % string))
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.splitted
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
        to_b58check
        (fun s =>
          match of_b58check s with
          | inl s => s
          | inr _ =>
            Tezos_protocol_environment_alpha__Environment.Data_encoding.Json.cannot_destruct
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Invalid contract notation." % string
                  CamlinternalFormatBasics.End_of_format)
                "Invalid contract notation." % string)
          end) None
        Tezos_protocol_environment_alpha__Environment.Data_encoding.string)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.union
        (Some variant)
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "Implicit" % string None (Tag 0)
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
            (fun function_parameter =>
              match function_parameter with
              | Implicit k => Some k
              | _ => None
              end) (fun k => Implicit k))
          (cons
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
              "Originated" % string None (Tag 1)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Fixed.add_padding
                Tezos_raw_protocol_alpha.Contract_hash.encoding 1)
              (fun function_parameter =>
                match function_parameter with
                | Originated k => Some k
                | _ => None
                end) (fun k => Originated k)) [])))).

Definition implicit_contract
  (id :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : t := Implicit id.

Definition is_implicit (function_parameter : t)
  : option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
  match function_parameter with
  | Implicit m => Some m
  | Originated _ => None
  end.

Definition is_originated (function_parameter : t)
  : option Tezos_raw_protocol_alpha.Contract_hash.t :=
  match function_parameter with
  | Implicit _ => None
  | Originated h => Some h
  end.

Record origination_nonce := {
  operation_hash :
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
  origination_index : int32 }.

Definition origination_nonce_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    origination_nonce :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {|
            operation_hash := operation_hash;
              origination_index := origination_index
              |} => (operation_hash, origination_index)
          end)
        (fun function_parameter =>
          match function_parameter with
          | (operation_hash, origination_index) =>
            {| operation_hash := operation_hash;
              origination_index := origination_index |}
          end) in
    fun eta => arg None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "operation" % string
        Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None None
        "index" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32 0)).

Definition originated_contract (nonce : origination_nonce) : t :=
  let data :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
      origination_nonce_encoding nonce in
  Originated
    (Tezos_raw_protocol_alpha.Contract_hash.hash_bytes None (cons data [])).

Definition originated_contracts (function_parameter : origination_nonce)
  : origination_nonce -> list t :=
  match function_parameter with
  | {| operation_hash := first_hash; origination_index := first |} =>
    fun function_parameter =>
      match function_parameter with
      |
        {| operation_hash := last_hash; origination_index := last |} as
          origination_nonce =>
        Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
          first_hash last_hash;
        let fix contracts
          (acc : list t) (origination_index :
          Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
          : list t :=
          if
            Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
              origination_index first then
            acc
          else
            let origination_nonce := record in
            let acc := cons (originated_contract origination_nonce) acc in
            contracts acc
              (Tezos_protocol_environment_alpha__Environment.Int32.pred
                origination_index) in
        contracts []
          (Tezos_protocol_environment_alpha__Environment.Int32.pred last)
      end
  end.

Definition initial_origination_nonce
  (operation_hash :
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : origination_nonce :=
  {| operation_hash := operation_hash; origination_index := 0 |}.

Definition incr_origination_nonce (nonce : origination_nonce)
  : origination_nonce :=
  let origination_index :=
    Tezos_protocol_environment_alpha__Environment.Int32.succ
      (origination_index nonce) in
  record.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg t :=
  let construct := to_b58check in
  let destruct (hash : string)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result t string :=
    match of_b58check hash with
    | inr _ => inr "Cannot parse contract id" % string
    | inl contract => inl contract
    end in
  Tezos_protocol_environment_alpha__Environment.RPC_arg.make
    (Some "A contract identifier encoded in b58check." % string)
    "contract_id" % string destruct construct tt.

Module Index.
  Definition t := contract.
  
  Definition path_length : Z := 7.
  
  Definition to_path (c : t) (l : list string) : list string :=
    let raw_key :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
        encoding c in
    match Tezos_protocol_environment_alpha__Environment.MBytes.to_hex raw_key
      with
    | Hex key =>
      match
        Tezos_protocol_environment_alpha__Environment.MBytes.to_hex
          (Tezos_protocol_environment_alpha__Environment.Raw_hashes.blake2b
            raw_key) with
      | Hex index_key =>
        cons
          (Tezos_protocol_environment_alpha__Environment.String.sub index_key 0
            2)
          (cons
            (Tezos_protocol_environment_alpha__Environment.String.sub index_key
              2 2)
            (cons
              (Tezos_protocol_environment_alpha__Environment.String.sub
                index_key 4 2)
              (cons
                (Tezos_protocol_environment_alpha__Environment.String.sub
                  index_key 6 2)
                (cons
                  (Tezos_protocol_environment_alpha__Environment.String.sub
                    index_key 8 2)
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.String.sub
                      index_key 10 2) (cons key l))))))
      end
    end.
  
  Definition of_path
    (function_parameter :
      list
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    : option t :=
    match function_parameter with
    |
      [] | cons _ [] | cons _ (cons _ []) | cons _ (cons _ (cons _ [])) |
        cons _ (cons _ (cons _ (cons _ []))) |
        cons _ (cons _ (cons _ (cons _ (cons _ [])))) |
        cons _ (cons _ (cons _ (cons _ (cons _ (cons _ []))))) |
        cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ _)))))))
      => None
    |
      cons index1
        (cons index2
          (cons index3 (cons index4 (cons index5 (cons index6 (cons key []))))))
      =>
      let raw_key :=
        Tezos_protocol_environment_alpha__Environment.MBytes.of_hex variant in
      match
        Tezos_protocol_environment_alpha__Environment.MBytes.to_hex
          (Tezos_protocol_environment_alpha__Environment.Raw_hashes.blake2b
            raw_key) with
      | Hex index_key =>
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          (Tezos_protocol_environment_alpha__Environment.String.sub index_key 0
            2) index1;
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          (Tezos_protocol_environment_alpha__Environment.String.sub index_key 2
            2) index2;
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          (Tezos_protocol_environment_alpha__Environment.String.sub index_key 4
            2) index3;
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          (Tezos_protocol_environment_alpha__Environment.String.sub index_key 6
            2) index4;
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          (Tezos_protocol_environment_alpha__Environment.String.sub index_key 8
            2) index5;
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          (Tezos_protocol_environment_alpha__Environment.String.sub index_key 10
            2) index6;
        Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
          encoding raw_key
      end
    end.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg t := rpc_arg.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
    encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.
src/proto_alpha/lib_protocol/contract_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = private
  | Implicit of Signature.Public_key_hash.t
  | Originated of Contract_hash.t

type contract = t

include Compare.S with type t := contract

(** {2 Implicit contracts} *)

val implicit_contract : Signature.Public_key_hash.t -> contract

val is_implicit : contract -> Signature.Public_key_hash.t option

(** {2 Originated contracts} *)

(** Originated contracts handles are crafted from the hash of the
    operation that triggered their origination (and nothing else).
    As a single operation can trigger several originations, the
    corresponding handles are forged from a deterministic sequence of
    nonces, initialized with the hash of the operation. *)
type origination_nonce

val originated_contract : origination_nonce -> contract

val originated_contracts :
  since:origination_nonce -> until:origination_nonce -> contract list

val initial_origination_nonce : Operation_hash.t -> origination_nonce

val incr_origination_nonce : origination_nonce -> origination_nonce

val is_originated : contract -> Contract_hash.t option

(** {2 Human readable notation} *)

type error += Invalid_contract_notation of string (* `Permanent *)

val to_b58check : contract -> string

val of_b58check : string -> contract tzresult

val pp : Format.formatter -> contract -> unit

val pp_short : Format.formatter -> contract -> unit

(** {2 Serializers} *)

val encoding : contract Data_encoding.t

val origination_nonce_encoding : origination_nonce Data_encoding.t

val rpc_arg : contract RPC_arg.arg

module Index : Storage_description.INDEX with type t = t
src/proto_alpha/lib_protocol/contract_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Implicit :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t -> t
| Originated : Tezos_raw_protocol_alpha.Contract_hash.t -> t.

Definition contract := t.

include

Parameter implicit_contract :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  contract.

Parameter is_implicit :
contract ->
  option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t.

Parameter origination_nonce : Type.

Parameter originated_contract : origination_nonce -> contract.

Parameter originated_contracts :
origination_nonce -> origination_nonce -> list contract.

Parameter initial_origination_nonce :
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> origination_nonce.

Parameter incr_origination_nonce : origination_nonce -> origination_nonce.

Parameter is_originated :
contract -> option Tezos_raw_protocol_alpha.Contract_hash.t.

extensible_type

Parameter to_b58check : contract -> string.

Parameter of_b58check :
string ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult contract.

Parameter pp :
Tezos_protocol_environment_alpha__Environment.Format.formatter ->
  contract -> unit.

Parameter pp_short :
Tezos_protocol_environment_alpha__Environment.Format.formatter ->
  contract -> unit.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t contract.

Parameter origination_nonce_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t origination_nonce.

Parameter rpc_arg :
Tezos_protocol_environment_alpha__Environment.RPC_arg.arg contract.

unhandled_module
src/proto_alpha/lib_protocol/contract_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root =
  ( RPC_path.(open_root / "context" / "contracts")
    : RPC_context.t RPC_path.context )

let big_map_root =
  ( RPC_path.(open_root / "context" / "big_maps")
    : RPC_context.t RPC_path.context )

type info = {
  balance : Tez.t;
  delegate : public_key_hash option;
  counter : counter option;
  script : Script.t option;
}

let info_encoding =
  let open Data_encoding in
  conv
    (fun {balance; delegate; script; counter} ->
      (balance, delegate, script, counter))
    (fun (balance, delegate, script, counter) ->
      {balance; delegate; script; counter})
  @@ obj4
       (req "balance" Tez.encoding)
       (opt "delegate" Signature.Public_key_hash.encoding)
       (opt "script" Script.encoding)
       (opt "counter" n)

module S = struct
  open Data_encoding

  let balance =
    RPC_service.get_service
      ~description:"Access the balance of a contract."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "balance")

  let manager_key =
    RPC_service.get_service
      ~description:"Access the manager of a contract."
      ~query:RPC_query.empty
      ~output:(option Signature.Public_key.encoding)
      RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")

  let delegate =
    RPC_service.get_service
      ~description:"Access the delegate of a contract, if any."
      ~query:RPC_query.empty
      ~output:Signature.Public_key_hash.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "delegate")

  let counter =
    RPC_service.get_service
      ~description:"Access the counter of a contract, if any."
      ~query:RPC_query.empty
      ~output:z
      RPC_path.(custom_root /: Contract.rpc_arg / "counter")

  let script =
    RPC_service.get_service
      ~description:"Access the code and data of the contract."
      ~query:RPC_query.empty
      ~output:Script.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "script")

  let storage =
    RPC_service.get_service
      ~description:"Access the data of the contract."
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "storage")

  let entrypoint_type =
    RPC_service.get_service
      ~description:"Return the type of the given entrypoint of the contract"
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(
        custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string)

  let list_entrypoints =
    RPC_service.get_service
      ~description:"Return the list of entrypoints of the contract"
      ~query:RPC_query.empty
      ~output:
        (obj2
           (dft
              "unreachable"
              (Data_encoding.list
                 (obj1
                    (req
                       "path"
                       (Data_encoding.list
                          Michelson_v1_primitives.prim_encoding))))
              [])
           (req "entrypoints" (assoc Script.expr_encoding)))
      RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints")

  let contract_big_map_get_opt =
    RPC_service.post_service
      ~description:
        "Access the value associated with a key in a big map of the contract \
         (deprecated)."
      ~query:RPC_query.empty
      ~input:
        (obj2
           (req "key" Script.expr_encoding)
           (req "type" Script.expr_encoding))
      ~output:(option Script.expr_encoding)
      RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")

  let big_map_get =
    RPC_service.get_service
      ~description:"Access the value associated with a key in a big map."
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg)

  let info =
    RPC_service.get_service
      ~description:"Access the complete status of a contract."
      ~query:RPC_query.empty
      ~output:info_encoding
      RPC_path.(custom_root /: Contract.rpc_arg)

  let list =
    RPC_service.get_service
      ~description:
        "All existing contracts (including non-empty default contracts)."
      ~query:RPC_query.empty
      ~output:(list Contract.encoding)
      custom_root
end

let register () =
  let open Services_registration in
  register0 S.list (fun ctxt () () -> Contract.list ctxt >>= return) ;
  let register_field s f =
    register1 s (fun ctxt contract () () ->
        Contract.exists ctxt contract
        >>=? function true -> f ctxt contract | false -> raise Not_found)
  in
  let register_opt_field s f =
    register_field s (fun ctxt a1 ->
        f ctxt a1 >>=? function None -> raise Not_found | Some v -> return v)
  in
  let do_big_map_get ctxt id key =
    let open Script_ir_translator in
    let ctxt = Gas.set_unlimited ctxt in
    Big_map.exists ctxt id
    >>=? fun (ctxt, types) ->
    match types with
    | None ->
        raise Not_found
    | Some (_, value_type) -> (
        Lwt.return
          (parse_ty
             ctxt
             ~legacy:true
             ~allow_big_map:false
             ~allow_operation:false
             ~allow_contract:true
             (Micheline.root value_type))
        >>=? fun (Ex_ty value_type, ctxt) ->
        Big_map.get_opt ctxt id key
        >>=? fun (_ctxt, value) ->
        match value with
        | None ->
            raise Not_found
        | Some value ->
            parse_data ctxt ~legacy:true value_type (Micheline.root value)
            >>=? fun (value, ctxt) ->
            unparse_data ctxt Readable value_type value
            >>=? fun (value, _ctxt) -> return (Micheline.strip_locations value)
        )
  in
  register_field S.balance Contract.get_balance ;
  register1 S.manager_key (fun ctxt contract () () ->
      match Contract.is_implicit contract with
      | None ->
          raise Not_found
      | Some mgr -> (
          Contract.is_manager_key_revealed ctxt mgr
          >>=? function
          | false ->
              return_none
          | true ->
              Contract.get_manager_key ctxt mgr >>=? return_some )) ;
  register_opt_field S.delegate Delegate.get ;
  register1 S.counter (fun ctxt contract () () ->
      match Contract.is_implicit contract with
      | None ->
          raise Not_found
      | Some mgr ->
          Contract.get_counter ctxt mgr) ;
  register_opt_field S.script (fun c v ->
      Contract.get_script c v >>=? fun (_, v) -> return v) ;
  register_opt_field S.storage (fun ctxt contract ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      match script with
      | None ->
          return_none
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          unparse_script ctxt Readable script
          >>=? fun (script, ctxt) ->
          Script.force_decode ctxt script.storage
          >>=? fun (storage, _ctxt) -> return_some storage) ;
  register2 S.entrypoint_type (fun ctxt v entrypoint () () ->
      Contract.get_script_code ctxt v
      >>=? fun (_, expr) ->
      match expr with
      | None ->
          raise Not_found
      | Some expr -> (
          let ctxt = Gas.set_unlimited ctxt in
          let legacy = true in
          let open Script_ir_translator in
          Script.force_decode ctxt expr
          >>=? fun (expr, _) ->
          Lwt.return
            ( parse_toplevel ~legacy expr
            >>? fun (arg_type, _, _, root_name) ->
            parse_ty
              ctxt
              ~legacy
              ~allow_big_map:true
              ~allow_operation:false
              ~allow_contract:true
              arg_type
            >>? fun (Ex_ty arg_type, _) ->
            Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
            )
          >>= function
          | Ok (_f, Ex_ty ty) ->
              unparse_ty ctxt ty
              >>=? fun (ty_node, _) ->
              return (Micheline.strip_locations ty_node)
          | Error _ ->
              raise Not_found )) ;
  register1 S.list_entrypoints (fun ctxt v () () ->
      Contract.get_script_code ctxt v
      >>=? fun (_, expr) ->
      match expr with
      | None ->
          raise Not_found
      | Some expr ->
          let ctxt = Gas.set_unlimited ctxt in
          let legacy = true in
          let open Script_ir_translator in
          Script.force_decode ctxt expr
          >>=? fun (expr, _) ->
          Lwt.return
            ( parse_toplevel ~legacy expr
            >>? fun (arg_type, _, _, root_name) ->
            parse_ty
              ctxt
              ~legacy
              ~allow_big_map:true
              ~allow_operation:false
              ~allow_contract:true
              arg_type
            >>? fun (Ex_ty arg_type, _) ->
            Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
          >>=? fun (unreachable_entrypoint, map) ->
          return
            ( unreachable_entrypoint,
              Entrypoints_map.fold
                (fun entry (_, ty) acc ->
                  (entry, Micheline.strip_locations ty) :: acc)
                map
                [] )) ;
  register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      Lwt.return
        (Script_ir_translator.parse_packable_ty
           ctxt
           ~legacy:true
           (Micheline.root key_type))
      >>=? fun (Ex_ty key_type, ctxt) ->
      Script_ir_translator.parse_data
        ctxt
        ~legacy:true
        key_type
        (Micheline.root key)
      >>=? fun (key, ctxt) ->
      Script_ir_translator.hash_data ctxt key_type key
      >>=? fun (key, ctxt) ->
      match script with
      | None ->
          raise Not_found
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          Script_ir_translator.collect_big_maps
            ctxt
            script.storage_type
            script.storage
          >>=? fun (ids, _ctxt) ->
          let ids = Script_ir_translator.list_of_big_map_ids ids in
          let rec find = function
            | [] ->
                return_none
            | (id : Z.t) :: ids -> (
              try do_big_map_get ctxt id key >>=? return_some
              with Not_found -> find ids )
          in
          find ids) ;
  register2 S.big_map_get (fun ctxt id key () () -> do_big_map_get ctxt id key) ;
  register_field S.info (fun ctxt contract ->
      Contract.get_balance ctxt contract
      >>=? fun balance ->
      Delegate.get ctxt contract
      >>=? fun delegate ->
      ( match Contract.is_implicit contract with
      | Some manager ->
          Contract.get_counter ctxt manager
          >>=? fun counter -> return_some counter
      | None ->
          return None )
      >>=? fun counter ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      ( match script with
      | None ->
          return (None, ctxt)
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          unparse_script ctxt Readable script
          >>=? fun (script, ctxt) -> return (Some script, ctxt) )
      >>=? fun (script, _ctxt) -> return {balance; delegate; script; counter})

let list ctxt block = RPC_context.make_call0 S.list ctxt block () ()

let info ctxt block contract =
  RPC_context.make_call1 S.info ctxt block contract () ()

let balance ctxt block contract =
  RPC_context.make_call1 S.balance ctxt block contract () ()

let manager_key ctxt block mgr =
  RPC_context.make_call1
    S.manager_key
    ctxt
    block
    (Contract.implicit_contract mgr)
    ()
    ()

let delegate ctxt block contract =
  RPC_context.make_call1 S.delegate ctxt block contract () ()

let delegate_opt ctxt block contract =
  RPC_context.make_opt_call1 S.delegate ctxt block contract () ()

let counter ctxt block mgr =
  RPC_context.make_call1
    S.counter
    ctxt
    block
    (Contract.implicit_contract mgr)
    ()
    ()

let script ctxt block contract =
  RPC_context.make_call1 S.script ctxt block contract () ()

let script_opt ctxt block contract =
  RPC_context.make_opt_call1 S.script ctxt block contract () ()

let storage ctxt block contract =
  RPC_context.make_call1 S.storage ctxt block contract () ()

let entrypoint_type ctxt block contract entrypoint =
  RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint () ()

let list_entrypoints ctxt block contract =
  RPC_context.make_call1 S.list_entrypoints ctxt block contract () ()

let storage_opt ctxt block contract =
  RPC_context.make_opt_call1 S.storage ctxt block contract () ()

let big_map_get ctxt block id key =
  RPC_context.make_call2 S.big_map_get ctxt block id key () ()

let contract_big_map_get_opt ctxt block contract key =
  RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key
src/proto_alpha/lib_protocol/contract_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Definition custom_root
  : Tezos_protocol_environment_alpha__Environment.RPC_path.context
    Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
  Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
    (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
      Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
      "context" % string) "contracts" % string.

Definition big_map_root
  : Tezos_protocol_environment_alpha__Environment.RPC_path.context
    Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
  Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
    (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
      Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
      "context" % string) "big_maps" % string.

Record info := {
  balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  delegate : option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash;
  counter : option Tezos_raw_protocol_alpha.Alpha_context.counter;
  script : option Tezos_raw_protocol_alpha.Alpha_context.Script.t }.

Definition info_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {|
            balance := balance;
              delegate := delegate;
              counter := counter;
              script := script
              |} => (balance, delegate, script, counter)
          end)
        (fun function_parameter =>
          match function_parameter with
          | (balance, delegate, script, counter) =>
            {| balance := balance; delegate := delegate; counter := counter;
              script := script |}
          end) in
    fun eta => arg None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "balance" % string Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None None
        "delegate" % string
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None None
        "script" % string Tezos_raw_protocol_alpha.Alpha_context.Script.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None None
        "counter" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.n)).

Module S.
  Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
  
  Definition balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Access the balance of a contract." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
        "balance" % string).
  
  Definition manager_key
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      (option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Access the manager of a contract." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.encoding)
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
        "manager_key" % string).
  
  Definition delegate
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Access the delegate of a contract, if any." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
        "delegate" % string).
  
  Definition counter
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Access the counter of a contract, if any." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_protocol_environment_alpha__Environment.Data_encoding.z
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
        "counter" % string).
  
  Definition script
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Script.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Access the code and data of the contract." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Script.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
        "script" % string).
  
  Definition storage
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Access the data of the contract." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
        "storage" % string).
  
  Definition entrypoint_type
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) * string) unit
      unit Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Return the type of the given entrypoint of the contract" % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
          (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
            custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
          "entrypoints" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_arg.string).
  
  Definition list_entrypoints
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
        (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Return the list of entrypoints of the contract" % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "unreachable" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "path" % string
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                  None
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim_encoding))))
          [])
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "entrypoints" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.assoc
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)))
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
        "entrypoints" % string).
  
  Definition contract_big_map_get_opt
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
      (Some
        "Access the value associated with a key in a big map of the contract (deprecated)."
          % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "key" % string
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "type" % string
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding))
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.option
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg)
        "big_map_get" % string).
  
  Definition big_map_get
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Big_map.id) *
        Tezos_raw_protocol_alpha.Script_expr_hash.t) unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Access the value associated with a key in a big map." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
          big_map_root Tezos_raw_protocol_alpha.Alpha_context.Big_map.rpc_arg)
        Tezos_raw_protocol_alpha.Script_expr_hash.rpc_arg).
  
  Definition info
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit info :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Access the complete status of a contract." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      info_encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
        custom_root Tezos_raw_protocol_alpha.Alpha_context.Contract.rpc_arg).
  
  Definition list
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
      (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "All existing contracts (including non-empty default contracts)." %
          string) Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
        Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding) custom_root.
End S.

Definition register (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    Tezos_raw_protocol_alpha.Services_registration.register0 S.list
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_raw_protocol_alpha.Alpha_context.Contract.list ctxt)
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
              end
          end);
    let register_field {A : Type}
      (s :
      Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
          Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit A)
      (f :
      Tezos_raw_protocol_alpha.Alpha_context.t ->
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              A)) : unit :=
      Tezos_raw_protocol_alpha.Services_registration.register1 s
        (fun ctxt =>
          fun contract =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Contract._exists
                        ctxt contract)
                      (fun function_parameter =>
                        match function_parameter with
                        | true => f ctxt contract
                        | false =>
                          Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                            OCaml.Not_found
                        end)
                  end
              end) in
    let register_opt_field {A : Type}
      (s :
      Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
          Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit A)
      (f :
      Tezos_raw_protocol_alpha.Alpha_context.t ->
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (option A))) : unit :=
      register_field s
        (fun ctxt =>
          fun a1 =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (f ctxt a1)
              (fun function_parameter =>
                match function_parameter with
                | None =>
                  Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                    OCaml.Not_found
                | Some v =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    v
                end)) in
    let do_big_map_get
      (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (id :
      Tezos_raw_protocol_alpha.Alpha_context.Big_map.id) (key :
      Tezos_raw_protocol_alpha.Script_expr_hash.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) :=
      let ctxt := Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited ctxt
        in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Alpha_context.Big_map._exists ctxt id)
        (fun function_parameter =>
          match function_parameter with
          | (ctxt, types) =>
            match types with
            | None =>
              Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                OCaml.Not_found
            | Some (_, value_type) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Script_ir_translator.parse_ty ctxt
                    true false false true
                    (Tezos_protocol_environment_alpha__Environment.Micheline.root
                      value_type)))
                (fun function_parameter =>
                  match function_parameter with
                  | (Ex_ty value_type, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Big_map.get_opt
                        ctxt id key)
                      (fun function_parameter =>
                        match function_parameter with
                        | (_ctxt, value) =>
                          match value with
                          | None =>
                            Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                              OCaml.Not_found
                          | Some value =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Script_ir_translator.parse_data
                                None ctxt true value_type
                                (Tezos_protocol_environment_alpha__Environment.Micheline.root
                                  value))
                              (fun function_parameter =>
                                match function_parameter with
                                | (value, ctxt) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data
                                      ctxt Readable value_type value)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (value, _ctxt) =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                            value)
                                      end)
                                end)
                          end
                        end)
                  end)
            end
          end) in
    register_field S.balance
      Tezos_raw_protocol_alpha.Alpha_context.Contract.get_balance;
    Tezos_raw_protocol_alpha.Services_registration.register1 S.manager_key
      (fun ctxt =>
        fun contract =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  match
                    Tezos_raw_protocol_alpha.Alpha_context.Contract.is_implicit
                      contract with
                  | None =>
                    Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                      OCaml.Not_found
                  | Some mgr =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Contract.is_manager_key_revealed
                        ctxt mgr)
                      (fun function_parameter =>
                        match function_parameter with
                        | false =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                        | true =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_manager_key
                              ctxt mgr)
                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                        end)
                  end
                end
            end);
    register_opt_field S.delegate
      Tezos_raw_protocol_alpha.Alpha_context.Delegate.get;
    Tezos_raw_protocol_alpha.Services_registration.register1 S.counter
      (fun ctxt =>
        fun contract =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  match
                    Tezos_raw_protocol_alpha.Alpha_context.Contract.is_implicit
                      contract with
                  | None =>
                    Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                      OCaml.Not_found
                  | Some mgr =>
                    Tezos_raw_protocol_alpha.Alpha_context.Contract.get_counter
                      ctxt mgr
                  end
                end
            end);
    register_opt_field S.script
      (fun c =>
        fun v =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script c v)
            (fun function_parameter =>
              match function_parameter with
              | (_, v) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  v
              end));
    register_opt_field S.storage
      (fun ctxt =>
        fun contract =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script ctxt
              contract)
            (fun function_parameter =>
              match function_parameter with
              | (ctxt, script) =>
                match script with
                | None =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                | Some script =>
                  let ctxt :=
                    Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                      ctxt in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Script_ir_translator.parse_script
                      None ctxt true script)
                    (fun function_parameter =>
                      match function_parameter with
                      | (Ex_script script, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_script
                            ctxt Readable script)
                          (fun function_parameter =>
                            match function_parameter with
                            | (script, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                  ctxt (storage script))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (storage, _ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                                      storage
                                  end)
                            end)
                      end)
                end
              end));
    Tezos_raw_protocol_alpha.Services_registration.register2 S.entrypoint_type
      (fun ctxt =>
        fun v =>
          fun entrypoint =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script_code
                        ctxt v)
                      (fun function_parameter =>
                        match function_parameter with
                        | (_, expr) =>
                          match expr with
                          | None =>
                            Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                              OCaml.Not_found
                          | Some expr =>
                            let ctxt :=
                              Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                                ctxt in
                            let legacy := true in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                ctxt expr)
                              (fun function_parameter =>
                                match function_parameter with
                                | (expr, _) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                        (Tezos_raw_protocol_alpha.Script_ir_translator.parse_toplevel
                                          legacy expr)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (arg_type, _, _, root_name) =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                              (Tezos_raw_protocol_alpha.Script_ir_translator.parse_ty
                                                ctxt legacy true false true
                                                arg_type)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (Ex_ty arg_type, _) =>
                                                  Tezos_raw_protocol_alpha.Script_ir_translator.find_entrypoint
                                                    arg_type root_name
                                                    entrypoint
                                                end)
                                          end)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | inl (_f, Ex_ty ty) =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_ty
                                            ctxt ty)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (ty_node, _) =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                  ty_node)
                                            end)
                                      | inr _ =>
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                                          OCaml.Not_found
                                      end)
                                end)
                          end
                        end)
                  end
              end);
    Tezos_raw_protocol_alpha.Services_registration.register1 S.list_entrypoints
      (fun ctxt =>
        fun v =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script_code
                      ctxt v)
                    (fun function_parameter =>
                      match function_parameter with
                      | (_, expr) =>
                        match expr with
                        | None =>
                          Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                            OCaml.Not_found
                        | Some expr =>
                          let ctxt :=
                            Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                              ctxt in
                          let legacy := true in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                              ctxt expr)
                            (fun function_parameter =>
                              match function_parameter with
                              | (expr, _) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                      (Tezos_raw_protocol_alpha.Script_ir_translator.parse_toplevel
                                        legacy expr)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (arg_type, _, _, root_name) =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                            (Tezos_raw_protocol_alpha.Script_ir_translator.parse_ty
                                              ctxt legacy true false true
                                              arg_type)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | (Ex_ty arg_type, _) =>
                                                Tezos_raw_protocol_alpha.Script_ir_translator.list_entrypoints
                                                  arg_type ctxt root_name
                                              end)
                                        end)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (unreachable_entrypoint, map) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                        (unreachable_entrypoint,
                                          (Tezos_raw_protocol_alpha.Script_ir_translator.Entrypoints_map.fold
                                            (fun entry =>
                                              fun function_parameter =>
                                                match function_parameter with
                                                | (_, ty) =>
                                                  fun acc =>
                                                    cons
                                                      (entry,
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                          ty)) acc
                                                end) map []))
                                    end)
                              end)
                        end
                      end)
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1
      S.contract_big_map_get_opt
      (fun ctxt =>
        fun contract =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (key, key_type) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script
                      ctxt contract)
                    (fun function_parameter =>
                      match function_parameter with
                      | (ctxt, script) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_protocol_environment_alpha__Environment.Lwt._return
                            (Tezos_raw_protocol_alpha.Script_ir_translator.parse_packable_ty
                              ctxt true
                              (Tezos_protocol_environment_alpha__Environment.Micheline.root
                                key_type)))
                          (fun function_parameter =>
                            match function_parameter with
                            | (Ex_ty key_type, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Script_ir_translator.parse_data
                                  None ctxt true key_type
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.root
                                    key))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (key, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_raw_protocol_alpha.Script_ir_translator.hash_data
                                        ctxt key_type key)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (key, ctxt) =>
                                          match script with
                                          | None =>
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                                              OCaml.Not_found
                                          | Some script =>
                                            let ctxt :=
                                              Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                                                ctxt in
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (Tezos_raw_protocol_alpha.Script_ir_translator.parse_script
                                                None ctxt true script)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (Ex_script script, ctxt) =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_raw_protocol_alpha.Script_ir_translator.collect_big_maps
                                                      ctxt (storage_type script)
                                                      (storage script))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | (ids, _ctxt) =>
                                                        let ids :=
                                                          Tezos_raw_protocol_alpha.Script_ir_translator.list_of_big_map_ids
                                                            ids in
                                                        let fix find
                                                          (function_parameter :
                                                          list
                                                            Tezos_protocol_environment_alpha__Environment.Z.t)
                                                          : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                                              (option
                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
                                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.prim))) :=
                                                          match
                                                            function_parameter
                                                            with
                                                          | [] =>
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                                                          | cons (_ as id) ids
                                                            => try
                                                          end in
                                                        find ids
                                                      end)
                                                end)
                                          end
                                        end)
                                  end)
                            end)
                      end)
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register2 S.big_map_get
      (fun ctxt =>
        fun id =>
          fun key =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                fun function_parameter =>
                  match function_parameter with
                  | tt => do_big_map_get ctxt id key
                  end
              end);
    register_field S.info
      (fun ctxt =>
        fun contract =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_balance ctxt
              contract)
            (fun balance =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.get ctxt
                  contract)
                (fun delegate =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    match
                      Tezos_raw_protocol_alpha.Alpha_context.Contract.is_implicit
                        contract with
                    | Some manager =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_counter
                          ctxt manager)
                        (fun counter =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                            counter)
                    | None =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        None
                    end
                    (fun counter =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script
                          ctxt contract)
                        (fun function_parameter =>
                          match function_parameter with
                          | (ctxt, script) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              match script with
                              | None =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  (None, ctxt)
                              | Some script =>
                                let ctxt :=
                                  Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                                    ctxt in
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_raw_protocol_alpha.Script_ir_translator.parse_script
                                    None ctxt true script)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (Ex_script script, ctxt) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_script
                                          ctxt Readable script)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (script, ctxt) =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                              ((Some script), ctxt)
                                          end)
                                    end)
                              end
                              (fun function_parameter =>
                                match function_parameter with
                                | (script, _ctxt) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                    {| balance := balance; delegate := delegate;
                                      counter := counter; script := script |}
                                end)
                          end)))))
  end.

Definition list {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0 S.list
    ctxt block tt tt.

Definition info {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      info) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1 S.info
    ctxt block contract tt tt.

Definition balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1 S.balance
    ctxt block contract tt tt.

Definition manager_key {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D) (mgr : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.manager_key ctxt block
    (Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract mgr) tt
    tt.

Definition delegate {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.delegate ctxt block contract tt tt.

Definition delegate_opt {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_opt_call1
    S.delegate ctxt block contract tt tt.

Definition counter {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D) (mgr : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1 S.counter
    ctxt block
    (Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract mgr) tt
    tt.

Definition script {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1 S.script
    ctxt block contract tt tt.

Definition script_opt {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.t)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_opt_call1
    S.script ctxt block contract tt tt.

Definition storage {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1 S.storage
    ctxt block contract tt tt.

Definition entrypoint_type {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  (entrypoint : string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call2
    S.entrypoint_type ctxt block contract entrypoint tt tt.

Definition list_entrypoints {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
        (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.list_entrypoints ctxt block contract tt tt.

Definition storage_opt {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_opt_call1
    S.storage ctxt block contract tt tt.

Definition big_map_get {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D) (id : Tezos_raw_protocol_alpha.Alpha_context.Big_map.id)
  (key : Tezos_raw_protocol_alpha.Script_expr_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call2
    S.big_map_get ctxt block id key tt tt.

Definition contract_big_map_get_opt {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  (key :
    Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.contract_big_map_get_opt ctxt block contract tt key.
src/proto_alpha/lib_protocol/contract_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

val list : 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t

type info = {
  balance : Tez.t;
  delegate : public_key_hash option;
  counter : counter option;
  script : Script.t option;
}

val info_encoding : info Data_encoding.t

val info :
  'a #RPC_context.simple -> 'a -> Contract.t -> info shell_tzresult Lwt.t

val balance :
  'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t

val manager_key :
  'a #RPC_context.simple ->
  'a ->
  public_key_hash ->
  public_key option shell_tzresult Lwt.t

val delegate :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  public_key_hash shell_tzresult Lwt.t

val delegate_opt :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  public_key_hash option shell_tzresult Lwt.t

val counter :
  'a #RPC_context.simple ->
  'a ->
  public_key_hash ->
  counter shell_tzresult Lwt.t

val script :
  'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t

val script_opt :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  Script.t option shell_tzresult Lwt.t

val storage :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  Script.expr shell_tzresult Lwt.t

val entrypoint_type :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  string ->
  Script.expr shell_tzresult Lwt.t

val list_entrypoints :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  (Michelson_v1_primitives.prim list list * (string * Script.expr) list)
  shell_tzresult
  Lwt.t

val storage_opt :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  Script.expr option shell_tzresult Lwt.t

val big_map_get :
  'a #RPC_context.simple ->
  'a ->
  Z.t ->
  Script_expr_hash.t ->
  Script.expr shell_tzresult Lwt.t

val contract_big_map_get_opt :
  'a #RPC_context.simple ->
  'a ->
  Contract.t ->
  Script.expr * Script.expr ->
  Script.expr option shell_tzresult Lwt.t

val register : unit -> unit
src/proto_alpha/lib_protocol/contract_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter list : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t)).

Record info := {
  balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  delegate : option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash;
  counter : option Tezos_raw_protocol_alpha.Alpha_context.counter;
  script : option Tezos_raw_protocol_alpha.Alpha_context.Script.t }.

Parameter info_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t info.

Parameter info : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          info).

Parameter balance : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t).

Parameter manager_key : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (option Tezos_raw_protocol_alpha.Alpha_context.public_key)).

Parameter delegate : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.public_key_hash).

Parameter delegate_opt : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)).

Parameter counter : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.counter).

Parameter script : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Script.t).

Parameter script_opt : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (option Tezos_raw_protocol_alpha.Alpha_context.Script.t)).

Parameter storage : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr).

Parameter entrypoint_type : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      string ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr).

Parameter list_entrypoints : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
            (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))).

Parameter storage_opt : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)).

Parameter big_map_get : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_raw_protocol_alpha.Script_expr_hash.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr).

Parameter contract_big_map_get_opt : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)).

Parameter register : unit -> unit.
src/proto_alpha/lib_protocol/contract_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t
  | (* `Temporary *)
      Counter_in_the_past of Contract_repr.contract * Z.t * Z.t
  | (* `Branch *)
      Counter_in_the_future of Contract_repr.contract * Z.t * Z.t
  | (* `Temporary *)
      Unspendable_contract of Contract_repr.contract
  | (* `Permanent *)
      Non_existing_contract of Contract_repr.contract
  | (* `Temporary *)
      Empty_implicit_contract of Signature.Public_key_hash.t
  | (* `Temporary *)
      Empty_transaction of Contract_repr.t (* `Temporary *)
  | Inconsistent_hash of
      Signature.Public_key.t
      * Signature.Public_key_hash.t
      * Signature.Public_key_hash.t
  | (* `Permanent *)
      Inconsistent_public_key of
      Signature.Public_key.t * Signature.Public_key.t
  | (* `Permanent *)
      Failure of string (* `Permanent *)
  | Previously_revealed_key of Contract_repr.t (* `Permanent *)
  | Unrevealed_manager_key of Contract_repr.t

(* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"contract.unspendable_contract"
    ~title:"Unspendable contract"
    ~description:
      "An operation tried to spend tokens from an unspendable contract"
    ~pp:(fun ppf c ->
      Format.fprintf
        ppf
        "The tokens of contract %a can only be spent by its script"
        Contract_repr.pp
        c)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Unspendable_contract c -> Some c | _ -> None)
    (fun c -> Unspendable_contract c) ;
  register_error_kind
    `Temporary
    ~id:"contract.balance_too_low"
    ~title:"Balance too low"
    ~description:
      "An operation tried to spend more tokens than the contract has"
    ~pp:(fun ppf (c, b, a) ->
      Format.fprintf
        ppf
        "Balance of contract %a too low (%a) to spend %a"
        Contract_repr.pp
        c
        Tez_repr.pp
        b
        Tez_repr.pp
        a)
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "balance" Tez_repr.encoding)
        (req "amount" Tez_repr.encoding))
    (function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None)
    (fun (c, b, a) -> Balance_too_low (c, b, a)) ;
  register_error_kind
    `Temporary
    ~id:"contract.counter_in_the_future"
    ~title:"Invalid counter (not yet reached) in a manager operation"
    ~description:"An operation assumed a contract counter in the future"
    ~pp:(fun ppf (contract, exp, found) ->
      Format.fprintf
        ppf
        "Counter %s not yet reached for contract %a (expected %s)"
        (Z.to_string found)
        Contract_repr.pp
        contract
        (Z.to_string exp))
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "expected" z)
        (req "found" z))
    (function Counter_in_the_future (c, x, y) -> Some (c, x, y) | _ -> None)
    (fun (c, x, y) -> Counter_in_the_future (c, x, y)) ;
  register_error_kind
    `Branch
    ~id:"contract.counter_in_the_past"
    ~title:"Invalid counter (already used) in a manager operation"
    ~description:"An operation assumed a contract counter in the past"
    ~pp:(fun ppf (contract, exp, found) ->
      Format.fprintf
        ppf
        "Counter %s already used for contract %a (expected %s)"
        (Z.to_string found)
        Contract_repr.pp
        contract
        (Z.to_string exp))
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "expected" z)
        (req "found" z))
    (function Counter_in_the_past (c, x, y) -> Some (c, x, y) | _ -> None)
    (fun (c, x, y) -> Counter_in_the_past (c, x, y)) ;
  register_error_kind
    `Temporary
    ~id:"contract.non_existing_contract"
    ~title:"Non existing contract"
    ~description:
      "A contract handle is not present in the context (either it never was \
       or it has been destroyed)"
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract %a does not exist" Contract_repr.pp contract)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Non_existing_contract c -> Some c | _ -> None)
    (fun c -> Non_existing_contract c) ;
  register_error_kind
    `Permanent
    ~id:"contract.manager.inconsistent_hash"
    ~title:"Inconsistent public key hash"
    ~description:
      "A revealed manager public key is inconsistent with the announced hash"
    ~pp:(fun ppf (k, eh, ph) ->
      Format.fprintf
        ppf
        "The hash of the manager public key %s is not %a as announced but %a"
        (Signature.Public_key.to_b58check k)
        Signature.Public_key_hash.pp
        ph
        Signature.Public_key_hash.pp
        eh)
    Data_encoding.(
      obj3
        (req "public_key" Signature.Public_key.encoding)
        (req "expected_hash" Signature.Public_key_hash.encoding)
        (req "provided_hash" Signature.Public_key_hash.encoding))
    (function Inconsistent_hash (k, eh, ph) -> Some (k, eh, ph) | _ -> None)
    (fun (k, eh, ph) -> Inconsistent_hash (k, eh, ph)) ;
  register_error_kind
    `Permanent
    ~id:"contract.manager.inconsistent_public_key"
    ~title:"Inconsistent public key"
    ~description:
      "A provided manager public key is different with the public key stored \
       in the contract"
    ~pp:(fun ppf (eh, ph) ->
      Format.fprintf
        ppf
        "Expected manager public key %s but %s was provided"
        (Signature.Public_key.to_b58check ph)
        (Signature.Public_key.to_b58check eh))
    Data_encoding.(
      obj2
        (req "public_key" Signature.Public_key.encoding)
        (req "expected_public_key" Signature.Public_key.encoding))
    (function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None)
    (fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ;
  register_error_kind
    `Permanent
    ~id:"contract.failure"
    ~title:"Contract storage failure"
    ~description:"Unexpected contract storage error"
    ~pp:(fun ppf s -> Format.fprintf ppf "Contract_storage.Failure %S" s)
    Data_encoding.(obj1 (req "message" string))
    (function Failure s -> Some s | _ -> None)
    (fun s -> Failure s) ;
  register_error_kind
    `Branch
    ~id:"contract.unrevealed_key"
    ~title:"Manager operation precedes key revelation"
    ~description:
      "One tried to apply a manager operation without revealing the manager \
       public key"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Unrevealed manager key for contract %a."
        Contract_repr.pp
        s)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Unrevealed_manager_key s -> Some s | _ -> None)
    (fun s -> Unrevealed_manager_key s) ;
  register_error_kind
    `Branch
    ~id:"contract.previously_revealed_key"
    ~title:"Manager operation already revealed"
    ~description:"One tried to revealed twice a manager public key"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Previously revealed manager key for contract %a."
        Contract_repr.pp
        s)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Previously_revealed_key s -> Some s | _ -> None)
    (fun s -> Previously_revealed_key s) ;
  register_error_kind
    `Branch
    ~id:"implicit.empty_implicit_contract"
    ~title:"Empty implicit contract"
    ~description:
      "No manager operations are allowed on an empty implicit contract."
    ~pp:(fun ppf implicit ->
      Format.fprintf
        ppf
        "Empty implicit contract (%a)"
        Signature.Public_key_hash.pp
        implicit)
    Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding))
    (function Empty_implicit_contract c -> Some c | _ -> None)
    (fun c -> Empty_implicit_contract c) ;
  register_error_kind
    `Branch
    ~id:"contract.empty_transaction"
    ~title:"Empty transaction"
    ~description:"Forbidden to credit 0ꜩ to a contract without code."
    ~pp:(fun ppf contract ->
      Format.fprintf
        ppf
        "Transaction of 0ꜩ towards a contract without code are forbidden \
         (%a)."
        Contract_repr.pp
        contract)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Empty_transaction c -> Some c | _ -> None)
    (fun c -> Empty_transaction c)

let failwith msg = fail (Failure msg)

type big_map_diff_item =
  | Update of {
      big_map : Z.t;
      diff_key : Script_repr.expr;
      diff_key_hash : Script_expr_hash.t;
      diff_value : Script_repr.expr option;
    }
  | Clear of Z.t
  | Copy of Z.t * Z.t
  | Alloc of {
      big_map : Z.t;
      key_type : Script_repr.expr;
      value_type : Script_repr.expr;
    }

type big_map_diff = big_map_diff_item list

let big_map_diff_item_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"update"
        (obj5
           (req "action" (constant "update"))
           (req "big_map" z)
           (req "key_hash" Script_expr_hash.encoding)
           (req "key" Script_repr.expr_encoding)
           (opt "value" Script_repr.expr_encoding))
        (function
          | Update {big_map; diff_key_hash; diff_key; diff_value} ->
              Some ((), big_map, diff_key_hash, diff_key, diff_value)
          | _ ->
              None)
        (fun ((), big_map, diff_key_hash, diff_key, diff_value) ->
          Update {big_map; diff_key_hash; diff_key; diff_value});
      case
        (Tag 1)
        ~title:"remove"
        (obj2 (req "action" (constant "remove")) (req "big_map" z))
        (function Clear big_map -> Some ((), big_map) | _ -> None)
        (fun ((), big_map) -> Clear big_map);
      case
        (Tag 2)
        ~title:"copy"
        (obj3
           (req "action" (constant "copy"))
           (req "source_big_map" z)
           (req "destination_big_map" z))
        (function Copy (src, dst) -> Some ((), src, dst) | _ -> None)
        (fun ((), src, dst) -> Copy (src, dst));
      case
        (Tag 3)
        ~title:"alloc"
        (obj4
           (req "action" (constant "alloc"))
           (req "big_map" z)
           (req "key_type" Script_repr.expr_encoding)
           (req "value_type" Script_repr.expr_encoding))
        (function
          | Alloc {big_map; key_type; value_type} ->
              Some ((), big_map, key_type, value_type)
          | _ ->
              None)
        (fun ((), big_map, key_type, value_type) ->
          Alloc {big_map; key_type; value_type}) ]

let big_map_diff_encoding =
  let open Data_encoding in
  def "contract.big_map_diff" @@ list big_map_diff_item_encoding

let big_map_key_cost = 65

let big_map_cost = 33

let update_script_big_map c = function
  | None ->
      return (c, Z.zero)
  | Some diff ->
      fold_left_s
        (fun (c, total) -> function Clear id ->
              Storage.Big_map.Total_bytes.get c id
              >>=? fun size ->
              Storage.Big_map.remove_rec c id
              >>= fun c ->
              if Compare.Z.(id < Z.zero) then return (c, total)
              else return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost))
          | Copy (from, to_) ->
              Storage.Big_map.copy c ~from ~to_
              >>=? fun c ->
              if Compare.Z.(to_ < Z.zero) then return (c, total)
              else
                Storage.Big_map.Total_bytes.get c from
                >>=? fun size ->
                return (c, Z.add (Z.add total size) (Z.of_int big_map_cost))
          | Alloc {big_map; key_type; value_type} ->
              Storage.Big_map.Total_bytes.init c big_map Z.zero
              >>=? fun c ->
              (* Annotations are erased to allow sharing on
                 [Copy]. The types from the contract code are used,
                 these ones are only used to make sure they are
                 compatible during transmissions between contracts,
                 and only need to be compatible, annotations
                 nonwhistanding. *)
              let key_type =
                Micheline.strip_locations
                  (Script_repr.strip_annotations (Micheline.root key_type))
              in
              let value_type =
                Micheline.strip_locations
                  (Script_repr.strip_annotations (Micheline.root value_type))
              in
              Storage.Big_map.Key_type.init c big_map key_type
              >>=? fun c ->
              Storage.Big_map.Value_type.init c big_map value_type
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.add total (Z.of_int big_map_cost))
          | Update {big_map; diff_key_hash; diff_value = None} ->
              Storage.Big_map.Contents.remove (c, big_map) diff_key_hash
              >>=? fun (c, freed, existed) ->
              let freed =
                if existed then freed + big_map_key_cost else freed
              in
              Storage.Big_map.Total_bytes.get c big_map
              >>=? fun size ->
              Storage.Big_map.Total_bytes.set
                c
                big_map
                (Z.sub size (Z.of_int freed))
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.sub total (Z.of_int freed))
          | Update {big_map; diff_key_hash; diff_value = Some v} ->
              Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v
              >>=? fun (c, size_diff, existed) ->
              let size_diff =
                if existed then size_diff else size_diff + big_map_key_cost
              in
              Storage.Big_map.Total_bytes.get c big_map
              >>=? fun size ->
              Storage.Big_map.Total_bytes.set
                c
                big_map
                (Z.add size (Z.of_int size_diff))
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.add total (Z.of_int size_diff)))
        (c, Z.zero)
        diff

let create_base c ?(prepaid_bootstrap_storage = false)
    (* Free space for bootstrap contracts *)
    contract ~balance ~manager ~delegate ?script () =
  ( match Contract_repr.is_implicit contract with
  | None ->
      return c
  | Some _ ->
      Storage.Contract.Global_counter.get c
      >>=? fun counter -> Storage.Contract.Counter.init c contract counter )
  >>=? fun c ->
  Storage.Contract.Balance.init c contract balance
  >>=? fun c ->
  ( match manager with
  | Some manager ->
      Storage.Contract.Manager.init c contract (Manager_repr.Hash manager)
  | None ->
      return c )
  >>=? fun c ->
  ( match delegate with
  | None ->
      return c
  | Some delegate ->
      Delegate_storage.init c contract delegate )
  >>=? fun c ->
  match script with
  | Some ({Script_repr.code; storage}, big_map_diff) ->
      Storage.Contract.Code.init c contract code
      >>=? fun (c, code_size) ->
      Storage.Contract.Storage.init c contract storage
      >>=? fun (c, storage_size) ->
      update_script_big_map c big_map_diff
      >>=? fun (c, big_map_size) ->
      let total_size =
        Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size
      in
      assert (Compare.Z.(total_size >= Z.zero)) ;
      let prepaid_bootstrap_storage =
        if prepaid_bootstrap_storage then total_size else Z.zero
      in
      Storage.Contract.Paid_storage_space.init
        c
        contract
        prepaid_bootstrap_storage
      >>=? fun c ->
      Storage.Contract.Used_storage_space.init c contract total_size
  | None ->
      return c

let originate c ?prepaid_bootstrap_storage contract ~balance ~script ~delegate
    =
  create_base
    c
    ?prepaid_bootstrap_storage
    contract
    ~balance
    ~manager:None
    ~delegate
    ~script
    ()

let create_implicit c manager ~balance =
  create_base
    c
    (Contract_repr.implicit_contract manager)
    ~balance
    ~manager:(Some manager)
    ?script:None
    ~delegate:None
    ()

let delete c contract =
  match Contract_repr.is_implicit contract with
  | None ->
      (* For non implicit contract Big_map should be cleared *)
      failwith "Non implicit contracts cannot be removed"
  | Some _ ->
      Delegate_storage.remove c contract
      >>=? fun c ->
      Storage.Contract.Balance.delete c contract
      >>=? fun c ->
      Storage.Contract.Manager.delete c contract
      >>=? fun c ->
      Storage.Contract.Counter.delete c contract
      >>=? fun c ->
      Storage.Contract.Code.remove c contract
      >>=? fun (c, _, _) ->
      Storage.Contract.Storage.remove c contract
      >>=? fun (c, _, _) ->
      Storage.Contract.Paid_storage_space.remove c contract
      >>= fun c ->
      Storage.Contract.Used_storage_space.remove c contract
      >>= fun c -> return c

let allocated c contract =
  Storage.Contract.Balance.get_option c contract
  >>=? function None -> return_false | Some _ -> return_true

let exists c contract =
  match Contract_repr.is_implicit contract with
  | Some _ ->
      return_true
  | None ->
      allocated c contract

let must_exist c contract =
  exists c contract
  >>=? function
  | true -> return_unit | false -> fail (Non_existing_contract contract)

let must_be_allocated c contract =
  allocated c contract
  >>=? function
  | true ->
      return_unit
  | false -> (
    match Contract_repr.is_implicit contract with
    | Some pkh ->
        fail (Empty_implicit_contract pkh)
    | None ->
        fail (Non_existing_contract contract) )

let list c = Storage.Contract.list c

let fresh_contract_from_current_nonce c =
  Lwt.return (Raw_context.increment_origination_nonce c)
  >>=? fun (c, nonce) -> return (c, Contract_repr.originated_contract nonce)

let originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until =
  Lwt.return (Raw_context.origination_nonce ctxt_since)
  >>=? fun since ->
  Lwt.return (Raw_context.origination_nonce ctxt_until)
  >>=? fun until ->
  filter_map_s
    (fun contract ->
      exists ctxt_until contract
      >>=? function true -> return_some contract | false -> return_none)
    (Contract_repr.originated_contracts ~since ~until)

let check_counter_increment c manager counter =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Counter.get c contract
  >>=? fun contract_counter ->
  let expected = Z.succ contract_counter in
  if Compare.Z.(expected = counter) then return_unit
  else if Compare.Z.(expected > counter) then
    fail (Counter_in_the_past (contract, expected, counter))
  else fail (Counter_in_the_future (contract, expected, counter))

let increment_counter c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Global_counter.get c
  >>=? fun global_counter ->
  Storage.Contract.Global_counter.set c (Z.succ global_counter)
  >>=? fun c ->
  Storage.Contract.Counter.get c contract
  >>=? fun contract_counter ->
  Storage.Contract.Counter.set c contract (Z.succ contract_counter)

let get_script_code c contract = Storage.Contract.Code.get_option c contract

let get_script c contract =
  Storage.Contract.Code.get_option c contract
  >>=? fun (c, code) ->
  Storage.Contract.Storage.get_option c contract
  >>=? fun (c, storage) ->
  match (code, storage) with
  | (None, None) ->
      return (c, None)
  | (Some code, Some storage) ->
      return (c, Some {Script_repr.code; storage})
  | (None, Some _) | (Some _, None) ->
      failwith "get_script"

let get_storage ctxt contract =
  Storage.Contract.Storage.get_option ctxt contract
  >>=? function
  | (ctxt, None) ->
      return (ctxt, None)
  | (ctxt, Some storage) ->
      Lwt.return (Script_repr.force_decode storage)
      >>=? fun (storage, cost) ->
      Lwt.return (Raw_context.consume_gas ctxt cost)
      >>=? fun ctxt -> return (ctxt, Some storage)

let get_counter c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Counter.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | Some _ ->
        Storage.Contract.Global_counter.get c
    | None ->
        failwith "get_counter" )
  | Some v ->
      return v

let get_manager_key c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get_option c contract
  >>=? function
  | None ->
      failwith "get_manager_key"
  | Some (Manager_repr.Hash _) ->
      fail (Unrevealed_manager_key contract)
  | Some (Manager_repr.Public_key v) ->
      return v

let is_manager_key_revealed c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get_option c contract
  >>=? function
  | None ->
      return_false
  | Some (Manager_repr.Hash _) ->
      return_false
  | Some (Manager_repr.Public_key _) ->
      return_true

let reveal_manager_key c manager public_key =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get c contract
  >>=? function
  | Public_key _ ->
      fail (Previously_revealed_key contract)
  | Hash v ->
      let actual_hash = Signature.Public_key.hash public_key in
      if Signature.Public_key_hash.equal actual_hash v then
        let v = Manager_repr.Public_key public_key in
        Storage.Contract.Manager.set c contract v >>=? fun c -> return c
      else fail (Inconsistent_hash (public_key, v, actual_hash))

let get_balance c contract =
  Storage.Contract.Balance.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | Some _ ->
        return Tez_repr.zero
    | None ->
        failwith "get_balance" )
  | Some v ->
      return v

let update_script_storage c contract storage big_map_diff =
  let storage = Script_repr.lazy_expr storage in
  update_script_big_map c big_map_diff
  >>=? fun (c, big_map_size_diff) ->
  Storage.Contract.Storage.set c contract storage
  >>=? fun (c, size_diff) ->
  Storage.Contract.Used_storage_space.get c contract
  >>=? fun previous_size ->
  let new_size =
    Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff))
  in
  Storage.Contract.Used_storage_space.set c contract new_size

let spend c contract amount =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  match Tez_repr.(balance -? amount) with
  | Error _ ->
      fail (Balance_too_low (contract, balance, amount))
  | Ok new_balance -> (
      Storage.Contract.Balance.set c contract new_balance
      >>=? fun c ->
      Roll_storage.Contract.remove_amount c contract amount
      >>=? fun c ->
      if Tez_repr.(new_balance > Tez_repr.zero) then return c
      else
        match Contract_repr.is_implicit contract with
        | None ->
            return c (* Never delete originated contracts *)
        | Some pkh -> (
            Delegate_storage.get c contract
            >>=? function
            | Some pkh' ->
                (* Don't delete "delegate" contract *)
                assert (Signature.Public_key_hash.equal pkh pkh') ;
                return c
            | None ->
                (* Delete empty implicit contract *)
                delete c contract ) )

let credit c contract amount =
  ( if Tez_repr.(amount <> Tez_repr.zero) then return c
  else
    Storage.Contract.Code.mem c contract
    >>=? fun (c, target_has_code) ->
    fail_unless target_has_code (Empty_transaction contract)
    >>=? fun () -> return c )
  >>=? fun c ->
  Storage.Contract.Balance.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | None ->
        fail (Non_existing_contract contract)
    | Some manager ->
        create_implicit c manager ~balance:amount )
  | Some balance ->
      Lwt.return Tez_repr.(amount +? balance)
      >>=? fun balance ->
      Storage.Contract.Balance.set c contract balance
      >>=? fun c -> Roll_storage.Contract.add_amount c contract amount

let init c = Storage.Contract.Global_counter.init c Z.zero

let used_storage_space c contract =
  Storage.Contract.Used_storage_space.get_option c contract
  >>=? function None -> return Z.zero | Some fees -> return fees

let paid_storage_space c contract =
  Storage.Contract.Paid_storage_space.get_option c contract
  >>=? function None -> return Z.zero | Some paid_space -> return paid_space

let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space
    =
  Storage.Contract.Paid_storage_space.get c contract
  >>=? fun already_paid_space ->
  if Compare.Z.(already_paid_space >= new_storage_space) then return (Z.zero, c)
  else
    let to_pay = Z.sub new_storage_space already_paid_space in
    Storage.Contract.Paid_storage_space.set c contract new_storage_space
    >>=? fun c -> return (to_pay, c)
src/proto_alpha/lib_protocol/contract_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition failwith {A : Type} (msg : string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
    (OCaml.Failure msg).

Inductive big_map_diff_item : Type :=
| Update : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_raw_protocol_alpha.Script_repr.expr ->
  Tezos_raw_protocol_alpha.Script_expr_hash.t ->
  (option Tezos_raw_protocol_alpha.Script_repr.expr) -> big_map_diff_item
| Clear : Tezos_protocol_environment_alpha__Environment.Z.t -> big_map_diff_item
| Copy : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t -> big_map_diff_item
| Alloc : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_raw_protocol_alpha.Script_repr.expr ->
  Tezos_raw_protocol_alpha.Script_repr.expr -> big_map_diff_item.

Definition big_map_diff := list big_map_diff_item.

Definition big_map_diff_item_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    big_map_diff_item :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
    (cons
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        "update" % string None (Tag 0)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj5
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "action" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
              "update" % string))
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "big_map" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "key_hash" % string
            Tezos_raw_protocol_alpha.Script_expr_hash.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "key" % string
            Tezos_raw_protocol_alpha.Script_repr.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
            None "value" % string
            Tezos_raw_protocol_alpha.Script_repr.expr_encoding))
        (fun function_parameter =>
          match function_parameter with
          |
            Update {|
              big_map := big_map;
                diff_key := diff_key;
                diff_key_hash := diff_key_hash;
                diff_value := diff_value
                |} => Some (tt, big_map, diff_key_hash, diff_key, diff_value)
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | (tt, big_map, diff_key_hash, diff_key, diff_value) =>
            Update
              {| big_map := big_map; diff_key := diff_key;
                diff_key_hash := diff_key_hash; diff_value := diff_value |}
          end))
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "remove" % string None (Tag 1)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "action" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                "remove" % string))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "big_map" % string
              Tezos_protocol_environment_alpha__Environment.Data_encoding.z))
          (fun function_parameter =>
            match function_parameter with
            | Clear big_map => Some (tt, big_map)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (tt, big_map) => Clear big_map
            end))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "copy" % string None (Tag 2)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "action" % string
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                  "copy" % string))
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "source_big_map" % string
                Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "destination_big_map" % string
                Tezos_protocol_environment_alpha__Environment.Data_encoding.z))
            (fun function_parameter =>
              match function_parameter with
              | Copy src dst => Some (tt, src, dst)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tt, src, dst) => Copy src dst
              end))
          (cons
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
              "alloc" % string None (Tag 3)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "action" % string
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                    "alloc" % string))
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "big_map" % string
                  Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "key_type" % string
                  Tezos_raw_protocol_alpha.Script_repr.expr_encoding)
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "value_type" % string
                  Tezos_raw_protocol_alpha.Script_repr.expr_encoding))
              (fun function_parameter =>
                match function_parameter with
                |
                  Alloc {|
                    big_map := big_map;
                      key_type := key_type;
                      value_type := value_type
                      |} => Some (tt, big_map, key_type, value_type)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (tt, big_map, key_type, value_type) =>
                  Alloc
                    {| big_map := big_map; key_type := key_type;
                      value_type := value_type |}
                end)) [])))).

Definition big_map_diff_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list big_map_diff_item) :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "contract.big_map_diff" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
      big_map_diff_item_encoding).

Definition big_map_key_cost : Z := 65.

Definition big_map_cost : Z := 33.

Definition update_script_big_map
  (c : Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context)
  (function_parameter : option (list big_map_diff_item))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context *
        Tezos_protocol_environment_alpha__Environment.Z.t)) :=
  match function_parameter with
  | None =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (c, Tezos_protocol_environment_alpha__Environment.Z.zero)
  | Some diff =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
      (fun function_parameter =>
        match function_parameter with
        | (c, total) =>
          fun function_parameter =>
            match function_parameter with
            | Clear id =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.get c id)
                (fun size =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (Tezos_raw_protocol_alpha.Storage.Big_map.remove_rec c id)
                    (fun c =>
                      if
                        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                          id
                          Tezos_protocol_environment_alpha__Environment.Z.zero
                        then
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (c, total)
                      else
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (c,
                            (Tezos_protocol_environment_alpha__Environment.Z.sub
                              (Tezos_protocol_environment_alpha__Environment.Z.sub
                                total size)
                              (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                big_map_cost)))))
            | Copy from to_ =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Big_map.copy c from to_)
                (fun c =>
                  if
                    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                      to_ Tezos_protocol_environment_alpha__Environment.Z.zero
                    then
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (c, total)
                  else
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.get
                        c from)
                      (fun size =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (c,
                            (Tezos_protocol_environment_alpha__Environment.Z.add
                              (Tezos_protocol_environment_alpha__Environment.Z.add
                                total size)
                              (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                big_map_cost)))))
            |
              Alloc {|
                big_map := big_map;
                  key_type := key_type;
                  value_type := value_type
                  |} =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.init c
                  big_map Tezos_protocol_environment_alpha__Environment.Z.zero)
                (fun c =>
                  let key_type :=
                    Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                      (Tezos_raw_protocol_alpha.Script_repr.strip_annotations
                        (Tezos_protocol_environment_alpha__Environment.Micheline.root
                          key_type)) in
                  let value_type :=
                    Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                      (Tezos_raw_protocol_alpha.Script_repr.strip_annotations
                        (Tezos_protocol_environment_alpha__Environment.Micheline.root
                          value_type)) in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Storage.Big_map.Key_type.init c
                      big_map key_type)
                    (fun c =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Storage.Big_map.Value_type.init
                          c big_map value_type)
                        (fun c =>
                          if
                            Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                              big_map
                              Tezos_protocol_environment_alpha__Environment.Z.zero
                            then
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              (c, total)
                          else
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              (c,
                                (Tezos_protocol_environment_alpha__Environment.Z.add
                                  total
                                  (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                    big_map_cost))))))
            |
              Update {|
                big_map := big_map;
                  diff_key_hash := diff_key_hash;
                  diff_value := None
                  |} =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Big_map.Contents.remove
                  (c, big_map) diff_key_hash)
                (fun function_parameter =>
                  match function_parameter with
                  | (c, freed, existed) =>
                    let freed :=
                      if existed then
                        Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                          freed big_map_key_cost
                      else
                        freed in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.get
                        c big_map)
                      (fun size =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.set
                            c big_map
                            (Tezos_protocol_environment_alpha__Environment.Z.sub
                              size
                              (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                freed)))
                          (fun c =>
                            if
                              Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                                big_map
                                Tezos_protocol_environment_alpha__Environment.Z.zero
                              then
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (c, total)
                            else
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (c,
                                  (Tezos_protocol_environment_alpha__Environment.Z.sub
                                    total
                                    (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                      freed)))))
                  end)
            |
              Update {|
                big_map := big_map;
                  diff_key_hash := diff_key_hash;
                  diff_value := Some v
                  |} =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Big_map.Contents.init_set
                  (c, big_map) diff_key_hash v)
                (fun function_parameter =>
                  match function_parameter with
                  | (c, size_diff, existed) =>
                    let size_diff :=
                      if existed then
                        size_diff
                      else
                        Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                          size_diff big_map_key_cost in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.get
                        c big_map)
                      (fun size =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.set
                            c big_map
                            (Tezos_protocol_environment_alpha__Environment.Z.add
                              size
                              (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                size_diff)))
                          (fun c =>
                            if
                              Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                                big_map
                                Tezos_protocol_environment_alpha__Environment.Z.zero
                              then
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (c, total)
                            else
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (c,
                                  (Tezos_protocol_environment_alpha__Environment.Z.add
                                    total
                                    (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                      size_diff)))))
                  end)
            end
        end) (c, Tezos_protocol_environment_alpha__Environment.Z.zero) diff
  end.

Definition create_base
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (op_star_o_p_t_star : option bool)
  : Tezos_raw_protocol_alpha.Contract_repr.contract ->
    Tezos_raw_protocol_alpha.Storage.Contract.Balance.value ->
      (option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
        ->
        (option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
          ->
          (option
            (Tezos_raw_protocol_alpha.Script_repr.t *
              (option (list big_map_diff_item)))) ->
            unit ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  Tezos_raw_protocol_alpha.Raw_context.t) :=
  let prepaid_bootstrap_storage :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun contract =>
    fun balance =>
      fun manager =>
        fun delegate =>
          fun script =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  match
                    Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract
                    with
                  | None =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      c
                  | Some _ =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Storage.Contract.Global_counter.get
                        c)
                      (fun counter =>
                        Tezos_raw_protocol_alpha.Storage.Contract.Counter.init c
                          contract counter)
                  end
                  (fun c =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Storage.Contract.Balance.init c
                        contract balance)
                      (fun c =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          match manager with
                          | Some manager =>
                            Tezos_raw_protocol_alpha.Storage.Contract.Manager.init
                              c contract (Manager_repr.Hash manager)
                          | None =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              c
                          end
                          (fun c =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              match delegate with
                              | None =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  c
                              | Some delegate =>
                                Tezos_raw_protocol_alpha.Delegate_storage.init c
                                  contract delegate
                              end
                              (fun c =>
                                match script with
                                |
                                  Some
                                    ({|
                                      Script_repr.code := code;
                                        Script_repr.storage := storage
                                        |}, big_map_diff) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Storage.Contract.Code.init
                                      c contract code)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (c, code_size) =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Storage.Contract.Storage.init
                                            c contract storage)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (c, storage_size) =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (update_script_big_map c
                                                  big_map_diff)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (c, big_map_size) =>
                                                    let total_size :=
                                                      Tezos_protocol_environment_alpha__Environment.Z.add
                                                        (Tezos_protocol_environment_alpha__Environment.Z.add
                                                          (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                                            code_size)
                                                          (Tezos_protocol_environment_alpha__Environment.Z.of_int
                                                            storage_size))
                                                        big_map_size in
                                                    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                                                      total_size
                                                      Tezos_protocol_environment_alpha__Environment.Z.zero;
                                                    let
                                                      prepaid_bootstrap_storage :=
                                                      if
                                                        prepaid_bootstrap_storage
                                                        then
                                                        total_size
                                                      else
                                                        Tezos_protocol_environment_alpha__Environment.Z.zero
                                                      in
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.init
                                                        c contract
                                                        prepaid_bootstrap_storage)
                                                      (fun c =>
                                                        Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.init
                                                          c contract total_size)
                                                  end)
                                            end)
                                      end)
                                | None =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                    c
                                end))))
              end.

Definition originate
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (prepaid_bootstrap_storage : option bool)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
  (balance : Tezos_raw_protocol_alpha.Storage.Contract.Balance.value)
  (script :
    Tezos_raw_protocol_alpha.Script_repr.t * (option (list big_map_diff_item)))
  (delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  create_base c prepaid_bootstrap_storage contract balance None delegate
    (Some script) tt.

Definition create_implicit
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (balance : Tezos_raw_protocol_alpha.Storage.Contract.Balance.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  create_base c None
    (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract manager) balance
    (Some manager) None None tt.

Definition delete
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract with
  | None => failwith "Non implicit contracts cannot be removed" % string
  | Some _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Delegate_storage.remove c contract)
      (fun c =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Contract.Balance.delete c contract)
          (fun c =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Storage.Contract.Manager.delete c
                contract)
              (fun c =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Contract.Counter.delete c
                    contract)
                  (fun c =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Storage.Contract.Code.remove c
                        contract)
                      (fun function_parameter =>
                        match function_parameter with
                        | (c, _, _) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Storage.Contract.Storage.remove
                              c contract)
                            (fun function_parameter =>
                              match function_parameter with
                              | (c, _, _) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                  (Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.remove
                                    c contract)
                                  (fun c =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                      (Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.remove
                                        c contract)
                                      (fun c =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                          c))
                              end)
                        end)))))
  end.

Definition allocated
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_false
      | Some _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_true
      end).

Definition _exists
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  match Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract with
  | Some _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_true
  | None => allocated c contract
  end.

Definition must_exist
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (_exists c contract)
    (fun function_parameter =>
      match function_parameter with
      | true =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
      | false =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Non_existing_contract contract)
      end).

Definition must_be_allocated
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (allocated c contract)
    (fun function_parameter =>
      match function_parameter with
      | true =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
      | false =>
        match Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract with
        | Some pkh =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Empty_implicit_contract pkh)
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Non_existing_contract contract)
        end
      end).

Definition list (c : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list Tezos_raw_protocol_alpha.Contract_repr.t) :=
  Tezos_raw_protocol_alpha.Storage.Contract.list c.

Definition fresh_contract_from_current_nonce
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Raw_context.increment_origination_nonce c))
    (fun function_parameter =>
      match function_parameter with
      | (c, nonce) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (c, (Tezos_raw_protocol_alpha.Contract_repr.originated_contract nonce))
      end).

Definition originated_from_current_nonce
  (ctxt_since : Tezos_raw_protocol_alpha.Raw_context.t)
  (ctxt_until : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Raw_context.origination_nonce ctxt_since))
    (fun since =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Raw_context.origination_nonce ctxt_until))
        (fun until =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.filter_map_s
            (fun contract =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (_exists ctxt_until contract)
                (fun function_parameter =>
                  match function_parameter with
                  | true =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                      contract
                  | false =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                  end))
            (Tezos_raw_protocol_alpha.Contract_repr.originated_contracts since
              until))).

Definition check_counter_increment
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Counter.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (counter :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract manager in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Counter.get c contract)
    (fun contract_counter =>
      let expected :=
        Tezos_protocol_environment_alpha__Environment.Z.succ contract_counter in
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          expected counter then
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
      else
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
            expected counter then
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Counter_in_the_past contract expected counter)
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Counter_in_the_future contract expected counter)).

Definition increment_counter
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract manager in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Global_counter.get c)
    (fun global_counter =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Contract.Global_counter.set c
          (Tezos_protocol_environment_alpha__Environment.Z.succ global_counter))
        (fun c =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Contract.Counter.get c contract)
            (fun contract_counter =>
              Tezos_raw_protocol_alpha.Storage.Contract.Counter.set c contract
                (Tezos_protocol_environment_alpha__Environment.Z.succ
                  contract_counter)))).

Definition get_script_code
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (option Tezos_raw_protocol_alpha.Storage.Contract.Code.value))) :=
  Tezos_raw_protocol_alpha.Storage.Contract.Code.get_option c contract.

Definition get_script
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (option Tezos_raw_protocol_alpha.Script_repr.t))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Code.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | (c, code) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Contract.Storage.get_option c
            contract)
          (fun function_parameter =>
            match function_parameter with
            | (c, storage) =>
              match (code, storage) with
              | (None, None) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (c, None)
              | (Some code, Some storage) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (c,
                    (Some
                      {| Script_repr.code := code;
                        Script_repr.storage := storage |}))
              | (None, Some _) | (Some _, None) =>
                failwith "get_script" % string
              end
            end)
      end).

Definition get_storage
  (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Storage.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Storage.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (option Tezos_raw_protocol_alpha.Script_repr.expr))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Storage.get_option ctxt contract)
    (fun function_parameter =>
      match function_parameter with
      | (ctxt, None) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (ctxt, None)
      | (ctxt, Some storage) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Script_repr.force_decode storage))
          (fun function_parameter =>
            match function_parameter with
            | (storage, cost) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Raw_context.consume_gas ctxt cost))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (ctxt, (Some storage)))
            end)
      end).

Definition get_counter
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Counter.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract manager in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Counter.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        match Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract with
        | Some _ =>
          Tezos_raw_protocol_alpha.Storage.Contract.Global_counter.get c
        | None => failwith "get_counter" % string
        end
      | Some v =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return v
      end).

Definition get_manager_key
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract manager in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Manager.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => failwith "get_manager_key" % string
      | Some (Manager_repr.Hash _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Unrevealed_manager_key contract)
      | Some (Manager_repr.Public_key v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return v
      end).

Definition is_manager_key_revealed
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract manager in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Manager.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_false
      | Some (Manager_repr.Hash _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_false
      | Some (Manager_repr.Public_key _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_true
      end).

Definition reveal_manager_key
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (public_key :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract manager in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Manager.get c contract)
    (fun function_parameter =>
      match function_parameter with
      | Public_key _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Previously_revealed_key contract)
      | Hash v =>
        let actual_hash :=
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
            public_key in
        if
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
            actual_hash v then
          let v := Manager_repr.Public_key public_key in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Contract.Manager.set c contract v)
            (fun c =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                c)
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Inconsistent_hash public_key v actual_hash)
      end).

Definition get_balance
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        match Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract with
        | Some _ =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            Tezos_raw_protocol_alpha.Tez_repr.zero
        | None => failwith "get_balance" % string
        end
      | Some v =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return v
      end).

Definition update_script_storage
  (c : Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Storage.key)
  (storage : Tezos_raw_protocol_alpha.Script_repr.expr)
  (big_map_diff : option (list big_map_diff_item))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let storage := Tezos_raw_protocol_alpha.Script_repr.lazy_expr storage in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (update_script_big_map c big_map_diff)
    (fun function_parameter =>
      match function_parameter with
      | (c, big_map_size_diff) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Contract.Storage.set c contract
            storage)
          (fun function_parameter =>
            match function_parameter with
            | (c, size_diff) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.get
                  c contract)
                (fun previous_size =>
                  let new_size :=
                    Tezos_protocol_environment_alpha__Environment.Z.add
                      previous_size
                      (Tezos_protocol_environment_alpha__Environment.Z.add
                        big_map_size_diff
                        (Tezos_protocol_environment_alpha__Environment.Z.of_int
                          size_diff)) in
                  Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.set
                    c contract new_size)
            end)
      end).

Definition spend
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get c contract)
    (fun balance =>
      match Tezos_raw_protocol_alpha.Tez_repr.op_minus_question balance amount
        with
      | inr _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Balance_too_low contract balance amount)
      | inl new_balance =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Contract.Balance.set c contract
            new_balance)
          (fun c =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Roll_storage.Contract.remove_amount c
                contract amount)
              (fun c =>
                if
                  Tezos_raw_protocol_alpha.Tez_repr.op_gt new_balance
                    Tezos_raw_protocol_alpha.Tez_repr.zero then
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    c
                else
                  match
                    Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract
                    with
                  | None =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      c
                  | Some pkh =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Delegate_storage.get c contract)
                      (fun function_parameter =>
                        match function_parameter with
                        | Some pkh' =>
                          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                            pkh pkh';
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            c
                        | None => delete c contract
                        end)
                  end))
      end).

Definition credit
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (if
      Tezos_raw_protocol_alpha.Tez_repr.op_lt_gt amount
        Tezos_raw_protocol_alpha.Tez_repr.zero then
      Tezos_protocol_environment_alpha__Environment.Error_monad._return c
    else
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Contract.Code.mem c contract)
        (fun function_parameter =>
          match function_parameter with
          | (c, target_has_code) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                target_has_code (Empty_transaction contract))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    c
                end)
          end))
    (fun c =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get_option c contract)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            match Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract
              with
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Non_existing_contract contract)
            | Some manager => create_implicit c manager amount
            end
          | Some balance =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question amount
                  balance))
              (fun balance =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Contract.Balance.set c
                    contract balance)
                  (fun c =>
                    Tezos_raw_protocol_alpha.Roll_storage.Contract.add_amount c
                      contract amount))
          end)).

Definition init (c : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Contract.Global_counter.init c
    Tezos_protocol_environment_alpha__Environment.Z.zero.

Definition used_storage_space
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.get_option c
      contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          Tezos_protocol_environment_alpha__Environment.Z.zero
      | Some fees =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return fees
      end).

Definition paid_storage_space
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.get_option c
      contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          Tezos_protocol_environment_alpha__Environment.Z.zero
      | Some paid_space =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          paid_space
      end).

Definition set_paid_storage_space_and_return_fees_to_pay
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.key)
  (new_storage_space :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.get c contract)
    (fun already_paid_space =>
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
          already_paid_space new_storage_space then
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (Tezos_protocol_environment_alpha__Environment.Z.zero, c)
      else
        let to_pay :=
          Tezos_protocol_environment_alpha__Environment.Z.sub new_storage_space
            already_paid_space in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.set c
            contract new_storage_space)
          (fun c =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (to_pay, c))).
src/proto_alpha/lib_protocol/contract_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t
  | (* `Temporary *)
      Counter_in_the_past of Contract_repr.contract * Z.t * Z.t
  | (* `Branch *)
      Counter_in_the_future of Contract_repr.contract * Z.t * Z.t
  | (* `Temporary *)
      Unspendable_contract of Contract_repr.contract
  | (* `Permanent *)
      Non_existing_contract of Contract_repr.contract
  | (* `Temporary *)
      Empty_implicit_contract of Signature.Public_key_hash.t
  | (* `Temporary *)
      Empty_transaction of Contract_repr.t (* `Temporary *)
  | Inconsistent_hash of
      Signature.Public_key.t
      * Signature.Public_key_hash.t
      * Signature.Public_key_hash.t
  | (* `Permanent *)
      Inconsistent_public_key of
      Signature.Public_key.t * Signature.Public_key.t
  | (* `Permanent *)
      Failure of string (* `Permanent *)
  | Previously_revealed_key of Contract_repr.t (* `Permanent *)
  | Unrevealed_manager_key of Contract_repr.t

(* `Permanent *)

val exists : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t

val must_exist : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t

val allocated : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t

val must_be_allocated : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t

val list : Raw_context.t -> Contract_repr.t list Lwt.t

val check_counter_increment :
  Raw_context.t -> Signature.Public_key_hash.t -> Z.t -> unit tzresult Lwt.t

val increment_counter :
  Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t

val get_manager_key :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Signature.Public_key.t tzresult Lwt.t

val is_manager_key_revealed :
  Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

val reveal_manager_key :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Signature.Public_key.t ->
  Raw_context.t tzresult Lwt.t

val get_balance : Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t

val get_counter :
  Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t

val get_script_code :
  Raw_context.t ->
  Contract_repr.t ->
  (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t

val get_script :
  Raw_context.t ->
  Contract_repr.t ->
  (Raw_context.t * Script_repr.t option) tzresult Lwt.t

val get_storage :
  Raw_context.t ->
  Contract_repr.t ->
  (Raw_context.t * Script_repr.expr option) tzresult Lwt.t

type big_map_diff_item =
  | Update of {
      big_map : Z.t;
      diff_key : Script_repr.expr;
      diff_key_hash : Script_expr_hash.t;
      diff_value : Script_repr.expr option;
    }
  | Clear of Z.t
  | Copy of Z.t * Z.t
  | Alloc of {
      big_map : Z.t;
      key_type : Script_repr.expr;
      value_type : Script_repr.expr;
    }

type big_map_diff = big_map_diff_item list

val big_map_diff_encoding : big_map_diff Data_encoding.t

val update_script_storage :
  Raw_context.t ->
  Contract_repr.t ->
  Script_repr.expr ->
  big_map_diff option ->
  Raw_context.t tzresult Lwt.t

val credit :
  Raw_context.t ->
  Contract_repr.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

val spend :
  Raw_context.t ->
  Contract_repr.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

val originate :
  Raw_context.t ->
  ?prepaid_bootstrap_storage:bool ->
  Contract_repr.t ->
  balance:Tez_repr.t ->
  script:Script_repr.t * big_map_diff option ->
  delegate:Signature.Public_key_hash.t option ->
  Raw_context.t tzresult Lwt.t

val fresh_contract_from_current_nonce :
  Raw_context.t -> (Raw_context.t * Contract_repr.t) tzresult Lwt.t

val originated_from_current_nonce :
  since:Raw_context.t ->
  until:Raw_context.t ->
  Contract_repr.t list tzresult Lwt.t

val init : Raw_context.t -> Raw_context.t tzresult Lwt.t

val used_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t

val paid_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t

val set_paid_storage_space_and_return_fees_to_pay :
  Raw_context.t ->
  Contract_repr.t ->
  Z.t ->
  (Z.t * Raw_context.t) tzresult Lwt.t
src/proto_alpha/lib_protocol/contract_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

Parameter _exists :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).

Parameter must_exist :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).

Parameter allocated :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).

Parameter must_be_allocated :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).

Parameter list :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list Tezos_raw_protocol_alpha.Contract_repr.t).

Parameter check_counter_increment :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).

Parameter increment_counter :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter get_manager_key :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t).

Parameter is_manager_key_revealed :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).

Parameter reveal_manager_key :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter get_balance :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Tez_repr.t).

Parameter get_counter :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_protocol_environment_alpha__Environment.Z.t).

Parameter get_script_code :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t *
          (option Tezos_raw_protocol_alpha.Script_repr.lazy_expr))).

Parameter get_script :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t *
          (option Tezos_raw_protocol_alpha.Script_repr.t))).

Parameter get_storage :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t *
          (option Tezos_raw_protocol_alpha.Script_repr.expr))).

Inductive big_map_diff_item : Type :=
| Update : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_raw_protocol_alpha.Script_repr.expr ->
  Tezos_raw_protocol_alpha.Script_expr_hash.t ->
  (option Tezos_raw_protocol_alpha.Script_repr.expr) -> big_map_diff_item
| Clear : Tezos_protocol_environment_alpha__Environment.Z.t -> big_map_diff_item
| Copy : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t -> big_map_diff_item
| Alloc : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_raw_protocol_alpha.Script_repr.expr ->
  Tezos_raw_protocol_alpha.Script_repr.expr -> big_map_diff_item.

Definition big_map_diff := list big_map_diff_item.

Parameter big_map_diff_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t big_map_diff.

Parameter update_script_storage :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_raw_protocol_alpha.Script_repr.expr ->
      (option big_map_diff) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).

Parameter credit :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter spend :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter originate :
Tezos_raw_protocol_alpha.Raw_context.t ->
  (option bool) ->
    Tezos_raw_protocol_alpha.Contract_repr.t ->
      Tezos_raw_protocol_alpha.Tez_repr.t ->
        (Tezos_raw_protocol_alpha.Script_repr.t * (option big_map_diff)) ->
          (option
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
            ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                Tezos_raw_protocol_alpha.Raw_context.t).

Parameter fresh_contract_from_current_nonce :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        Tezos_raw_protocol_alpha.Contract_repr.t)).

Parameter originated_from_current_nonce :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list Tezos_raw_protocol_alpha.Contract_repr.t)).

Parameter init :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).

Parameter used_storage_space :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_protocol_environment_alpha__Environment.Z.t).

Parameter paid_storage_space :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_protocol_environment_alpha__Environment.Z.t).

Parameter set_paid_storage_space_and_return_fees_to_pay :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_protocol_environment_alpha__Environment.Z.t *
            Tezos_raw_protocol_alpha.Raw_context.t)).
src/proto_alpha/lib_protocol/cycle_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type cycle = t

let encoding = Data_encoding.int32

let rpc_arg =
  let construct = Int32.to_string in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse cycle"
    | cycle ->
        Ok cycle
  in
  RPC_arg.make
    ~descr:"A cycle integer"
    ~name:"block_cycle"
    ~construct
    ~destruct
    ()

let pp ppf cycle = Format.fprintf ppf "%ld" cycle

include (Compare.Int32 : Compare.S with type t := t)

module Map = Map.Make (Compare.Int32)

let root = 0l

let succ = Int32.succ

let pred = function 0l -> None | i -> Some (Int32.pred i)

let add c i =
  assert (Compare.Int.(i > 0)) ;
  Int32.add c (Int32.of_int i)

let sub c i =
  assert (Compare.Int.(i > 0)) ;
  let r = Int32.sub c (Int32.of_int i) in
  if Compare.Int32.(r < 0l) then None else Some r

let to_int32 i = i

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l
  else invalid_arg "Level_repr.Cycle.of_int32"

module Index = struct
  type t = cycle

  let path_length = 1

  let to_path c l = Int32.to_string (to_int32 c) :: l

  let of_path = function
    | [s] -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
src/proto_alpha/lib_protocol/cycle_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := int32.

Definition cycle := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.int32.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
  let construct := Tezos_protocol_environment_alpha__Environment.Int32.to_string
    in
  let destruct (str : string)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
      string :=
    match Tezos_protocol_environment_alpha__Environment.Int32.of_string str with
    | cycle => inl cycle
    end in
  Tezos_protocol_environment_alpha__Environment.RPC_arg.make
    (Some "A cycle integer" % string) "block_cycle" % string destruct construct
    tt.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (cycle : int32) : unit :=
  Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        CamlinternalFormatBasics.End_of_format) "%ld" % string) cycle.

Definition root : int32 := 0.

Definition succ : int32 -> int32 :=
  Tezos_protocol_environment_alpha__Environment.Int32.succ.

Definition pred (function_parameter : int32) : option int32 :=
  match function_parameter with
  | 0 => None
  | i => Some (Tezos_protocol_environment_alpha__Environment.Int32.pred i)
  end.

Definition add
  (c : int32)
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : int32 :=
  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
    i 0;
  Tezos_protocol_environment_alpha__Environment.Int32.add c
    (Tezos_protocol_environment_alpha__Environment.Int32.of_int i).

Definition sub
  (c : int32)
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : option int32 :=
  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
    i 0;
  let r :=
    Tezos_protocol_environment_alpha__Environment.Int32.sub c
      (Tezos_protocol_environment_alpha__Environment.Int32.of_int i) in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      r 0 then
    None
  else
    Some r.

Definition to_int32 {A : Type} (i : A) : A := i.

Definition of_int32_exn
  (l :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
      l 0 then
    l
  else
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "Level_repr.Cycle.of_int32" % string.

Module Index.
  Definition t := cycle.
  
  Definition path_length : Z := 1.
  
  Definition to_path (c : int32) (l : list string) : list string :=
    cons
      (Tezos_protocol_environment_alpha__Environment.Int32.to_string
        (to_int32 c)) l.
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons s [] => try
    | _ => None
    end.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
    encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.
src/proto_alpha/lib_protocol/cycle_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type cycle = t

include Compare.S with type t := t

val encoding : cycle Data_encoding.t

val rpc_arg : cycle RPC_arg.arg

val pp : Format.formatter -> cycle -> unit

val root : cycle

val pred : cycle -> cycle option

val add : cycle -> int -> cycle

val sub : cycle -> int -> cycle option

val succ : cycle -> cycle

val to_int32 : cycle -> int32

val of_int32_exn : int32 -> cycle

module Map : S.MAP with type key = cycle

module Index : Storage_description.INDEX with type t = cycle
src/proto_alpha/lib_protocol/cycle_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition cycle := t.

include

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t cycle.

Parameter rpc_arg :
Tezos_protocol_environment_alpha__Environment.RPC_arg.arg cycle.

Parameter pp :
Tezos_protocol_environment_alpha__Environment.Format.formatter -> cycle -> unit.

Parameter root : cycle.

Parameter pred : cycle -> option cycle.

Parameter add : cycle -> Z -> cycle.

Parameter sub : cycle -> Z -> option cycle.

Parameter succ : cycle -> cycle.

Parameter to_int32 : cycle -> int32.

Parameter of_int32_exn : int32 -> cycle.

unhandled_module

unhandled_module
src/proto_alpha/lib_protocol/delegate_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type info = {
  balance : Tez.t;
  frozen_balance : Tez.t;
  frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
  staking_balance : Tez.t;
  delegated_contracts : Contract_repr.t list;
  delegated_balance : Tez.t;
  deactivated : bool;
  grace_period : Cycle.t;
}

let info_encoding =
  let open Data_encoding in
  conv
    (fun { balance;
           frozen_balance;
           frozen_balance_by_cycle;
           staking_balance;
           delegated_contracts;
           delegated_balance;
           deactivated;
           grace_period } ->
      ( balance,
        frozen_balance,
        frozen_balance_by_cycle,
        staking_balance,
        delegated_contracts,
        delegated_balance,
        deactivated,
        grace_period ))
    (fun ( balance,
           frozen_balance,
           frozen_balance_by_cycle,
           staking_balance,
           delegated_contracts,
           delegated_balance,
           deactivated,
           grace_period ) ->
      {
        balance;
        frozen_balance;
        frozen_balance_by_cycle;
        staking_balance;
        delegated_contracts;
        delegated_balance;
        deactivated;
        grace_period;
      })
    (obj8
       (req "balance" Tez.encoding)
       (req "frozen_balance" Tez.encoding)
       (req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding)
       (req "staking_balance" Tez.encoding)
       (req "delegated_contracts" (list Contract_repr.encoding))
       (req "delegated_balance" Tez.encoding)
       (req "deactivated" bool)
       (req "grace_period" Cycle.encoding))

module S = struct
  let path = RPC_path.(open_root / "context" / "delegates")

  open Data_encoding

  type list_query = {active : bool; inactive : bool}

  let list_query : list_query RPC_query.t =
    let open RPC_query in
    query (fun active inactive -> {active; inactive})
    |+ flag "active" (fun t -> t.active)
    |+ flag "inactive" (fun t -> t.inactive)
    |> seal

  let list_delegate =
    RPC_service.get_service
      ~description:"Lists all registered delegates."
      ~query:list_query
      ~output:(list Signature.Public_key_hash.encoding)
      path

  let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg)

  let info =
    RPC_service.get_service
      ~description:"Everything about a delegate."
      ~query:RPC_query.empty
      ~output:info_encoding
      path

  let balance =
    RPC_service.get_service
      ~description:
        "Returns the full balance of a given delegate, including the frozen \
         balances."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "balance")

  let frozen_balance =
    RPC_service.get_service
      ~description:
        "Returns the total frozen balances of a given delegate, this includes \
         the frozen deposits, rewards and fees."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "frozen_balance")

  let frozen_balance_by_cycle =
    RPC_service.get_service
      ~description:
        "Returns the frozen balances of a given delegate, indexed by the \
         cycle by which it will be unfrozen"
      ~query:RPC_query.empty
      ~output:Delegate.frozen_balance_by_cycle_encoding
      RPC_path.(path / "frozen_balance_by_cycle")

  let staking_balance =
    RPC_service.get_service
      ~description:
        "Returns the total amount of tokens delegated to a given delegate. \
         This includes the balances of all the contracts that delegate to it, \
         but also the balance of the delegate itself and its frozen fees and \
         deposits. The rewards do not count in the delegated balance until \
         they are unfrozen."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "staking_balance")

  let delegated_contracts =
    RPC_service.get_service
      ~description:
        "Returns the list of contracts that delegate to a given delegate."
      ~query:RPC_query.empty
      ~output:(list Contract_repr.encoding)
      RPC_path.(path / "delegated_contracts")

  let delegated_balance =
    RPC_service.get_service
      ~description:
        "Returns the balances of all the contracts that delegate to a given \
         delegate. This excludes the delegate's own balance and its frozen \
         balances."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "delegated_balance")

  let deactivated =
    RPC_service.get_service
      ~description:
        "Tells whether the delegate is currently tagged as deactivated or not."
      ~query:RPC_query.empty
      ~output:bool
      RPC_path.(path / "deactivated")

  let grace_period =
    RPC_service.get_service
      ~description:
        "Returns the cycle by the end of which the delegate might be \
         deactivated if she fails to execute any delegate action. A \
         deactivated delegate might be reactivated (without loosing any \
         rolls) by simply re-registering as a delegate. For deactivated \
         delegates, this value contains the cycle by which they were \
         deactivated."
      ~query:RPC_query.empty
      ~output:Cycle.encoding
      RPC_path.(path / "grace_period")
end

let register () =
  let open Services_registration in
  register0 S.list_delegate (fun ctxt q () ->
      Delegate.list ctxt
      >>= fun delegates ->
      if q.active && q.inactive then return delegates
      else if q.active then
        filter_map_s
          (fun pkh ->
            Delegate.deactivated ctxt pkh
            >>=? function true -> return_none | false -> return_some pkh)
          delegates
      else if q.inactive then
        filter_map_s
          (fun pkh ->
            Delegate.deactivated ctxt pkh
            >>=? function false -> return_none | true -> return_some pkh)
          delegates
      else return_nil) ;
  register1 S.info (fun ctxt pkh () () ->
      Delegate.full_balance ctxt pkh
      >>=? fun balance ->
      Delegate.frozen_balance ctxt pkh
      >>=? fun frozen_balance ->
      Delegate.frozen_balance_by_cycle ctxt pkh
      >>= fun frozen_balance_by_cycle ->
      Delegate.staking_balance ctxt pkh
      >>=? fun staking_balance ->
      Delegate.delegated_contracts ctxt pkh
      >>= fun delegated_contracts ->
      Delegate.delegated_balance ctxt pkh
      >>=? fun delegated_balance ->
      Delegate.deactivated ctxt pkh
      >>=? fun deactivated ->
      Delegate.grace_period ctxt pkh
      >>=? fun grace_period ->
      return
        {
          balance;
          frozen_balance;
          frozen_balance_by_cycle;
          staking_balance;
          delegated_contracts;
          delegated_balance;
          deactivated;
          grace_period;
        }) ;
  register1 S.balance (fun ctxt pkh () () -> Delegate.full_balance ctxt pkh) ;
  register1 S.frozen_balance (fun ctxt pkh () () ->
      Delegate.frozen_balance ctxt pkh) ;
  register1 S.frozen_balance_by_cycle (fun ctxt pkh () () ->
      Delegate.frozen_balance_by_cycle ctxt pkh >>= return) ;
  register1 S.staking_balance (fun ctxt pkh () () ->
      Delegate.staking_balance ctxt pkh) ;
  register1 S.delegated_contracts (fun ctxt pkh () () ->
      Delegate.delegated_contracts ctxt pkh >>= return) ;
  register1 S.delegated_balance (fun ctxt pkh () () ->
      Delegate.delegated_balance ctxt pkh) ;
  register1 S.deactivated (fun ctxt pkh () () -> Delegate.deactivated ctxt pkh) ;
  register1 S.grace_period (fun ctxt pkh () () ->
      Delegate.grace_period ctxt pkh)

let list ctxt block ?(active = true) ?(inactive = false) () =
  RPC_context.make_call0 S.list_delegate ctxt block {active; inactive} ()

let info ctxt block pkh = RPC_context.make_call1 S.info ctxt block pkh () ()

let balance ctxt block pkh =
  RPC_context.make_call1 S.balance ctxt block pkh () ()

let frozen_balance ctxt block pkh =
  RPC_context.make_call1 S.frozen_balance ctxt block pkh () ()

let frozen_balance_by_cycle ctxt block pkh =
  RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh () ()

let staking_balance ctxt block pkh =
  RPC_context.make_call1 S.staking_balance ctxt block pkh () ()

let delegated_contracts ctxt block pkh =
  RPC_context.make_call1 S.delegated_contracts ctxt block pkh () ()

let delegated_balance ctxt block pkh =
  RPC_context.make_call1 S.delegated_balance ctxt block pkh () ()

let deactivated ctxt block pkh =
  RPC_context.make_call1 S.deactivated ctxt block pkh () ()

let grace_period ctxt block pkh =
  RPC_context.make_call1 S.grace_period ctxt block pkh () ()

let requested_levels ~default ctxt cycles levels =
  match (levels, cycles) with
  | ([], []) ->
      return [default]
  | (levels, cycles) ->
      (* explicitly fail when requested levels or cycle are in the past...
         or too far in the future... *)
      let levels =
        List.sort_uniq
          Level.compare
          (List.concat
             ( List.map (Level.from_raw ctxt) levels
             :: List.map (Level.levels_in_cycle ctxt) cycles ))
      in
      map_s
        (fun level ->
          let current_level = Level.current ctxt in
          if Level.(level <= current_level) then return (level, None)
          else
            Baking.earlier_predecessor_timestamp ctxt level
            >>=? fun timestamp -> return (level, Some timestamp))
        levels

module Baking_rights = struct
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    priority : int;
    timestamp : Timestamp.t option;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {level; delegate; priority; timestamp} ->
        (level, delegate, priority, timestamp))
      (fun (level, delegate, priority, timestamp) ->
        {level; delegate; priority; timestamp})
      (obj4
         (req "level" Raw_level.encoding)
         (req "delegate" Signature.Public_key_hash.encoding)
         (req "priority" uint16)
         (opt "estimated_time" Timestamp.encoding))

  module S = struct
    open Data_encoding

    let custom_root = RPC_path.(open_root / "helpers" / "baking_rights")

    type baking_rights_query = {
      levels : Raw_level.t list;
      cycles : Cycle.t list;
      delegates : Signature.Public_key_hash.t list;
      max_priority : int option;
      all : bool;
    }

    let baking_rights_query =
      let open RPC_query in
      query (fun levels cycles delegates max_priority all ->
          {levels; cycles; delegates; max_priority; all})
      |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
      |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
      |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
             t.delegates)
      |+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority)
      |+ flag "all" (fun t -> t.all)
      |> seal

    let baking_rights =
      RPC_service.get_service
        ~description:
          "Retrieves the list of delegates allowed to bake a block.\n\
           By default, it gives the best baking priorities for bakers that \
           have at least one opportunity below the 64th priority for the next \
           block.\n\
           Parameters `level` and `cycle` can be used to specify the (valid) \
           level(s) in the past or future at which the baking rights have to \
           be returned. Parameter `delegate` can be used to restrict the \
           results to the given delegates. If parameter `all` is set, all the \
           baking opportunities for each baker at each level are returned, \
           instead of just the first one.\n\
           Returns the list of baking slots. Also returns the minimal \
           timestamps that correspond to these slots. The timestamps are \
           omitted for levels in the past, and are only estimates for levels \
           later that the next block, based on the hypothesis that all \
           predecessor blocks were baked at the first priority."
        ~query:baking_rights_query
        ~output:(list encoding)
        custom_root
  end

  let baking_priorities ctxt max_prio (level, pred_timestamp) =
    Baking.baking_priorities ctxt level
    >>=? fun contract_list ->
    let rec loop l acc priority =
      if Compare.Int.(priority >= max_prio) then return (List.rev acc)
      else
        let (Misc.LCons (pk, next)) = l in
        let delegate = Signature.Public_key.hash pk in
        ( match pred_timestamp with
        | None ->
            return_none
        | Some pred_timestamp ->
            Baking.minimal_time ctxt priority pred_timestamp
            >>=? fun t -> return_some t )
        >>=? fun timestamp ->
        let acc =
          {level = level.level; delegate; priority; timestamp} :: acc
        in
        next () >>=? fun l -> loop l acc (priority + 1)
    in
    loop contract_list [] 0

  let remove_duplicated_delegates rights =
    List.rev @@ fst
    @@ List.fold_left
         (fun (acc, previous) r ->
           if Signature.Public_key_hash.Set.mem r.delegate previous then
             (acc, previous)
           else
             (r :: acc, Signature.Public_key_hash.Set.add r.delegate previous))
         ([], Signature.Public_key_hash.Set.empty)
         rights

  let register () =
    let open Services_registration in
    register0 S.baking_rights (fun ctxt q () ->
        requested_levels
          ~default:
            ( Level.succ ctxt (Level.current ctxt),
              Some (Timestamp.current ctxt) )
          ctxt
          q.cycles
          q.levels
        >>=? fun levels ->
        let max_priority =
          match q.max_priority with None -> 64 | Some max -> max
        in
        map_s (baking_priorities ctxt max_priority) levels
        >>=? fun rights ->
        let rights =
          if q.all then rights else List.map remove_duplicated_delegates rights
        in
        let rights = List.concat rights in
        match q.delegates with
        | [] ->
            return rights
        | _ :: _ as delegates ->
            let is_requested p =
              List.exists
                (Signature.Public_key_hash.equal p.delegate)
                delegates
            in
            return (List.filter is_requested rights))

  let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false)
      ?max_priority block =
    RPC_context.make_call0
      S.baking_rights
      ctxt
      block
      {levels; cycles; delegates; max_priority; all}
      ()
end

module Endorsing_rights = struct
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    slots : int list;
    estimated_time : Time.t option;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {level; delegate; slots; estimated_time} ->
        (level, delegate, slots, estimated_time))
      (fun (level, delegate, slots, estimated_time) ->
        {level; delegate; slots; estimated_time})
      (obj4
         (req "level" Raw_level.encoding)
         (req "delegate" Signature.Public_key_hash.encoding)
         (req "slots" (list uint16))
         (opt "estimated_time" Timestamp.encoding))

  module S = struct
    open Data_encoding

    let custom_root = RPC_path.(open_root / "helpers" / "endorsing_rights")

    type endorsing_rights_query = {
      levels : Raw_level.t list;
      cycles : Cycle.t list;
      delegates : Signature.Public_key_hash.t list;
    }

    let endorsing_rights_query =
      let open RPC_query in
      query (fun levels cycles delegates -> {levels; cycles; delegates})
      |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
      |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
      |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
             t.delegates)
      |> seal

    let endorsing_rights =
      RPC_service.get_service
        ~description:
          "Retrieves the delegates allowed to endorse a block.\n\
           By default, it gives the endorsement slots for delegates that have \
           at least one in the next block.\n\
           Parameters `level` and `cycle` can be used to specify the (valid) \
           level(s) in the past or future at which the endorsement rights \
           have to be returned. Parameter `delegate` can be used to restrict \
           the results to the given delegates.\n\
           Returns the list of endorsement slots. Also returns the minimal \
           timestamps that correspond to these slots. The timestamps are \
           omitted for levels in the past, and are only estimates for levels \
           later that the next block, based on the hypothesis that all \
           predecessor blocks were baked at the first priority."
        ~query:endorsing_rights_query
        ~output:(list encoding)
        custom_root
  end

  let endorsement_slots ctxt (level, estimated_time) =
    Baking.endorsement_rights ctxt level
    >>=? fun rights ->
    return
      (Signature.Public_key_hash.Map.fold
         (fun delegate (_, slots, _) acc ->
           {level = level.level; delegate; slots; estimated_time} :: acc)
         rights
         [])

  let register () =
    let open Services_registration in
    register0 S.endorsing_rights (fun ctxt q () ->
        requested_levels
          ~default:(Level.current ctxt, Some (Timestamp.current ctxt))
          ctxt
          q.cycles
          q.levels
        >>=? fun levels ->
        map_s (endorsement_slots ctxt) levels
        >>=? fun rights ->
        let rights = List.concat rights in
        match q.delegates with
        | [] ->
            return rights
        | _ :: _ as delegates ->
            let is_requested p =
              List.exists
                (Signature.Public_key_hash.equal p.delegate)
                delegates
            in
            return (List.filter is_requested rights))

  let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) block =
    RPC_context.make_call0
      S.endorsing_rights
      ctxt
      block
      {levels; cycles; delegates}
      ()
end

module Endorsing_power = struct
  let endorsing_power ctxt (operation, chain_id) =
    let (Operation_data data) = operation.protocol_data in
    match data.contents with
    | Single (Endorsement _) ->
        Baking.check_endorsement_rights
          ctxt
          chain_id
          {shell = operation.shell; protocol_data = data}
        >>=? fun (_, slots, _) -> return (List.length slots)
    | _ ->
        failwith "Operation is not an endorsement"

  module S = struct
    let endorsing_power =
      let open Data_encoding in
      RPC_service.post_service
        ~description:
          "Get the endorsing power of an endorsement, that is, the number of \
           slots that the endorser has"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "endorsement_operation" Operation.encoding)
             (req "chain_id" Chain_id.encoding))
        ~output:int31
        RPC_path.(open_root / "endorsing_power")
  end

  let register () =
    let open Services_registration in
    register0 S.endorsing_power (fun ctxt () (op, chain_id) ->
        endorsing_power ctxt (op, chain_id))

  let get ctxt block op chain_id =
    RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id)
end

module Required_endorsements = struct
  let required_endorsements ctxt block_delay =
    return (Baking.minimum_allowed_endorsements ctxt ~block_delay)

  module S = struct
    type t = {block_delay : Period.t}

    let required_endorsements_query =
      let open RPC_query in
      query (fun block_delay -> {block_delay})
      |+ field "block_delay" Period.rpc_arg Period.zero (fun t ->
             t.block_delay)
      |> seal

    let required_endorsements =
      let open Data_encoding in
      RPC_service.get_service
        ~description:
          "Minimum number of endorsements for a block to be valid, given a \
           delay of the block's timestamp with respect to the minimum time to \
           bake at the block's priority"
        ~query:required_endorsements_query
        ~output:int31
        RPC_path.(open_root / "required_endorsements")
  end

  let register () =
    let open Services_registration in
    register0 S.required_endorsements (fun ctxt {block_delay} () ->
        required_endorsements ctxt block_delay)

  let get ctxt block block_delay =
    RPC_context.make_call0 S.required_endorsements ctxt block {block_delay} ()
end

module Minimal_valid_time = struct
  let minimal_valid_time ctxt ~priority ~endorsing_power =
    Baking.minimal_valid_time ctxt ~priority ~endorsing_power

  module S = struct
    type t = {priority : int; endorsing_power : int}

    let minimal_valid_time_query =
      let open RPC_query in
      query (fun priority endorsing_power -> {priority; endorsing_power})
      |+ field "priority" RPC_arg.int 0 (fun t -> t.priority)
      |+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power)
      |> seal

    let minimal_valid_time =
      RPC_service.get_service
        ~description:
          "Minimal valid time for a block given a priority and an endorsing \
           power."
        ~query:minimal_valid_time_query
        ~output:Time.encoding
        RPC_path.(open_root / "minimal_valid_time")
  end

  let register () =
    let open Services_registration in
    register0 S.minimal_valid_time (fun ctxt {priority; endorsing_power} () ->
        minimal_valid_time ctxt ~priority ~endorsing_power)

  let get ctxt block priority endorsing_power =
    RPC_context.make_call0
      S.minimal_valid_time
      ctxt
      block
      {priority; endorsing_power}
      ()
end

let register () =
  register () ;
  Baking_rights.register () ;
  Endorsing_rights.register () ;
  Endorsing_power.register () ;
  Required_endorsements.register () ;
  Minimal_valid_time.register ()

let endorsement_rights ctxt level =
  Endorsing_rights.endorsement_slots ctxt (level, None)
  >>=? fun l ->
  return (List.map (fun {Endorsing_rights.delegate; _} -> delegate) l)

let baking_rights ctxt max_priority =
  let max = match max_priority with None -> 64 | Some m -> m in
  let level = Level.current ctxt in
  Baking_rights.baking_priorities ctxt max (level, None)
  >>=? fun l ->
  return
    ( level.level,
      List.map
        (fun {Baking_rights.delegate; timestamp; _} -> (delegate, timestamp))
        l )

let endorsing_power ctxt operation =
  Endorsing_power.endorsing_power ctxt operation

let required_endorsements ctxt delay =
  Required_endorsements.required_endorsements ctxt delay

let minimal_valid_time ctxt priority endorsing_power =
  Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power
src/proto_alpha/lib_protocol/delegate_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Record info := {
  balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  frozen_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  frozen_balance_by_cycle :
    Tezos_raw_protocol_alpha.Alpha_context.Cycle.Map.t
      Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance;
  staking_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  delegated_contracts : list Tezos_raw_protocol_alpha.Contract_repr.t;
  delegated_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  deactivated : bool;
  grace_period : Tezos_raw_protocol_alpha.Alpha_context.Cycle.t }.

Definition info_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        balance := balance;
          frozen_balance := frozen_balance;
          frozen_balance_by_cycle := frozen_balance_by_cycle;
          staking_balance := staking_balance;
          delegated_contracts := delegated_contracts;
          delegated_balance := delegated_balance;
          deactivated := deactivated;
          grace_period := grace_period
          |} =>
        (balance, frozen_balance, frozen_balance_by_cycle, staking_balance,
          delegated_contracts, delegated_balance, deactivated, grace_period)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        (balance, frozen_balance, frozen_balance_by_cycle, staking_balance,
          delegated_contracts, delegated_balance, deactivated, grace_period) =>
        {| balance := balance; frozen_balance := frozen_balance;
          frozen_balance_by_cycle := frozen_balance_by_cycle;
          staking_balance := staking_balance;
          delegated_contracts := delegated_contracts;
          delegated_balance := delegated_balance; deactivated := deactivated;
          grace_period := grace_period |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj8
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "balance" % string Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "frozen_balance" % string
        Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "frozen_balance_by_cycle" % string
        Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance_by_cycle_encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "staking_balance" % string
        Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "delegated_contracts" % string
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
          Tezos_raw_protocol_alpha.Contract_repr.encoding))
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "delegated_balance" % string
        Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "deactivated" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.bool)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "grace_period" % string
        Tezos_raw_protocol_alpha.Alpha_context.Cycle.encoding)).

Module S.
  Definition path
    : Tezos_protocol_environment_alpha__Environment.RPC_path.path
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
    Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
        "context" % string) "delegates" % string.
  
  Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
  
  Record list_query := {
    active : bool;
    inactive : bool }.
  
  Definition list_query
    : Tezos_protocol_environment_alpha__Environment.RPC_query.t list_query :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
      (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
        (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
          (Tezos_protocol_environment_alpha__Environment.RPC_query.query
            (fun active =>
              fun inactive => {| active := active; inactive := inactive |}))
          (Tezos_protocol_environment_alpha__Environment.RPC_query.flag None
            "active" % string (fun t => active t)))
        (Tezos_protocol_environment_alpha__Environment.RPC_query.flag None
          "inactive" % string (fun t => inactive t)))
      Tezos_protocol_environment_alpha__Environment.RPC_query.seal.
  
  Definition list_delegate
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      list_query unit
      (list
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Lists all registered delegates." % string) list_query
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
      path.
  
  Definition path
    : Tezos_protocol_environment_alpha__Environment.RPC_path.path
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
    Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon path
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.rpc_arg.
  
  Definition info
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit info :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Everything about a delegate." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      info_encoding path.
  
  Definition balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Returns the full balance of a given delegate, including the frozen balances."
          % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "balance" % string).
  
  Definition frozen_balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Returns the total frozen balances of a given delegate, this includes the frozen deposits, rewards and fees."
          % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "frozen_balance" % string).
  
  Definition frozen_balance_by_cycle
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit
      (Tezos_raw_protocol_alpha__Alpha_context.Cycle.Map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Returns the frozen balances of a given delegate, indexed by the cycle by which it will be unfrozen"
          % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance_by_cycle_encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "frozen_balance_by_cycle" % string).
  
  Definition staking_balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Returns the total amount of tokens delegated to a given delegate. This includes the balances of all the contracts that delegate to it, but also the balance of the delegate itself and its frozen fees and deposits. The rewards do not count in the delegated balance until they are unfrozen."
          % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "staking_balance" % string).
  
  Definition delegated_contracts
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit (list Tezos_raw_protocol_alpha.Contract_repr.contract) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Returns the list of contracts that delegate to a given delegate." %
          string) Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
        Tezos_raw_protocol_alpha.Contract_repr.encoding)
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "delegated_contracts" % string).
  
  Definition delegated_balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Returns the balances of all the contracts that delegate to a given delegate. This excludes the delegate's own balance and its frozen balances."
          % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "delegated_balance" % string).
  
  Definition deactivated
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit bool :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Tells whether the delegate is currently tagged as deactivated or not."
          % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_protocol_environment_alpha__Environment.Data_encoding.bool
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "deactivated" % string).
  
  Definition grace_period
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Cycle.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Returns the cycle by the end of which the delegate might be deactivated if she fails to execute any delegate action. A deactivated delegate might be reactivated (without loosing any rolls) by simply re-registering as a delegate. For deactivated delegates, this value contains the cycle by which they were deactivated."
          % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Cycle.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "grace_period" % string).
End S.

Definition register (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    Tezos_raw_protocol_alpha.Services_registration.register0 S.list_delegate
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.list ctxt)
                (fun delegates =>
                  if
                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                      (active q) (inactive q) then
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      delegates
                  else
                    if active q then
                      Tezos_protocol_environment_alpha__Environment.Error_monad.filter_map_s
                        (fun pkh =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Alpha_context.Delegate.deactivated
                              ctxt pkh)
                            (fun function_parameter =>
                              match function_parameter with
                              | true =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                              | false =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                                  pkh
                              end)) delegates
                    else
                      if inactive q then
                        Tezos_protocol_environment_alpha__Environment.Error_monad.filter_map_s
                          (fun pkh =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Alpha_context.Delegate.deactivated
                                ctxt pkh)
                              (fun function_parameter =>
                                match function_parameter with
                                | false =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                                | true =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                                    pkh
                                end)) delegates
                      else
                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_nil)
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1 S.info
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.full_balance
                      ctxt pkh)
                    (fun balance =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance
                          ctxt pkh)
                        (fun frozen_balance =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance_by_cycle
                              ctxt pkh)
                            (fun frozen_balance_by_cycle =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.staking_balance
                                  ctxt pkh)
                                (fun staking_balance =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.delegated_contracts
                                      ctxt pkh)
                                    (fun delegated_contracts =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.delegated_balance
                                          ctxt pkh)
                                        (fun delegated_balance =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (Tezos_raw_protocol_alpha.Alpha_context.Delegate.deactivated
                                              ctxt pkh)
                                            (fun deactivated =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.grace_period
                                                  ctxt pkh)
                                                (fun grace_period =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                    {| balance := balance;
                                                      frozen_balance :=
                                                        frozen_balance;
                                                      frozen_balance_by_cycle :=
                                                        frozen_balance_by_cycle;
                                                      staking_balance :=
                                                        staking_balance;
                                                      delegated_contracts :=
                                                        delegated_contracts;
                                                      delegated_balance :=
                                                        delegated_balance;
                                                      deactivated := deactivated;
                                                      grace_period :=
                                                        grace_period |}))))))))
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1 S.balance
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.full_balance
                    ctxt pkh
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1 S.frozen_balance
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance
                    ctxt pkh
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1
      S.frozen_balance_by_cycle
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance_by_cycle
                      ctxt pkh)
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1 S.staking_balance
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.staking_balance
                    ctxt pkh
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1
      S.delegated_contracts
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.delegated_contracts
                      ctxt pkh)
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1 S.delegated_balance
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.delegated_balance
                    ctxt pkh
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1 S.deactivated
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.deactivated
                    ctxt pkh
                end
            end);
    Tezos_raw_protocol_alpha.Services_registration.register1 S.grace_period
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_raw_protocol_alpha.Alpha_context.Delegate.grace_period
                    ctxt pkh
                end
            end)
  end.

Definition list {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D) (op_star_o_p_t_star : option bool)
  : (option bool) ->
    unit ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (list
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  let active :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => true
    end in
  fun op_star_o_p_t_star =>
    let inactive :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
          S.list_delegate ctxt block
          {| active := active; inactive := inactive |} tt
      end.

Definition info {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      info) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1 S.info
    ctxt block pkh tt tt.

Definition balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1 S.balance
    ctxt block pkh tt tt.

Definition frozen_balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.frozen_balance ctxt block pkh tt tt.

Definition frozen_balance_by_cycle {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (Tezos_raw_protocol_alpha__Alpha_context.Cycle.Map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.frozen_balance_by_cycle ctxt block pkh tt tt.

Definition staking_balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.staking_balance ctxt block pkh tt tt.

Definition delegated_contracts {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.delegated_contracts ctxt block pkh tt tt.

Definition delegated_balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.delegated_balance ctxt block pkh tt tt.

Definition deactivated {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      bool) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.deactivated ctxt block pkh tt tt.

Definition grace_period {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Cycle.t) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call1
    S.grace_period ctxt block pkh tt tt.

Definition requested_levels
  (default :
    Tezos_raw_protocol_alpha.Alpha_context.Level.t *
      (option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t))
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (cycles : list Tezos_raw_protocol_alpha__Alpha_context.Cycle.t)
  (levels : list Tezos_raw_protocol_alpha__Alpha_context.Raw_level.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Level.t *
          (option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)))) :=
  match (levels, cycles) with
  | ([], []) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (cons default [])
  | (levels, cycles) =>
    let levels :=
      Tezos_protocol_environment_alpha__Environment.List.sort_uniq
        Tezos_raw_protocol_alpha.Alpha_context.Level.compare
        (Tezos_protocol_environment_alpha__Environment.List.concat
          (cons
            (Tezos_protocol_environment_alpha__Environment.List.map
              (let arg :=
                Tezos_raw_protocol_alpha.Alpha_context.Level.from_raw ctxt in
              fun eta => arg None eta) levels)
            (Tezos_protocol_environment_alpha__Environment.List.map
              (Tezos_raw_protocol_alpha.Alpha_context.Level.levels_in_cycle ctxt)
              cycles))) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
      (fun level =>
        let current_level :=
          Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
        if
          Tezos_raw_protocol_alpha.Alpha_context.Level.op_lt_eq level
            current_level then
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (level, None)
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Baking.earlier_predecessor_timestamp ctxt
              level)
            (fun timestamp =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (level, (Some timestamp)))) levels
  end.

Module Baking_rights.
  Record t := {
    level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    priority : Z;
    timestamp : option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t }.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          level := level;
            delegate := delegate;
            priority := priority;
            timestamp := timestamp
            |} => (level, delegate, priority, timestamp)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (level, delegate, priority, timestamp) =>
          {| level := level; delegate := delegate; priority := priority;
            timestamp := timestamp |}
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "level" % string
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "delegate" % string
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "priority" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "estimated_time" % string
          Tezos_raw_protocol_alpha.Alpha_context.Timestamp.encoding)).
  
  Module S.
    Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
    
    Definition custom_root
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
          Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
          "helpers" % string) "baking_rights" % string.
    
    Record baking_rights_query := {
      levels : list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
      cycles : list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t;
      delegates :
        list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
      max_priority : option Z;
      all : bool }.
    
    Definition baking_rights_query
      : Tezos_protocol_environment_alpha__Environment.RPC_query.t
        baking_rights_query :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
        (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
          (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
            (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
              (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
                (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
                  (Tezos_protocol_environment_alpha__Environment.RPC_query.query
                    (fun levels =>
                      fun cycles =>
                        fun delegates =>
                          fun max_priority =>
                            fun all =>
                              {| levels := levels; cycles := cycles;
                                delegates := delegates;
                                max_priority := max_priority; all := all |}))
                  (Tezos_protocol_environment_alpha__Environment.RPC_query.multi_field
                    None "level" % string
                    Tezos_raw_protocol_alpha.Alpha_context.Raw_level.rpc_arg
                    (fun t => levels t)))
                (Tezos_protocol_environment_alpha__Environment.RPC_query.multi_field
                  None "cycle" % string
                  Tezos_raw_protocol_alpha.Alpha_context.Cycle.rpc_arg
                  (fun t => cycles t)))
              (Tezos_protocol_environment_alpha__Environment.RPC_query.multi_field
                None "delegate" % string
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.rpc_arg
                (fun t => delegates t)))
            (Tezos_protocol_environment_alpha__Environment.RPC_query.opt_field
              None "max_priority" % string
              Tezos_protocol_environment_alpha__Environment.RPC_arg.int
              (fun t => max_priority t)))
          (Tezos_protocol_environment_alpha__Environment.RPC_query.flag None
            "all" % string (fun t => all t)))
        Tezos_protocol_environment_alpha__Environment.RPC_query.seal.
    
    Definition baking_rights
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        baking_rights_query unit (list t) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
        (Some
          "Retrieves the list of delegates allowed to bake a block.
By default, it gives the best baking priorities for bakers that have at least one opportunity below the 64th priority for the next block.
Parameters `level` and `cycle` can be used to specify the (valid) level(s) in the past or future at which the baking rights have to be returned. Parameter `delegate` can be used to restrict the results to the given delegates. If parameter `all` is set, all the baking opportunities for each baker at each level are returned, instead of just the first one.
Returns the list of baking slots. Also returns the minimal timestamps that correspond to these slots. The timestamps are omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority."
            % string) baking_rights_query
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
          encoding) custom_root.
  End S.
  
  Definition baking_priorities
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
    (max_prio :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Level.t *
        (option Tezos_protocol_environment_alpha__Environment.Time.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list t)) :=
    match function_parameter with
    | (level, pred_timestamp) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Baking.baking_priorities ctxt level)
        (fun contract_list =>
          let fix loop
            (l :
            Tezos_raw_protocol_alpha.Misc.lazy_list_t
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
            (acc : list t) (priority :
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
            : Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (list t)) :=
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                priority max_prio then
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (Tezos_protocol_environment_alpha__Environment.List.rev acc)
            else
              match l with
              | Misc.LCons pk next =>
                let delegate :=
                  Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                    pk in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  match pred_timestamp with
                  | None =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                  | Some pred_timestamp =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Baking.minimal_time ctxt
                        priority pred_timestamp)
                      (fun t =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                          t)
                  end
                  (fun timestamp =>
                    let acc :=
                      cons
                        {| level := level level; delegate := delegate;
                          priority := priority; timestamp := timestamp |} acc in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (next tt)
                      (fun l =>
                        loop l acc
                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                            priority 1)))
              end in
          loop contract_list [] 0)
    end.
  
  Definition remove_duplicated_delegates (rights : list t) : list t :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      Tezos_protocol_environment_alpha__Environment.List.rev
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Pervasives.fst
        (Tezos_protocol_environment_alpha__Environment.List.fold_left
          (fun function_parameter =>
            match function_parameter with
            | (acc, previous) =>
              fun r =>
                if
                  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Set.mem
                    (delegate r) previous then
                  (acc, previous)
                else
                  ((cons r acc),
                    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Set.add
                      (delegate r) previous))
            end)
          ([],
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Set.empty)
          rights)).
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Tezos_raw_protocol_alpha.Services_registration.register0 S.baking_rights
        (fun ctxt =>
          fun q =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (requested_levels
                    ((Tezos_raw_protocol_alpha.Alpha_context.Level.succ ctxt
                      (Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt)),
                      (Some
                        (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.current
                          ctxt))) ctxt (cycles q) (levels q))
                  (fun levels =>
                    let max_priority :=
                      match max_priority q with
                      | None => 64
                      | Some max => max
                      end in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                        (baking_priorities ctxt max_priority) levels)
                      (fun rights =>
                        let rights :=
                          if all q then
                            rights
                          else
                            Tezos_protocol_environment_alpha__Environment.List.map
                              remove_duplicated_delegates rights in
                        let rights :=
                          Tezos_protocol_environment_alpha__Environment.List.concat
                            rights in
                        match delegates q with
                        | [] =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            rights
                        | (cons _ _) as delegates =>
                          let is_requested (p : t) : bool :=
                            Tezos_protocol_environment_alpha__Environment.List._exists
                              (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                                (delegate p)) delegates in
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (Tezos_protocol_environment_alpha__Environment.List.filter
                              is_requested rights)
                        end))
              end)
    end.
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (op_star_o_p_t_star :
      option (list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t))
    : (option (list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)) ->
      (option
        (list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))
        ->
        (option bool) ->
          (option Z) ->
            D ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  (list t)) :=
    let levels :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun op_star_o_p_t_star =>
      let cycles :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => []
        end in
      fun op_star_o_p_t_star =>
        let delegates :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => []
          end in
        fun op_star_o_p_t_star =>
          let all :=
            match op_star_o_p_t_star with
            | Some op_star_s_t_h_star => op_star_s_t_h_star
            | None => false
            end in
          fun max_priority =>
            fun block =>
              Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
                S.baking_rights ctxt block
                {| levels := levels; cycles := cycles; delegates := delegates;
                  max_priority := max_priority; all := all |} tt.
End Baking_rights.

Module Endorsing_rights.
  Record t := {
    level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    slots : list Z;
    estimated_time : option Tezos_protocol_environment_alpha__Environment.Time.t
    }.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {|
          level := level;
            delegate := delegate;
            slots := slots;
            estimated_time := estimated_time
            |} => (level, delegate, slots, estimated_time)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (level, delegate, slots, estimated_time) =>
          {| level := level; delegate := delegate; slots := slots;
            estimated_time := estimated_time |}
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "level" % string
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "delegate" % string
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "slots" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "estimated_time" % string
          Tezos_raw_protocol_alpha.Alpha_context.Timestamp.encoding)).
  
  Module S.
    Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
    
    Definition custom_root
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
          Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
          "helpers" % string) "endorsing_rights" % string.
    
    Record endorsing_rights_query := {
      levels : list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
      cycles : list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t;
      delegates :
        list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
      }.
    
    Definition endorsing_rights_query
      : Tezos_protocol_environment_alpha__Environment.RPC_query.t
        endorsing_rights_query :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
        (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
          (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
            (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
              (Tezos_protocol_environment_alpha__Environment.RPC_query.query
                (fun levels =>
                  fun cycles =>
                    fun delegates =>
                      {| levels := levels; cycles := cycles;
                        delegates := delegates |}))
              (Tezos_protocol_environment_alpha__Environment.RPC_query.multi_field
                None "level" % string
                Tezos_raw_protocol_alpha.Alpha_context.Raw_level.rpc_arg
                (fun t => levels t)))
            (Tezos_protocol_environment_alpha__Environment.RPC_query.multi_field
              None "cycle" % string
              Tezos_raw_protocol_alpha.Alpha_context.Cycle.rpc_arg
              (fun t => cycles t)))
          (Tezos_protocol_environment_alpha__Environment.RPC_query.multi_field
            None "delegate" % string
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.rpc_arg
            (fun t => delegates t)))
        Tezos_protocol_environment_alpha__Environment.RPC_query.seal.
    
    Definition endorsing_rights
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        endorsing_rights_query unit (list t) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
        (Some
          "Retrieves the delegates allowed to endorse a block.
By default, it gives the endorsement slots for delegates that have at least one in the next block.
Parameters `level` and `cycle` can be used to specify the (valid) level(s) in the past or future at which the endorsement rights have to be returned. Parameter `delegate` can be used to restrict the results to the given delegates.
Returns the list of endorsement slots. Also returns the minimal timestamps that correspond to these slots. The timestamps are omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority."
            % string) endorsing_rights_query
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
          encoding) custom_root.
  End S.
  
  Definition endorsement_slots
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Level.t *
        (option Tezos_protocol_environment_alpha__Environment.Time.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list t)) :=
    match function_parameter with
    | (level, estimated_time) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Baking.endorsement_rights ctxt level)
        (fun rights =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.fold
              (fun delegate =>
                fun function_parameter =>
                  match function_parameter with
                  | (_, slots, _) =>
                    fun acc =>
                      cons
                        {| level := level level; delegate := delegate;
                          slots := slots; estimated_time := estimated_time |}
                        acc
                  end) rights []))
    end.
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Tezos_raw_protocol_alpha.Services_registration.register0
        S.endorsing_rights
        (fun ctxt =>
          fun q =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (requested_levels
                    ((Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt),
                      (Some
                        (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.current
                          ctxt))) ctxt (cycles q) (levels q))
                  (fun levels =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                        (endorsement_slots ctxt) levels)
                      (fun rights =>
                        let rights :=
                          Tezos_protocol_environment_alpha__Environment.List.concat
                            rights in
                        match delegates q with
                        | [] =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            rights
                        | (cons _ _) as delegates =>
                          let is_requested (p : t) : bool :=
                            Tezos_protocol_environment_alpha__Environment.List._exists
                              (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                                (delegate p)) delegates in
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (Tezos_protocol_environment_alpha__Environment.List.filter
                              is_requested rights)
                        end))
              end)
    end.
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (op_star_o_p_t_star :
      option (list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t))
    : (option (list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)) ->
      (option
        (list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))
        ->
        D ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              (list t)) :=
    let levels :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => []
      end in
    fun op_star_o_p_t_star =>
      let cycles :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => []
        end in
      fun op_star_o_p_t_star =>
        let delegates :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => []
          end in
        fun block =>
          Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
            S.endorsing_rights ctxt block
            {| levels := levels; cycles := cycles; delegates := delegates |} tt.
End Endorsing_rights.

Module Endorsing_power.
  Definition endorsing_power
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.packed_operation *
        Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
    match function_parameter with
    | (operation, chain_id) =>
      match protocol_data operation with
      | Operation_data data =>
        match contents data with
        | Single (Endorsement _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Baking.check_endorsement_rights ctxt
              chain_id {| shell := shell operation; protocol_data := data |})
            (fun function_parameter =>
              match function_parameter with
              | (_, slots, _) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (Tezos_protocol_environment_alpha__Environment.List.length
                    slots)
              end)
        | _ =>
          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
            "Operation is not an endorsement" % string
        end
      end
    end.
  
  Module S.
    Definition endorsing_power
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
        Z :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some
          "Get the endorsing power of an endorsement, that is, the number of slots that the endorser has"
            % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "endorsement_operation" % string
            Tezos_raw_protocol_alpha.Alpha_context.Operation.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "chain_id" % string
            Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)))
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int31
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
          Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
          "endorsing_power" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Tezos_raw_protocol_alpha.Services_registration.register0 S.endorsing_power
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (op, chain_id) => endorsing_power ctxt (op, chain_id)
                end
            end)
    end.
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (op : Tezos_raw_protocol_alpha.Alpha_context.Operation.packed)
    (chain_id :
      Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Z) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.endorsing_power ctxt block tt (op, chain_id).
End Endorsing_power.

Module Required_endorsements.
  Definition required_endorsements
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
    (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (Tezos_raw_protocol_alpha.Baking.minimum_allowed_endorsements ctxt
        block_delay).
  
  Module S.
    Record t := {
      block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t }.
    
    Definition required_endorsements_query
      : Tezos_protocol_environment_alpha__Environment.RPC_query.t t :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
        (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
          (Tezos_protocol_environment_alpha__Environment.RPC_query.query
            (fun block_delay => {| block_delay := block_delay |}))
          (Tezos_protocol_environment_alpha__Environment.RPC_query.field None
            "block_delay" % string
            Tezos_raw_protocol_alpha.Alpha_context.Period.rpc_arg
            Tezos_raw_protocol_alpha.Alpha_context.Period.zero
            (fun t => block_delay t)))
        Tezos_protocol_environment_alpha__Environment.RPC_query.seal.
    
    Definition required_endorsements
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context t unit
        Z :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
        (Some
          "Minimum number of endorsements for a block to be valid, given a delay of the block's timestamp with respect to the minimum time to bake at the block's priority"
            % string) required_endorsements_query
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int31
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
          Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
          "required_endorsements" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Tezos_raw_protocol_alpha.Services_registration.register0
        S.required_endorsements
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | {| block_delay := block_delay |} =>
              fun function_parameter =>
                match function_parameter with
                | tt => required_endorsements ctxt block_delay
                end
            end)
    end.
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Z) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.required_endorsements ctxt block {| block_delay := block_delay |} tt.
End Required_endorsements.

Module Minimal_valid_time.
  Definition minimal_valid_time
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (priority : Z)
    (endorsing_power : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_protocol_environment_alpha__Environment.Time.t) :=
    Tezos_raw_protocol_alpha.Baking.minimal_valid_time ctxt priority
      endorsing_power.
  
  Module S.
    Record t := {
      priority : Z;
      endorsing_power : Z }.
    
    Definition minimal_valid_time_query
      : Tezos_protocol_environment_alpha__Environment.RPC_query.t t :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
        (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
          (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
            (Tezos_protocol_environment_alpha__Environment.RPC_query.query
              (fun priority =>
                fun endorsing_power =>
                  {| priority := priority; endorsing_power := endorsing_power |}))
            (Tezos_protocol_environment_alpha__Environment.RPC_query.field None
              "priority" % string
              Tezos_protocol_environment_alpha__Environment.RPC_arg.int 0
              (fun t => priority t)))
          (Tezos_protocol_environment_alpha__Environment.RPC_query.field None
            "endorsing_power" % string
            Tezos_protocol_environment_alpha__Environment.RPC_arg.int 0
            (fun t => endorsing_power t)))
        Tezos_protocol_environment_alpha__Environment.RPC_query.seal.
    
    Definition minimal_valid_time
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context t unit
        Tezos_protocol_environment_alpha__Environment.Time.t :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
        (Some
          "Minimal valid time for a block given a priority and an endorsing power."
            % string) minimal_valid_time_query
        Tezos_protocol_environment_alpha__Environment.Time.encoding
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
          Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
          "minimal_valid_time" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Tezos_raw_protocol_alpha.Services_registration.register0
        S.minimal_valid_time
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | {| priority := priority; endorsing_power := endorsing_power |} =>
              fun function_parameter =>
                match function_parameter with
                | tt => minimal_valid_time ctxt priority endorsing_power
                end
            end)
    end.
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (priority : Z) (endorsing_power : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.Time.t) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.minimal_valid_time ctxt block
      {| priority := priority; endorsing_power := endorsing_power |} tt.
End Minimal_valid_time.

Definition register (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    register tt;
    Baking_rights.register tt;
    Endorsing_rights.register tt;
    Endorsing_power.register tt;
    Required_endorsements.register tt;
    Minimal_valid_time.register tt
  end.

Definition endorsement_rights
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (level : Tezos_raw_protocol_alpha.Alpha_context.Level.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Endorsing_rights.endorsement_slots ctxt (level, None))
    (fun l =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (Tezos_protocol_environment_alpha__Environment.List.map
          (fun function_parameter =>
            match function_parameter with
            | {| Endorsing_rights.delegate := delegate |} => delegate
            end) l)).

Definition baking_rights
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (max_priority :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha__Alpha_context.Raw_level.t *
        (list
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
            * (option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t))))) :=
  let max :=
    match max_priority with
    | None => 64
    | Some m => m
    end in
  let level := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Baking_rights.baking_priorities ctxt max (level, None))
    (fun l =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        ((level level),
          (Tezos_protocol_environment_alpha__Environment.List.map
            (fun function_parameter =>
              match function_parameter with
              | {|
                Baking_rights.delegate := delegate;
                  Baking_rights.timestamp := timestamp
                  |} => (delegate, timestamp)
              end) l))).

Definition endorsing_power
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (operation :
    Tezos_raw_protocol_alpha.Alpha_context.packed_operation *
      Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  Endorsing_power.endorsing_power ctxt operation.

Definition required_endorsements
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  Required_endorsements.required_endorsements ctxt delay.

Definition minimal_valid_time
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (priority : Z)
  (endorsing_power : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Time.t) :=
  Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power.
src/proto_alpha/lib_protocol/delegate_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

val list :
  'a #RPC_context.simple ->
  'a ->
  ?active:bool ->
  ?inactive:bool ->
  unit ->
  Signature.Public_key_hash.t list shell_tzresult Lwt.t

type info = {
  balance : Tez.t;
  frozen_balance : Tez.t;
  frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
  staking_balance : Tez.t;
  delegated_contracts : Contract_repr.t list;
  delegated_balance : Tez.t;
  deactivated : bool;
  grace_period : Cycle.t;
}

val info_encoding : info Data_encoding.t

val info :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  info shell_tzresult Lwt.t

val balance :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Tez.t shell_tzresult Lwt.t

val frozen_balance :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Tez.t shell_tzresult Lwt.t

val frozen_balance_by_cycle :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Delegate.frozen_balance Cycle.Map.t shell_tzresult Lwt.t

val staking_balance :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Tez.t shell_tzresult Lwt.t

val delegated_contracts :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Contract_repr.t list shell_tzresult Lwt.t

val delegated_balance :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Tez.t shell_tzresult Lwt.t

val deactivated :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  bool shell_tzresult Lwt.t

val grace_period :
  'a #RPC_context.simple ->
  'a ->
  Signature.Public_key_hash.t ->
  Cycle.t shell_tzresult Lwt.t

module Baking_rights : sig
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    priority : int;
    timestamp : Timestamp.t option;
  }

  (** Retrieves the list of delegates allowed to bake a block.

      By default, it gives the best baking priorities for bakers
      that have at least one opportunity below the 64th priority for
      the next block.

      Parameters [levels] and [cycles] can be used to specify the
      (valid) level(s) in the past or future at which the baking rights
      have to be returned. Parameter [delegates] can be used to
      restrict the results to the given delegates. If parameter [all]
      is [true], all the baking opportunities for each baker at each level
      are returned, instead of just the first one.

      Returns the list of baking slots. Also returns the minimal
      timestamps that correspond to these slots. The timestamps are
      omitted for levels in the past, and are only estimates for levels
      later that the next block, based on the hypothesis that all
      predecessor blocks were baked at the first priority. *)
  val get :
    'a #RPC_context.simple ->
    ?levels:Raw_level.t list ->
    ?cycles:Cycle.t list ->
    ?delegates:Signature.public_key_hash list ->
    ?all:bool ->
    ?max_priority:int ->
    'a ->
    t list shell_tzresult Lwt.t
end

module Endorsing_rights : sig
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    slots : int list;
    estimated_time : Timestamp.t option;
  }

  (** Retrieves the delegates allowed to endorse a block.

      By default, it gives the endorsement slots for bakers that have
      at least one in the next block.

      Parameters [levels] and [cycles] can be used to specify the
      (valid) level(s) in the past or future at which the endorsement
      rights have to be returned. Parameter [delegates] can be used to
      restrict the results to the given delegates.  Returns the list of
      endorsement slots. Also returns the minimal timestamps that
      correspond to these slots.

      Timestamps are omitted for levels in the past, and are only
      estimates for levels later that the next block, based on the
      hypothesis that all predecessor blocks were baked at the first
      priority. *)
  val get :
    'a #RPC_context.simple ->
    ?levels:Raw_level.t list ->
    ?cycles:Cycle.t list ->
    ?delegates:Signature.public_key_hash list ->
    'a ->
    t list shell_tzresult Lwt.t
end

module Endorsing_power : sig
  val get :
    'a #RPC_context.simple ->
    'a ->
    Alpha_context.packed_operation ->
    Chain_id.t ->
    int shell_tzresult Lwt.t
end

module Required_endorsements : sig
  val get :
    'a #RPC_context.simple -> 'a -> Period.t -> int shell_tzresult Lwt.t
end

module Minimal_valid_time : sig
  val get :
    'a #RPC_context.simple -> 'a -> int -> int -> Time.t shell_tzresult Lwt.t
end

(* temporary export for deprecated unit test *)
val endorsement_rights :
  Alpha_context.t -> Level.t -> public_key_hash list tzresult Lwt.t

val baking_rights :
  Alpha_context.t ->
  int option ->
  (Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t

val endorsing_power :
  Alpha_context.t ->
  Alpha_context.packed_operation * Chain_id.t ->
  int tzresult Lwt.t

val required_endorsements :
  Alpha_context.t -> Alpha_context.Period.t -> int tzresult Lwt.t

val minimal_valid_time : Alpha_context.t -> int -> int -> Time.t tzresult Lwt.t

val register : unit -> unit
src/proto_alpha/lib_protocol/delegate_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter list : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    (option bool) ->
      (option bool) ->
        unit ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              (list
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)).

Record info := {
  balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  frozen_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  frozen_balance_by_cycle :
    Tezos_raw_protocol_alpha.Alpha_context.Cycle.Map.t
      Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance;
  staking_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  delegated_contracts : list Tezos_raw_protocol_alpha.Contract_repr.t;
  delegated_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  deactivated : bool;
  grace_period : Tezos_raw_protocol_alpha.Alpha_context.Cycle.t }.

Parameter info_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t info.

Parameter info : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          info).

Parameter balance : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t).

Parameter frozen_balance : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t).

Parameter frozen_balance_by_cycle : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.Cycle.Map.t
            Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance)).

Parameter staking_balance : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t).

Parameter delegated_contracts : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (list Tezos_raw_protocol_alpha.Contract_repr.t)).

Parameter delegated_balance : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t).

Parameter deactivated : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          bool).

Parameter grace_period : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Cycle.t).

Module Baking_rights.
  Record t := {
    level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    priority : Z;
    timestamp : option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t }.
  
  Parameter get : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    (option (list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)) ->
      (option (list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)) ->
        (option
          (list
            Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash))
          ->
          (option bool) ->
            (option Z) ->
              a ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    (list t)).
End Baking_rights.

Module Endorsing_rights.
  Record t := {
    level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    slots : list Z;
    estimated_time : option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t
    }.
  
  Parameter get : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    (option (list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)) ->
      (option (list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)) ->
        (option
          (list
            Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash))
          ->
          a ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                (list t)).
End Endorsing_rights.

Module Endorsing_power.
  Parameter get : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_raw_protocol_alpha.Alpha_context.packed_operation ->
        Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              Z).
End Endorsing_power.

Module Required_endorsements.
  Parameter get : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_raw_protocol_alpha.Alpha_context.Period.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            Z).
End Required_endorsements.

Module Minimal_valid_time.
  Parameter get : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Z ->
        Z ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              Tezos_protocol_environment_alpha__Environment.Time.t).
End Minimal_valid_time.

Parameter endorsement_rights :
Tezos_raw_protocol_alpha.Alpha_context.t ->
  Tezos_raw_protocol_alpha.Alpha_context.Level.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)).

Parameter baking_rights :
Tezos_raw_protocol_alpha.Alpha_context.t ->
  (option Z) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
          (list
            (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash *
              (option Tezos_protocol_environment_alpha__Environment.Time.t))))).

Parameter endorsing_power :
Tezos_raw_protocol_alpha.Alpha_context.t ->
  (Tezos_raw_protocol_alpha.Alpha_context.packed_operation *
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z).

Parameter required_endorsements :
Tezos_raw_protocol_alpha.Alpha_context.t ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z).

Parameter minimal_valid_time :
Tezos_raw_protocol_alpha.Alpha_context.t ->
  Z ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Time.t).

Parameter register : unit -> unit.
src/proto_alpha/lib_protocol/delegate_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type balance =
  | Contract of Contract_repr.t
  | Rewards of Signature.Public_key_hash.t * Cycle_repr.t
  | Fees of Signature.Public_key_hash.t * Cycle_repr.t
  | Deposits of Signature.Public_key_hash.t * Cycle_repr.t

let balance_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance"
  @@ union
       [ case
           (Tag 0)
           ~title:"Contract"
           (obj2
              (req "kind" (constant "contract"))
              (req "contract" Contract_repr.encoding))
           (function Contract c -> Some ((), c) | _ -> None)
           (fun ((), c) -> Contract c);
         case
           (Tag 1)
           ~title:"Rewards"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "rewards"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Rewards (d, l));
         case
           (Tag 2)
           ~title:"Fees"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "fees"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Fees (d, l));
         case
           (Tag 3)
           ~title:"Deposits"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "deposits"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Deposits (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Deposits (d, l)) ]

type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t

let balance_update_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance_update"
  @@ obj1
       (req
          "change"
          (conv
             (function
               | Credited v ->
                   Tez_repr.to_mutez v
               | Debited v ->
                   Int64.neg (Tez_repr.to_mutez v))
             ( Json.wrap_error
             @@ fun v ->
             if Compare.Int64.(v < 0L) then
               match Tez_repr.of_mutez (Int64.neg v) with
               | Some v ->
                   Debited v
               | None ->
                   failwith "Qty.of_mutez"
             else
               match Tez_repr.of_mutez v with
               | Some v ->
                   Credited v
               | None ->
                   failwith "Qty.of_mutez" )
             int64))

type balance_updates = (balance * balance_update) list

let balance_updates_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance_updates"
  @@ list (merge_objs balance_encoding balance_update_encoding)

let cleanup_balance_updates balance_updates =
  List.filter
    (fun (_, (Credited update | Debited update)) ->
      not (Tez_repr.equal update Tez_repr.zero))
    balance_updates

type frozen_balance = {
  deposit : Tez_repr.t;
  fees : Tez_repr.t;
  rewards : Tez_repr.t;
}

let frozen_balance_encoding =
  let open Data_encoding in
  conv
    (fun {deposit; fees; rewards} -> (deposit, fees, rewards))
    (fun (deposit, fees, rewards) -> {deposit; fees; rewards})
    (obj3
       (req "deposit" Tez_repr.encoding)
       (req "fees" Tez_repr.encoding)
       (req "rewards" Tez_repr.encoding))

type error +=
  | No_deletion of Signature.Public_key_hash.t (* `Permanent *)
  | Active_delegate (* `Temporary *)
  | Current_delegate (* `Temporary *)
  | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
  | Balance_too_low_for_deposit of {
      delegate : Signature.Public_key_hash.t;
      deposit : Tez_repr.t;
      balance : Tez_repr.t;
    }

(* `Temporary *)

let () =
  register_error_kind
    `Permanent
    ~id:"delegate.no_deletion"
    ~title:"Forbidden delegate deletion"
    ~description:"Tried to unregister a delegate"
    ~pp:(fun ppf delegate ->
      Format.fprintf
        ppf
        "Delegate deletion is forbidden (%a)"
        Signature.Public_key_hash.pp
        delegate)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function No_deletion c -> Some c | _ -> None)
    (fun c -> No_deletion c) ;
  register_error_kind
    `Temporary
    ~id:"delegate.already_active"
    ~title:"Delegate already active"
    ~description:"Useless delegate reactivation"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "The delegate is still active, no need to refresh it")
    Data_encoding.empty
    (function Active_delegate -> Some () | _ -> None)
    (fun () -> Active_delegate) ;
  register_error_kind
    `Temporary
    ~id:"delegate.unchanged"
    ~title:"Unchanged delegated"
    ~description:"Contract already delegated to the given delegate"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "The contract is already delegated to the same delegate")
    Data_encoding.empty
    (function Current_delegate -> Some () | _ -> None)
    (fun () -> Current_delegate) ;
  register_error_kind
    `Permanent
    ~id:"delegate.empty_delegate_account"
    ~title:"Empty delegate account"
    ~description:
      "Cannot register a delegate when its implicit account is empty"
    ~pp:(fun ppf delegate ->
      Format.fprintf
        ppf
        "Delegate registration is forbidden when the delegate\n\
        \           implicit account is empty (%a)"
        Signature.Public_key_hash.pp
        delegate)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function Empty_delegate_account c -> Some c | _ -> None)
    (fun c -> Empty_delegate_account c) ;
  register_error_kind
    `Temporary
    ~id:"delegate.balance_too_low_for_deposit"
    ~title:"Balance too low for deposit"
    ~description:"Cannot freeze deposit when the balance is too low"
    ~pp:(fun ppf (delegate, balance, deposit) ->
      Format.fprintf
        ppf
        "Delegate %a has a too low balance (%a) to deposit %a"
        Signature.Public_key_hash.pp
        delegate
        Tez_repr.pp
        balance
        Tez_repr.pp
        deposit)
    Data_encoding.(
      obj3
        (req "delegate" Signature.Public_key_hash.encoding)
        (req "balance" Tez_repr.encoding)
        (req "deposit" Tez_repr.encoding))
    (function
      | Balance_too_low_for_deposit {delegate; balance; deposit} ->
          Some (delegate, balance, deposit)
      | _ ->
          None)
    (fun (delegate, balance, deposit) ->
      Balance_too_low_for_deposit {delegate; balance; deposit})

let link c contract delegate =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  Roll_storage.Delegate.add_amount c delegate balance
  >>=? fun c ->
  Storage.Contract.Delegated.add
    (c, Contract_repr.implicit_contract delegate)
    contract
  >>= fun c -> return c

let unlink c contract =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  Storage.Contract.Delegate.get_option c contract
  >>=? function
  | None ->
      return c
  | Some delegate ->
      (* Removes the balance of the contract from the delegate *)
      Roll_storage.Delegate.remove_amount c delegate balance
      >>=? fun c ->
      Storage.Contract.Delegated.del
        (c, Contract_repr.implicit_contract delegate)
        contract
      >>= fun c -> return c

let known c delegate =
  Storage.Contract.Manager.get_option
    c
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | None | Some (Manager_repr.Hash _) ->
      return_false
  | Some (Manager_repr.Public_key _) ->
      return_true

(* A delegate is registered if its "implicit account" delegates to itself. *)
let registered c delegate =
  Storage.Contract.Delegate.get_option
    c
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | Some current_delegate ->
      return @@ Signature.Public_key_hash.equal delegate current_delegate
  | None ->
      return_false

let init ctxt contract delegate =
  known ctxt delegate
  >>=? fun known_delegate ->
  fail_unless known_delegate (Roll_storage.Unregistered_delegate delegate)
  >>=? fun () ->
  registered ctxt delegate
  >>=? fun is_registered ->
  fail_unless is_registered (Roll_storage.Unregistered_delegate delegate)
  >>=? fun () ->
  Storage.Contract.Delegate.init ctxt contract delegate
  >>=? fun ctxt -> link ctxt contract delegate

let get = Roll_storage.get_contract_delegate

let set c contract delegate =
  match delegate with
  | None -> (
      let delete () =
        unlink c contract
        >>=? fun c ->
        Storage.Contract.Delegate.remove c contract >>= fun c -> return c
      in
      match Contract_repr.is_implicit contract with
      | Some pkh ->
          (* check if contract is a registered delegate *)
          registered c pkh
          >>=? fun is_registered ->
          if is_registered then fail (No_deletion pkh) else delete ()
      | None ->
          delete () )
  | Some delegate ->
      known c delegate
      >>=? fun known_delegate ->
      registered c delegate
      >>=? fun registered_delegate ->
      let self_delegation =
        match Contract_repr.is_implicit contract with
        | Some pkh ->
            Signature.Public_key_hash.equal pkh delegate
        | None ->
            false
      in
      if (not known_delegate) || not (registered_delegate || self_delegation)
      then fail (Roll_storage.Unregistered_delegate delegate)
      else
        Storage.Contract.Delegate.get_option c contract
        >>=? (function
               | Some current_delegate
                 when Signature.Public_key_hash.equal delegate current_delegate
                 ->
                   if self_delegation then
                     Roll_storage.Delegate.is_inactive c delegate
                     >>=? function
                     | true -> return_unit | false -> fail Active_delegate
                   else fail Current_delegate
               | None | Some _ ->
                   return_unit)
        >>=? fun () ->
        (* check if contract is a registered delegate *)
        ( match Contract_repr.is_implicit contract with
        | Some pkh ->
            registered c pkh
            >>=? fun is_registered ->
            (* allow self-delegation to re-activate *)
            if (not self_delegation) && is_registered then
              fail (No_deletion pkh)
            else return_unit
        | None ->
            return_unit )
        >>=? fun () ->
        Storage.Contract.Balance.mem c contract
        >>= fun exists ->
        fail_when
          (self_delegation && not exists)
          (Empty_delegate_account delegate)
        >>=? fun () ->
        unlink c contract
        >>=? fun c ->
        Storage.Contract.Delegate.init_set c contract delegate
        >>= fun c ->
        link c contract delegate
        >>=? fun c ->
        ( if self_delegation then
          Storage.Delegates.add c delegate
          >>= fun c ->
          Roll_storage.Delegate.set_active c delegate >>=? fun c -> return c
        else return c )
        >>=? fun c -> return c

let remove ctxt contract = unlink ctxt contract

let delegated_contracts ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegated.elements (ctxt, contract)

let get_frozen_deposit ctxt contract cycle =
  Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_deposit ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_deposit ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  Roll_storage.Delegate.set_active ctxt delegate
  >>=? fun ctxt ->
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance ->
  Lwt.return
    (record_trace
       (Balance_too_low_for_deposit {delegate; deposit = amount; balance})
       Tez_repr.(balance -? amount))
  >>=? fun new_balance ->
  Storage.Contract.Balance.set ctxt contract new_balance
  >>=? fun ctxt -> credit_frozen_deposit ctxt delegate cycle amount

let get_frozen_fees ctxt contract cycle =
  Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_fees ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_fees ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_fees ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  Roll_storage.Delegate.add_amount ctxt delegate amount
  >>=? fun ctxt -> credit_frozen_fees ctxt delegate cycle amount

let burn_fees ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_fees ctxt contract cycle
  >>=? fun old_amount ->
  ( match Tez_repr.(old_amount -? amount) with
  | Ok new_amount ->
      Roll_storage.Delegate.remove_amount ctxt delegate amount
      >>=? fun ctxt -> return (new_amount, ctxt)
  | Error _ ->
      Roll_storage.Delegate.remove_amount ctxt delegate old_amount
      >>=? fun ctxt -> return (Tez_repr.zero, ctxt) )
  >>=? fun (new_amount, ctxt) ->
  Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt -> return ctxt

let get_frozen_rewards ctxt contract cycle =
  Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_rewards ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_rewards ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_rewards ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  credit_frozen_rewards ctxt delegate cycle amount

let burn_rewards ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_rewards ctxt contract cycle
  >>=? fun old_amount ->
  let new_amount =
    match Tez_repr.(old_amount -? amount) with
    | Error _ ->
        Tez_repr.zero
    | Ok new_amount ->
        new_amount
  in
  Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt -> return ctxt

let unfreeze ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  get_frozen_fees ctxt contract cycle
  >>=? fun fees ->
  get_frozen_rewards ctxt contract cycle
  >>=? fun rewards ->
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance ->
  Lwt.return Tez_repr.(deposit +? fees)
  >>=? fun unfrozen_amount ->
  Lwt.return Tez_repr.(unfrozen_amount +? rewards)
  >>=? fun unfrozen_amount ->
  Lwt.return Tez_repr.(balance +? unfrozen_amount)
  >>=? fun balance ->
  Storage.Contract.Balance.set ctxt contract balance
  >>=? fun ctxt ->
  Roll_storage.Delegate.add_amount ctxt delegate rewards
  >>=? fun ctxt ->
  Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  return
    ( ctxt,
      cleanup_balance_updates
        [ (Deposits (delegate, cycle), Debited deposit);
          (Fees (delegate, cycle), Debited fees);
          (Rewards (delegate, cycle), Debited rewards);
          ( Contract (Contract_repr.implicit_contract delegate),
            Credited unfrozen_amount ) ] )

let cycle_end ctxt last_cycle unrevealed =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.pred last_cycle with
  | None ->
      return (ctxt, [])
  | Some revealed_cycle ->
      List.fold_left
        (fun acc (u : Nonce_storage.unrevealed) ->
          acc
          >>=? fun (ctxt, balance_updates) ->
          burn_fees ctxt u.delegate revealed_cycle u.fees
          >>=? fun ctxt ->
          burn_rewards ctxt u.delegate revealed_cycle u.rewards
          >>=? fun ctxt ->
          let bus =
            [ (Fees (u.delegate, revealed_cycle), Debited u.fees);
              (Rewards (u.delegate, revealed_cycle), Debited u.rewards) ]
          in
          return (ctxt, bus @ balance_updates))
        (return (ctxt, []))
        unrevealed )
  >>=? fun (ctxt, balance_updates) ->
  match Cycle_repr.sub last_cycle preserved with
  | None ->
      return (ctxt, balance_updates, [])
  | Some unfrozen_cycle ->
      Storage.Delegates_with_frozen_balance.fold
        (ctxt, unfrozen_cycle)
        ~init:(Ok (ctxt, balance_updates))
        ~f:(fun delegate acc ->
          Lwt.return acc
          >>=? fun (ctxt, bus) ->
          unfreeze ctxt delegate unfrozen_cycle
          >>=? fun (ctxt, balance_updates) ->
          return (ctxt, balance_updates @ bus))
      >>=? fun (ctxt, balance_updates) ->
      Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle)
      >>= fun ctxt ->
      Storage.Active_delegates_with_rolls.fold
        ctxt
        ~init:(Ok (ctxt, []))
        ~f:(fun delegate acc ->
          Lwt.return acc
          >>=? fun (ctxt, deactivated) ->
          Storage.Contract.Delegate_desactivation.get
            ctxt
            (Contract_repr.implicit_contract delegate)
          >>=? fun cycle ->
          if Cycle_repr.(cycle <= last_cycle) then
            Roll_storage.Delegate.set_inactive ctxt delegate
            >>=? fun ctxt -> return (ctxt, delegate :: deactivated)
          else return (ctxt, deactivated))
      >>=? fun (ctxt, deactivated) ->
      return (ctxt, balance_updates, deactivated)

let punish ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  get_frozen_fees ctxt contract cycle
  >>=? fun fees ->
  get_frozen_rewards ctxt contract cycle
  >>=? fun rewards ->
  Roll_storage.Delegate.remove_amount ctxt delegate deposit
  >>=? fun ctxt ->
  Roll_storage.Delegate.remove_amount ctxt delegate fees
  >>=? fun ctxt ->
  (* Rewards are not accounted in the delegate's rolls yet... *)
  Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
  >>= fun ctxt -> return (ctxt, {deposit; fees; rewards})

let has_frozen_balance ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  if Tez_repr.(deposit <> zero) then return_true
  else
    get_frozen_fees ctxt contract cycle
    >>=? fun fees ->
    if Tez_repr.(fees <> zero) then return_true
    else
      get_frozen_rewards ctxt contract cycle
      >>=? fun rewards -> return Tez_repr.(rewards <> zero)

let frozen_balance_by_cycle_encoding =
  let open Data_encoding in
  conv
    Cycle_repr.Map.bindings
    (List.fold_left
       (fun m (c, b) -> Cycle_repr.Map.add c b m)
       Cycle_repr.Map.empty)
    (list
       (merge_objs
          (obj1 (req "cycle" Cycle_repr.encoding))
          frozen_balance_encoding))

let empty_frozen_balance =
  {deposit = Tez_repr.zero; fees = Tez_repr.zero; rewards = Tez_repr.zero}

let frozen_balance_by_cycle ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  let map = Cycle_repr.Map.empty in
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      Lwt.return
        (Cycle_repr.Map.add
           cycle
           {empty_frozen_balance with deposit = amount}
           map))
  >>= fun map ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      let balance =
        match Cycle_repr.Map.find_opt cycle map with
        | None ->
            empty_frozen_balance
        | Some balance ->
            balance
      in
      Lwt.return (Cycle_repr.Map.add cycle {balance with fees = amount} map))
  >>= fun map ->
  Storage.Contract.Frozen_rewards.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      let balance =
        match Cycle_repr.Map.find_opt cycle map with
        | None ->
            empty_frozen_balance
        | Some balance ->
            balance
      in
      Lwt.return (Cycle_repr.Map.add cycle {balance with rewards = amount} map))
  >>= fun map -> Lwt.return map

let frozen_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  let balance = Ok Tez_repr.zero in
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance ->
  Storage.Contract.Frozen_rewards.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance -> Lwt.return balance

let full_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  frozen_balance ctxt delegate
  >>=? fun frozen_balance ->
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance -> Lwt.return Tez_repr.(frozen_balance +? balance)

let deactivated = Roll_storage.Delegate.is_inactive

let grace_period ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegate_desactivation.get ctxt contract

let staking_balance ctxt delegate =
  let token_per_rolls = Constants_storage.tokens_per_roll ctxt in
  Roll_storage.get_rolls ctxt delegate
  >>=? fun rolls ->
  Roll_storage.get_change ctxt delegate
  >>=? fun change ->
  let rolls = Int64.of_int (List.length rolls) in
  Lwt.return Tez_repr.(token_per_rolls *? rolls)
  >>=? fun balance -> Lwt.return Tez_repr.(balance +? change)

let delegated_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  staking_balance ctxt delegate
  >>=? fun staking_balance ->
  Storage.Contract.Balance.get ctxt contract
  >>= fun self_staking_balance ->
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:self_staking_balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun self_staking_balance ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:self_staking_balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>=? fun self_staking_balance ->
  Lwt.return Tez_repr.(staking_balance -? self_staking_balance)

let fold = Storage.Delegates.fold

let list = Storage.Delegates.elements
src/proto_alpha/lib_protocol/delegate_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive balance : Type :=
| Contract : Tezos_raw_protocol_alpha.Contract_repr.t -> balance
| Rewards :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance
| Fees :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance
| Deposits :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance.

Definition balance_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding balance :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation_metadata.alpha.balance" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Contract" % string None (Tag 0)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "kind" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                "contract" % string))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "contract" % string
              Tezos_raw_protocol_alpha.Contract_repr.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Contract c => Some (tt, c)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (tt, c) => Contract c
            end))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "Rewards" % string None (Tag 1)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "kind" % string
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                  "freezer" % string))
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "category" % string
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                  "rewards" % string))
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "delegate" % string
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "cycle" % string
                Tezos_raw_protocol_alpha.Cycle_repr.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Rewards d l => Some (tt, tt, d, l)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (tt, tt, d, l) => Rewards d l
              end))
          (cons
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
              "Fees" % string None (Tag 2)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "kind" % string
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                    "freezer" % string))
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "category" % string
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                    "fees" % string))
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "delegate" % string
                  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "cycle" % string
                  Tezos_raw_protocol_alpha.Cycle_repr.encoding))
              (fun function_parameter =>
                match function_parameter with
                | Fees d l => Some (tt, tt, d, l)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (tt, tt, d, l) => Fees d l
                end))
            (cons
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
                "Deposits" % string None (Tag 3)
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                    None None "kind" % string
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                      "freezer" % string))
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                    None None "category" % string
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                      "deposits" % string))
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                    None None "delegate" % string
                    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                    None None "cycle" % string
                    Tezos_raw_protocol_alpha.Cycle_repr.encoding))
                (fun function_parameter =>
                  match function_parameter with
                  | Deposits d l => Some (tt, tt, d, l)
                  | _ => None
                  end)
                (fun function_parameter =>
                  match function_parameter with
                  | (tt, tt, d, l) => Deposits d l
                  end)) []))))).

Inductive balance_update : Type :=
| Debited : Tezos_raw_protocol_alpha.Tez_repr.t -> balance_update
| Credited : Tezos_raw_protocol_alpha.Tez_repr.t -> balance_update.

Definition balance_update_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    balance_update :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation_metadata.alpha.balance_update" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "change" % string
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
          (fun function_parameter =>
            match function_parameter with
            | Credited v => Tezos_raw_protocol_alpha.Tez_repr.to_mutez v
            | Debited v =>
              Tezos_protocol_environment_alpha__Environment.Int64.neg
                (Tezos_raw_protocol_alpha.Tez_repr.to_mutez v)
            end)
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Data_encoding.Json.wrap_error
            (fun v =>
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                  v 0 then
                match
                  Tezos_raw_protocol_alpha.Tez_repr.of_mutez
                    (Tezos_protocol_environment_alpha__Environment.Int64.neg v)
                  with
                | Some v => Debited v
                | None =>
                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                    "Qty.of_mutez" % string
                end
              else
                match Tezos_raw_protocol_alpha.Tez_repr.of_mutez v with
                | Some v => Credited v
                | None =>
                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                    "Qty.of_mutez" % string
                end)) None
          Tezos_protocol_environment_alpha__Environment.Data_encoding.int64))).

Definition balance_updates := list (balance * balance_update).

Definition balance_updates_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list (balance * balance_update)) :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "operation_metadata.alpha.balance_updates" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        balance_encoding balance_update_encoding)).

Definition cleanup_balance_updates {A : Type}
  (balance_updates : list (A * balance_update)) : list (A * balance_update) :=
  Tezos_protocol_environment_alpha__Environment.List.filter
    (fun function_parameter =>
      match function_parameter with
      | (_, Credited update | Debited update) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.not
          (Tezos_raw_protocol_alpha.Tez_repr.equal update
            Tezos_raw_protocol_alpha.Tez_repr.zero)
      end) balance_updates.

Record frozen_balance := {
  deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
  fees : Tezos_raw_protocol_alpha.Tez_repr.t;
  rewards : Tezos_raw_protocol_alpha.Tez_repr.t }.

Definition frozen_balance_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    frozen_balance :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| deposit := deposit; fees := fees; rewards := rewards |} =>
        (deposit, fees, rewards)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (deposit, fees, rewards) =>
        {| deposit := deposit; fees := fees; rewards := rewards |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "deposit" % string Tezos_raw_protocol_alpha.Tez_repr.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "fees" % string Tezos_raw_protocol_alpha.Tez_repr.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "rewards" % string Tezos_raw_protocol_alpha.Tez_repr.encoding)).

Definition link
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get c contract)
    (fun balance =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Roll_storage.Delegate.add_amount c delegate
          balance)
        (fun c =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Storage.Contract.Delegated.add
              (c,
                (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract
                  delegate)) contract)
            (fun c =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                c))).

Definition unlink
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Contract.Balance.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get c contract)
    (fun balance =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Contract.Delegate.get_option c
          contract)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return c
          | Some delegate =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Roll_storage.Delegate.remove_amount c
                delegate balance)
              (fun c =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_raw_protocol_alpha.Storage.Contract.Delegated.del
                    (c,
                      (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract
                        delegate)) contract)
                  (fun c =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      c))
          end)).

Definition known
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Manager.get_option c
      (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | None | Some (Manager_repr.Hash _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_false
      | Some (Manager_repr.Public_key _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_true
      end).

Definition registered
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Delegate.get_option c
      (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | Some current_delegate =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
            delegate current_delegate)
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_false
      end).

Definition init
  (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (known ctxt delegate)
    (fun known_delegate =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
          known_delegate (Roll_storage.Unregistered_delegate delegate))
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (registered ctxt delegate)
              (fun is_registered =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                    is_registered (Roll_storage.Unregistered_delegate delegate))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Storage.Contract.Delegate.init
                          ctxt contract delegate)
                        (fun ctxt => link ctxt contract delegate)
                    end))
          end)).

Definition get
  : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_raw_protocol_alpha.Contract_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  Tezos_raw_protocol_alpha.Roll_storage.get_contract_delegate.

Definition set
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  (delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match delegate with
  | None =>
    let delete (function_parameter : unit)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
      match function_parameter with
      | tt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (unlink c contract)
          (fun c =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
              (Tezos_raw_protocol_alpha.Storage.Contract.Delegate.remove c
                contract)
              (fun c =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  c))
      end in
    match Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract with
    | Some pkh =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (registered c pkh)
        (fun is_registered =>
          if is_registered then
            Tezos_protocol_environment_alpha__Environment.Error_monad.fail
              (No_deletion pkh)
          else
            delete tt)
    | None => delete tt
    end
  | Some delegate =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (known c delegate)
      (fun known_delegate =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (registered c delegate)
          (fun registered_delegate =>
            let self_delegation :=
              match Tezos_raw_protocol_alpha.Contract_repr.is_implicit contract
                with
              | Some pkh =>
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                  pkh delegate
              | None => false
              end in
            if
              Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                (Tezos_protocol_environment_alpha__Environment.Pervasives.not
                  known_delegate)
                (Tezos_protocol_environment_alpha__Environment.Pervasives.not
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                    registered_delegate self_delegation)) then
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Roll_storage.Unregistered_delegate delegate)
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Contract.Delegate.get_option
                    c contract)
                  (fun function_parameter =>
                    match function_parameter with
                    | Some current_delegate =>
                      if self_delegation then
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Roll_storage.Delegate.is_inactive
                            c delegate)
                          (fun function_parameter =>
                            match function_parameter with
                            | true =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                            | false =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                Active_delegate
                            end)
                      else
                        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                          Current_delegate
                    | None | Some _ =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                    end))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      match
                        Tezos_raw_protocol_alpha.Contract_repr.is_implicit
                          contract with
                      | Some pkh =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (registered c pkh)
                          (fun is_registered =>
                            if
                              Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                                (Tezos_protocol_environment_alpha__Environment.Pervasives.not
                                  self_delegation) is_registered then
                              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                (No_deletion pkh)
                            else
                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit)
                      | None =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                      end
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (Tezos_raw_protocol_alpha.Storage.Contract.Balance.mem
                              c contract)
                            (fun _exists =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_when
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                                    self_delegation
                                    (Tezos_protocol_environment_alpha__Environment.Pervasives.not
                                      _exists))
                                  (Empty_delegate_account delegate))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (unlink c contract)
                                      (fun c =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                          (Tezos_raw_protocol_alpha.Storage.Contract.Delegate.init_set
                                            c contract delegate)
                                          (fun c =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (link c contract delegate)
                                              (fun c =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (if self_delegation then
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                      (Tezos_raw_protocol_alpha.Storage.Delegates.add
                                                        c delegate)
                                                      (fun c =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (Tezos_raw_protocol_alpha.Roll_storage.Delegate.set_active
                                                            c delegate)
                                                          (fun c =>
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                              c))
                                                  else
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                      c)
                                                  (fun c =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                      c))))
                                  end))
                        end)
                  end)))
  end.

Definition remove
  (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Contract.Balance.context) :=
  unlink ctxt contract.

Definition delegated_contracts
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list Tezos_raw_protocol_alpha.Storage.Contract.Delegated.elt) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_raw_protocol_alpha.Storage.Contract.Delegated.elements (ctxt, contract).

Definition get_frozen_deposit
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.get_option
      (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          Tezos_raw_protocol_alpha.Tez_repr.zero
      | Some frozen =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return frozen
      end).

Definition credit_frozen_deposit
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_frozen_deposit ctxt contract cycle)
    (fun old_amount =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question old_amount amount))
        (fun new_amount =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.init_set
              (ctxt, contract) cycle new_amount)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Storage.Delegates_with_frozen_balance.add
                  (ctxt, cycle) delegate)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt)))).

Definition freeze_deposit
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match Tezos_raw_protocol_alpha.Level_storage.current ctxt with
  | {| Level_repr.cycle := cycle |} =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Roll_storage.Delegate.set_active ctxt delegate)
      (fun ctxt =>
        let contract :=
          Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get ctxt contract)
          (fun balance =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
                  (Balance_too_low_for_deposit
                    {| delegate := delegate; deposit := amount;
                      balance := balance |})
                  (Tezos_raw_protocol_alpha.Tez_repr.op_minus_question balance
                    amount)))
              (fun new_balance =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Contract.Balance.set ctxt
                    contract new_balance)
                  (fun ctxt => credit_frozen_deposit ctxt delegate cycle amount))))
  end.

Definition get_frozen_fees
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.get_option
      (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          Tezos_raw_protocol_alpha.Tez_repr.zero
      | Some frozen =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return frozen
      end).

Definition credit_frozen_fees
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_frozen_fees ctxt contract cycle)
    (fun old_amount =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question old_amount amount))
        (fun new_amount =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.init_set
              (ctxt, contract) cycle new_amount)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Storage.Delegates_with_frozen_balance.add
                  (ctxt, cycle) delegate)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt)))).

Definition freeze_fees
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match Tezos_raw_protocol_alpha.Level_storage.current ctxt with
  | {| Level_repr.cycle := cycle |} =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Roll_storage.Delegate.add_amount ctxt delegate
        amount) (fun ctxt => credit_frozen_fees ctxt delegate cycle amount)
  end.

Definition burn_fees
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_frozen_fees ctxt contract cycle)
    (fun old_amount =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        match
          Tezos_raw_protocol_alpha.Tez_repr.op_minus_question old_amount amount
          with
        | inl new_amount =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Roll_storage.Delegate.remove_amount ctxt
              delegate amount)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (new_amount, ctxt))
        | inr _ =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Roll_storage.Delegate.remove_amount ctxt
              delegate old_amount)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (Tezos_raw_protocol_alpha.Tez_repr.zero, ctxt))
        end
        (fun function_parameter =>
          match function_parameter with
          | (new_amount, ctxt) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
              (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.init_set
                (ctxt, contract) cycle new_amount)
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ctxt)
          end)).

Definition get_frozen_rewards
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.get_option
      (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          Tezos_raw_protocol_alpha.Tez_repr.zero
      | Some frozen =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return frozen
      end).

Definition credit_frozen_rewards
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_frozen_rewards ctxt contract cycle)
    (fun old_amount =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question old_amount amount))
        (fun new_amount =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.init_set
              (ctxt, contract) cycle new_amount)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Storage.Delegates_with_frozen_balance.add
                  (ctxt, cycle) delegate)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt)))).

Definition freeze_rewards
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match Tezos_raw_protocol_alpha.Level_storage.current ctxt with
  | {| Level_repr.cycle := cycle |} =>
    credit_frozen_rewards ctxt delegate cycle amount
  end.

Definition burn_rewards
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_frozen_rewards ctxt contract cycle)
    (fun old_amount =>
      let new_amount :=
        match
          Tezos_raw_protocol_alpha.Tez_repr.op_minus_question old_amount amount
          with
        | inr _ => Tezos_raw_protocol_alpha.Tez_repr.zero
        | inl new_amount => new_amount
        end in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.init_set
          (ctxt, contract) cycle new_amount)
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt)).

Definition unfreeze
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (list (balance * balance_update)))) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (get_frozen_fees ctxt contract cycle)
        (fun fees =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (get_frozen_rewards ctxt contract cycle)
            (fun rewards =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get ctxt
                  contract)
                (fun balance =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question
                        deposit fees))
                    (fun unfrozen_amount =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question
                            unfrozen_amount rewards))
                        (fun unfrozen_amount =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_protocol_environment_alpha__Environment.Lwt._return
                              (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question
                                balance unfrozen_amount))
                            (fun balance =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Storage.Contract.Balance.set
                                  ctxt contract balance)
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Roll_storage.Delegate.add_amount
                                      ctxt delegate rewards)
                                    (fun ctxt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                        (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.remove
                                          (ctxt, contract) cycle)
                                        (fun ctxt =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                            (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.remove
                                              (ctxt, contract) cycle)
                                            (fun ctxt =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.remove
                                                  (ctxt, contract) cycle)
                                                (fun ctxt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                    (ctxt,
                                                      (cleanup_balance_updates
                                                        (cons
                                                          ((Deposits delegate
                                                            cycle),
                                                            (Debited deposit))
                                                          (cons
                                                            ((Fees delegate
                                                              cycle),
                                                              (Debited fees))
                                                            (cons
                                                              ((Rewards delegate
                                                                cycle),
                                                                (Debited rewards))
                                                              (cons
                                                                ((Contract
                                                                  (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract
                                                                    delegate)),
                                                                  (Credited
                                                                    unfrozen_amount))
                                                                [])))))))))))))))))).

Definition cycle_end
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  (unrevealed : list Tezos_raw_protocol_alpha.Nonce_storage.unrevealed)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.context *
        (list (balance * balance_update)) *
        (list Tezos_raw_protocol_alpha.Storage.Active_delegates_with_rolls.elt))) :=
  let preserved :=
    Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    match Tezos_raw_protocol_alpha.Cycle_repr.pred last_cycle with
    | None =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (ctxt, [])
    | Some revealed_cycle =>
      Tezos_protocol_environment_alpha__Environment.List.fold_left
        (fun acc =>
          fun u =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              acc
              (fun function_parameter =>
                match function_parameter with
                | (ctxt, balance_updates) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (burn_fees ctxt (delegate u) revealed_cycle (fees u))
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (burn_rewards ctxt (delegate u) revealed_cycle
                          (rewards u))
                        (fun ctxt =>
                          let bus :=
                            cons
                              ((Fees (delegate u) revealed_cycle),
                                (Debited (fees u)))
                              (cons
                                ((Rewards (delegate u) revealed_cycle),
                                  (Debited (rewards u))) []) in
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (ctxt,
                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                bus balance_updates))))
                end))
        (Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (ctxt, [])) unrevealed
    end
    (fun function_parameter =>
      match function_parameter with
      | (ctxt, balance_updates) =>
        match Tezos_raw_protocol_alpha.Cycle_repr.sub last_cycle preserved with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (ctxt, balance_updates, [])
        | Some unfrozen_cycle =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Delegates_with_frozen_balance.fold
              (ctxt, unfrozen_cycle) (inl (ctxt, balance_updates))
              (fun delegate =>
                fun acc =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      acc)
                    (fun function_parameter =>
                      match function_parameter with
                      | (ctxt, bus) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (unfreeze ctxt delegate unfrozen_cycle)
                          (fun function_parameter =>
                            match function_parameter with
                            | (ctxt, balance_updates) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (ctxt,
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                    balance_updates bus))
                            end)
                      end)))
            (fun function_parameter =>
              match function_parameter with
              | (ctxt, balance_updates) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_raw_protocol_alpha.Storage.Delegates_with_frozen_balance.clear
                    (ctxt, unfrozen_cycle))
                  (fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Storage.Active_delegates_with_rolls.fold
                        ctxt (inl (ctxt, []))
                        (fun delegate =>
                          fun acc =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                acc)
                              (fun function_parameter =>
                                match function_parameter with
                                | (ctxt, deactivated) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.get
                                      ctxt
                                      (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract
                                        delegate))
                                    (fun cycle =>
                                      if
                                        Tezos_raw_protocol_alpha.Cycle_repr.op_lt_eq
                                          cycle last_cycle then
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Roll_storage.Delegate.set_inactive
                                            ctxt delegate)
                                          (fun ctxt =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                              (ctxt, (cons delegate deactivated)))
                                      else
                                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                          (ctxt, deactivated))
                                end)))
                      (fun function_parameter =>
                        match function_parameter with
                        | (ctxt, deactivated) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (ctxt, balance_updates, deactivated)
                        end))
              end)
        end
      end).

Definition punish
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t * frozen_balance)) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (get_frozen_fees ctxt contract cycle)
        (fun fees =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (get_frozen_rewards ctxt contract cycle)
            (fun rewards =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Roll_storage.Delegate.remove_amount
                  ctxt delegate deposit)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Roll_storage.Delegate.remove_amount
                      ctxt delegate fees)
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                        (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.remove
                          (ctxt, contract) cycle)
                        (fun ctxt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.remove
                              (ctxt, contract) cycle)
                            (fun ctxt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.remove
                                  (ctxt, contract) cycle)
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                    (ctxt,
                                      {| deposit := deposit; fees := fees;
                                        rewards := rewards |}))))))))).

Definition has_frozen_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      if
        Tezos_raw_protocol_alpha.Tez_repr.op_lt_gt deposit
          Tezos_raw_protocol_alpha.Tez_repr.zero then
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_true
      else
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (get_frozen_fees ctxt contract cycle)
          (fun fees =>
            if
              Tezos_raw_protocol_alpha.Tez_repr.op_lt_gt fees
                Tezos_raw_protocol_alpha.Tez_repr.zero then
              Tezos_protocol_environment_alpha__Environment.Error_monad.return_true
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (get_frozen_rewards ctxt contract cycle)
                (fun rewards =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (Tezos_raw_protocol_alpha.Tez_repr.op_lt_gt rewards
                      Tezos_raw_protocol_alpha.Tez_repr.zero)))).

Definition frozen_balance_by_cycle_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_raw_protocol_alpha.Cycle_repr.Map.t frozen_balance) :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    Tezos_raw_protocol_alpha.Cycle_repr.Map.bindings
    (Tezos_protocol_environment_alpha__Environment.List.fold_left
      (fun m =>
        fun function_parameter =>
          match function_parameter with
          | (c, b) => Tezos_raw_protocol_alpha.Cycle_repr.Map.add c b m
          end) Tezos_raw_protocol_alpha.Cycle_repr.Map.empty) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "cycle" % string Tezos_raw_protocol_alpha.Cycle_repr.encoding))
        frozen_balance_encoding)).

Definition empty_frozen_balance : frozen_balance :=
  {| deposit := Tezos_raw_protocol_alpha.Tez_repr.zero;
    fees := Tezos_raw_protocol_alpha.Tez_repr.zero;
    rewards := Tezos_raw_protocol_alpha.Tez_repr.zero |}.

Definition frozen_balance_by_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_raw_protocol_alpha.Cycle_repr.Map.t frozen_balance) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  let map := Tezos_raw_protocol_alpha.Cycle_repr.Map.empty in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.fold
      (ctxt, contract) map
      (fun cycle =>
        fun amount =>
          fun map =>
            Tezos_protocol_environment_alpha__Environment.Lwt._return
              (Tezos_raw_protocol_alpha.Cycle_repr.Map.add cycle record map)))
    (fun map =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.fold
          (ctxt, contract) map
          (fun cycle =>
            fun amount =>
              fun map =>
                let balance :=
                  match
                    Tezos_raw_protocol_alpha.Cycle_repr.Map.find_opt cycle map
                    with
                  | None => empty_frozen_balance
                  | Some balance => balance
                  end in
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Cycle_repr.Map.add cycle record map)))
        (fun map =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.fold
              (ctxt, contract) map
              (fun cycle =>
                fun amount =>
                  fun map =>
                    let balance :=
                      match
                        Tezos_raw_protocol_alpha.Cycle_repr.Map.find_opt cycle
                          map with
                      | None => empty_frozen_balance
                      | Some balance => balance
                      end in
                    Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Cycle_repr.Map.add cycle record
                        map)))
            (fun map =>
              Tezos_protocol_environment_alpha__Environment.Lwt._return map))).

Definition frozen_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Pervasives.result
      Tezos_raw_protocol_alpha.Tez_repr.t
      (list Tezos_protocol_environment_alpha__Environment.Error_monad.error)) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  let balance := inl Tezos_raw_protocol_alpha.Tez_repr.zero in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.fold
      (ctxt, contract) balance
      (fun _cycle =>
        fun amount =>
          fun acc =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return acc)
              (fun acc =>
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question acc amount))))
    (fun balance =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.fold
          (ctxt, contract) balance
          (fun _cycle =>
            fun amount =>
              fun acc =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return acc)
                  (fun acc =>
                    Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question acc
                        amount))))
        (fun balance =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.fold
              (ctxt, contract) balance
              (fun _cycle =>
                fun amount =>
                  fun acc =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        acc)
                      (fun acc =>
                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question
                            acc amount))))
            (fun balance =>
              Tezos_protocol_environment_alpha__Environment.Lwt._return balance))).

Definition full_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (frozen_balance ctxt delegate)
    (fun frozen_balance =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get ctxt contract)
        (fun balance =>
          Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question frozen_balance
              balance))).

Definition deactivated
  : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  Tezos_raw_protocol_alpha.Roll_storage.Delegate.is_inactive.

Definition grace_period
  (ctxt :
    Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.value) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.get ctxt
    contract.

Definition staking_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  let token_per_rolls :=
    Tezos_raw_protocol_alpha.Constants_storage.tokens_per_roll ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Roll_storage.get_rolls ctxt delegate)
    (fun rolls =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Roll_storage.get_change ctxt delegate)
        (fun change =>
          let rolls :=
            Tezos_protocol_environment_alpha__Environment.Int64.of_int
              (Tezos_protocol_environment_alpha__Environment.List.length rolls)
            in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Lwt._return
              (Tezos_raw_protocol_alpha.Tez_repr.op_star_question
                token_per_rolls rolls))
            (fun balance =>
              Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question balance
                  change)))).

Definition delegated_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  let contract :=
    Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (staking_balance ctxt delegate)
    (fun staking_balance =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (Tezos_raw_protocol_alpha.Storage.Contract.Balance.get ctxt contract)
        (fun self_staking_balance =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.fold
              (ctxt, contract) self_staking_balance
              (fun _cycle =>
                fun amount =>
                  fun acc =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        acc)
                      (fun acc =>
                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question
                            acc amount))))
            (fun self_staking_balance =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.fold
                  (ctxt, contract) self_staking_balance
                  (fun _cycle =>
                    fun amount =>
                      fun acc =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_protocol_environment_alpha__Environment.Lwt._return
                            acc)
                          (fun acc =>
                            Tezos_protocol_environment_alpha__Environment.Lwt._return
                              (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question
                                acc amount))))
                (fun self_staking_balance =>
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_raw_protocol_alpha.Tez_repr.op_minus_question
                      staking_balance self_staking_balance))))).

Definition fold {A : Type}
  : Tezos_raw_protocol_alpha.Storage.Delegates.context ->
    A ->
      (Tezos_raw_protocol_alpha.Storage.Delegates.elt ->
        A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
  Tezos_raw_protocol_alpha.Storage.Delegates.fold.

Definition list
  : Tezos_raw_protocol_alpha.Storage.Delegates.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list Tezos_raw_protocol_alpha.Storage.Delegates.elt) :=
  Tezos_raw_protocol_alpha.Storage.Delegates.elements.
src/proto_alpha/lib_protocol/delegate_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Places where tezzies can be found in the ledger's state. *)
type balance =
  | Contract of Contract_repr.t
  | Rewards of Signature.Public_key_hash.t * Cycle_repr.t
  | Fees of Signature.Public_key_hash.t * Cycle_repr.t
  | Deposits of Signature.Public_key_hash.t * Cycle_repr.t

(** A credit or debit of tezzies to a balance. *)
type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t

(** A list of balance updates. Duplicates may happen. *)
type balance_updates = (balance * balance_update) list

val balance_updates_encoding : balance_updates Data_encoding.t

(** Remove zero-valued balances from a list of updates. *)
val cleanup_balance_updates : balance_updates -> balance_updates

type frozen_balance = {
  deposit : Tez_repr.t;
  fees : Tez_repr.t;
  rewards : Tez_repr.t;
}

(** Allow to register a delegate when creating an account. *)
val init :
  Raw_context.t ->
  Contract_repr.t ->
  Signature.Public_key_hash.t ->
  Raw_context.t tzresult Lwt.t

(** Cleanup delegation when deleting a contract. *)
val remove : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t

(** Reading the current delegate of a contract. *)
val get :
  Raw_context.t ->
  Contract_repr.t ->
  Signature.Public_key_hash.t option tzresult Lwt.t

val registered :
  Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

(** Updating the delegate of a contract.

    When calling this function on an "implicit contract" and setting
    the delegate to the contract manager registers it as a delegate. One
    cannot unregister a delegate for now. The associate contract is now
    'undeletable'. *)
val set :
  Raw_context.t ->
  Contract_repr.t ->
  Signature.Public_key_hash.t option ->
  Raw_context.t tzresult Lwt.t

type error +=
  | No_deletion of Signature.Public_key_hash.t (* `Permanent *)
  | Active_delegate (* `Temporary *)
  | Current_delegate (* `Temporary *)
  | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
  | Balance_too_low_for_deposit of {
      delegate : Signature.Public_key_hash.t;
      deposit : Tez_repr.t;
      balance : Tez_repr.t;
    }

(* `Temporary *)

(** Iterate on all registered delegates. *)
val fold :
  Raw_context.t ->
  init:'a ->
  f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) ->
  'a Lwt.t

(** List all registered delegates. *)
val list : Raw_context.t -> Signature.Public_key_hash.t list Lwt.t

(** Various functions to 'freeze' tokens.  A frozen 'deposit' keeps its
    associated rolls. When frozen, 'fees' may trigger new rolls
    allocation. Rewards won't trigger new rolls allocation until
    unfrozen. *)
val freeze_deposit :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

val freeze_fees :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

val freeze_rewards :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Tez_repr.t ->
  Raw_context.t tzresult Lwt.t

(** Trigger the context maintenance at the end of cycle 'n', i.e.:
    unfreeze deposit/fees/rewards from 'n - preserved_cycle' ; punish the
    provided unrevealed seeds (tipically seed from cycle 'n - 1').
    Returns a list of account with the amount that was unfrozen for each
    and the list of deactivated delegates. *)
val cycle_end :
  Raw_context.t ->
  Cycle_repr.t ->
  Nonce_storage.unrevealed list ->
  (Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult
  Lwt.t

(** Burn all then frozen deposit/fees/rewards for a delegate at a given
    cycle. Returns the burned amounts. *)
val punish :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Cycle_repr.t ->
  (Raw_context.t * frozen_balance) tzresult Lwt.t

(** Has the given key some frozen tokens in its implicit contract? *)
val has_frozen_balance :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Cycle_repr.t ->
  bool tzresult Lwt.t

(** Returns the amount of frozen deposit, fees and rewards associated
    to a given delegate. *)
val frozen_balance :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

val frozen_balance_encoding : frozen_balance Data_encoding.t

val frozen_balance_by_cycle_encoding :
  frozen_balance Cycle_repr.Map.t Data_encoding.t

(** Returns the amount of frozen deposit, fees and rewards associated
    to a given delegate, indexed by the cycle by which at the end the
    balance will be unfrozen. *)
val frozen_balance_by_cycle :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  frozen_balance Cycle_repr.Map.t Lwt.t

(** Returns the full 'balance' of the implicit contract associated to
    a given key, i.e. the sum of the spendable balance and of the
    frozen balance. *)
val full_balance :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

val staking_balance :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

(** Returns the list of contracts (implicit or originated) that delegated towards a given delegate *)
val delegated_contracts :
  Raw_context.t -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t

val delegated_balance :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

val deactivated :
  Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

val grace_period :
  Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t tzresult Lwt.t
src/proto_alpha/lib_protocol/delegate_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive balance : Type :=
| Contract : Tezos_raw_protocol_alpha.Contract_repr.t -> balance
| Rewards :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance
| Fees :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance
| Deposits :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance.

Inductive balance_update : Type :=
| Debited : Tezos_raw_protocol_alpha.Tez_repr.t -> balance_update
| Credited : Tezos_raw_protocol_alpha.Tez_repr.t -> balance_update.

Definition balance_updates := list (balance * balance_update).

Parameter balance_updates_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t balance_updates.

Parameter cleanup_balance_updates : balance_updates -> balance_updates.

Record frozen_balance := {
  deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
  fees : Tezos_raw_protocol_alpha.Tez_repr.t;
  rewards : Tezos_raw_protocol_alpha.Tez_repr.t }.

Parameter init :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter remove :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter get :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)).

Parameter registered :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).

Parameter set :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    (option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

extensible_type

Parameter fold : forall {a : Type},
Tezos_raw_protocol_alpha.Raw_context.t ->
  a ->
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
      -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t a.

Parameter list :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t).

Parameter freeze_deposit :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter freeze_fees :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter freeze_rewards :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter cycle_end :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t ->
    (list Tezos_raw_protocol_alpha.Nonce_storage.unrevealed) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * balance_updates *
            (list
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))).

Parameter punish :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha.Cycle_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * frozen_balance)).

Parameter has_frozen_balance :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha.Cycle_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).

Parameter frozen_balance :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Tez_repr.t).

Parameter frozen_balance_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t frozen_balance.

Parameter frozen_balance_by_cycle_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  (Tezos_raw_protocol_alpha.Cycle_repr.Map.t frozen_balance).

Parameter frozen_balance_by_cycle :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_raw_protocol_alpha.Cycle_repr.Map.t frozen_balance).

Parameter full_balance :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Tez_repr.t).

Parameter staking_balance :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Tez_repr.t).

Parameter delegated_contracts :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list Tezos_raw_protocol_alpha.Contract_repr.t).

Parameter delegated_balance :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Tez_repr.t).

Parameter deactivated :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).

Parameter grace_period :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Cycle_repr.t).
src/proto_alpha/lib_protocol/fees_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Cannot_pay_storage_fee (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

type error += Storage_limit_too_high (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Temporary
    ~id:"contract.cannot_pay_storage_fee"
    ~title:"Cannot pay storage fee"
    ~description:"The storage fee is higher than the contract balance"
    ~pp:(fun ppf () -> Format.fprintf ppf "Cannot pay storage storage fee")
    Data_encoding.empty
    (function Cannot_pay_storage_fee -> Some () | _ -> None)
    (fun () -> Cannot_pay_storage_fee) ;
  register_error_kind
    `Temporary
    ~id:"storage_exhausted.operation"
    ~title:"Storage quota exceeded for the operation"
    ~description:
      "A script or one of its callee wrote more bytes than the operation said \
       it would"
    Data_encoding.empty
    (function Operation_quota_exceeded -> Some () | _ -> None)
    (fun () -> Operation_quota_exceeded) ;
  register_error_kind
    `Permanent
    ~id:"storage_limit_too_high"
    ~title:"Storage limit out of protocol hard bounds"
    ~description:"A transaction tried to exceed the hard limit on storage"
    empty
    (function Storage_limit_too_high -> Some () | _ -> None)
    (fun () -> Storage_limit_too_high)

let origination_burn c =
  let origination_size = Constants_storage.origination_size c in
  let cost_per_byte = Constants_storage.cost_per_byte c in
  (* the origination burn, measured in bytes *)
  Lwt.return Tez_repr.(cost_per_byte *? Int64.of_int origination_size)
  >>=? fun to_be_paid ->
  return (Raw_context.update_allocated_contracts_count c, to_be_paid)

let record_paid_storage_space c contract =
  Contract_storage.used_storage_space c contract
  >>=? fun size ->
  Contract_storage.set_paid_storage_space_and_return_fees_to_pay
    c
    contract
    size
  >>=? fun (to_be_paid, c) ->
  let c = Raw_context.update_storage_space_to_pay c to_be_paid in
  let cost_per_byte = Constants_storage.cost_per_byte c in
  Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 to_be_paid)
  >>=? fun to_burn -> return (c, size, to_be_paid, to_burn)

let burn_storage_fees c ~storage_limit ~payer =
  let origination_size = Constants_storage.origination_size c in
  let (c, storage_space_to_pay, allocated_contracts) =
    Raw_context.clear_storage_space_to_pay c
  in
  let storage_space_for_allocated_contracts =
    Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size)
  in
  let consumed =
    Z.add storage_space_to_pay storage_space_for_allocated_contracts
  in
  let remaining = Z.sub storage_limit consumed in
  if Compare.Z.(remaining < Z.zero) then fail Operation_quota_exceeded
  else
    let cost_per_byte = Constants_storage.cost_per_byte c in
    Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 consumed)
    >>=? fun to_burn ->
    (* Burning the fees... *)
    if Tez_repr.(to_burn = Tez_repr.zero) then
      (* If the payer was was deleted by transfering all its balance, and no space was used,
         burning zero would fail *)
      return c
    else
      trace
        Cannot_pay_storage_fee
        ( Contract_storage.must_exist c payer
        >>=? fun () -> Contract_storage.spend c payer to_burn )
      >>=? fun c -> return c

let check_storage_limit c ~storage_limit =
  if
    Compare.Z.(
      storage_limit
      > (Raw_context.constants c).hard_storage_limit_per_operation)
    || Compare.Z.(storage_limit < Z.zero)
  then error Storage_limit_too_high
  else ok ()

let start_counting_storage_fees c = Raw_context.init_storage_space_to_pay c
src/proto_alpha/lib_protocol/fees_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition origination_burn (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        Tezos_raw_protocol_alpha.Tez_repr.t)) :=
  let origination_size :=
    Tezos_raw_protocol_alpha.Constants_storage.origination_size c in
  let cost_per_byte :=
    Tezos_raw_protocol_alpha.Constants_storage.cost_per_byte c in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Tez_repr.op_star_question cost_per_byte
        (Tezos_protocol_environment_alpha__Environment.Int64.of_int
          origination_size)))
    (fun to_be_paid =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        ((Tezos_raw_protocol_alpha.Raw_context.update_allocated_contracts_count
          c), to_be_paid)).

Definition record_paid_storage_space
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_raw_protocol_alpha.Tez_repr.t)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Contract_storage.used_storage_space c contract)
    (fun size =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Contract_storage.set_paid_storage_space_and_return_fees_to_pay
          c contract size)
        (fun function_parameter =>
          match function_parameter with
          | (to_be_paid, c) =>
            let c :=
              Tezos_raw_protocol_alpha.Raw_context.update_storage_space_to_pay c
                to_be_paid in
            let cost_per_byte :=
              Tezos_raw_protocol_alpha.Constants_storage.cost_per_byte c in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Tez_repr.op_star_question
                  cost_per_byte
                  (Tezos_protocol_environment_alpha__Environment.Z.to_int64
                    to_be_paid)))
              (fun to_burn =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (c, size, to_be_paid, to_burn))
          end)).

Definition burn_storage_fees
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  (storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
  (payer : Tezos_raw_protocol_alpha.Contract_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let origination_size :=
    Tezos_raw_protocol_alpha.Constants_storage.origination_size c in
  match Tezos_raw_protocol_alpha.Raw_context.clear_storage_space_to_pay c with
  | (c, storage_space_to_pay, allocated_contracts) =>
    let storage_space_for_allocated_contracts :=
      Tezos_protocol_environment_alpha__Environment.Z.mul
        (Tezos_protocol_environment_alpha__Environment.Z.of_int
          allocated_contracts)
        (Tezos_protocol_environment_alpha__Environment.Z.of_int origination_size)
      in
    let consumed :=
      Tezos_protocol_environment_alpha__Environment.Z.add storage_space_to_pay
        storage_space_for_allocated_contracts in
    let remaining :=
      Tezos_protocol_environment_alpha__Environment.Z.sub storage_limit consumed
      in
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
        remaining Tezos_protocol_environment_alpha__Environment.Z.zero then
      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
        Operation_quota_exceeded
    else
      let cost_per_byte :=
        Tezos_raw_protocol_alpha.Constants_storage.cost_per_byte c in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Tez_repr.op_star_question cost_per_byte
            (Tezos_protocol_environment_alpha__Environment.Z.to_int64 consumed)))
        (fun to_burn =>
          if
            Tezos_raw_protocol_alpha.Tez_repr.op_eq to_burn
              Tezos_raw_protocol_alpha.Tez_repr.zero then
            Tezos_protocol_environment_alpha__Environment.Error_monad._return c
          else
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                Cannot_pay_storage_fee
                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Contract_storage.must_exist c payer)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      Tezos_raw_protocol_alpha.Contract_storage.spend c payer
                        to_burn
                    end)))
              (fun c =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  c))
  end.

Definition check_storage_limit
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  (storage_limit :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  if
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
      (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        storage_limit
        (hard_storage_limit_per_operation
          (Tezos_raw_protocol_alpha.Raw_context.constants c)))
      (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
        storage_limit Tezos_protocol_environment_alpha__Environment.Z.zero) then
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Storage_limit_too_high
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt.

Definition start_counting_storage_fees
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_raw_protocol_alpha.Raw_context.t :=
  Tezos_raw_protocol_alpha.Raw_context.init_storage_space_to_pay c.
src/proto_alpha/lib_protocol/fees_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Cannot_pay_storage_fee (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

type error += Storage_limit_too_high (* `Permanent *)

(** Does not burn, only adds the burn to storage space to be paid *)
val origination_burn :
  Raw_context.t -> (Raw_context.t * Tez_repr.t) tzresult Lwt.t

(** The returned Tez quantity is for logging purpose only *)
val record_paid_storage_space :
  Raw_context.t ->
  Contract_repr.t ->
  (Raw_context.t * Z.t * Z.t * Tez_repr.t) tzresult Lwt.t

val check_storage_limit : Raw_context.t -> storage_limit:Z.t -> unit tzresult

val start_counting_storage_fees : Raw_context.t -> Raw_context.t

val burn_storage_fees :
  Raw_context.t ->
  storage_limit:Z.t ->
  payer:Contract_repr.t ->
  Raw_context.t tzresult Lwt.t
src/proto_alpha/lib_protocol/fees_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

extensible_type

extensible_type

Parameter origination_burn :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        Tezos_raw_protocol_alpha.Tez_repr.t)).

Parameter record_paid_storage_space :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t *
          Tezos_protocol_environment_alpha__Environment.Z.t *
          Tezos_protocol_environment_alpha__Environment.Z.t *
          Tezos_raw_protocol_alpha.Tez_repr.t)).

Parameter check_storage_limit :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.

Parameter start_counting_storage_fees :
Tezos_raw_protocol_alpha.Raw_context.t -> Tezos_raw_protocol_alpha.Raw_context.t.

Parameter burn_storage_fees :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_raw_protocol_alpha.Contract_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).
src/proto_alpha/lib_protocol/fitness_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Invalid_fitness (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"invalid_fitness"
    ~title:"Invalid fitness"
    ~description:"Fitness representation should be exactly 8 bytes long."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid fitness")
    Data_encoding.empty
    (function Invalid_fitness -> Some () | _ -> None)
    (fun () -> Invalid_fitness)

let int64_to_bytes i =
  let b = MBytes.create 8 in
  MBytes.set_int64 b 0 i ; b

let int64_of_bytes b =
  if Compare.Int.(MBytes.length b <> 8) then error Invalid_fitness
  else ok (MBytes.get_int64 b 0)

let from_int64 fitness =
  [MBytes.of_string Constants_repr.version_number; int64_to_bytes fitness]

let to_int64 = function
  | [version; fitness]
    when Compare.String.(
           MBytes.to_string version = Constants_repr.version_number) ->
      int64_of_bytes fitness
  | [version; _fitness (* ignored since higher version takes priority *)]
    when Compare.String.(
           MBytes.to_string version = Constants_repr.version_number_004) ->
      ok 0L
  | [] ->
      ok 0L
  | _ ->
      error Invalid_fitness
src/proto_alpha/lib_protocol/fitness_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition int64_to_bytes (i : int64)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  let b := Tezos_protocol_environment_alpha__Environment.MBytes.create 8 in
  Tezos_protocol_environment_alpha__Environment.MBytes.set_int64 b 0 i;
  b.

Definition int64_of_bytes
  (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_gt)
      (Tezos_protocol_environment_alpha__Environment.MBytes.length b) 8 then
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Invalid_fitness
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      (Tezos_protocol_environment_alpha__Environment.MBytes.get_int64 b 0).

Definition from_int64 (fitness : int64)
  : list Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  cons
    (Tezos_protocol_environment_alpha__Environment.MBytes.of_string
      Tezos_raw_protocol_alpha.Constants_repr.version_number)
    (cons (int64_to_bytes fitness) []).

Definition to_int64
  (function_parameter :
    list Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
  match function_parameter with
  | cons version (cons fitness []) => int64_of_bytes fitness
  | cons version (cons _fitness []) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok 0
  | [] => Tezos_protocol_environment_alpha__Environment.Error_monad.ok 0
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Invalid_fitness
  end.
src/proto_alpha/lib_protocol/fitness_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let current = Raw_context.current_fitness

let increase ?(gap = 1) ctxt =
  let fitness = current ctxt in
  Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness)
src/proto_alpha/lib_protocol/fitness_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition current
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Int64.t :=
  Tezos_raw_protocol_alpha.Raw_context.current_fitness.

Definition increase (op_star_o_p_t_star : option Z)
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Raw_context.t :=
  let gap :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 1
    end in
  fun ctxt =>
    let fitness := current ctxt in
    Tezos_raw_protocol_alpha.Raw_context.set_current_fitness ctxt
      (Tezos_protocol_environment_alpha__Environment.Int64.add
        (Tezos_protocol_environment_alpha__Environment.Int64.of_int gap) fitness).
src/proto_alpha/lib_protocol/gas_limit_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Unaccounted | Limited of {remaining : Z.t}

type internal_gas = Z.t

type cost = {
  allocations : Z.t;
  steps : Z.t;
  reads : Z.t;
  writes : Z.t;
  bytes_read : Z.t;
  bytes_written : Z.t;
}

let encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Limited"
        z
        (function Limited {remaining} -> Some remaining | _ -> None)
        (fun remaining -> Limited {remaining});
      case
        (Tag 1)
        ~title:"Unaccounted"
        (constant "unaccounted")
        (function Unaccounted -> Some () | _ -> None)
        (fun () -> Unaccounted) ]

let pp ppf = function
  | Unaccounted ->
      Format.fprintf ppf "unaccounted"
  | Limited {remaining} ->
      Format.fprintf ppf "%s units remaining" (Z.to_string remaining)

let cost_encoding =
  let open Data_encoding in
  conv
    (fun {allocations; steps; reads; writes; bytes_read; bytes_written} ->
      (allocations, steps, reads, writes, bytes_read, bytes_written))
    (fun (allocations, steps, reads, writes, bytes_read, bytes_written) ->
      {allocations; steps; reads; writes; bytes_read; bytes_written})
    (obj6
       (req "allocations" z)
       (req "steps" z)
       (req "reads" z)
       (req "writes" z)
       (req "bytes_read" z)
       (req "bytes_written" z))

let pp_cost ppf {allocations; steps; reads; writes; bytes_read; bytes_written}
    =
  Format.fprintf
    ppf
    "(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))"
    (Z.to_string steps)
    (Z.to_string allocations)
    (Z.to_string reads)
    (Z.to_string bytes_read)
    (Z.to_string writes)
    (Z.to_string bytes_written)

type error += Block_quota_exceeded (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

let allocation_weight = Z.of_int 2

let step_weight = Z.of_int 1

let read_base_weight = Z.of_int 100

let write_base_weight = Z.of_int 160

let byte_read_weight = Z.of_int 10

let byte_written_weight = Z.of_int 15

let rescaling_bits = 7

let rescaling_mask = Z.sub (Z.shift_left Z.one rescaling_bits) Z.one

let scale (z : Z.t) = Z.shift_left z rescaling_bits

let rescale (z : Z.t) = Z.shift_right z rescaling_bits

let cost_to_internal_gas (cost : cost) : internal_gas =
  Z.add
    (Z.add
       (Z.mul cost.allocations allocation_weight)
       (Z.mul cost.steps step_weight))
    (Z.add
       (Z.add
          (Z.mul cost.reads read_base_weight)
          (Z.mul cost.writes write_base_weight))
       (Z.add
          (Z.mul cost.bytes_read byte_read_weight)
          (Z.mul cost.bytes_written byte_written_weight)))

let internal_gas_to_gas internal_gas : Z.t * internal_gas =
  let gas = rescale internal_gas in
  let rest = Z.logand internal_gas rescaling_mask in
  (gas, rest)

let consume block_gas operation_gas internal_gas cost =
  match operation_gas with
  | Unaccounted ->
      ok (block_gas, Unaccounted, internal_gas)
  | Limited {remaining} ->
      let cost_internal_gas = cost_to_internal_gas cost in
      let total_internal_gas = Z.add cost_internal_gas internal_gas in
      let (gas, rest) = internal_gas_to_gas total_internal_gas in
      if Compare.Z.(gas > Z.zero) then
        let remaining = Z.sub remaining gas in
        let block_remaining = Z.sub block_gas gas in
        if Compare.Z.(remaining < Z.zero) then error Operation_quota_exceeded
        else if Compare.Z.(block_remaining < Z.zero) then
          error Block_quota_exceeded
        else ok (block_remaining, Limited {remaining}, rest)
      else ok (block_gas, operation_gas, total_internal_gas)

let check_enough block_gas operation_gas internal_gas cost =
  consume block_gas operation_gas internal_gas cost
  >|? fun (_block_remainig, _remaining, _internal_gas) -> ()

let internal_gas_zero : internal_gas = Z.zero

let alloc_cost n =
  {
    allocations = scale (Z.of_int (n + 1));
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let alloc_bytes_cost n = alloc_cost ((n + 7) / 8)

let alloc_bits_cost n = alloc_cost ((n + 63) / 64)

let atomic_step_cost n =
  {
    allocations = Z.zero;
    steps = Z.of_int (2 * n);
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let step_cost n =
  {
    allocations = Z.zero;
    steps = scale (Z.of_int n);
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let free =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let read_bytes_cost n =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = scale Z.one;
    writes = Z.zero;
    bytes_read = scale n;
    bytes_written = Z.zero;
  }

let write_bytes_cost n =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.one;
    bytes_read = Z.zero;
    bytes_written = scale n;
  }

let ( +@ ) x y =
  {
    allocations = Z.add x.allocations y.allocations;
    steps = Z.add x.steps y.steps;
    reads = Z.add x.reads y.reads;
    writes = Z.add x.writes y.writes;
    bytes_read = Z.add x.bytes_read y.bytes_read;
    bytes_written = Z.add x.bytes_written y.bytes_written;
  }

let ( *@ ) x y =
  {
    allocations = Z.mul (Z.of_int x) y.allocations;
    steps = Z.mul (Z.of_int x) y.steps;
    reads = Z.mul (Z.of_int x) y.reads;
    writes = Z.mul (Z.of_int x) y.writes;
    bytes_read = Z.mul (Z.of_int x) y.bytes_read;
    bytes_written = Z.mul (Z.of_int x) y.bytes_written;
  }

let alloc_mbytes_cost n = alloc_cost 12 +@ alloc_bytes_cost n

let () =
  let open Data_encoding in
  register_error_kind
    `Temporary
    ~id:"gas_exhausted.operation"
    ~title:"Gas quota exceeded for the operation"
    ~description:
      "A script or one of its callee took more time than the operation said \
       it would"
    empty
    (function Operation_quota_exceeded -> Some () | _ -> None)
    (fun () -> Operation_quota_exceeded) ;
  register_error_kind
    `Temporary
    ~id:"gas_exhausted.block"
    ~title:"Gas quota exceeded for the block"
    ~description:
      "The sum of gas consumed by all the operations in the block exceeds the \
       hard gas limit per block"
    empty
    (function Block_quota_exceeded -> Some () | _ -> None)
    (fun () -> Block_quota_exceeded)
src/proto_alpha/lib_protocol/gas_limit_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Unaccounted : t
| Limited : Tezos_protocol_environment_alpha__Environment.Z.t -> t.

Definition internal_gas := Tezos_protocol_environment_alpha__Environment.Z.t.

Record cost := {
  allocations : Tezos_protocol_environment_alpha__Environment.Z.t;
  steps : Tezos_protocol_environment_alpha__Environment.Z.t;
  reads : Tezos_protocol_environment_alpha__Environment.Z.t;
  writes : Tezos_protocol_environment_alpha__Environment.Z.t;
  bytes_read : Tezos_protocol_environment_alpha__Environment.Z.t;
  bytes_written : Tezos_protocol_environment_alpha__Environment.Z.t }.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
    (cons
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        "Limited" % string None (Tag 0)
        Tezos_protocol_environment_alpha__Environment.Data_encoding.z
        (fun function_parameter =>
          match function_parameter with
          | Limited {| remaining := remaining |} => Some remaining
          | _ => None
          end) (fun remaining => Limited {| remaining := remaining |}))
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Unaccounted" % string None (Tag 1)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
            "unaccounted" % string)
          (fun function_parameter =>
            match function_parameter with
            | Unaccounted => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | tt => Unaccounted
            end)) [])).

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : t) : unit :=
  match function_parameter with
  | Unaccounted =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "unaccounted" % string
          CamlinternalFormatBasics.End_of_format) "unaccounted" % string)
  | Limited {| remaining := remaining |} =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal " units remaining" % string
            CamlinternalFormatBasics.End_of_format))
        "%s units remaining" % string)
      (Tezos_protocol_environment_alpha__Environment.Z.to_string remaining)
  end.

Definition cost_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding cost :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        allocations := allocations;
          steps := steps;
          reads := reads;
          writes := writes;
          bytes_read := bytes_read;
          bytes_written := bytes_written
          |} => (allocations, steps, reads, writes, bytes_read, bytes_written)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (allocations, steps, reads, writes, bytes_read, bytes_written) =>
        {| allocations := allocations; steps := steps; reads := reads;
          writes := writes; bytes_read := bytes_read;
          bytes_written := bytes_written |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj6
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "allocations" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "steps" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "reads" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "writes" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "bytes_read" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "bytes_written" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.z)).

Definition pp_cost
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : cost) : unit :=
  match function_parameter with
  | {|
    allocations := allocations;
      steps := steps;
      reads := reads;
      writes := writes;
      bytes_read := bytes_read;
      bytes_written := bytes_written
      |} =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "(steps: " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal ", allocs: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal ", reads: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal " (" % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          " bytes), writes: " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              " (" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " bytes))" % string
                                  CamlinternalFormatBasics.End_of_format)))))))))))))
        "(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))" %
          string)
      (Tezos_protocol_environment_alpha__Environment.Z.to_string steps)
      (Tezos_protocol_environment_alpha__Environment.Z.to_string allocations)
      (Tezos_protocol_environment_alpha__Environment.Z.to_string reads)
      (Tezos_protocol_environment_alpha__Environment.Z.to_string bytes_read)
      (Tezos_protocol_environment_alpha__Environment.Z.to_string writes)
      (Tezos_protocol_environment_alpha__Environment.Z.to_string bytes_written)
  end.

Definition allocation_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int 2.

Definition step_weight : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int 1.

Definition read_base_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int 100.

Definition write_base_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int 160.

Definition byte_read_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int 10.

Definition byte_written_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int 15.

Definition rescaling_bits : Z := 7.

Definition rescaling_mask : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.sub
    (Tezos_protocol_environment_alpha__Environment.Z.shift_left
      Tezos_protocol_environment_alpha__Environment.Z.one rescaling_bits)
    Tezos_protocol_environment_alpha__Environment.Z.one.

Definition scale (z : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.shift_left z rescaling_bits.

Definition rescale (z : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.shift_right z rescaling_bits.

Definition cost_to_internal_gas (cost : cost) : internal_gas :=
  Tezos_protocol_environment_alpha__Environment.Z.add
    (Tezos_protocol_environment_alpha__Environment.Z.add
      (Tezos_protocol_environment_alpha__Environment.Z.mul (allocations cost)
        allocation_weight)
      (Tezos_protocol_environment_alpha__Environment.Z.mul (steps cost)
        step_weight))
    (Tezos_protocol_environment_alpha__Environment.Z.add
      (Tezos_protocol_environment_alpha__Environment.Z.add
        (Tezos_protocol_environment_alpha__Environment.Z.mul (reads cost)
          read_base_weight)
        (Tezos_protocol_environment_alpha__Environment.Z.mul (writes cost)
          write_base_weight))
      (Tezos_protocol_environment_alpha__Environment.Z.add
        (Tezos_protocol_environment_alpha__Environment.Z.mul (bytes_read cost)
          byte_read_weight)
        (Tezos_protocol_environment_alpha__Environment.Z.mul
          (bytes_written cost) byte_written_weight))).

Definition internal_gas_to_gas
  (internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t * internal_gas :=
  let gas := rescale internal_gas in
  let rest :=
    Tezos_protocol_environment_alpha__Environment.Z.logand internal_gas
      rescaling_mask in
  (gas, rest).

Definition consume
  (block_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  (operation_gas : t)
  (internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  (cost : cost)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_protocol_environment_alpha__Environment.Z.t * t *
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  match operation_gas with
  | Unaccounted =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      (block_gas, Unaccounted, internal_gas)
  | Limited {| remaining := remaining |} =>
    let cost_internal_gas := cost_to_internal_gas cost in
    let total_internal_gas :=
      Tezos_protocol_environment_alpha__Environment.Z.add cost_internal_gas
        internal_gas in
    match internal_gas_to_gas total_internal_gas with
    | (gas, rest) =>
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
          gas Tezos_protocol_environment_alpha__Environment.Z.zero then
        let remaining :=
          Tezos_protocol_environment_alpha__Environment.Z.sub remaining gas in
        let block_remaining :=
          Tezos_protocol_environment_alpha__Environment.Z.sub block_gas gas in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
            remaining Tezos_protocol_environment_alpha__Environment.Z.zero then
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            Operation_quota_exceeded
        else
          if
            Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
              block_remaining
              Tezos_protocol_environment_alpha__Environment.Z.zero then
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              Block_quota_exceeded
          else
            Tezos_protocol_environment_alpha__Environment.Error_monad.ok
              (block_remaining, (Limited {| remaining := remaining |}), rest)
      else
        Tezos_protocol_environment_alpha__Environment.Error_monad.ok
          (block_gas, operation_gas, total_internal_gas)
    end
  end.

Definition check_enough
  (block_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  (operation_gas : t)
  (internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  (cost : cost)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
    (consume block_gas operation_gas internal_gas cost)
    (fun function_parameter =>
      match function_parameter with
      | (_block_remainig, _remaining, _internal_gas) => tt
      end).

Definition internal_gas_zero : internal_gas :=
  Tezos_protocol_environment_alpha__Environment.Z.zero.

Definition alloc_cost (n : Z) : cost :=
  {|
    allocations :=
      scale
        (Tezos_protocol_environment_alpha__Environment.Z.of_int
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus n 1));
    steps := Tezos_protocol_environment_alpha__Environment.Z.zero;
    reads := Tezos_protocol_environment_alpha__Environment.Z.zero;
    writes := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_read := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_written := Tezos_protocol_environment_alpha__Environment.Z.zero |}.

Definition alloc_bytes_cost (n : Z) : cost :=
  alloc_cost
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus n 7) 8).

Definition alloc_bits_cost (n : Z) : cost :=
  alloc_cost
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus n 63) 64).

Definition atomic_step_cost (n : Z) : cost :=
  {| allocations := Tezos_protocol_environment_alpha__Environment.Z.zero;
    steps :=
      Tezos_protocol_environment_alpha__Environment.Z.of_int
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star 2 n);
    reads := Tezos_protocol_environment_alpha__Environment.Z.zero;
    writes := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_read := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_written := Tezos_protocol_environment_alpha__Environment.Z.zero |}.

Definition step_cost (n : Z) : cost :=
  {| allocations := Tezos_protocol_environment_alpha__Environment.Z.zero;
    steps := scale (Tezos_protocol_environment_alpha__Environment.Z.of_int n);
    reads := Tezos_protocol_environment_alpha__Environment.Z.zero;
    writes := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_read := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_written := Tezos_protocol_environment_alpha__Environment.Z.zero |}.

Definition free : cost :=
  {| allocations := Tezos_protocol_environment_alpha__Environment.Z.zero;
    steps := Tezos_protocol_environment_alpha__Environment.Z.zero;
    reads := Tezos_protocol_environment_alpha__Environment.Z.zero;
    writes := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_read := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_written := Tezos_protocol_environment_alpha__Environment.Z.zero |}.

Definition read_bytes_cost
  (n : Tezos_protocol_environment_alpha__Environment.Z.t) : cost :=
  {| allocations := Tezos_protocol_environment_alpha__Environment.Z.zero;
    steps := Tezos_protocol_environment_alpha__Environment.Z.zero;
    reads := scale Tezos_protocol_environment_alpha__Environment.Z.one;
    writes := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_read := scale n;
    bytes_written := Tezos_protocol_environment_alpha__Environment.Z.zero |}.

Definition write_bytes_cost
  (n : Tezos_protocol_environment_alpha__Environment.Z.t) : cost :=
  {| allocations := Tezos_protocol_environment_alpha__Environment.Z.zero;
    steps := Tezos_protocol_environment_alpha__Environment.Z.zero;
    reads := Tezos_protocol_environment_alpha__Environment.Z.zero;
    writes := Tezos_protocol_environment_alpha__Environment.Z.one;
    bytes_read := Tezos_protocol_environment_alpha__Environment.Z.zero;
    bytes_written := scale n |}.

Definition op_plus_at (x : cost) (y : cost) : cost :=
  {|
    allocations :=
      Tezos_protocol_environment_alpha__Environment.Z.add (allocations x)
        (allocations y);
    steps :=
      Tezos_protocol_environment_alpha__Environment.Z.add (steps x) (steps y);
    reads :=
      Tezos_protocol_environment_alpha__Environment.Z.add (reads x) (reads y);
    writes :=
      Tezos_protocol_environment_alpha__Environment.Z.add (writes x) (writes y);
    bytes_read :=
      Tezos_protocol_environment_alpha__Environment.Z.add (bytes_read x)
        (bytes_read y);
    bytes_written :=
      Tezos_protocol_environment_alpha__Environment.Z.add (bytes_written x)
        (bytes_written y) |}.

Definition op_star_at (x : Z) (y : cost) : cost :=
  {|
    allocations :=
      Tezos_protocol_environment_alpha__Environment.Z.mul
        (Tezos_protocol_environment_alpha__Environment.Z.of_int x)
        (allocations y);
    steps :=
      Tezos_protocol_environment_alpha__Environment.Z.mul
        (Tezos_protocol_environment_alpha__Environment.Z.of_int x) (steps y);
    reads :=
      Tezos_protocol_environment_alpha__Environment.Z.mul
        (Tezos_protocol_environment_alpha__Environment.Z.of_int x) (reads y);
    writes :=
      Tezos_protocol_environment_alpha__Environment.Z.mul
        (Tezos_protocol_environment_alpha__Environment.Z.of_int x) (writes y);
    bytes_read :=
      Tezos_protocol_environment_alpha__Environment.Z.mul
        (Tezos_protocol_environment_alpha__Environment.Z.of_int x)
        (bytes_read y);
    bytes_written :=
      Tezos_protocol_environment_alpha__Environment.Z.mul
        (Tezos_protocol_environment_alpha__Environment.Z.of_int x)
        (bytes_written y) |}.

Definition alloc_mbytes_cost (n : Z) : cost :=
  op_plus_at (alloc_cost 12) (alloc_bytes_cost n).
src/proto_alpha/lib_protocol/gas_limit_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Unaccounted | Limited of {remaining : Z.t}

type internal_gas

val encoding : t Data_encoding.encoding

val pp : Format.formatter -> t -> unit

type cost

val cost_encoding : cost Data_encoding.encoding

val pp_cost : Format.formatter -> cost -> unit

type error += Block_quota_exceeded (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

val consume :
  Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult

val check_enough : Z.t -> t -> internal_gas -> cost -> unit tzresult

val internal_gas_zero : internal_gas

val free : cost

val atomic_step_cost : int -> cost

val step_cost : int -> cost

val alloc_cost : int -> cost

val alloc_bytes_cost : int -> cost

val alloc_mbytes_cost : int -> cost

val alloc_bits_cost : int -> cost

val read_bytes_cost : Z.t -> cost

val write_bytes_cost : Z.t -> cost

val ( *@ ) : int -> cost -> cost

val ( +@ ) : cost -> cost -> cost
src/proto_alpha/lib_protocol/gas_limit_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Unaccounted : t
| Limited : Tezos_protocol_environment_alpha__Environment.Z.t -> t.

Parameter internal_gas : Type.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t.

Parameter pp :
Tezos_protocol_environment_alpha__Environment.Format.formatter -> t -> unit.

Parameter cost : Type.

Parameter cost_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding cost.

Parameter pp_cost :
Tezos_protocol_environment_alpha__Environment.Format.formatter -> cost -> unit.

extensible_type

extensible_type

Parameter consume :
Tezos_protocol_environment_alpha__Environment.Z.t ->
  t ->
    internal_gas ->
      cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_protocol_environment_alpha__Environment.Z.t * t * internal_gas).

Parameter check_enough :
Tezos_protocol_environment_alpha__Environment.Z.t ->
  t ->
    internal_gas ->
      cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.

Parameter internal_gas_zero : internal_gas.

Parameter free : cost.

Parameter atomic_step_cost : Z -> cost.

Parameter step_cost : Z -> cost.

Parameter alloc_cost : Z -> cost.

Parameter alloc_bytes_cost : Z -> cost.

Parameter alloc_mbytes_cost : Z -> cost.

Parameter alloc_bits_cost : Z -> cost.

Parameter read_bytes_cost :
Tezos_protocol_environment_alpha__Environment.Z.t -> cost.

Parameter write_bytes_cost :
Tezos_protocol_environment_alpha__Environment.Z.t -> cost.

Parameter op_star_at : Z -> cost -> cost.

Parameter op_plus_at : cost -> cost -> cost.
src/proto_alpha/lib_protocol/helpers_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type error += Cannot_parse_operation (* `Branch *)

let () =
  register_error_kind
    `Branch
    ~id:"operation.cannot_parse"
    ~title:"Cannot parse operation"
    ~description:"The operation is ill-formed or for another protocol version"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation cannot be parsed")
    Data_encoding.unit
    (function Cannot_parse_operation -> Some () | _ -> None)
    (fun () -> Cannot_parse_operation)

let parse_operation (op : Operation.raw) =
  match
    Data_encoding.Binary.of_bytes Operation.protocol_data_encoding op.proto
  with
  | Some protocol_data ->
      ok {shell = op.shell; protocol_data}
  | None ->
      error Cannot_parse_operation

let path = RPC_path.(open_root / "helpers")

module Scripts = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "scripts")

    let run_code_input_encoding =
      obj9
        (req "script" Script.expr_encoding)
        (req "storage" Script.expr_encoding)
        (req "input" Script.expr_encoding)
        (req "amount" Tez.encoding)
        (req "chain_id" Chain_id.encoding)
        (opt "source" Contract.encoding)
        (opt "payer" Contract.encoding)
        (opt "gas" z)
        (dft "entrypoint" string "default")

    let trace_encoding =
      def "scripted.trace" @@ list
      @@ obj3
           (req "location" Script.location_encoding)
           (req "gas" Gas.encoding)
           (req
              "stack"
              (list
                 (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))

    let run_code =
      RPC_service.post_service
        ~description:"Run a piece of code in the current context"
        ~query:RPC_query.empty
        ~input:run_code_input_encoding
        ~output:
          (obj3
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (opt "big_map_diff" Contract.big_map_diff_encoding))
        RPC_path.(path / "run_code")

    let trace_code =
      RPC_service.post_service
        ~description:
          "Run a piece of code in the current context, keeping a trace"
        ~query:RPC_query.empty
        ~input:run_code_input_encoding
        ~output:
          (obj4
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (req "trace" trace_encoding)
             (opt "big_map_diff" Contract.big_map_diff_encoding))
        RPC_path.(path / "trace_code")

    let typecheck_code =
      RPC_service.post_service
        ~description:"Typecheck a piece of code in the current context"
        ~query:RPC_query.empty
        ~input:(obj2 (req "program" Script.expr_encoding) (opt "gas" z))
        ~output:
          (obj2
             (req "type_map" Script_tc_errors_registration.type_map_enc)
             (req "gas" Gas.encoding))
        RPC_path.(path / "typecheck_code")

    let typecheck_data =
      RPC_service.post_service
        ~description:
          "Check that some data expression is well formed and of a given type \
           in the current context"
        ~query:RPC_query.empty
        ~input:
          (obj3
             (req "data" Script.expr_encoding)
             (req "type" Script.expr_encoding)
             (opt "gas" z))
        ~output:(obj1 (req "gas" Gas.encoding))
        RPC_path.(path / "typecheck_data")

    let pack_data =
      RPC_service.post_service
        ~description:
          "Computes the serialized version of some data expression using the \
           same algorithm as script instruction PACK"
        ~input:
          (obj3
             (req "data" Script.expr_encoding)
             (req "type" Script.expr_encoding)
             (opt "gas" z))
        ~output:(obj2 (req "packed" bytes) (req "gas" Gas.encoding))
        ~query:RPC_query.empty
        RPC_path.(path / "pack_data")

    let run_operation =
      RPC_service.post_service
        ~description:"Run an operation without signature checks"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "operation" Operation.encoding)
             (req "chain_id" Chain_id.encoding))
        ~output:Apply_results.operation_data_and_metadata_encoding
        RPC_path.(path / "run_operation")

    let entrypoint_type =
      RPC_service.post_service
        ~description:"Return the type of the given entrypoint"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "script" Script.expr_encoding)
             (dft "entrypoint" string "default"))
        ~output:(obj1 (req "entrypoint_type" Script.expr_encoding))
        RPC_path.(path / "entrypoint")

    let list_entrypoints =
      RPC_service.post_service
        ~description:"Return the list of entrypoints of the given script"
        ~query:RPC_query.empty
        ~input:(obj1 (req "script" Script.expr_encoding))
        ~output:
          (obj2
             (dft
                "unreachable"
                (Data_encoding.list
                   (obj1
                      (req
                         "path"
                         (Data_encoding.list
                            Michelson_v1_primitives.prim_encoding))))
                [])
             (req "entrypoints" (assoc Script.expr_encoding)))
        RPC_path.(path / "entrypoints")
  end

  let register () =
    let open Services_registration in
    let originate_dummy_contract ctxt script =
      let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, dummy_contract) ->
      let balance =
        match Tez.of_mutez 4_000_000_000_000L with
        | Some balance ->
            balance
        | None ->
            assert false
      in
      Contract.originate
        ctxt
        dummy_contract
        ~balance
        ~delegate:None
        ~script:(script, None)
      >>=? fun ctxt -> return (ctxt, dummy_contract)
    in
    register0
      S.run_code
      (fun ctxt
           ()
           ( code,
             storage,
             parameter,
             amount,
             chain_id,
             source,
             payer,
             gas,
             entrypoint )
           ->
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code}
        >>=? fun (ctxt, dummy_contract) ->
        let (source, payer) =
          match (source, payer) with
          | (Some source, Some payer) ->
              (source, payer)
          | (Some source, None) ->
              (source, source)
          | (None, Some payer) ->
              (payer, payer)
          | (None, None) ->
              (dummy_contract, dummy_contract)
        in
        let gas =
          match gas with
          | Some gas ->
              gas
          | None ->
              Constants.hard_gas_limit_per_operation ctxt
        in
        let ctxt = Gas.set_limit ctxt gas in
        let step_constants =
          let open Script_interpreter in
          {source; payer; self = dummy_contract; amount; chain_id}
        in
        Script_interpreter.execute
          ctxt
          Readable
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >>=? fun {Script_interpreter.storage; operations; big_map_diff; _} ->
        return (storage, operations, big_map_diff)) ;
    register0
      S.trace_code
      (fun ctxt
           ()
           ( code,
             storage,
             parameter,
             amount,
             chain_id,
             source,
             payer,
             gas,
             entrypoint )
           ->
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code}
        >>=? fun (ctxt, dummy_contract) ->
        let (source, payer) =
          match (source, payer) with
          | (Some source, Some payer) ->
              (source, payer)
          | (Some source, None) ->
              (source, source)
          | (None, Some payer) ->
              (payer, payer)
          | (None, None) ->
              (dummy_contract, dummy_contract)
        in
        let gas =
          match gas with
          | Some gas ->
              gas
          | None ->
              Constants.hard_gas_limit_per_operation ctxt
        in
        let ctxt = Gas.set_limit ctxt gas in
        let step_constants =
          let open Script_interpreter in
          {source; payer; self = dummy_contract; amount; chain_id}
        in
        Script_interpreter.trace
          ctxt
          Readable
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >>=? fun ( {Script_interpreter.storage; operations; big_map_diff; _},
                   trace ) ->
        return (storage, operations, trace, big_map_diff)) ;
    register0 S.typecheck_code (fun ctxt () (expr, maybe_gas) ->
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Script_ir_translator.typecheck_code ctxt expr
        >>=? fun (res, ctxt) -> return (res, Gas.level ctxt)) ;
    register0 S.typecheck_data (fun ctxt () (data, ty, maybe_gas) ->
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Script_ir_translator.typecheck_data ctxt (data, ty)
        >>=? fun ctxt -> return (Gas.level ctxt)) ;
    register0 S.pack_data (fun ctxt () (expr, typ, maybe_gas) ->
        let open Script_ir_translator in
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ))
        >>=? fun (Ex_ty typ, ctxt) ->
        parse_data ctxt ~legacy:true typ (Micheline.root expr)
        >>=? fun (data, ctxt) ->
        Script_ir_translator.pack_data ctxt typ data
        >>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt)) ;
    register0
      S.run_operation
      (fun ctxt
           ()
           ({shell; protocol_data = Operation_data protocol_data}, chain_id)
           ->
        (* this code is a duplicate of Apply without signature check *)
        let partial_precheck_manager_contents (type kind) ctxt
            (op : kind Kind.manager contents) : context tzresult Lwt.t =
          let (Manager_operation
                {source; fee; counter; operation; gas_limit; storage_limit}) =
            op
          in
          Lwt.return (Gas.check_limit ctxt gas_limit)
          >>=? fun () ->
          let ctxt = Gas.set_limit ctxt gas_limit in
          Lwt.return (Fees.check_storage_limit ctxt storage_limit)
          >>=? fun () ->
          Contract.must_be_allocated ctxt (Contract.implicit_contract source)
          >>=? fun () ->
          Contract.check_counter_increment ctxt source counter
          >>=? fun () ->
          ( match operation with
          | Reveal pk ->
              Contract.reveal_manager_key ctxt source pk
          | Transaction {parameters; _} ->
              (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
              let arg_bytes =
                Data_encoding.Binary.to_bytes_exn
                  Script.lazy_expr_encoding
                  parameters
              in
              let arg =
                match
                  Data_encoding.Binary.of_bytes
                    Script.lazy_expr_encoding
                    arg_bytes
                with
                | Some arg ->
                    arg
                | None ->
                    assert false
              in
              (* Fail quickly if not enough gas for minimal deserialization cost *)
              Lwt.return
              @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost arg)
              >>=? fun () ->
              (* Fail if not enough gas for complete deserialization cost *)
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt arg
              >>|? fun (_arg, ctxt) -> ctxt
          | Origination {script; _} ->
              (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
              let script_bytes =
                Data_encoding.Binary.to_bytes_exn Script.encoding script
              in
              let script =
                match
                  Data_encoding.Binary.of_bytes Script.encoding script_bytes
                with
                | Some script ->
                    script
                | None ->
                    assert false
              in
              (* Fail quickly if not enough gas for minimal deserialization cost *)
              Lwt.return
              @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
              @@ ( Gas.consume
                     ctxt
                     (Script.minimal_deserialize_cost script.code)
                 >>? fun ctxt ->
                 Gas.check_enough
                   ctxt
                   (Script.minimal_deserialize_cost script.storage) )
              >>=? fun () ->
              (* Fail if not enough gas for complete deserialization cost *)
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt script.code
              >>=? fun (_code, ctxt) ->
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt script.storage
              >>|? fun (_storage, ctxt) -> ctxt
          | _ ->
              return ctxt )
          >>=? fun ctxt ->
          Contract.get_manager_key ctxt source
          >>=? fun _public_key ->
          (* signature check unplugged from here *)
          Contract.increment_counter ctxt source
          >>=? fun ctxt ->
          Contract.spend ctxt (Contract.implicit_contract source) fee
          >>=? fun ctxt -> return ctxt
        in
        let rec partial_precheck_manager_contents_list :
            type kind.
            Alpha_context.t ->
            kind Kind.manager contents_list ->
            context tzresult Lwt.t =
         fun ctxt contents_list ->
          match contents_list with
          | Single (Manager_operation _ as op) ->
              partial_precheck_manager_contents ctxt op
          | Cons ((Manager_operation _ as op), rest) ->
              partial_precheck_manager_contents ctxt op
              >>=? fun ctxt -> partial_precheck_manager_contents_list ctxt rest
        in
        let return contents =
          return
            ( Operation_data protocol_data,
              Apply_results.Operation_metadata {contents} )
        in
        let operation : _ operation = {shell; protocol_data} in
        let hash = Operation.hash {shell; protocol_data} in
        let ctxt = Contract.init_origination_nonce ctxt hash in
        let baker = Signature.Public_key_hash.zero in
        match protocol_data.contents with
        | Single (Manager_operation _) as op ->
            partial_precheck_manager_contents_list ctxt op
            >>=? fun ctxt ->
            Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
            >>= fun (_ctxt, result) -> return result
        | Cons (Manager_operation _, _) as op ->
            partial_precheck_manager_contents_list ctxt op
            >>=? fun ctxt ->
            Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
            >>= fun (_ctxt, result) -> return result
        | _ ->
            Apply.apply_contents_list
              ctxt
              chain_id
              Optimized
              shell.branch
              baker
              operation
              operation.protocol_data.contents
            >>=? fun (_ctxt, result) -> return result) ;
    register0 S.entrypoint_type (fun ctxt () (expr, entrypoint) ->
        let ctxt = Gas.set_unlimited ctxt in
        let legacy = false in
        let open Script_ir_translator in
        Lwt.return
          ( parse_toplevel ~legacy expr
          >>? fun (arg_type, _, _, root_name) ->
          parse_ty
            ctxt
            ~legacy
            ~allow_big_map:true
            ~allow_operation:false
            ~allow_contract:true
            arg_type
          >>? fun (Ex_ty arg_type, _) ->
          Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
          )
        >>=? fun (_f, Ex_ty ty) ->
        unparse_ty ctxt ty
        >>=? fun (ty_node, _) -> return (Micheline.strip_locations ty_node)) ;
    register0 S.list_entrypoints (fun ctxt () expr ->
        let ctxt = Gas.set_unlimited ctxt in
        let legacy = false in
        let open Script_ir_translator in
        Lwt.return
          ( parse_toplevel ~legacy expr
          >>? fun (arg_type, _, _, root_name) ->
          parse_ty
            ctxt
            ~legacy
            ~allow_big_map:true
            ~allow_operation:false
            ~allow_contract:true
            arg_type
          >>? fun (Ex_ty arg_type, _) ->
          Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
        >>=? fun (unreachable_entrypoint, map) ->
        return
          ( unreachable_entrypoint,
            Entrypoints_map.fold
              (fun entry (_, ty) acc ->
                (entry, Micheline.strip_locations ty) :: acc)
              map
              [] ))

  let run_code ctxt block code
      (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
    RPC_context.make_call0
      S.run_code
      ctxt
      block
      ()
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)

  let trace_code ctxt block code
      (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
    RPC_context.make_call0
      S.trace_code
      ctxt
      block
      ()
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)

  let typecheck_code ctxt block =
    RPC_context.make_call0 S.typecheck_code ctxt block ()

  let typecheck_data ctxt block =
    RPC_context.make_call0 S.typecheck_data ctxt block ()

  let pack_data ctxt block = RPC_context.make_call0 S.pack_data ctxt block ()

  let run_operation ctxt block =
    RPC_context.make_call0 S.run_operation ctxt block ()

  let entrypoint_type ctxt block =
    RPC_context.make_call0 S.entrypoint_type ctxt block ()

  let list_entrypoints ctxt block =
    RPC_context.make_call0 S.list_entrypoints ctxt block ()
end

module Forge = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "forge")

    let operations =
      RPC_service.post_service
        ~description:"Forge an operation"
        ~query:RPC_query.empty
        ~input:Operation.unsigned_encoding
        ~output:bytes
        RPC_path.(path / "operations")

    let empty_proof_of_work_nonce =
      MBytes.of_string
        (String.make Constants_repr.proof_of_work_nonce_size '\000')

    let protocol_data =
      RPC_service.post_service
        ~description:"Forge the protocol-specific part of a block header"
        ~query:RPC_query.empty
        ~input:
          (obj3
             (req "priority" uint16)
             (opt "nonce_hash" Nonce_hash.encoding)
             (dft
                "proof_of_work_nonce"
                (Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size)
                empty_proof_of_work_nonce))
        ~output:(obj1 (req "protocol_data" bytes))
        RPC_path.(path / "protocol_data")
  end

  let register () =
    let open Services_registration in
    register0_noctxt S.operations (fun () (shell, proto) ->
        return
          (Data_encoding.Binary.to_bytes_exn
             Operation.unsigned_encoding
             (shell, proto))) ;
    register0_noctxt
      S.protocol_data
      (fun () (priority, seed_nonce_hash, proof_of_work_nonce) ->
        return
          (Data_encoding.Binary.to_bytes_exn
             Block_header.contents_encoding
             {priority; seed_nonce_hash; proof_of_work_nonce}))

  module Manager = struct
    let operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
        ~gas_limit ~storage_limit operations =
      Contract_services.manager_key ctxt block source
      >>= function
      | Error _ as e ->
          Lwt.return e
      | Ok revealed ->
          let ops =
            List.map
              (fun (Manager operation) ->
                Contents
                  (Manager_operation
                     {
                       source;
                       counter;
                       operation;
                       fee;
                       gas_limit;
                       storage_limit;
                     }))
              operations
          in
          let ops =
            match (sourcePubKey, revealed) with
            | (None, _) | (_, Some _) ->
                ops
            | (Some pk, None) ->
                let operation = Reveal pk in
                Contents
                  (Manager_operation
                     {
                       source;
                       counter;
                       operation;
                       fee;
                       gas_limit;
                       storage_limit;
                     })
                :: ops
          in
          RPC_context.make_call0
            S.operations
            ctxt
            block
            ()
            ({branch}, Operation.of_list ops)

    let reveal ctxt block ~branch ~source ~sourcePubKey ~counter ~fee () =
      operations
        ctxt
        block
        ~branch
        ~source
        ~sourcePubKey
        ~counter
        ~fee
        ~gas_limit:Z.zero
        ~storage_limit:Z.zero
        []

    let transaction ctxt block ~branch ~source ?sourcePubKey ~counter ~amount
        ~destination ?(entrypoint = "default") ?parameters ~gas_limit
        ~storage_limit ~fee () =
      let parameters =
        Option.unopt_map
          ~f:Script.lazy_expr
          ~default:Script.unit_parameter
          parameters
      in
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit
        ~storage_limit
        [Manager (Transaction {amount; parameters; destination; entrypoint})]

    let origination ctxt block ~branch ~source ?sourcePubKey ~counter ~balance
        ?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () =
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit
        ~storage_limit
        [ Manager
            (Origination
               {
                 delegate = delegatePubKey;
                 script;
                 credit = balance;
                 preorigination = None;
               }) ]

    let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
        delegate =
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit:Z.zero
        ~storage_limit:Z.zero
        [Manager (Delegation delegate)]
  end

  let operation ctxt block ~branch operation =
    RPC_context.make_call0
      S.operations
      ctxt
      block
      ()
      ({branch}, Contents_list (Single operation))

  let endorsement ctxt b ~branch ~level () =
    operation ctxt b ~branch (Endorsement {level})

  let proposals ctxt b ~branch ~source ~period ~proposals () =
    operation ctxt b ~branch (Proposals {source; period; proposals})

  let ballot ctxt b ~branch ~source ~period ~proposal ~ballot () =
    operation ctxt b ~branch (Ballot {source; period; proposal; ballot})

  let seed_nonce_revelation ctxt block ~branch ~level ~nonce () =
    operation ctxt block ~branch (Seed_nonce_revelation {level; nonce})

  let double_baking_evidence ctxt block ~branch ~bh1 ~bh2 () =
    operation ctxt block ~branch (Double_baking_evidence {bh1; bh2})

  let double_endorsement_evidence ctxt block ~branch ~op1 ~op2 () =
    operation ctxt block ~branch (Double_endorsement_evidence {op1; op2})

  let empty_proof_of_work_nonce =
    MBytes.of_string
      (String.make Constants_repr.proof_of_work_nonce_size '\000')

  let protocol_data ctxt block ~priority ?seed_nonce_hash
      ?(proof_of_work_nonce = empty_proof_of_work_nonce) () =
    RPC_context.make_call0
      S.protocol_data
      ctxt
      block
      ()
      (priority, seed_nonce_hash, proof_of_work_nonce)
end

module Parse = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "parse")

    let operations =
      RPC_service.post_service
        ~description:"Parse operations"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "operations" (list (dynamic_size Operation.raw_encoding)))
             (opt "check_signature" bool))
        ~output:(list (dynamic_size Operation.encoding))
        RPC_path.(path / "operations")

    let block =
      RPC_service.post_service
        ~description:"Parse a block"
        ~query:RPC_query.empty
        ~input:Block_header.raw_encoding
        ~output:Block_header.protocol_data_encoding
        RPC_path.(path / "block")
  end

  let parse_protocol_data protocol_data =
    match
      Data_encoding.Binary.of_bytes
        Block_header.protocol_data_encoding
        protocol_data
    with
    | None ->
        failwith "Cant_parse_protocol_data"
    | Some protocol_data ->
        return protocol_data

  let register () =
    let open Services_registration in
    register0 S.operations (fun _ctxt () (operations, check) ->
        map_s
          (fun raw ->
            Lwt.return (parse_operation raw)
            >>=? fun op ->
            ( match check with
            | Some true ->
                return_unit (* FIXME *)
            (* I.check_signature ctxt *)
            (* op.protocol_data.signature op.shell op.protocol_data.contents *)
            | Some false | None ->
                return_unit )
            >>|? fun () -> op)
          operations) ;
    register0_noctxt S.block (fun () raw_block ->
        parse_protocol_data raw_block.protocol_data)

  let operations ctxt block ?check operations =
    RPC_context.make_call0 S.operations ctxt block () (operations, check)

  let block ctxt block shell protocol_data =
    RPC_context.make_call0
      S.block
      ctxt
      block
      ()
      ({shell; protocol_data} : Block_header.raw)
end

module S = struct
  open Data_encoding

  type level_query = {offset : int32}

  let level_query : level_query RPC_query.t =
    let open RPC_query in
    query (fun offset -> {offset})
    |+ field "offset" RPC_arg.int32 0l (fun t -> t.offset)
    |> seal

  let current_level =
    RPC_service.get_service
      ~description:
        "Returns the level of the interrogated block, or the one of a block \
         located `offset` blocks after in the chain (or before when \
         negative). For instance, the next block if `offset` is 1."
      ~query:level_query
      ~output:Level.encoding
      RPC_path.(path / "current_level")

  let levels_in_current_cycle =
    RPC_service.get_service
      ~description:"Levels of a cycle"
      ~query:level_query
      ~output:
        (obj2 (req "first" Raw_level.encoding) (req "last" Raw_level.encoding))
      RPC_path.(path / "levels_in_current_cycle")
end

let register () =
  Scripts.register () ;
  Forge.register () ;
  Parse.register () ;
  let open Services_registration in
  register0 S.current_level (fun ctxt q () ->
      let level = Level.current ctxt in
      return (Level.from_raw ctxt ~offset:q.offset level.level)) ;
  register0 S.levels_in_current_cycle (fun ctxt q () ->
      let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in
      match levels with
      | [] ->
          raise Not_found
      | _ ->
          let first = List.hd (List.rev levels) in
          let last = List.hd levels in
          return (first.level, last.level))

let current_level ctxt ?(offset = 0l) block =
  RPC_context.make_call0 S.current_level ctxt block {offset} ()

let levels_in_current_cycle ctxt ?(offset = 0l) block =
  RPC_context.make_call0 S.levels_in_current_cycle ctxt block {offset} ()
src/proto_alpha/lib_protocol/helpers_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Definition parse_operation
  (op : Tezos_raw_protocol_alpha.Alpha_context.Operation.raw)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_raw_protocol_alpha.Alpha_context.packed_operation :=
  match
    Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
      Tezos_raw_protocol_alpha.Alpha_context.Operation.protocol_data_encoding
      (proto op) with
  | Some protocol_data =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      {| shell := shell op; protocol_data := protocol_data |}
  | None =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Cannot_parse_operation
  end.

Definition path
  : Tezos_protocol_environment_alpha__Environment.RPC_path.path
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
  Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
    Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
    "helpers" % string.

Module Scripts.
  Module S.
    Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
    
    Definition path
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "scripts" % string.
    
    Definition run_code_input_encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_protocol_environment_alpha__Environment.Z.t) * string) :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.obj9
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "script" % string
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "storage" % string
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "input" % string
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "amount" % string
          Tezos_raw_protocol_alpha.Alpha_context.Tez.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "chain_id" % string
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "source" % string
          Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "payer" % string
          Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "gas" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.z)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "entrypoint" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.string
          "default" % string).
    
    Definition trace_encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        (list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
            (list
              (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                (option string))))) :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        (let arg :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.def
            "scripted.trace" % string in
        fun eta => arg None None eta)
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          (let arg :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.list in
          fun eta => arg None eta)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "location" % string
              Tezos_raw_protocol_alpha.Alpha_context.Script.location_encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "gas" % string
              Tezos_raw_protocol_alpha.Alpha_context.Gas.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "stack" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                None
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                    None None "item" % string
                    Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt
                    None None "annot" % string
                    Tezos_protocol_environment_alpha__Environment.Data_encoding.string)))))).
    
    Definition run_code
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (list
            Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Run a piece of code in the current context" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        run_code_input_encoding
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "storage" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "operations" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
              None
              Tezos_raw_protocol_alpha.Alpha_context.Operation.internal_operation_encoding))
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
            None "big_map_diff" % string
            Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_encoding))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "run_code" % string).
    
    Definition trace_code
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (list
            Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
          (list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
              Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
              (list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                  (option string))))) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some
          "Run a piece of code in the current context, keeping a trace" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        run_code_input_encoding
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "storage" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "operations" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
              None
              Tezos_raw_protocol_alpha.Alpha_context.Operation.internal_operation_encoding))
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "trace" % string trace_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
            None "big_map_diff" % string
            Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_encoding))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "trace_code" % string).
    
    Definition typecheck_code
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (option Tezos_protocol_environment_alpha__Environment.Z.t))
        ((list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            ((list
              (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                (list string))) *
              (list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                  (list string)))))) *
          Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Typecheck a piece of code in the current context" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "program" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
            None "gas" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.z))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "type_map" % string
            Tezos_raw_protocol_alpha.Script_tc_errors_registration.type_map_enc)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "gas" % string
            Tezos_raw_protocol_alpha.Alpha_context.Gas.encoding))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "typecheck_code" % string).
    
    Definition typecheck_data
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (option Tezos_protocol_environment_alpha__Environment.Z.t))
        Tezos_raw_protocol_alpha.Alpha_context.Gas.t :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some
          "Check that some data expression is well formed and of a given type in the current context"
            % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "data" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "type" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
            None "gas" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.z))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "gas" % string
            Tezos_raw_protocol_alpha.Alpha_context.Gas.encoding))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "typecheck_data" % string).
    
    Definition pack_data
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (option Tezos_protocol_environment_alpha__Environment.Z.t))
        (Tezos_protocol_environment_alpha__Environment.MBytes.t *
          Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some
          "Computes the serialized version of some data expression using the same algorithm as script instruction PACK"
            % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "data" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "type" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
            None "gas" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.z))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "packed" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.bytes)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "gas" % string
            Tezos_raw_protocol_alpha.Alpha_context.Gas.encoding))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "pack_data" % string).
    
    Definition run_operation
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
        (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data *
          Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Run an operation without signature checks" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "operation" % string
            Tezos_raw_protocol_alpha.Alpha_context.Operation.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "chain_id" % string
            Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)))
        Tezos_raw_protocol_alpha.Apply_results.operation_data_and_metadata_encoding
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "run_operation" % string).
    
    Definition entrypoint_type
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * string)
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Return the type of the given entrypoint" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "script" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
            None "entrypoint" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.string
            "default" % string))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "entrypoint_type" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "entrypoint" % string).
    
    Definition list_entrypoints
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr
        ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
          (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Return the list of entrypoints of the given script" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "script" % string
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
            None "unreachable" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
              None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "path" % string
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                    None
                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim_encoding))))
            [])
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "entrypoints" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.assoc
              Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "entrypoints" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      let originate_dummy_contract
        (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (script :
        Tezos_raw_protocol_alpha__Alpha_context.Script.t)
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha__Alpha_context.context *
              Tezos_raw_protocol_alpha.Alpha_context.Contract.t)) :=
        let ctxt :=
          Tezos_raw_protocol_alpha.Alpha_context.Contract.init_origination_nonce
            ctxt
            Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
          in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Contract.fresh_contract_from_current_nonce
            ctxt)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, dummy_contract) =>
              let balance :=
                match
                  Tezos_raw_protocol_alpha.Alpha_context.Tez.of_mutez
                    4000000000000 with
                | Some balance => balance
                | None => false
                end in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Alpha_context.Contract.originate ctxt
                  dummy_contract balance (script, None) None)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (ctxt, dummy_contract))
            end) in
      Tezos_raw_protocol_alpha.Services_registration.register0 S.run_code
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                |
                  (code, storage, parameter, amount, chain_id, source, payer,
                    gas, entrypoint) =>
                  let storage :=
                    Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                      storage in
                  let code :=
                    Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr code
                    in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (originate_dummy_contract ctxt
                      {| code := code; storage := storage |})
                    (fun function_parameter =>
                      match function_parameter with
                      | (ctxt, dummy_contract) =>
                        match
                          match (source, payer) with
                          | (Some source, Some payer) => (source, payer)
                          | (Some source, None) => (source, source)
                          | (None, Some payer) => (payer, payer)
                          | (None, None) => (dummy_contract, dummy_contract)
                          end with
                        | (source, payer) =>
                          let gas :=
                            match gas with
                            | Some gas => gas
                            | None =>
                              Tezos_raw_protocol_alpha.Alpha_context.Constants.hard_gas_limit_per_operation
                                ctxt
                            end in
                          let ctxt :=
                            Tezos_raw_protocol_alpha.Alpha_context.Gas.set_limit
                              ctxt gas in
                          let step_constants :=
                            {| source := source; payer := payer;
                              self := dummy_contract; amount := amount;
                              chain_id := chain_id |} in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Script_interpreter.execute
                              ctxt Readable step_constants
                              {| code := code; storage := storage |} entrypoint
                              parameter)
                            (fun function_parameter =>
                              match function_parameter with
                              | {|
                                Script_interpreter.storage := storage;
                                  Script_interpreter.big_map_diff :=
                                    big_map_diff;
                                  Script_interpreter.operations := operations
                                  |} =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  (storage, operations, big_map_diff)
                              end)
                        end
                      end)
                end
            end);
      Tezos_raw_protocol_alpha.Services_registration.register0 S.trace_code
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                |
                  (code, storage, parameter, amount, chain_id, source, payer,
                    gas, entrypoint) =>
                  let storage :=
                    Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                      storage in
                  let code :=
                    Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr code
                    in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (originate_dummy_contract ctxt
                      {| code := code; storage := storage |})
                    (fun function_parameter =>
                      match function_parameter with
                      | (ctxt, dummy_contract) =>
                        match
                          match (source, payer) with
                          | (Some source, Some payer) => (source, payer)
                          | (Some source, None) => (source, source)
                          | (None, Some payer) => (payer, payer)
                          | (None, None) => (dummy_contract, dummy_contract)
                          end with
                        | (source, payer) =>
                          let gas :=
                            match gas with
                            | Some gas => gas
                            | None =>
                              Tezos_raw_protocol_alpha.Alpha_context.Constants.hard_gas_limit_per_operation
                                ctxt
                            end in
                          let ctxt :=
                            Tezos_raw_protocol_alpha.Alpha_context.Gas.set_limit
                              ctxt gas in
                          let step_constants :=
                            {| source := source; payer := payer;
                              self := dummy_contract; amount := amount;
                              chain_id := chain_id |} in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Script_interpreter.trace
                              ctxt Readable step_constants
                              {| code := code; storage := storage |} entrypoint
                              parameter)
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                ({|
                                  Script_interpreter.storage := storage;
                                    Script_interpreter.big_map_diff :=
                                      big_map_diff;
                                    Script_interpreter.operations := operations
                                    |}, trace) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  (storage, operations, trace, big_map_diff)
                              end)
                        end
                      end)
                end
            end);
      Tezos_raw_protocol_alpha.Services_registration.register0 S.typecheck_code
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (expr, maybe_gas) =>
                  let ctxt :=
                    match maybe_gas with
                    | None =>
                      Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                        ctxt
                    | Some gas =>
                      Tezos_raw_protocol_alpha.Alpha_context.Gas.set_limit ctxt
                        gas
                    end in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Script_ir_translator.typecheck_code
                      ctxt expr)
                    (fun function_parameter =>
                      match function_parameter with
                      | (res, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (res,
                            (Tezos_raw_protocol_alpha.Alpha_context.Gas.level
                              ctxt))
                      end)
                end
            end);
      Tezos_raw_protocol_alpha.Services_registration.register0 S.typecheck_data
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (data, ty, maybe_gas) =>
                  let ctxt :=
                    match maybe_gas with
                    | None =>
                      Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                        ctxt
                    | Some gas =>
                      Tezos_raw_protocol_alpha.Alpha_context.Gas.set_limit ctxt
                        gas
                    end in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Script_ir_translator.typecheck_data
                      None ctxt (data, ty))
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.level ctxt))
                end
            end);
      Tezos_raw_protocol_alpha.Services_registration.register0 S.pack_data
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (expr, typ, maybe_gas) =>
                  let ctxt :=
                    match maybe_gas with
                    | None =>
                      Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                        ctxt
                    | Some gas =>
                      Tezos_raw_protocol_alpha.Alpha_context.Gas.set_limit ctxt
                        gas
                    end in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Script_ir_translator.parse_packable_ty
                        ctxt true
                        (Tezos_protocol_environment_alpha__Environment.Micheline.root
                          typ)))
                    (fun function_parameter =>
                      match function_parameter with
                      | (Ex_ty typ, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Script_ir_translator.parse_data
                            None ctxt true typ
                            (Tezos_protocol_environment_alpha__Environment.Micheline.root
                              expr))
                          (fun function_parameter =>
                            match function_parameter with
                            | (data, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Script_ir_translator.pack_data
                                  ctxt typ data)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (bytes, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                      (string,
                                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.level
                                          ctxt))
                                  end)
                            end)
                      end)
                end
            end);
      Tezos_raw_protocol_alpha.Services_registration.register0 S.run_operation
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                |
                  ({|
                    shell := shell;
                      protocol_data := Operation_data protocol_data
                      |}, chain_id) =>
                  let partial_precheck_manager_contents {A : Type}
                    (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (op
                    :
                    Tezos_raw_protocol_alpha.Alpha_context.contents
                      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
                    : Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                        Tezos_raw_protocol_alpha.Alpha_context.context) :=
                    match op with
                    |
                      Manager_operation {|
                        source := source;
                          fee := fee;
                          counter := counter;
                          operation := operation;
                          gas_limit := gas_limit;
                          storage_limit := storage_limit
                          |} =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Alpha_context.Gas.check_limit
                            ctxt gas_limit))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            let ctxt :=
                              Tezos_raw_protocol_alpha.Alpha_context.Gas.set_limit
                                ctxt gas_limit in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                (Tezos_raw_protocol_alpha.Alpha_context.Fees.check_storage_limit
                                  ctxt storage_limit))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.must_be_allocated
                                      ctxt
                                      (Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract
                                        source))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Alpha_context.Contract.check_counter_increment
                                            ctxt source counter)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                match operation with
                                                | Reveal pk =>
                                                  Tezos_raw_protocol_alpha.Alpha_context.Contract.reveal_manager_key
                                                    ctxt source pk
                                                |
                                                  Transaction {|
                                                    parameters := parameters
                                                      |} =>
                                                  let arg_bytes :=
                                                    Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr_encoding
                                                      parameters in
                                                  let arg :=
                                                    match
                                                      Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr_encoding
                                                        arg_bytes with
                                                    | Some arg => arg
                                                    | None => false
                                                    end in
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
                                                          Apply.Gas_quota_exceeded_init_deserialize)
                                                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.check_enough
                                                          ctxt
                                                          (Tezos_raw_protocol_alpha.Alpha_context.Script.minimal_deserialize_cost
                                                            arg))))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                                              Apply.Gas_quota_exceeded_init_deserialize)
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                                              ctxt arg))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | (_arg, ctxt) =>
                                                              ctxt
                                                            end)
                                                      end)
                                                |
                                                  Origination {|
                                                    script := script |} =>
                                                  let script_bytes :=
                                                    Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.encoding
                                                      script in
                                                  let script :=
                                                    match
                                                      Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.encoding
                                                        script_bytes with
                                                    | Some script => script
                                                    | None => false
                                                    end in
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
                                                          Apply.Gas_quota_exceeded_init_deserialize)
                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                                          (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                                            ctxt
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Script.minimal_deserialize_cost
                                                              (code script)))
                                                          (fun ctxt =>
                                                            Tezos_raw_protocol_alpha.Alpha_context.Gas.check_enough
                                                              ctxt
                                                              (Tezos_raw_protocol_alpha.Alpha_context.Script.minimal_deserialize_cost
                                                                (storage script))))))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                                              Apply.Gas_quota_exceeded_init_deserialize)
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                                              ctxt (code script)))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | (_code, ctxt) =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                                                    Apply.Gas_quota_exceeded_init_deserialize)
                                                                  (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                                                                    ctxt
                                                                    (storage
                                                                      script)))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  |
                                                                    (_storage,
                                                                      ctxt) =>
                                                                    ctxt
                                                                  end)
                                                            end)
                                                      end)
                                                | _ =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                    ctxt
                                                end
                                                (fun ctxt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_manager_key
                                                      ctxt source)
                                                    (fun _public_key =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (Tezos_raw_protocol_alpha.Alpha_context.Contract.increment_counter
                                                          ctxt source)
                                                        (fun ctxt =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Contract.spend
                                                              ctxt
                                                              (Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract
                                                                source) fee)
                                                            (fun ctxt =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                                ctxt))))
                                            end)
                                      end)
                                end)
                          end)
                    end in
                  let fix partial_precheck_manager_contents_list {kind : Type}
                    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
                    (contents_list :
                    Tezos_raw_protocol_alpha.Alpha_context.contents_list
                      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
                    : Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                        Tezos_raw_protocol_alpha.Alpha_context.context) :=
                    match contents_list with
                    | Single ((Manager_operation _) as op) =>
                      partial_precheck_manager_contents ctxt op
                    | Cons ((Manager_operation _) as op) rest =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (partial_precheck_manager_contents ctxt op)
                        (fun ctxt =>
                          partial_precheck_manager_contents_list ctxt rest)
                    end in
                  let _return {A : Type}
                    (contents :
                    Tezos_raw_protocol_alpha.Apply_results.contents_result_list
                      A)
                    : Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                        (Tezos_raw_protocol_alpha.Alpha_context.packed_protocol_data
                          *
                          Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata)) :=
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      ((Operation_data protocol_data),
                        (Apply_results.Operation_metadata
                          {| contents := contents |})) in
                  let operation :=
                    {| shell := shell; protocol_data := protocol_data |} in
                  let hash :=
                    Tezos_raw_protocol_alpha.Alpha_context.Operation.hash
                      {| shell := shell; protocol_data := protocol_data |} in
                  let ctxt :=
                    Tezos_raw_protocol_alpha.Alpha_context.Contract.init_origination_nonce
                      ctxt hash in
                  let baker :=
                    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.zero
                    in
                  match contents protocol_data with
                  | (Single (Manager_operation _)) as op =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (partial_precheck_manager_contents_list ctxt op)
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                          (Tezos_raw_protocol_alpha.Apply.apply_manager_contents_list
                            ctxt Optimized baker chain_id op)
                          (fun function_parameter =>
                            match function_parameter with
                            | (_ctxt, result) => _return result
                            end))
                  | (Cons (Manager_operation _) _) as op =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (partial_precheck_manager_contents_list ctxt op)
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                          (Tezos_raw_protocol_alpha.Apply.apply_manager_contents_list
                            ctxt Optimized baker chain_id op)
                          (fun function_parameter =>
                            match function_parameter with
                            | (_ctxt, result) => _return result
                            end))
                  | _ =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Apply.apply_contents_list ctxt
                        chain_id Optimized (branch shell) baker operation
                        (contents (protocol_data operation)))
                      (fun function_parameter =>
                        match function_parameter with
                        | (_ctxt, result) => _return result
                        end)
                  end
                end
            end);
      Tezos_raw_protocol_alpha.Services_registration.register0 S.entrypoint_type
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (expr, entrypoint) =>
                  let ctxt :=
                    Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited
                      ctxt in
                  let legacy := false in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                        (Tezos_raw_protocol_alpha.Script_ir_translator.parse_toplevel
                          legacy expr)
                        (fun function_parameter =>
                          match function_parameter with
                          | (arg_type, _, _, root_name) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                              (Tezos_raw_protocol_alpha.Script_ir_translator.parse_ty
                                ctxt legacy true false true arg_type)
                              (fun function_parameter =>
                                match function_parameter with
                                | (Ex_ty arg_type, _) =>
                                  Tezos_raw_protocol_alpha.Script_ir_translator.find_entrypoint
                                    arg_type root_name entrypoint
                                end)
                          end)))
                    (fun function_parameter =>
                      match function_parameter with
                      | (_f, Ex_ty ty) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_ty
                            ctxt ty)
                          (fun function_parameter =>
                            match function_parameter with
                            | (ty_node, _) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                  ty_node)
                            end)
                      end)
                end
            end);
      Tezos_raw_protocol_alpha.Services_registration.register0
        S.list_entrypoints
        (fun ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun expr =>
                let ctxt :=
                  Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited ctxt
                  in
                let legacy := false in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                      (Tezos_raw_protocol_alpha.Script_ir_translator.parse_toplevel
                        legacy expr)
                      (fun function_parameter =>
                        match function_parameter with
                        | (arg_type, _, _, root_name) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                            (Tezos_raw_protocol_alpha.Script_ir_translator.parse_ty
                              ctxt legacy true false true arg_type)
                            (fun function_parameter =>
                              match function_parameter with
                              | (Ex_ty arg_type, _) =>
                                Tezos_raw_protocol_alpha.Script_ir_translator.list_entrypoints
                                  arg_type ctxt root_name
                              end)
                        end)))
                  (fun function_parameter =>
                    match function_parameter with
                    | (unreachable_entrypoint, map) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        (unreachable_entrypoint,
                          (Tezos_raw_protocol_alpha.Script_ir_translator.Entrypoints_map.fold
                            (fun entry =>
                              fun function_parameter =>
                                match function_parameter with
                                | (_, ty) =>
                                  fun acc =>
                                    cons
                                      (entry,
                                        (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                          ty)) acc
                                end) map []))
                    end)
            end)
    end.
  
  Definition run_code {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
        Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
        (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (list
            Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
    match function_parameter with
    | (storage, input, amount, chain_id, source, payer, gas, entrypoint) =>
      Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
        S.run_code ctxt block tt
        (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)
    end.
  
  Definition trace_code {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
        Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
        (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (list
            Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
          (list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
              Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
              (list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                  (option string))))) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
    match function_parameter with
    | (storage, input, amount, chain_id, source, payer, gas, entrypoint) =>
      Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
        S.trace_code ctxt block tt
        (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)
    end.
  
  Definition typecheck_code {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          ((list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
              ((list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                  (list string))) *
                (list
                  (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                    (list string)))))) *
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.typecheck_code ctxt block tt.
  
  Definition typecheck_data {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.typecheck_data ctxt block tt.
  
  Definition pack_data {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (Tezos_protocol_environment_alpha__Environment.MBytes.t *
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.pack_data ctxt block tt.
  
  Definition run_operation {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
      Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data
            * Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata)) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.run_operation ctxt block tt.
  
  Definition entrypoint_type {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * string) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.entrypoint_type ctxt block tt.
  
  Definition list_entrypoints {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
            (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.list_entrypoints ctxt block tt.
End Scripts.

Module Forge.
  Module S.
    Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
    
    Definition path
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "forge" % string.
    
    Definition operations
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
          Tezos_raw_protocol_alpha__Alpha_context.packed_contents_list)
        Tezos_protocol_environment_alpha__Environment.MBytes.t :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Forge an operation" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        Tezos_raw_protocol_alpha.Alpha_context.Operation.unsigned_encoding
        Tezos_protocol_environment_alpha__Environment.Data_encoding.bytes
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "operations" % string).
    
    Definition empty_proof_of_work_nonce
      : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
      Tezos_protocol_environment_alpha__Environment.MBytes.of_string
        (Tezos_protocol_environment_alpha__Environment.String.make
          Tezos_raw_protocol_alpha.Constants_repr.proof_of_work_nonce_size
          "000" % char).
    
    Definition protocol_data
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Z * (option Tezos_raw_protocol_alpha.Nonce_hash.t) *
          Tezos_protocol_environment_alpha__Environment.MBytes.t)
        Tezos_protocol_environment_alpha__Environment.MBytes.t :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Forge the protocol-specific part of a block header" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "priority" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
            None "nonce_hash" % string
            Tezos_raw_protocol_alpha.Nonce_hash.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
            None "proof_of_work_nonce" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Fixed.bytes
              Tezos_raw_protocol_alpha.Alpha_context.Constants.proof_of_work_nonce_size)
            empty_proof_of_work_nonce))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "protocol_data" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.bytes))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "protocol_data" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Tezos_raw_protocol_alpha.Services_registration.register0_noctxt
        S.operations
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | (shell, proto) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                    Tezos_raw_protocol_alpha.Alpha_context.Operation.unsigned_encoding
                    (shell, proto))
              end
          end);
      Tezos_raw_protocol_alpha.Services_registration.register0_noctxt
        S.protocol_data
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | (priority, seed_nonce_hash, proof_of_work_nonce) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                    Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents_encoding
                    {| priority := priority; seed_nonce_hash := seed_nonce_hash;
                      proof_of_work_nonce := proof_of_work_nonce |})
              end
          end)
    end.
  
  Module Manager.
    Definition operations {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (gas_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
      (storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
      (operations :
        list Tezos_raw_protocol_alpha.Alpha_context.packed_manager_operation)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result
          Tezos_protocol_environment_alpha__Environment.MBytes.t
          (list
            Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (Tezos_raw_protocol_alpha.Contract_services.manager_key ctxt block
          source)
        (fun function_parameter =>
          match function_parameter with
          | (inr _) as e =>
            Tezos_protocol_environment_alpha__Environment.Lwt._return e
          | inl revealed =>
            let ops :=
              Tezos_protocol_environment_alpha__Environment.List.map
                (fun function_parameter =>
                  match function_parameter with
                  | Manager operation =>
                    Contents
                      (Manager_operation
                        {| source := source; fee := fee; counter := counter;
                          operation := operation; gas_limit := gas_limit;
                          storage_limit := storage_limit |})
                  end) operations in
            let ops :=
              match (sourcePubKey, revealed) with
              | (None, _) | (_, Some _) => ops
              | (Some pk, None) =>
                let operation := Reveal pk in
                cons
                  (Contents
                    (Manager_operation
                      {| source := source; fee := fee; counter := counter;
                        operation := operation; gas_limit := gas_limit;
                        storage_limit := storage_limit |})) ops
              end in
            Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
              S.operations ctxt block tt
              ({| branch := branch |},
                (Tezos_raw_protocol_alpha.Alpha_context.Operation.of_list ops))
          end).
    
    Definition reveal {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (function_parameter : unit)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result
          Tezos_protocol_environment_alpha__Environment.MBytes.t
          (list
            Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      match function_parameter with
      | tt =>
        operations ctxt block branch source (Some sourcePubKey) counter fee
          Tezos_protocol_environment_alpha__Environment.Z.zero
          Tezos_protocol_environment_alpha__Environment.Z.zero []
      end.
    
    Definition transaction {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (amount : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (destination : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
      (op_star_o_p_t_star : option string)
      : (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
        Tezos_protocol_environment_alpha__Environment.Z.t ->
          Tezos_protocol_environment_alpha__Environment.Z.t ->
            Tezos_raw_protocol_alpha.Alpha_context.Tez.tez ->
              unit ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.result
                    Tezos_protocol_environment_alpha__Environment.MBytes.t
                    (list
                      Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      let entrypoint :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "default" % string
        end in
      fun parameters =>
        fun gas_limit =>
          fun storage_limit =>
            fun fee =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  let parameters :=
                    Tezos_protocol_environment_alpha__Environment.Option.unopt_map
                      Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                      Tezos_raw_protocol_alpha.Alpha_context.Script.unit_parameter
                      parameters in
                  operations ctxt block branch source sourcePubKey counter fee
                    gas_limit storage_limit
                    (cons
                      (Manager
                        (Transaction
                          {| amount := amount; parameters := parameters;
                            entrypoint := entrypoint; destination := destination
                            |})) [])
                end.
    
    Definition origination {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (delegatePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      (script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
      (gas_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
      (storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
      (fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (function_parameter : unit)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result
          Tezos_protocol_environment_alpha__Environment.MBytes.t
          (list
            Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      match function_parameter with
      | tt =>
        operations ctxt block branch source sourcePubKey counter fee gas_limit
          storage_limit
          (cons
            (Manager
              (Origination
                {| delegate := delegatePubKey; script := script;
                  credit := balance; preorigination := None |})) [])
      end.
    
    Definition delegation {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (delegate :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result
          Tezos_protocol_environment_alpha__Environment.MBytes.t
          (list
            Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      operations ctxt block branch source sourcePubKey counter fee
        Tezos_protocol_environment_alpha__Environment.Z.zero
        Tezos_protocol_environment_alpha__Environment.Z.zero
        (cons (Manager (Delegation delegate)) []).
  End Manager.
  
  Definition operation {D E G I K L M a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (operation : Tezos_raw_protocol_alpha.Alpha_context.contents M)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.operations ctxt block tt
      ({| branch := branch |}, (Contents_list (Single operation))).
  
  Definition endorsement {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (b : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    match function_parameter with
    | tt => operation ctxt b branch (Endorsement {| level := level |})
    end.
  
  Definition proposals {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (b : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (source :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    (period : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.t)
    (proposals :
      list
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    match function_parameter with
    | tt =>
      operation ctxt b branch
        (Proposals
          {| source := source; period := period; proposals := proposals |})
    end.
  
  Definition ballot {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (b : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (source :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    (period : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.t)
    (proposal :
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (ballot : Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    match function_parameter with
    | tt =>
      operation ctxt b branch
        (Ballot
          {| source := source; period := period; proposal := proposal;
            ballot := ballot |})
    end.
  
  Definition seed_nonce_revelation {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
    (nonce : Tezos_raw_protocol_alpha.Alpha_context.Nonce.t)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    match function_parameter with
    | tt =>
      operation ctxt block branch
        (Seed_nonce_revelation {| level := level; nonce := nonce |})
    end.
  
  Definition double_baking_evidence {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (bh1 : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
    (bh2 : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    match function_parameter with
    | tt =>
      operation ctxt block branch
        (Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |})
    end.
  
  Definition double_endorsement_evidence {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (op1 :
      Tezos_raw_protocol_alpha.Alpha_context.operation
        Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
    (op2 :
      Tezos_raw_protocol_alpha.Alpha_context.operation
        Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    match function_parameter with
    | tt =>
      operation ctxt block branch
        (Double_endorsement_evidence {| op1 := op1; op2 := op2 |})
    end.
  
  Definition empty_proof_of_work_nonce
    : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
    Tezos_protocol_environment_alpha__Environment.MBytes.of_string
      (Tezos_protocol_environment_alpha__Environment.String.make
        Tezos_raw_protocol_alpha.Constants_repr.proof_of_work_nonce_size
        "000" % char).
  
  Definition protocol_data {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (priority : Z)
    (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
    (op_star_o_p_t_star :
      option Tezos_protocol_environment_alpha__Environment.MBytes.t)
    : unit ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    let proof_of_work_nonce :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => empty_proof_of_work_nonce
      end in
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
          S.protocol_data ctxt block tt
          (priority, seed_nonce_hash, proof_of_work_nonce)
      end.
End Forge.

Module Parse.
  Module S.
    Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
    
    Definition path
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "parse" % string.
    
    Definition operations
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        ((list Tezos_raw_protocol_alpha.Alpha_context.Operation.raw) *
          (option bool))
        (list Tezos_raw_protocol_alpha.Alpha_context.Operation.packed) :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Parse operations" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "operations" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
              None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                None
                Tezos_raw_protocol_alpha.Alpha_context.Operation.raw_encoding)))
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
            None "check_signature" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.bool))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
            None Tezos_raw_protocol_alpha.Alpha_context.Operation.encoding))
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "operations" % string).
    
    Definition block
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.raw
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data :=
      Tezos_protocol_environment_alpha__Environment.RPC_service.post_service
        (Some "Parse a block" % string)
        Tezos_protocol_environment_alpha__Environment.RPC_query.empty
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.raw_encoding
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data_encoding
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
          "block" % string).
  End S.
  
  Definition parse_protocol_data
    (protocol_data : Tezos_protocol_environment_alpha__Environment.MBytes.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data) :=
    match
      Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data_encoding
        protocol_data with
    | None =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
        "Cant_parse_protocol_data" % string
    | Some protocol_data =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        protocol_data
    end.
  
  Definition register (function_parameter : unit) : unit :=
    match function_parameter with
    | tt =>
      Tezos_raw_protocol_alpha.Services_registration.register0 S.operations
        (fun _ctxt =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              fun function_parameter =>
                match function_parameter with
                | (operations, check) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                    (fun raw =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (parse_operation raw))
                        (fun op =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                            match check with
                            | Some true =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                            | Some false | None =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                            end
                            (fun function_parameter =>
                              match function_parameter with
                              | tt => op
                              end))) operations
                end
            end);
      Tezos_raw_protocol_alpha.Services_registration.register0_noctxt S.block
        (fun function_parameter =>
          match function_parameter with
          | tt => fun raw_block => parse_protocol_data (protocol_data raw_block)
          end)
    end.
  
  Definition operations {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (check : option bool)
    (operations : list Tezos_raw_protocol_alpha.Alpha_context.Operation.raw)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list Tezos_raw_protocol_alpha.Alpha_context.Operation.packed)) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.operations ctxt block tt (operations, check).
  
  Definition block {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (shell :
      Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
    (protocol_data : Tezos_protocol_environment_alpha__Environment.MBytes.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data) :=
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0 S.block
      ctxt block tt {| shell := shell; protocol_data := protocol_data |}.
End Parse.

Module S.
  Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
  
  Record level_query := {
    offset : int32 }.
  
  Definition level_query
    : Tezos_protocol_environment_alpha__Environment.RPC_query.t level_query :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
      (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
        (Tezos_protocol_environment_alpha__Environment.RPC_query.query
          (fun offset => {| offset := offset |}))
        (Tezos_protocol_environment_alpha__Environment.RPC_query.field None
          "offset" % string
          Tezos_protocol_environment_alpha__Environment.RPC_arg.int32 0
          (fun t => offset t)))
      Tezos_protocol_environment_alpha__Environment.RPC_query.seal.
  
  Definition current_level
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      level_query unit Tezos_raw_protocol_alpha.Alpha_context.Level.t :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "Returns the level of the interrogated block, or the one of a block located `offset` blocks after in the chain (or before when negative). For instance, the next block if `offset` is 1."
          % string) level_query
      Tezos_raw_protocol_alpha.Alpha_context.Level.encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "current_level" % string).
  
  Definition levels_in_current_cycle
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      level_query unit
      (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
        Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Levels of a cycle" % string) level_query
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "first" % string
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "last" % string
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.encoding))
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "levels_in_current_cycle" % string).
End S.

Definition register (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    Scripts.register tt;
    Forge.register tt;
    Parse.register tt;
    Tezos_raw_protocol_alpha.Services_registration.register0 S.current_level
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              let level :=
                Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (Tezos_raw_protocol_alpha.Alpha_context.Level.from_raw ctxt
                  (Some (offset q)) (level level))
            end);
    Tezos_raw_protocol_alpha.Services_registration.register0
      S.levels_in_current_cycle
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              let levels :=
                Tezos_raw_protocol_alpha.Alpha_context.Level.levels_in_current_cycle
                  ctxt (Some (offset q)) tt in
              match levels with
              | [] =>
                Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                  OCaml.Not_found
              | _ =>
                let first :=
                  Tezos_protocol_environment_alpha__Environment.List.hd
                    (Tezos_protocol_environment_alpha__Environment.List.rev
                      levels) in
                let last :=
                  Tezos_protocol_environment_alpha__Environment.List.hd levels
                  in
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ((level first), (level last))
              end
            end)
  end.

Definition current_level {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (op_star_o_p_t_star : option int32)
  : D ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Level.t) :=
  let offset :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun block =>
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.current_level ctxt block {| offset := offset |} tt.

Definition levels_in_current_cycle {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (op_star_o_p_t_star : option int32)
  : D ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)) :=
  let offset :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun block =>
    Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
      S.levels_in_current_cycle ctxt block {| offset := offset |} tt.
src/proto_alpha/lib_protocol/helpers_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type error += Cannot_parse_operation (* `Branch *)

val current_level :
  'a #RPC_context.simple -> ?offset:int32 -> 'a -> Level.t shell_tzresult Lwt.t

val levels_in_current_cycle :
  'a #RPC_context.simple ->
  ?offset:int32 ->
  'a ->
  (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t

module Scripts : sig
  val run_code :
    'a #RPC_context.simple ->
    'a ->
    Script.expr ->
    Script.expr
    * Script.expr
    * Tez.t
    * Chain_id.t
    * Contract.t option
    * Contract.t option
    * Z.t option
    * string ->
    ( Script.expr
    * packed_internal_operation list
    * Contract.big_map_diff option )
    shell_tzresult
    Lwt.t

  val trace_code :
    'a #RPC_context.simple ->
    'a ->
    Script.expr ->
    Script.expr
    * Script.expr
    * Tez.t
    * Chain_id.t
    * Contract.t option
    * Contract.t option
    * Z.t option
    * string ->
    ( Script.expr
    * packed_internal_operation list
    * Script_interpreter.execution_trace
    * Contract.big_map_diff option )
    shell_tzresult
    Lwt.t

  val typecheck_code :
    'a #RPC_context.simple ->
    'a ->
    Script.expr * Z.t option ->
    (Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t

  val typecheck_data :
    'a #RPC_context.simple ->
    'a ->
    Script.expr * Script.expr * Z.t option ->
    Gas.t shell_tzresult Lwt.t

  val pack_data :
    'a #RPC_context.simple ->
    'a ->
    Script.expr * Script.expr * Z.t option ->
    (MBytes.t * Gas.t) shell_tzresult Lwt.t

  val run_operation :
    'a #RPC_context.simple ->
    'a ->
    packed_operation * Chain_id.t ->
    (packed_protocol_data * Apply_results.packed_operation_metadata)
    shell_tzresult
    Lwt.t

  val entrypoint_type :
    'a #RPC_context.simple ->
    'a ->
    Script.expr * string ->
    Script.expr shell_tzresult Lwt.t

  val list_entrypoints :
    'a #RPC_context.simple ->
    'a ->
    Script.expr ->
    (Michelson_v1_primitives.prim list list * (string * Script.expr) list)
    shell_tzresult
    Lwt.t
end

module Forge : sig
  module Manager : sig
    val operations :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      ?sourcePubKey:public_key ->
      counter:counter ->
      fee:Tez.t ->
      gas_limit:Z.t ->
      storage_limit:Z.t ->
      packed_manager_operation list ->
      MBytes.t shell_tzresult Lwt.t

    val reveal :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      sourcePubKey:public_key ->
      counter:counter ->
      fee:Tez.t ->
      unit ->
      MBytes.t shell_tzresult Lwt.t

    val transaction :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      ?sourcePubKey:public_key ->
      counter:counter ->
      amount:Tez.t ->
      destination:Contract.t ->
      ?entrypoint:string ->
      ?parameters:Script.expr ->
      gas_limit:Z.t ->
      storage_limit:Z.t ->
      fee:Tez.t ->
      unit ->
      MBytes.t shell_tzresult Lwt.t

    val origination :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      ?sourcePubKey:public_key ->
      counter:counter ->
      balance:Tez.t ->
      ?delegatePubKey:public_key_hash ->
      script:Script.t ->
      gas_limit:Z.t ->
      storage_limit:Z.t ->
      fee:Tez.t ->
      unit ->
      MBytes.t shell_tzresult Lwt.t

    val delegation :
      'a #RPC_context.simple ->
      'a ->
      branch:Block_hash.t ->
      source:public_key_hash ->
      ?sourcePubKey:public_key ->
      counter:counter ->
      fee:Tez.t ->
      public_key_hash option ->
      MBytes.t shell_tzresult Lwt.t
  end

  val endorsement :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    level:Raw_level.t ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val proposals :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    source:public_key_hash ->
    period:Voting_period.t ->
    proposals:Protocol_hash.t list ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val ballot :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    source:public_key_hash ->
    period:Voting_period.t ->
    proposal:Protocol_hash.t ->
    ballot:Vote.ballot ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val seed_nonce_revelation :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    level:Raw_level.t ->
    nonce:Nonce.t ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val double_baking_evidence :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    bh1:Block_header.t ->
    bh2:Block_header.t ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val double_endorsement_evidence :
    'a #RPC_context.simple ->
    'a ->
    branch:Block_hash.t ->
    op1:Kind.endorsement operation ->
    op2:Kind.endorsement operation ->
    unit ->
    MBytes.t shell_tzresult Lwt.t

  val protocol_data :
    'a #RPC_context.simple ->
    'a ->
    priority:int ->
    ?seed_nonce_hash:Nonce_hash.t ->
    ?proof_of_work_nonce:MBytes.t ->
    unit ->
    MBytes.t shell_tzresult Lwt.t
end

module Parse : sig
  val operations :
    'a #RPC_context.simple ->
    'a ->
    ?check:bool ->
    Operation.raw list ->
    Operation.packed list shell_tzresult Lwt.t

  val block :
    'a #RPC_context.simple ->
    'a ->
    Block_header.shell_header ->
    MBytes.t ->
    Block_header.protocol_data shell_tzresult Lwt.t
end

val register : unit -> unit
src/proto_alpha/lib_protocol/helpers_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

Parameter current_level : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  (option int32) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Level.t).

Parameter levels_in_current_cycle : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  (option int32) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
            Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)).

Module Scripts.
  Parameter run_code : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
          ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                (list
                  Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
                *
                (option
                  Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))).
  
  Parameter trace_code : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
          ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                (list
                  Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
                * Tezos_raw_protocol_alpha.Script_interpreter.execution_trace *
                (option
                  Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))).
  
  Parameter typecheck_code : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            (Tezos_raw_protocol_alpha.Script_tc_errors.type_map *
              Tezos_raw_protocol_alpha.Alpha_context.Gas.t)).
  
  Parameter typecheck_data : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t).
  
  Parameter pack_data : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            (Tezos_protocol_environment_alpha__Environment.MBytes.t *
              Tezos_raw_protocol_alpha.Alpha_context.Gas.t)).
  
  Parameter run_operation : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      (Tezos_raw_protocol_alpha.Alpha_context.packed_operation *
        Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
        ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            (Tezos_raw_protocol_alpha.Alpha_context.packed_protocol_data *
              Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata)).
  
  Parameter entrypoint_type : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * string) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr).
  
  Parameter list_entrypoints : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))
              *
              (list
                (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))).
End Scripts.

Module Forge.
  Module Manager.
    Parameter operations : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
      variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        a ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          a ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            a ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a)
      ->
      a ->
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          ->
          Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
            (option Tezos_raw_protocol_alpha.Alpha_context.public_key) ->
              Tezos_raw_protocol_alpha.Alpha_context.counter ->
                Tezos_raw_protocol_alpha.Alpha_context.Tez.t ->
                  Tezos_protocol_environment_alpha__Environment.Z.t ->
                    Tezos_protocol_environment_alpha__Environment.Z.t ->
                      (list
                        Tezos_raw_protocol_alpha.Alpha_context.packed_manager_operation)
                        ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            Tezos_protocol_environment_alpha__Environment.MBytes.t).
    
    Parameter reveal : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
      variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        a ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          a ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            a ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a)
      ->
      a ->
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          ->
          Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
            Tezos_raw_protocol_alpha.Alpha_context.public_key ->
              Tezos_raw_protocol_alpha.Alpha_context.counter ->
                Tezos_raw_protocol_alpha.Alpha_context.Tez.t ->
                  unit ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        Tezos_protocol_environment_alpha__Environment.MBytes.t).
    
    Parameter transaction : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
      variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        a ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          a ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            a ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a)
      ->
      a ->
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          ->
          Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
            (option Tezos_raw_protocol_alpha.Alpha_context.public_key) ->
              Tezos_raw_protocol_alpha.Alpha_context.counter ->
                Tezos_raw_protocol_alpha.Alpha_context.Tez.t ->
                  Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
                    (option string) ->
                      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
                        ->
                        Tezos_protocol_environment_alpha__Environment.Z.t ->
                          Tezos_protocol_environment_alpha__Environment.Z.t ->
                            Tezos_raw_protocol_alpha.Alpha_context.Tez.t ->
                              unit ->
                                Tezos_protocol_environment_alpha__Environment.Lwt.t
                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                    Tezos_protocol_environment_alpha__Environment.MBytes.t).
    
    Parameter origination : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
      variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        a ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          a ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            a ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a)
      ->
      a ->
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          ->
          Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
            (option Tezos_raw_protocol_alpha.Alpha_context.public_key) ->
              Tezos_raw_protocol_alpha.Alpha_context.counter ->
                Tezos_raw_protocol_alpha.Alpha_context.Tez.t ->
                  (option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
                    ->
                    Tezos_raw_protocol_alpha.Alpha_context.Script.t ->
                      Tezos_protocol_environment_alpha__Environment.Z.t ->
                        Tezos_protocol_environment_alpha__Environment.Z.t ->
                          Tezos_raw_protocol_alpha.Alpha_context.Tez.t ->
                            unit ->
                              Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                  Tezos_protocol_environment_alpha__Environment.MBytes.t).
    
    Parameter delegation : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
      variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        a ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          a ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            a ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a)
      ->
      a ->
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          ->
          Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
            (option Tezos_raw_protocol_alpha.Alpha_context.public_key) ->
              Tezos_raw_protocol_alpha.Alpha_context.counter ->
                Tezos_raw_protocol_alpha.Alpha_context.Tez.t ->
                  (option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
                    ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        Tezos_protocol_environment_alpha__Environment.MBytes.t).
  End Manager.
  
  Parameter endorsement : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        ->
        Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t ->
          unit ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                Tezos_protocol_environment_alpha__Environment.MBytes.t).
  
  Parameter proposals : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        ->
        Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
          Tezos_raw_protocol_alpha.Alpha_context.Voting_period.t ->
            (list
              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
              ->
              unit ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    Tezos_protocol_environment_alpha__Environment.MBytes.t).
  
  Parameter ballot : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        ->
        Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
          Tezos_raw_protocol_alpha.Alpha_context.Voting_period.t ->
            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
              ->
              Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot ->
                unit ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      Tezos_protocol_environment_alpha__Environment.MBytes.t).
  
  Parameter seed_nonce_revelation : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        ->
        Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t ->
          Tezos_raw_protocol_alpha.Alpha_context.Nonce.t ->
            unit ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  Tezos_protocol_environment_alpha__Environment.MBytes.t).
  
  Parameter double_baking_evidence : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        ->
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
          Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
            unit ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  Tezos_protocol_environment_alpha__Environment.MBytes.t).
  
  Parameter double_endorsement_evidence : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        ->
        (Tezos_raw_protocol_alpha.Alpha_context.operation
          Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement) ->
          (Tezos_raw_protocol_alpha.Alpha_context.operation
            Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement) ->
            unit ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  Tezos_protocol_environment_alpha__Environment.MBytes.t).
  
  Parameter protocol_data : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Z ->
        (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
          (option Tezos_protocol_environment_alpha__Environment.MBytes.t) ->
            unit ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  Tezos_protocol_environment_alpha__Environment.MBytes.t).
End Forge.

Module Parse.
  Parameter operations : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      (option bool) ->
        (list Tezos_raw_protocol_alpha.Alpha_context.Operation.raw) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              (list Tezos_raw_protocol_alpha.Alpha_context.Operation.packed)).
  
  Parameter block : forall {_ a b c i o q variant : Type}, (((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
    variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
    Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
    a ->
      q ->
        i ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              o)) * (_ * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
      ->
      a ->
        a ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (_ * a * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
        q i o) ->
        a ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (_ * a * b * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
            b) * c) q i o) ->
          a ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
    a ->
      Tezos_raw_protocol_alpha.Alpha_context.Block_header.shell_header ->
        Tezos_protocol_environment_alpha__Environment.MBytes.t ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data).
End Parse.

Parameter register : unit -> unit.
src/proto_alpha/lib_protocol/init_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* This is the genesis protocol: initialise the state *)
let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
  Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt
  >>=? fun (previous_protocol, ctxt) ->
  Storage.Big_map.Next.init ctxt
  >>=? fun ctxt ->
  match previous_protocol with
  | Genesis param ->
      Commitment_storage.init ctxt param.commitments
      >>=? fun ctxt ->
      Roll_storage.init ctxt
      >>=? fun ctxt ->
      Seed_storage.init ctxt
      >>=? fun ctxt ->
      Contract_storage.init ctxt
      >>=? fun ctxt ->
      Bootstrap_storage.init
        ctxt
        ~typecheck
        ?ramp_up_cycles:param.security_deposit_ramp_up_cycles
        ?no_reward_cycles:param.no_reward_cycles
        param.bootstrap_accounts
        param.bootstrap_contracts
      >>=? fun ctxt ->
      Roll_storage.init_first_cycles ctxt
      >>=? fun ctxt ->
      Vote_storage.init ctxt
      >>=? fun ctxt ->
      Storage.Block_priority.init ctxt 0
      >>=? fun ctxt ->
      Vote_storage.freeze_listings ctxt >>=? fun ctxt -> return ctxt
  | Alpha_previous ->
      return ctxt

let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness =
  Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
src/proto_alpha/lib_protocol/init_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition prepare_first_block
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (typecheck :
    Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Script_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_repr.t *
              (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
              Tezos_raw_protocol_alpha.Raw_context.t))) (level : int32)
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (fitness :
    Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Raw_context.prepare_first_block level timestamp
      fitness ctxt)
    (fun function_parameter =>
      match function_parameter with
      | (previous_protocol, ctxt) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Big_map.Next.init ctxt)
          (fun ctxt =>
            match previous_protocol with
            | Genesis param =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Commitment_storage.init ctxt
                  (commitments param))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Roll_storage.init ctxt)
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Seed_storage.init ctxt)
                        (fun ctxt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Contract_storage.init ctxt)
                            (fun ctxt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_raw_protocol_alpha.Bootstrap_storage.init
                                  ctxt typecheck
                                  (security_deposit_ramp_up_cycles param)
                                  (no_reward_cycles param)
                                  (bootstrap_accounts param)
                                  (bootstrap_contracts param))
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Roll_storage.init_first_cycles
                                      ctxt)
                                    (fun ctxt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_raw_protocol_alpha.Vote_storage.init
                                          ctxt)
                                        (fun ctxt =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (Tezos_raw_protocol_alpha.Storage.Block_priority.init
                                              ctxt 0)
                                            (fun ctxt =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_raw_protocol_alpha.Vote_storage.freeze_listings
                                                  ctxt)
                                                (fun ctxt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                    ctxt)))))))))
            | Alpha_previous =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ctxt
            end)
      end).

Definition prepare
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (level : Tezos_protocol_environment_alpha__Environment.Int32.t)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (fitness :
    Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.context) :=
  Tezos_raw_protocol_alpha.Raw_context.prepare level predecessor_timestamp
    timestamp fitness ctxt.
src/proto_alpha/lib_protocol/legacy_script_support_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com>              *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let manager_script_code : Script_repr.lazy_expr =
  let open Micheline in
  let open Michelson_v1_primitives in
  Script_repr.lazy_expr @@ strip_locations
  @@ Seq
       ( 0,
         [ Prim
             ( 0,
               K_parameter,
               [ Prim
                   ( 0,
                     T_or,
                     [ Prim
                         ( 0,
                           T_lambda,
                           [ Prim (0, T_unit, [], []);
                             Prim
                               (0, T_list, [Prim (0, T_operation, [], [])], [])
                           ],
                           ["%do"] );
                       Prim (0, T_unit, [], ["%default"]) ],
                     [] ) ],
               [] );
           Prim (0, K_storage, [Prim (0, T_key_hash, [], [])], []);
           Prim
             ( 0,
               K_code,
               [ Seq
                   ( 0,
                     [ Seq
                         ( 0,
                           [ Seq
                               ( 0,
                                 [ Prim (0, I_DUP, [], []);
                                   Prim (0, I_CAR, [], []);
                                   Prim
                                     ( 0,
                                       I_DIP,
                                       [Seq (0, [Prim (0, I_CDR, [], [])])],
                                       [] ) ] ) ] );
                       Prim
                         ( 0,
                           I_IF_LEFT,
                           [ Seq
                               ( 0,
                                 [ Prim
                                     ( 0,
                                       I_PUSH,
                                       [ Prim (0, T_mutez, [], []);
                                         Int (0, Z.zero) ],
                                       [] );
                                   Prim (0, I_AMOUNT, [], []);
                                   Seq
                                     ( 0,
                                       [ Seq
                                           ( 0,
                                             [ Prim (0, I_COMPARE, [], []);
                                               Prim (0, I_EQ, [], []) ] );
                                         Prim
                                           ( 0,
                                             I_IF,
                                             [ Seq (0, []);
                                               Seq
                                                 ( 0,
                                                   [ Seq
                                                       ( 0,
                                                         [ Prim
                                                             (0, I_UNIT, [], []);
                                                           Prim
                                                             ( 0,
                                                               I_FAILWITH,
                                                               [],
                                                               [] ) ] ) ] ) ],
                                             [] ) ] );
                                   Seq
                                     ( 0,
                                       [ Prim
                                           ( 0,
                                             I_DIP,
                                             [ Seq
                                                 (0, [Prim (0, I_DUP, [], [])])
                                             ],
                                             [] );
                                         Prim (0, I_SWAP, [], []) ] );
                                   Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                   Prim (0, I_ADDRESS, [], []);
                                   Prim (0, I_SENDER, [], []);
                                   Seq
                                     ( 0,
                                       [ Seq
                                           ( 0,
                                             [ Prim (0, I_COMPARE, [], []);
                                               Prim (0, I_EQ, [], []) ] );
                                         Prim
                                           ( 0,
                                             I_IF,
                                             [ Seq (0, []);
                                               Seq
                                                 ( 0,
                                                   [ Seq
                                                       ( 0,
                                                         [ Prim
                                                             (0, I_UNIT, [], []);
                                                           Prim
                                                             ( 0,
                                                               I_FAILWITH,
                                                               [],
                                                               [] ) ] ) ] ) ],
                                             [] ) ] );
                                   Prim (0, I_UNIT, [], []);
                                   Prim (0, I_EXEC, [], []);
                                   Prim (0, I_PAIR, [], []) ] );
                             Seq
                               ( 0,
                                 [ Prim (0, I_DROP, [], []);
                                   Prim
                                     ( 0,
                                       I_NIL,
                                       [Prim (0, T_operation, [], [])],
                                       [] );
                                   Prim (0, I_PAIR, [], []) ] ) ],
                           [] ) ] ) ],
               [] ) ] )

(* Find the toplevel expression with a given prim type from list,
   because they can be in arbitrary order. *)
let find_toplevel toplevel exprs =
  let open Micheline in
  let rec iter toplevel = function
    | (Prim (_, prim, _, _) as found) :: _
      when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim)
      ->
        Some found
    | _ :: rest ->
        iter toplevel rest
    | [] ->
        None
  in
  iter (Michelson_v1_primitives.string_of_prim toplevel) exprs

let add_do :
    manager_pkh:Signature.Public_key_hash.t ->
    script_code:Script_repr.lazy_expr ->
    script_storage:Script_repr.lazy_expr ->
    (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
 fun ~manager_pkh ~script_code ~script_storage ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>=? fun (script_code_expr, _gas_cost) ->
  Lwt.return (Script_repr.force_decode script_storage)
  >>|? fun (script_storage_expr, _gas_cost) ->
  let storage_expr = root script_storage_expr in
  match root script_code_expr with
  | Seq (_, toplevel) -> (
    match
      ( find_toplevel K_parameter toplevel,
        find_toplevel K_storage toplevel,
        find_toplevel K_code toplevel )
    with
    | ( Some
          (Prim
            ( _,
              K_parameter,
              [Prim (_, parameter_type, parameter_expr, parameter_annot)],
              prim_param_annot )),
        Some
          (Prim
            ( _,
              K_storage,
              [ Prim
                  (_, code_storage_type, code_storage_expr, code_storage_annot)
              ],
              k_storage_annot )),
        Some (Prim (_, K_code, [code_expr], code_annot)) ) ->
        (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
        let migrated_code =
          Seq
            ( 0,
              [ Prim
                  ( 0,
                    K_parameter,
                    [ Prim
                        ( 0,
                          T_or,
                          [ Prim
                              ( 0,
                                T_lambda,
                                [ Prim (0, T_unit, [], []);
                                  Prim
                                    ( 0,
                                      T_list,
                                      [Prim (0, T_operation, [], [])],
                                      [] ) ],
                                ["%do"] );
                            Prim
                              ( 0,
                                parameter_type,
                                parameter_expr,
                                "%default" :: parameter_annot ) ],
                          [] ) ],
                    prim_param_annot );
                Prim
                  ( 0,
                    K_storage,
                    [ Prim
                        ( 0,
                          T_pair,
                          [ Prim (0, T_key_hash, [], []);
                            Prim
                              ( 0,
                                code_storage_type,
                                code_storage_expr,
                                code_storage_annot ) ],
                          [] ) ],
                    k_storage_annot );
                Prim
                  ( 0,
                    K_code,
                    [ Seq
                        ( 0,
                          [ Prim (0, I_DUP, [], []);
                            Prim (0, I_CAR, [], []);
                            Prim
                              ( 0,
                                I_IF_LEFT,
                                [ Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_PUSH,
                                            [ Prim (0, T_mutez, [], []);
                                              Int (0, Z.zero) ],
                                            [] );
                                        Prim (0, I_AMOUNT, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_COMPARE, [], []);
                                                    Prim (0, I_EQ, [], []) ] );
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq (0, []);
                                                    Seq
                                                      ( 0,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_UNIT,
                                                                    [],
                                                                    [] );
                                                                Prim
                                                                  ( 0,
                                                                    I_FAILWITH,
                                                                    [],
                                                                    [] ) ] ) ]
                                                      ) ],
                                                  [] ) ] );
                                        Seq
                                          ( 0,
                                            [ Prim
                                                ( 0,
                                                  I_DIP,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_DUP, [], [])
                                                        ] ) ],
                                                  [] );
                                              Prim (0, I_SWAP, [], []) ] );
                                        Prim (0, I_CDR, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                        Prim (0, I_ADDRESS, [], []);
                                        Prim (0, I_SENDER, [], []);
                                        Seq
                                          ( 0,
                                            [ Prim (0, I_COMPARE, [], []);
                                              Prim (0, I_NEQ, [], []);
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_SENDER,
                                                              [],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_PUSH,
                                                              [ Prim
                                                                  ( 0,
                                                                    T_string,
                                                                    [],
                                                                    [] );
                                                                String
                                                                  ( 0,
                                                                    "Only the \
                                                                     owner \
                                                                     can \
                                                                     operate."
                                                                  ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_FAILWITH,
                                                              [],
                                                              [] ) ] );
                                                    Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_UNIT, [], []);
                                                          Prim
                                                            (0, I_EXEC, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_DIP,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_CDR,
                                                                          [],
                                                                          [] )
                                                                    ] ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], [])
                                                        ] ) ],
                                                  [] ) ] ) ] );
                                  Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_CDR, [], []);
                                                    Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CDR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []);
                                        code_expr;
                                        Prim (0, I_SWAP, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_SWAP, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CAR, [], []);
                                                    Prim
                                                      ( 0,
                                                        I_DIP,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_CDR,
                                                                    [],
                                                                    [] ) ] ) ],
                                                        [] ) ] ) ] );
                                        Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_SWAP, [], []);
                                                    Prim (0, I_PAIR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []) ] ) ],
                                [] ) ] ) ],
                    code_annot ) ] )
        in
        let migrated_storage =
          Prim
            ( 0,
              D_Pair,
              [ (* Instead of
                   `String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
                   the storage is written as unparsed with [Optimized] *)
                Bytes
                  ( 0,
                    Data_encoding.Binary.to_bytes_exn
                      Signature.Public_key_hash.encoding
                      manager_pkh );
                storage_expr ],
              [] )
        in
        ( Script_repr.lazy_expr @@ strip_locations migrated_code,
          Script_repr.lazy_expr @@ strip_locations migrated_storage )
    | _ ->
        (script_code, script_storage) )
  | _ ->
      (script_code, script_storage)

let add_set_delegate :
    manager_pkh:Signature.Public_key_hash.t ->
    script_code:Script_repr.lazy_expr ->
    script_storage:Script_repr.lazy_expr ->
    (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
 fun ~manager_pkh ~script_code ~script_storage ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>=? fun (script_code_expr, _gas_cost) ->
  Lwt.return (Script_repr.force_decode script_storage)
  >>|? fun (script_storage_expr, _gas_cost) ->
  let storage_expr = root script_storage_expr in
  match root script_code_expr with
  | Seq (_, toplevel) -> (
    match
      ( find_toplevel K_parameter toplevel,
        find_toplevel K_storage toplevel,
        find_toplevel K_code toplevel )
    with
    | ( Some
          (Prim
            ( _,
              K_parameter,
              [Prim (_, parameter_type, parameter_expr, parameter_annot)],
              prim_param_annot )),
        Some
          (Prim
            ( _,
              K_storage,
              [ Prim
                  (_, code_storage_type, code_storage_expr, code_storage_annot)
              ],
              k_storage_annot )),
        Some (Prim (_, K_code, [code_expr], code_annot)) ) ->
        (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
        let migrated_code =
          Seq
            ( 0,
              [ Prim
                  ( 0,
                    K_parameter,
                    [ Prim
                        ( 0,
                          T_or,
                          [ Prim
                              ( 0,
                                T_or,
                                [ Prim (0, T_key_hash, [], ["%set_delegate"]);
                                  Prim (0, T_unit, [], ["%remove_delegate"]) ],
                                [] );
                            Prim
                              ( 0,
                                parameter_type,
                                parameter_expr,
                                "%default" :: parameter_annot ) ],
                          [] ) ],
                    prim_param_annot );
                Prim
                  ( 0,
                    K_storage,
                    [ Prim
                        ( 0,
                          T_pair,
                          [ Prim (0, T_key_hash, [], []);
                            Prim
                              ( 0,
                                code_storage_type,
                                code_storage_expr,
                                code_storage_annot ) ],
                          [] ) ],
                    k_storage_annot );
                Prim
                  ( 0,
                    K_code,
                    [ Seq
                        ( 0,
                          [ Prim (0, I_DUP, [], []);
                            Prim (0, I_CAR, [], []);
                            Prim
                              ( 0,
                                I_IF_LEFT,
                                [ Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_PUSH,
                                            [ Prim (0, T_mutez, [], []);
                                              Int (0, Z.zero) ],
                                            [] );
                                        Prim (0, I_AMOUNT, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_COMPARE, [], []);
                                                    Prim (0, I_EQ, [], []) ] );
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq (0, []);
                                                    Seq
                                                      ( 0,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_UNIT,
                                                                    [],
                                                                    [] );
                                                                Prim
                                                                  ( 0,
                                                                    I_FAILWITH,
                                                                    [],
                                                                    [] ) ] ) ]
                                                      ) ],
                                                  [] ) ] );
                                        Seq
                                          ( 0,
                                            [ Prim
                                                ( 0,
                                                  I_DIP,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_DUP, [], [])
                                                        ] ) ],
                                                  [] );
                                              Prim (0, I_SWAP, [], []) ] );
                                        Prim (0, I_CDR, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                        Prim (0, I_ADDRESS, [], []);
                                        Prim (0, I_SENDER, [], []);
                                        Seq
                                          ( 0,
                                            [ Prim (0, I_COMPARE, [], []);
                                              Prim (0, I_NEQ, [], []);
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_SENDER,
                                                              [],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_PUSH,
                                                              [ Prim
                                                                  ( 0,
                                                                    T_string,
                                                                    [],
                                                                    [] );
                                                                String
                                                                  ( 0,
                                                                    "Only the \
                                                                     owner \
                                                                     can \
                                                                     operate."
                                                                  ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_FAILWITH,
                                                              [],
                                                              [] ) ] );
                                                    Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_DIP,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_CDR,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_NIL,
                                                                          [ Prim
                                                                              ( 
                                                                              0,
                                                                               T_operation,
                                                                               [],
                                                                               []
                                                                              )
                                                                          ],
                                                                          [] )
                                                                    ] ) ],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_IF_LEFT,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_SOME,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_SET_DELEGATE,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_CONS,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_PAIR,
                                                                          [],
                                                                          [] )
                                                                    ] );
                                                                Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_DROP,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_NONE,
                                                                          [ Prim
                                                                              ( 
                                                                              0,
                                                                               T_key_hash,
                                                                               [],
                                                                               []
                                                                              )
                                                                          ],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_SET_DELEGATE,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_CONS,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_PAIR,
                                                                          [],
                                                                          [] )
                                                                    ] ) ],
                                                              [] ) ] ) ],
                                                  [] ) ] ) ] );
                                  Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_CDR, [], []);
                                                    Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CDR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []);
                                        code_expr;
                                        Prim (0, I_SWAP, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_SWAP, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CAR, [], []);
                                                    Prim
                                                      ( 0,
                                                        I_DIP,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_CDR,
                                                                    [],
                                                                    [] ) ] ) ],
                                                        [] ) ] ) ] );
                                        Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_SWAP, [], []);
                                                    Prim (0, I_PAIR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []) ] ) ],
                                [] ) ] ) ],
                    code_annot ) ] )
        in
        let migrated_storage =
          Prim
            ( 0,
              D_Pair,
              [ (* Instead of
                   `String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
                   the storage is written as unparsed with [Optimized] *)
                Bytes
                  ( 0,
                    Data_encoding.Binary.to_bytes_exn
                      Signature.Public_key_hash.encoding
                      manager_pkh );
                storage_expr ],
              [] )
        in
        ( Script_repr.lazy_expr @@ strip_locations migrated_code,
          Script_repr.lazy_expr @@ strip_locations migrated_storage )
    | _ ->
        (script_code, script_storage) )
  | _ ->
      (script_code, script_storage)

let has_default_entrypoint expr =
  let open Micheline in
  let open Michelson_v1_primitives in
  match Script_repr.force_decode expr with
  | Error _ ->
      false
  | Ok (expr, _) -> (
    match root expr with
    | Seq (_, toplevel) -> (
      match find_toplevel K_parameter toplevel with
      | Some (Prim (_, K_parameter, [_], ["%default"])) ->
          false
      | Some (Prim (_, K_parameter, [parameter_expr], _)) ->
          let rec has_default = function
            | Prim (_, T_or, [l; r], annots) ->
                List.exists (String.equal "%default") annots
                || has_default l || has_default r
            | Prim (_, _, _, annots) ->
                List.exists (String.equal "%default") annots
            | _ ->
                false
          in
          has_default parameter_expr
      | Some _ | None ->
          false )
    | _ ->
        false )

let add_root_entrypoint :
    script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t =
 fun ~script_code ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>|? fun (script_code_expr, _gas_cost) ->
  match root script_code_expr with
  | Seq (_, toplevel) ->
      let migrated_code =
        Seq
          ( 0,
            List.map
              (function
                | Prim (_, K_parameter, [parameter_expr], _) ->
                    Prim (0, K_parameter, [parameter_expr], ["%root"])
                | Prim (_, K_code, exprs, annots) ->
                    let rec rewrite_self = function
                      | ( Int _
                        | String _
                        | Bytes _
                        | Prim (_, I_CREATE_CONTRACT, _, _) ) as leaf ->
                          leaf
                      | Prim (_, I_SELF, [], annots) ->
                          Prim (0, I_SELF, [], "%root" :: annots)
                      | Prim (_, name, args, annots) ->
                          Prim (0, name, List.map rewrite_self args, annots)
                      | Seq (_, args) ->
                          Seq (0, List.map rewrite_self args)
                    in
                    Prim (0, K_code, List.map rewrite_self exprs, annots)
                | other ->
                    other)
              toplevel )
      in
      Script_repr.lazy_expr @@ strip_locations migrated_code
  | _ ->
      script_code
src/proto_alpha/lib_protocol/legacy_script_support_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition manager_script_code
  : Tezos_raw_protocol_alpha.Script_repr.lazy_expr :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    Tezos_raw_protocol_alpha.Script_repr.lazy_expr
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
      (Seq 0
        (cons
          (Prim 0 K_parameter
            (cons
              (Prim 0 T_or
                (cons
                  (Prim 0 T_lambda
                    (cons (Prim 0 T_unit [] [])
                      (cons
                        (Prim 0 T_list (cons (Prim 0 T_operation [] []) []) [])
                        [])) (cons "%do" % string []))
                  (cons (Prim 0 T_unit [] (cons "%default" % string [])) [])) [])
              []) [])
          (cons (Prim 0 K_storage (cons (Prim 0 T_key_hash [] []) []) [])
            (cons
              (Prim 0 K_code
                (cons
                  (Seq 0
                    (cons
                      (Seq 0
                        (cons
                          (Seq 0
                            (cons (Prim 0 I_DUP [] [])
                              (cons (Prim 0 I_CAR [] [])
                                (cons
                                  (Prim 0 I_DIP
                                    (cons (Seq 0 (cons (Prim 0 I_CDR [] []) []))
                                      []) []) [])))) []))
                      (cons
                        (Prim 0 I_IF_LEFT
                          (cons
                            (Seq 0
                              (cons
                                (Prim 0 I_PUSH
                                  (cons (Prim 0 T_mutez [] [])
                                    (cons
                                      (Int 0
                                        Tezos_protocol_environment_alpha__Environment.Z.zero)
                                      [])) [])
                                (cons (Prim 0 I_AMOUNT [] [])
                                  (cons
                                    (Seq 0
                                      (cons
                                        (Seq 0
                                          (cons (Prim 0 I_COMPARE [] [])
                                            (cons (Prim 0 I_EQ [] []) [])))
                                        (cons
                                          (Prim 0 I_IF
                                            (cons (Seq 0 [])
                                              (cons
                                                (Seq 0
                                                  (cons
                                                    (Seq 0
                                                      (cons
                                                        (Prim 0 I_UNIT [] [])
                                                        (cons
                                                          (Prim 0 I_FAILWITH []
                                                            []) []))) [])) []))
                                            []) [])))
                                    (cons
                                      (Seq 0
                                        (cons
                                          (Prim 0 I_DIP
                                            (cons
                                              (Seq 0
                                                (cons (Prim 0 I_DUP [] []) []))
                                              []) [])
                                          (cons (Prim 0 I_SWAP [] []) [])))
                                      (cons (Prim 0 I_IMPLICIT_ACCOUNT [] [])
                                        (cons (Prim 0 I_ADDRESS [] [])
                                          (cons (Prim 0 I_SENDER [] [])
                                            (cons
                                              (Seq 0
                                                (cons
                                                  (Seq 0
                                                    (cons
                                                      (Prim 0 I_COMPARE [] [])
                                                      (cons (Prim 0 I_EQ [] [])
                                                        [])))
                                                  (cons
                                                    (Prim 0 I_IF
                                                      (cons (Seq 0 [])
                                                        (cons
                                                          (Seq 0
                                                            (cons
                                                              (Seq 0
                                                                (cons
                                                                  (Prim 0 I_UNIT
                                                                    [] [])
                                                                  (cons
                                                                    (Prim 0
                                                                      I_FAILWITH
                                                                      [] []) [])))
                                                              [])) [])) []) [])))
                                              (cons (Prim 0 I_UNIT [] [])
                                                (cons (Prim 0 I_EXEC [] [])
                                                  (cons (Prim 0 I_PAIR [] []) []))))))))))))
                            (cons
                              (Seq 0
                                (cons (Prim 0 I_DROP [] [])
                                  (cons
                                    (Prim 0 I_NIL
                                      (cons (Prim 0 T_operation [] []) []) [])
                                    (cons (Prim 0 I_PAIR [] []) [])))) [])) [])
                        []))) []) []) []))))).

Definition find_toplevel {A : Type}
  (toplevel : Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
  (exprs :
    list
      (Tezos_protocol_environment_alpha__Environment.Micheline.node A
        Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))
  : option
    (Tezos_protocol_environment_alpha__Environment.Micheline.node A
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
  let fix iter {B : Type}
    (toplevel : Tezos_protocol_environment_alpha__Environment.String.t)
    (function_parameter :
    list
      (Tezos_protocol_environment_alpha__Environment.Micheline.node B
        Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))
    : option
      (Tezos_protocol_environment_alpha__Environment.Micheline.node B
        Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
    match function_parameter with
    | cons ((Prim _ prim _ _) as found) _ => Some found
    | cons _ rest => iter toplevel rest
    | [] => None
    end in
  iter
    (Tezos_raw_protocol_alpha.Michelson_v1_primitives.string_of_prim toplevel)
    exprs.

Definition add_do
  (manager_pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  (script_storage : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Script_repr.lazy_expr *
        Tezos_raw_protocol_alpha.Script_repr.lazy_expr)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Script_repr.force_decode script_code))
    (fun function_parameter =>
      match function_parameter with
      | (script_code_expr, _gas_cost) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Script_repr.force_decode script_storage))
          (fun function_parameter =>
            match function_parameter with
            | (script_storage_expr, _gas_cost) =>
              let storage_expr :=
                Tezos_protocol_environment_alpha__Environment.Micheline.root
                  script_storage_expr in
              match
                Tezos_protocol_environment_alpha__Environment.Micheline.root
                  script_code_expr with
              | Seq _ toplevel =>
                match
                  ((find_toplevel K_parameter toplevel),
                    (find_toplevel K_storage toplevel),
                    (find_toplevel K_code toplevel)) with
                |
                  (Some
                    (Prim _ K_parameter
                      (cons
                        (Prim _ parameter_type parameter_expr parameter_annot)
                        []) prim_param_annot),
                    Some
                      (Prim _ K_storage
                        (cons
                          (Prim _ code_storage_type code_storage_expr
                            code_storage_annot) []) k_storage_annot),
                    Some (Prim _ K_code (cons code_expr []) code_annot)) =>
                  let migrated_code :=
                    Seq 0
                      (cons
                        (Prim 0 K_parameter
                          (cons
                            (Prim 0 T_or
                              (cons
                                (Prim 0 T_lambda
                                  (cons (Prim 0 T_unit [] [])
                                    (cons
                                      (Prim 0 T_list
                                        (cons (Prim 0 T_operation [] []) []) [])
                                      [])) (cons "%do" % string []))
                                (cons
                                  (Prim 0 parameter_type parameter_expr
                                    (cons "%default" % string parameter_annot))
                                  [])) []) []) prim_param_annot)
                        (cons
                          (Prim 0 K_storage
                            (cons
                              (Prim 0 T_pair
                                (cons (Prim 0 T_key_hash [] [])
                                  (cons
                                    (Prim 0 code_storage_type code_storage_expr
                                      code_storage_annot) [])) []) [])
                            k_storage_annot)
                          (cons
                            (Prim 0 K_code
                              (cons
                                (Seq 0
                                  (cons (Prim 0 I_DUP [] [])
                                    (cons (Prim 0 I_CAR [] [])
                                      (cons
                                        (Prim 0 I_IF_LEFT
                                          (cons
                                            (Seq 0
                                              (cons
                                                (Prim 0 I_PUSH
                                                  (cons (Prim 0 T_mutez [] [])
                                                    (cons
                                                      (Int 0
                                                        Tezos_protocol_environment_alpha__Environment.Z.zero)
                                                      [])) [])
                                                (cons (Prim 0 I_AMOUNT [] [])
                                                  (cons
                                                    (Seq 0
                                                      (cons
                                                        (Seq 0
                                                          (cons
                                                            (Prim 0 I_COMPARE []
                                                              [])
                                                            (cons
                                                              (Prim 0 I_EQ [] [])
                                                              [])))
                                                        (cons
                                                          (Prim 0 I_IF
                                                            (cons (Seq 0 [])
                                                              (cons
                                                                (Seq 0
                                                                  (cons
                                                                    (Seq 0
                                                                      (cons
                                                                        (Prim 0
                                                                          I_UNIT
                                                                          [] [])
                                                                        (cons
                                                                          (Prim
                                                                            0
                                                                            I_FAILWITH
                                                                            []
                                                                            [])
                                                                          [])))
                                                                    [])) [])) [])
                                                          [])))
                                                    (cons
                                                      (Seq 0
                                                        (cons
                                                          (Prim 0 I_DIP
                                                            (cons
                                                              (Seq 0
                                                                (cons
                                                                  (Prim 0 I_DUP
                                                                    [] []) []))
                                                              []) [])
                                                          (cons
                                                            (Prim 0 I_SWAP [] [])
                                                            [])))
                                                      (cons (Prim 0 I_CDR [] [])
                                                        (cons
                                                          (Prim 0 I_CAR [] [])
                                                          (cons
                                                            (Prim 0
                                                              I_IMPLICIT_ACCOUNT
                                                              [] [])
                                                            (cons
                                                              (Prim 0 I_ADDRESS
                                                                [] [])
                                                              (cons
                                                                (Prim 0 I_SENDER
                                                                  [] [])
                                                                (cons
                                                                  (Seq 0
                                                                    (cons
                                                                      (Prim 0
                                                                        I_COMPARE
                                                                        [] [])
                                                                      (cons
                                                                        (Prim 0
                                                                          I_NEQ
                                                                          [] [])
                                                                        (cons
                                                                          (Prim
                                                                            0
                                                                            I_IF
                                                                            (cons
                                                                              (Seq
                                                                                0
                                                                                (cons
                                                                                  (Prim
                                                                                    0
                                                                                    I_SENDER
                                                                                    []
                                                                                    [])
                                                                                  (cons
                                                                                    (Prim
                                                                                      0
                                                                                      I_PUSH
                                                                                      (cons
                                                                                        (Prim
                                                                                          0
                                                                                          T_string
                                                                                          []
                                                                                          [])
                                                                                        (cons
                                                                                          (String
                                                                                            0
                                                                                            "Only the owner can operate."
                                                                                              %
                                                                                              string)
                                                                                          []))
                                                                                      [])
                                                                                    (cons
                                                                                      (Prim
                                                                                        0
                                                                                        I_PAIR
                                                                                        []
                                                                                        [])
                                                                                      (cons
                                                                                        (Prim
                                                                                          0
                                                                                          I_FAILWITH
                                                                                          []
                                                                                          [])
                                                                                        [])))))
                                                                              (cons
                                                                                (Seq
                                                                                  0
                                                                                  (cons
                                                                                    (Prim
                                                                                      0
                                                                                      I_UNIT
                                                                                      []
                                                                                      [])
                                                                                    (cons
                                                                                      (Prim
                                                                                        0
                                                                                        I_EXEC
                                                                                        []
                                                                                        [])
                                                                                      (cons
                                                                                        (Prim
                                                                                          0
                                                                                          I_DIP
                                                                                          (cons
                                                                                            (Seq
                                                                                              0
                                                                                              (cons
                                                                                                (Prim
                                                                                                  0
                                                                                                  I_CDR
                                                                                                  []
                                                                                                  [])
                                                                                                []))
                                                                                            [])
                                                                                          [])
                                                                                        (cons
                                                                                          (Prim
                                                                                            0
                                                                                            I_PAIR
                                                                                            []
                                                                                            [])
                                                                                          [])))))
                                                                                []))
                                                                            [])
                                                                          []))))
                                                                  [])))))))))))
                                            (cons
                                              (Seq 0
                                                (cons
                                                  (Prim 0 I_DIP
                                                    (cons
                                                      (Seq 0
                                                        (cons
                                                          (Prim 0 I_CDR [] [])
                                                          (cons
                                                            (Prim 0 I_DUP [] [])
                                                            (cons
                                                              (Prim 0 I_CDR []
                                                                []) [])))) [])
                                                    [])
                                                  (cons (Prim 0 I_PAIR [] [])
                                                    (cons code_expr
                                                      (cons
                                                        (Prim 0 I_SWAP [] [])
                                                        (cons
                                                          (Prim 0 I_CAR [] [])
                                                          (cons
                                                            (Prim 0 I_SWAP [] [])
                                                            (cons
                                                              (Seq 0
                                                                (cons
                                                                  (Seq 0
                                                                    (cons
                                                                      (Prim 0
                                                                        I_DUP []
                                                                        [])
                                                                      (cons
                                                                        (Prim 0
                                                                          I_CAR
                                                                          [] [])
                                                                        (cons
                                                                          (Prim
                                                                            0
                                                                            I_DIP
                                                                            (cons
                                                                              (Seq
                                                                                0
                                                                                (cons
                                                                                  (Prim
                                                                                    0
                                                                                    I_CDR
                                                                                    []
                                                                                    [])
                                                                                  []))
                                                                              [])
                                                                            [])
                                                                          []))))
                                                                  []))
                                                              (cons
                                                                (Prim 0 I_DIP
                                                                  (cons
                                                                    (Seq 0
                                                                      (cons
                                                                        (Prim 0
                                                                          I_SWAP
                                                                          [] [])
                                                                        (cons
                                                                          (Prim
                                                                            0
                                                                            I_PAIR
                                                                            []
                                                                            [])
                                                                          [])))
                                                                    []) [])
                                                                (cons
                                                                  (Prim 0 I_PAIR
                                                                    [] []) []))))))))))
                                              [])) []) [])))) []) code_annot) [])))
                    in
                  let migrated_storage :=
                    Prim 0 D_Pair
                      (cons
                        (Bytes 0
                          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
                            manager_pkh)) (cons storage_expr [])) [] in
                  ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                    Tezos_raw_protocol_alpha.Script_repr.lazy_expr
                    (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                      migrated_code)),
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      Tezos_raw_protocol_alpha.Script_repr.lazy_expr
                      (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                        migrated_storage)))
                | _ => (script_code, script_storage)
                end
              | _ => (script_code, script_storage)
              end
            end)
      end).

Definition add_set_delegate
  (manager_pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  (script_storage : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Script_repr.lazy_expr *
        Tezos_raw_protocol_alpha.Script_repr.lazy_expr)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Script_repr.force_decode script_code))
    (fun function_parameter =>
      match function_parameter with
      | (script_code_expr, _gas_cost) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Script_repr.force_decode script_storage))
          (fun function_parameter =>
            match function_parameter with
            | (script_storage_expr, _gas_cost) =>
              let storage_expr :=
                Tezos_protocol_environment_alpha__Environment.Micheline.root
                  script_storage_expr in
              match
                Tezos_protocol_environment_alpha__Environment.Micheline.root
                  script_code_expr with
              | Seq _ toplevel =>
                match
                  ((find_toplevel K_parameter toplevel),
                    (find_toplevel K_storage toplevel),
                    (find_toplevel K_code toplevel)) with
                |
                  (Some
                    (Prim _ K_parameter
                      (cons
                        (Prim _ parameter_type parameter_expr parameter_annot)
                        []) prim_param_annot),
                    Some
                      (Prim _ K_storage
                        (cons
                          (Prim _ code_storage_type code_storage_expr
                            code_storage_annot) []) k_storage_annot),
                    Some (Prim _ K_code (cons code_expr []) code_annot)) =>
                  let migrated_code :=
                    Seq 0
                      (cons
                        (Prim 0 K_parameter
                          (cons
                            (Prim 0 T_or
                              (cons
                                (Prim 0 T_or
                                  (cons
                                    (Prim 0 T_key_hash []
                                      (cons "%set_delegate" % string []))
                                    (cons
                                      (Prim 0 T_unit []
                                        (cons "%remove_delegate" % string []))
                                      [])) [])
                                (cons
                                  (Prim 0 parameter_type parameter_expr
                                    (cons "%default" % string parameter_annot))
                                  [])) []) []) prim_param_annot)
                        (cons
                          (Prim 0 K_storage
                            (cons
                              (Prim 0 T_pair
                                (cons (Prim 0 T_key_hash [] [])
                                  (cons
                                    (Prim 0 code_storage_type code_storage_expr
                                      code_storage_annot) [])) []) [])
                            k_storage_annot)
                          (cons
                            (Prim 0 K_code
                              (cons
                                (Seq 0
                                  (cons (Prim 0 I_DUP [] [])
                                    (cons (Prim 0 I_CAR [] [])
                                      (cons
                                        (Prim 0 I_IF_LEFT
                                          (cons
                                            (Seq 0
                                              (cons
                                                (Prim 0 I_PUSH
                                                  (cons (Prim 0 T_mutez [] [])
                                                    (cons
                                                      (Int 0
                                                        Tezos_protocol_environment_alpha__Environment.Z.zero)
                                                      [])) [])
                                                (cons (Prim 0 I_AMOUNT [] [])
                                                  (cons
                                                    (Seq 0
                                                      (cons
                                                        (Seq 0
                                                          (cons
                                                            (Prim 0 I_COMPARE []
                                                              [])
                                                            (cons
                                                              (Prim 0 I_EQ [] [])
                                                              [])))
                                                        (cons
                                                          (Prim 0 I_IF
                                                            (cons (Seq 0 [])
                                                              (cons
                                                                (Seq 0
                                                                  (cons
                                                                    (Seq 0
                                                                      (cons
                                                                        (Prim 0
                                                                          I_UNIT
                                                                          [] [])
                                                                        (cons
                                                                          (Prim
                                                                            0
                                                                            I_FAILWITH
                                                                            []
                                                                            [])
                                                                          [])))
                                                                    [])) [])) [])
                                                          [])))
                                                    (cons
                                                      (Seq 0
                                                        (cons
                                                          (Prim 0 I_DIP
                                                            (cons
                                                              (Seq 0
                                                                (cons
                                                                  (Prim 0 I_DUP
                                                                    [] []) []))
                                                              []) [])
                                                          (cons
                                                            (Prim 0 I_SWAP [] [])
                                                            [])))
                                                      (cons (Prim 0 I_CDR [] [])
                                                        (cons
                                                          (Prim 0 I_CAR [] [])
                                                          (cons
                                                            (Prim 0
                                                              I_IMPLICIT_ACCOUNT
                                                              [] [])
                                                            (cons
                                                              (Prim 0 I_ADDRESS
                                                                [] [])
                                                              (cons
                                                                (Prim 0 I_SENDER
                                                                  [] [])
                                                                (cons
                                                                  (Seq 0
                                                                    (cons
                                                                      (Prim 0
                                                                        I_COMPARE
                                                                        [] [])
                                                                      (cons
                                                                        (Prim 0
                                                                          I_NEQ
                                                                          [] [])
                                                                        (cons
                                                                          (Prim
                                                                            0
                                                                            I_IF
                                                                            (cons
                                                                              (Seq
                                                                                0
                                                                                (cons
                                                                                  (Prim
                                                                                    0
                                                                                    I_SENDER
                                                                                    []
                                                                                    [])
                                                                                  (cons
                                                                                    (Prim
                                                                                      0
                                                                                      I_PUSH
                                                                                      (cons
                                                                                        (Prim
                                                                                          0
                                                                                          T_string
                                                                                          []
                                                                                          [])
                                                                                        (cons
                                                                                          (String
                                                                                            0
                                                                                            "Only the owner can operate."
                                                                                              %
                                                                                              string)
                                                                                          []))
                                                                                      [])
                                                                                    (cons
                                                                                      (Prim
                                                                                        0
                                                                                        I_PAIR
                                                                                        []
                                                                                        [])
                                                                                      (cons
                                                                                        (Prim
                                                                                          0
                                                                                          I_FAILWITH
                                                                                          []
                                                                                          [])
                                                                                        [])))))
                                                                              (cons
                                                                                (Seq
                                                                                  0
                                                                                  (cons
                                                                                    (Prim
                                                                                      0
                                                                                      I_DIP
                                                                                      (cons
                                                                                        (Seq
                                                                                          0
                                                                                          (cons
                                                                                            (Prim
                                                                                              0
                                                                                              I_CDR
                                                                                              []
                                                                                              [])
                                                                                            (cons
                                                                                              (Prim
                                                                                                0
                                                                                                I_NIL
                                                                                                (cons
                                                                                                  (Prim
                                                                                                    0
                                                                                                    T_operation
                                                                                                    []
                                                                                                    [])
                                                                                                  [])
                                                                                                [])
                                                                                              [])))
                                                                                        [])
                                                                                      [])
                                                                                    (cons
                                                                                      (Prim
                                                                                        0
                                                                                        I_IF_LEFT
                                                                                        (cons
                                                                                          (Seq
                                                                                            0
                                                                                            (cons
                                                                                              (Prim
                                                                                                0
                                                                                                I_SOME
                                                                                                []
                                                                                                [])
                                                                                              (cons
                                                                                                (Prim
                                                                                                  0
                                                                                                  I_SET_DELEGATE
                                                                                                  []
                                                                                                  [])
                                                                                                (cons
                                                                                                  (Prim
                                                                                                    0
                                                                                                    I_CONS
                                                                                                    []
                                                                                                    [])
                                                                                                  (cons
                                                                                                    (Prim
                                                                                                      0
                                                                                                      I_PAIR
                                                                                                      []
                                                                                                      [])
                                                                                                    [])))))
                                                                                          (cons
                                                                                            (Seq
                                                                                              0
                                                                                              (cons
                                                                                                (Prim
                                                                                                  0
                                                                                                  I_DROP
                                                                                                  []
                                                                                                  [])
                                                                                                (cons
                                                                                                  (Prim
                                                                                                    0
                                                                                                    I_NONE
                                                                                                    (cons
                                                                                                      (Prim
                                                                                                        0
                                                                                                        T_key_hash
                                                                                                        []
                                                                                                        [])
                                                                                                      [])
                                                                                                    [])
                                                                                                  (cons
                                                                                                    (Prim
                                                                                                      0
                                                                                                      I_SET_DELEGATE
                                                                                                      []
                                                                                                      [])
                                                                                                    (cons
                                                                                                      (Prim
                                                                                                        0
                                                                                                        I_CONS
                                                                                                        []
                                                                                                        [])
                                                                                                      (cons
                                                                                                        (Prim
                                                                                                          0
                                                                                                          I_PAIR
                                                                                                          []
                                                                                                          [])
                                                                                                        []))))))
                                                                                            []))
                                                                                        [])
                                                                                      [])))
                                                                                []))
                                                                            [])
                                                                          []))))
                                                                  [])))))))))))
                                            (cons
                                              (Seq 0
                                                (cons
                                                  (Prim 0 I_DIP
                                                    (cons
                                                      (Seq 0
                                                        (cons
                                                          (Prim 0 I_CDR [] [])
                                                          (cons
                                                            (Prim 0 I_DUP [] [])
                                                            (cons
                                                              (Prim 0 I_CDR []
                                                                []) [])))) [])
                                                    [])
                                                  (cons (Prim 0 I_PAIR [] [])
                                                    (cons code_expr
                                                      (cons
                                                        (Prim 0 I_SWAP [] [])
                                                        (cons
                                                          (Prim 0 I_CAR [] [])
                                                          (cons
                                                            (Prim 0 I_SWAP [] [])
                                                            (cons
                                                              (Seq 0
                                                                (cons
                                                                  (Seq 0
                                                                    (cons
                                                                      (Prim 0
                                                                        I_DUP []
                                                                        [])
                                                                      (cons
                                                                        (Prim 0
                                                                          I_CAR
                                                                          [] [])
                                                                        (cons
                                                                          (Prim
                                                                            0
                                                                            I_DIP
                                                                            (cons
                                                                              (Seq
                                                                                0
                                                                                (cons
                                                                                  (Prim
                                                                                    0
                                                                                    I_CDR
                                                                                    []
                                                                                    [])
                                                                                  []))
                                                                              [])
                                                                            [])
                                                                          []))))
                                                                  []))
                                                              (cons
                                                                (Prim 0 I_DIP
                                                                  (cons
                                                                    (Seq 0
                                                                      (cons
                                                                        (Prim 0
                                                                          I_SWAP
                                                                          [] [])
                                                                        (cons
                                                                          (Prim
                                                                            0
                                                                            I_PAIR
                                                                            []
                                                                            [])
                                                                          [])))
                                                                    []) [])
                                                                (cons
                                                                  (Prim 0 I_PAIR
                                                                    [] []) []))))))))))
                                              [])) []) [])))) []) code_annot) [])))
                    in
                  let migrated_storage :=
                    Prim 0 D_Pair
                      (cons
                        (Bytes 0
                          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
                            manager_pkh)) (cons storage_expr [])) [] in
                  ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                    Tezos_raw_protocol_alpha.Script_repr.lazy_expr
                    (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                      migrated_code)),
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      Tezos_raw_protocol_alpha.Script_repr.lazy_expr
                      (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                        migrated_storage)))
                | _ => (script_code, script_storage)
                end
              | _ => (script_code, script_storage)
              end
            end)
      end).

Definition has_default_entrypoint
  (expr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr) : bool :=
  match Tezos_raw_protocol_alpha.Script_repr.force_decode expr with
  | inr _ => false
  | inl (expr, _) =>
    match Tezos_protocol_environment_alpha__Environment.Micheline.root expr with
    | Seq _ toplevel =>
      match find_toplevel K_parameter toplevel with
      | Some (Prim _ K_parameter (cons _ []) (cons "%default" % string [])) =>
        false
      | Some (Prim _ K_parameter (cons parameter_expr []) _) =>
        let fix has_default {A : Type}
          (function_parameter :
          Tezos_protocol_environment_alpha__Environment.Micheline.node A
            Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) : bool :=
          match function_parameter with
          | Prim _ T_or (cons l (cons r [])) annots =>
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
              (Tezos_protocol_environment_alpha__Environment.List._exists
                (Tezos_protocol_environment_alpha__Environment.String.equal
                  "%default" % string) annots)
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                (has_default l) (has_default r))
          | Prim _ _ _ annots =>
            Tezos_protocol_environment_alpha__Environment.List._exists
              (Tezos_protocol_environment_alpha__Environment.String.equal
                "%default" % string) annots
          | _ => false
          end in
        has_default parameter_expr
      | Some _ | None => false
      end
    | _ => false
    end
  end.

Definition add_root_entrypoint
  (script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Script_repr.lazy_expr) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Script_repr.force_decode script_code))
    (fun function_parameter =>
      match function_parameter with
      | (script_code_expr, _gas_cost) =>
        match
          Tezos_protocol_environment_alpha__Environment.Micheline.root
            script_code_expr with
        | Seq _ toplevel =>
          let migrated_code :=
            Seq 0
              (Tezos_protocol_environment_alpha__Environment.List.map
                (fun function_parameter =>
                  match function_parameter with
                  | Prim _ K_parameter (cons parameter_expr []) _ =>
                    Prim 0 K_parameter (cons parameter_expr [])
                      (cons "%root" % string [])
                  | Prim _ K_code exprs annots =>
                    let fix rewrite_self
                      (function_parameter :
                      Tezos_protocol_environment_alpha__Environment.Micheline.node
                        Z Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
                      : Tezos_protocol_environment_alpha__Environment.Micheline.node
                        Z Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim :=
                      match function_parameter with
                      |
                        (Int _ _ | String _ _ | Bytes _ _ |
                          Prim _ I_CREATE_CONTRACT _ _) as leaf => leaf
                      | Prim _ I_SELF [] annots =>
                        Prim 0 I_SELF [] (cons "%root" % string annots)
                      | Prim _ name args annots =>
                        Prim 0 name
                          (Tezos_protocol_environment_alpha__Environment.List.map
                            rewrite_self args) annots
                      | Seq _ args =>
                        Seq 0
                          (Tezos_protocol_environment_alpha__Environment.List.map
                            rewrite_self args)
                      end in
                    Prim 0 K_code
                      (Tezos_protocol_environment_alpha__Environment.List.map
                        rewrite_self exprs) annots
                  | other => other
                  end) toplevel) in
          Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_raw_protocol_alpha.Script_repr.lazy_expr
            (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
              migrated_code)
        | _ => script_code
        end
      end).
src/proto_alpha/lib_protocol/legacy_script_support_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com>              *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** This code mimics the now defunct scriptless KT1s.

    The manager contract is from:
    https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/manager.tz
    The formal proof is at:
    https://gitlab.com/nomadic-labs/mi-cho-coq/blob/a7603e12021166e15890f6d504feebec2f945502/src/contracts_coq/manager.v *)
val manager_script_code : Script_repr.lazy_expr

(** This code mimics the now defunct "spendable" flags of KT1s by
    adding a [do] entrypoint, preserving the original script's at
    'default' entrypoint.

    The pseudo-code for the applied transformations is from:
    https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_do.tz *)
val add_do :
  manager_pkh:Signature.Public_key_hash.t ->
  script_code:Script_repr.lazy_expr ->
  script_storage:Script_repr.lazy_expr ->
  (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t

(** This code mimics the now defunct "spendable" flags of KT1s by
    adding a [do] entrypoint, preserving the original script's at
    'default' entrypoint.

    The pseudo-code for the applied transformations is from:
    https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_set_delegate.tz *)
val add_set_delegate :
  manager_pkh:Signature.Public_key_hash.t ->
  script_code:Script_repr.lazy_expr ->
  script_storage:Script_repr.lazy_expr ->
  (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t

(** Checks if a contract was declaring a default entrypoint somewhere
   else than at the root, in which case its type changes when
   entrypoints are activated. *)
val has_default_entrypoint : Script_repr.lazy_expr -> bool

(** Adds a [%root] annotation on the toplevel parameter construct. *)
val add_root_entrypoint :
  script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t
src/proto_alpha/lib_protocol/legacy_script_support_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter manager_script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr.

Parameter add_do :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Script_repr.lazy_expr ->
    Tezos_raw_protocol_alpha.Script_repr.lazy_expr ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Script_repr.lazy_expr *
            Tezos_raw_protocol_alpha.Script_repr.lazy_expr)).

Parameter add_set_delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Script_repr.lazy_expr ->
    Tezos_raw_protocol_alpha.Script_repr.lazy_expr ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Script_repr.lazy_expr *
            Tezos_raw_protocol_alpha.Script_repr.lazy_expr)).

Parameter has_default_entrypoint :
Tezos_raw_protocol_alpha.Script_repr.lazy_expr -> bool.

Parameter add_root_entrypoint :
Tezos_raw_protocol_alpha.Script_repr.lazy_expr ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Script_repr.lazy_expr).
src/proto_alpha/lib_protocol/level_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  level : Raw_level_repr.t;
  level_position : int32;
  cycle : Cycle_repr.t;
  cycle_position : int32;
  voting_period : Voting_period_repr.t;
  voting_period_position : int32;
  expected_commitment : bool;
}

include Compare.Make (struct
  type nonrec t = t

  let compare {level = l1} {level = l2} = Raw_level_repr.compare l1 l2
end)

type level = t

let pp ppf {level} = Raw_level_repr.pp ppf level

let pp_full ppf l =
  Format.fprintf
    ppf
    "%a.%ld (cycle %a.%ld) (vote %a.%ld)"
    Raw_level_repr.pp
    l.level
    l.level_position
    Cycle_repr.pp
    l.cycle
    l.cycle_position
    Voting_period_repr.pp
    l.voting_period
    l.voting_period_position

let encoding =
  let open Data_encoding in
  conv
    (fun { level;
           level_position;
           cycle;
           cycle_position;
           voting_period;
           voting_period_position;
           expected_commitment } ->
      ( level,
        level_position,
        cycle,
        cycle_position,
        voting_period,
        voting_period_position,
        expected_commitment ))
    (fun ( level,
           level_position,
           cycle,
           cycle_position,
           voting_period,
           voting_period_position,
           expected_commitment ) ->
      {
        level;
        level_position;
        cycle;
        cycle_position;
        voting_period;
        voting_period_position;
        expected_commitment;
      })
    (obj7
       (req
          "level"
          ~description:
            "The level of the block relative to genesis. This is also the \
             Shell's notion of level"
          Raw_level_repr.encoding)
       (req
          "level_position"
          ~description:
            "The level of the block relative to the block that starts \
             protocol alpha. This is specific to the protocol alpha. Other \
             protocols might or might not include a similar notion."
          int32)
       (req
          "cycle"
          ~description:
            "The current cycle's number. Note that cycles are a \
             protocol-specific notion. As a result, the cycle number starts \
             at 0 with the first block of protocol alpha."
          Cycle_repr.encoding)
       (req
          "cycle_position"
          ~description:
            "The current level of the block relative to the first block of \
             the current cycle."
          int32)
       (req
          "voting_period"
          ~description:
            "The current voting period's index. Note that cycles are a \
             protocol-specific notion. As a result, the voting period index \
             starts at 0 with the first block of protocol alpha."
          Voting_period_repr.encoding)
       (req
          "voting_period_position"
          ~description:
            "The current level of the block relative to the first block of \
             the current voting period."
          int32)
       (req
          "expected_commitment"
          ~description:
            "Tells wether the baker of this block has to commit a seed nonce \
             hash."
          bool))

let root first_level =
  {
    level = first_level;
    level_position = 0l;
    cycle = Cycle_repr.root;
    cycle_position = 0l;
    voting_period = Voting_period_repr.root;
    voting_period_position = 0l;
    expected_commitment = false;
  }

let from_raw ~first_level ~blocks_per_cycle ~blocks_per_voting_period
    ~blocks_per_commitment level =
  let raw_level = Raw_level_repr.to_int32 level in
  let first_level = Raw_level_repr.to_int32 first_level in
  let level_position =
    Compare.Int32.max 0l (Int32.sub raw_level first_level)
  in
  let cycle =
    Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle)
  in
  let cycle_position = Int32.rem level_position blocks_per_cycle in
  let voting_period =
    Voting_period_repr.of_int32_exn
      (Int32.div level_position blocks_per_voting_period)
  in
  let voting_period_position =
    Int32.rem level_position blocks_per_voting_period
  in
  let expected_commitment =
    Compare.Int32.(
      Int32.rem cycle_position blocks_per_commitment
      = Int32.pred blocks_per_commitment)
  in
  {
    level;
    level_position;
    cycle;
    cycle_position;
    voting_period;
    voting_period_position;
    expected_commitment;
  }

let diff {level = l1; _} {level = l2; _} =
  Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2)
src/proto_alpha/lib_protocol/level_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  level : Tezos_raw_protocol_alpha.Raw_level_repr.t;
  level_position : int32;
  cycle : Tezos_raw_protocol_alpha.Cycle_repr.t;
  cycle_position : int32;
  voting_period : Tezos_raw_protocol_alpha.Voting_period_repr.t;
  voting_period_position : int32;
  expected_commitment : bool }.

Definition level := t.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : t) : unit :=
  match function_parameter with
  | {| level := level |} => Tezos_raw_protocol_alpha.Raw_level_repr.pp ppf level
  end.

Definition pp_full
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter) (l : t)
  : unit :=
  Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha
        (CamlinternalFormatBasics.Char_literal "." % char
          (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " (cycle " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") (vote " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "." % char
                          (CamlinternalFormatBasics.Int32
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format))))))))))))
      "%a.%ld (cycle %a.%ld) (vote %a.%ld)" % string)
    Tezos_raw_protocol_alpha.Raw_level_repr.pp (level l) (level_position l)
    Tezos_raw_protocol_alpha.Cycle_repr.pp (cycle l) (cycle_position l)
    Tezos_raw_protocol_alpha.Voting_period_repr.pp (voting_period l)
    (voting_period_position l).

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        level := level;
          level_position := level_position;
          cycle := cycle;
          cycle_position := cycle_position;
          voting_period := voting_period;
          voting_period_position := voting_period_position;
          expected_commitment := expected_commitment
          |} =>
        (level, level_position, cycle, cycle_position, voting_period,
          voting_period_position, expected_commitment)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        (level, level_position, cycle, cycle_position, voting_period,
          voting_period_position, expected_commitment) =>
        {| level := level; level_position := level_position; cycle := cycle;
          cycle_position := cycle_position; voting_period := voting_period;
          voting_period_position := voting_period_position;
          expected_commitment := expected_commitment |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj7
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
        (Some
          "The level of the block relative to genesis. This is also the Shell's notion of level"
            % string) "level" % string
        Tezos_raw_protocol_alpha.Raw_level_repr.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
        (Some
          "The level of the block relative to the block that starts protocol alpha. This is specific to the protocol alpha. Other protocols might or might not include a similar notion."
            % string) "level_position" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
        (Some
          "The current cycle's number. Note that cycles are a protocol-specific notion. As a result, the cycle number starts at 0 with the first block of protocol alpha."
            % string) "cycle" % string
        Tezos_raw_protocol_alpha.Cycle_repr.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
        (Some
          "The current level of the block relative to the first block of the current cycle."
            % string) "cycle_position" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
        (Some
          "The current voting period's index. Note that cycles are a protocol-specific notion. As a result, the voting period index starts at 0 with the first block of protocol alpha."
            % string) "voting_period" % string
        Tezos_raw_protocol_alpha.Voting_period_repr.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
        (Some
          "The current level of the block relative to the first block of the current voting period."
            % string) "voting_period_position" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
        (Some
          "Tells wether the baker of this block has to commit a seed nonce hash."
            % string) "expected_commitment" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.bool)).

Definition root (first_level : Tezos_raw_protocol_alpha.Raw_level_repr.t) : t :=
  {| level := first_level; level_position := 0;
    cycle := Tezos_raw_protocol_alpha.Cycle_repr.root; cycle_position := 0;
    voting_period := Tezos_raw_protocol_alpha.Voting_period_repr.root;
    voting_period_position := 0; expected_commitment := false |}.

Definition from_raw
  (first_level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
  (blocks_per_cycle : int32) (blocks_per_voting_period : int32)
  (blocks_per_commitment : int32)
  (level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level) : t :=
  let raw_level := Tezos_raw_protocol_alpha.Raw_level_repr.to_int32 level in
  let first_level :=
    Tezos_raw_protocol_alpha.Raw_level_repr.to_int32 first_level in
  let level_position :=
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
      0
      (Tezos_protocol_environment_alpha__Environment.Int32.sub raw_level
        first_level) in
  let cycle :=
    Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn
      (Tezos_protocol_environment_alpha__Environment.Int32.div level_position
        blocks_per_cycle) in
  let cycle_position :=
    Tezos_protocol_environment_alpha__Environment.Int32.rem level_position
      blocks_per_cycle in
  let voting_period :=
    Tezos_raw_protocol_alpha.Voting_period_repr.of_int32_exn
      (Tezos_protocol_environment_alpha__Environment.Int32.div level_position
        blocks_per_voting_period) in
  let voting_period_position :=
    Tezos_protocol_environment_alpha__Environment.Int32.rem level_position
      blocks_per_voting_period in
  let expected_commitment :=
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
      (Tezos_protocol_environment_alpha__Environment.Int32.rem cycle_position
        blocks_per_commitment)
      (Tezos_protocol_environment_alpha__Environment.Int32.pred
        blocks_per_commitment) in
  {| level := level; level_position := level_position; cycle := cycle;
    cycle_position := cycle_position; voting_period := voting_period;
    voting_period_position := voting_period_position;
    expected_commitment := expected_commitment |}.

Definition diff (function_parameter : t) : t -> int32 :=
  match function_parameter with
  | {| level := l1 |} =>
    fun function_parameter =>
      match function_parameter with
      | {| level := l2 |} =>
        Tezos_protocol_environment_alpha__Environment.Int32.sub
          (Tezos_raw_protocol_alpha.Raw_level_repr.to_int32 l1)
          (Tezos_raw_protocol_alpha.Raw_level_repr.to_int32 l2)
      end
  end.
src/proto_alpha/lib_protocol/level_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = private {
  level : Raw_level_repr.t;
      (** The level of the block relative to genesis. This
                              is also the Shell's notion of level. *)
  level_position : int32;
      (** The level of the block relative to the block that
                            starts protocol alpha. This is specific to the
                            protocol alpha. Other protocols might or might not
                            include a similar notion. *)
  cycle : Cycle_repr.t;
      (** The current cycle's number. Note that cycles are a
                          protocol-specific notion. As a result, the cycle
                          number starts at 0 with the first block of protocol
                          alpha. *)
  cycle_position : int32;
      (** The current level of the block relative to the first
                            block of the current cycle. *)
  voting_period : Voting_period_repr.t;
  voting_period_position : int32;
  expected_commitment : bool;
}

(* Note that, the type `t` above must respect some invariants (hence the
   `private` annotation). Notably:

   level_position = cycle * blocks_per_cycle + cycle_position
*)

type level = t

include Compare.S with type t := level

val encoding : level Data_encoding.t

val pp : Format.formatter -> level -> unit

val pp_full : Format.formatter -> level -> unit

val root : Raw_level_repr.t -> level

val from_raw :
  first_level:Raw_level_repr.t ->
  blocks_per_cycle:int32 ->
  blocks_per_voting_period:int32 ->
  blocks_per_commitment:int32 ->
  Raw_level_repr.t ->
  level

val diff : level -> level -> int32
src/proto_alpha/lib_protocol/level_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  level : Tezos_raw_protocol_alpha.Raw_level_repr.t;
  level_position : int32;
  cycle : Tezos_raw_protocol_alpha.Cycle_repr.t;
  cycle_position : int32;
  voting_period : Tezos_raw_protocol_alpha.Voting_period_repr.t;
  voting_period_position : int32;
  expected_commitment : bool }.

Definition level := t.

include

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t level.

Parameter pp :
Tezos_protocol_environment_alpha__Environment.Format.formatter -> level -> unit.

Parameter pp_full :
Tezos_protocol_environment_alpha__Environment.Format.formatter -> level -> unit.

Parameter root : Tezos_raw_protocol_alpha.Raw_level_repr.t -> level.

Parameter from_raw :
Tezos_raw_protocol_alpha.Raw_level_repr.t ->
  int32 -> int32 -> int32 -> Tezos_raw_protocol_alpha.Raw_level_repr.t -> level.

Parameter diff : level -> level -> int32.
src/proto_alpha/lib_protocol/level_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Level_repr

let from_raw c ?offset l =
  let l =
    match offset with
    | None ->
        l
    | Some o ->
        Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o))
  in
  let constants = Raw_context.constants c in
  let first_level = Raw_context.first_level c in
  Level_repr.from_raw
    ~first_level
    ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle
    ~blocks_per_voting_period:constants.Constants_repr.blocks_per_voting_period
    ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
    l

let root c = Level_repr.root (Raw_context.first_level c)

let succ c l = from_raw c (Raw_level_repr.succ l.level)

let pred c l =
  match Raw_level_repr.pred l.Level_repr.level with
  | None ->
      None
  | Some l ->
      Some (from_raw c l)

let current ctxt = Raw_context.current_level ctxt

let previous ctxt =
  let l = current ctxt in
  match pred ctxt l with
  | None ->
      assert false (* We never validate the Genesis... *)
  | Some p ->
      p

let first_level_in_cycle ctxt c =
  let constants = Raw_context.constants ctxt in
  let first_level = Raw_context.first_level ctxt in
  from_raw
    ctxt
    (Raw_level_repr.of_int32_exn
       (Int32.add
          (Raw_level_repr.to_int32 first_level)
          (Int32.mul
             constants.Constants_repr.blocks_per_cycle
             (Cycle_repr.to_int32 c))))

let last_level_in_cycle ctxt c =
  match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with
  | None ->
      assert false
  | Some x ->
      x

let levels_in_cycle ctxt cycle =
  let first = first_level_in_cycle ctxt cycle in
  let rec loop n acc =
    if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc)
    else acc
  in
  loop first []

let levels_in_current_cycle ctxt ?(offset = 0l) () =
  let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in
  let cycle = Int32.add current_cycle offset in
  if Compare.Int32.(cycle < 0l) then []
  else
    let cycle = Cycle_repr.of_int32_exn cycle in
    levels_in_cycle ctxt cycle

let levels_with_commitments_in_cycle ctxt c =
  let first = first_level_in_cycle ctxt c in
  let rec loop n acc =
    if Cycle_repr.(n.cycle = first.cycle) then
      if n.expected_commitment then loop (succ ctxt n) (n :: acc)
      else loop (succ ctxt n) acc
    else acc
  in
  loop first []

let last_allowed_fork_level c =
  let level = Raw_context.current_level c in
  let preserved_cycles = Constants_storage.preserved_cycles c in
  match Cycle_repr.sub level.cycle preserved_cycles with
  | None ->
      Raw_level_repr.root
  | Some cycle ->
      (first_level_in_cycle c cycle).level
src/proto_alpha/lib_protocol/level_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Level_repr.

Definition from_raw
  (c : Tezos_raw_protocol_alpha.Raw_context.context) (offset : option int32)
  (l : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  let l :=
    match offset with
    | None => l
    | Some o =>
      Tezos_raw_protocol_alpha.Raw_level_repr.of_int32_exn
        (Tezos_protocol_environment_alpha__Environment.Int32.add
          (Tezos_raw_protocol_alpha.Raw_level_repr.to_int32 l) o)
    end in
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants c in
  let first_level := Tezos_raw_protocol_alpha.Raw_context.first_level c in
  Tezos_raw_protocol_alpha.Level_repr.from_raw first_level
    (Constants_repr.blocks_per_cycle constants)
    (Constants_repr.blocks_per_voting_period constants)
    (Constants_repr.blocks_per_commitment constants) l.

Definition root (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  Tezos_raw_protocol_alpha.Level_repr.root
    (Tezos_raw_protocol_alpha.Raw_context.first_level c).

Definition succ
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  (l : Tezos_raw_protocol_alpha.Level_repr.t)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  from_raw c None (Tezos_raw_protocol_alpha.Raw_level_repr.succ (level l)).

Definition pred
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  (l : Tezos_raw_protocol_alpha.Level_repr.t)
  : option Tezos_raw_protocol_alpha.Level_repr.level :=
  match Tezos_raw_protocol_alpha.Raw_level_repr.pred (Level_repr.level l) with
  | None => None
  | Some l => Some (from_raw c None l)
  end.

Definition current (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Level_repr.t :=
  Tezos_raw_protocol_alpha.Raw_context.current_level ctxt.

Definition previous (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  let l := current ctxt in
  match pred ctxt l with
  | None => false
  | Some p => p
  end.

Definition first_level_in_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants ctxt in
  let first_level := Tezos_raw_protocol_alpha.Raw_context.first_level ctxt in
  from_raw ctxt None
    (Tezos_raw_protocol_alpha.Raw_level_repr.of_int32_exn
      (Tezos_protocol_environment_alpha__Environment.Int32.add
        (Tezos_raw_protocol_alpha.Raw_level_repr.to_int32 first_level)
        (Tezos_protocol_environment_alpha__Environment.Int32.mul
          (Constants_repr.blocks_per_cycle constants)
          (Tezos_raw_protocol_alpha.Cycle_repr.to_int32 c)))).

Definition last_level_in_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  match
    pred ctxt
      (first_level_in_cycle ctxt (Tezos_raw_protocol_alpha.Cycle_repr.succ c))
    with
  | None => false
  | Some x => x
  end.

Definition levels_in_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : list Tezos_raw_protocol_alpha.Level_repr.t :=
  let first := first_level_in_cycle ctxt cycle in
  let fix loop
    (n : Tezos_raw_protocol_alpha.Level_repr.t) (acc :
    list Tezos_raw_protocol_alpha.Level_repr.t)
    : list Tezos_raw_protocol_alpha.Level_repr.t :=
    if Tezos_raw_protocol_alpha.Cycle_repr.op_eq (cycle n) (cycle first) then
      loop (succ ctxt n) (cons n acc)
    else
      acc in
  loop first [].

Definition levels_in_current_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (op_star_o_p_t_star : option int32)
  : unit -> list Tezos_raw_protocol_alpha.Level_repr.t :=
  let offset :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      let current_cycle :=
        Tezos_raw_protocol_alpha.Cycle_repr.to_int32 (cycle (current ctxt)) in
      let cycle :=
        Tezos_protocol_environment_alpha__Environment.Int32.add current_cycle
          offset in
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
          cycle 0 then
        []
      else
        let cycle := Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn cycle in
        levels_in_cycle ctxt cycle
    end.

Definition levels_with_commitments_in_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : list Tezos_raw_protocol_alpha.Level_repr.t :=
  let first := first_level_in_cycle ctxt c in
  let fix loop
    (n : Tezos_raw_protocol_alpha.Level_repr.t) (acc :
    list Tezos_raw_protocol_alpha.Level_repr.t)
    : list Tezos_raw_protocol_alpha.Level_repr.t :=
    if Tezos_raw_protocol_alpha.Cycle_repr.op_eq (cycle n) (cycle first) then
      if expected_commitment n then
        loop (succ ctxt n) (cons n acc)
      else
        loop (succ ctxt n) acc
    else
      acc in
  loop first [].

Definition last_allowed_fork_level
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level :=
  let level := Tezos_raw_protocol_alpha.Raw_context.current_level c in
  let preserved_cycles :=
    Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles c in
  match Tezos_raw_protocol_alpha.Cycle_repr.sub (cycle level) preserved_cycles
    with
  | None => Tezos_raw_protocol_alpha.Raw_level_repr.root
  | Some cycle => level (first_level_in_cycle c cycle)
  end.
src/proto_alpha/lib_protocol/level_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

val current : Raw_context.t -> Level_repr.t

val previous : Raw_context.t -> Level_repr.t

val root : Raw_context.t -> Level_repr.t

val from_raw :
  Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t

val pred : Raw_context.t -> Level_repr.t -> Level_repr.t option

val succ : Raw_context.t -> Level_repr.t -> Level_repr.t

val first_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t

val last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t

val levels_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t list

val levels_in_current_cycle :
  Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list

val levels_with_commitments_in_cycle :
  Raw_context.t -> Cycle_repr.t -> Level_repr.t list

val last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t
src/proto_alpha/lib_protocol/level_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter current :
Tezos_raw_protocol_alpha.Raw_context.t -> Tezos_raw_protocol_alpha.Level_repr.t.

Parameter previous :
Tezos_raw_protocol_alpha.Raw_context.t -> Tezos_raw_protocol_alpha.Level_repr.t.

Parameter root :
Tezos_raw_protocol_alpha.Raw_context.t -> Tezos_raw_protocol_alpha.Level_repr.t.

Parameter from_raw :
Tezos_raw_protocol_alpha.Raw_context.t ->
  (option int32) ->
    Tezos_raw_protocol_alpha.Raw_level_repr.t ->
      Tezos_raw_protocol_alpha.Level_repr.t.

Parameter pred :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Level_repr.t ->
    option Tezos_raw_protocol_alpha.Level_repr.t.

Parameter succ :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Level_repr.t -> Tezos_raw_protocol_alpha.Level_repr.t.

Parameter first_level_in_cycle :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> Tezos_raw_protocol_alpha.Level_repr.t.

Parameter last_level_in_cycle :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> Tezos_raw_protocol_alpha.Level_repr.t.

Parameter levels_in_cycle :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t ->
    list Tezos_raw_protocol_alpha.Level_repr.t.

Parameter levels_in_current_cycle :
Tezos_raw_protocol_alpha.Raw_context.t ->
  (option int32) -> unit -> list Tezos_raw_protocol_alpha.Level_repr.t.

Parameter levels_with_commitments_in_cycle :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t ->
    list Tezos_raw_protocol_alpha.Level_repr.t.

Parameter last_allowed_fork_level :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Raw_level_repr.t.
src/proto_alpha/lib_protocol/main.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Protocol Signature Instance *)

type block_header_data = Alpha_context.Block_header.protocol_data

type block_header = Alpha_context.Block_header.t = {
  shell : Block_header.shell_header;
  protocol_data : block_header_data;
}

let block_header_data_encoding =
  Alpha_context.Block_header.protocol_data_encoding

type block_header_metadata = Apply_results.block_metadata

let block_header_metadata_encoding = Apply_results.block_metadata_encoding

type operation_data = Alpha_context.packed_protocol_data =
  | Operation_data :
      'kind Alpha_context.Operation.protocol_data
      -> operation_data

let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding

type operation_receipt = Apply_results.packed_operation_metadata =
  | Operation_metadata :
      'kind Apply_results.operation_metadata
      -> operation_receipt
  | No_operation_metadata : operation_receipt

let operation_receipt_encoding = Apply_results.operation_metadata_encoding

let operation_data_and_receipt_encoding =
  Apply_results.operation_data_and_metadata_encoding

type operation = Alpha_context.packed_operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

let acceptable_passes = Alpha_context.Operation.acceptable_passes

let max_block_length = Alpha_context.Block_header.max_header_length

let max_operation_data_length =
  Alpha_context.Constants.max_operation_data_length

let validation_passes =
  let max_anonymous_operations =
    Alpha_context.Constants.max_revelations_per_block
    + (* allow 100 wallet activations or denunciations per block *) 100
  in
  Updater.
    [ {max_size = 32 * 1024; max_op = Some 32};
      (* 32 endorsements *)
      {max_size = 32 * 1024; max_op = None};
      (* 32k of voting operations *)
      {
        max_size = max_anonymous_operations * 1024;
        max_op = Some max_anonymous_operations;
      };
      {max_size = 512 * 1024; max_op = None} ]

(* 512kB *)

let rpc_services =
  Alpha_services.register () ;
  Services_registration.get_rpc_services ()

type validation_mode =
  | Application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_construction of {predecessor : Block_hash.t}
  | Full_construction of {
      predecessor : Block_hash.t;
      protocol_data : Alpha_context.Block_header.contents;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }

type validation_state = {
  mode : validation_mode;
  chain_id : Chain_id.t;
  ctxt : Alpha_context.t;
  op_count : int;
}

let current_context {ctxt; _} = return (Alpha_context.finalize ctxt).context

let begin_partial_application ~chain_id ~ancestor_context:ctxt
    ~predecessor_timestamp ~predecessor_fitness
    (block_header : Alpha_context.Block_header.t) =
  let level = block_header.shell.level in
  let fitness = predecessor_fitness in
  let timestamp = block_header.shell.timestamp in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  Apply.begin_application ctxt chain_id block_header predecessor_timestamp
  >>=? fun (ctxt, baker, block_delay) ->
  let mode =
    Partial_application
      {block_header; baker = Signature.Public_key.hash baker; block_delay}
  in
  return {mode; chain_id; ctxt; op_count = 0}

let begin_application ~chain_id ~predecessor_context:ctxt
    ~predecessor_timestamp ~predecessor_fitness
    (block_header : Alpha_context.Block_header.t) =
  let level = block_header.shell.level in
  let fitness = predecessor_fitness in
  let timestamp = block_header.shell.timestamp in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  Apply.begin_application ctxt chain_id block_header predecessor_timestamp
  >>=? fun (ctxt, baker, block_delay) ->
  let mode =
    Application
      {block_header; baker = Signature.Public_key.hash baker; block_delay}
  in
  return {mode; chain_id; ctxt; op_count = 0}

let begin_construction ~chain_id ~predecessor_context:ctxt
    ~predecessor_timestamp ~predecessor_level:pred_level
    ~predecessor_fitness:pred_fitness ~predecessor ~timestamp
    ?(protocol_data : block_header_data option) () =
  let level = Int32.succ pred_level in
  let fitness = pred_fitness in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  ( match protocol_data with
  | None ->
      Apply.begin_partial_construction ctxt
      >>=? fun ctxt ->
      let mode = Partial_construction {predecessor} in
      return (mode, ctxt)
  | Some proto_header ->
      Apply.begin_full_construction
        ctxt
        predecessor_timestamp
        proto_header.contents
      >>=? fun (ctxt, protocol_data, baker, block_delay) ->
      let mode =
        let baker = Signature.Public_key.hash baker in
        Full_construction {predecessor; baker; protocol_data; block_delay}
      in
      return (mode, ctxt) )
  >>=? fun (mode, ctxt) -> return {mode; chain_id; ctxt; op_count = 0}

let apply_operation ({mode; chain_id; ctxt; op_count; _} as data)
    (operation : Alpha_context.packed_operation) =
  match mode with
  | Partial_application _
    when not
           (List.exists
              (Compare.Int.equal 0)
              (Alpha_context.Operation.acceptable_passes operation)) ->
      (* Multipass validation only considers operations in pass 0. *)
      let op_count = op_count + 1 in
      return ({data with ctxt; op_count}, No_operation_metadata)
  | _ ->
      let {shell; protocol_data = Operation_data protocol_data} = operation in
      let operation : _ Alpha_context.operation = {shell; protocol_data} in
      let (predecessor, baker) =
        match mode with
        | Partial_application
            {block_header = {shell = {predecessor; _}; _}; baker}
        | Application {block_header = {shell = {predecessor; _}; _}; baker}
        | Full_construction {predecessor; baker; _} ->
            (predecessor, baker)
        | Partial_construction {predecessor} ->
            (predecessor, Signature.Public_key_hash.zero)
      in
      Apply.apply_operation
        ctxt
        chain_id
        Optimized
        predecessor
        baker
        (Alpha_context.Operation.hash operation)
        operation
      >>=? fun (ctxt, result) ->
      let op_count = op_count + 1 in
      return ({data with ctxt; op_count}, Operation_metadata result)

let finalize_block {mode; ctxt; op_count} =
  match mode with
  | Partial_construction _ ->
      let level = Alpha_context.Level.current ctxt in
      Alpha_context.Vote.get_current_period_kind ctxt
      >>=? fun voting_period_kind ->
      let baker = Signature.Public_key_hash.zero in
      Signature.Public_key_hash.Map.fold
        (fun delegate deposit ctxt ->
          ctxt
          >>=? fun ctxt ->
          Alpha_context.Delegate.freeze_deposit ctxt delegate deposit)
        (Alpha_context.get_deposits ctxt)
        (return ctxt)
      >>=? fun ctxt ->
      let ctxt = Alpha_context.finalize ctxt in
      return
        ( ctxt,
          Apply_results.
            {
              baker;
              level;
              voting_period_kind;
              nonce_hash = None;
              consumed_gas = Z.zero;
              deactivated = [];
              balance_updates = [];
            } )
  | Partial_application {block_header; baker; block_delay} ->
      let level = Alpha_context.Level.current ctxt in
      let included_endorsements = Alpha_context.included_endorsements ctxt in
      Apply.check_minimum_endorsements
        ctxt
        block_header.protocol_data.contents
        block_delay
        included_endorsements
      >>=? fun () ->
      Alpha_context.Vote.get_current_period_kind ctxt
      >>=? fun voting_period_kind ->
      let ctxt = Alpha_context.finalize ctxt in
      return
        ( ctxt,
          Apply_results.
            {
              baker;
              level;
              voting_period_kind;
              nonce_hash = None;
              consumed_gas = Z.zero;
              deactivated = [];
              balance_updates = [];
            } )
  | Application
      { baker;
        block_delay;
        block_header = {protocol_data = {contents = protocol_data; _}; _} }
  | Full_construction {protocol_data; baker; block_delay; _} ->
      Apply.finalize_application ctxt protocol_data baker ~block_delay
      >>=? fun (ctxt, receipt) ->
      let level = Alpha_context.Level.current ctxt in
      let priority = protocol_data.priority in
      let raw_level = Alpha_context.Raw_level.to_int32 level.level in
      let fitness = Alpha_context.Fitness.current ctxt in
      let commit_message =
        Format.asprintf
          "lvl %ld, fit 1:%Ld, prio %d, %d ops"
          raw_level
          fitness
          priority
          op_count
      in
      let ctxt = Alpha_context.finalize ~commit_message ctxt in
      return (ctxt, receipt)

let compare_operations op1 op2 =
  let open Alpha_context in
  let (Operation_data op1) = op1.protocol_data in
  let (Operation_data op2) = op2.protocol_data in
  match (op1.contents, op2.contents) with
  | (Single (Endorsement _), Single (Endorsement _)) ->
      0
  | (_, Single (Endorsement _)) ->
      1
  | (Single (Endorsement _), _) ->
      -1
  | (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) ->
      0
  | (_, Single (Seed_nonce_revelation _)) ->
      1
  | (Single (Seed_nonce_revelation _), _) ->
      -1
  | ( Single (Double_endorsement_evidence _),
      Single (Double_endorsement_evidence _) ) ->
      0
  | (_, Single (Double_endorsement_evidence _)) ->
      1
  | (Single (Double_endorsement_evidence _), _) ->
      -1
  | (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) ->
      0
  | (_, Single (Double_baking_evidence _)) ->
      1
  | (Single (Double_baking_evidence _), _) ->
      -1
  | (Single (Activate_account _), Single (Activate_account _)) ->
      0
  | (_, Single (Activate_account _)) ->
      1
  | (Single (Activate_account _), _) ->
      -1
  | (Single (Proposals _), Single (Proposals _)) ->
      0
  | (_, Single (Proposals _)) ->
      1
  | (Single (Proposals _), _) ->
      -1
  | (Single (Ballot _), Single (Ballot _)) ->
      0
  | (_, Single (Ballot _)) ->
      1
  | (Single (Ballot _), _) ->
      -1
  (* Manager operations with smaller counter are pre-validated first. *)
  | (Single (Manager_operation op1), Single (Manager_operation op2)) ->
      Z.compare op1.counter op2.counter
  | (Cons (Manager_operation op1, _), Single (Manager_operation op2)) ->
      Z.compare op1.counter op2.counter
  | (Single (Manager_operation op1), Cons (Manager_operation op2, _)) ->
      Z.compare op1.counter op2.counter
  | (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) ->
      Z.compare op1.counter op2.counter

let init ctxt block_header =
  let level = block_header.Block_header.level in
  let fitness = block_header.fitness in
  let timestamp = block_header.timestamp in
  let typecheck (ctxt : Alpha_context.context)
      (script : Alpha_context.Script.t) =
    Script_ir_translator.parse_script ctxt ~legacy:false script
    >>=? fun (Ex_script parsed_script, ctxt) ->
    Script_ir_translator.extract_big_map_diff
      ctxt
      Optimized
      parsed_script.storage_type
      parsed_script.storage
      ~to_duplicate:Script_ir_translator.no_big_map_id
      ~to_update:Script_ir_translator.no_big_map_id
      ~temporary:false
    >>=? fun (storage, big_map_diff, ctxt) ->
    Script_ir_translator.unparse_data
      ctxt
      Optimized
      parsed_script.storage_type
      storage
    >>=? fun (storage, ctxt) ->
    let storage =
      Alpha_context.Script.lazy_expr (Micheline.strip_locations storage)
    in
    return (({script with storage}, big_map_diff), ctxt)
  in
  Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt
  >>=? fun ctxt -> return (Alpha_context.finalize ctxt)

(* Vanity nonce: 313282890 *)
src/proto_alpha/lib_protocol/main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition block_header_data :=
  Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data.

Record block_header := {
  shell :
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header;
  protocol_data : block_header_data }.

Definition block_header_data_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data :=
  Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data_encoding.

Definition block_header_metadata :=
  Tezos_raw_protocol_alpha.Apply_results.block_metadata.

Definition block_header_metadata_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_raw_protocol_alpha.Apply_results.block_metadata :=
  Tezos_raw_protocol_alpha.Apply_results.block_metadata_encoding.

Inductive operation_data : Type :=
| Operation_data : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.Operation.protocol_data kind) ->
  operation_data.

Definition operation_data_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data :=
  Tezos_raw_protocol_alpha.Alpha_context.Operation.protocol_data_encoding.

Inductive operation_receipt : Type :=
| Operation_metadata : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Apply_results.operation_metadata kind) ->
  operation_receipt
| No_operation_metadata : operation_receipt.

Definition operation_receipt_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata :=
  Tezos_raw_protocol_alpha.Apply_results.operation_metadata_encoding.

Definition operation_data_and_receipt_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data *
      Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata) :=
  Tezos_raw_protocol_alpha.Apply_results.operation_data_and_metadata_encoding.

Record operation := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  protocol_data : operation_data }.

Definition acceptable_passes
  : Tezos_raw_protocol_alpha__Alpha_context.packed_operation -> list Z :=
  Tezos_raw_protocol_alpha.Alpha_context.Operation.acceptable_passes.

Definition max_block_length : Z :=
  Tezos_raw_protocol_alpha.Alpha_context.Block_header.max_header_length.

Definition max_operation_data_length : Z :=
  Tezos_raw_protocol_alpha.Alpha_context.Constants.max_operation_data_length.

Definition validation_passes
  : list Tezos_protocol_environment_alpha__Environment.Updater.quota :=
  let max_anonymous_operations :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
      Tezos_raw_protocol_alpha.Alpha_context.Constants.max_revelations_per_block
      100 in
  cons
    {|
      max_size :=
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_star 32 1024;
      max_op := Some 32 |}
    (cons
      {|
        max_size :=
          Tezos_protocol_environment_alpha__Environment.Pervasives.op_star 32
            1024; max_op := None |}
      (cons
        {|
          max_size :=
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
              max_anonymous_operations 1024;
          max_op := Some max_anonymous_operations |}
        (cons
          {|
            max_size :=
              Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
                512 1024; max_op := None |} []))).

Definition rpc_services
  : Tezos_protocol_environment_alpha__Environment.RPC_directory.directory
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
  Tezos_raw_protocol_alpha.Alpha_services.register tt;
  Tezos_raw_protocol_alpha.Services_registration.get_rpc_services tt.

Inductive validation_mode : Type :=
| Application : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode
| Partial_application : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode
| Partial_construction :
  Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> validation_mode
| Full_construction :
  Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode.

Record validation_state := {
  mode : validation_mode;
  chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
  ctxt : Tezos_raw_protocol_alpha.Alpha_context.t;
  op_count : Z }.

Definition current_context (function_parameter : validation_state)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Context.t) :=
  match function_parameter with
  | {| ctxt := ctxt |} =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (context (Tezos_raw_protocol_alpha.Alpha_context.finalize None ctxt))
  end.

Definition begin_partial_application
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (predecessor_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
  (block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      validation_state) :=
  let level := level (shell block_header) in
  let fitness := predecessor_fitness in
  let timestamp := timestamp (shell block_header) in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.prepare ctxt level
      predecessor_timestamp timestamp fitness)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Apply.begin_application ctxt chain_id
          block_header predecessor_timestamp)
        (fun function_parameter =>
          match function_parameter with
          | (ctxt, baker, block_delay) =>
            let mode :=
              Partial_application
                {| block_header := block_header;
                  baker :=
                    Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                      baker; block_delay := block_delay |} in
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              {| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := 0
                |}
          end)).

Definition begin_application
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (predecessor_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
  (block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      validation_state) :=
  let level := level (shell block_header) in
  let fitness := predecessor_fitness in
  let timestamp := timestamp (shell block_header) in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.prepare ctxt level
      predecessor_timestamp timestamp fitness)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Apply.begin_application ctxt chain_id
          block_header predecessor_timestamp)
        (fun function_parameter =>
          match function_parameter with
          | (ctxt, baker, block_delay) =>
            let mode :=
              Application
                {| block_header := block_header;
                  baker :=
                    Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                      baker; block_delay := block_delay |} in
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              {| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := 0
                |}
          end)).

Definition begin_construction
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (pred_level : int32)
  (pred_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
  (predecessor :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (protocol_data : option block_header_data) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      validation_state) :=
  match function_parameter with
  | tt =>
    let level :=
      Tezos_protocol_environment_alpha__Environment.Int32.succ pred_level in
    let fitness := pred_fitness in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.prepare ctxt level
        predecessor_timestamp timestamp fitness)
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          match protocol_data with
          | None =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Apply.begin_partial_construction ctxt)
              (fun ctxt =>
                let mode :=
                  Partial_construction {| predecessor := predecessor |} in
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (mode, ctxt))
          | Some proto_header =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Apply.begin_full_construction ctxt
                predecessor_timestamp (contents proto_header))
              (fun function_parameter =>
                match function_parameter with
                | (ctxt, protocol_data, baker, block_delay) =>
                  let mode :=
                    let baker :=
                      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                        baker in
                    Full_construction
                      {| predecessor := predecessor;
                        protocol_data := protocol_data; baker := baker;
                        block_delay := block_delay |} in
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (mode, ctxt)
                end)
          end
          (fun function_parameter =>
            match function_parameter with
            | (mode, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                {| mode := mode; chain_id := chain_id; ctxt := ctxt;
                  op_count := 0 |}
            end))
  end.

Definition apply_operation (function_parameter : validation_state)
  : Tezos_raw_protocol_alpha.Alpha_context.packed_operation ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (validation_state * operation_receipt)) :=
  match function_parameter with
  |
    {| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := op_count |}
      as data =>
    fun operation =>
      match mode with
      | _ =>
        match operation with
        | {| shell := shell; protocol_data := Operation_data protocol_data |} =>
          let operation := {| shell := shell; protocol_data := protocol_data |}
            in
          match
            match mode with
            |
              Partial_application {|
                block_header := {| shell := {| predecessor := predecessor |} |};
                  baker := baker
                  |} |
                Application {|
                  block_header := {| shell := {| predecessor := predecessor |} |};
                    baker := baker
                    |} |
                Full_construction {|
                  predecessor := predecessor; baker := baker |} =>
              (predecessor, baker)
            | Partial_construction {| predecessor := predecessor |} =>
              (predecessor,
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.zero)
            end with
          | (predecessor, baker) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Apply.apply_operation ctxt chain_id
                Optimized predecessor baker
                (Tezos_raw_protocol_alpha.Alpha_context.Operation.hash operation)
                operation)
              (fun function_parameter =>
                match function_parameter with
                | (ctxt, result) =>
                  let op_count :=
                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                      op_count 1 in
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (record, (Operation_metadata result))
                end)
          end
        end
      end
  end.

Definition finalize_block (function_parameter : validation_state)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Updater.validation_result *
        Tezos_raw_protocol_alpha.Apply_results.block_metadata)) :=
  match function_parameter with
  | {| mode := mode; ctxt := ctxt; op_count := op_count |} =>
    match mode with
    | Partial_construction _ =>
      let level := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_period_kind
          ctxt)
        (fun voting_period_kind =>
          let baker :=
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.zero
            in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.fold
              (fun delegate =>
                fun deposit =>
                  fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      ctxt
                      (fun ctxt =>
                        Tezos_raw_protocol_alpha.Alpha_context.Delegate.freeze_deposit
                          ctxt delegate deposit))
              (Tezos_raw_protocol_alpha.Alpha_context.get_deposits ctxt)
              (Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ctxt))
            (fun ctxt =>
              let ctxt :=
                Tezos_raw_protocol_alpha.Alpha_context.finalize None ctxt in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt,
                  {| baker := baker; level := level;
                    voting_period_kind := voting_period_kind;
                    nonce_hash := None;
                    consumed_gas :=
                      Tezos_protocol_environment_alpha__Environment.Z.zero;
                    deactivated := []; balance_updates := [] |})))
    |
      Partial_application {|
        block_header := block_header;
          baker := baker;
          block_delay := block_delay
          |} =>
      let level := Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
      let included_endorsements :=
        Tezos_raw_protocol_alpha.Alpha_context.included_endorsements ctxt in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Apply.check_minimum_endorsements ctxt
          (contents (protocol_data block_header)) block_delay
          included_endorsements)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_period_kind
                ctxt)
              (fun voting_period_kind =>
                let ctxt :=
                  Tezos_raw_protocol_alpha.Alpha_context.finalize None ctxt in
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (ctxt,
                    {| baker := baker; level := level;
                      voting_period_kind := voting_period_kind;
                      nonce_hash := None;
                      consumed_gas :=
                        Tezos_protocol_environment_alpha__Environment.Z.zero;
                      deactivated := []; balance_updates := [] |}))
          end)
    |
      Application {|
        block_header := {| protocol_data := {| contents := protocol_data |} |};
          baker := baker;
          block_delay := block_delay
          |} |
        Full_construction {|
          protocol_data := protocol_data;
            baker := baker;
            block_delay := block_delay
            |} =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Apply.finalize_application ctxt protocol_data
          baker block_delay)
        (fun function_parameter =>
          match function_parameter with
          | (ctxt, receipt) =>
            let level :=
              Tezos_raw_protocol_alpha.Alpha_context.Level.current ctxt in
            let priority := priority protocol_data in
            let raw_level :=
              Tezos_raw_protocol_alpha.Alpha_context.Raw_level.to_int32
                (level level) in
            let fitness :=
              Tezos_raw_protocol_alpha.Alpha_context.Fitness.current ctxt in
            let commit_message :=
              Tezos_protocol_environment_alpha__Environment.Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "lvl " % string
                    (CamlinternalFormatBasics.Int32
                      CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        ", fit 1:" % string
                        (CamlinternalFormatBasics.Int64
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.String_literal
                            ", prio " % string
                            (CamlinternalFormatBasics.Int
                              CamlinternalFormatBasics.Int_d
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.No_precision
                              (CamlinternalFormatBasics.String_literal
                                ", " % string
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " ops" % string
                                    CamlinternalFormatBasics.End_of_format)))))))))
                  "lvl %ld, fit 1:%Ld, prio %d, %d ops" % string) raw_level
                fitness priority op_count in
            let ctxt :=
              Tezos_raw_protocol_alpha.Alpha_context.finalize
                (Some commit_message) ctxt in
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (ctxt, receipt)
          end)
    end
  end.

Definition compare_operations
  (op1 : Tezos_raw_protocol_alpha.Alpha_context.packed_operation)
  (op2 : Tezos_raw_protocol_alpha.Alpha_context.packed_operation) : Z :=
  match protocol_data op1 with
  | Operation_data op1 =>
    match protocol_data op2 with
    | Operation_data op2 =>
      match ((contents op1), (contents op2)) with
      | (Single (Endorsement _), Single (Endorsement _)) => 0
      | (_, Single (Endorsement _)) => 1
      | (Single (Endorsement _), _) => (-1)
      | (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) =>
        0
      | (_, Single (Seed_nonce_revelation _)) => 1
      | (Single (Seed_nonce_revelation _), _) => (-1)
      |
        (Single (Double_endorsement_evidence _),
          Single (Double_endorsement_evidence _)) => 0
      | (_, Single (Double_endorsement_evidence _)) => 1
      | (Single (Double_endorsement_evidence _), _) => (-1)
      | (Single (Double_baking_evidence _), Single (Double_baking_evidence _))
        => 0
      | (_, Single (Double_baking_evidence _)) => 1
      | (Single (Double_baking_evidence _), _) => (-1)
      | (Single (Activate_account _), Single (Activate_account _)) => 0
      | (_, Single (Activate_account _)) => 1
      | (Single (Activate_account _), _) => (-1)
      | (Single (Proposals _), Single (Proposals _)) => 0
      | (_, Single (Proposals _)) => 1
      | (Single (Proposals _), _) => (-1)
      | (Single (Ballot _), Single (Ballot _)) => 0
      | (_, Single (Ballot _)) => 1
      | (Single (Ballot _), _) => (-1)
      | (Single (Manager_operation op1), Single (Manager_operation op2)) =>
        Tezos_protocol_environment_alpha__Environment.Z.compare (counter op1)
          (counter op2)
      | (Cons (Manager_operation op1) _, Single (Manager_operation op2)) =>
        Tezos_protocol_environment_alpha__Environment.Z.compare (counter op1)
          (counter op2)
      | (Single (Manager_operation op1), Cons (Manager_operation op2) _) =>
        Tezos_protocol_environment_alpha__Environment.Z.compare (counter op1)
          (counter op2)
      | (Cons (Manager_operation op1) _, Cons (Manager_operation op2) _) =>
        Tezos_protocol_environment_alpha__Environment.Z.compare (counter op1)
          (counter op2)
      end
    end
  end.

Definition init
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (block_header :
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Updater.validation_result) :=
  let level := Block_header.level block_header in
  let fitness := fitness block_header in
  let timestamp := timestamp block_header in
  let typecheck
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (script :
    Tezos_raw_protocol_alpha.Alpha_context.Script.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((Tezos_raw_protocol_alpha.Alpha_context.Script.t *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))
          * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Script_ir_translator.parse_script None ctxt
        false script)
      (fun function_parameter =>
        match function_parameter with
        | (Ex_script parsed_script, ctxt) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Script_ir_translator.extract_big_map_diff
              ctxt Optimized false
              Tezos_raw_protocol_alpha.Script_ir_translator.no_big_map_id
              Tezos_raw_protocol_alpha.Script_ir_translator.no_big_map_id
              (storage_type parsed_script) (storage parsed_script))
            (fun function_parameter =>
              match function_parameter with
              | (storage, big_map_diff, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data
                    ctxt Optimized (storage_type parsed_script) storage)
                  (fun function_parameter =>
                    match function_parameter with
                    | (storage, ctxt) =>
                      let storage :=
                        Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                          (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                            storage) in
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        ((record, big_map_diff), ctxt)
                    end)
              end)
        end) in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Alpha_context.prepare_first_block ctxt typecheck
      level timestamp fitness)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (Tezos_raw_protocol_alpha.Alpha_context.finalize None ctxt)).
src/proto_alpha/lib_protocol/main.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Protocol Signature Instance *)

type validation_mode =
  | Application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_construction of {predecessor : Block_hash.t}
  | Full_construction of {
      predecessor : Block_hash.t;
      protocol_data : Alpha_context.Block_header.contents;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }

type validation_state = {
  mode : validation_mode;
  chain_id : Chain_id.t;
  ctxt : Alpha_context.t;
  op_count : int;
}

type operation_data = Alpha_context.packed_protocol_data

type operation = Alpha_context.packed_operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

include
  Updater.PROTOCOL
    with type block_header_data = Alpha_context.Block_header.protocol_data
     and type block_header_metadata = Apply_results.block_metadata
     and type block_header = Alpha_context.Block_header.t
     and type operation_data := operation_data
     and type operation_receipt = Apply_results.packed_operation_metadata
     and type operation := operation
     and type validation_state := validation_state
src/proto_alpha/lib_protocol/main.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive validation_mode : Type :=
| Application : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode
| Partial_application : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode
| Partial_construction :
  Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> validation_mode
| Full_construction :
  Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode.

Record validation_state := {
  mode : validation_mode;
  chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
  ctxt : Tezos_raw_protocol_alpha.Alpha_context.t;
  op_count : Z }.

Definition operation_data :=
  Tezos_raw_protocol_alpha.Alpha_context.packed_protocol_data.

Record operation := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  protocol_data : operation_data }.

include
src/proto_alpha/lib_protocol/manager_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *)

type manager_key =
  | Hash of Signature.Public_key_hash.t
  | Public_key of Signature.Public_key.t

type t = manager_key

open Data_encoding

let hash_case tag =
  case
    tag
    ~title:"Public_key_hash"
    Signature.Public_key_hash.encoding
    (function Hash hash -> Some hash | _ -> None)
    (fun hash -> Hash hash)

let pubkey_case tag =
  case
    tag
    ~title:"Public_key"
    Signature.Public_key.encoding
    (function Public_key hash -> Some hash | _ -> None)
    (fun hash -> Public_key hash)

let encoding = union [hash_case (Tag 0); pubkey_case (Tag 1)]
src/proto_alpha/lib_protocol/manager_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive manager_key : Type :=
| Hash :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  manager_key
| Public_key :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t ->
  manager_key.

Definition t := manager_key.

Import Tezos_protocol_environment_alpha__Environment.Data_encoding.

Definition hash_case
  (tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.case manager_key :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.case
    "Public_key_hash" % string None tag
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
    (fun function_parameter =>
      match function_parameter with
      | Hash hash => Some hash
      | _ => None
      end) (fun hash => Hash hash).

Definition pubkey_case
  (tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.case manager_key :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.case
    "Public_key" % string None tag
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key.encoding
    (fun function_parameter =>
      match function_parameter with
      | Public_key hash => Some hash
      | _ => None
      end) (fun hash => Public_key hash).

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    manager_key :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
    (cons (hash_case (Tag 0)) (cons (pubkey_case (Tag 1)) [])).
src/proto_alpha/lib_protocol/manager_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *)

(** The public key of the manager of a contract is reveled only after the
    first operation. At Origination time, the manager provides only the hash
    of its public key that is stored in the contract. When the public key
    is actually reveeld, the public key instead of the hash of the key *)
type manager_key =
  | Hash of Signature.Public_key_hash.t
  | Public_key of Signature.Public_key.t

type t = manager_key

val encoding : t Data_encoding.encoding
src/proto_alpha/lib_protocol/manager_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive manager_key : Type :=
| Hash :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  manager_key
| Public_key :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t ->
  manager_key.

Definition t := manager_key.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t.
src/proto_alpha/lib_protocol/michelson_v1_gas.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Gas

module Cost_of = struct
  let log2 =
    let rec help acc = function 0 -> acc | n -> help (acc + 1) (n / 2) in
    help 1

  let z_bytes (z : Z.t) =
    let bits = Z.numbits z in
    (7 + bits) / 8

  let int_bytes (z : 'a Script_int.num) = z_bytes (Script_int.to_zint z)

  let timestamp_bytes (t : Script_timestamp.t) =
    let z = Script_timestamp.to_zint t in
    z_bytes z

  (* For now, returns size in bytes, but this could get more complicated... *)
  let rec size_of_comparable :
      type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int =
   fun wit v ->
    match wit with
    | Int_key _ ->
        int_bytes v
    | Nat_key _ ->
        int_bytes v
    | String_key _ ->
        String.length v
    | Bytes_key _ ->
        MBytes.length v
    | Bool_key _ ->
        8
    | Key_hash_key _ ->
        Signature.Public_key_hash.size
    | Timestamp_key _ ->
        timestamp_bytes v
    | Address_key _ ->
        Signature.Public_key_hash.size
    | Mutez_key _ ->
        8
    | Pair_key ((l, _), (r, _), _) ->
        let (lval, rval) = v in
        size_of_comparable l lval + size_of_comparable r rval

  let string length = alloc_bytes_cost length

  let bytes length = alloc_mbytes_cost length

  let manager_operation = step_cost 10_000

  module Legacy = struct
    let zint z = alloc_bits_cost (Z.numbits z)

    let set_to_list : type item. item Script_typed_ir.set -> cost =
     fun (module Box) -> alloc_cost @@ Pervasives.(Box.size * 2)

    let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
        =
     fun (module Box) ->
      let size = snd Box.boxed in
      3 *@ alloc_cost size

    let z_to_int64 = step_cost 2 +@ alloc_cost 1

    let hash data len = (10 *@ step_cost (MBytes.length data)) +@ bytes len

    let set_access : type elt. elt -> elt Script_typed_ir.set -> int =
     fun _key (module Box) -> log2 @@ Box.size

    let set_update key _presence set = set_access key set *@ alloc_cost 3
  end

  module Interpreter = struct
    let cycle = atomic_step_cost 10

    let nop = free

    let stack_op = atomic_step_cost 10

    let push = atomic_step_cost 10

    let wrap = atomic_step_cost 10

    let variant_no_data = atomic_step_cost 10

    let branch = atomic_step_cost 10

    let pair = atomic_step_cost 10

    let pair_access = atomic_step_cost 10

    let cons = atomic_step_cost 10

    let loop_size = atomic_step_cost 5

    let loop_cycle = atomic_step_cost 10

    let loop_iter = atomic_step_cost 20

    let loop_map = atomic_step_cost 30

    let empty_set = atomic_step_cost 10

    let set_to_list : type elt. elt Script_typed_ir.set -> cost =
     fun (module Box) -> atomic_step_cost (Box.size * 20)

    let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost =
     fun elt (module Box) ->
      let elt_bytes = size_of_comparable Box.elt_ty elt in
      atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)

    let set_update : type elt. elt -> bool -> elt Script_typed_ir.set -> cost =
     fun elt _ (module Box) ->
      let elt_bytes = size_of_comparable Box.elt_ty elt in
      atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)

    let set_size = atomic_step_cost 10

    let empty_map = atomic_step_cost 10

    let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
        =
     fun (module Box) ->
      let size = snd Box.boxed in
      atomic_step_cost (size * 20)

    let map_access :
        type key value. key -> (key, value) Script_typed_ir.map -> cost =
     fun key (module Box) ->
      let map_card = snd Box.boxed in
      let key_bytes = size_of_comparable Box.key_ty key in
      atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card)

    let map_mem = map_access

    let map_get = map_access

    let map_update :
        type key value.
        key -> value option -> (key, value) Script_typed_ir.map -> cost =
     fun key _value (module Box) ->
      let map_card = snd Box.boxed in
      let key_bytes = size_of_comparable Box.key_ty key in
      atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card)

    let map_size = atomic_step_cost 10

    let add_timestamp (t1 : Script_timestamp.t) (t2 : 'a Script_int.num) =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = int_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))

    let sub_timestamp = add_timestamp

    let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = timestamp_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))

    let rec concat_loop l acc =
      match l with [] -> 30 | _ :: tl -> concat_loop tl (acc + 30)

    let concat_string string_list =
      atomic_step_cost (concat_loop string_list 0)

    let slice_string string_length =
      atomic_step_cost (40 + (string_length / 70))

    let concat_bytes bytes_list = atomic_step_cost (concat_loop bytes_list 0)

    let int64_op = atomic_step_cost 61

    let z_to_int64 = atomic_step_cost 20

    let int64_to_z = atomic_step_cost 20

    let bool_binop _ _ = atomic_step_cost 10

    let bool_unop _ = atomic_step_cost 10

    let abs int = atomic_step_cost (61 + (int_bytes int / 70))

    let int _int = free

    let neg = abs

    let add i1 i2 =
      atomic_step_cost
        (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62))

    let sub = add

    let mul i1 i2 =
      let bytes = Compare.Int.max (int_bytes i1) (int_bytes i2) in
      atomic_step_cost (51 + (bytes / 6 * log2 bytes))

    let indic_lt x y = if Compare.Int.(x < y) then 1 else 0

    let div i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      let cost = indic_lt bytes2 bytes1 * (bytes1 - bytes2) * bytes2 in
      atomic_step_cost (51 + (cost / 3151))

    let shift_left _i _shift_bits = atomic_step_cost 30

    let shift_right _i _shift_bits = atomic_step_cost 30

    let logor i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 70))

    let logand i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 70))

    let logxor = logor

    let lognot i = atomic_step_cost (51 + (int_bytes i / 20))

    let exec = atomic_step_cost 10

    let compare_bool _ _ = atomic_step_cost 30

    let compare_string s1 s2 =
      let bytes1 = String.length s1 in
      let bytes2 = String.length s2 in
      atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))

    let compare_bytes b1 b2 =
      let bytes1 = MBytes.length b1 in
      let bytes2 = MBytes.length b2 in
      atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))

    let compare_tez _ _ = atomic_step_cost 30

    let compare_zint i1 i2 =
      atomic_step_cost
        (51 + (Compare.Int.min (int_bytes i1) (int_bytes i2) / 82))

    let compare_key_hash _ _ = atomic_step_cost 92

    let compare_timestamp t1 t2 =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = timestamp_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 82))

    let compare_address _ _ = atomic_step_cost 92

    let compare_res = atomic_step_cost 30

    let unpack_failed bytes =
      (* We cannot instrument failed deserialization,
         so we take worst case fees: a set of size 1 bytes values. *)
      let len = MBytes.length bytes in
      (len *@ alloc_mbytes_cost 1)
      +@ (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1)))

    let address = atomic_step_cost 10

    let contract = step_cost 10000

    let transfer = step_cost 10

    let create_account = step_cost 10

    let create_contract = step_cost 10

    let implicit_account = step_cost 10

    let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32)

    let balance = atomic_step_cost 10

    let now = atomic_step_cost 10

    let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5))

    let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5))

    let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5))

    let check_signature (pkey : Signature.public_key) bytes =
      match pkey with
      | Ed25519 _ ->
          check_signature_ed25519 (MBytes.length bytes)
      | Secp256k1 _ ->
          check_signature_secp256k1 (MBytes.length bytes)
      | P256 _ ->
          check_signature_p256 (MBytes.length bytes)

    let hash_key = atomic_step_cost 30

    let hash_blake2b b = atomic_step_cost (102 + (MBytes.length b / 5))

    let hash_sha256 b = atomic_step_cost (409 + MBytes.length b)

    let hash_sha512 b =
      let bytes = MBytes.length b in
      atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4)))

    let steps_to_quota = atomic_step_cost 10

    let source = atomic_step_cost 10

    let self = atomic_step_cost 10

    let amount = atomic_step_cost 10

    let chain_id = step_cost 1

    let stack_n_op n =
      atomic_step_cost (20 + ((n lsr 1) + (n lsr 2) + (n lsr 4)))

    let apply = alloc_cost 8 +@ step_cost 1

    let rec compare :
        type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost =
     fun ty x y ->
      match ty with
      | Bool_key _ ->
          compare_bool x y
      | String_key _ ->
          compare_string x y
      | Bytes_key _ ->
          compare_bytes x y
      | Mutez_key _ ->
          compare_tez x y
      | Int_key _ ->
          compare_zint x y
      | Nat_key _ ->
          compare_zint x y
      | Key_hash_key _ ->
          compare_key_hash x y
      | Timestamp_key _ ->
          compare_timestamp x y
      | Address_key _ ->
          compare_address x y
      | Pair_key ((tl, _), (tr, _), _) ->
          (* Reasonable over-approximation of the cost of lexicographic comparison. *)
          let (xl, xr) = x and (yl, yr) = y in
          compare tl xl yl +@ compare tr xr yr
  end

  module Typechecking = struct
    let cycle = step_cost 1

    let bool = free

    let unit = free

    let string = string

    let bytes = bytes

    let z = Legacy.zint

    let int_of_string str =
      alloc_cost @@ Pervasives.( / ) (String.length str) 5

    let tez = step_cost 1 +@ alloc_cost 1

    let string_timestamp = step_cost 3 +@ alloc_cost 3

    let key = step_cost 3 +@ alloc_cost 3

    let key_hash = step_cost 1 +@ alloc_cost 1

    let signature = step_cost 1 +@ alloc_cost 1

    let chain_id = step_cost 1 +@ alloc_cost 1

    let contract = step_cost 5

    let get_script = step_cost 20 +@ alloc_cost 5

    let contract_exists = step_cost 15 +@ alloc_cost 5

    let pair = alloc_cost 2

    let union = alloc_cost 1

    let lambda = alloc_cost 5 +@ step_cost 3

    let some = alloc_cost 1

    let none = alloc_cost 0

    let list_element = alloc_cost 2 +@ step_cost 1

    let set_element size = log2 size *@ (alloc_cost 3 +@ step_cost 2)

    let map_element size = log2 size *@ (alloc_cost 4 +@ step_cost 2)

    let primitive_type = alloc_cost 1

    let one_arg_type = alloc_cost 2

    let two_arg_type = alloc_cost 3

    let operation b = bytes b

    let type_ nb_args = alloc_cost (nb_args + 1)

    (* Cost of parsing instruction, is cost of allocation of
       constructor + cost of contructor parameters + cost of
       allocation on the stack type *)
    let instr : type b a. (b, a) Script_typed_ir.instr -> cost =
     fun i ->
      let open Script_typed_ir in
      alloc_cost 1
      +@
      (* cost of allocation of constructor *)
      match i with
      | Drop ->
          alloc_cost 0
      | Dup ->
          alloc_cost 1
      | Swap ->
          alloc_cost 0
      | Const _ ->
          alloc_cost 1
      | Cons_pair ->
          alloc_cost 2
      | Car ->
          alloc_cost 1
      | Cdr ->
          alloc_cost 1
      | Cons_some ->
          alloc_cost 2
      | Cons_none _ ->
          alloc_cost 3
      | If_none _ ->
          alloc_cost 2
      | Left ->
          alloc_cost 3
      | Right ->
          alloc_cost 3
      | If_left _ ->
          alloc_cost 2
      | Cons_list ->
          alloc_cost 1
      | Nil ->
          alloc_cost 1
      | If_cons _ ->
          alloc_cost 2
      | List_map _ ->
          alloc_cost 5
      | List_iter _ ->
          alloc_cost 4
      | List_size ->
          alloc_cost 1
      | Empty_set _ ->
          alloc_cost 1
      | Set_iter _ ->
          alloc_cost 4
      | Set_mem ->
          alloc_cost 1
      | Set_update ->
          alloc_cost 1
      | Set_size ->
          alloc_cost 1
      | Empty_map _ ->
          alloc_cost 2
      | Map_map _ ->
          alloc_cost 5
      | Map_iter _ ->
          alloc_cost 4
      | Map_mem ->
          alloc_cost 1
      | Map_get ->
          alloc_cost 1
      | Map_update ->
          alloc_cost 1
      | Map_size ->
          alloc_cost 1
      | Empty_big_map _ ->
          alloc_cost 2
      | Big_map_mem ->
          alloc_cost 1
      | Big_map_get ->
          alloc_cost 1
      | Big_map_update ->
          alloc_cost 1
      | Concat_string ->
          alloc_cost 1
      | Concat_string_pair ->
          alloc_cost 1
      | Concat_bytes ->
          alloc_cost 1
      | Concat_bytes_pair ->
          alloc_cost 1
      | Slice_string ->
          alloc_cost 1
      | Slice_bytes ->
          alloc_cost 1
      | String_size ->
          alloc_cost 1
      | Bytes_size ->
          alloc_cost 1
      | Add_seconds_to_timestamp ->
          alloc_cost 1
      | Add_timestamp_to_seconds ->
          alloc_cost 1
      | Sub_timestamp_seconds ->
          alloc_cost 1
      | Diff_timestamps ->
          alloc_cost 1
      | Add_tez ->
          alloc_cost 1
      | Sub_tez ->
          alloc_cost 1
      | Mul_teznat ->
          alloc_cost 1
      | Mul_nattez ->
          alloc_cost 1
      | Ediv_teznat ->
          alloc_cost 1
      | Ediv_tez ->
          alloc_cost 1
      | Or ->
          alloc_cost 1
      | And ->
          alloc_cost 1
      | Xor ->
          alloc_cost 1
      | Not ->
          alloc_cost 1
      | Is_nat ->
          alloc_cost 1
      | Neg_nat ->
          alloc_cost 1
      | Neg_int ->
          alloc_cost 1
      | Abs_int ->
          alloc_cost 1
      | Int_nat ->
          alloc_cost 1
      | Add_intint ->
          alloc_cost 1
      | Add_intnat ->
          alloc_cost 1
      | Add_natint ->
          alloc_cost 1
      | Add_natnat ->
          alloc_cost 1
      | Sub_int ->
          alloc_cost 1
      | Mul_intint ->
          alloc_cost 1
      | Mul_intnat ->
          alloc_cost 1
      | Mul_natint ->
          alloc_cost 1
      | Mul_natnat ->
          alloc_cost 1
      | Ediv_intint ->
          alloc_cost 1
      | Ediv_intnat ->
          alloc_cost 1
      | Ediv_natint ->
          alloc_cost 1
      | Ediv_natnat ->
          alloc_cost 1
      | Lsl_nat ->
          alloc_cost 1
      | Lsr_nat ->
          alloc_cost 1
      | Or_nat ->
          alloc_cost 1
      | And_nat ->
          alloc_cost 1
      | And_int_nat ->
          alloc_cost 1
      | Xor_nat ->
          alloc_cost 1
      | Not_nat ->
          alloc_cost 1
      | Not_int ->
          alloc_cost 1
      | Seq _ ->
          alloc_cost 8
      | If _ ->
          alloc_cost 8
      | Loop _ ->
          alloc_cost 4
      | Loop_left _ ->
          alloc_cost 5
      | Dip _ ->
          alloc_cost 4
      | Exec ->
          alloc_cost 1
      | Apply _ ->
          alloc_cost 1
      | Lambda _ ->
          alloc_cost 2
      | Failwith _ ->
          alloc_cost 1
      | Nop ->
          alloc_cost 0
      | Compare _ ->
          alloc_cost 1
      | Eq ->
          alloc_cost 1
      | Neq ->
          alloc_cost 1
      | Lt ->
          alloc_cost 1
      | Gt ->
          alloc_cost 1
      | Le ->
          alloc_cost 1
      | Ge ->
          alloc_cost 1
      | Address ->
          alloc_cost 1
      | Contract _ ->
          alloc_cost 2
      | Transfer_tokens ->
          alloc_cost 1
      | Create_account ->
          alloc_cost 2
      | Implicit_account ->
          alloc_cost 1
      | Create_contract _ ->
          alloc_cost 8
      (* Deducted the cost of removed arguments manager, spendable and delegatable:
           - manager: key_hash = 1
           - spendable: bool = 0
           - delegatable: bool = 0
        *)
      | Create_contract_2 _ ->
          alloc_cost 7
      | Set_delegate ->
          alloc_cost 1
      | Now ->
          alloc_cost 1
      | Balance ->
          alloc_cost 1
      | Check_signature ->
          alloc_cost 1
      | Hash_key ->
          alloc_cost 1
      | Pack _ ->
          alloc_cost 2
      | Unpack _ ->
          alloc_cost 2
      | Blake2b ->
          alloc_cost 1
      | Sha256 ->
          alloc_cost 1
      | Sha512 ->
          alloc_cost 1
      | Steps_to_quota ->
          alloc_cost 1
      | Source ->
          alloc_cost 1
      | Sender ->
          alloc_cost 1
      | Self _ ->
          alloc_cost 2
      | Amount ->
          alloc_cost 1
      | Dig (n, _) ->
          n *@ alloc_cost 1 (* _ is a unary development of n *)
      | Dug (n, _) ->
          n *@ alloc_cost 1
      | Dipn (n, _, _) ->
          n *@ alloc_cost 1
      | Dropn (n, _) ->
          n *@ alloc_cost 1
      | ChainId ->
          alloc_cost 1
  end

  module Unparse = struct
    let prim_cost l annot = Script.prim_node_cost_nonrec_of_length l annot

    let seq_cost = Script.seq_node_cost_nonrec_of_length

    let string_cost length = Script.string_node_cost_of_length length

    let cycle = step_cost 1

    let bool = prim_cost 0 []

    let unit = prim_cost 0 []

    (* We count the length of strings and bytes to prevent hidden
       miscalculations due to non detectable expansion of sharing. *)
    let string s = Script.string_node_cost s

    let bytes s = Script.bytes_node_cost s

    let z i = Script.int_node_cost i

    let int i = Script.int_node_cost (Script_int.to_zint i)

    let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *)

    let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int

    let operation bytes = Script.bytes_node_cost bytes

    let chain_id bytes = Script.bytes_node_cost bytes

    let key = string_cost 54

    let key_hash = string_cost 36

    let signature = string_cost 128

    let contract = string_cost 36

    let pair = prim_cost 2 []

    let union = prim_cost 1 []

    let some = prim_cost 1 []

    let none = prim_cost 0 []

    let list_element = alloc_cost 2

    let set_element = alloc_cost 2

    let map_element = alloc_cost 2

    let one_arg_type = prim_cost 1

    let two_arg_type = prim_cost 2

    let set_to_list = Legacy.set_to_list

    let map_to_list = Legacy.map_to_list
  end
end
src/proto_alpha/lib_protocol/michelson_v1_gas.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_raw_protocol_alpha.Alpha_context.Gas.

Module Cost_of.
  Definition log2 : Z -> Z :=
    let fix help (acc : Z) (function_parameter : Z) : Z :=
      match function_parameter with
      | 0 => acc
      | n =>
        help
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus acc
            1)
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div n 2)
      end in
    help 1.
  
  Definition z_bytes (z : Tezos_protocol_environment_alpha__Environment.Z.t)
    : Z :=
    let bits := Tezos_protocol_environment_alpha__Environment.Z.numbits z in
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 7 bits)
      8.
  
  Definition int_bytes {a : Type}
    (z : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num a) : Z :=
    z_bytes (Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_zint z).
  
  Definition timestamp_bytes
    (t : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t) : Z :=
    let z := Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.to_zint t
      in
    z_bytes z.
  
  Fixpoint size_of_comparable {a b : Type}
    (wit : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a b)
    (v : a) : Z :=
    match wit with
    | Int_key _ => int_bytes v
    | Nat_key _ => int_bytes v
    | String_key _ =>
      Tezos_protocol_environment_alpha__Environment.String.length v
    | Bytes_key _ =>
      Tezos_protocol_environment_alpha__Environment.MBytes.length v
    | Bool_key _ => 8
    | Key_hash_key _ =>
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.size
    | Timestamp_key _ => timestamp_bytes v
    | Address_key _ =>
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.size
    | Mutez_key _ => 8
    | Pair_key (l, _) (r, _) _ =>
      match v with
      | (lval, rval) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
          (size_of_comparable l lval) (size_of_comparable r rval)
      end
    end.
  
  Definition string (length : Z)
    : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
    Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_bytes_cost length.
  
  Definition bytes (length : Z)
    : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
    Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_mbytes_cost length.
  
  Definition manager_operation
    : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
    Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 10000.
  
  Module Legacy.
    Definition zint (z : Tezos_protocol_environment_alpha__Environment.Z.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_bits_cost
        (Tezos_protocol_environment_alpha__Environment.Z.numbits z).
    
    Definition set_to_list {item : Type}
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set item)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
          Box.size 2).
    
    Definition map_to_list {key value : Type}
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let size :=
        Tezos_protocol_environment_alpha__Environment.Pervasives.snd Box.boxed
        in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at 3
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost size).
    
    Definition z_to_int64 : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 2)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1).
    
    Definition hash
      (data : Tezos_protocol_environment_alpha__Environment.MBytes.t) (len : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at 10
          (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost
            (Tezos_protocol_environment_alpha__Environment.MBytes.length data)))
        (string len).
    
    Definition set_access {elt : Type}
      (_key : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
      : Z :=
      let Box := projT2 Box in
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at log2
        Box.size.
    
    Definition set_update {A B : Type}
      (key : A) (_presence : B)
      (set : Tezos_raw_protocol_alpha.Script_typed_ir.set A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at (set_access key set)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3).
  End Legacy.
  
  Module Interpreter.
    Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition nop : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.free.
    
    Definition stack_op : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition push : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition wrap : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition variant_no_data
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition branch : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition pair_access : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition cons : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition loop_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 5.
    
    Definition loop_cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition loop_iter : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 20.
    
    Definition loop_map : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 30.
    
    Definition empty_set : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition set_to_list {elt : Type}
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
          Box.size 20).
    
    Definition set_mem {elt : Type}
      (elt : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let elt_bytes := size_of_comparable Box.elt_ty elt in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
              elt_bytes 82)) (log2 Box.size)).
    
    Definition set_update {elt : Type} (elt : elt) (function_parameter : bool)
      : (Tezos_raw_protocol_alpha.Script_typed_ir.set elt) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match function_parameter with
      | _ =>
        fun Box =>
          let Box := projT2 Box in
          let elt_bytes := size_of_comparable Box.elt_ty elt in
          Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                1
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
                  elt_bytes 82)) (log2 Box.size))
      end.
    
    Definition set_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition empty_map : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition map_to_list {key value : Type}
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let size :=
        Tezos_protocol_environment_alpha__Environment.Pervasives.snd Box.boxed
        in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star size
          20).
    
    Definition map_access {key value : Type}
      (key : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let map_card :=
        Tezos_protocol_environment_alpha__Environment.Pervasives.snd Box.boxed
        in
      let key_bytes := size_of_comparable Box.key_ty key in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
              key_bytes 70)) (log2 map_card)).
    
    Definition map_mem {A B : Type}
      : A ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := map_access.
    
    Definition map_get {A B : Type}
      : A ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := map_access.
    
    Definition map_update {key value : Type}
      (key : key) (_value : option value)
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let map_card :=
        Tezos_protocol_environment_alpha__Environment.Pervasives.snd Box.boxed
        in
      let key_bytes := size_of_comparable Box.key_ty key in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
              key_bytes 38)) (log2 map_card)).
    
    Definition map_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition add_timestamp {a : Type}
      (t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      (t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num a)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := int_bytes t2 in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
              bytes1 bytes2) 62)).
    
    Definition sub_timestamp {A : Type}
      : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t ->
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := add_timestamp.
    
    Definition diff_timestamps
      (t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      (t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := timestamp_bytes t2 in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
              bytes1 bytes2) 62)).
    
    Fixpoint concat_loop {A : Type} (l : list A) (acc : Z) : Z :=
      match l with
      | [] => 30
      | cons _ tl =>
        concat_loop tl
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus acc
            30)
      end.
    
    Definition concat_string {A : Type} (string_list : list A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (concat_loop string_list 0).
    
    Definition slice_string (string_length : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 40
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            string_length 70)).
    
    Definition concat_bytes {A : Type} (bytes_list : list A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (concat_loop bytes_list 0).
    
    Definition int64_op : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 61.
    
    Definition z_to_int64 : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 20.
    
    Definition int64_to_z : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 20.
    
    Definition bool_binop {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10
          end
      end.
    
    Definition bool_unop {A : Type} (function_parameter : A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match function_parameter with
      | _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10
      end.
    
    Definition abs {A : Type}
      (int : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 61
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (int_bytes Z) 70)).
    
    Definition int {A : Type} (_int : A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.free.
    
    Definition neg {A : Type}
      : (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := abs.
    
    Definition add {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
              (int_bytes i1) (int_bytes i2)) 62)).
    
    Definition sub {A B : Type}
      : (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := add.
    
    Definition mul {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes :=
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
          (int_bytes i1) (int_bytes i2) in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
              string 6) (log2 string))).
    
    Definition indic_lt
      (x :
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (y :
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : Z :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
          x y then
        1
      else
        0.
    
    Definition div {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      let cost :=
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
            (indic_lt bytes2 bytes1)
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
              bytes1 bytes2)) bytes2 in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div cost
            3151)).
    
    Definition shift_left {A B : Type} (_i : A) (_shift_bits : B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 30.
    
    Definition shift_right {A B : Type} (_i : A) (_shift_bits : B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 30.
    
    Definition logor {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
              bytes1 bytes2) 70)).
    
    Definition logand {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              bytes1 bytes2) 70)).
    
    Definition logxor {A B : Type}
      : (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := logor.
    
    Definition lognot {A : Type}
      (i : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (int_bytes i) 20)).
    
    Definition exec : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition compare_bool {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 30
          end
      end.
    
    Definition compare_string (s1 : string) (s2 : string)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 :=
        Tezos_protocol_environment_alpha__Environment.String.length s1 in
      let bytes2 :=
        Tezos_protocol_environment_alpha__Environment.String.length s2 in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 30
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              bytes1 bytes2) 123)).
    
    Definition compare_bytes
      (b1 : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      (b2 : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 :=
        Tezos_protocol_environment_alpha__Environment.MBytes.length b1 in
      let bytes2 :=
        Tezos_protocol_environment_alpha__Environment.MBytes.length b2 in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 30
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              bytes1 bytes2) 123)).
    
    Definition compare_tez {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 30
          end
      end.
    
    Definition compare_zint {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              (int_bytes i1) (int_bytes i2)) 82)).
    
    Definition compare_key_hash {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 92
          end
      end.
    
    Definition compare_timestamp
      (t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      (t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := timestamp_bytes t2 in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 51
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              bytes1 bytes2) 82)).
    
    Definition compare_address {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match function_parameter with
      | _ =>
        fun function_parameter =>
          match function_parameter with
          | _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 92
          end
      end.
    
    Definition compare_res : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 30.
    
    Definition unpack_failed
      (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let len :=
        Tezos_protocol_environment_alpha__Environment.MBytes.length string in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at len
          (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_mbytes_cost 1))
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at len
          (Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at (log2 len)
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3)
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1)))).
    
    Definition address : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 10000.
    
    Definition transfer : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 10.
    
    Definition create_account
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 10.
    
    Definition create_contract
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 10.
    
    Definition implicit_account
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 10.
    
    Definition set_delegate : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 10)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.write_bytes_cost
          (Tezos_protocol_environment_alpha__Environment.Z.of_int 32)).
    
    Definition balance : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition now : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition check_signature_secp256k1 (bytes : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 10342
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            string 5)).
    
    Definition check_signature_ed25519 (bytes : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 36864
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            string 5)).
    
    Definition check_signature_p256 (bytes : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 36864
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            string 5)).
    
    Definition check_signature
      (pkey : Tezos_protocol_environment_alpha__Environment.Signature.public_key)
      (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match pkey with
      | Ed25519 _ =>
        check_signature_ed25519
          (Tezos_protocol_environment_alpha__Environment.MBytes.length string)
      | Secp256k1 _ =>
        check_signature_secp256k1
          (Tezos_protocol_environment_alpha__Environment.MBytes.length string)
      | P256 _ =>
        check_signature_p256
          (Tezos_protocol_environment_alpha__Environment.MBytes.length string)
      end.
    
    Definition hash_key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 30.
    
    Definition hash_blake2b
      (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 102
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
            (Tezos_protocol_environment_alpha__Environment.MBytes.length b) 5)).
    
    Definition hash_sha256
      (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 409
          (Tezos_protocol_environment_alpha__Environment.MBytes.length b)).
    
    Definition hash_sha512
      (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes := Tezos_protocol_environment_alpha__Environment.MBytes.length b
        in
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 409
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
            (Tezos_protocol_environment_alpha__Environment.Pervasives.lsr string
              1)
            (Tezos_protocol_environment_alpha__Environment.Pervasives.lsr string
              4))).
    
    Definition steps_to_quota
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition source : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition self : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition amount : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost 10.
    
    Definition chain_id : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1.
    
    Definition stack_n_op (n : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.atomic_step_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 20
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
              (Tezos_protocol_environment_alpha__Environment.Pervasives.lsr n 1)
              (Tezos_protocol_environment_alpha__Environment.Pervasives.lsr n 2))
            (Tezos_protocol_environment_alpha__Environment.Pervasives.lsr n 4))).
    
    Definition apply : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 8)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1).
    
    Fixpoint compare {a s : Type}
      (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
      (x : a) (y : a) : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match ty with
      | Bool_key _ => compare_bool x y
      | String_key _ => compare_string x y
      | Bytes_key _ => compare_bytes x y
      | Mutez_key _ => compare_tez x y
      | Int_key _ => compare_zint x y
      | Nat_key _ => compare_zint x y
      | Key_hash_key _ => compare_key_hash x y
      | Timestamp_key _ => compare_timestamp x y
      | Address_key _ => compare_address x y
      | Pair_key (tl, _) (tr, _) _ =>
        in
        Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at (compare tl xl yl)
          (compare tr xr yr)
      end.
  End Interpreter.
  
  Module Typechecking.
    Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1.
    
    Definition bool : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.free.
    
    Definition unit : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.free.
    
    Definition string : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      string.
    
    Definition bytes : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      string.
    
    Definition z
      : Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.zint.
    
    Definition int_of_string (str : string)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
          (Tezos_protocol_environment_alpha__Environment.String.length str) 5).
    
    Definition tez : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1).
    
    Definition string_timestamp
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 3)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3).
    
    Definition key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 3)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3).
    
    Definition key_hash : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1).
    
    Definition signature : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1).
    
    Definition chain_id : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1).
    
    Definition contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 5.
    
    Definition get_script : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 20)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 5).
    
    Definition contract_exists
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 15)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 5).
    
    Definition pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2.
    
    Definition union : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1.
    
    Definition lambda : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 5)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 3).
    
    Definition some : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1.
    
    Definition none : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 0.
    
    Definition list_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1).
    
    Definition set_element (size : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at (log2 size)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
          (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3)
          (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 2)).
    
    Definition map_element (size : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at (log2 size)
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
          (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 4)
          (Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 2)).
    
    Definition primitive_type
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1.
    
    Definition one_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2.
    
    Definition two_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3.
    
    Definition operation (b : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := string b.
    
    Definition type_ (nb_args : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
          nb_args 1).
    
    Definition instr {a b : Type}
      (i : Tezos_raw_protocol_alpha.Script_typed_ir.instr b a)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.op_plus_at
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1)
        match i with
        | Drop => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 0
        | Dup => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Swap => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 0
        | Const _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Cons_pair => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Car => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Cdr => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Cons_some => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Cons_none _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3
        | If_none _ _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Left => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3
        | Right => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 3
        | If_left _ _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Cons_list => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Nil => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | If_cons _ _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | List_map _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 5
        | List_iter _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 4
        | List_size => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Empty_set _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Set_iter _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 4
        | Set_mem => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Set_update => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Set_size => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Empty_map _ _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Map_map _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 5
        | Map_iter _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 4
        | Map_mem => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Map_get => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Map_update => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Map_size => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Empty_big_map _ _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Big_map_mem => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Big_map_get => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Big_map_update =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Concat_string =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Concat_string_pair =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Concat_bytes =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Concat_bytes_pair =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Slice_string =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Slice_bytes => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | String_size => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Bytes_size => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Add_seconds_to_timestamp =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Add_timestamp_to_seconds =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Sub_timestamp_seconds =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Diff_timestamps =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Add_tez => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Sub_tez => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Mul_teznat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Mul_nattez => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Ediv_teznat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Ediv_tez => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Or => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | And => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Xor => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Not => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Is_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Neg_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Neg_int => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Abs_int => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Int_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Add_intint => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Add_intnat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Add_natint => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Add_natnat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Sub_int => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Mul_intint => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Mul_intnat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Mul_natint => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Mul_natnat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Ediv_intint => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Ediv_intnat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Ediv_natint => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Ediv_natnat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Lsl_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Lsr_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Or_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | And_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | And_int_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Xor_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Not_nat => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Not_int => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Seq _ _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 8
        | If _ _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 8
        | Loop _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 4
        | Loop_left _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 5
        | Dip _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 4
        | Exec => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Apply _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Lambda _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Failwith _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Nop => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 0
        | Compare _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Eq => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Neq => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Lt => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Gt => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Le => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Ge => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Address => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Contract _ _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Transfer_tokens =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Create_account =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Implicit_account =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Create_contract _ _ _ _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 8
        | Create_contract_2 _ _ _ _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 7
        | Set_delegate =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Now => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Balance => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Check_signature =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Hash_key => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Pack _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Unpack _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Blake2b => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Sha256 => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Sha512 => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Steps_to_quota =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Source => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Sender => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Self _ _ => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2
        | Amount => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        | Dig n _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at n
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1)
        | Dug n _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at n
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1)
        | Dipn n _ _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at n
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1)
        | Dropn n _ =>
          Tezos_raw_protocol_alpha.Alpha_context.Gas.op_star_at n
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1)
        | ChainId => Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 1
        end.
  End Typechecking.
  
  Module Unparse.
    Definition prim_cost
      (l : Z) (annot : Tezos_raw_protocol_alpha.Alpha_context.Script.annot)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim_node_cost_nonrec_of_length
        l annot.
    
    Definition seq_cost
      : Z -> Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.seq_node_cost_nonrec_of_length.
    
    Definition string_cost (length : Z)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.string_node_cost_of_length
        length.
    
    Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.step_cost 1.
    
    Definition bool : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 0 [].
    
    Definition unit : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 0 [].
    
    Definition string (s : string)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.string_node_cost s.
    
    Definition bytes
      (s : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.bytes_node_cost s.
    
    Definition z (i : Tezos_protocol_environment_alpha__Environment.Z.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.int_node_cost i.
    
    Definition int {A : Type}
      (i : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.int_node_cost
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_zint i).
    
    Definition tez : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.int_node_cost_of_numbits 60.
    
    Definition timestamp
      (x : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.to_zint x)
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_zint) Z.
    
    Definition operation
      (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.bytes_node_cost string.
    
    Definition chain_id
      (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Script.bytes_node_cost string.
    
    Definition key : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      string_cost 54.
    
    Definition key_hash : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      string_cost 36.
    
    Definition signature : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      string_cost 128.
    
    Definition contract : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      string_cost 36.
    
    Definition pair : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 2 [].
    
    Definition union : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 1 [].
    
    Definition some : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 1 [].
    
    Definition none : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 0 [].
    
    Definition list_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2.
    
    Definition set_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2.
    
    Definition map_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      Tezos_raw_protocol_alpha.Alpha_context.Gas.alloc_cost 2.
    
    Definition one_arg_type
      : Tezos_raw_protocol_alpha.Alpha_context.Script.annot ->
        Tezos_raw_protocol_alpha__Alpha_context.Gas.cost := prim_cost 1.
    
    Definition two_arg_type
      : Tezos_raw_protocol_alpha.Alpha_context.Script.annot ->
        Tezos_raw_protocol_alpha__Alpha_context.Gas.cost := prim_cost 2.
    
    Definition set_to_list {A : Type}
      : (Tezos_raw_protocol_alpha.Script_typed_ir.set A) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.set_to_list.
    
    Definition map_to_list {A B : Type}
      : (Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.map_to_list.
  End Unparse.
End Cost_of.
src/proto_alpha/lib_protocol/michelson_v1_gas.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

module Cost_of : sig
  val manager_operation : Gas.cost

  module Legacy : sig
    val z_to_int64 : Gas.cost

    val hash : MBytes.t -> int -> Gas.cost

    val map_to_list : ('b, 'c) Script_typed_ir.map -> Gas.cost

    val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost
  end

  module Interpreter : sig
    val cycle : Gas.cost

    val loop_cycle : Gas.cost

    val loop_size : Gas.cost

    val loop_iter : Gas.cost

    val loop_map : Gas.cost

    val nop : Gas.cost

    val stack_op : Gas.cost

    val stack_n_op : int -> Gas.cost

    val bool_binop : 'a -> 'b -> Gas.cost

    val bool_unop : 'a -> Gas.cost

    val pair : Gas.cost

    val pair_access : Gas.cost

    val cons : Gas.cost

    val variant_no_data : Gas.cost

    val branch : Gas.cost

    val concat_string : string list -> Gas.cost

    val concat_bytes : MBytes.t list -> Gas.cost

    val slice_string : int -> Gas.cost

    val map_mem : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost

    val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost

    val map_get : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost

    val map_update :
      'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost

    val map_size : Gas.cost

    val set_to_list : 'a Script_typed_ir.set -> Gas.cost

    val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost

    val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost

    val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val abs : 'a Script_int.num -> Gas.cost

    val neg : 'a Script_int.num -> Gas.cost

    val int : 'a -> Gas.cost

    val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost

    val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost

    val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost

    val empty_set : Gas.cost

    val set_size : Gas.cost

    val empty_map : Gas.cost

    val int64_op : Gas.cost

    val z_to_int64 : Gas.cost

    val int64_to_z : Gas.cost

    val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val lognot : 'a Script_int.num -> Gas.cost

    val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost

    val exec : Gas.cost

    val push : Gas.cost

    val compare_res : Gas.cost

    val unpack_failed : MBytes.t -> Gas.cost

    val address : Gas.cost

    val contract : Gas.cost

    val transfer : Gas.cost

    val create_account : Gas.cost

    val create_contract : Gas.cost

    val implicit_account : Gas.cost

    val set_delegate : Gas.cost

    val balance : Gas.cost

    val now : Gas.cost

    val check_signature : public_key -> MBytes.t -> Gas.cost

    val hash_key : Gas.cost

    val hash_blake2b : MBytes.t -> Gas.cost

    val hash_sha256 : MBytes.t -> Gas.cost

    val hash_sha512 : MBytes.t -> Gas.cost

    val steps_to_quota : Gas.cost

    val source : Gas.cost

    val self : Gas.cost

    val amount : Gas.cost

    val chain_id : Gas.cost

    val wrap : Gas.cost

    val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost

    val apply : Gas.cost
  end

  module Typechecking : sig
    val cycle : Gas.cost

    val unit : Gas.cost

    val bool : Gas.cost

    val tez : Gas.cost

    val z : Z.t -> Gas.cost

    val string : int -> Gas.cost

    val bytes : int -> Gas.cost

    val int_of_string : string -> Gas.cost

    val string_timestamp : Gas.cost

    val key : Gas.cost

    val key_hash : Gas.cost

    val signature : Gas.cost

    val chain_id : Gas.cost

    val contract : Gas.cost

    (** Gas.Cost of getting the code for a contract *)
    val get_script : Gas.cost

    val contract_exists : Gas.cost

    (** Additional Gas.cost of parsing a pair over the Gas.cost of parsing each type  *)
    val pair : Gas.cost

    val union : Gas.cost

    val lambda : Gas.cost

    val some : Gas.cost

    val none : Gas.cost

    val list_element : Gas.cost

    val set_element : int -> Gas.cost

    val map_element : int -> Gas.cost

    val primitive_type : Gas.cost

    val one_arg_type : Gas.cost

    val two_arg_type : Gas.cost

    val operation : int -> Gas.cost

    (** Cost of parsing a type *)
    val type_ : int -> Gas.cost

    (** Cost of parsing an instruction *)
    val instr : ('a, 'b) Script_typed_ir.instr -> Gas.cost
  end

  module Unparse : sig
    val prim_cost : int -> Script.annot -> Gas.cost

    val seq_cost : int -> Gas.cost

    val cycle : Gas.cost

    val unit : Gas.cost

    val bool : Gas.cost

    val z : Z.t -> Gas.cost

    val int : 'a Script_int.num -> Gas.cost

    val tez : Gas.cost

    val string : string -> Gas.cost

    val bytes : MBytes.t -> Gas.cost

    val timestamp : Script_timestamp.t -> Gas.cost

    val key : Gas.cost

    val key_hash : Gas.cost

    val signature : Gas.cost

    val operation : MBytes.t -> Gas.cost

    val chain_id : MBytes.t -> Gas.cost

    val contract : Gas.cost

    (** Additional Gas.cost of parsing a pair over the Gas.cost of parsing each type  *)
    val pair : Gas.cost

    val union : Gas.cost

    val some : Gas.cost

    val none : Gas.cost

    val list_element : Gas.cost

    val set_element : Gas.cost

    val map_element : Gas.cost

    val one_arg_type : Script.annot -> Gas.cost

    val two_arg_type : Script.annot -> Gas.cost

    val set_to_list : 'a Script_typed_ir.set -> Gas.cost

    val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost
  end
end
src/proto_alpha/lib_protocol/michelson_v1_gas.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Cost_of.
  Parameter manager_operation : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
  
  Module Legacy.
    Parameter z_to_int64 : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter hash : Tezos_protocol_environment_alpha__Environment.MBytes.t ->
      Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_to_list : forall {b c : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.map
      b c) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_update : forall {a : Type}, a ->
      bool ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.set a) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
  End Legacy.
  
  Module Interpreter.
    Parameter cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter loop_cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter loop_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter loop_iter : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter loop_map : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter nop : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter stack_op : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter stack_n_op : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter bool_binop : forall {a b : Type}, a ->
      b -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter bool_unop : forall {a : Type}, a ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter pair_access : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter cons : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter variant_no_data : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter branch : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter concat_string : (list string) ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter concat_bytes : (list
      Tezos_protocol_environment_alpha__Environment.MBytes.t) ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter slice_string : Z ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_mem : forall {a b : Type}, a ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.map a b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_to_list : forall {a b : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.map
      a b) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_get : forall {a b : Type}, a ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.map a b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_update : forall {a b : Type}, a ->
      (option b) ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.map a b) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_to_list : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.set
      a) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_update : forall {a : Type}, a ->
      bool ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.set a) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_mem : forall {a : Type}, a ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.set a) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter mul : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter div : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter add : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter sub : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter abs : forall {a : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter neg : forall {a : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter int : forall {a : Type}, a ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter add_timestamp : forall {a : Type}, Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t
      ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num a) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter sub_timestamp : forall {a : Type}, Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t
      ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num a) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter diff_timestamps : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t
      ->
      Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter empty_set : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter empty_map : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter int64_op : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter z_to_int64 : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter int64_to_z : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter logor : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter logand : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter logxor : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter lognot : forall {a : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter shift_left : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter shift_right : forall {a b : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) ->
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num b) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter exec : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter push : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter compare_res : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter unpack_failed : Tezos_protocol_environment_alpha__Environment.MBytes.t
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter address : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter transfer : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter create_account : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter create_contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter implicit_account : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_delegate : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter balance : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter now : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter check_signature : Tezos_raw_protocol_alpha.Alpha_context.public_key
      ->
      Tezos_protocol_environment_alpha__Environment.MBytes.t ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter hash_key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter hash_blake2b : Tezos_protocol_environment_alpha__Environment.MBytes.t
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter hash_sha256 : Tezos_protocol_environment_alpha__Environment.MBytes.t
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter hash_sha512 : Tezos_protocol_environment_alpha__Environment.MBytes.t
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter steps_to_quota : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter source : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter self : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter amount : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter chain_id : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter wrap : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter compare : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty
      a) -> a -> a -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter apply : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
  End Interpreter.
  
  Module Typechecking.
    Parameter cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter unit : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter bool : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter tez : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter z : Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter string : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter bytes : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter int_of_string : string ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter string_timestamp : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter key_hash : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter signature : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter chain_id : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter get_script : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter contract_exists : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter union : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter lambda : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter some : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter none : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter list_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_element : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_element : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter primitive_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter one_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter two_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter operation : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter type_ : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter instr : forall {a b : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.instr
      a b) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
  End Typechecking.
  
  Module Unparse.
    Parameter prim_cost : Z ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.annot ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter seq_cost : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter unit : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter bool : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter z : Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter int : forall {a : Type}, (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      a) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter tez : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter string : string -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t ->
      Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter timestamp : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter key_hash : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter signature : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter operation : Tezos_protocol_environment_alpha__Environment.MBytes.t
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter chain_id : Tezos_protocol_environment_alpha__Environment.MBytes.t
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter union : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter some : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter none : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter list_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter one_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Script.annot
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter two_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Script.annot
      -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter set_to_list : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.set
      a) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
    
    Parameter map_to_list : forall {a b : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.map
      a b) -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost.
  End Unparse.
End Cost_of.
src/proto_alpha/lib_protocol/michelson_v1_primitives.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Micheline

type error += Unknown_primitive_name of string

type error += Invalid_case of string

type error +=
  | Invalid_primitive_name of
      string Micheline.canonical * Micheline.canonical_location

type prim =
  | K_parameter
  | K_storage
  | K_code
  | D_False
  | D_Elt
  | D_Left
  | D_None
  | D_Pair
  | D_Right
  | D_Some
  | D_True
  | D_Unit
  | I_PACK
  | I_UNPACK
  | I_BLAKE2B
  | I_SHA256
  | I_SHA512
  | I_ABS
  | I_ADD
  | I_AMOUNT
  | I_AND
  | I_BALANCE
  | I_CAR
  | I_CDR
  | I_CHAIN_ID
  | I_CHECK_SIGNATURE
  | I_COMPARE
  | I_CONCAT
  | I_CONS
  | I_CREATE_ACCOUNT
  | I_CREATE_CONTRACT
  | I_IMPLICIT_ACCOUNT
  | I_DIP
  | I_DROP
  | I_DUP
  | I_EDIV
  | I_EMPTY_BIG_MAP
  | I_EMPTY_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | I_APPLY
  | I_FAILWITH
  | I_GE
  | I_GET
  | I_GT
  | I_HASH_KEY
  | I_IF
  | I_IF_CONS
  | I_IF_LEFT
  | I_IF_NONE
  | I_INT
  | I_LAMBDA
  | I_LE
  | I_LEFT
  | I_LOOP
  | I_LSL
  | I_LSR
  | I_LT
  | I_MAP
  | I_MEM
  | I_MUL
  | I_NEG
  | I_NEQ
  | I_NIL
  | I_NONE
  | I_NOT
  | I_NOW
  | I_OR
  | I_PAIR
  | I_PUSH
  | I_RIGHT
  | I_SIZE
  | I_SOME
  | I_SOURCE
  | I_SENDER
  | I_SELF
  | I_SLICE
  | I_STEPS_TO_QUOTA
  | I_SUB
  | I_SWAP
  | I_TRANSFER_TOKENS
  | I_SET_DELEGATE
  | I_UNIT
  | I_UPDATE
  | I_XOR
  | I_ITER
  | I_LOOP_LEFT
  | I_ADDRESS
  | I_CONTRACT
  | I_ISNAT
  | I_CAST
  | I_RENAME
  | I_DIG
  | I_DUG
  | T_bool
  | T_contract
  | T_int
  | T_key
  | T_key_hash
  | T_lambda
  | T_list
  | T_map
  | T_big_map
  | T_nat
  | T_option
  | T_or
  | T_pair
  | T_set
  | T_signature
  | T_string
  | T_bytes
  | T_mutez
  | T_timestamp
  | T_unit
  | T_operation
  | T_address
  | T_chain_id

let valid_case name =
  let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in
  let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in
  let rec for_all a b f =
    Compare.Int.(a > b) || (f a && for_all (a + 1) b f)
  in
  let len = String.length name in
  Compare.Int.(len <> 0)
  && Compare.Char.(name.[0] <> '_')
  && ( (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_upper name.[i]))
     || (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))
     || (is_lower name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))
     )

let string_of_prim = function
  | K_parameter ->
      "parameter"
  | K_storage ->
      "storage"
  | K_code ->
      "code"
  | D_False ->
      "False"
  | D_Elt ->
      "Elt"
  | D_Left ->
      "Left"
  | D_None ->
      "None"
  | D_Pair ->
      "Pair"
  | D_Right ->
      "Right"
  | D_Some ->
      "Some"
  | D_True ->
      "True"
  | D_Unit ->
      "Unit"
  | I_PACK ->
      "PACK"
  | I_UNPACK ->
      "UNPACK"
  | I_BLAKE2B ->
      "BLAKE2B"
  | I_SHA256 ->
      "SHA256"
  | I_SHA512 ->
      "SHA512"
  | I_ABS ->
      "ABS"
  | I_ADD ->
      "ADD"
  | I_AMOUNT ->
      "AMOUNT"
  | I_AND ->
      "AND"
  | I_BALANCE ->
      "BALANCE"
  | I_CAR ->
      "CAR"
  | I_CDR ->
      "CDR"
  | I_CHAIN_ID ->
      "CHAIN_ID"
  | I_CHECK_SIGNATURE ->
      "CHECK_SIGNATURE"
  | I_COMPARE ->
      "COMPARE"
  | I_CONCAT ->
      "CONCAT"
  | I_CONS ->
      "CONS"
  | I_CREATE_ACCOUNT ->
      "CREATE_ACCOUNT"
  | I_CREATE_CONTRACT ->
      "CREATE_CONTRACT"
  | I_IMPLICIT_ACCOUNT ->
      "IMPLICIT_ACCOUNT"
  | I_DIP ->
      "DIP"
  | I_DROP ->
      "DROP"
  | I_DUP ->
      "DUP"
  | I_EDIV ->
      "EDIV"
  | I_EMPTY_BIG_MAP ->
      "EMPTY_BIG_MAP"
  | I_EMPTY_MAP ->
      "EMPTY_MAP"
  | I_EMPTY_SET ->
      "EMPTY_SET"
  | I_EQ ->
      "EQ"
  | I_EXEC ->
      "EXEC"
  | I_APPLY ->
      "APPLY"
  | I_FAILWITH ->
      "FAILWITH"
  | I_GE ->
      "GE"
  | I_GET ->
      "GET"
  | I_GT ->
      "GT"
  | I_HASH_KEY ->
      "HASH_KEY"
  | I_IF ->
      "IF"
  | I_IF_CONS ->
      "IF_CONS"
  | I_IF_LEFT ->
      "IF_LEFT"
  | I_IF_NONE ->
      "IF_NONE"
  | I_INT ->
      "INT"
  | I_LAMBDA ->
      "LAMBDA"
  | I_LE ->
      "LE"
  | I_LEFT ->
      "LEFT"
  | I_LOOP ->
      "LOOP"
  | I_LSL ->
      "LSL"
  | I_LSR ->
      "LSR"
  | I_LT ->
      "LT"
  | I_MAP ->
      "MAP"
  | I_MEM ->
      "MEM"
  | I_MUL ->
      "MUL"
  | I_NEG ->
      "NEG"
  | I_NEQ ->
      "NEQ"
  | I_NIL ->
      "NIL"
  | I_NONE ->
      "NONE"
  | I_NOT ->
      "NOT"
  | I_NOW ->
      "NOW"
  | I_OR ->
      "OR"
  | I_PAIR ->
      "PAIR"
  | I_PUSH ->
      "PUSH"
  | I_RIGHT ->
      "RIGHT"
  | I_SIZE ->
      "SIZE"
  | I_SOME ->
      "SOME"
  | I_SOURCE ->
      "SOURCE"
  | I_SENDER ->
      "SENDER"
  | I_SELF ->
      "SELF"
  | I_SLICE ->
      "SLICE"
  | I_STEPS_TO_QUOTA ->
      "STEPS_TO_QUOTA"
  | I_SUB ->
      "SUB"
  | I_SWAP ->
      "SWAP"
  | I_TRANSFER_TOKENS ->
      "TRANSFER_TOKENS"
  | I_SET_DELEGATE ->
      "SET_DELEGATE"
  | I_UNIT ->
      "UNIT"
  | I_UPDATE ->
      "UPDATE"
  | I_XOR ->
      "XOR"
  | I_ITER ->
      "ITER"
  | I_LOOP_LEFT ->
      "LOOP_LEFT"
  | I_ADDRESS ->
      "ADDRESS"
  | I_CONTRACT ->
      "CONTRACT"
  | I_ISNAT ->
      "ISNAT"
  | I_CAST ->
      "CAST"
  | I_RENAME ->
      "RENAME"
  | I_DIG ->
      "DIG"
  | I_DUG ->
      "DUG"
  | T_bool ->
      "bool"
  | T_contract ->
      "contract"
  | T_int ->
      "int"
  | T_key ->
      "key"
  | T_key_hash ->
      "key_hash"
  | T_lambda ->
      "lambda"
  | T_list ->
      "list"
  | T_map ->
      "map"
  | T_big_map ->
      "big_map"
  | T_nat ->
      "nat"
  | T_option ->
      "option"
  | T_or ->
      "or"
  | T_pair ->
      "pair"
  | T_set ->
      "set"
  | T_signature ->
      "signature"
  | T_string ->
      "string"
  | T_bytes ->
      "bytes"
  | T_mutez ->
      "mutez"
  | T_timestamp ->
      "timestamp"
  | T_unit ->
      "unit"
  | T_operation ->
      "operation"
  | T_address ->
      "address"
  | T_chain_id ->
      "chain_id"

let prim_of_string = function
  | "parameter" ->
      ok K_parameter
  | "storage" ->
      ok K_storage
  | "code" ->
      ok K_code
  | "False" ->
      ok D_False
  | "Elt" ->
      ok D_Elt
  | "Left" ->
      ok D_Left
  | "None" ->
      ok D_None
  | "Pair" ->
      ok D_Pair
  | "Right" ->
      ok D_Right
  | "Some" ->
      ok D_Some
  | "True" ->
      ok D_True
  | "Unit" ->
      ok D_Unit
  | "PACK" ->
      ok I_PACK
  | "UNPACK" ->
      ok I_UNPACK
  | "BLAKE2B" ->
      ok I_BLAKE2B
  | "SHA256" ->
      ok I_SHA256
  | "SHA512" ->
      ok I_SHA512
  | "ABS" ->
      ok I_ABS
  | "ADD" ->
      ok I_ADD
  | "AMOUNT" ->
      ok I_AMOUNT
  | "AND" ->
      ok I_AND
  | "BALANCE" ->
      ok I_BALANCE
  | "CAR" ->
      ok I_CAR
  | "CDR" ->
      ok I_CDR
  | "CHAIN_ID" ->
      ok I_CHAIN_ID
  | "CHECK_SIGNATURE" ->
      ok I_CHECK_SIGNATURE
  | "COMPARE" ->
      ok I_COMPARE
  | "CONCAT" ->
      ok I_CONCAT
  | "CONS" ->
      ok I_CONS
  | "CREATE_ACCOUNT" ->
      ok I_CREATE_ACCOUNT
  | "CREATE_CONTRACT" ->
      ok I_CREATE_CONTRACT
  | "IMPLICIT_ACCOUNT" ->
      ok I_IMPLICIT_ACCOUNT
  | "DIP" ->
      ok I_DIP
  | "DROP" ->
      ok I_DROP
  | "DUP" ->
      ok I_DUP
  | "EDIV" ->
      ok I_EDIV
  | "EMPTY_BIG_MAP" ->
      ok I_EMPTY_BIG_MAP
  | "EMPTY_MAP" ->
      ok I_EMPTY_MAP
  | "EMPTY_SET" ->
      ok I_EMPTY_SET
  | "EQ" ->
      ok I_EQ
  | "EXEC" ->
      ok I_EXEC
  | "APPLY" ->
      ok I_APPLY
  | "FAILWITH" ->
      ok I_FAILWITH
  | "GE" ->
      ok I_GE
  | "GET" ->
      ok I_GET
  | "GT" ->
      ok I_GT
  | "HASH_KEY" ->
      ok I_HASH_KEY
  | "IF" ->
      ok I_IF
  | "IF_CONS" ->
      ok I_IF_CONS
  | "IF_LEFT" ->
      ok I_IF_LEFT
  | "IF_NONE" ->
      ok I_IF_NONE
  | "INT" ->
      ok I_INT
  | "LAMBDA" ->
      ok I_LAMBDA
  | "LE" ->
      ok I_LE
  | "LEFT" ->
      ok I_LEFT
  | "LOOP" ->
      ok I_LOOP
  | "LSL" ->
      ok I_LSL
  | "LSR" ->
      ok I_LSR
  | "LT" ->
      ok I_LT
  | "MAP" ->
      ok I_MAP
  | "MEM" ->
      ok I_MEM
  | "MUL" ->
      ok I_MUL
  | "NEG" ->
      ok I_NEG
  | "NEQ" ->
      ok I_NEQ
  | "NIL" ->
      ok I_NIL
  | "NONE" ->
      ok I_NONE
  | "NOT" ->
      ok I_NOT
  | "NOW" ->
      ok I_NOW
  | "OR" ->
      ok I_OR
  | "PAIR" ->
      ok I_PAIR
  | "PUSH" ->
      ok I_PUSH
  | "RIGHT" ->
      ok I_RIGHT
  | "SIZE" ->
      ok I_SIZE
  | "SOME" ->
      ok I_SOME
  | "SOURCE" ->
      ok I_SOURCE
  | "SENDER" ->
      ok I_SENDER
  | "SELF" ->
      ok I_SELF
  | "SLICE" ->
      ok I_SLICE
  | "STEPS_TO_QUOTA" ->
      ok I_STEPS_TO_QUOTA
  | "SUB" ->
      ok I_SUB
  | "SWAP" ->
      ok I_SWAP
  | "TRANSFER_TOKENS" ->
      ok I_TRANSFER_TOKENS
  | "SET_DELEGATE" ->
      ok I_SET_DELEGATE
  | "UNIT" ->
      ok I_UNIT
  | "UPDATE" ->
      ok I_UPDATE
  | "XOR" ->
      ok I_XOR
  | "ITER" ->
      ok I_ITER
  | "LOOP_LEFT" ->
      ok I_LOOP_LEFT
  | "ADDRESS" ->
      ok I_ADDRESS
  | "CONTRACT" ->
      ok I_CONTRACT
  | "ISNAT" ->
      ok I_ISNAT
  | "CAST" ->
      ok I_CAST
  | "RENAME" ->
      ok I_RENAME
  | "DIG" ->
      ok I_DIG
  | "DUG" ->
      ok I_DUG
  | "bool" ->
      ok T_bool
  | "contract" ->
      ok T_contract
  | "int" ->
      ok T_int
  | "key" ->
      ok T_key
  | "key_hash" ->
      ok T_key_hash
  | "lambda" ->
      ok T_lambda
  | "list" ->
      ok T_list
  | "map" ->
      ok T_map
  | "big_map" ->
      ok T_big_map
  | "nat" ->
      ok T_nat
  | "option" ->
      ok T_option
  | "or" ->
      ok T_or
  | "pair" ->
      ok T_pair
  | "set" ->
      ok T_set
  | "signature" ->
      ok T_signature
  | "string" ->
      ok T_string
  | "bytes" ->
      ok T_bytes
  | "mutez" ->
      ok T_mutez
  | "timestamp" ->
      ok T_timestamp
  | "unit" ->
      ok T_unit
  | "operation" ->
      ok T_operation
  | "address" ->
      ok T_address
  | "chain_id" ->
      ok T_chain_id
  | n ->
      if valid_case n then error (Unknown_primitive_name n)
      else error (Invalid_case n)

let prims_of_strings expr =
  let rec convert = function
    | (Int _ | String _ | Bytes _) as expr ->
        ok expr
    | Prim (loc, prim, args, annot) ->
        Error_monad.record_trace
          (Invalid_primitive_name (expr, loc))
          (prim_of_string prim)
        >>? fun prim ->
        List.fold_left
          (fun acc arg ->
            acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args))
          (ok [])
          args
        >>? fun args -> ok (Prim (0, prim, List.rev args, annot))
    | Seq (_, args) ->
        List.fold_left
          (fun acc arg ->
            acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args))
          (ok [])
          args
        >>? fun args -> ok (Seq (0, List.rev args))
  in
  convert (root expr) >>? fun expr -> ok (strip_locations expr)

let strings_of_prims expr =
  let rec convert = function
    | (Int _ | String _ | Bytes _) as expr ->
        expr
    | Prim (_, prim, args, annot) ->
        let prim = string_of_prim prim in
        let args = List.map convert args in
        Prim (0, prim, args, annot)
    | Seq (_, args) ->
        let args = List.map convert args in
        Seq (0, args)
  in
  strip_locations (convert (root expr))

let prim_encoding =
  let open Data_encoding in
  def "michelson.v1.primitives"
  @@ string_enum
       [ (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("parameter", K_parameter);
         ("storage", K_storage);
         ("code", K_code);
         ("False", D_False);
         ("Elt", D_Elt);
         ("Left", D_Left);
         ("None", D_None);
         ("Pair", D_Pair);
         ("Right", D_Right);
         ("Some", D_Some);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("True", D_True);
         ("Unit", D_Unit);
         ("PACK", I_PACK);
         ("UNPACK", I_UNPACK);
         ("BLAKE2B", I_BLAKE2B);
         ("SHA256", I_SHA256);
         ("SHA512", I_SHA512);
         ("ABS", I_ABS);
         ("ADD", I_ADD);
         ("AMOUNT", I_AMOUNT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("AND", I_AND);
         ("BALANCE", I_BALANCE);
         ("CAR", I_CAR);
         ("CDR", I_CDR);
         ("CHECK_SIGNATURE", I_CHECK_SIGNATURE);
         ("COMPARE", I_COMPARE);
         ("CONCAT", I_CONCAT);
         ("CONS", I_CONS);
         ("CREATE_ACCOUNT", I_CREATE_ACCOUNT);
         ("CREATE_CONTRACT", I_CREATE_CONTRACT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT);
         ("DIP", I_DIP);
         ("DROP", I_DROP);
         ("DUP", I_DUP);
         ("EDIV", I_EDIV);
         ("EMPTY_MAP", I_EMPTY_MAP);
         ("EMPTY_SET", I_EMPTY_SET);
         ("EQ", I_EQ);
         ("EXEC", I_EXEC);
         ("FAILWITH", I_FAILWITH);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("GE", I_GE);
         ("GET", I_GET);
         ("GT", I_GT);
         ("HASH_KEY", I_HASH_KEY);
         ("IF", I_IF);
         ("IF_CONS", I_IF_CONS);
         ("IF_LEFT", I_IF_LEFT);
         ("IF_NONE", I_IF_NONE);
         ("INT", I_INT);
         ("LAMBDA", I_LAMBDA);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("LE", I_LE);
         ("LEFT", I_LEFT);
         ("LOOP", I_LOOP);
         ("LSL", I_LSL);
         ("LSR", I_LSR);
         ("LT", I_LT);
         ("MAP", I_MAP);
         ("MEM", I_MEM);
         ("MUL", I_MUL);
         ("NEG", I_NEG);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("NEQ", I_NEQ);
         ("NIL", I_NIL);
         ("NONE", I_NONE);
         ("NOT", I_NOT);
         ("NOW", I_NOW);
         ("OR", I_OR);
         ("PAIR", I_PAIR);
         ("PUSH", I_PUSH);
         ("RIGHT", I_RIGHT);
         ("SIZE", I_SIZE);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("SOME", I_SOME);
         ("SOURCE", I_SOURCE);
         ("SENDER", I_SENDER);
         ("SELF", I_SELF);
         ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA);
         ("SUB", I_SUB);
         ("SWAP", I_SWAP);
         ("TRANSFER_TOKENS", I_TRANSFER_TOKENS);
         ("SET_DELEGATE", I_SET_DELEGATE);
         ("UNIT", I_UNIT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("UPDATE", I_UPDATE);
         ("XOR", I_XOR);
         ("ITER", I_ITER);
         ("LOOP_LEFT", I_LOOP_LEFT);
         ("ADDRESS", I_ADDRESS);
         ("CONTRACT", I_CONTRACT);
         ("ISNAT", I_ISNAT);
         ("CAST", I_CAST);
         ("RENAME", I_RENAME);
         ("bool", T_bool);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("contract", T_contract);
         ("int", T_int);
         ("key", T_key);
         ("key_hash", T_key_hash);
         ("lambda", T_lambda);
         ("list", T_list);
         ("map", T_map);
         ("big_map", T_big_map);
         ("nat", T_nat);
         ("option", T_option);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("or", T_or);
         ("pair", T_pair);
         ("set", T_set);
         ("signature", T_signature);
         ("string", T_string);
         ("bytes", T_bytes);
         ("mutez", T_mutez);
         ("timestamp", T_timestamp);
         ("unit", T_unit);
         ("operation", T_operation);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("address", T_address);
         (* Alpha_002 addition *)
         ("SLICE", I_SLICE);
         (* Alpha_005 addition *)
         ("DIG", I_DIG);
         ("DUG", I_DUG);
         ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP);
         ("APPLY", I_APPLY);
         ("chain_id", T_chain_id);
         ("CHAIN_ID", I_CHAIN_ID)
         (* New instructions must be added here, for backward compatibility of the encoding. *)
        ]

let () =
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unknown_primitive_name"
    ~title:"Unknown primitive name"
    ~description:"In a script or data expression, a primitive was unknown."
    ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n)
    Data_encoding.(obj1 (req "wrong_primitive_name" string))
    (function Unknown_primitive_name got -> Some got | _ -> None)
    (fun got -> Unknown_primitive_name got) ;
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_name_case"
    ~title:"Invalid primitive name case"
    ~description:
      "In a script or data expression, a primitive name is neither uppercase, \
       lowercase or capitalized."
    ~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n)
    Data_encoding.(obj1 (req "wrong_primitive_name" string))
    (function Invalid_case name -> Some name | _ -> None)
    (fun name -> Invalid_case name) ;
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_name"
    ~title:"Invalid primitive name"
    ~description:
      "In a script or data expression, a primitive name is unknown or has a \
       wrong case."
    ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.")
    Data_encoding.(
      obj2
        (req
           "expression"
           (Micheline.canonical_encoding ~variant:"generic" string))
        (req "location" Micheline.canonical_location_encoding))
    (function
      | Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None)
    (fun (expr, loc) -> Invalid_primitive_name (expr, loc))
src/proto_alpha/lib_protocol/michelson_v1_primitives.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_environment_alpha__Environment.Micheline.

Inductive prim : Type :=
| K_parameter : prim
| K_storage : prim
| K_code : prim
| D_False : prim
| D_Elt : prim
| D_Left : prim
| D_None : prim
| D_Pair : prim
| D_Right : prim
| D_Some : prim
| D_True : prim
| D_Unit : prim
| I_PACK : prim
| I_UNPACK : prim
| I_BLAKE2B : prim
| I_SHA256 : prim
| I_SHA512 : prim
| I_ABS : prim
| I_ADD : prim
| I_AMOUNT : prim
| I_AND : prim
| I_BALANCE : prim
| I_CAR : prim
| I_CDR : prim
| I_CHAIN_ID : prim
| I_CHECK_SIGNATURE : prim
| I_COMPARE : prim
| I_CONCAT : prim
| I_CONS : prim
| I_CREATE_ACCOUNT : prim
| I_CREATE_CONTRACT : prim
| I_IMPLICIT_ACCOUNT : prim
| I_DIP : prim
| I_DROP : prim
| I_DUP : prim
| I_EDIV : prim
| I_EMPTY_BIG_MAP : prim
| I_EMPTY_MAP : prim
| I_EMPTY_SET : prim
| I_EQ : prim
| I_EXEC : prim
| I_APPLY : prim
| I_FAILWITH : prim
| I_GE : prim
| I_GET : prim
| I_GT : prim
| I_HASH_KEY : prim
| I_IF : prim
| I_IF_CONS : prim
| I_IF_LEFT : prim
| I_IF_NONE : prim
| I_INT : prim
| I_LAMBDA : prim
| I_LE : prim
| I_LEFT : prim
| I_LOOP : prim
| I_LSL : prim
| I_LSR : prim
| I_LT : prim
| I_MAP : prim
| I_MEM : prim
| I_MUL : prim
| I_NEG : prim
| I_NEQ : prim
| I_NIL : prim
| I_NONE : prim
| I_NOT : prim
| I_NOW : prim
| I_OR : prim
| I_PAIR : prim
| I_PUSH : prim
| I_RIGHT : prim
| I_SIZE : prim
| I_SOME : prim
| I_SOURCE : prim
| I_SENDER : prim
| I_SELF : prim
| I_SLICE : prim
| I_STEPS_TO_QUOTA : prim
| I_SUB : prim
| I_SWAP : prim
| I_TRANSFER_TOKENS : prim
| I_SET_DELEGATE : prim
| I_UNIT : prim
| I_UPDATE : prim
| I_XOR : prim
| I_ITER : prim
| I_LOOP_LEFT : prim
| I_ADDRESS : prim
| I_CONTRACT : prim
| I_ISNAT : prim
| I_CAST : prim
| I_RENAME : prim
| I_DIG : prim
| I_DUG : prim
| T_bool : prim
| T_contract : prim
| T_int : prim
| T_key : prim
| T_key_hash : prim
| T_lambda : prim
| T_list : prim
| T_map : prim
| T_big_map : prim
| T_nat : prim
| T_option : prim
| T_or : prim
| T_pair : prim
| T_set : prim
| T_signature : prim
| T_string : prim
| T_bytes : prim
| T_mutez : prim
| T_timestamp : prim
| T_unit : prim
| T_operation : prim
| T_address : prim
| T_chain_id : prim.

Definition valid_case (name : string) : bool :=
  let is_lower (function_parameter : ascii) : bool :=
    match function_parameter with
    |
      "_" % char |
        "a" % char |
          "b" % char |
            "c" % char |
              "d" % char |
                "e" % char |
                  "f" % char |
                    "g" % char |
                      "h" % char |
                        "i" % char |
                          "j" % char |
                            "k" % char |
                              "l" % char |
                                "m" % char |
                                  "n" % char |
                                    "o" % char |
                                      "p" % char |
                                        "q" % char |
                                          "r" % char |
                                            "s" % char |
                                              "t" % char |
                                                "u" % char |
                                                  "v" % char |
                                                    "w" % char |
                                                      "x" % char |
                                                        "y" % char | "z" % char
      => true
    | _ => false
    end in
  let is_upper (function_parameter : ascii) : bool :=
    match function_parameter with
    |
      "_" % char |
        "A" % char |
          "B" % char |
            "C" % char |
              "D" % char |
                "E" % char |
                  "F" % char |
                    "G" % char |
                      "H" % char |
                        "I" % char |
                          "J" % char |
                            "K" % char |
                              "L" % char |
                                "M" % char |
                                  "N" % char |
                                    "O" % char |
                                      "P" % char |
                                        "Q" % char |
                                          "R" % char |
                                            "S" % char |
                                              "T" % char |
                                                "U" % char |
                                                  "V" % char |
                                                    "W" % char |
                                                      "X" % char |
                                                        "Y" % char | "Z" % char
      => true
    | _ => false
    end in
  let fix for_all
    (a :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (b :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (f :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
      -> bool) : bool :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        a b)
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and (f a)
        (for_all
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus a 1)
          b f)) in
  let len := Tezos_protocol_environment_alpha__Environment.String.length name in
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
    (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_gt)
      len 0)
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
      (Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_gt)
        (Tezos_protocol_environment_alpha__Environment.String.get name 0)
        "_" % char)
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
          (is_upper
            (Tezos_protocol_environment_alpha__Environment.String.get name 0))
          (for_all 1
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
              len 1)
            (fun i =>
              is_upper
                (Tezos_protocol_environment_alpha__Environment.String.get name i))))
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
            (is_upper
              (Tezos_protocol_environment_alpha__Environment.String.get name 0))
            (for_all 1
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                len 1)
              (fun i =>
                is_lower
                  (Tezos_protocol_environment_alpha__Environment.String.get name
                    i))))
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
            (is_lower
              (Tezos_protocol_environment_alpha__Environment.String.get name 0))
            (for_all 1
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                len 1)
              (fun i =>
                is_lower
                  (Tezos_protocol_environment_alpha__Environment.String.get name
                    i))))))).

Definition string_of_prim (function_parameter : prim) : string :=
  match function_parameter with
  | K_parameter => "parameter" % string
  | K_storage => "storage" % string
  | K_code => "code" % string
  | D_False => "False" % string
  | D_Elt => "Elt" % string
  | D_Left => "Left" % string
  | D_None => "None" % string
  | D_Pair => "Pair" % string
  | D_Right => "Right" % string
  | D_Some => "Some" % string
  | D_True => "True" % string
  | D_Unit => "Unit" % string
  | I_PACK => "PACK" % string
  | I_UNPACK => "UNPACK" % string
  | I_BLAKE2B => "BLAKE2B" % string
  | I_SHA256 => "SHA256" % string
  | I_SHA512 => "SHA512" % string
  | I_ABS => "ABS" % string
  | I_ADD => "ADD" % string
  | I_AMOUNT => "AMOUNT" % string
  | I_AND => "AND" % string
  | I_BALANCE => "BALANCE" % string
  | I_CAR => "CAR" % string
  | I_CDR => "CDR" % string
  | I_CHAIN_ID => "CHAIN_ID" % string
  | I_CHECK_SIGNATURE => "CHECK_SIGNATURE" % string
  | I_COMPARE => "COMPARE" % string
  | I_CONCAT => "CONCAT" % string
  | I_CONS => "CONS" % string
  | I_CREATE_ACCOUNT => "CREATE_ACCOUNT" % string
  | I_CREATE_CONTRACT => "CREATE_CONTRACT" % string
  | I_IMPLICIT_ACCOUNT => "IMPLICIT_ACCOUNT" % string
  | I_DIP => "DIP" % string
  | I_DROP => "DROP" % string
  | I_DUP => "DUP" % string
  | I_EDIV => "EDIV" % string
  | I_EMPTY_BIG_MAP => "EMPTY_BIG_MAP" % string
  | I_EMPTY_MAP => "EMPTY_MAP" % string
  | I_EMPTY_SET => "EMPTY_SET" % string
  | I_EQ => "EQ" % string
  | I_EXEC => "EXEC" % string
  | I_APPLY => "APPLY" % string
  | I_FAILWITH => "FAILWITH" % string
  | I_GE => "GE" % string
  | I_GET => "GET" % string
  | I_GT => "GT" % string
  | I_HASH_KEY => "HASH_KEY" % string
  | I_IF => "IF" % string
  | I_IF_CONS => "IF_CONS" % string
  | I_IF_LEFT => "IF_LEFT" % string
  | I_IF_NONE => "IF_NONE" % string
  | I_INT => "INT" % string
  | I_LAMBDA => "LAMBDA" % string
  | I_LE => "LE" % string
  | I_LEFT => "LEFT" % string
  | I_LOOP => "LOOP" % string
  | I_LSL => "LSL" % string
  | I_LSR => "LSR" % string
  | I_LT => "LT" % string
  | I_MAP => "MAP" % string
  | I_MEM => "MEM" % string
  | I_MUL => "MUL" % string
  | I_NEG => "NEG" % string
  | I_NEQ => "NEQ" % string
  | I_NIL => "NIL" % string
  | I_NONE => "NONE" % string
  | I_NOT => "NOT" % string
  | I_NOW => "NOW" % string
  | I_OR => "OR" % string
  | I_PAIR => "PAIR" % string
  | I_PUSH => "PUSH" % string
  | I_RIGHT => "RIGHT" % string
  | I_SIZE => "SIZE" % string
  | I_SOME => "SOME" % string
  | I_SOURCE => "SOURCE" % string
  | I_SENDER => "SENDER" % string
  | I_SELF => "SELF" % string
  | I_SLICE => "SLICE" % string
  | I_STEPS_TO_QUOTA => "STEPS_TO_QUOTA" % string
  | I_SUB => "SUB" % string
  | I_SWAP => "SWAP" % string
  | I_TRANSFER_TOKENS => "TRANSFER_TOKENS" % string
  | I_SET_DELEGATE => "SET_DELEGATE" % string
  | I_UNIT => "UNIT" % string
  | I_UPDATE => "UPDATE" % string
  | I_XOR => "XOR" % string
  | I_ITER => "ITER" % string
  | I_LOOP_LEFT => "LOOP_LEFT" % string
  | I_ADDRESS => "ADDRESS" % string
  | I_CONTRACT => "CONTRACT" % string
  | I_ISNAT => "ISNAT" % string
  | I_CAST => "CAST" % string
  | I_RENAME => "RENAME" % string
  | I_DIG => "DIG" % string
  | I_DUG => "DUG" % string
  | T_bool => "bool" % string
  | T_contract => "contract" % string
  | T_int => "int" % string
  | T_key => "key" % string
  | T_key_hash => "key_hash" % string
  | T_lambda => "lambda" % string
  | T_list => "list" % string
  | T_map => "map" % string
  | T_big_map => "big_map" % string
  | T_nat => "nat" % string
  | T_option => "option" % string
  | T_or => "or" % string
  | T_pair => "pair" % string
  | T_set => "set" % string
  | T_signature => "signature" % string
  | T_string => "string" % string
  | T_bytes => "bytes" % string
  | T_mutez => "mutez" % string
  | T_timestamp => "timestamp" % string
  | T_unit => "unit" % string
  | T_operation => "operation" % string
  | T_address => "address" % string
  | T_chain_id => "chain_id" % string
  end.

Definition prim_of_string (function_parameter : string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult prim :=
  match function_parameter with
  | "parameter" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok K_parameter
  | "storage" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok K_storage
  | "code" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok K_code
  | "False" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_False
  | "Elt" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_Elt
  | "Left" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_Left
  | "None" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_None
  | "Pair" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_Pair
  | "Right" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_Right
  | "Some" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_Some
  | "True" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_True
  | "Unit" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok D_Unit
  | "PACK" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_PACK
  | "UNPACK" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_UNPACK
  | "BLAKE2B" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_BLAKE2B
  | "SHA256" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SHA256
  | "SHA512" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SHA512
  | "ABS" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_ABS
  | "ADD" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_ADD
  | "AMOUNT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_AMOUNT
  | "AND" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_AND
  | "BALANCE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_BALANCE
  | "CAR" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_CAR
  | "CDR" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_CDR
  | "CHAIN_ID" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_CHAIN_ID
  | "CHECK_SIGNATURE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      I_CHECK_SIGNATURE
  | "COMPARE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_COMPARE
  | "CONCAT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_CONCAT
  | "CONS" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_CONS
  | "CREATE_ACCOUNT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      I_CREATE_ACCOUNT
  | "CREATE_CONTRACT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      I_CREATE_CONTRACT
  | "IMPLICIT_ACCOUNT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      I_IMPLICIT_ACCOUNT
  | "DIP" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_DIP
  | "DROP" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_DROP
  | "DUP" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_DUP
  | "EDIV" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_EDIV
  | "EMPTY_BIG_MAP" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_EMPTY_BIG_MAP
  | "EMPTY_MAP" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_EMPTY_MAP
  | "EMPTY_SET" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_EMPTY_SET
  | "EQ" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_EQ
  | "EXEC" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_EXEC
  | "APPLY" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_APPLY
  | "FAILWITH" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_FAILWITH
  | "GE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_GE
  | "GET" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_GET
  | "GT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_GT
  | "HASH_KEY" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_HASH_KEY
  | "IF" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_IF
  | "IF_CONS" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_IF_CONS
  | "IF_LEFT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_IF_LEFT
  | "IF_NONE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_IF_NONE
  | "INT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_INT
  | "LAMBDA" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_LAMBDA
  | "LE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_LE
  | "LEFT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_LEFT
  | "LOOP" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_LOOP
  | "LSL" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_LSL
  | "LSR" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_LSR
  | "LT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_LT
  | "MAP" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_MAP
  | "MEM" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_MEM
  | "MUL" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_MUL
  | "NEG" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_NEG
  | "NEQ" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_NEQ
  | "NIL" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_NIL
  | "NONE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_NONE
  | "NOT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_NOT
  | "NOW" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_NOW
  | "OR" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_OR
  | "PAIR" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_PAIR
  | "PUSH" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_PUSH
  | "RIGHT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_RIGHT
  | "SIZE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SIZE
  | "SOME" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SOME
  | "SOURCE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SOURCE
  | "SENDER" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SENDER
  | "SELF" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SELF
  | "SLICE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SLICE
  | "STEPS_TO_QUOTA" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      I_STEPS_TO_QUOTA
  | "SUB" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SUB
  | "SWAP" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SWAP
  | "TRANSFER_TOKENS" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      I_TRANSFER_TOKENS
  | "SET_DELEGATE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_SET_DELEGATE
  | "UNIT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_UNIT
  | "UPDATE" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_UPDATE
  | "XOR" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_XOR
  | "ITER" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_ITER
  | "LOOP_LEFT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_LOOP_LEFT
  | "ADDRESS" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_ADDRESS
  | "CONTRACT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_CONTRACT
  | "ISNAT" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_ISNAT
  | "CAST" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_CAST
  | "RENAME" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_RENAME
  | "DIG" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_DIG
  | "DUG" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok I_DUG
  | "bool" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_bool
  | "contract" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_contract
  | "int" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_int
  | "key" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_key
  | "key_hash" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_key_hash
  | "lambda" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_lambda
  | "list" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_list
  | "map" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_map
  | "big_map" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_big_map
  | "nat" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_nat
  | "option" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_option
  | "or" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_or
  | "pair" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_pair
  | "set" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_set
  | "signature" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_signature
  | "string" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_string
  | "bytes" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_bytes
  | "mutez" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_mutez
  | "timestamp" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_timestamp
  | "unit" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_unit
  | "operation" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_operation
  | "address" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_address
  | "chain_id" % string =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok T_chain_id
  | n =>
    if valid_case n then
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Unknown_primitive_name n)
    else
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Invalid_case n)
  end.

Definition prims_of_strings
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim) :=
  let fix convert
    (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node
      Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location
      string)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Micheline.node
        Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location
        prim) :=
    match function_parameter with
    | (Int _ _ | String _ _ | Bytes _ _) as expr =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok expr
    | Prim loc prim args annot =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
          (Invalid_primitive_name expr loc) (prim_of_string prim))
        (fun prim =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (Tezos_protocol_environment_alpha__Environment.List.fold_left
              (fun acc =>
                fun arg =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                    acc
                    (fun args =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                        (convert arg)
                        (fun arg =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                            (cons arg args))))
              (Tezos_protocol_environment_alpha__Environment.Error_monad.ok [])
              args)
            (fun args =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                (Prim 0 prim
                  (Tezos_protocol_environment_alpha__Environment.List.rev args)
                  annot)))
    | Seq _ args =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_protocol_environment_alpha__Environment.List.fold_left
          (fun acc =>
            fun arg =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                acc
                (fun args =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                    (convert arg)
                    (fun arg =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                        (cons arg args))))
          (Tezos_protocol_environment_alpha__Environment.Error_monad.ok []) args)
        (fun args =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.ok
            (Seq 0 (Tezos_protocol_environment_alpha__Environment.List.rev args)))
    end in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (convert (Tezos_protocol_environment_alpha__Environment.Micheline.root expr))
    (fun expr =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
        (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
          expr)).

Definition strings_of_prims
  (expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim)
  : Tezos_protocol_environment_alpha__Environment.Micheline.canonical string :=
  let fix convert
    (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node Z prim)
    : Tezos_protocol_environment_alpha__Environment.Micheline.node Z string :=
    match function_parameter with
    | (Int _ _ | String _ _ | Bytes _ _) as expr => expr
    | Prim _ prim args annot =>
      let prim := string_of_prim prim in
      let args :=
        Tezos_protocol_environment_alpha__Environment.List.map convert args in
      Prim 0 prim args annot
    | Seq _ args =>
      let args :=
        Tezos_protocol_environment_alpha__Environment.List.map convert args in
      Seq 0 args
    end in
  Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
    (convert (Tezos_protocol_environment_alpha__Environment.Micheline.root expr)).

Definition prim_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding prim :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "michelson.v1.primitives" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.string_enum
      (cons ("parameter" % string, K_parameter)
        (cons ("storage" % string, K_storage)
          (cons ("code" % string, K_code)
            (cons ("False" % string, D_False)
              (cons ("Elt" % string, D_Elt)
                (cons ("Left" % string, D_Left)
                  (cons ("None" % string, D_None)
                    (cons ("Pair" % string, D_Pair)
                      (cons ("Right" % string, D_Right)
                        (cons ("Some" % string, D_Some)
                          (cons ("True" % string, D_True)
                            (cons ("Unit" % string, D_Unit)
                              (cons ("PACK" % string, I_PACK)
                                (cons ("UNPACK" % string, I_UNPACK)
                                  (cons ("BLAKE2B" % string, I_BLAKE2B)
                                    (cons ("SHA256" % string, I_SHA256)
                                      (cons ("SHA512" % string, I_SHA512)
                                        (cons ("ABS" % string, I_ABS)
                                          (cons ("ADD" % string, I_ADD)
                                            (cons ("AMOUNT" % string, I_AMOUNT)
                                              (cons ("AND" % string, I_AND)
                                                (cons
                                                  ("BALANCE" % string, I_BALANCE)
                                                  (cons ("CAR" % string, I_CAR)
                                                    (cons
                                                      ("CDR" % string, I_CDR)
                                                      (cons
                                                        ("CHECK_SIGNATURE" %
                                                          string,
                                                          I_CHECK_SIGNATURE)
                                                        (cons
                                                          ("COMPARE" % string,
                                                            I_COMPARE)
                                                          (cons
                                                            ("CONCAT" % string,
                                                              I_CONCAT)
                                                            (cons
                                                              ("CONS" % string,
                                                                I_CONS)
                                                              (cons
                                                                ("CREATE_ACCOUNT"
                                                                  % string,
                                                                  I_CREATE_ACCOUNT)
                                                                (cons
                                                                  ("CREATE_CONTRACT"
                                                                    % string,
                                                                    I_CREATE_CONTRACT)
                                                                  (cons
                                                                    ("IMPLICIT_ACCOUNT"
                                                                      % string,
                                                                      I_IMPLICIT_ACCOUNT)
                                                                    (cons
                                                                      ("DIP" %
                                                                        string,
                                                                        I_DIP)
                                                                      (cons
                                                                        ("DROP"
                                                                          %
                                                                          string,
                                                                          I_DROP)
                                                                        (cons
                                                                          ("DUP"
                                                                            %
                                                                            string,
                                                                            I_DUP)
                                                                          (cons
                                                                            ("EDIV"
                                                                              %
                                                                              string,
                                                                              I_EDIV)
                                                                            (cons
                                                                              ("EMPTY_MAP"
                                                                                %
                                                                                string,
                                                                                I_EMPTY_MAP)
                                                                              (cons
                                                                                ("EMPTY_SET"
                                                                                  %
                                                                                  string,
                                                                                  I_EMPTY_SET)
                                                                                (cons
                                                                                  ("EQ"
                                                                                    %
                                                                                    string,
                                                                                    I_EQ)
                                                                                  (cons
                                                                                    ("EXEC"
                                                                                      %
                                                                                      string,
                                                                                      I_EXEC)
                                                                                    (cons
                                                                                      ("FAILWITH"
                                                                                        %
                                                                                        string,
                                                                                        I_FAILWITH)
                                                                                      (cons
                                                                                        ("GE"
                                                                                          %
                                                                                          string,
                                                                                          I_GE)
                                                                                        (cons
                                                                                          ("GET"
                                                                                            %
                                                                                            string,
                                                                                            I_GET)
                                                                                          (cons
                                                                                            ("GT"
                                                                                              %
                                                                                              string,
                                                                                              I_GT)
                                                                                            (cons
                                                                                              ("HASH_KEY"
                                                                                                %
                                                                                                string,
                                                                                                I_HASH_KEY)
                                                                                              (cons
                                                                                                ("IF"
                                                                                                  %
                                                                                                  string,
                                                                                                  I_IF)
                                                                                                (cons
                                                                                                  ("IF_CONS"
                                                                                                    %
                                                                                                    string,
                                                                                                    I_IF_CONS)
                                                                                                  (cons
                                                                                                    ("IF_LEFT"
                                                                                                      %
                                                                                                      string,
                                                                                                      I_IF_LEFT)
                                                                                                    (cons
                                                                                                      ("IF_NONE"
                                                                                                        %
                                                                                                        string,
                                                                                                        I_IF_NONE)
                                                                                                      (cons
                                                                                                        ("INT"
                                                                                                          %
                                                                                                          string,
                                                                                                          I_INT)
                                                                                                        (cons
                                                                                                          ("LAMBDA"
                                                                                                            %
                                                                                                            string,
                                                                                                            I_LAMBDA)
                                                                                                          (cons
                                                                                                            ("LE"
                                                                                                              %
                                                                                                              string,
                                                                                                              I_LE)
                                                                                                            (cons
                                                                                                              ("LEFT"
                                                                                                                %
                                                                                                                string,
                                                                                                                I_LEFT)
                                                                                                              (cons
                                                                                                                ("LOOP"
                                                                                                                  %
                                                                                                                  string,
                                                                                                                  I_LOOP)
                                                                                                                (cons
                                                                                                                  ("LSL"
                                                                                                                    %
                                                                                                                    string,
                                                                                                                    I_LSL)
                                                                                                                  (cons
                                                                                                                    ("LSR"
                                                                                                                      %
                                                                                                                      string,
                                                                                                                      I_LSR)
                                                                                                                    (cons
                                                                                                                      ("LT"
                                                                                                                        %
                                                                                                                        string,
                                                                                                                        I_LT)
                                                                                                                      (cons
                                                                                                                        ("MAP"
                                                                                                                          %
                                                                                                                          string,
                                                                                                                          I_MAP)
                                                                                                                        (cons
                                                                                                                          ("MEM"
                                                                                                                            %
                                                                                                                            string,
                                                                                                                            I_MEM)
                                                                                                                          (cons
                                                                                                                            ("MUL"
                                                                                                                              %
                                                                                                                              string,
                                                                                                                              I_MUL)
                                                                                                                            (cons
                                                                                                                              ("NEG"
                                                                                                                                %
                                                                                                                                string,
                                                                                                                                I_NEG)
                                                                                                                              (cons
                                                                                                                                ("NEQ"
                                                                                                                                  %
                                                                                                                                  string,
                                                                                                                                  I_NEQ)
                                                                                                                                (cons
                                                                                                                                  ("NIL"
                                                                                                                                    %
                                                                                                                                    string,
                                                                                                                                    I_NIL)
                                                                                                                                  (cons
                                                                                                                                    ("NONE"
                                                                                                                                      %
                                                                                                                                      string,
                                                                                                                                      I_NONE)
                                                                                                                                    (cons
                                                                                                                                      ("NOT"
                                                                                                                                        %
                                                                                                                                        string,
                                                                                                                                        I_NOT)
                                                                                                                                      (cons
                                                                                                                                        ("NOW"
                                                                                                                                          %
                                                                                                                                          string,
                                                                                                                                          I_NOW)
                                                                                                                                        (cons
                                                                                                                                          ("OR"
                                                                                                                                            %
                                                                                                                                            string,
                                                                                                                                            I_OR)
                                                                                                                                          (cons
                                                                                                                                            ("PAIR"
                                                                                                                                              %
                                                                                                                                              string,
                                                                                                                                              I_PAIR)
                                                                                                                                            (cons
                                                                                                                                              ("PUSH"
                                                                                                                                                %
                                                                                                                                                string,
                                                                                                                                                I_PUSH)
                                                                                                                                              (cons
                                                                                                                                                ("RIGHT"
                                                                                                                                                  %
                                                                                                                                                  string,
                                                                                                                                                  I_RIGHT)
                                                                                                                                                (cons
                                                                                                                                                  ("SIZE"
                                                                                                                                                    %
                                                                                                                                                    string,
                                                                                                                                                    I_SIZE)
                                                                                                                                                  (cons
                                                                                                                                                    ("SOME"
                                                                                                                                                      %
                                                                                                                                                      string,
                                                                                                                                                      I_SOME)
                                                                                                                                                    (cons
                                                                                                                                                      ("SOURCE"
                                                                                                                                                        %
                                                                                                                                                        string,
                                                                                                                                                        I_SOURCE)
                                                                                                                                                      (cons
                                                                                                                                                        ("SENDER"
                                                                                                                                                          %
                                                                                                                                                          string,
                                                                                                                                                          I_SENDER)
                                                                                                                                                        (cons
                                                                                                                                                          ("SELF"
                                                                                                                                                            %
                                                                                                                                                            string,
                                                                                                                                                            I_SELF)
                                                                                                                                                          (cons
                                                                                                                                                            ("STEPS_TO_QUOTA"
                                                                                                                                                              %
                                                                                                                                                              string,
                                                                                                                                                              I_STEPS_TO_QUOTA)
                                                                                                                                                            (cons
                                                                                                                                                              ("SUB"
                                                                                                                                                                %
                                                                                                                                                                string,
                                                                                                                                                                I_SUB)
                                                                                                                                                              (cons
                                                                                                                                                                ("SWAP"
                                                                                                                                                                  %
                                                                                                                                                                  string,
                                                                                                                                                                  I_SWAP)
                                                                                                                                                                (cons
                                                                                                                                                                  ("TRANSFER_TOKENS"
                                                                                                                                                                    %
                                                                                                                                                                    string,
                                                                                                                                                                    I_TRANSFER_TOKENS)
                                                                                                                                                                  (cons
                                                                                                                                                                    ("SET_DELEGATE"
                                                                                                                                                                      %
                                                                                                                                                                      string,
                                                                                                                                                                      I_SET_DELEGATE)
                                                                                                                                                                    (cons
                                                                                                                                                                      ("UNIT"
                                                                                                                                                                        %
                                                                                                                                                                        string,
                                                                                                                                                                        I_UNIT)
                                                                                                                                                                      (cons
                                                                                                                                                                        ("UPDATE"
                                                                                                                                                                          %
                                                                                                                                                                          string,
                                                                                                                                                                          I_UPDATE)
                                                                                                                                                                        (cons
                                                                                                                                                                          ("XOR"
                                                                                                                                                                            %
                                                                                                                                                                            string,
                                                                                                                                                                            I_XOR)
                                                                                                                                                                          (cons
                                                                                                                                                                            ("ITER"
                                                                                                                                                                              %
                                                                                                                                                                              string,
                                                                                                                                                                              I_ITER)
                                                                                                                                                                            (cons
                                                                                                                                                                              ("LOOP_LEFT"
                                                                                                                                                                                %
                                                                                                                                                                                string,
                                                                                                                                                                                I_LOOP_LEFT)
                                                                                                                                                                              (cons
                                                                                                                                                                                ("ADDRESS"
                                                                                                                                                                                  %
                                                                                                                                                                                  string,
                                                                                                                                                                                  I_ADDRESS)
                                                                                                                                                                                (cons
                                                                                                                                                                                  ("CONTRACT"
                                                                                                                                                                                    %
                                                                                                                                                                                    string,
                                                                                                                                                                                    I_CONTRACT)
                                                                                                                                                                                  (cons
                                                                                                                                                                                    ("ISNAT"
                                                                                                                                                                                      %
                                                                                                                                                                                      string,
                                                                                                                                                                                      I_ISNAT)
                                                                                                                                                                                    (cons
                                                                                                                                                                                      ("CAST"
                                                                                                                                                                                        %
                                                                                                                                                                                        string,
                                                                                                                                                                                        I_CAST)
                                                                                                                                                                                      (cons
                                                                                                                                                                                        ("RENAME"
                                                                                                                                                                                          %
                                                                                                                                                                                          string,
                                                                                                                                                                                          I_RENAME)
                                                                                                                                                                                        (cons
                                                                                                                                                                                          ("bool"
                                                                                                                                                                                            %
                                                                                                                                                                                            string,
                                                                                                                                                                                            T_bool)
                                                                                                                                                                                          (cons
                                                                                                                                                                                            ("contract"
                                                                                                                                                                                              %
                                                                                                                                                                                              string,
                                                                                                                                                                                              T_contract)
                                                                                                                                                                                            (cons
                                                                                                                                                                                              ("int"
                                                                                                                                                                                                %
                                                                                                                                                                                                string,
                                                                                                                                                                                                T_int)
                                                                                                                                                                                              (cons
                                                                                                                                                                                                ("key"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  string,
                                                                                                                                                                                                  T_key)
                                                                                                                                                                                                (cons
                                                                                                                                                                                                  ("key_hash"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string,
                                                                                                                                                                                                    T_key_hash)
                                                                                                                                                                                                  (cons
                                                                                                                                                                                                    ("lambda"
                                                                                                                                                                                                      %
                                                                                                                                                                                                      string,
                                                                                                                                                                                                      T_lambda)
                                                                                                                                                                                                    (cons
                                                                                                                                                                                                      ("list"
                                                                                                                                                                                                        %
                                                                                                                                                                                                        string,
                                                                                                                                                                                                        T_list)
                                                                                                                                                                                                      (cons
                                                                                                                                                                                                        ("map"
                                                                                                                                                                                                          %
                                                                                                                                                                                                          string,
                                                                                                                                                                                                          T_map)
                                                                                                                                                                                                        (cons
                                                                                                                                                                                                          ("big_map"
                                                                                                                                                                                                            %
                                                                                                                                                                                                            string,
                                                                                                                                                                                                            T_big_map)
                                                                                                                                                                                                          (cons
                                                                                                                                                                                                            ("nat"
                                                                                                                                                                                                              %
                                                                                                                                                                                                              string,
                                                                                                                                                                                                              T_nat)
                                                                                                                                                                                                            (cons
                                                                                                                                                                                                              ("option"
                                                                                                                                                                                                                %
                                                                                                                                                                                                                string,
                                                                                                                                                                                                                T_option)
                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                ("or"
                                                                                                                                                                                                                  %
                                                                                                                                                                                                                  string,
                                                                                                                                                                                                                  T_or)
                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                  ("pair"
                                                                                                                                                                                                                    %
                                                                                                                                                                                                                    string,
                                                                                                                                                                                                                    T_pair)
                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                    ("set"
                                                                                                                                                                                                                      %
                                                                                                                                                                                                                      string,
                                                                                                                                                                                                                      T_set)
                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                      ("signature"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string,
                                                                                                                                                                                                                        T_signature)
                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                        ("string"
                                                                                                                                                                                                                          %
                                                                                                                                                                                                                          string,
                                                                                                                                                                                                                          T_string)
                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                          ("bytes"
                                                                                                                                                                                                                            %
                                                                                                                                                                                                                            string,
                                                                                                                                                                                                                            T_bytes)
                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                            ("mutez"
                                                                                                                                                                                                                              %
                                                                                                                                                                                                                              string,
                                                                                                                                                                                                                              T_mutez)
                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                              ("timestamp"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string,
                                                                                                                                                                                                                                T_timestamp)
                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                ("unit"
                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                  string,
                                                                                                                                                                                                                                  T_unit)
                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                  ("operation"
                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                    string,
                                                                                                                                                                                                                                    T_operation)
                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                    ("address"
                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                      string,
                                                                                                                                                                                                                                      T_address)
                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                      ("SLICE"
                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                        string,
                                                                                                                                                                                                                                        I_SLICE)
                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                        ("DIG"
                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                          string,
                                                                                                                                                                                                                                          I_DIG)
                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                          ("DUG"
                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                            string,
                                                                                                                                                                                                                                            I_DUG)
                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                            ("EMPTY_BIG_MAP"
                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                              string,
                                                                                                                                                                                                                                              I_EMPTY_BIG_MAP)
                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                              ("APPLY"
                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                string,
                                                                                                                                                                                                                                                I_APPLY)
                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                ("chain_id"
                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                  string,
                                                                                                                                                                                                                                                  T_chain_id)
                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                  ("CHAIN_ID"
                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                    string,
                                                                                                                                                                                                                                                    I_CHAIN_ID)
                                                                                                                                                                                                                                                  []))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).
src/proto_alpha/lib_protocol/michelson_v1_primitives.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Unknown_primitive_name of string (* `Permanent *)

type error += Invalid_case of string (* `Permanent *)

type error +=
  | Invalid_primitive_name of
      string Micheline.canonical * Micheline.canonical_location

(* `Permanent *)

type prim =
  | K_parameter
  | K_storage
  | K_code
  | D_False
  | D_Elt
  | D_Left
  | D_None
  | D_Pair
  | D_Right
  | D_Some
  | D_True
  | D_Unit
  | I_PACK
  | I_UNPACK
  | I_BLAKE2B
  | I_SHA256
  | I_SHA512
  | I_ABS
  | I_ADD
  | I_AMOUNT
  | I_AND
  | I_BALANCE
  | I_CAR
  | I_CDR
  | I_CHAIN_ID
  | I_CHECK_SIGNATURE
  | I_COMPARE
  | I_CONCAT
  | I_CONS
  | I_CREATE_ACCOUNT
  | I_CREATE_CONTRACT
  | I_IMPLICIT_ACCOUNT
  | I_DIP
  | I_DROP
  | I_DUP
  | I_EDIV
  | I_EMPTY_BIG_MAP
  | I_EMPTY_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | I_APPLY
  | I_FAILWITH
  | I_GE
  | I_GET
  | I_GT
  | I_HASH_KEY
  | I_IF
  | I_IF_CONS
  | I_IF_LEFT
  | I_IF_NONE
  | I_INT
  | I_LAMBDA
  | I_LE
  | I_LEFT
  | I_LOOP
  | I_LSL
  | I_LSR
  | I_LT
  | I_MAP
  | I_MEM
  | I_MUL
  | I_NEG
  | I_NEQ
  | I_NIL
  | I_NONE
  | I_NOT
  | I_NOW
  | I_OR
  | I_PAIR
  | I_PUSH
  | I_RIGHT
  | I_SIZE
  | I_SOME
  | I_SOURCE
  | I_SENDER
  | I_SELF
  | I_SLICE
  | I_STEPS_TO_QUOTA
  | I_SUB
  | I_SWAP
  | I_TRANSFER_TOKENS
  | I_SET_DELEGATE
  | I_UNIT
  | I_UPDATE
  | I_XOR
  | I_ITER
  | I_LOOP_LEFT
  | I_ADDRESS
  | I_CONTRACT
  | I_ISNAT
  | I_CAST
  | I_RENAME
  | I_DIG
  | I_DUG
  | T_bool
  | T_contract
  | T_int
  | T_key
  | T_key_hash
  | T_lambda
  | T_list
  | T_map
  | T_big_map
  | T_nat
  | T_option
  | T_or
  | T_pair
  | T_set
  | T_signature
  | T_string
  | T_bytes
  | T_mutez
  | T_timestamp
  | T_unit
  | T_operation
  | T_address
  | T_chain_id

val prim_encoding : prim Data_encoding.encoding

val string_of_prim : prim -> string

val prim_of_string : string -> prim tzresult

val prims_of_strings :
  string Micheline.canonical -> prim Micheline.canonical tzresult

val strings_of_prims : prim Micheline.canonical -> string Micheline.canonical
src/proto_alpha/lib_protocol/michelson_v1_primitives.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

extensible_type

extensible_type

Inductive prim : Type :=
| K_parameter : prim
| K_storage : prim
| K_code : prim
| D_False : prim
| D_Elt : prim
| D_Left : prim
| D_None : prim
| D_Pair : prim
| D_Right : prim
| D_Some : prim
| D_True : prim
| D_Unit : prim
| I_PACK : prim
| I_UNPACK : prim
| I_BLAKE2B : prim
| I_SHA256 : prim
| I_SHA512 : prim
| I_ABS : prim
| I_ADD : prim
| I_AMOUNT : prim
| I_AND : prim
| I_BALANCE : prim
| I_CAR : prim
| I_CDR : prim
| I_CHAIN_ID : prim
| I_CHECK_SIGNATURE : prim
| I_COMPARE : prim
| I_CONCAT : prim
| I_CONS : prim
| I_CREATE_ACCOUNT : prim
| I_CREATE_CONTRACT : prim
| I_IMPLICIT_ACCOUNT : prim
| I_DIP : prim
| I_DROP : prim
| I_DUP : prim
| I_EDIV : prim
| I_EMPTY_BIG_MAP : prim
| I_EMPTY_MAP : prim
| I_EMPTY_SET : prim
| I_EQ : prim
| I_EXEC : prim
| I_APPLY : prim
| I_FAILWITH : prim
| I_GE : prim
| I_GET : prim
| I_GT : prim
| I_HASH_KEY : prim
| I_IF : prim
| I_IF_CONS : prim
| I_IF_LEFT : prim
| I_IF_NONE : prim
| I_INT : prim
| I_LAMBDA : prim
| I_LE : prim
| I_LEFT : prim
| I_LOOP : prim
| I_LSL : prim
| I_LSR : prim
| I_LT : prim
| I_MAP : prim
| I_MEM : prim
| I_MUL : prim
| I_NEG : prim
| I_NEQ : prim
| I_NIL : prim
| I_NONE : prim
| I_NOT : prim
| I_NOW : prim
| I_OR : prim
| I_PAIR : prim
| I_PUSH : prim
| I_RIGHT : prim
| I_SIZE : prim
| I_SOME : prim
| I_SOURCE : prim
| I_SENDER : prim
| I_SELF : prim
| I_SLICE : prim
| I_STEPS_TO_QUOTA : prim
| I_SUB : prim
| I_SWAP : prim
| I_TRANSFER_TOKENS : prim
| I_SET_DELEGATE : prim
| I_UNIT : prim
| I_UPDATE : prim
| I_XOR : prim
| I_ITER : prim
| I_LOOP_LEFT : prim
| I_ADDRESS : prim
| I_CONTRACT : prim
| I_ISNAT : prim
| I_CAST : prim
| I_RENAME : prim
| I_DIG : prim
| I_DUG : prim
| T_bool : prim
| T_contract : prim
| T_int : prim
| T_key : prim
| T_key_hash : prim
| T_lambda : prim
| T_list : prim
| T_map : prim
| T_big_map : prim
| T_nat : prim
| T_option : prim
| T_or : prim
| T_pair : prim
| T_set : prim
| T_signature : prim
| T_string : prim
| T_bytes : prim
| T_mutez : prim
| T_timestamp : prim
| T_unit : prim
| T_operation : prim
| T_address : prim
| T_chain_id : prim.

Parameter prim_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding prim.

Parameter string_of_prim : prim -> string.

Parameter prim_of_string :
string ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult prim.

Parameter prims_of_strings :
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical string) ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim).

Parameter strings_of_prims :
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim) ->
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical string.
src/proto_alpha/lib_protocol/misc.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a lazyt = unit -> 'a

type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt

type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t

let rec ( --> ) i j =
  (* [i; i+1; ...; j] *)
  if Compare.Int.(i > j) then [] else i :: (succ i --> j)

let rec ( ---> ) i j =
  (* [i; i+1; ...; j] *)
  if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j)

let split delim ?(limit = max_int) path =
  let l = String.length path in
  let rec do_slashes acc limit i =
    if Compare.Int.(i >= l) then List.rev acc
    else if Compare.Char.(path.[i] = delim) then do_slashes acc limit (i + 1)
    else do_split acc limit i
  and do_split acc limit i =
    if Compare.Int.(limit <= 0) then
      if Compare.Int.(i = l) then List.rev acc
      else List.rev (String.sub path i (l - i) :: acc)
    else do_component acc (pred limit) i i
  and do_component acc limit i j =
    if Compare.Int.(j >= l) then
      if Compare.Int.(i = j) then List.rev acc
      else List.rev (String.sub path i (j - i) :: acc)
    else if Compare.Char.(path.[j] = delim) then
      do_slashes (String.sub path i (j - i) :: acc) limit j
    else do_component acc limit i (j + 1)
  in
  if Compare.Int.(limit > 0) then do_slashes [] limit 0 else [path]

let pp_print_paragraph ppf description =
  Format.fprintf
    ppf
    "@[%a@]"
    Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string)
    (split ' ' description)

let take n l =
  let rec loop acc n = function
    | xs when Compare.Int.(n <= 0) ->
        Some (List.rev acc, xs)
    | [] ->
        None
    | x :: xs ->
        loop (x :: acc) (n - 1) xs
  in
  loop [] n l

let remove_prefix ~prefix s =
  let x = String.length prefix in
  let n = String.length s in
  if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then
    Some (String.sub s x (n - x))
  else None

let rec remove_elem_from_list nb = function
  | [] ->
      []
  | l when Compare.Int.(nb <= 0) ->
      l
  | _ :: tl ->
      remove_elem_from_list (nb - 1) tl
src/proto_alpha/lib_protocol/misc.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition lazyt (a : Type) := unit -> a.

Inductive lazy_list_t (a : Type) : Type :=
| LCons : a ->
  (lazyt
    (Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (lazy_list_t a)))) -> lazy_list_t a.

Arguments LCons {_}.

Definition lazy_list (a : Type) :=
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (lazy_list_t a)).

Fixpoint op_minus_minus_gt
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (j :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : list
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      i j then
    []
  else
    cons i
      (op_minus_minus_gt
        (Tezos_protocol_environment_alpha__Environment.Pervasives.succ i) j).

Fixpoint op_minus_minus_minus_gt
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (j :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : list
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      i j then
    []
  else
    cons i
      (op_minus_minus_minus_gt
        (Tezos_protocol_environment_alpha__Environment.Int32.succ i) j).

Definition split
  (delim :
    Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (op_star_o_p_t_star :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : string -> list string :=
  let limit :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_protocol_environment_alpha__Environment.Pervasives.max_int
    end in
  fun path =>
    let l := Tezos_protocol_environment_alpha__Environment.String.length path in
    let fix do_slashes
      (acc : list string) (limit :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (i :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : list string :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
          i l then
        Tezos_protocol_environment_alpha__Environment.List.rev acc
      else
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Tezos_protocol_environment_alpha__Environment.String.get path i)
            delim then
          do_slashes acc limit
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus i
              1)
        else
          do_split acc limit i
    with do_split
      (acc : list string) (limit :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (i :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : list string :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
          limit 0 then
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            i l then
          Tezos_protocol_environment_alpha__Environment.List.rev acc
        else
          Tezos_protocol_environment_alpha__Environment.List.rev
            (cons
              (Tezos_protocol_environment_alpha__Environment.String.sub path i
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                  l i)) acc)
      else
        do_component acc
          (Tezos_protocol_environment_alpha__Environment.Pervasives.pred limit)
          i i
    with do_component
      (acc : list string) (limit :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (i :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (j :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : list string :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
          j l then
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            i j then
          Tezos_protocol_environment_alpha__Environment.List.rev acc
        else
          Tezos_protocol_environment_alpha__Environment.List.rev
            (cons
              (Tezos_protocol_environment_alpha__Environment.String.sub path i
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                  j i)) acc)
      else
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Tezos_protocol_environment_alpha__Environment.String.get path j)
            delim then
          do_slashes
            (cons
              (Tezos_protocol_environment_alpha__Environment.String.sub path i
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                  j i)) acc) limit j
        else
          do_component acc limit i
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus j
              1) in
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        limit 0 then
      do_slashes [] limit 0
    else
      cons path [].

Definition pp_print_paragraph
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (description : string) : unit :=
  Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format))) "@[%a@]" % string)
    (Tezos_protocol_environment_alpha__Environment.Format.pp_print_list
      (Some Tezos_protocol_environment_alpha__Environment.Format.pp_print_space)
      Tezos_protocol_environment_alpha__Environment.Format.pp_print_string)
    (split " " % char None description).

Definition take {A : Type}
  (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (l : list A) : option ((list A) * (list A)) :=
  let fix loop {B : Type}
    (acc : list B) (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (function_parameter : list B) : option ((list B) * (list B)) :=
    match function_parameter with
    | xs =>
      Some ((Tezos_protocol_environment_alpha__Environment.List.rev acc), xs)
    | [] => None
    | cons x xs =>
      loop (cons x acc)
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus n 1)
        xs
    end in
  loop [] n l.

Definition remove_prefix
  (prefix :
    Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (s : string) : option string :=
  let x := Tezos_protocol_environment_alpha__Environment.String.length prefix in
  let n := Tezos_protocol_environment_alpha__Environment.String.length s in
  if
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
        n x)
      (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        (Tezos_protocol_environment_alpha__Environment.String.sub s 0 x) prefix)
    then
    Some
      (Tezos_protocol_environment_alpha__Environment.String.sub s x
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus n x))
  else
    None.

Fixpoint remove_elem_from_list {A : Type}
  (nb :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (function_parameter : list A) : list A :=
  match function_parameter with
  | [] => []
  | l => l
  | cons _ tl =>
    remove_elem_from_list
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus nb 1)
      tl
  end.
src/proto_alpha/lib_protocol/misc.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {2 Helper functions} *)

type 'a lazyt = unit -> 'a

type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt

type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t

(** Include bounds *)
val ( --> ) : int -> int -> int list

val ( ---> ) : Int32.t -> Int32.t -> Int32.t list

val pp_print_paragraph : Format.formatter -> string -> unit

val take : int -> 'a list -> ('a list * 'a list) option

(** Some (input with [prefix] removed), if string has [prefix], else [None] *)
val remove_prefix : prefix:string -> string -> string option

(** [remove nb list] remove the first [nb] elements from the list [list]. *)
val remove_elem_from_list : int -> 'a list -> 'a list
src/proto_alpha/lib_protocol/misc.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition lazyt (a : Type) := unit -> a.

Inductive lazy_list_t (a : Type) : Type :=
| LCons : a ->
  (lazyt
    (Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (lazy_list_t a)))) -> lazy_list_t a.

Arguments LCons {_}.

Definition lazy_list (a : Type) :=
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (lazy_list_t a)).

Parameter op_minus_minus_gt : Z -> Z -> list Z.

Parameter op_minus_minus_minus_gt :
Tezos_protocol_environment_alpha__Environment.Int32.t ->
  Tezos_protocol_environment_alpha__Environment.Int32.t ->
    list Tezos_protocol_environment_alpha__Environment.Int32.t.

Parameter pp_print_paragraph :
Tezos_protocol_environment_alpha__Environment.Format.formatter -> string -> unit.

Parameter take : forall {a : Type},
Z -> (list a) -> option ((list a) * (list a)).

Parameter remove_prefix : string -> string -> option string.

Parameter remove_elem_from_list : forall {a : Type}, Z -> (list a) -> list a.
src/proto_alpha/lib_protocol/nonce_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* 32 *)
let nonce_hash = "\069\220\169" (* nce(53) *)

include Blake2B.Make
          (Base58)
          (struct
            let name = "cycle_nonce"

            let title = "A nonce hash"

            let b58check_prefix = nonce_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "nce" 53
src/proto_alpha/lib_protocol/nonce_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition nonce_hash : string := "EÜ©" % string.
src/proto_alpha/lib_protocol/nonce_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Seed_repr.nonce

type nonce = t

let encoding = Seed_repr.nonce_encoding

type error +=
  | Too_late_revelation
  | Too_early_revelation
  | Previously_revealed_nonce
  | Unexpected_nonce

let () =
  register_error_kind
    `Branch
    ~id:"nonce.too_late_revelation"
    ~title:"Too late nonce revelation"
    ~description:"Nonce revelation happens too late"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "This nonce cannot be revealed anymore.")
    Data_encoding.unit
    (function Too_late_revelation -> Some () | _ -> None)
    (fun () -> Too_late_revelation) ;
  register_error_kind
    `Temporary
    ~id:"nonce.too_early_revelation"
    ~title:"Too early nonce revelation"
    ~description:"Nonce revelation happens before cycle end"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "This nonce should not yet be revealed")
    Data_encoding.unit
    (function Too_early_revelation -> Some () | _ -> None)
    (fun () -> Too_early_revelation) ;
  register_error_kind
    `Branch
    ~id:"nonce.previously_revealed"
    ~title:"Previously revealed nonce"
    ~description:"Duplicated revelation for a nonce."
    ~pp:(fun ppf () -> Format.fprintf ppf "This nonce was previously revealed")
    Data_encoding.unit
    (function Previously_revealed_nonce -> Some () | _ -> None)
    (fun () -> Previously_revealed_nonce) ;
  register_error_kind
    `Branch
    ~id:"nonce.unexpected"
    ~title:"Unexpected nonce"
    ~description:
      "The provided nonce is inconsistent with the committed nonce hash."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "This nonce revelation is invalid (inconsistent with the committed \
         hash)")
    Data_encoding.unit
    (function Unexpected_nonce -> Some () | _ -> None)
    (fun () -> Unexpected_nonce)

(* checks that the level of a revelation is not too early or too late wrt to the
   current context and that a nonce has not been already revealed for that level *)
let get_unrevealed ctxt level =
  let cur_level = Level_storage.current ctxt in
  match Cycle_repr.pred cur_level.cycle with
  | None ->
      fail Too_early_revelation (* no revelations during cycle 0 *)
  | Some revealed_cycle -> (
      if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then
        fail Too_early_revelation
      else if Cycle_repr.(level.Level_repr.cycle < revealed_cycle) then
        fail Too_late_revelation
      else
        Storage.Seed.Nonce.get ctxt level
        >>=? function
        | Revealed _ ->
            fail Previously_revealed_nonce
        | Unrevealed status ->
            return status )

let record_hash ctxt unrevealed =
  let level = Level_storage.current ctxt in
  Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed)

let reveal ctxt level nonce =
  get_unrevealed ctxt level
  >>=? fun unrevealed ->
  fail_unless
    (Seed_repr.check_hash nonce unrevealed.nonce_hash)
    Unexpected_nonce
  >>=? fun () ->
  Storage.Seed.Nonce.set ctxt level (Revealed nonce)
  >>=? fun ctxt -> return ctxt

type unrevealed = Storage.Seed.unrevealed_nonce = {
  nonce_hash : Nonce_hash.t;
  delegate : Signature.Public_key_hash.t;
  rewards : Tez_repr.t;
  fees : Tez_repr.t;
}

type status = Storage.Seed.nonce_status =
  | Unrevealed of unrevealed
  | Revealed of Seed_repr.nonce

let get = Storage.Seed.Nonce.get

let of_bytes = Seed_repr.make_nonce

let hash = Seed_repr.hash

let check_hash = Seed_repr.check_hash
src/proto_alpha/lib_protocol/nonce_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_raw_protocol_alpha.Seed_repr.nonce.

Definition nonce := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_raw_protocol_alpha.Seed_repr.nonce :=
  Tezos_raw_protocol_alpha.Seed_repr.nonce_encoding.

Definition get_unrevealed
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (level : Tezos_raw_protocol_alpha.Level_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce) :=
  let cur_level := Tezos_raw_protocol_alpha.Level_storage.current ctxt in
  match Tezos_raw_protocol_alpha.Cycle_repr.pred (cycle cur_level) with
  | None =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
      Too_early_revelation
  | Some revealed_cycle =>
    if
      Tezos_raw_protocol_alpha.Cycle_repr.op_lt revealed_cycle
        (Level_repr.cycle level) then
      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
        Too_early_revelation
    else
      if
        Tezos_raw_protocol_alpha.Cycle_repr.op_lt (Level_repr.cycle level)
          revealed_cycle then
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          Too_late_revelation
      else
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Seed.Nonce.get ctxt level)
          (fun function_parameter =>
            match function_parameter with
            | Revealed _ =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                Previously_revealed_nonce
            | Unrevealed status =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                status
            end)
  end.

Definition record_hash
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (unrevealed : Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let level := Tezos_raw_protocol_alpha.Level_storage.current ctxt in
  Tezos_raw_protocol_alpha.Storage.Seed.Nonce.init ctxt level
    (Unrevealed unrevealed).

Definition reveal
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (level : Tezos_raw_protocol_alpha.Level_repr.t)
  (nonce : Tezos_raw_protocol_alpha.Seed_repr.nonce)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_unrevealed ctxt level)
    (fun unrevealed =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
          (Tezos_raw_protocol_alpha.Seed_repr.check_hash nonce
            (nonce_hash unrevealed)) Unexpected_nonce)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Storage.Seed.Nonce.set ctxt level
                (Revealed nonce))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ctxt)
          end)).

Record unrevealed := {
  nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
  delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
  fees : Tezos_raw_protocol_alpha.Tez_repr.t }.

Inductive status : Type :=
| Unrevealed : unrevealed -> status
| Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> status.

Definition get
  : Tezos_raw_protocol_alpha.Storage.Seed.Nonce.context ->
    Tezos_raw_protocol_alpha.Level_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha__Storage.Seed.nonce_status) :=
  Tezos_raw_protocol_alpha.Storage.Seed.Nonce.get.

Definition of_bytes
  : Tezos_protocol_environment_alpha__Environment.MBytes.t ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Seed_repr.nonce :=
  Tezos_raw_protocol_alpha.Seed_repr.make_nonce.

Definition hash
  : Tezos_raw_protocol_alpha.Seed_repr.nonce ->
    Tezos_raw_protocol_alpha.Nonce_hash.t :=
  Tezos_raw_protocol_alpha.Seed_repr.hash.

Definition check_hash
  : Tezos_raw_protocol_alpha.Seed_repr.nonce ->
    Tezos_raw_protocol_alpha.Nonce_hash.t -> bool :=
  Tezos_raw_protocol_alpha.Seed_repr.check_hash.
src/proto_alpha/lib_protocol/nonce_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Too_late_revelation
  | Too_early_revelation
  | Previously_revealed_nonce
  | Unexpected_nonce

type t = Seed_repr.nonce

type nonce = t

val encoding : nonce Data_encoding.t

type unrevealed = Storage.Seed.unrevealed_nonce = {
  nonce_hash : Nonce_hash.t;
  delegate : Signature.Public_key_hash.t;
  rewards : Tez_repr.t;
  fees : Tez_repr.t;
}

type status = Unrevealed of unrevealed | Revealed of Seed_repr.nonce

val get : Raw_context.t -> Level_repr.t -> status tzresult Lwt.t

val record_hash : Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t

val reveal :
  Raw_context.t -> Level_repr.t -> nonce -> Raw_context.t tzresult Lwt.t

val of_bytes : MBytes.t -> nonce tzresult

val hash : nonce -> Nonce_hash.t

val check_hash : nonce -> Nonce_hash.t -> bool
src/proto_alpha/lib_protocol/nonce_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

Definition t := Tezos_raw_protocol_alpha.Seed_repr.nonce.

Definition nonce := t.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t nonce.

Record unrevealed := {
  nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
  delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
  fees : Tezos_raw_protocol_alpha.Tez_repr.t }.

Inductive status : Type :=
| Unrevealed : unrevealed -> status
| Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> status.

Parameter get :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Level_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult status).

Parameter record_hash :
Tezos_raw_protocol_alpha.Raw_context.t ->
  unrevealed ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter reveal :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Level_repr.t ->
    nonce ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter of_bytes :
Tezos_protocol_environment_alpha__Environment.MBytes.t ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult nonce.

Parameter hash : nonce -> Tezos_raw_protocol_alpha.Nonce_hash.t.

Parameter check_hash : nonce -> Tezos_raw_protocol_alpha.Nonce_hash.t -> bool.
src/proto_alpha/lib_protocol/operation_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Operations *)

module Kind = struct
  type seed_nonce_revelation = Seed_nonce_revelation_kind

  type double_endorsement_evidence = Double_endorsement_evidence_kind

  type double_baking_evidence = Double_baking_evidence_kind

  type activate_account = Activate_account_kind

  type endorsement = Endorsement_kind

  type proposals = Proposals_kind

  type ballot = Ballot_kind

  type reveal = Reveal_kind

  type transaction = Transaction_kind

  type origination = Origination_kind

  type delegation = Delegation_kind

  type 'a manager =
    | Reveal_manager_kind : reveal manager
    | Transaction_manager_kind : transaction manager
    | Origination_manager_kind : origination manager
    | Delegation_manager_kind : delegation manager
end

type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}

let raw_encoding = Operation.encoding

type 'kind operation = {
  shell : Operation.shell_header;
  protocol_data : 'kind protocol_data;
}

and 'kind protocol_data = {
  contents : 'kind contents_list;
  signature : Signature.t option;
}

and _ contents_list =
  | Single : 'kind contents -> 'kind contents_list
  | Cons :
      'kind Kind.manager contents * 'rest Kind.manager contents_list
      -> ('kind * 'rest) Kind.manager contents_list

and _ contents =
  | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents
  | Seed_nonce_revelation : {
      level : Raw_level_repr.t;
      nonce : Seed_repr.nonce;
    }
      -> Kind.seed_nonce_revelation contents
  | Double_endorsement_evidence : {
      op1 : Kind.endorsement operation;
      op2 : Kind.endorsement operation;
    }
      -> Kind.double_endorsement_evidence contents
  | Double_baking_evidence : {
      bh1 : Block_header_repr.t;
      bh2 : Block_header_repr.t;
    }
      -> Kind.double_baking_evidence contents
  | Activate_account : {
      id : Ed25519.Public_key_hash.t;
      activation_code : Blinded_public_key_hash.activation_code;
    }
      -> Kind.activate_account contents
  | Proposals : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposals : Protocol_hash.t list;
    }
      -> Kind.proposals contents
  | Ballot : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposal : Protocol_hash.t;
      ballot : Vote_repr.ballot;
    }
      -> Kind.ballot contents
  | Manager_operation : {
      source : Signature.public_key_hash;
      fee : Tez_repr.tez;
      counter : counter;
      operation : 'kind manager_operation;
      gas_limit : Z.t;
      storage_limit : Z.t;
    }
      -> 'kind Kind.manager contents

and _ manager_operation =
  | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
  | Transaction : {
      amount : Tez_repr.tez;
      parameters : Script_repr.lazy_expr;
      entrypoint : string;
      destination : Contract_repr.contract;
    }
      -> Kind.transaction manager_operation
  | Origination : {
      delegate : Signature.Public_key_hash.t option;
      script : Script_repr.t;
      credit : Tez_repr.tez;
      preorigination : Contract_repr.t option;
    }
      -> Kind.origination manager_operation
  | Delegation :
      Signature.Public_key_hash.t option
      -> Kind.delegation manager_operation

and counter = Z.t

let manager_kind : type kind. kind manager_operation -> kind Kind.manager =
  function
  | Reveal _ ->
      Kind.Reveal_manager_kind
  | Transaction _ ->
      Kind.Transaction_manager_kind
  | Origination _ ->
      Kind.Origination_manager_kind
  | Delegation _ ->
      Kind.Delegation_manager_kind

type 'kind internal_operation = {
  source : Contract_repr.contract;
  operation : 'kind manager_operation;
  nonce : int;
}

type packed_manager_operation =
  | Manager : 'kind manager_operation -> packed_manager_operation

type packed_contents = Contents : 'kind contents -> packed_contents

type packed_contents_list =
  | Contents_list : 'kind contents_list -> packed_contents_list

type packed_protocol_data =
  | Operation_data : 'kind protocol_data -> packed_protocol_data

type packed_operation = {
  shell : Operation.shell_header;
  protocol_data : packed_protocol_data;
}

let pack ({shell; protocol_data} : _ operation) : packed_operation =
  {shell; protocol_data = Operation_data protocol_data}

type packed_internal_operation =
  | Internal_operation : 'kind internal_operation -> packed_internal_operation

let rec to_list = function
  | Contents_list (Single o) ->
      [Contents o]
  | Contents_list (Cons (o, os)) ->
      Contents o :: to_list (Contents_list os)

let rec of_list = function
  | [] ->
      assert false
  | [Contents o] ->
      Contents_list (Single o)
  | Contents o :: os -> (
      let (Contents_list os) = of_list os in
      match (o, os) with
      | (Manager_operation _, Single (Manager_operation _)) ->
          Contents_list (Cons (o, os))
      | (Manager_operation _, Cons _) ->
          Contents_list (Cons (o, os))
      | _ ->
          Pervasives.failwith
            "Operation list of length > 1 should only contains manager \
             operations." )

module Encoding = struct
  open Data_encoding

  let case tag name args proj inj =
    let open Data_encoding in
    case
      tag
      ~title:(String.capitalize_ascii name)
      (merge_objs (obj1 (req "kind" (constant name))) args)
      (fun x -> match proj x with None -> None | Some x -> Some ((), x))
      (fun ((), x) -> inj x)

  module Manager_operations = struct
    type 'kind case =
      | MCase : {
          tag : int;
          name : string;
          encoding : 'a Data_encoding.t;
          select : packed_manager_operation -> 'kind manager_operation option;
          proj : 'kind manager_operation -> 'a;
          inj : 'a -> 'kind manager_operation;
        }
          -> 'kind case

    let reveal_case =
      MCase
        {
          tag = 0;
          name = "reveal";
          encoding = obj1 (req "public_key" Signature.Public_key.encoding);
          select = (function Manager (Reveal _ as op) -> Some op | _ -> None);
          proj = (function Reveal pkh -> pkh);
          inj = (fun pkh -> Reveal pkh);
        }

    let entrypoint_encoding =
      def
        ~title:"entrypoint"
        ~description:"Named entrypoint to a Michelson smart contract"
        "entrypoint"
      @@
      let builtin_case tag name =
        Data_encoding.case
          (Tag tag)
          ~title:name
          (constant name)
          (fun n -> if Compare.String.(n = name) then Some () else None)
          (fun () -> name)
      in
      union
        [ builtin_case 0 "default";
          builtin_case 1 "root";
          builtin_case 2 "do";
          builtin_case 3 "set_delegate";
          builtin_case 4 "remove_delegate";
          Data_encoding.case
            (Tag 255)
            ~title:"named"
            (Bounded.string 31)
            (fun s -> Some s)
            (fun s -> s) ]

    let transaction_case =
      MCase
        {
          tag = 1;
          name = "transaction";
          encoding =
            obj3
              (req "amount" Tez_repr.encoding)
              (req "destination" Contract_repr.encoding)
              (opt
                 "parameters"
                 (obj2
                    (req "entrypoint" entrypoint_encoding)
                    (req "value" Script_repr.lazy_expr_encoding)));
          select =
            (function Manager (Transaction _ as op) -> Some op | _ -> None);
          proj =
            (function
            | Transaction {amount; destination; parameters; entrypoint} ->
                let parameters =
                  if
                    Script_repr.is_unit_parameter parameters
                    && Compare.String.(entrypoint = "default")
                  then None
                  else Some (entrypoint, parameters)
                in
                (amount, destination, parameters));
          inj =
            (fun (amount, destination, parameters) ->
              let (entrypoint, parameters) =
                match parameters with
                | None ->
                    ("default", Script_repr.unit_parameter)
                | Some (entrypoint, value) ->
                    (entrypoint, value)
              in
              Transaction {amount; destination; parameters; entrypoint});
        }

    let origination_case =
      MCase
        {
          tag = 2;
          name = "origination";
          encoding =
            obj3
              (req "balance" Tez_repr.encoding)
              (opt "delegate" Signature.Public_key_hash.encoding)
              (req "script" Script_repr.encoding);
          select =
            (function Manager (Origination _ as op) -> Some op | _ -> None);
          proj =
            (function
            | Origination
                { credit;
                  delegate;
                  script;
                  preorigination =
                    _
                    (* the hash is only used internally
                               when originating from smart
                               contracts, don't serialize it *)
                } ->
                (credit, delegate, script));
          inj =
            (fun (credit, delegate, script) ->
              Origination {credit; delegate; script; preorigination = None});
        }

    let delegation_case =
      MCase
        {
          tag = 3;
          name = "delegation";
          encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding);
          select =
            (function Manager (Delegation _ as op) -> Some op | _ -> None);
          proj = (function Delegation key -> key);
          inj = (fun key -> Delegation key);
        }

    let encoding =
      let make (MCase {tag; name; encoding; select; proj; inj}) =
        case
          (Tag tag)
          name
          encoding
          (fun o ->
            match select o with None -> None | Some o -> Some (proj o))
          (fun x -> Manager (inj x))
      in
      union
        ~tag_size:`Uint8
        [ make reveal_case;
          make transaction_case;
          make origination_case;
          make delegation_case ]
  end

  type 'b case =
    | Case : {
        tag : int;
        name : string;
        encoding : 'a Data_encoding.t;
        select : packed_contents -> 'b contents option;
        proj : 'b contents -> 'a;
        inj : 'a -> 'b contents;
      }
        -> 'b case

  let endorsement_encoding = obj1 (req "level" Raw_level_repr.encoding)

  let endorsement_case =
    Case
      {
        tag = 0;
        name = "endorsement";
        encoding = endorsement_encoding;
        select =
          (function Contents (Endorsement _ as op) -> Some op | _ -> None);
        proj = (fun (Endorsement {level}) -> level);
        inj = (fun level -> Endorsement {level});
      }

  let endorsement_encoding =
    let make (Case {tag; name; encoding; select = _; proj; inj}) =
      case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)
    in
    let to_list : Kind.endorsement contents_list -> _ = function
      | Single o ->
          o
    in
    let of_list : Kind.endorsement contents -> _ = function o -> Single o in
    def "inlined.endorsement"
    @@ conv
         (fun ({shell; protocol_data = {contents; signature}} : _ operation) ->
           (shell, (contents, signature)))
         (fun (shell, (contents, signature)) ->
           ({shell; protocol_data = {contents; signature}} : _ operation))
         (merge_objs
            Operation.shell_header_encoding
            (obj2
               (req
                  "operations"
                  ( conv to_list of_list
                  @@ def "inlined.endorsement.contents"
                  @@ union [make endorsement_case] ))
               (varopt "signature" Signature.encoding)))

  let seed_nonce_revelation_case =
    Case
      {
        tag = 1;
        name = "seed_nonce_revelation";
        encoding =
          obj2
            (req "level" Raw_level_repr.encoding)
            (req "nonce" Seed_repr.nonce_encoding);
        select =
          (function
          | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None);
        proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce));
        inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce});
      }

  let double_endorsement_evidence_case : Kind.double_endorsement_evidence case
      =
    Case
      {
        tag = 2;
        name = "double_endorsement_evidence";
        encoding =
          obj2
            (req "op1" (dynamic_size endorsement_encoding))
            (req "op2" (dynamic_size endorsement_encoding));
        select =
          (function
          | Contents (Double_endorsement_evidence _ as op) ->
              Some op
          | _ ->
              None);
        proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2));
        inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2});
      }

  let double_baking_evidence_case =
    Case
      {
        tag = 3;
        name = "double_baking_evidence";
        encoding =
          obj2
            (req "bh1" (dynamic_size Block_header_repr.encoding))
            (req "bh2" (dynamic_size Block_header_repr.encoding));
        select =
          (function
          | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None);
        proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2));
        inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2});
      }

  let activate_account_case =
    Case
      {
        tag = 4;
        name = "activate_account";
        encoding =
          obj2
            (req "pkh" Ed25519.Public_key_hash.encoding)
            (req "secret" Blinded_public_key_hash.activation_code_encoding);
        select =
          (function
          | Contents (Activate_account _ as op) -> Some op | _ -> None);
        proj =
          (fun (Activate_account {id; activation_code}) ->
            (id, activation_code));
        inj =
          (fun (id, activation_code) -> Activate_account {id; activation_code});
      }

  let proposals_case =
    Case
      {
        tag = 5;
        name = "proposals";
        encoding =
          obj3
            (req "source" Signature.Public_key_hash.encoding)
            (req "period" Voting_period_repr.encoding)
            (req "proposals" (list Protocol_hash.encoding));
        select =
          (function Contents (Proposals _ as op) -> Some op | _ -> None);
        proj =
          (fun (Proposals {source; period; proposals}) ->
            (source, period, proposals));
        inj =
          (fun (source, period, proposals) ->
            Proposals {source; period; proposals});
      }

  let ballot_case =
    Case
      {
        tag = 6;
        name = "ballot";
        encoding =
          obj4
            (req "source" Signature.Public_key_hash.encoding)
            (req "period" Voting_period_repr.encoding)
            (req "proposal" Protocol_hash.encoding)
            (req "ballot" Vote_repr.ballot_encoding);
        select = (function Contents (Ballot _ as op) -> Some op | _ -> None);
        proj =
          (function
          | Ballot {source; period; proposal; ballot} ->
              (source, period, proposal, ballot));
        inj =
          (fun (source, period, proposal, ballot) ->
            Ballot {source; period; proposal; ballot});
      }

  let manager_encoding =
    obj5
      (req "source" Signature.Public_key_hash.encoding)
      (req "fee" Tez_repr.encoding)
      (req "counter" (check_size 10 n))
      (req "gas_limit" (check_size 10 n))
      (req "storage_limit" (check_size 10 n))

  let extract (type kind)
      (Manager_operation
         {source; fee; counter; gas_limit; storage_limit; operation = _} :
        kind Kind.manager contents) =
    (source, fee, counter, gas_limit, storage_limit)

  let rebuild (source, fee, counter, gas_limit, storage_limit) operation =
    Manager_operation
      {source; fee; counter; gas_limit; storage_limit; operation}

  let make_manager_case tag (type kind)
      (Manager_operations.MCase mcase : kind Manager_operations.case) =
    Case
      {
        tag;
        name = mcase.name;
        encoding = merge_objs manager_encoding mcase.encoding;
        select =
          (function
          | Contents (Manager_operation ({operation; _} as op)) -> (
            match mcase.select (Manager operation) with
            | None ->
                None
            | Some operation ->
                Some (Manager_operation {op with operation}) )
          | _ ->
              None);
        proj =
          (function
          | Manager_operation {operation; _} as op ->
              (extract op, mcase.proj operation));
        inj = (fun (op, contents) -> rebuild op (mcase.inj contents));
      }

  let reveal_case = make_manager_case 107 Manager_operations.reveal_case

  let transaction_case =
    make_manager_case 108 Manager_operations.transaction_case

  let origination_case =
    make_manager_case 109 Manager_operations.origination_case

  let delegation_case =
    make_manager_case 110 Manager_operations.delegation_case

  let contents_encoding =
    let make (Case {tag; name; encoding; select; proj; inj}) =
      case
        (Tag tag)
        name
        encoding
        (fun o -> match select o with None -> None | Some o -> Some (proj o))
        (fun x -> Contents (inj x))
    in
    def "operation.alpha.contents"
    @@ union
         [ make endorsement_case;
           make seed_nonce_revelation_case;
           make double_endorsement_evidence_case;
           make double_baking_evidence_case;
           make activate_account_case;
           make proposals_case;
           make ballot_case;
           make reveal_case;
           make transaction_case;
           make origination_case;
           make delegation_case ]

  let contents_list_encoding =
    conv to_list of_list (Variable.list contents_encoding)

  let optional_signature_encoding =
    conv
      (function Some s -> s | None -> Signature.zero)
      (fun s -> if Signature.equal s Signature.zero then None else Some s)
      Signature.encoding

  let protocol_data_encoding =
    def "operation.alpha.contents_and_signature"
    @@ conv
         (fun (Operation_data {contents; signature}) ->
           (Contents_list contents, signature))
         (fun (Contents_list contents, signature) ->
           Operation_data {contents; signature})
         (obj2
            (req "contents" contents_list_encoding)
            (req "signature" optional_signature_encoding))

  let operation_encoding =
    conv
      (fun {shell; protocol_data} -> (shell, protocol_data))
      (fun (shell, protocol_data) -> {shell; protocol_data})
      (merge_objs Operation.shell_header_encoding protocol_data_encoding)

  let unsigned_operation_encoding =
    def "operation.alpha.unsigned_operation"
    @@ merge_objs
         Operation.shell_header_encoding
         (obj1 (req "contents" contents_list_encoding))

  let internal_operation_encoding =
    def "operation.alpha.internal_operation"
    @@ conv
         (fun (Internal_operation {source; operation; nonce}) ->
           ((source, nonce), Manager operation))
         (fun ((source, nonce), Manager operation) ->
           Internal_operation {source; operation; nonce})
         (merge_objs
            (obj2 (req "source" Contract_repr.encoding) (req "nonce" uint16))
            Manager_operations.encoding)
end

let encoding = Encoding.operation_encoding

let contents_encoding = Encoding.contents_encoding

let contents_list_encoding = Encoding.contents_list_encoding

let protocol_data_encoding = Encoding.protocol_data_encoding

let unsigned_operation_encoding = Encoding.unsigned_operation_encoding

let internal_operation_encoding = Encoding.internal_operation_encoding

let raw ({shell; protocol_data} : _ operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn
      protocol_data_encoding
      (Operation_data protocol_data)
  in
  {Operation.shell; proto}

let acceptable_passes (op : packed_operation) =
  let (Operation_data protocol_data) = op.protocol_data in
  match protocol_data.contents with
  | Single (Endorsement _) ->
      [0]
  | Single (Proposals _) ->
      [1]
  | Single (Ballot _) ->
      [1]
  | Single (Seed_nonce_revelation _) ->
      [2]
  | Single (Double_endorsement_evidence _) ->
      [2]
  | Single (Double_baking_evidence _) ->
      [2]
  | Single (Activate_account _) ->
      [2]
  | Single (Manager_operation _) ->
      [3]
  | Cons _ ->
      [3]

type error += Invalid_signature (* `Permanent *)

type error += Missing_signature (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"operation.invalid_signature"
    ~title:"Invalid operation signature"
    ~description:
      "The operation signature is ill-formed or has been made with the wrong \
       public key"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation signature is invalid")
    Data_encoding.unit
    (function Invalid_signature -> Some () | _ -> None)
    (fun () -> Invalid_signature) ;
  register_error_kind
    `Permanent
    ~id:"operation.missing_signature"
    ~title:"Missing operation signature"
    ~description:
      "The operation is of a kind that must be signed, but the signature is \
       missing"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation requires a signature")
    Data_encoding.unit
    (function Missing_signature -> Some () | _ -> None)
    (fun () -> Missing_signature)

let check_signature_sync (type kind) key chain_id
    ({shell; protocol_data} : kind operation) =
  let check ~watermark contents signature =
    let unsigned_operation =
      Data_encoding.Binary.to_bytes_exn
        unsigned_operation_encoding
        (shell, contents)
    in
    if Signature.check ~watermark key signature unsigned_operation then Ok ()
    else error Invalid_signature
  in
  match (protocol_data.contents, protocol_data.signature) with
  | (Single _, None) ->
      error Missing_signature
  | (Cons _, None) ->
      error Missing_signature
  | ((Single (Endorsement _) as contents), Some signature) ->
      check
        ~watermark:(Endorsement chain_id)
        (Contents_list contents)
        signature
  | ((Single _ as contents), Some signature) ->
      check ~watermark:Generic_operation (Contents_list contents) signature
  | ((Cons _ as contents), Some signature) ->
      check ~watermark:Generic_operation (Contents_list contents) signature

let check_signature pk chain_id op =
  Lwt.return (check_signature_sync pk chain_id op)

let hash_raw = Operation.hash

let hash (o : _ operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn
      protocol_data_encoding
      (Operation_data o.protocol_data)
  in
  Operation.hash {shell = o.shell; proto}

let hash_packed (o : packed_operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding o.protocol_data
  in
  Operation.hash {shell = o.shell; proto}

type ('a, 'b) eq = Eq : ('a, 'a) eq

let equal_manager_operation_kind :
    type a b. a manager_operation -> b manager_operation -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Reveal _, Reveal _) ->
      Some Eq
  | (Reveal _, _) ->
      None
  | (Transaction _, Transaction _) ->
      Some Eq
  | (Transaction _, _) ->
      None
  | (Origination _, Origination _) ->
      Some Eq
  | (Origination _, _) ->
      None
  | (Delegation _, Delegation _) ->
      Some Eq
  | (Delegation _, _) ->
      None

let equal_contents_kind :
    type a b. a contents -> b contents -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Endorsement _, Endorsement _) ->
      Some Eq
  | (Endorsement _, _) ->
      None
  | (Seed_nonce_revelation _, Seed_nonce_revelation _) ->
      Some Eq
  | (Seed_nonce_revelation _, _) ->
      None
  | (Double_endorsement_evidence _, Double_endorsement_evidence _) ->
      Some Eq
  | (Double_endorsement_evidence _, _) ->
      None
  | (Double_baking_evidence _, Double_baking_evidence _) ->
      Some Eq
  | (Double_baking_evidence _, _) ->
      None
  | (Activate_account _, Activate_account _) ->
      Some Eq
  | (Activate_account _, _) ->
      None
  | (Proposals _, Proposals _) ->
      Some Eq
  | (Proposals _, _) ->
      None
  | (Ballot _, Ballot _) ->
      Some Eq
  | (Ballot _, _) ->
      None
  | (Manager_operation op1, Manager_operation op2) -> (
    match equal_manager_operation_kind op1.operation op2.operation with
    | None ->
        None
    | Some Eq ->
        Some Eq )
  | (Manager_operation _, _) ->
      None

let rec equal_contents_kind_list :
    type a b. a contents_list -> b contents_list -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Single op1, Single op2) ->
      equal_contents_kind op1 op2
  | (Single _, Cons _) ->
      None
  | (Cons _, Single _) ->
      None
  | (Cons (op1, ops1), Cons (op2, ops2)) -> (
    match equal_contents_kind op1 op2 with
    | None ->
        None
    | Some Eq -> (
      match equal_contents_kind_list ops1 ops2 with
      | None ->
          None
      | Some Eq ->
          Some Eq ) )

let equal : type a b. a operation -> b operation -> (a, b) eq option =
 fun op1 op2 ->
  if not (Operation_hash.equal (hash op1) (hash op2)) then None
  else
    equal_contents_kind_list
      op1.protocol_data.contents
      op2.protocol_data.contents
src/proto_alpha/lib_protocol/operation_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Kind.
  Inductive seed_nonce_revelation : Type :=
  | Seed_nonce_revelation_kind : seed_nonce_revelation.
  
  Inductive double_endorsement_evidence : Type :=
  | Double_endorsement_evidence_kind : double_endorsement_evidence.
  
  Inductive double_baking_evidence : Type :=
  | Double_baking_evidence_kind : double_baking_evidence.
  
  Inductive activate_account : Type :=
  | Activate_account_kind : activate_account.
  
  Inductive endorsement : Type :=
  | Endorsement_kind : endorsement.
  
  Inductive proposals : Type :=
  | Proposals_kind : proposals.
  
  Inductive ballot : Type :=
  | Ballot_kind : ballot.
  
  Inductive reveal : Type :=
  | Reveal_kind : reveal.
  
  Inductive transaction : Type :=
  | Transaction_kind : transaction.
  
  Inductive origination : Type :=
  | Origination_kind : origination.
  
  Inductive delegation : Type :=
  | Delegation_kind : delegation.
  
  Inductive manager : forall (a : Type), Type :=
  | Reveal_manager_kind : manager reveal
  | Transaction_manager_kind : manager transaction
  | Origination_manager_kind : manager origination
  | Delegation_manager_kind : manager delegation.
End Kind.

Record raw := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  proto : Tezos_protocol_environment_alpha__Environment.MBytes.t }.

Definition raw_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_protocol_environment_alpha__Environment.Operation.t :=
  Tezos_protocol_environment_alpha__Environment.Operation.encoding.

Reserved Notation "'counter".

Inductive contents_list : forall (_ : Type), Type :=
| Single : forall {kind : Type}, (contents kind) -> contents_list kind
| Cons : forall {kind rest : Type}, (contents (Kind.manager kind)) ->
  (contents_list (Kind.manager rest)) ->
  contents_list (Kind.manager (kind * rest))

with contents : forall (_ : Type), Type :=
| Endorsement : Tezos_raw_protocol_alpha.Raw_level_repr.t ->
  contents Kind.endorsement
| Seed_nonce_revelation : Tezos_raw_protocol_alpha.Raw_level_repr.t ->
  Tezos_raw_protocol_alpha.Seed_repr.nonce ->
  contents Kind.seed_nonce_revelation
| Double_endorsement_evidence : (operation Kind.endorsement) ->
  (operation Kind.endorsement) -> contents Kind.double_endorsement_evidence
| Double_baking_evidence : Tezos_raw_protocol_alpha.Block_header_repr.t ->
  Tezos_raw_protocol_alpha.Block_header_repr.t ->
  contents Kind.double_baking_evidence
| Activate_account :
  Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code ->
  contents Kind.activate_account
| Proposals :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Voting_period_repr.t ->
  (list
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  -> contents Kind.proposals
| Ballot :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Voting_period_repr.t ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> Tezos_raw_protocol_alpha.Vote_repr.ballot -> contents Kind.ballot
| Manager_operation : forall {kind : Type},
  Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash ->
  Tezos_raw_protocol_alpha.Tez_repr.tez -> 'counter -> (manager_operation kind)
  -> Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  contents (Kind.manager kind)

with manager_operation : forall (_ : Type), Type :=
| Reveal : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t
  -> manager_operation Kind.reveal
| Transaction : Tezos_raw_protocol_alpha.Tez_repr.tez ->
  Tezos_raw_protocol_alpha.Script_repr.lazy_expr -> string ->
  Tezos_raw_protocol_alpha.Contract_repr.contract ->
  manager_operation Kind.transaction
| Origination :
  (option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  -> Tezos_raw_protocol_alpha.Script_repr.t ->
  Tezos_raw_protocol_alpha.Tez_repr.tez ->
  (option Tezos_raw_protocol_alpha.Contract_repr.t) ->
  manager_operation Kind.origination
| Delegation :
  (option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  -> manager_operation Kind.delegation

where "'counter" := ( Tezos_protocol_environment_alpha__Environment.Z.t).

Definition counter := 'counter.

Definition manager_kind {kind : Type}
  (function_parameter : manager_operation kind) : Kind.manager kind :=
  match function_parameter with
  | Reveal _ => Kind.Reveal_manager_kind
  | Transaction _ => Kind.Transaction_manager_kind
  | Origination _ => Kind.Origination_manager_kind
  | Delegation _ => Kind.Delegation_manager_kind
  end.

Record internal_operation {kind : Type} := {
  source : Tezos_raw_protocol_alpha.Contract_repr.contract;
  operation : manager_operation kind;
  nonce : Z }.
Arguments internal_operation : clear implicits.

Inductive packed_manager_operation : Type :=
| Manager : forall {kind : Type}, (manager_operation kind) ->
  packed_manager_operation.

Inductive packed_contents : Type :=
| Contents : forall {kind : Type}, (contents kind) -> packed_contents.

Inductive packed_contents_list : Type :=
| Contents_list : forall {kind : Type}, (contents_list kind) ->
  packed_contents_list.

Inductive packed_protocol_data : Type :=
| Operation_data : forall {kind : Type}, (protocol_data kind) ->
  packed_protocol_data.

Record packed_operation := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  protocol_data : packed_protocol_data }.

Definition pack {A : Type} (function_parameter : operation A)
  : packed_operation :=
  match function_parameter with
  | {| shell := shell; protocol_data := protocol_data |} =>
    {| shell := shell; protocol_data := Operation_data protocol_data |}
  end.

Inductive packed_internal_operation : Type :=
| Internal_operation : forall {kind : Type}, (internal_operation kind) ->
  packed_internal_operation.

Fixpoint to_list (function_parameter : packed_contents_list)
  : list packed_contents :=
  match function_parameter with
  | Contents_list (Single o) => cons (Contents o) []
  | Contents_list (Cons o os) => cons (Contents o) (to_list (Contents_list os))
  end.

Fixpoint of_list (function_parameter : list packed_contents)
  : packed_contents_list :=
  match function_parameter with
  | [] => false
  | cons (Contents o) [] => Contents_list (Single o)
  | cons (Contents o) os =>
    match of_list os with
    | Contents_list os =>
      match (o, os) with
      | (Manager_operation _, Single (Manager_operation _)) =>
        Contents_list (Cons o os)
      | (Manager_operation _, Cons _ _) => Contents_list (Cons o os)
      | _ =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
          "Operation list of length > 1 should only contains manager operations."
            % string
      end
    end
  end.

Module Encoding.
  Import Tezos_protocol_environment_alpha__Environment.Data_encoding.
  
  Definition case {A B : Type}
    (tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
    (name : string)
    (args :
      Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding A)
    (proj : B -> option A) (inj : A -> B)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case B :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.case
      (Tezos_protocol_environment_alpha__Environment.String.capitalize_ascii
        name) None tag
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "kind" % string
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
              name))) args)
      (fun x =>
        match proj x with
        | None => None
        | Some x => Some (tt, x)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (tt, x) => inj x
        end).
  
  Module Manager_operations.
    Inductive case (kind : Type) : Type :=
    | MCase : forall {a : Type}, Z -> string ->
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
      (packed_manager_operation -> option (manager_operation kind)) ->
      ((manager_operation kind) -> a) -> (a -> manager_operation kind) ->
      case kind.
    
    Arguments MCase {_}.
    
    Definition reveal_case : case Kind.reveal :=
      MCase
        {| tag := 0; name := "reveal" % string;
          encoding :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "public_key" % string
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key.encoding);
          select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Reveal _) as op) => Some op
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              match function_parameter with
              | Reveal pkh => pkh
              end; inj := fun pkh => Reveal pkh |}.
    
    Definition entrypoint_encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.def
          "entrypoint" % string (Some "entrypoint" % string)
          (Some "Named entrypoint to a Michelson smart contract" % string))
        (let builtin_case
          (tag : Z) (name :
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
          : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.case name
            None (Tag tag)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
              name)
            (fun n =>
              if
                Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  n name then
                Some tt
              else
                None)
            (fun function_parameter =>
              match function_parameter with
              | tt => name
              end) in
        Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
          (cons (builtin_case 0 "default" % string)
            (cons (builtin_case 1 "root" % string)
              (cons (builtin_case 2 "do" % string)
                (cons (builtin_case 3 "set_delegate" % string)
                  (cons (builtin_case 4 "remove_delegate" % string)
                    (cons
                      (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
                        "named" % string None (Tag 255)
                        (Tezos_protocol_environment_alpha__Environment.Data_encoding.Bounded.string
                          31) (fun s => Some s) (fun s => s)) []))))))).
    
    Definition transaction_case : case Kind.transaction :=
      MCase
        {| tag := 1; name := "transaction" % string;
          encoding :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "amount" % string
                Tezos_raw_protocol_alpha.Tez_repr.encoding)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "destination" % string
                Tezos_raw_protocol_alpha.Contract_repr.encoding)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt
                None None "parameters" % string
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                    None None "entrypoint" % string entrypoint_encoding)
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                    None None "value" % string
                    Tezos_raw_protocol_alpha.Script_repr.lazy_expr_encoding)));
          select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Transaction _) as op) => Some op
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              match function_parameter with
              |
                Transaction {|
                  amount := amount;
                    parameters := parameters;
                    entrypoint := entrypoint;
                    destination := destination
                    |} =>
                let parameters :=
                  if
                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                      (Tezos_raw_protocol_alpha.Script_repr.is_unit_parameter
                        parameters)
                      (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                        entrypoint "default" % string) then
                    None
                  else
                    Some (entrypoint, parameters) in
                (amount, destination, parameters)
              end;
          inj :=
            fun function_parameter =>
              match function_parameter with
              | (amount, destination, parameters) =>
                match
                  match parameters with
                  | None =>
                    ("default" % string,
                      Tezos_raw_protocol_alpha.Script_repr.unit_parameter)
                  | Some (entrypoint, value) => (entrypoint, value)
                  end with
                | (entrypoint, parameters) =>
                  Transaction
                    {| amount := amount; parameters := parameters;
                      entrypoint := entrypoint; destination := destination |}
                end
              end |}.
    
    Definition origination_case : case Kind.origination :=
      MCase
        {| tag := 2; name := "origination" % string;
          encoding :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "balance" % string
                Tezos_raw_protocol_alpha.Tez_repr.encoding)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt
                None None "delegate" % string
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "script" % string
                Tezos_raw_protocol_alpha.Script_repr.encoding);
          select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Origination _) as op) => Some op
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              match function_parameter with
              |
                Origination {|
                  delegate := delegate;
                    script := script;
                    credit := credit;
                    preorigination := _
                    |} => (credit, delegate, script)
              end;
          inj :=
            fun function_parameter =>
              match function_parameter with
              | (credit, delegate, script) =>
                Origination
                  {| delegate := delegate; script := script; credit := credit;
                    preorigination := None |}
              end |}.
    
    Definition delegation_case : case Kind.delegation :=
      MCase
        {| tag := 3; name := "delegation" % string;
          encoding :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt
                None None "delegate" % string
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding);
          select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Delegation _) as op) => Some op
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              match function_parameter with
              | Delegation key => key
              end; inj := fun key => Delegation key |}.
    
    Definition encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        packed_manager_operation :=
      let make {A : Type} (function_parameter : case A)
        : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          packed_manager_operation :=
        match function_parameter with
        |
          MCase {|
            tag := tag;
              name := name;
              encoding := encoding;
              select := select;
              proj := proj;
              inj := inj
              |} =>
          case (Tag tag) name encoding
            (fun o =>
              match select o with
              | None => None
              | Some o => Some (proj o)
              end) (fun x => Manager (inj x))
        end in
      Tezos_protocol_environment_alpha__Environment.Data_encoding.union
        (Some variant)
        (cons (make reveal_case)
          (cons (make transaction_case)
            (cons (make origination_case) (cons (make delegation_case) [])))).
  End Manager_operations.
  
  Inductive case (b : Type) : Type :=
  | Case : forall {a : Type}, Z -> string ->
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
    (packed_contents -> option (contents b)) -> ((contents b) -> a) ->
    (a -> contents b) -> case b.
  
  Arguments Case {_}.
  
  Definition endorsement_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      Tezos_raw_protocol_alpha.Raw_level_repr.raw_level :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "level" % string Tezos_raw_protocol_alpha.Raw_level_repr.encoding).
  
  Definition endorsement_case : case Kind.endorsement :=
    Case
      {| tag := 0; name := "endorsement" % string;
        encoding := endorsement_encoding;
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Endorsement _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Endorsement {| level := level |} => level
            end; inj := fun level => Endorsement {| level := level |} |}.
  
  Definition endorsement_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      (operation Kind.endorsement) :=
    let make {A : Type} (function_parameter : case A)
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        (contents A) :=
      match function_parameter with
      |
        Case {|
          tag := tag;
            name := name;
            encoding := encoding;
            select := _;
            proj := proj;
            inj := inj
            |} =>
        case (Tag tag) name encoding (fun o => Some (proj o)) (fun x => inj x)
      end in
    let to_list (function_parameter : contents_list Kind.endorsement)
      : contents Kind.endorsement :=
      match function_parameter with
      | Single o => o
      end in
    let of_list (o : contents Kind.endorsement)
      : contents_list Kind.endorsement :=
      Single o in
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      (let arg :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.def
          "inlined.endorsement" % string in
      fun eta => arg None None eta)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {|
            shell := shell;
              protocol_data := {|
                contents := contents;
                  signature := signature
                  |}
              |} => (shell, (contents, signature))
          end)
        (fun function_parameter =>
          match function_parameter with
          | (shell, (contents, signature)) =>
            {| shell := shell;
              protocol_data :=
                {| contents := contents; signature := signature |} |}
          end) None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
          Tezos_protocol_environment_alpha__Environment.Operation.shell_header_encoding
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "operations" % string
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                (let arg :=
                  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
                    to_list of_list in
                fun eta => arg None eta)
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  (let arg :=
                    Tezos_protocol_environment_alpha__Environment.Data_encoding.def
                      "inlined.endorsement.contents" % string in
                  fun eta => arg None None eta)
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.union
                    None (cons (make endorsement_case) [])))))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.varopt
              None None "signature" % string
              Tezos_protocol_environment_alpha__Environment.Signature.encoding)))).
  
  Definition seed_nonce_revelation_case : case Kind.seed_nonce_revelation :=
    Case
      {| tag := 1; name := "seed_nonce_revelation" % string;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "level" % string
              Tezos_raw_protocol_alpha.Raw_level_repr.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "nonce" % string
              Tezos_raw_protocol_alpha.Seed_repr.nonce_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Seed_nonce_revelation _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Seed_nonce_revelation {| level := level; nonce := nonce |} =>
              (level, nonce)
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | (level, nonce) =>
              Seed_nonce_revelation {| level := level; nonce := nonce |}
            end |}.
  
  Definition double_endorsement_evidence_case
    : case Kind.double_endorsement_evidence :=
    Case
      {| tag := 2; name := "double_endorsement_evidence" % string;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "op1" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                None endorsement_encoding))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "op2" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                None endorsement_encoding));
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Double_endorsement_evidence _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Double_endorsement_evidence {| op1 := op1; op2 := op2 |} =>
              (op1, op2)
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | (op1, op2) =>
              Double_endorsement_evidence {| op1 := op1; op2 := op2 |}
            end |}.
  
  Definition double_baking_evidence_case : case Kind.double_baking_evidence :=
    Case
      {| tag := 3; name := "double_baking_evidence" % string;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "bh1" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                None Tezos_raw_protocol_alpha.Block_header_repr.encoding))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "bh2" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                None Tezos_raw_protocol_alpha.Block_header_repr.encoding));
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Double_baking_evidence _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            | Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |} => (bh1, bh2)
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | (bh1, bh2) => Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |}
            end |}.
  
  Definition activate_account_case : case Kind.activate_account :=
    Case
      {| tag := 4; name := "activate_account" % string;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "pkh" % string
              Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "secret" % string
              Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Activate_account _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            |
              Activate_account {|
                id := id; activation_code := activation_code |} =>
              (id, activation_code)
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | (id, activation_code) =>
              Activate_account
                {| id := id; activation_code := activation_code |}
            end |}.
  
  Definition proposals_case : case Kind.proposals :=
    Case
      {| tag := 5; name := "proposals" % string;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "source" % string
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "period" % string
              Tezos_raw_protocol_alpha.Voting_period_repr.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "proposals" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                None
                Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)));
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Proposals _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            |
              Proposals {|
                source := source;
                  period := period;
                  proposals := proposals
                  |} => (source, period, proposals)
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | (source, period, proposals) =>
              Proposals
                {| source := source; period := period; proposals := proposals |}
            end |}.
  
  Definition ballot_case : case Kind.ballot :=
    Case
      {| tag := 6; name := "ballot" % string;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.obj4
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "source" % string
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "period" % string
              Tezos_raw_protocol_alpha.Voting_period_repr.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "proposal" % string
              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "ballot" % string
              Tezos_raw_protocol_alpha.Vote_repr.ballot_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Ballot _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            match function_parameter with
            |
              Ballot {|
                source := source;
                  period := period;
                  proposal := proposal;
                  ballot := ballot
                  |} => (source, period, proposal, ballot)
            end;
        inj :=
          fun function_parameter =>
            match function_parameter with
            | (source, period, proposal, ballot) =>
              Ballot
                {| source := source; period := period; proposal := proposal;
                  ballot := ballot |}
            end |}.
  
  Definition manager_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Tezos_raw_protocol_alpha.Tez_repr.t *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_protocol_environment_alpha__Environment.Z.t) :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.obj5
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "source" % string
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "fee" % string Tezos_raw_protocol_alpha.Tez_repr.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "counter" % string
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.check_size
          10 Tezos_protocol_environment_alpha__Environment.Data_encoding.n))
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "gas_limit" % string
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.check_size
          10 Tezos_protocol_environment_alpha__Environment.Data_encoding.n))
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "storage_limit" % string
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.check_size
          10 Tezos_protocol_environment_alpha__Environment.Data_encoding.n)).
  
  Definition extract {A : Type} (function_parameter : contents (Kind.manager A))
    : Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash *
      Tezos_raw_protocol_alpha.Tez_repr.tez * counter *
      Tezos_protocol_environment_alpha__Environment.Z.t *
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    match function_parameter with
    |
      Manager_operation {|
        source := source;
          fee := fee;
          counter := counter;
          operation := _;
          gas_limit := gas_limit;
          storage_limit := storage_limit
          |} => (source, fee, counter, gas_limit, storage_limit)
    end.
  
  Definition rebuild {A : Type}
    (function_parameter :
      Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash *
        Tezos_raw_protocol_alpha.Tez_repr.tez * counter *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_protocol_environment_alpha__Environment.Z.t)
    : (manager_operation A) -> contents (Kind.manager A) :=
    match function_parameter with
    | (source, fee, counter, gas_limit, storage_limit) =>
      fun operation =>
        Manager_operation
          {| source := source; fee := fee; counter := counter;
            operation := operation; gas_limit := gas_limit;
            storage_limit := storage_limit |}
    end.
  
  Definition make_manager_case {A : Type}
    (tag : Z) (function_parameter : Manager_operations.case A)
    : case (Kind.manager A) :=
    match function_parameter with
    | Manager_operations.MCase mcase =>
      Case
        {| tag := tag; name := name mcase;
          encoding :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
              manager_encoding (encoding mcase);
          select :=
            fun function_parameter =>
              match function_parameter with
              |
                Contents
                  (Manager_operation ({| operation := operation |} as op)) =>
                match (select mcase) (Manager operation) with
                | None => None
                | Some operation => Some (Manager_operation record)
                end
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              match function_parameter with
              | (Manager_operation {| operation := operation |}) as op =>
                ((extract op), ((proj mcase) operation))
              end;
          inj :=
            fun function_parameter =>
              match function_parameter with
              | (op, contents) => rebuild op ((inj mcase) contents)
              end |}
    end.
  
  Definition reveal_case : case (Kind.manager Kind.reveal) :=
    make_manager_case 107 Manager_operations.reveal_case.
  
  Definition transaction_case : case (Kind.manager Kind.transaction) :=
    make_manager_case 108 Manager_operations.transaction_case.
  
  Definition origination_case : case (Kind.manager Kind.origination) :=
    make_manager_case 109 Manager_operations.origination_case.
  
  Definition delegation_case : case (Kind.manager Kind.delegation) :=
    make_manager_case 110 Manager_operations.delegation_case.
  
  Definition contents_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_contents :=
    let make {A : Type} (function_parameter : case A)
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        packed_contents :=
      match function_parameter with
      |
        Case {|
          tag := tag;
            name := name;
            encoding := encoding;
            select := select;
            proj := proj;
            inj := inj
            |} =>
        case (Tag tag) name encoding
          (fun o =>
            match select o with
            | None => None
            | Some o => Some (proj o)
            end) (fun x => Contents (inj x))
      end in
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      (let arg :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.def
          "operation.alpha.contents" % string in
      fun eta => arg None None eta)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
        (cons (make endorsement_case)
          (cons (make seed_nonce_revelation_case)
            (cons (make double_endorsement_evidence_case)
              (cons (make double_baking_evidence_case)
                (cons (make activate_account_case)
                  (cons (make proposals_case)
                    (cons (make ballot_case)
                      (cons (make reveal_case)
                        (cons (make transaction_case)
                          (cons (make origination_case)
                            (cons (make delegation_case) [])))))))))))).
  
  Definition contents_list_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_contents_list :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.conv to_list
      of_list None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.Variable.list
        None contents_encoding).
  
  Definition optional_signature_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      (option Tezos_protocol_environment_alpha__Environment.Signature.t) :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | Some s => s
        | None => Tezos_protocol_environment_alpha__Environment.Signature.zero
        end)
      (fun s =>
        if
          Tezos_protocol_environment_alpha__Environment.Signature.equal s
            Tezos_protocol_environment_alpha__Environment.Signature.zero then
          None
        else
          Some s) None
      Tezos_protocol_environment_alpha__Environment.Signature.encoding.
  
  Definition protocol_data_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_protocol_data :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      (let arg :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.def
          "operation.alpha.contents_and_signature" % string in
      fun eta => arg None None eta)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | Operation_data {| contents := contents; signature := signature |} =>
            ((Contents_list contents), signature)
          end)
        (fun function_parameter =>
          match function_parameter with
          | (Contents_list contents, signature) =>
            Operation_data {| contents := contents; signature := signature |}
          end) None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "contents" % string contents_list_encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "signature" % string optional_signature_encoding))).
  
  Definition operation_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_operation :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| shell := shell; protocol_data := protocol_data |} =>
          (shell, protocol_data)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (shell, protocol_data) =>
          {| shell := shell; protocol_data := protocol_data |}
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        Tezos_protocol_environment_alpha__Environment.Operation.shell_header_encoding
        protocol_data_encoding).
  
  Definition unsigned_operation_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
        packed_contents_list) :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      (let arg :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.def
          "operation.alpha.unsigned_operation" % string in
      fun eta => arg None None eta)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
        Tezos_protocol_environment_alpha__Environment.Operation.shell_header_encoding
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "contents" % string contents_list_encoding))).
  
  Definition internal_operation_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_internal_operation :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      (let arg :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.def
          "operation.alpha.internal_operation" % string in
      fun eta => arg None None eta)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          |
            Internal_operation {|
              source := source; operation := operation; nonce := nonce |} =>
            ((source, nonce), (Manager operation))
          end)
        (fun function_parameter =>
          match function_parameter with
          | ((source, nonce), Manager operation) =>
            Internal_operation
              {| source := source; operation := operation; nonce := nonce |}
          end) None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "source" % string
              Tezos_raw_protocol_alpha.Contract_repr.encoding)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "nonce" % string
              Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16))
          Manager_operations.encoding)).
End Encoding.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_operation := Encoding.operation_encoding.

Definition contents_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents := Encoding.contents_encoding.

Definition contents_list_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_list := Encoding.contents_list_encoding.

Definition protocol_data_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_protocol_data := Encoding.protocol_data_encoding.

Definition unsigned_operation_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
      packed_contents_list) := Encoding.unsigned_operation_encoding.

Definition internal_operation_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_internal_operation := Encoding.internal_operation_encoding.

Definition raw {A : Type} (function_parameter : operation A)
  : Tezos_protocol_environment_alpha__Environment.Operation.t :=
  match function_parameter with
  | {| shell := shell; protocol_data := protocol_data |} =>
    let proto :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
        protocol_data_encoding (Operation_data protocol_data) in
    {| Operation.shell := shell; Operation.proto := proto |}
  end.

Definition acceptable_passes (op : packed_operation) : list Z :=
  match protocol_data op with
  | Operation_data protocol_data =>
    match contents protocol_data with
    | Single (Endorsement _) => cons 0 []
    | Single (Proposals _) => cons 1 []
    | Single (Ballot _) => cons 1 []
    | Single (Seed_nonce_revelation _) => cons 2 []
    | Single (Double_endorsement_evidence _) => cons 2 []
    | Single (Double_baking_evidence _) => cons 2 []
    | Single (Activate_account _) => cons 2 []
    | Single (Manager_operation _) => cons 3 []
    | Cons _ _ => cons 3 []
    end
  end.

Definition check_signature_sync {A : Type}
  (key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (function_parameter : operation A)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  match function_parameter with
  | {| shell := shell; protocol_data := protocol_data |} =>
    let check
      (watermark :
      Tezos_protocol_environment_alpha__Environment.Signature.watermark)
      (contents : packed_contents_list) (signature :
      Tezos_protocol_environment_alpha__Environment.Signature.t)
      : Tezos_protocol_environment_alpha__Environment.Pervasives.result unit
        (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
      let unsigned_operation :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
          unsigned_operation_encoding (shell, contents) in
      if
        Tezos_protocol_environment_alpha__Environment.Signature.check
          (Some watermark) key signature unsigned_operation then
        inl tt
      else
        Tezos_protocol_environment_alpha__Environment.Error_monad.error
          Invalid_signature in
    match ((contents protocol_data), (signature protocol_data)) with
    | (Single _, None) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        Missing_signature
    | (Cons _ _, None) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        Missing_signature
    | ((Single (Endorsement _)) as contents, Some signature) =>
      check (Endorsement chain_id) (Contents_list contents) signature
    | ((Single _) as contents, Some signature) =>
      check Generic_operation (Contents_list contents) signature
    | ((Cons _ _) as contents, Some signature) =>
      check Generic_operation (Contents_list contents) signature
    end
  end.

Definition check_signature {A : Type}
  (pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (op : operation A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (check_signature_sync pk chain_id op).

Definition hash_raw
  : Tezos_protocol_environment_alpha__Environment.Operation.t ->
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  Tezos_protocol_environment_alpha__Environment.Operation.hash.

Definition hash {A : Type} (o : operation A)
  : Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  let proto :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
      protocol_data_encoding (Operation_data (protocol_data o)) in
  Tezos_protocol_environment_alpha__Environment.Operation.hash
    {| shell := shell o; proto := proto |}.

Definition hash_packed (o : packed_operation)
  : Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  let proto :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
      protocol_data_encoding (protocol_data o) in
  Tezos_protocol_environment_alpha__Environment.Operation.hash
    {| shell := shell o; proto := proto |}.

Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.

Arguments Eq {_}.

Definition equal_manager_operation_kind {a b : Type}
  (op1 : manager_operation a) (op2 : manager_operation b) : option (eq a b) :=
  match (op1, op2) with
  | (Reveal _, Reveal _) => Some Eq
  | (Reveal _, _) => None
  | (Transaction _, Transaction _) => Some Eq
  | (Transaction _, _) => None
  | (Origination _, Origination _) => Some Eq
  | (Origination _, _) => None
  | (Delegation _, Delegation _) => Some Eq
  | (Delegation _, _) => None
  end.

Definition equal_contents_kind {a b : Type}
  (op1 : contents a) (op2 : contents b) : option (eq a b) :=
  match (op1, op2) with
  | (Endorsement _, Endorsement _) => Some Eq
  | (Endorsement _, _) => None
  | (Seed_nonce_revelation _, Seed_nonce_revelation _) => Some Eq
  | (Seed_nonce_revelation _, _) => None
  | (Double_endorsement_evidence _, Double_endorsement_evidence _) => Some Eq
  | (Double_endorsement_evidence _, _) => None
  | (Double_baking_evidence _, Double_baking_evidence _) => Some Eq
  | (Double_baking_evidence _, _) => None
  | (Activate_account _, Activate_account _) => Some Eq
  | (Activate_account _, _) => None
  | (Proposals _, Proposals _) => Some Eq
  | (Proposals _, _) => None
  | (Ballot _, Ballot _) => Some Eq
  | (Ballot _, _) => None
  | (Manager_operation op1, Manager_operation op2) =>
    match equal_manager_operation_kind (operation op1) (operation op2) with
    | None => None
    | Some Eq => Some Eq
    end
  | (Manager_operation _, _) => None
  end.

Fixpoint equal_contents_kind_list {a b : Type}
  (op1 : contents_list a) (op2 : contents_list b) : option (eq a b) :=
  match (op1, op2) with
  | (Single op1, Single op2) => equal_contents_kind op1 op2
  | (Single _, Cons _ _) => None
  | (Cons _ _, Single _) => None
  | (Cons op1 ops1, Cons op2 ops2) =>
    match equal_contents_kind op1 op2 with
    | None => None
    | Some Eq =>
      match equal_contents_kind_list ops1 ops2 with
      | None => None
      | Some Eq => Some Eq
      end
    end
  end.

Definition equal {a b : Type} (op1 : operation a) (op2 : operation b)
  : option (eq a b) :=
  if
    Tezos_protocol_environment_alpha__Environment.Pervasives.not
      (Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
        (hash op1) (hash op2)) then
    None
  else
    equal_contents_kind_list (contents (protocol_data op1))
      (contents (protocol_data op2)).
src/proto_alpha/lib_protocol/operation_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Operations *)

module Kind : sig
  type seed_nonce_revelation = Seed_nonce_revelation_kind

  type double_endorsement_evidence = Double_endorsement_evidence_kind

  type double_baking_evidence = Double_baking_evidence_kind

  type activate_account = Activate_account_kind

  type endorsement = Endorsement_kind

  type proposals = Proposals_kind

  type ballot = Ballot_kind

  type reveal = Reveal_kind

  type transaction = Transaction_kind

  type origination = Origination_kind

  type delegation = Delegation_kind

  type 'a manager =
    | Reveal_manager_kind : reveal manager
    | Transaction_manager_kind : transaction manager
    | Origination_manager_kind : origination manager
    | Delegation_manager_kind : delegation manager
end

type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}

val raw_encoding : raw Data_encoding.t

type 'kind operation = {
  shell : Operation.shell_header;
  protocol_data : 'kind protocol_data;
}

and 'kind protocol_data = {
  contents : 'kind contents_list;
  signature : Signature.t option;
}

and _ contents_list =
  | Single : 'kind contents -> 'kind contents_list
  | Cons :
      'kind Kind.manager contents * 'rest Kind.manager contents_list
      -> ('kind * 'rest) Kind.manager contents_list

and _ contents =
  | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents
  | Seed_nonce_revelation : {
      level : Raw_level_repr.t;
      nonce : Seed_repr.nonce;
    }
      -> Kind.seed_nonce_revelation contents
  | Double_endorsement_evidence : {
      op1 : Kind.endorsement operation;
      op2 : Kind.endorsement operation;
    }
      -> Kind.double_endorsement_evidence contents
  | Double_baking_evidence : {
      bh1 : Block_header_repr.t;
      bh2 : Block_header_repr.t;
    }
      -> Kind.double_baking_evidence contents
  | Activate_account : {
      id : Ed25519.Public_key_hash.t;
      activation_code : Blinded_public_key_hash.activation_code;
    }
      -> Kind.activate_account contents
  | Proposals : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposals : Protocol_hash.t list;
    }
      -> Kind.proposals contents
  | Ballot : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposal : Protocol_hash.t;
      ballot : Vote_repr.ballot;
    }
      -> Kind.ballot contents
  | Manager_operation : {
      source : Signature.Public_key_hash.t;
      fee : Tez_repr.tez;
      counter : counter;
      operation : 'kind manager_operation;
      gas_limit : Z.t;
      storage_limit : Z.t;
    }
      -> 'kind Kind.manager contents

and _ manager_operation =
  | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
  | Transaction : {
      amount : Tez_repr.tez;
      parameters : Script_repr.lazy_expr;
      entrypoint : string;
      destination : Contract_repr.contract;
    }
      -> Kind.transaction manager_operation
  | Origination : {
      delegate : Signature.Public_key_hash.t option;
      script : Script_repr.t;
      credit : Tez_repr.tez;
      preorigination : Contract_repr.t option;
    }
      -> Kind.origination manager_operation
  | Delegation :
      Signature.Public_key_hash.t option
      -> Kind.delegation manager_operation

and counter = Z.t

type 'kind internal_operation = {
  source : Contract_repr.contract;
  operation : 'kind manager_operation;
  nonce : int;
}

type packed_manager_operation =
  | Manager : 'kind manager_operation -> packed_manager_operation

type packed_contents = Contents : 'kind contents -> packed_contents

type packed_contents_list =
  | Contents_list : 'kind contents_list -> packed_contents_list

val of_list : packed_contents list -> packed_contents_list

val to_list : packed_contents_list -> packed_contents list

type packed_protocol_data =
  | Operation_data : 'kind protocol_data -> packed_protocol_data

type packed_operation = {
  shell : Operation.shell_header;
  protocol_data : packed_protocol_data;
}

val pack : 'kind operation -> packed_operation

type packed_internal_operation =
  | Internal_operation : 'kind internal_operation -> packed_internal_operation

val manager_kind : 'kind manager_operation -> 'kind Kind.manager

val encoding : packed_operation Data_encoding.t

val contents_encoding : packed_contents Data_encoding.t

val contents_list_encoding : packed_contents_list Data_encoding.t

val protocol_data_encoding : packed_protocol_data Data_encoding.t

val unsigned_operation_encoding :
  (Operation.shell_header * packed_contents_list) Data_encoding.t

val raw : _ operation -> raw

val hash_raw : raw -> Operation_hash.t

val hash : _ operation -> Operation_hash.t

val hash_packed : packed_operation -> Operation_hash.t

val acceptable_passes : packed_operation -> int list

type error += Missing_signature (* `Permanent *)

type error += Invalid_signature (* `Permanent *)

val check_signature :
  Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult Lwt.t

val check_signature_sync :
  Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult

val internal_operation_encoding : packed_internal_operation Data_encoding.t

type ('a, 'b) eq = Eq : ('a, 'a) eq

val equal : 'a operation -> 'b operation -> ('a, 'b) eq option

module Encoding : sig
  type 'b case =
    | Case : {
        tag : int;
        name : string;
        encoding : 'a Data_encoding.t;
        select : packed_contents -> 'b contents option;
        proj : 'b contents -> 'a;
        inj : 'a -> 'b contents;
      }
        -> 'b case

  val endorsement_case : Kind.endorsement case

  val seed_nonce_revelation_case : Kind.seed_nonce_revelation case

  val double_endorsement_evidence_case : Kind.double_endorsement_evidence case

  val double_baking_evidence_case : Kind.double_baking_evidence case

  val activate_account_case : Kind.activate_account case

  val proposals_case : Kind.proposals case

  val ballot_case : Kind.ballot case

  val reveal_case : Kind.reveal Kind.manager case

  val transaction_case : Kind.transaction Kind.manager case

  val origination_case : Kind.origination Kind.manager case

  val delegation_case : Kind.delegation Kind.manager case

  module Manager_operations : sig
    type 'b case =
      | MCase : {
          tag : int;
          name : string;
          encoding : 'a Data_encoding.t;
          select : packed_manager_operation -> 'kind manager_operation option;
          proj : 'kind manager_operation -> 'a;
          inj : 'a -> 'kind manager_operation;
        }
          -> 'kind case

    val reveal_case : Kind.reveal case

    val transaction_case : Kind.transaction case

    val origination_case : Kind.origination case

    val delegation_case : Kind.delegation case
  end
end
src/proto_alpha/lib_protocol/operation_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Kind.
  Inductive seed_nonce_revelation : Type :=
  | Seed_nonce_revelation_kind : seed_nonce_revelation.
  
  Inductive double_endorsement_evidence : Type :=
  | Double_endorsement_evidence_kind : double_endorsement_evidence.
  
  Inductive double_baking_evidence : Type :=
  | Double_baking_evidence_kind : double_baking_evidence.
  
  Inductive activate_account : Type :=
  | Activate_account_kind : activate_account.
  
  Inductive endorsement : Type :=
  | Endorsement_kind : endorsement.
  
  Inductive proposals : Type :=
  | Proposals_kind : proposals.
  
  Inductive ballot : Type :=
  | Ballot_kind : ballot.
  
  Inductive reveal : Type :=
  | Reveal_kind : reveal.
  
  Inductive transaction : Type :=
  | Transaction_kind : transaction.
  
  Inductive origination : Type :=
  | Origination_kind : origination.
  
  Inductive delegation : Type :=
  | Delegation_kind : delegation.
  
  Inductive manager : forall (a : Type), Type :=
  | Reveal_manager_kind : manager reveal
  | Transaction_manager_kind : manager transaction
  | Origination_manager_kind : manager origination
  | Delegation_manager_kind : manager delegation.
End Kind.

Record raw := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  proto : Tezos_protocol_environment_alpha__Environment.MBytes.t }.

Parameter raw_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t raw.

Reserved Notation "'counter".

Inductive contents_list : forall (_ : Type), Type :=
| Single : forall {kind : Type}, (contents kind) -> contents_list kind
| Cons : forall {kind rest : Type}, (contents (Kind.manager kind)) ->
  (contents_list (Kind.manager rest)) ->
  contents_list (Kind.manager (kind * rest))

with contents : forall (_ : Type), Type :=
| Endorsement : Tezos_raw_protocol_alpha.Raw_level_repr.t ->
  contents Kind.endorsement
| Seed_nonce_revelation : Tezos_raw_protocol_alpha.Raw_level_repr.t ->
  Tezos_raw_protocol_alpha.Seed_repr.nonce ->
  contents Kind.seed_nonce_revelation
| Double_endorsement_evidence : (operation Kind.endorsement) ->
  (operation Kind.endorsement) -> contents Kind.double_endorsement_evidence
| Double_baking_evidence : Tezos_raw_protocol_alpha.Block_header_repr.t ->
  Tezos_raw_protocol_alpha.Block_header_repr.t ->
  contents Kind.double_baking_evidence
| Activate_account :
  Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code ->
  contents Kind.activate_account
| Proposals :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Voting_period_repr.t ->
  (list
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  -> contents Kind.proposals
| Ballot :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Voting_period_repr.t ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> Tezos_raw_protocol_alpha.Vote_repr.ballot -> contents Kind.ballot
| Manager_operation : forall {kind : Type},
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Tez_repr.tez -> 'counter -> (manager_operation kind)
  -> Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  contents (Kind.manager kind)

with manager_operation : forall (_ : Type), Type :=
| Reveal : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t
  -> manager_operation Kind.reveal
| Transaction : Tezos_raw_protocol_alpha.Tez_repr.tez ->
  Tezos_raw_protocol_alpha.Script_repr.lazy_expr -> string ->
  Tezos_raw_protocol_alpha.Contract_repr.contract ->
  manager_operation Kind.transaction
| Origination :
  (option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  -> Tezos_raw_protocol_alpha.Script_repr.t ->
  Tezos_raw_protocol_alpha.Tez_repr.tez ->
  (option Tezos_raw_protocol_alpha.Contract_repr.t) ->
  manager_operation Kind.origination
| Delegation :
  (option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  -> manager_operation Kind.delegation

where "'counter" := ( Tezos_protocol_environment_alpha__Environment.Z.t).

Definition counter := 'counter.

Record internal_operation {kind : Type} := {
  source : Tezos_raw_protocol_alpha.Contract_repr.contract;
  operation : manager_operation kind;
  nonce : Z }.
Arguments internal_operation : clear implicits.

Inductive packed_manager_operation : Type :=
| Manager : forall {kind : Type}, (manager_operation kind) ->
  packed_manager_operation.

Inductive packed_contents : Type :=
| Contents : forall {kind : Type}, (contents kind) -> packed_contents.

Inductive packed_contents_list : Type :=
| Contents_list : forall {kind : Type}, (contents_list kind) ->
  packed_contents_list.

Parameter of_list : (list packed_contents) -> packed_contents_list.

Parameter to_list : packed_contents_list -> list packed_contents.

Inductive packed_protocol_data : Type :=
| Operation_data : forall {kind : Type}, (protocol_data kind) ->
  packed_protocol_data.

Record packed_operation := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  protocol_data : packed_protocol_data }.

Parameter pack : forall {kind : Type}, (operation kind) -> packed_operation.

Inductive packed_internal_operation : Type :=
| Internal_operation : forall {kind : Type}, (internal_operation kind) ->
  packed_internal_operation.

Parameter manager_kind : forall {kind : Type},
(manager_operation kind) -> Kind.manager kind.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t packed_operation.

Parameter contents_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t packed_contents.

Parameter contents_list_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  packed_contents_list.

Parameter protocol_data_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  packed_protocol_data.

Parameter unsigned_operation_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
    packed_contents_list).

Parameter raw : forall {_ : Type}, (operation _) -> raw.

Parameter hash_raw :
raw ->
  Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).

Parameter hash : forall {_ : Type},
(operation _) ->
  Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).

Parameter hash_packed :
packed_operation ->
  Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).

Parameter acceptable_passes : packed_operation -> list Z.

extensible_type

extensible_type

Parameter check_signature : forall {_ : Type},
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t ->
  Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    (operation _) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).

Parameter check_signature_sync : forall {_ : Type},
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t ->
  Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    (operation _) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.

Parameter internal_operation_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  packed_internal_operation.

Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.

Arguments Eq {_}.

Parameter equal : forall {a b : Type},
(operation a) -> (operation b) -> option (eq a b).

Module Encoding.
  Inductive case (b : Type) : Type :=
  | Case : forall {a : Type}, Z -> string ->
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
    (packed_contents -> option (contents b)) -> ((contents b) -> a) ->
    (a -> contents b) -> case b.
  
  Arguments Case {_}.
  
  Parameter endorsement_case : case Kind.endorsement.
  
  Parameter seed_nonce_revelation_case : case Kind.seed_nonce_revelation.
  
  Parameter double_endorsement_evidence_case : case
    Kind.double_endorsement_evidence.
  
  Parameter double_baking_evidence_case : case Kind.double_baking_evidence.
  
  Parameter activate_account_case : case Kind.activate_account.
  
  Parameter proposals_case : case Kind.proposals.
  
  Parameter ballot_case : case Kind.ballot.
  
  Parameter reveal_case : case (Kind.manager Kind.reveal).
  
  Parameter transaction_case : case (Kind.manager Kind.transaction).
  
  Parameter origination_case : case (Kind.manager Kind.origination).
  
  Parameter delegation_case : case (Kind.manager Kind.delegation).
  
  Module Manager_operations.
    Inductive case : forall (b : Type), Type :=
    | MCase : forall {a kind : Type}, Z -> string ->
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
      (packed_manager_operation -> option (manager_operation kind)) ->
      ((manager_operation kind) -> a) -> (a -> manager_operation kind) ->
      case kind.
    
    Parameter reveal_case : case Kind.reveal.
    
    Parameter transaction_case : case Kind.transaction.
    
    Parameter origination_case : case Kind.origination.
    
    Parameter delegation_case : case Kind.delegation.
  End Manager_operations.
End Encoding.
src/proto_alpha/lib_protocol/parameters_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type bootstrap_account = {
  public_key_hash : Signature.Public_key_hash.t;
  public_key : Signature.Public_key.t option;
  amount : Tez_repr.t;
}

type bootstrap_contract = {
  delegate : Signature.Public_key_hash.t;
  amount : Tez_repr.t;
  script : Script_repr.t;
}

type t = {
  bootstrap_accounts : bootstrap_account list;
  bootstrap_contracts : bootstrap_contract list;
  commitments : Commitment_repr.t list;
  constants : Constants_repr.parametric;
  security_deposit_ramp_up_cycles : int option;
  no_reward_cycles : int option;
}

let bootstrap_account_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Public_key_known"
        (tup2 Signature.Public_key.encoding Tez_repr.encoding)
        (function
          | {public_key_hash; public_key = Some public_key; amount} ->
              assert (
                Signature.Public_key_hash.equal
                  (Signature.Public_key.hash public_key)
                  public_key_hash ) ;
              Some (public_key, amount)
          | {public_key = None} ->
              None)
        (fun (public_key, amount) ->
          {
            public_key = Some public_key;
            public_key_hash = Signature.Public_key.hash public_key;
            amount;
          });
      case
        (Tag 1)
        ~title:"Public_key_unknown"
        (tup2 Signature.Public_key_hash.encoding Tez_repr.encoding)
        (function
          | {public_key_hash; public_key = None; amount} ->
              Some (public_key_hash, amount)
          | {public_key = Some _} ->
              None)
        (fun (public_key_hash, amount) ->
          {public_key = None; public_key_hash; amount}) ]

let bootstrap_contract_encoding =
  let open Data_encoding in
  conv
    (fun {delegate; amount; script} -> (delegate, amount, script))
    (fun (delegate, amount, script) -> {delegate; amount; script})
    (obj3
       (req "delegate" Signature.Public_key_hash.encoding)
       (req "amount" Tez_repr.encoding)
       (req "script" Script_repr.encoding))

let encoding =
  let open Data_encoding in
  conv
    (fun { bootstrap_accounts;
           bootstrap_contracts;
           commitments;
           constants;
           security_deposit_ramp_up_cycles;
           no_reward_cycles } ->
      ( ( bootstrap_accounts,
          bootstrap_contracts,
          commitments,
          security_deposit_ramp_up_cycles,
          no_reward_cycles ),
        constants ))
    (fun ( ( bootstrap_accounts,
             bootstrap_contracts,
             commitments,
             security_deposit_ramp_up_cycles,
             no_reward_cycles ),
           constants ) ->
      {
        bootstrap_accounts;
        bootstrap_contracts;
        commitments;
        constants;
        security_deposit_ramp_up_cycles;
        no_reward_cycles;
      })
    (merge_objs
       (obj5
          (req "bootstrap_accounts" (list bootstrap_account_encoding))
          (dft "bootstrap_contracts" (list bootstrap_contract_encoding) [])
          (dft "commitments" (list Commitment_repr.encoding) [])
          (opt "security_deposit_ramp_up_cycles" int31)
          (opt "no_reward_cycles" int31))
       Constants_repr.parametric_encoding)
src/proto_alpha/lib_protocol/parameters_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record bootstrap_account := {
  public_key_hash :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  public_key :
    option Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t }.

Record bootstrap_contract := {
  delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t;
  script : Tezos_raw_protocol_alpha.Script_repr.t }.

Record t := {
  bootstrap_accounts : list bootstrap_account;
  bootstrap_contracts : list bootstrap_contract;
  commitments : list Tezos_raw_protocol_alpha.Commitment_repr.t;
  constants : Tezos_raw_protocol_alpha.Constants_repr.parametric;
  security_deposit_ramp_up_cycles : option Z;
  no_reward_cycles : option Z }.

Definition bootstrap_account_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    bootstrap_account :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
    (cons
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        "Public_key_known" % string None (Tag 0)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.encoding
          Tezos_raw_protocol_alpha.Tez_repr.encoding)
        (fun function_parameter =>
          match function_parameter with
          | {|
            public_key_hash := public_key_hash;
              public_key := Some public_key;
              amount := amount
              |} =>
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
              (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                public_key) public_key_hash;
            Some (public_key, amount)
          | {| public_key := None |} => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | (public_key, amount) =>
            {|
              public_key_hash :=
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                  public_key; public_key := Some public_key; amount := amount |}
          end))
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Public_key_unknown" % string None (Tag 1)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
            Tezos_raw_protocol_alpha.Tez_repr.encoding)
          (fun function_parameter =>
            match function_parameter with
            | {|
              public_key_hash := public_key_hash;
                public_key := None;
                amount := amount
                |} => Some (public_key_hash, amount)
            | {| public_key := Some _ |} => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (public_key_hash, amount) =>
              {| public_key_hash := public_key_hash; public_key := None;
                amount := amount |}
            end)) [])).

Definition bootstrap_contract_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    bootstrap_contract :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| delegate := delegate; amount := amount; script := script |} =>
        (delegate, amount, script)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (delegate, amount, script) =>
        {| delegate := delegate; amount := amount; script := script |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "delegate" % string
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "amount" % string Tezos_raw_protocol_alpha.Tez_repr.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "script" % string Tezos_raw_protocol_alpha.Script_repr.encoding)).

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {|
        bootstrap_accounts := bootstrap_accounts;
          bootstrap_contracts := bootstrap_contracts;
          commitments := commitments;
          constants := constants;
          security_deposit_ramp_up_cycles := security_deposit_ramp_up_cycles;
          no_reward_cycles := no_reward_cycles
          |} =>
        ((bootstrap_accounts, bootstrap_contracts, commitments,
          security_deposit_ramp_up_cycles, no_reward_cycles), constants)
      end)
    (fun function_parameter =>
      match function_parameter with
      |
        ((bootstrap_accounts, bootstrap_contracts, commitments,
          security_deposit_ramp_up_cycles, no_reward_cycles), constants) =>
        {| bootstrap_accounts := bootstrap_accounts;
          bootstrap_contracts := bootstrap_contracts;
          commitments := commitments; constants := constants;
          security_deposit_ramp_up_cycles := security_deposit_ramp_up_cycles;
          no_reward_cycles := no_reward_cycles |}
      end) None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj5
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "bootstrap_accounts" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            bootstrap_account_encoding))
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "bootstrap_contracts" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            bootstrap_contract_encoding) [])
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None
          None "commitments" % string
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
            Tezos_raw_protocol_alpha.Commitment_repr.encoding) [])
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "security_deposit_ramp_up_cycles" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.int31)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt None
          None "no_reward_cycles" % string
          Tezos_protocol_environment_alpha__Environment.Data_encoding.int31))
      Tezos_raw_protocol_alpha.Constants_repr.parametric_encoding).
src/proto_alpha/lib_protocol/parameters_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type bootstrap_account = {
  public_key_hash : Signature.Public_key_hash.t;
  public_key : Signature.Public_key.t option;
  amount : Tez_repr.t;
}

type bootstrap_contract = {
  delegate : Signature.Public_key_hash.t;
  amount : Tez_repr.t;
  script : Script_repr.t;
}

type t = {
  bootstrap_accounts : bootstrap_account list;
  bootstrap_contracts : bootstrap_contract list;
  commitments : Commitment_repr.t list;
  constants : Constants_repr.parametric;
  security_deposit_ramp_up_cycles : int option;
  no_reward_cycles : int option;
}

val encoding : t Data_encoding.t
src/proto_alpha/lib_protocol/parameters_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record bootstrap_account := {
  public_key_hash :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  public_key :
    option Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t }.

Record bootstrap_contract := {
  delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t;
  script : Tezos_raw_protocol_alpha.Script_repr.t }.

Record t := {
  bootstrap_accounts : list bootstrap_account;
  bootstrap_contracts : list bootstrap_contract;
  commitments : list Tezos_raw_protocol_alpha.Commitment_repr.t;
  constants : Tezos_raw_protocol_alpha.Constants_repr.parametric;
  security_deposit_ramp_up_cycles : option Z;
  no_reward_cycles : option Z }.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t t.
src/proto_alpha/lib_protocol/period_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Int64.t

type period = t

include (Compare.Int64 : Compare.S with type t := t)

let encoding = Data_encoding.int64

let rpc_arg = RPC_arg.int64

let pp ppf v = Format.fprintf ppf "%Ld" v

type error += (* `Permanent *)
                Malformed_period | Invalid_arg

let () =
  let open Data_encoding in
  (* Malformed period *)
  register_error_kind
    `Permanent
    ~id:"malformed_period"
    ~title:"Malformed period"
    ~description:"Period is negative."
    ~pp:(fun ppf () -> Format.fprintf ppf "Malformed period")
    empty
    (function Malformed_period -> Some () | _ -> None)
    (fun () -> Malformed_period) ;
  (* Invalid arg *)
  register_error_kind
    `Permanent
    ~id:"invalid_arg"
    ~title:"Invalid arg"
    ~description:"Negative multiple of periods are not allowed."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid arg")
    empty
    (function Invalid_arg -> Some () | _ -> None)
    (fun () -> Invalid_arg)

let of_seconds t =
  if Compare.Int64.(t >= 0L) then ok t else error Malformed_period

let to_seconds t = t

let of_seconds_exn t =
  match of_seconds t with
  | Ok t ->
      t
  | _ ->
      invalid_arg "Period.of_seconds_exn"

let mult i p =
  (* TODO check overflow *)
  if Compare.Int32.(i < 0l) then error Invalid_arg
  else ok (Int64.mul (Int64.of_int32 i) p)

let zero = of_seconds_exn 0L

let one_second = of_seconds_exn 1L

let one_minute = of_seconds_exn 60L

let one_hour = of_seconds_exn 3600L
src/proto_alpha/lib_protocol/period_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_protocol_environment_alpha__Environment.Int64.t.

Definition period := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int64 :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.int64.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int64 :=
  Tezos_protocol_environment_alpha__Environment.RPC_arg.int64.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (v : int64) : unit :=
  Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        CamlinternalFormatBasics.End_of_format) "%Ld" % string) v.

Definition of_seconds
  (t :
    Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
      t 0 then
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok t
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Malformed_period.

Definition to_seconds {A : Type} (t : A) : A := t.

Definition of_seconds_exn
  (t :
    Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  match of_seconds t with
  | inl t => t
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "Period.of_seconds_exn" % string
  end.

Definition mult
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (p : int64)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      i 0 then
    Tezos_protocol_environment_alpha__Environment.Error_monad.error Invalid_arg
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      (Tezos_protocol_environment_alpha__Environment.Int64.mul
        (Tezos_protocol_environment_alpha__Environment.Int64.of_int32 i) p).

Definition zero
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  of_seconds_exn 0.

Definition one_second
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  of_seconds_exn 1.

Definition one_minute
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  of_seconds_exn 60.

Definition one_hour
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  of_seconds_exn 3600.
src/proto_alpha/lib_protocol/period_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type period = t

include Compare.S with type t := t

val encoding : period Data_encoding.t

val rpc_arg : period RPC_arg.t

val pp : Format.formatter -> period -> unit

val to_seconds : period -> int64

(** [of_second period] fails if period is not positive *)
val of_seconds : int64 -> period tzresult

(** [of_second period] fails if period is not positive.
    It should only be used at toplevel for constants. *)
val of_seconds_exn : int64 -> period

val mult : int32 -> period -> period tzresult

val zero : period

val one_second : period

val one_minute : period

val one_hour : period
src/proto_alpha/lib_protocol/period_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition period := t.

include

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t period.

Parameter rpc_arg :
Tezos_protocol_environment_alpha__Environment.RPC_arg.t period.

Parameter pp :
Tezos_protocol_environment_alpha__Environment.Format.formatter -> period -> unit.

Parameter to_seconds : period -> int64.

Parameter of_seconds :
int64 ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult period.

Parameter of_seconds_exn : int64 -> period.

Parameter mult :
int32 ->
  period ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult period.

Parameter zero : period.

Parameter one_second : period.

Parameter one_minute : period.

Parameter one_hour : period.
src/proto_alpha/lib_protocol/qty_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type QTY = sig
  val id : string
end

module type S = sig
  type qty

  type error +=
    | Addition_overflow of qty * qty (* `Temporary *)
    | Subtraction_underflow of qty * qty (* `Temporary *)
    | Multiplication_overflow of qty * int64 (* `Temporary *)
    | Negative_multiplicator of qty * int64 (* `Temporary *)
    | Invalid_divisor of qty * int64

  (* `Temporary *)

  val id : string

  val zero : qty

  val one_mutez : qty

  val one_cent : qty

  val fifty_cents : qty

  val one : qty

  val ( -? ) : qty -> qty -> qty tzresult

  val ( +? ) : qty -> qty -> qty tzresult

  val ( *? ) : qty -> int64 -> qty tzresult

  val ( /? ) : qty -> int64 -> qty tzresult

  val to_mutez : qty -> int64

  (** [of_mutez n] (micro tez) is None if n is negative *)
  val of_mutez : int64 -> qty option

  (** [of_mutez_exn n] fails if n is negative.
      It should only be used at toplevel for constants. *)
  val of_mutez_exn : int64 -> qty

  (** It should only be used at toplevel for constants. *)
  val add_exn : qty -> qty -> qty

  (** It should only be used at toplevel for constants. *)
  val mul_exn : qty -> int -> qty

  val encoding : qty Data_encoding.t

  val to_int64 : qty -> int64

  include Compare.S with type t := qty

  val pp : Format.formatter -> qty -> unit

  val of_string : string -> qty option

  val to_string : qty -> string
end

module Make (T : QTY) : S = struct
  type qty = int64 (* invariant: positive *)

  type error +=
    | Addition_overflow of qty * qty (* `Temporary *)
    | Subtraction_underflow of qty * qty (* `Temporary *)
    | Multiplication_overflow of qty * int64 (* `Temporary *)
    | Negative_multiplicator of qty * int64 (* `Temporary *)
    | Invalid_divisor of qty * int64

  (* `Temporary *)

  include Compare.Int64

  let zero = 0L

  (* all other constant are defined from the value of one micro tez *)
  let one_mutez = 1L

  let one_cent = Int64.mul one_mutez 10_000L

  let fifty_cents = Int64.mul one_cent 50L

  (* 1 tez = 100 cents = 1_000_000 mutez *)
  let one = Int64.mul one_cent 100L

  let id = T.id

  let of_string s =
    let triplets = function
      | hd :: tl ->
          let len = String.length hd in
          Compare.Int.(
            len <= 3 && len > 0
            && List.for_all (fun s -> String.length s = 3) tl)
      | [] ->
          false
    in
    let integers s = triplets (String.split_on_char ',' s) in
    let decimals s =
      let l = String.split_on_char ',' s in
      if Compare.Int.(List.length l > 2) then false else triplets (List.rev l)
    in
    let parse left right =
      let remove_commas s = String.concat "" (String.split_on_char ',' s) in
      let pad_to_six s =
        let len = String.length s in
        String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0')
      in
      try
        Some
          (Int64.of_string
             (remove_commas left ^ pad_to_six (remove_commas right)))
      with _ -> None
    in
    match String.split_on_char '.' s with
    | [left; right] ->
        if String.contains s ',' then
          if integers left && decimals right then parse left right else None
        else if
          Compare.Int.(String.length right > 0)
          && Compare.Int.(String.length right <= 6)
        then parse left right
        else None
    | [left] ->
        if (not (String.contains s ',')) || integers left then parse left ""
        else None
    | _ ->
        None

  let pp ppf amount =
    let mult_int = 1_000_000L in
    let rec left ppf amount =
      let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in
      if d > 0L then Format.fprintf ppf "%a%03Ld" left d r
      else Format.fprintf ppf "%Ld" r
    in
    let right ppf amount =
      let triplet ppf v =
        if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf "%03d" v
        else if Compare.Int.(v mod 100 > 0) then
          Format.fprintf ppf "%02d" (v / 10)
        else Format.fprintf ppf "%d" (v / 100)
      in
      let (hi, lo) = (amount / 1000, amount mod 1000) in
      if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi
      else Format.fprintf ppf "%03d%a" hi triplet lo
    in
    let (ints, decs) =
      (Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int)))
    in
    Format.fprintf ppf "%a" left ints ;
    if Compare.Int.(decs > 0) then Format.fprintf ppf ".%a" right decs

  let to_string t = Format.asprintf "%a" pp t

  let ( - ) t1 t2 = if t2 <= t1 then Some (Int64.sub t1 t2) else None

  let ( -? ) t1 t2 =
    match t1 - t2 with
    | None ->
        error (Subtraction_underflow (t1, t2))
    | Some v ->
        ok v

  let ( +? ) t1 t2 =
    let t = Int64.add t1 t2 in
    if t < t1 then error (Addition_overflow (t1, t2)) else ok t

  let ( *? ) t m =
    let open Compare.Int64 in
    let open Int64 in
    let rec step cur pow acc =
      if cur = 0L then ok acc
      else
        pow +? pow
        >>? fun npow ->
        if logand cur 1L = 1L then
          acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc
        else step (shift_right_logical cur 1) npow acc
    in
    if m < 0L then error (Negative_multiplicator (t, m))
    else
      match step m t 0L with
      | Ok res ->
          Ok res
      | Error ([Addition_overflow _] as errs) ->
          Error (Multiplication_overflow (t, m) :: errs)
      | Error errs ->
          Error errs

  let ( /? ) t d =
    if d <= 0L then error (Invalid_divisor (t, d)) else ok (Int64.div t d)

  let add_exn t1 t2 =
    let t = Int64.add t1 t2 in
    if t <= 0L then invalid_arg "add_exn" else t

  let mul_exn t m =
    match t *? Int64.(of_int m) with
    | Ok v ->
        v
    | Error _ ->
        invalid_arg "mul_exn"

  let of_mutez t = if t < 0L then None else Some t

  let of_mutez_exn x =
    match of_mutez x with None -> invalid_arg "Qty.of_mutez" | Some v -> v

  let to_int64 t = t

  let to_mutez t = t

  let encoding =
    let open Data_encoding in
    check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)

  let () =
    let open Data_encoding in
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".addition_overflow")
      ~title:("Overflowing " ^ T.id ^ " addition")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Overflowing addition of %a %s and %a %s"
          pp
          opa
          T.id
          pp
          opb
          T.id)
      ~description:("An addition of two " ^ T.id ^ " amounts overflowed")
      (obj1 (req "amounts" (tup2 encoding encoding)))
      (function Addition_overflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Addition_overflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".subtraction_underflow")
      ~title:("Underflowing " ^ T.id ^ " subtraction")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Underflowing subtraction of %a %s and %a %s"
          pp
          opa
          T.id
          pp
          opb
          T.id)
      ~description:("An subtraction of two " ^ T.id ^ " amounts underflowed")
      (obj1 (req "amounts" (tup2 encoding encoding)))
      (function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Subtraction_underflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".multiplication_overflow")
      ~title:("Overflowing " ^ T.id ^ " multiplication")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Overflowing multiplication of %a %s and %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("A multiplication of a " ^ T.id ^ " amount by an integer overflowed")
      (obj2 (req "amount" encoding) (req "multiplicator" int64))
      (function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Multiplication_overflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".negative_multiplicator")
      ~title:("Negative " ^ T.id ^ " multiplicator")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Multiplication of %a %s by negative integer %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("Multiplication of a " ^ T.id ^ " amount by a negative integer")
      (obj2 (req "amount" encoding) (req "multiplicator" int64))
      (function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Negative_multiplicator (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".invalid_divisor")
      ~title:("Invalid " ^ T.id ^ " divisor")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Division of %a %s by non positive integer %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("Multiplication of a " ^ T.id ^ " amount by a non positive integer")
      (obj2 (req "amount" encoding) (req "divisor" int64))
      (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Invalid_divisor (a, b))
end
src/proto_alpha/lib_protocol/qty_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module QTY.
  Record signature := {
    id : string;
  }.
End QTY.

Module S.
  Record signature {qty : Type} := {
    qty := qty;
    extensible_type;
    id : string;
    zero : qty;
    one_mutez : qty;
    one_cent : qty;
    fifty_cents : qty;
    one : qty;
    op_minus_question : qty ->
      qty ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
    op_plus_question : qty ->
      qty ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
    op_star_question : qty ->
      int64 ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
    op_div_question : qty ->
      int64 ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
    to_mutez : qty -> int64;
    of_mutez : int64 -> option qty;
    of_mutez_exn : int64 -> qty;
    add_exn : qty -> qty -> qty;
    mul_exn : qty -> Z -> qty;
    encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t qty;
    to_int64 : qty -> int64;
    include;
    pp : Tezos_protocol_environment_alpha__Environment.Format.formatter ->
      qty -> unit;
    of_string : string -> option qty;
    to_string : qty -> string;
  }.
  Arguments signature : clear implicits.
End S.
src/proto_alpha/lib_protocol/raw_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Int_set = Set.Make (Compare.Int)

type t = {
  context : Context.t;
  constants : Constants_repr.parametric;
  first_level : Raw_level_repr.t;
  level : Level_repr.t;
  predecessor_timestamp : Time.t;
  timestamp : Time.t;
  fitness : Int64.t;
  deposits : Tez_repr.t Signature.Public_key_hash.Map.t;
  included_endorsements : int;
  allowed_endorsements :
    (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t;
  fees : Tez_repr.t;
  rewards : Tez_repr.t;
  block_gas : Z.t;
  operation_gas : Gas_limit_repr.t;
  internal_gas : Gas_limit_repr.internal_gas;
  storage_space_to_pay : Z.t option;
  allocated_contracts : int option;
  origination_nonce : Contract_repr.origination_nonce option;
  temporary_big_map : Z.t;
  internal_nonce : int;
  internal_nonces_used : Int_set.t;
}

type context = t

type root_context = t

let current_level ctxt = ctxt.level

let predecessor_timestamp ctxt = ctxt.predecessor_timestamp

let current_timestamp ctxt = ctxt.timestamp

let current_fitness ctxt = ctxt.fitness

let first_level ctxt = ctxt.first_level

let constants ctxt = ctxt.constants

let recover ctxt = ctxt.context

let record_endorsement ctxt k =
  match Signature.Public_key_hash.Map.find_opt k ctxt.allowed_endorsements with
  | None ->
      assert false
  | Some (_, _, true) ->
      assert false (* right already used *)
  | Some (d, s, false) ->
      {
        ctxt with
        included_endorsements = ctxt.included_endorsements + List.length s;
        allowed_endorsements =
          Signature.Public_key_hash.Map.add
            k
            (d, s, true)
            ctxt.allowed_endorsements;
      }

let init_endorsements ctxt allowed_endorsements =
  if Signature.Public_key_hash.Map.is_empty allowed_endorsements then
    assert false (* can't initialize to empty *)
  else if Signature.Public_key_hash.Map.is_empty ctxt.allowed_endorsements then
    {ctxt with allowed_endorsements}
  else assert false

(* can't initialize twice *)

let allowed_endorsements ctxt = ctxt.allowed_endorsements

let included_endorsements ctxt = ctxt.included_endorsements

type error += Too_many_internal_operations (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"too_many_internal_operations"
    ~title:"Too many internal operations"
    ~description:
      "A transaction exceeded the hard limit of internal operations it can emit"
    empty
    (function Too_many_internal_operations -> Some () | _ -> None)
    (fun () -> Too_many_internal_operations)

let fresh_internal_nonce ctxt =
  if Compare.Int.(ctxt.internal_nonce >= 65_535) then
    error Too_many_internal_operations
  else
    ok
      ( {ctxt with internal_nonce = ctxt.internal_nonce + 1},
        ctxt.internal_nonce )

let reset_internal_nonce ctxt =
  {ctxt with internal_nonces_used = Int_set.empty; internal_nonce = 0}

let record_internal_nonce ctxt k =
  {ctxt with internal_nonces_used = Int_set.add k ctxt.internal_nonces_used}

let internal_nonce_already_recorded ctxt k =
  Int_set.mem k ctxt.internal_nonces_used

let set_current_fitness ctxt fitness = {ctxt with fitness}

let add_fees ctxt fees =
  Lwt.return Tez_repr.(ctxt.fees +? fees)
  >>=? fun fees -> return {ctxt with fees}

let add_rewards ctxt rewards =
  Lwt.return Tez_repr.(ctxt.rewards +? rewards)
  >>=? fun rewards -> return {ctxt with rewards}

let add_deposit ctxt delegate deposit =
  let previous =
    match Signature.Public_key_hash.Map.find_opt delegate ctxt.deposits with
    | Some tz ->
        tz
    | None ->
        Tez_repr.zero
  in
  Lwt.return Tez_repr.(previous +? deposit)
  >>=? fun deposit ->
  let deposits =
    Signature.Public_key_hash.Map.add delegate deposit ctxt.deposits
  in
  return {ctxt with deposits}

let get_deposits ctxt = ctxt.deposits

let get_rewards ctxt = ctxt.rewards

let get_fees ctxt = ctxt.fees

type error += Undefined_operation_nonce (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"undefined_operation_nonce"
    ~title:"Ill timed access to the origination nonce"
    ~description:
      "An origination was attemped out of the scope of a manager operation"
    empty
    (function Undefined_operation_nonce -> Some () | _ -> None)
    (fun () -> Undefined_operation_nonce)

let init_origination_nonce ctxt operation_hash =
  let origination_nonce =
    Some (Contract_repr.initial_origination_nonce operation_hash)
  in
  {ctxt with origination_nonce}

let origination_nonce ctxt =
  match ctxt.origination_nonce with
  | None ->
      error Undefined_operation_nonce
  | Some origination_nonce ->
      ok origination_nonce

let increment_origination_nonce ctxt =
  match ctxt.origination_nonce with
  | None ->
      error Undefined_operation_nonce
  | Some cur_origination_nonce ->
      let origination_nonce =
        Some (Contract_repr.incr_origination_nonce cur_origination_nonce)
      in
      ok ({ctxt with origination_nonce}, cur_origination_nonce)

let unset_origination_nonce ctxt = {ctxt with origination_nonce = None}

type error += Gas_limit_too_high (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"gas_limit_too_high"
    ~title:"Gas limit out of protocol hard bounds"
    ~description:"A transaction tried to exceed the hard limit on gas"
    empty
    (function Gas_limit_too_high -> Some () | _ -> None)
    (fun () -> Gas_limit_too_high)

let check_gas_limit ctxt remaining =
  if
    Compare.Z.(remaining > ctxt.constants.hard_gas_limit_per_operation)
    || Compare.Z.(remaining < Z.zero)
  then error Gas_limit_too_high
  else ok ()

let set_gas_limit ctxt remaining =
  {
    ctxt with
    operation_gas = Limited {remaining};
    internal_gas = Gas_limit_repr.internal_gas_zero;
  }

let set_gas_unlimited ctxt = {ctxt with operation_gas = Unaccounted}

let consume_gas ctxt cost =
  Gas_limit_repr.consume
    ctxt.block_gas
    ctxt.operation_gas
    ctxt.internal_gas
    cost
  >>? fun (block_gas, operation_gas, internal_gas) ->
  ok {ctxt with block_gas; operation_gas; internal_gas}

let check_enough_gas ctxt cost =
  Gas_limit_repr.check_enough
    ctxt.block_gas
    ctxt.operation_gas
    ctxt.internal_gas
    cost

let gas_level ctxt = ctxt.operation_gas

let block_gas_level ctxt = ctxt.block_gas

let gas_consumed ~since ~until =
  match (gas_level since, gas_level until) with
  | (Limited {remaining = before}, Limited {remaining = after}) ->
      Z.sub before after
  | (_, _) ->
      Z.zero

let init_storage_space_to_pay ctxt =
  match ctxt.storage_space_to_pay with
  | Some _ ->
      assert false
  | None ->
      {
        ctxt with
        storage_space_to_pay = Some Z.zero;
        allocated_contracts = Some 0;
      }

let update_storage_space_to_pay ctxt n =
  match ctxt.storage_space_to_pay with
  | None ->
      assert false
  | Some storage_space_to_pay ->
      {ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay)}

let update_allocated_contracts_count ctxt =
  match ctxt.allocated_contracts with
  | None ->
      assert false
  | Some allocated_contracts ->
      {ctxt with allocated_contracts = Some (succ allocated_contracts)}

let clear_storage_space_to_pay ctxt =
  match (ctxt.storage_space_to_pay, ctxt.allocated_contracts) with
  | (None, _) | (_, None) ->
      assert false
  | (Some storage_space_to_pay, Some allocated_contracts) ->
      ( {ctxt with storage_space_to_pay = None; allocated_contracts = None},
        storage_space_to_pay,
        allocated_contracts )

type storage_error =
  | Incompatible_protocol_version of string
  | Missing_key of string list * [`Get | `Set | `Del | `Copy]
  | Existing_key of string list
  | Corrupted_data of string list

let storage_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Incompatible_protocol_version"
        (obj1 (req "incompatible_protocol_version" string))
        (function Incompatible_protocol_version arg -> Some arg | _ -> None)
        (fun arg -> Incompatible_protocol_version arg);
      case
        (Tag 1)
        ~title:"Missing_key"
        (obj2
           (req "missing_key" (list string))
           (req
              "function"
              (string_enum
                 [("get", `Get); ("set", `Set); ("del", `Del); ("copy", `Copy)])))
        (function Missing_key (key, f) -> Some (key, f) | _ -> None)
        (fun (key, f) -> Missing_key (key, f));
      case
        (Tag 2)
        ~title:"Existing_key"
        (obj1 (req "existing_key" (list string)))
        (function Existing_key key -> Some key | _ -> None)
        (fun key -> Existing_key key);
      case
        (Tag 3)
        ~title:"Corrupted_data"
        (obj1 (req "corrupted_data" (list string)))
        (function Corrupted_data key -> Some key | _ -> None)
        (fun key -> Corrupted_data key) ]

let pp_storage_error ppf = function
  | Incompatible_protocol_version version ->
      Format.fprintf
        ppf
        "Found a context with an unexpected version '%s'."
        version
  | Missing_key (key, `Get) ->
      Format.fprintf ppf "Missing key '%s'." (String.concat "/" key)
  | Missing_key (key, `Set) ->
      Format.fprintf
        ppf
        "Cannot set undefined key '%s'."
        (String.concat "/" key)
  | Missing_key (key, `Del) ->
      Format.fprintf
        ppf
        "Cannot delete undefined key '%s'."
        (String.concat "/" key)
  | Missing_key (key, `Copy) ->
      Format.fprintf
        ppf
        "Cannot copy undefined key '%s'."
        (String.concat "/" key)
  | Existing_key key ->
      Format.fprintf
        ppf
        "Cannot initialize defined key '%s'."
        (String.concat "/" key)
  | Corrupted_data key ->
      Format.fprintf
        ppf
        "Failed to parse the data at '%s'."
        (String.concat "/" key)

type error += Storage_error of storage_error

let () =
  register_error_kind
    `Permanent
    ~id:"context.storage_error"
    ~title:"Storage error (fatal internal error)"
    ~description:
      "An error that should never happen unless something has been deleted or \
       corrupted in the database."
    ~pp:(fun ppf err ->
      Format.fprintf ppf "@[<v 2>Storage error:@ %a@]" pp_storage_error err)
    storage_error_encoding
    (function Storage_error err -> Some err | _ -> None)
    (fun err -> Storage_error err)

let storage_error err = fail (Storage_error err)

(* Initialization *********************************************************)

(* This key should always be populated for every version of the
   protocol.  It's absence meaning that the context is empty. *)
let version_key = ["version"]

let version_value = "alpha_current"

let version = "v1"

let first_level_key = [version; "first_level"]

let constants_key = [version; "constants"]

let protocol_param_key = ["protocol_parameters"]

let get_first_level ctxt =
  Context.get ctxt first_level_key
  >>= function
  | None ->
      storage_error (Missing_key (first_level_key, `Get))
  | Some bytes -> (
    match Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes with
    | None ->
        storage_error (Corrupted_data first_level_key)
    | Some level ->
        return level )

let set_first_level ctxt level =
  let bytes =
    Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level
  in
  Context.set ctxt first_level_key bytes >>= fun ctxt -> return ctxt

type error += Failed_to_parse_parameter of MBytes.t

type error += Failed_to_decode_parameter of Data_encoding.json * string

let () =
  register_error_kind
    `Temporary
    ~id:"context.failed_to_parse_parameter"
    ~title:"Failed to parse parameter"
    ~description:"The protocol parameters are not valid JSON."
    ~pp:(fun ppf bytes ->
      Format.fprintf
        ppf
        "@[<v 2>Cannot parse the protocol parameter:@ %s@]"
        (MBytes.to_string bytes))
    Data_encoding.(obj1 (req "contents" bytes))
    (function Failed_to_parse_parameter data -> Some data | _ -> None)
    (fun data -> Failed_to_parse_parameter data) ;
  register_error_kind
    `Temporary
    ~id:"context.failed_to_decode_parameter"
    ~title:"Failed to decode parameter"
    ~description:"Unexpected JSON object."
    ~pp:(fun ppf (json, msg) ->
      Format.fprintf
        ppf
        "@[<v 2>Cannot decode the protocol parameter:@ %s@ %a@]"
        msg
        Data_encoding.Json.pp
        json)
    Data_encoding.(obj2 (req "contents" json) (req "error" string))
    (function
      | Failed_to_decode_parameter (json, msg) -> Some (json, msg) | _ -> None)
    (fun (json, msg) -> Failed_to_decode_parameter (json, msg))

let get_proto_param ctxt =
  Context.get ctxt protocol_param_key
  >>= function
  | None ->
      failwith "Missing protocol parameters."
  | Some bytes -> (
    match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
    | None ->
        fail (Failed_to_parse_parameter bytes)
    | Some json -> (
        Context.del ctxt protocol_param_key
        >>= fun ctxt ->
        match Data_encoding.Json.destruct Parameters_repr.encoding json with
        | exception (Data_encoding.Json.Cannot_destruct _ as exn) ->
            Format.kasprintf
              failwith
              "Invalid protocol_parameters: %a %a"
              (fun ppf -> Data_encoding.Json.print_error ppf)
              exn
              Data_encoding.Json.pp
              json
        | param ->
            return (param, ctxt) ) )

let set_constants ctxt constants =
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      Constants_repr.parametric_encoding
      constants
  in
  Context.set ctxt constants_key bytes

let get_constants ctxt =
  Context.get ctxt constants_key
  >>= function
  | None ->
      failwith "Internal error: cannot read constants in context."
  | Some bytes -> (
    match
      Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes
    with
    | None ->
        failwith "Internal error: cannot parse constants in context."
    | Some constants ->
        return constants )

let patch_constants ctxt f =
  let constants = f ctxt.constants in
  set_constants ctxt.context constants
  >>= fun context -> Lwt.return {ctxt with context; constants}

let check_inited ctxt =
  Context.get ctxt version_key
  >>= function
  | None ->
      failwith "Internal error: un-initialized context."
  | Some bytes ->
      let s = MBytes.to_string bytes in
      if Compare.String.(s = version_value) then return_unit
      else storage_error (Incompatible_protocol_version s)

let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt =
  Lwt.return (Raw_level_repr.of_int32 level)
  >>=? fun level ->
  Lwt.return (Fitness_repr.to_int64 fitness)
  >>=? fun fitness ->
  check_inited ctxt
  >>=? fun () ->
  get_constants ctxt
  >>=? fun constants ->
  get_first_level ctxt
  >>=? fun first_level ->
  let level =
    Level_repr.from_raw
      ~first_level
      ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle
      ~blocks_per_voting_period:
        constants.Constants_repr.blocks_per_voting_period
      ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
      level
  in
  return
    {
      context = ctxt;
      constants;
      level;
      predecessor_timestamp;
      timestamp;
      fitness;
      first_level;
      allowed_endorsements = Signature.Public_key_hash.Map.empty;
      included_endorsements = 0;
      fees = Tez_repr.zero;
      rewards = Tez_repr.zero;
      deposits = Signature.Public_key_hash.Map.empty;
      operation_gas = Unaccounted;
      internal_gas = Gas_limit_repr.internal_gas_zero;
      storage_space_to_pay = None;
      allocated_contracts = None;
      block_gas = constants.Constants_repr.hard_gas_limit_per_block;
      origination_nonce = None;
      temporary_big_map = Z.sub Z.zero Z.one;
      internal_nonce = 0;
      internal_nonces_used = Int_set.empty;
    }

type previous_protocol = Genesis of Parameters_repr.t | Alpha_previous

let check_and_update_protocol_version ctxt =
  Context.get ctxt version_key
  >>= (function
        | None ->
            failwith
              "Internal error: un-initialized context in check_first_block."
        | Some bytes ->
            let s = MBytes.to_string bytes in
            if Compare.String.(s = version_value) then
              failwith "Internal error: previously initialized context."
            else if Compare.String.(s = "genesis") then
              get_proto_param ctxt
              >>=? fun (param, ctxt) -> return (Genesis param, ctxt)
            else if Compare.String.(s = "alpha_previous") then
              return (Alpha_previous, ctxt)
            else storage_error (Incompatible_protocol_version s))
  >>=? fun (previous_proto, ctxt) ->
  Context.set ctxt version_key (MBytes.of_string version_value)
  >>= fun ctxt -> return (previous_proto, ctxt)

let prepare_first_block ~level ~timestamp ~fitness ctxt =
  check_and_update_protocol_version ctxt
  >>=? fun (previous_proto, ctxt) ->
  ( match previous_proto with
  | Genesis param ->
      Lwt.return (Raw_level_repr.of_int32 level)
      >>=? fun first_level ->
      set_first_level ctxt first_level
      >>=? fun ctxt ->
      set_constants ctxt param.constants >>= fun ctxt -> return ctxt
  | Alpha_previous ->
      return ctxt )
  >>=? fun ctxt ->
  prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness
  >>=? fun ctxt -> return (previous_proto, ctxt)

let activate ({context = c; _} as s) h =
  Updater.activate c h >>= fun c -> Lwt.return {s with context = c}

let fork_test_chain ({context = c; _} as s) protocol expiration =
  Updater.fork_test_chain c ~protocol ~expiration
  >>= fun c -> Lwt.return {s with context = c}

(* Generic context ********************************************************)

type key = string list

type value = MBytes.t

module type T = sig
  type t

  type context = t

  val mem : context -> key -> bool Lwt.t

  val dir_mem : context -> key -> bool Lwt.t

  val get : context -> key -> value tzresult Lwt.t

  val get_option : context -> key -> value option Lwt.t

  val init : context -> key -> value -> context tzresult Lwt.t

  val set : context -> key -> value -> context tzresult Lwt.t

  val init_set : context -> key -> value -> context Lwt.t

  val set_option : context -> key -> value option -> context Lwt.t

  val delete : context -> key -> context tzresult Lwt.t

  val remove : context -> key -> context Lwt.t

  val remove_rec : context -> key -> context Lwt.t

  val copy : context -> from:key -> to_:key -> context tzresult Lwt.t

  val fold :
    context ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val keys : context -> key -> key list Lwt.t

  val fold_keys :
    context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val project : context -> root_context

  val absolute_key : context -> key -> key

  val consume_gas : context -> Gas_limit_repr.cost -> context tzresult

  val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult

  val description : context Storage_description.t
end

let mem ctxt k = Context.mem ctxt.context k

let dir_mem ctxt k = Context.dir_mem ctxt.context k

let get ctxt k =
  Context.get ctxt.context k
  >>= function
  | None -> storage_error (Missing_key (k, `Get)) | Some v -> return v

let get_option ctxt k = Context.get ctxt.context k

(* Verify that the k is present before modifying *)
let set ctxt k v =
  Context.mem ctxt.context k
  >>= function
  | false ->
      storage_error (Missing_key (k, `Set))
  | true ->
      Context.set ctxt.context k v
      >>= fun context -> return {ctxt with context}

(* Verify that the k is not present before inserting *)
let init ctxt k v =
  Context.mem ctxt.context k
  >>= function
  | true ->
      storage_error (Existing_key k)
  | false ->
      Context.set ctxt.context k v
      >>= fun context -> return {ctxt with context}

(* Does not verify that the key is present or not *)
let init_set ctxt k v =
  Context.set ctxt.context k v
  >>= fun context -> Lwt.return {ctxt with context}

(* Verify that the key is present before deleting *)
let delete ctxt k =
  Context.mem ctxt.context k
  >>= function
  | false ->
      storage_error (Missing_key (k, `Del))
  | true ->
      Context.del ctxt.context k >>= fun context -> return {ctxt with context}

(* Do not verify before deleting *)
let remove ctxt k =
  Context.del ctxt.context k >>= fun context -> Lwt.return {ctxt with context}

let set_option ctxt k = function
  | None ->
      remove ctxt k
  | Some v ->
      init_set ctxt k v

let remove_rec ctxt k =
  Context.remove_rec ctxt.context k
  >>= fun context -> Lwt.return {ctxt with context}

let copy ctxt ~from ~to_ =
  Context.copy ctxt.context ~from ~to_
  >>= function
  | None ->
      storage_error (Missing_key (from, `Copy))
  | Some context ->
      return {ctxt with context}

let fold ctxt k ~init ~f = Context.fold ctxt.context k ~init ~f

let keys ctxt k = Context.keys ctxt.context k

let fold_keys ctxt k ~init ~f = Context.fold_keys ctxt.context k ~init ~f

let project x = x

let absolute_key _ k = k

let description = Storage_description.create ()

let fresh_temporary_big_map ctxt =
  ( {ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one},
    ctxt.temporary_big_map )

let reset_temporary_big_map ctxt =
  {ctxt with temporary_big_map = Z.sub Z.zero Z.one}

let temporary_big_maps ctxt f acc =
  let rec iter acc id =
    if Z.equal id ctxt.temporary_big_map then Lwt.return acc
    else f acc id >>= fun acc -> iter acc (Z.sub id Z.one)
  in
  iter acc (Z.sub Z.zero Z.one)
src/proto_alpha/lib_protocol/raw_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  context : Tezos_protocol_environment_alpha__Environment.Context.t;
  constants : Tezos_raw_protocol_alpha.Constants_repr.parametric;
  first_level : Tezos_raw_protocol_alpha.Raw_level_repr.t;
  level : Tezos_raw_protocol_alpha.Level_repr.t;
  predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t;
  timestamp : Tezos_protocol_environment_alpha__Environment.Time.t;
  fitness : Tezos_protocol_environment_alpha__Environment.Int64.t;
  deposits :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      Tezos_raw_protocol_alpha.Tez_repr.t;
  included_endorsements : Z;
  allowed_endorsements :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
        (list Z) * bool);
  fees : Tezos_raw_protocol_alpha.Tez_repr.t;
  rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
  block_gas : Tezos_protocol_environment_alpha__Environment.Z.t;
  operation_gas : Tezos_raw_protocol_alpha.Gas_limit_repr.t;
  internal_gas : Tezos_raw_protocol_alpha.Gas_limit_repr.internal_gas;
  storage_space_to_pay :
    option Tezos_protocol_environment_alpha__Environment.Z.t;
  allocated_contracts : option Z;
  origination_nonce :
    option Tezos_raw_protocol_alpha.Contract_repr.origination_nonce;
  temporary_big_map : Tezos_protocol_environment_alpha__Environment.Z.t;
  internal_nonce : Z;
  internal_nonces_used :
    Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.t) }.

Definition context := t.

Definition root_context := t.

Definition current_level (ctxt : t) : Tezos_raw_protocol_alpha.Level_repr.t :=
  level ctxt.

Definition predecessor_timestamp (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Time.t :=
  predecessor_timestamp ctxt.

Definition current_timestamp (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Time.t := timestamp ctxt.

Definition current_fitness (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Int64.t := fitness ctxt.

Definition first_level (ctxt : t) : Tezos_raw_protocol_alpha.Raw_level_repr.t :=
  first_level ctxt.

Definition constants (ctxt : t)
  : Tezos_raw_protocol_alpha.Constants_repr.parametric := constants ctxt.

Definition recover (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Context.t := context ctxt.

Definition record_endorsement
  (ctxt : t)
  (k :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key)
  : t :=
  match
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.find_opt
      k (allowed_endorsements ctxt) with
  | None => false
  | Some (_, _, true) => false
  | Some (d, s, false) => record
  end.

Definition init_endorsements
  (ctxt : t)
  (allowed_endorsements :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
        (list Z) * bool)) : t :=
  if
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.is_empty
      allowed_endorsements then
    false
  else
    if
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.is_empty
        (allowed_endorsements ctxt) then
      record
    else
      false.

Definition allowed_endorsements (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
      (list Z) * bool) := allowed_endorsements ctxt.

Definition included_endorsements (ctxt : t) : Z := included_endorsements ctxt.

Definition fresh_internal_nonce (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (t * Z) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
      (internal_nonce ctxt) 65535 then
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Too_many_internal_operations
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      (record, (internal_nonce ctxt)).

Definition reset_internal_nonce (ctxt : t) : t := record.

Definition record_internal_nonce
  (ctxt : t)
  (k : Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.elt)) : t :=
  record.

Definition internal_nonce_already_recorded
  (ctxt : t)
  (k : Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.elt))
  : bool :=
  Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.mem) k
    (internal_nonces_used ctxt).

Definition set_current_fitness
  (ctxt : t) (fitness : Tezos_protocol_environment_alpha__Environment.Int64.t)
  : t := record.

Definition add_fees (ctxt : t) (fees : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question (fees ctxt) fees))
    (fun fees =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return record).

Definition add_rewards
  (ctxt : t) (rewards : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question (rewards ctxt) rewards))
    (fun rewards =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return record).

Definition add_deposit
  (ctxt : t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key)
  (deposit : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  let previous :=
    match
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.find_opt
        delegate (deposits ctxt) with
    | Some tz => tz
    | None => Tezos_raw_protocol_alpha.Tez_repr.zero
    end in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question previous deposit))
    (fun deposit =>
      let deposits :=
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.add
          delegate deposit (deposits ctxt) in
      Tezos_protocol_environment_alpha__Environment.Error_monad._return record).

Definition get_deposits (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    Tezos_raw_protocol_alpha.Tez_repr.t := deposits ctxt.

Definition get_rewards (ctxt : t) : Tezos_raw_protocol_alpha.Tez_repr.t :=
  rewards ctxt.

Definition get_fees (ctxt : t) : Tezos_raw_protocol_alpha.Tez_repr.t :=
  fees ctxt.

Definition init_origination_nonce
  (ctxt : t)
  (operation_hash :
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : t :=
  let origination_nonce :=
    Some
      (Tezos_raw_protocol_alpha.Contract_repr.initial_origination_nonce
        operation_hash) in
  record.

Definition origination_nonce (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_raw_protocol_alpha.Contract_repr.origination_nonce :=
  match origination_nonce ctxt with
  | None =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Undefined_operation_nonce
  | Some origination_nonce =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      origination_nonce
  end.

Definition increment_origination_nonce (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (t * Tezos_raw_protocol_alpha.Contract_repr.origination_nonce) :=
  match origination_nonce ctxt with
  | None =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Undefined_operation_nonce
  | Some cur_origination_nonce =>
    let origination_nonce :=
      Some
        (Tezos_raw_protocol_alpha.Contract_repr.incr_origination_nonce
          cur_origination_nonce) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      (record, cur_origination_nonce)
  end.

Definition unset_origination_nonce (ctxt : t) : t := record.

Definition check_gas_limit
  (ctxt : t)
  (remaining :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  if
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
      (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        remaining (hard_gas_limit_per_operation (constants ctxt)))
      (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
        remaining Tezos_protocol_environment_alpha__Environment.Z.zero) then
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Gas_limit_too_high
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt.

Definition set_gas_limit
  (ctxt : t) (remaining : Tezos_protocol_environment_alpha__Environment.Z.t)
  : t := record.

Definition set_gas_unlimited (ctxt : t) : t := record.

Definition consume_gas
  (ctxt : t) (cost : Tezos_raw_protocol_alpha.Gas_limit_repr.cost)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_raw_protocol_alpha.Gas_limit_repr.consume (block_gas ctxt)
      (operation_gas ctxt) (internal_gas ctxt) cost)
    (fun function_parameter =>
      match function_parameter with
      | (block_gas, operation_gas, internal_gas) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.ok record
      end).

Definition check_enough_gas
  (ctxt : t) (cost : Tezos_raw_protocol_alpha.Gas_limit_repr.cost)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  Tezos_raw_protocol_alpha.Gas_limit_repr.check_enough (block_gas ctxt)
    (operation_gas ctxt) (internal_gas ctxt) cost.

Definition gas_level (ctxt : t) : Tezos_raw_protocol_alpha.Gas_limit_repr.t :=
  operation_gas ctxt.

Definition block_gas_level (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := block_gas ctxt.

Definition gas_consumed (since : t) (until : t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  match ((gas_level since), (gas_level until)) with
  | (Limited {| remaining := before |}, Limited {| remaining := after |}) =>
    Tezos_protocol_environment_alpha__Environment.Z.sub before after
  | (_, _) => Tezos_protocol_environment_alpha__Environment.Z.zero
  end.

Definition init_storage_space_to_pay (ctxt : t) : t :=
  match storage_space_to_pay ctxt with
  | Some _ => false
  | None => record
  end.

Definition update_storage_space_to_pay
  (ctxt : t) (n : Tezos_protocol_environment_alpha__Environment.Z.t) : t :=
  match storage_space_to_pay ctxt with
  | None => false
  | Some storage_space_to_pay => record
  end.

Definition update_allocated_contracts_count (ctxt : t) : t :=
  match allocated_contracts ctxt with
  | None => false
  | Some allocated_contracts => record
  end.

Definition clear_storage_space_to_pay (ctxt : t)
  : t * Tezos_protocol_environment_alpha__Environment.Z.t * Z :=
  match ((storage_space_to_pay ctxt), (allocated_contracts ctxt)) with
  | (None, _) | (_, None) => false
  | (Some storage_space_to_pay, Some allocated_contracts) =>
    (record, storage_space_to_pay, allocated_contracts)
  end.

Inductive storage_error : Type :=
| Incompatible_protocol_version : string -> storage_error
| Missing_key : (list string) -> variant -> storage_error
| Existing_key : (list string) -> storage_error
| Corrupted_data : (list string) -> storage_error.

Definition storage_error_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    storage_error :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
    (cons
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        "Incompatible_protocol_version" % string None (Tag 0)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "incompatible_protocol_version" % string
            Tezos_protocol_environment_alpha__Environment.Data_encoding.string))
        (fun function_parameter =>
          match function_parameter with
          | Incompatible_protocol_version arg => Some arg
          | _ => None
          end) (fun arg => Incompatible_protocol_version arg))
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Missing_key" % string None (Tag 1)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "missing_key" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                None
                Tezos_protocol_environment_alpha__Environment.Data_encoding.string))
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
              None None "function" % string
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.string_enum
                (cons ("get" % string, variant)
                  (cons ("set" % string, variant)
                    (cons ("del" % string, variant)
                      (cons ("copy" % string, variant) [])))))))
          (fun function_parameter =>
            match function_parameter with
            | Missing_key key f => Some (key, f)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (key, f) => Missing_key key f
            end))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "Existing_key" % string None (Tag 2)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                None None "existing_key" % string
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                  None
                  Tezos_protocol_environment_alpha__Environment.Data_encoding.string)))
            (fun function_parameter =>
              match function_parameter with
              | Existing_key key => Some key
              | _ => None
              end) (fun key => Existing_key key))
          (cons
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
              "Corrupted_data" % string None (Tag 3)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.req
                  None None "corrupted_data" % string
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                    None
                    Tezos_protocol_environment_alpha__Environment.Data_encoding.string)))
              (fun function_parameter =>
                match function_parameter with
                | Corrupted_data key => Some key
                | _ => None
                end) (fun key => Corrupted_data key)) [])))).

Definition pp_storage_error
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : storage_error) : unit :=
  match function_parameter with
  | Incompatible_protocol_version version =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Found a context with an unexpected version '" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'." % string
              CamlinternalFormatBasics.End_of_format)))
        "Found a context with an unexpected version '%s'." % string) version
  | Missing_key key Get =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Missing key '" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'." % string
              CamlinternalFormatBasics.End_of_format)))
        "Missing key '%s'." % string)
      (Tezos_protocol_environment_alpha__Environment.String.concat "/" % string
        key)
  | Missing_key key Set =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Cannot set undefined key '" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'." % string
              CamlinternalFormatBasics.End_of_format)))
        "Cannot set undefined key '%s'." % string)
      (Tezos_protocol_environment_alpha__Environment.String.concat "/" % string
        key)
  | Missing_key key Del =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Cannot delete undefined key '" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'." % string
              CamlinternalFormatBasics.End_of_format)))
        "Cannot delete undefined key '%s'." % string)
      (Tezos_protocol_environment_alpha__Environment.String.concat "/" % string
        key)
  | Missing_key key Copy =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Cannot copy undefined key '" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'." % string
              CamlinternalFormatBasics.End_of_format)))
        "Cannot copy undefined key '%s'." % string)
      (Tezos_protocol_environment_alpha__Environment.String.concat "/" % string
        key)
  | Existing_key key =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Cannot initialize defined key '" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'." % string
              CamlinternalFormatBasics.End_of_format)))
        "Cannot initialize defined key '%s'." % string)
      (Tezos_protocol_environment_alpha__Environment.String.concat "/" % string
        key)
  | Corrupted_data key =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to parse the data at '" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "'." % string
              CamlinternalFormatBasics.End_of_format)))
        "Failed to parse the data at '%s'." % string)
      (Tezos_protocol_environment_alpha__Environment.String.concat "/" % string
        key)
  end.

Definition storage_error {A : Type} (err : storage_error)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
    (Storage_error err).

Definition version_key : list string := cons "version" % string [].

Definition version_value : string := "alpha_current" % string.

Definition version : string := "v1" % string.

Definition first_level_key : list string :=
  cons version (cons "first_level" % string []).

Definition constants_key : list string :=
  cons version (cons "constants" % string []).

Definition protocol_param_key : list string :=
  cons "protocol_parameters" % string [].

Definition get_first_level
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_level_repr.raw_level) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.get ctxt
      first_level_key)
    (fun function_parameter =>
      match function_parameter with
      | None => storage_error (Missing_key first_level_key variant)
      | Some bytes =>
        match
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
            Tezos_raw_protocol_alpha.Raw_level_repr.encoding string with
        | None => storage_error (Corrupted_data first_level_key)
        | Some level =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            level
        end
      end).

Definition set_first_level
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Context.t) :=
  let bytes :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
      Tezos_raw_protocol_alpha.Raw_level_repr.encoding level in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.set ctxt
      first_level_key string)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt).

Definition get_proto_param
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Parameters_repr.t *
        Tezos_protocol_environment_alpha__Environment.Context.t)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.get ctxt
      protocol_param_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
          "Missing protocol parameters." % string
      | Some bytes =>
        match
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
            Tezos_protocol_environment_alpha__Environment.Data_encoding.json
            string with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Failed_to_parse_parameter string)
        | Some json =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_protocol_environment_alpha__Environment.Context.del ctxt
              protocol_param_key)
            (fun ctxt =>
              match
                Tezos_protocol_environment_alpha__Environment.Data_encoding.Json.destruct
                  Tezos_raw_protocol_alpha.Parameters_repr.encoding json with
              | param =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (param, ctxt)
              end)
        end
      end).

Definition set_constants
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (constants : Tezos_raw_protocol_alpha.Constants_repr.parametric)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    Tezos_protocol_environment_alpha__Environment.Context.t :=
  let bytes :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
      Tezos_raw_protocol_alpha.Constants_repr.parametric_encoding constants in
  Tezos_protocol_environment_alpha__Environment.Context.set ctxt constants_key
    string.

Definition get_constants
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Constants_repr.parametric) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.get ctxt
      constants_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
          "Internal error: cannot read constants in context." % string
      | Some bytes =>
        match
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
            Tezos_raw_protocol_alpha.Constants_repr.parametric_encoding string
          with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
            "Internal error: cannot parse constants in context." % string
        | Some constants =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            constants
        end
      end).

Definition patch_constants
  (ctxt : t)
  (f :
    Tezos_raw_protocol_alpha.Constants_repr.parametric ->
      Tezos_raw_protocol_alpha.Constants_repr.parametric)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  let constants := f (constants ctxt) in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (set_constants (context ctxt) constants)
    (fun context =>
      Tezos_protocol_environment_alpha__Environment.Lwt._return record).

Definition check_inited
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.get ctxt version_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
          "Internal error: un-initialized context." % string
      | Some bytes =>
        let s :=
          Tezos_protocol_environment_alpha__Environment.MBytes.to_string string
          in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            s version_value then
          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
        else
          storage_error (Incompatible_protocol_version s)
      end).

Definition prepare
  (level : int32)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (fitness : list Tezos_protocol_environment_alpha__Environment.MBytes.t)
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Raw_level_repr.of_int32 level))
    (fun level =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Fitness_repr.to_int64 fitness))
        (fun fitness =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (check_inited ctxt)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (get_constants ctxt)
                  (fun constants =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (get_first_level ctxt)
                      (fun first_level =>
                        let level :=
                          Tezos_raw_protocol_alpha.Level_repr.from_raw
                            first_level
                            (Constants_repr.blocks_per_cycle constants)
                            (Constants_repr.blocks_per_voting_period constants)
                            (Constants_repr.blocks_per_commitment constants)
                            level in
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          {| context := ctxt; constants := constants;
                            first_level := first_level; level := level;
                            predecessor_timestamp := predecessor_timestamp;
                            timestamp := timestamp; fitness := fitness;
                            deposits :=
                              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.empty;
                            included_endorsements := 0;
                            allowed_endorsements :=
                              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.empty;
                            fees := Tezos_raw_protocol_alpha.Tez_repr.zero;
                            rewards := Tezos_raw_protocol_alpha.Tez_repr.zero;
                            block_gas :=
                              Constants_repr.hard_gas_limit_per_block constants;
                            operation_gas := Unaccounted;
                            internal_gas :=
                              Tezos_raw_protocol_alpha.Gas_limit_repr.internal_gas_zero;
                            storage_space_to_pay := None;
                            allocated_contracts := None;
                            origination_nonce := None;
                            temporary_big_map :=
                              Tezos_protocol_environment_alpha__Environment.Z.sub
                                Tezos_protocol_environment_alpha__Environment.Z.zero
                                Tezos_protocol_environment_alpha__Environment.Z.one;
                            internal_nonce := 0;
                            internal_nonces_used :=
                              Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.empty)
                            |}))
              end))).

Inductive previous_protocol : Type :=
| Genesis : Tezos_raw_protocol_alpha.Parameters_repr.t -> previous_protocol
| Alpha_previous : previous_protocol.

Definition check_and_update_protocol_version
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (previous_protocol *
        Tezos_protocol_environment_alpha__Environment.Context.t)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
      (Tezos_protocol_environment_alpha__Environment.Context.get ctxt
        version_key)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
            "Internal error: un-initialized context in check_first_block." %
              string
        | Some bytes =>
          let s :=
            Tezos_protocol_environment_alpha__Environment.MBytes.to_string
              string in
          if
            Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              s version_value then
            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
              "Internal error: previously initialized context." % string
          else
            if
              Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                s "genesis" % string then
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (get_proto_param ctxt)
                (fun function_parameter =>
                  match function_parameter with
                  | (param, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      ((Genesis param), ctxt)
                  end)
            else
              if
                Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  s "alpha_previous" % string then
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (Alpha_previous, ctxt)
              else
                storage_error (Incompatible_protocol_version s)
        end))
    (fun function_parameter =>
      match function_parameter with
      | (previous_proto, ctxt) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
          (Tezos_protocol_environment_alpha__Environment.Context.set ctxt
            version_key
            (Tezos_protocol_environment_alpha__Environment.MBytes.of_string
              version_value))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (previous_proto, ctxt))
      end).

Definition prepare_first_block
  (level : int32)
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (fitness : list Tezos_protocol_environment_alpha__Environment.MBytes.t)
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (previous_protocol * t)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (check_and_update_protocol_version ctxt)
    (fun function_parameter =>
      match function_parameter with
      | (previous_proto, ctxt) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          match previous_proto with
          | Genesis param =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Raw_level_repr.of_int32 level))
              (fun first_level =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (set_first_level ctxt first_level)
                  (fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                      (set_constants ctxt (constants param))
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          ctxt)))
          | Alpha_previous =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ctxt
          end
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (prepare level timestamp timestamp fitness ctxt)
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (previous_proto, ctxt)))
      end).

Definition activate (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    -> Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  match function_parameter with
  | {| context := c |} as s =>
    fun h =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (Tezos_protocol_environment_alpha__Environment.Updater.activate c h)
        (fun c =>
          Tezos_protocol_environment_alpha__Environment.Lwt._return record)
  end.

Definition fork_test_chain (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_alpha__Environment.Time.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  match function_parameter with
  | {| context := c |} as s =>
    fun protocol =>
      fun expiration =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
          (Tezos_protocol_environment_alpha__Environment.Updater.fork_test_chain
            c protocol expiration)
          (fun c =>
            Tezos_protocol_environment_alpha__Environment.Lwt._return record)
  end.

Definition key := list string.

Definition value := Tezos_protocol_environment_alpha__Environment.MBytes.t.

Module T.
  Record signature {t : Type} := {
    t := t;
    context := t;
    mem : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    dir_mem : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    get : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            value);
    get_option : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t (option value);
    init : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context);
    set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context);
    init_set : context ->
      key ->
        value -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    set_option : context ->
      key ->
        (option value) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    delete : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context);
    remove : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    remove_rec : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    copy : context ->
      key ->
        key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context);
    fold : forall {a variant : Type}, context ->
      key ->
        a ->
          (variant -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a)
            -> Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    keys : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
    fold_keys : forall {a : Type}, context ->
      key ->
        a ->
          (key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    project : context -> root_context;
    absolute_key : context -> key -> key;
    consume_gas : context ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context;
    check_enough_gas : context ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit;
    description : Tezos_raw_protocol_alpha.Storage_description.t context;
  }.
  Arguments signature : clear implicits.
End T.

Definition mem
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
  Tezos_protocol_environment_alpha__Environment.Context.mem (context ctxt) k.

Definition dir_mem
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
  Tezos_protocol_environment_alpha__Environment.Context.dir_mem (context ctxt) k.

Definition get
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Context.value) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.get (context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | None => storage_error (Missing_key k variant)
      | Some v =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return v
      end).

Definition get_option
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (option Tezos_protocol_environment_alpha__Environment.Context.value) :=
  Tezos_protocol_environment_alpha__Environment.Context.get (context ctxt) k.

Definition set
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (v : Tezos_protocol_environment_alpha__Environment.Context.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.mem (context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | false => storage_error (Missing_key k variant)
      | true =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
          (Tezos_protocol_environment_alpha__Environment.Context.set
            (context ctxt) k v)
          (fun context =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              record)
      end).

Definition init
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (v : Tezos_protocol_environment_alpha__Environment.Context.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.mem (context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | true => storage_error (Existing_key k)
      | false =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
          (Tezos_protocol_environment_alpha__Environment.Context.set
            (context ctxt) k v)
          (fun context =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              record)
      end).

Definition init_set
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (v : Tezos_protocol_environment_alpha__Environment.Context.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.set (context ctxt) k
      v)
    (fun context =>
      Tezos_protocol_environment_alpha__Environment.Lwt._return record).

Definition delete
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.mem (context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | false => storage_error (Missing_key k variant)
      | true =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
          (Tezos_protocol_environment_alpha__Environment.Context.del
            (context ctxt) k)
          (fun context =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              record)
      end).

Definition remove
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.del (context ctxt) k)
    (fun context =>
      Tezos_protocol_environment_alpha__Environment.Lwt._return record).

Definition set_option
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (function_parameter :
    option Tezos_protocol_environment_alpha__Environment.Context.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  match function_parameter with
  | None => remove ctxt k
  | Some v => init_set ctxt k v
  end.

Definition remove_rec
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.remove_rec
      (context ctxt) k)
    (fun context =>
      Tezos_protocol_environment_alpha__Environment.Lwt._return record).

Definition copy
  (ctxt : t) (from : Tezos_protocol_environment_alpha__Environment.Context.key)
  (to_ : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_alpha__Environment.Context.copy (context ctxt)
      from to_)
    (fun function_parameter =>
      match function_parameter with
      | None => storage_error (Missing_key from variant)
      | Some context =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return record
      end).

Definition fold {A : Type}
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (init : A)
  (f : variant -> A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
  Tezos_protocol_environment_alpha__Environment.Context.fold (context ctxt) k
    init f.

Definition keys
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list Tezos_protocol_environment_alpha__Environment.Context.key) :=
  Tezos_protocol_environment_alpha__Environment.Context.keys (context ctxt) k.

Definition fold_keys {A : Type}
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (init : A)
  (f :
    Tezos_protocol_environment_alpha__Environment.Context.key ->
      A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
  Tezos_protocol_environment_alpha__Environment.Context.fold_keys (context ctxt)
    k init f.

Definition project {A : Type} (x : A) : A := x.

Definition absolute_key {A B : Type} (function_parameter : A) : B -> B :=
  match function_parameter with
  | _ => fun k => k
  end.

Definition description {A : Type}
  : Tezos_raw_protocol_alpha.Storage_description.t A :=
  Tezos_raw_protocol_alpha.Storage_description.create tt.

Definition fresh_temporary_big_map (ctxt : t)
  : t * Tezos_protocol_environment_alpha__Environment.Z.t :=
  (record, (temporary_big_map ctxt)).

Definition reset_temporary_big_map (ctxt : t) : t := record.

Definition temporary_big_maps {A : Type}
  (ctxt : t)
  (f :
    A ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t A) (acc : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
  let fix iter
    (acc : A) (id : Tezos_protocol_environment_alpha__Environment.Z.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
    if
      Tezos_protocol_environment_alpha__Environment.Z.equal id
        (temporary_big_map ctxt) then
      Tezos_protocol_environment_alpha__Environment.Lwt._return acc
    else
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (f acc id)
        (fun acc =>
          iter acc
            (Tezos_protocol_environment_alpha__Environment.Z.sub id
              Tezos_protocol_environment_alpha__Environment.Z.one)) in
  iter acc
    (Tezos_protocol_environment_alpha__Environment.Z.sub
      Tezos_protocol_environment_alpha__Environment.Z.zero
      Tezos_protocol_environment_alpha__Environment.Z.one).
src/proto_alpha/lib_protocol/raw_context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {1 Errors} *)

type error += Too_many_internal_operations (* `Permanent *)

(** An internal storage error that should not happen *)
type storage_error =
  | Incompatible_protocol_version of string
  | Missing_key of string list * [`Get | `Set | `Del | `Copy]
  | Existing_key of string list
  | Corrupted_data of string list

type error += Storage_error of storage_error

type error += Failed_to_parse_parameter of MBytes.t

type error += Failed_to_decode_parameter of Data_encoding.json * string

val storage_error : storage_error -> 'a tzresult Lwt.t

(** {1 Abstract Context} *)

(** Abstract view of the context.
    Includes a handle to the functional key-value database
    ({!Context.t}) along with some in-memory values (gas, etc.). *)
type t

type context = t

type root_context = t

(** Retrieves the state of the database and gives its abstract view.
    It also returns wether this is the first block validated
    with this version of the protocol. *)
val prepare :
  level:Int32.t ->
  predecessor_timestamp:Time.t ->
  timestamp:Time.t ->
  fitness:Fitness.t ->
  Context.t ->
  context tzresult Lwt.t

type previous_protocol = Genesis of Parameters_repr.t | Alpha_previous

val prepare_first_block :
  level:int32 ->
  timestamp:Time.t ->
  fitness:Fitness.t ->
  Context.t ->
  (previous_protocol * context) tzresult Lwt.t

val activate : context -> Protocol_hash.t -> t Lwt.t

val fork_test_chain : context -> Protocol_hash.t -> Time.t -> t Lwt.t

(** Returns the state of the database resulting of operations on its
    abstract view *)
val recover : context -> Context.t

val current_level : context -> Level_repr.t

val predecessor_timestamp : context -> Time.t

val current_timestamp : context -> Time.t

val current_fitness : context -> Int64.t

val set_current_fitness : context -> Int64.t -> t

val constants : context -> Constants_repr.parametric

val patch_constants :
  context ->
  (Constants_repr.parametric -> Constants_repr.parametric) ->
  context Lwt.t

val first_level : context -> Raw_level_repr.t

(** Increment the current block fee stash that will be credited to baker's
    frozen_fees account at finalize_application *)
val add_fees : context -> Tez_repr.t -> context tzresult Lwt.t

(** Increment the current block reward stash that will be credited to baker's
    frozen_fees account at finalize_application *)
val add_rewards : context -> Tez_repr.t -> context tzresult Lwt.t

(** Increment the current block deposit stash for a specific delegate. All the
    delegates' frozen_deposit accounts are credited at finalize_application *)
val add_deposit :
  context ->
  Signature.Public_key_hash.t ->
  Tez_repr.t ->
  context tzresult Lwt.t

val get_fees : context -> Tez_repr.t

val get_rewards : context -> Tez_repr.t

val get_deposits : context -> Tez_repr.t Signature.Public_key_hash.Map.t

type error += Gas_limit_too_high (* `Permanent *)

val check_gas_limit : t -> Z.t -> unit tzresult

val set_gas_limit : t -> Z.t -> t

val set_gas_unlimited : t -> t

val gas_level : t -> Gas_limit_repr.t

val gas_consumed : since:t -> until:t -> Z.t

val block_gas_level : t -> Z.t

val init_storage_space_to_pay : t -> t

val update_storage_space_to_pay : t -> Z.t -> t

val update_allocated_contracts_count : t -> t

val clear_storage_space_to_pay : t -> t * Z.t * int

type error += Undefined_operation_nonce (* `Permanent *)

val init_origination_nonce : t -> Operation_hash.t -> t

val origination_nonce : t -> Contract_repr.origination_nonce tzresult

val increment_origination_nonce :
  t -> (t * Contract_repr.origination_nonce) tzresult

val unset_origination_nonce : t -> t

(** {1 Generic accessors} *)

type key = string list

type value = MBytes.t

(** All context manipulation functions. This signature is included
    as-is for direct context accesses, and used in {!Storage_functors}
    to provide restricted views to the context. *)
module type T = sig
  type t

  type context = t

  (** Tells if the key is already defined as a value. *)
  val mem : context -> key -> bool Lwt.t

  (** Tells if the key is already defined as a directory. *)
  val dir_mem : context -> key -> bool Lwt.t

  (** Retrieve the value from the storage bucket ; returns a
      {!Storage_error Missing_key} if the key is not set. *)
  val get : context -> key -> value tzresult Lwt.t

  (** Retrieves the value from the storage bucket ; returns [None] if
      the data is not initialized. *)
  val get_option : context -> key -> value option Lwt.t

  (** Allocates the storage bucket and initializes it ; returns a
      {!Storage_error Existing_key} if the bucket exists. *)
  val init : context -> key -> value -> context tzresult Lwt.t

  (** Updates the content of the bucket ; returns a {!Storage_error
      Missing_key} if the value does not exists. *)
  val set : context -> key -> value -> context tzresult Lwt.t

  (** Allocates the data and initializes it with a value ; just
      updates it if the bucket exists. *)
  val init_set : context -> key -> value -> context Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists. *)
  val set_option : context -> key -> value option -> context Lwt.t

  (** Delete the storage bucket ; returns a {!Storage_error
      Missing_key} if the bucket does not exists. *)
  val delete : context -> key -> context tzresult Lwt.t

  (** Removes the storage bucket and its contents ; does nothing if the
      bucket does not exists. *)
  val remove : context -> key -> context Lwt.t

  (** Recursively removes all the storage buckets and contents ; does
      nothing if no bucket exists. *)
  val remove_rec : context -> key -> context Lwt.t

  val copy : context -> from:key -> to_:key -> context tzresult Lwt.t

  (** Iterator on all the items of a given directory. *)
  val fold :
    context ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  (** Recursively list all subkeys of a given key. *)
  val keys : context -> key -> key list Lwt.t

  (** Recursive iterator on all the subkeys of a given key. *)
  val fold_keys :
    context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  (** Internally used in {!Storage_functors} to escape from a view. *)
  val project : context -> root_context

  (** Internally used in {!Storage_functors} to retrieve a full key
      from partial key relative a view. *)
  val absolute_key : context -> key -> key

  (** Internally used in {!Storage_functors} to consume gas from
      within a view. *)
  val consume_gas : context -> Gas_limit_repr.cost -> context tzresult

  (** Check if consume_gas will fail *)
  val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult

  val description : context Storage_description.t
end

include T with type t := t and type context := context

(** Initialize the local nonce used for preventing a script to
    duplicate an internal operation to replay it. *)
val reset_internal_nonce : context -> context

(** Increments the internal operation nonce. *)
val fresh_internal_nonce : context -> (context * int) tzresult

(** Mark an internal operation nonce as taken. *)
val record_internal_nonce : context -> int -> context

(** Check is the internal operation nonce has been taken. *)
val internal_nonce_already_recorded : context -> int -> bool

(** Returns a map where to each endorser's pkh is associated the list of its
    endorsing slots (in decreasing order) for a given level. *)
val allowed_endorsements :
  context ->
  (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t

(** Keep track of the number of endorsements that are included in a block *)
val included_endorsements : context -> int

(** Initializes the map of allowed endorsements, this function must only be
    called once. *)
val init_endorsements :
  context ->
  (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ->
  context

(** Marks an endorsment in the map as used. *)
val record_endorsement : context -> Signature.Public_key_hash.t -> context

(** Provide a fresh identifier for a temporary big map (negative index). *)
val fresh_temporary_big_map : context -> context * Z.t

(** Reset the temporary big_map identifier generator to [-1]. *)
val reset_temporary_big_map : context -> context

(** Iterate over all created temporary big maps since the last {!reset_temporary_big_map}. *)
val temporary_big_maps : context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t
src/proto_alpha/lib_protocol/raw_context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

Inductive storage_error : Type :=
| Incompatible_protocol_version : string -> storage_error
| Missing_key : (list string) -> variant -> storage_error
| Existing_key : (list string) -> storage_error
| Corrupted_data : (list string) -> storage_error.

extensible_type

extensible_type

extensible_type

Parameter storage_error : forall {a : Type},
storage_error ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult a).

Parameter t : Type.

Definition context := t.

Definition root_context := t.

Parameter prepare :
Tezos_protocol_environment_alpha__Environment.Int32.t ->
  Tezos_protocol_environment_alpha__Environment.Time.t ->
    Tezos_protocol_environment_alpha__Environment.Time.t ->
      Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t)
        ->
        Tezos_protocol_environment_alpha__Environment.Context.t ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context).

Inductive previous_protocol : Type :=
| Genesis : Tezos_raw_protocol_alpha.Parameters_repr.t -> previous_protocol
| Alpha_previous : previous_protocol.

Parameter prepare_first_block :
int32 ->
  Tezos_protocol_environment_alpha__Environment.Time.t ->
    Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t)
      ->
      Tezos_protocol_environment_alpha__Environment.Context.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (previous_protocol * context)).

Parameter activate :
context ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    -> Tezos_protocol_environment_alpha__Environment.Lwt.t t.

Parameter fork_test_chain :
context ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_alpha__Environment.Time.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t t.

Parameter recover :
context -> Tezos_protocol_environment_alpha__Environment.Context.t.

Parameter current_level : context -> Tezos_raw_protocol_alpha.Level_repr.t.

Parameter predecessor_timestamp :
context -> Tezos_protocol_environment_alpha__Environment.Time.t.

Parameter current_timestamp :
context -> Tezos_protocol_environment_alpha__Environment.Time.t.

Parameter current_fitness :
context -> Tezos_protocol_environment_alpha__Environment.Int64.t.

Parameter set_current_fitness :
context -> Tezos_protocol_environment_alpha__Environment.Int64.t -> t.

Parameter constants :
context -> Tezos_raw_protocol_alpha.Constants_repr.parametric.

Parameter patch_constants :
context ->
  (Tezos_raw_protocol_alpha.Constants_repr.parametric ->
    Tezos_raw_protocol_alpha.Constants_repr.parametric) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t context.

Parameter first_level : context -> Tezos_raw_protocol_alpha.Raw_level_repr.t.

Parameter add_fees :
context ->
  Tezos_raw_protocol_alpha.Tez_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        context).

Parameter add_rewards :
context ->
  Tezos_raw_protocol_alpha.Tez_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        context).

Parameter add_deposit :
context ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context).

Parameter get_fees : context -> Tezos_raw_protocol_alpha.Tez_repr.t.

Parameter get_rewards : context -> Tezos_raw_protocol_alpha.Tez_repr.t.

Parameter get_deposits :
context ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    Tezos_raw_protocol_alpha.Tez_repr.t.

extensible_type

Parameter check_gas_limit :
t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.

Parameter set_gas_limit :
t -> Tezos_protocol_environment_alpha__Environment.Z.t -> t.

Parameter set_gas_unlimited : t -> t.

Parameter gas_level : t -> Tezos_raw_protocol_alpha.Gas_limit_repr.t.

Parameter gas_consumed :
t -> t -> Tezos_protocol_environment_alpha__Environment.Z.t.

Parameter block_gas_level :
t -> Tezos_protocol_environment_alpha__Environment.Z.t.

Parameter init_storage_space_to_pay : t -> t.

Parameter update_storage_space_to_pay :
t -> Tezos_protocol_environment_alpha__Environment.Z.t -> t.

Parameter update_allocated_contracts_count : t -> t.

Parameter clear_storage_space_to_pay :
t -> t * Tezos_protocol_environment_alpha__Environment.Z.t * Z.

extensible_type

Parameter init_origination_nonce :
t ->
  Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    -> t.

Parameter origination_nonce :
t ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_raw_protocol_alpha.Contract_repr.origination_nonce.

Parameter increment_origination_nonce :
t ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (t * Tezos_raw_protocol_alpha.Contract_repr.origination_nonce).

Parameter unset_origination_nonce : t -> t.

Definition key := list string.

Definition value := Tezos_protocol_environment_alpha__Environment.MBytes.t.

module_type

include

Parameter reset_internal_nonce : context -> context.

Parameter fresh_internal_nonce :
context ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (context * Z).

Parameter record_internal_nonce : context -> Z -> context.

Parameter internal_nonce_already_recorded : context -> Z -> bool.

Parameter allowed_endorsements :
context ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
      (list Z) * bool).

Parameter included_endorsements : context -> Z.

Parameter init_endorsements :
context ->
  (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
      (list Z) * bool)) -> context.

Parameter record_endorsement :
context ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    context.

Parameter fresh_temporary_big_map :
context -> context * Tezos_protocol_environment_alpha__Environment.Z.t.

Parameter reset_temporary_big_map : context -> context.

Parameter temporary_big_maps : forall {a : Type},
context ->
  (a ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
    a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a.
src/proto_alpha/lib_protocol/raw_level_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type raw_level = t

include (Compare.Int32 : Compare.S with type t := t)

let encoding = Data_encoding.int32

let pp ppf level = Format.fprintf ppf "%ld" level

let rpc_arg =
  let construct raw_level = Int32.to_string raw_level in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse level"
    | raw_level ->
        Ok raw_level
  in
  RPC_arg.make
    ~descr:"A level integer"
    ~name:"block_level"
    ~construct
    ~destruct
    ()

let root = 0l

let succ = Int32.succ

let pred l = if l = 0l then None else Some (Int32.pred l)

let diff = Int32.sub

let to_int32 l = l

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.of_int32"

type error += Unexpected_level of Int32.t (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"unexpected_level"
    ~title:"Unexpected level"
    ~description:"Level must be non-negative."
    ~pp:(fun ppf l ->
      Format.fprintf
        ppf
        "The level is %s but should be non-negative."
        (Int32.to_string l))
    Data_encoding.(obj1 (req "level" int32))
    (function Unexpected_level l -> Some l | _ -> None)
    (fun l -> Unexpected_level l)

let of_int32 l = try Ok (of_int32_exn l) with _ -> error (Unexpected_level l)

module Index = struct
  type t = raw_level

  let path_length = 1

  let to_path level l = Int32.to_string level :: l

  let of_path = function
    | [s] -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
src/proto_alpha/lib_protocol/raw_level_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := int32.

Definition raw_level := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.int32.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (level : int32) : unit :=
  Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        CamlinternalFormatBasics.End_of_format) "%ld" % string) level.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
  let construct (raw_level : int32) : string :=
    Tezos_protocol_environment_alpha__Environment.Int32.to_string raw_level in
  let destruct (str : string)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
      string :=
    match Tezos_protocol_environment_alpha__Environment.Int32.of_string str with
    | raw_level => inl raw_level
    end in
  Tezos_protocol_environment_alpha__Environment.RPC_arg.make
    (Some "A level integer" % string) "block_level" % string destruct construct
    tt.

Definition root : int32 := 0.

Definition succ : int32 -> int32 :=
  Tezos_protocol_environment_alpha__Environment.Int32.succ.

Definition pred (l : t) : option int32 :=
  if op_eq l 0 then
    None
  else
    Some (Tezos_protocol_environment_alpha__Environment.Int32.pred l).

Definition diff : int32 -> int32 -> int32 :=
  Tezos_protocol_environment_alpha__Environment.Int32.sub.

Definition to_int32 {A : Type} (l : A) : A := l.

Definition of_int32_exn
  (l :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
      l 0 then
    l
  else
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "Level_repr.of_int32" % string.

Definition of_int32
  (l :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Pervasives.result
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
    (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
  try.

Module Index.
  Definition t := raw_level.
  
  Definition path_length : Z := 1.
  
  Definition to_path (level : int32) (l : list string) : list string :=
    cons (Tezos_protocol_environment_alpha__Environment.Int32.to_string level) l.
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons s [] => try
    | _ => None
    end.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
    encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.
src/proto_alpha/lib_protocol/raw_level_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The shell's notion of a level: an integer indicating the number of blocks
    since genesis: genesis is 0, all other blocks have increasing levels from
    there. *)
type t

type raw_level = t

val encoding : raw_level Data_encoding.t

val rpc_arg : raw_level RPC_arg.arg

val pp : Format.formatter -> raw_level -> unit

include Compare.S with type t := raw_level

val to_int32 : raw_level -> int32

val of_int32_exn : int32 -> raw_level

val of_int32 : int32 -> raw_level tzresult

val diff : raw_level -> raw_level -> int32

val root : raw_level

val succ : raw_level -> raw_level

val pred : raw_level -> raw_level option

module Index : Storage_description.INDEX with type t = raw_level
src/proto_alpha/lib_protocol/raw_level_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition raw_level := t.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t raw_level.

Parameter rpc_arg :
Tezos_protocol_environment_alpha__Environment.RPC_arg.arg raw_level.

Parameter pp :
Tezos_protocol_environment_alpha__Environment.Format.formatter ->
  raw_level -> unit.

include

Parameter to_int32 : raw_level -> int32.

Parameter of_int32_exn : int32 -> raw_level.

Parameter of_int32 :
int32 ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult raw_level.

Parameter diff : raw_level -> raw_level -> int32.

Parameter root : raw_level.

Parameter succ : raw_level -> raw_level.

Parameter pred : raw_level -> option raw_level.

unhandled_module
src/proto_alpha/lib_protocol/roll_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Compare.Int32

type roll = t

let encoding = Data_encoding.int32

let first = 0l

let succ i = Int32.succ i

let random sequence ~bound = Seed_repr.take_int32 sequence bound

let rpc_arg = RPC_arg.like RPC_arg.int32 "roll"

let to_int32 v = v

module Index = struct
  type t = roll

  let path_length = 3

  let to_path roll l =
    (Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff))
    :: ( Int32.to_string
       @@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff)
       )
    :: Int32.to_string roll :: l

  let of_path = function
    | _ :: _ :: s :: _ -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
src/proto_alpha/lib_protocol/roll_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition roll := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.int32.

Definition first : int32 := 0.

Definition succ (i : int32) : int32 :=
  Tezos_protocol_environment_alpha__Environment.Int32.succ i.

Definition random
  (sequence : Tezos_raw_protocol_alpha.Seed_repr.sequence) (bound : int32)
  : int32 * Tezos_raw_protocol_alpha.Seed_repr.sequence :=
  Tezos_raw_protocol_alpha.Seed_repr.take_int32 sequence bound.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
  Tezos_protocol_environment_alpha__Environment.RPC_arg.like
    Tezos_protocol_environment_alpha__Environment.RPC_arg.int32 None
    "roll" % string.

Definition to_int32 {A : Type} (v : A) : A := v.

Module Index.
  Definition t := roll.
  
  Definition path_length : Z := 3.
  
  Definition to_path (roll : int32) (l : list string) : list string :=
    cons
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Int32.to_string
        (Tezos_protocol_environment_alpha__Environment.Int32.logand roll
          (Tezos_protocol_environment_alpha__Environment.Int32.of_int 255)))
      (cons
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Int32.to_string
          (Tezos_protocol_environment_alpha__Environment.Int32.logand
            (Tezos_protocol_environment_alpha__Environment.Int32.shift_right_logical
              roll 8)
            (Tezos_protocol_environment_alpha__Environment.Int32.of_int 255)))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Int32.to_string roll) l)).
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons _ (cons _ (cons s _)) => try
    | _ => None
    end.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
    encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.
src/proto_alpha/lib_protocol/roll_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = private int32

type roll = t

val encoding : roll Data_encoding.t

val rpc_arg : roll RPC_arg.t

val random : Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence

val first : roll

val succ : roll -> roll

val to_int32 : roll -> Int32.t

val ( = ) : roll -> roll -> bool

module Index : Storage_description.INDEX with type t = roll
src/proto_alpha/lib_protocol/roll_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := int32.

Definition roll := t.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t roll.

Parameter rpc_arg :
Tezos_protocol_environment_alpha__Environment.RPC_arg.t roll.

Parameter random :
Tezos_raw_protocol_alpha.Seed_repr.sequence ->
  roll -> roll * Tezos_raw_protocol_alpha.Seed_repr.sequence.

Parameter first : roll.

Parameter succ : roll -> roll.

Parameter to_int32 :
roll -> Tezos_protocol_environment_alpha__Environment.Int32.t.

Parameter op_eq : roll -> roll -> bool.

unhandled_module
src/proto_alpha/lib_protocol/roll_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

type error +=
  | Consume_roll_change (* `Permanent *)
  | No_roll_for_delegate (* `Permanent *)
  | No_roll_snapshot_for_cycle of Cycle_repr.t (* `Permanent *)
  | Unregistered_delegate of Signature.Public_key_hash.t

(* `Permanent *)

let () =
  let open Data_encoding in
  (* Consume roll change *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.consume_roll_change"
    ~title:"Consume roll change"
    ~description:"Change is not enough to consume a roll."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Not enough change to consume a roll.")
    empty
    (function Consume_roll_change -> Some () | _ -> None)
    (fun () -> Consume_roll_change) ;
  (* No roll for delegate *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.no_roll_for_delegate"
    ~title:"No roll for delegate"
    ~description:"Delegate has no roll."
    ~pp:(fun ppf () -> Format.fprintf ppf "Delegate has no roll.")
    empty
    (function No_roll_for_delegate -> Some () | _ -> None)
    (fun () -> No_roll_for_delegate) ;
  (* No roll snapshot for cycle *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.no_roll_snapshot_for_cycle"
    ~title:"No roll snapshot for cycle"
    ~description:
      "A snapshot of the rolls distribution does not exist for this cycle."
    ~pp:(fun ppf c ->
      Format.fprintf
        ppf
        "A snapshot of the rolls distribution does not exist for cycle %a"
        Cycle_repr.pp
        c)
    (obj1 (req "cycle" Cycle_repr.encoding))
    (function No_roll_snapshot_for_cycle c -> Some c | _ -> None)
    (fun c -> No_roll_snapshot_for_cycle c) ;
  (* Unregistered delegate *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.unregistered_delegate"
    ~title:"Unregistered delegate"
    ~description:"A contract cannot be delegated to an unregistered delegate"
    ~pp:(fun ppf k ->
      Format.fprintf
        ppf
        "The provided public key (with hash %a) is  not registered as valid \
         delegate key."
        Signature.Public_key_hash.pp
        k)
    (obj1 (req "hash" Signature.Public_key_hash.encoding))
    (function Unregistered_delegate k -> Some k | _ -> None)
    (fun k -> Unregistered_delegate k)

let get_contract_delegate c contract =
  Storage.Contract.Delegate.get_option c contract

let delegate_pubkey ctxt delegate =
  Storage.Contract.Manager.get_option
    ctxt
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | None | Some (Manager_repr.Hash _) ->
      fail (Unregistered_delegate delegate)
  | Some (Manager_repr.Public_key pk) ->
      return pk

let clear_cycle c cycle =
  Storage.Roll.Snapshot_for_cycle.get c cycle
  >>=? fun index ->
  Storage.Roll.Snapshot_for_cycle.delete c cycle
  >>=? fun c ->
  Storage.Roll.Last_for_snapshot.delete (c, cycle) index
  >>=? fun c ->
  Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c -> return c

let fold ctxt ~f init =
  Storage.Roll.Next.get ctxt
  >>=? fun last ->
  let rec loop ctxt roll acc =
    acc
    >>=? fun acc ->
    if Roll_repr.(roll = last) then return acc
    else
      Storage.Roll.Owner.get_option ctxt roll
      >>=? function
      | None ->
          loop ctxt (Roll_repr.succ roll) (return acc)
      | Some delegate ->
          loop ctxt (Roll_repr.succ roll) (f roll delegate acc)
  in
  loop ctxt Roll_repr.first (return init)

let snapshot_rolls_for_cycle ctxt cycle =
  Storage.Roll.Snapshot_for_cycle.get ctxt cycle
  >>=? fun index ->
  Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1)
  >>=? fun ctxt ->
  Storage.Roll.Owner.snapshot ctxt (cycle, index)
  >>=? fun ctxt ->
  Storage.Roll.Next.get ctxt
  >>=? fun last ->
  Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last
  >>=? fun ctxt -> return ctxt

let freeze_rolls_for_cycle ctxt cycle =
  Storage.Roll.Snapshot_for_cycle.get ctxt cycle
  >>=? fun max_index ->
  Storage.Seed.For_cycle.get ctxt cycle
  >>=? fun seed ->
  let rd = Seed_repr.initialize_new seed [MBytes.of_string "roll_snapshot"] in
  let seq = Seed_repr.sequence rd 0l in
  let selected_index =
    Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int
  in
  Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index
  >>=? fun ctxt ->
  fold_left_s
    (fun ctxt index ->
      if Compare.Int.(index = selected_index) then return ctxt
      else
        Storage.Roll.Owner.delete_snapshot ctxt (cycle, index)
        >>= fun ctxt ->
        Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index
        >>=? fun ctxt -> return ctxt)
    ctxt
    Misc.(0 --> (max_index - 1))
  >>=? fun ctxt -> return ctxt

(* Roll selection *)

module Random = struct
  let int32_to_bytes i =
    let b = MBytes.create 4 in
    MBytes.set_int32 b 0 i ; b

  let level_random seed use level =
    let position = level.Level_repr.cycle_position in
    Seed_repr.initialize_new
      seed
      [MBytes.of_string ("level " ^ use ^ ":"); int32_to_bytes position]

  let owner c kind level offset =
    let cycle = level.Level_repr.cycle in
    Seed_storage.for_cycle c cycle
    >>=? fun random_seed ->
    let rd = level_random random_seed kind level in
    let sequence = Seed_repr.sequence rd (Int32.of_int offset) in
    Storage.Roll.Snapshot_for_cycle.get c cycle
    >>=? fun index ->
    Storage.Roll.Last_for_snapshot.get (c, cycle) index
    >>=? fun bound ->
    let rec loop sequence =
      let (roll, sequence) = Roll_repr.random sequence ~bound in
      Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll)
      >>=? function None -> loop sequence | Some delegate -> return delegate
    in
    Storage.Roll.Owner.snapshot_exists c (cycle, index)
    >>= fun snapshot_exists ->
    fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle)
    >>=? fun () -> loop sequence
end

let baking_rights_owner c level ~priority =
  Random.owner c "baking" level priority

let endorsement_rights_owner c level ~slot =
  Random.owner c "endorsement" level slot

let traverse_rolls ctxt head =
  let rec loop acc roll =
    Storage.Roll.Successor.get_option ctxt roll
    >>=? function
    | None -> return (List.rev acc) | Some next -> loop (next :: acc) next
  in
  loop [head] head

let get_rolls ctxt delegate =
  Storage.Roll.Delegate_roll_list.get_option ctxt delegate
  >>=? function
  | None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll

let count_rolls ctxt delegate =
  Storage.Roll.Delegate_roll_list.get_option ctxt delegate
  >>=? function
  | None ->
      return 0
  | Some head_roll ->
      let rec loop acc roll =
        Storage.Roll.Successor.get_option ctxt roll
        >>=? function None -> return acc | Some next -> loop (succ acc) next
      in
      loop 1 head_roll

let get_change c delegate =
  Storage.Roll.Delegate_change.get_option c delegate
  >>=? function None -> return Tez_repr.zero | Some change -> return change

module Delegate = struct
  let fresh_roll c =
    Storage.Roll.Next.get c
    >>=? fun roll ->
    Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> return (roll, c)

  let get_limbo_roll c =
    Storage.Roll.Limbo.get_option c
    >>=? function
    | None ->
        fresh_roll c
        >>=? fun (roll, c) ->
        Storage.Roll.Limbo.init c roll >>=? fun c -> return (roll, c)
    | Some roll ->
        return (roll, c)

  let consume_roll_change c delegate =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    trace Consume_roll_change (Lwt.return Tez_repr.(change -? tokens_per_roll))
    >>=? fun new_change ->
    Storage.Roll.Delegate_change.set c delegate new_change

  let recover_roll_change c delegate =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    Lwt.return Tez_repr.(change +? tokens_per_roll)
    >>=? fun new_change ->
    Storage.Roll.Delegate_change.set c delegate new_change

  let pop_roll_from_delegate c delegate =
    recover_roll_change c delegate
    >>=? fun c ->
    (* beginning:
       delegate : roll -> successor_roll -> ...
       limbo : limbo_head -> ...
    *)
    Storage.Roll.Limbo.get_option c
    >>=? fun limbo_head ->
    Storage.Roll.Delegate_roll_list.get_option c delegate
    >>=? function
    | None ->
        fail No_roll_for_delegate
    | Some roll ->
        Storage.Roll.Owner.delete c roll
        >>=? fun c ->
        Storage.Roll.Successor.get_option c roll
        >>=? fun successor_roll ->
        Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll
        >>= fun c ->
        (* delegate : successor_roll -> ...
           roll ------^
           limbo : limbo_head -> ... *)
        Storage.Roll.Successor.set_option c roll limbo_head
        >>= fun c ->
        (* delegate : successor_roll -> ...
           roll ------v
           limbo : limbo_head -> ... *)
        Storage.Roll.Limbo.init_set c roll
        >>= fun c ->
        (* delegate : successor_roll -> ...
           limbo : roll -> limbo_head -> ... *)
        return (roll, c)

  let create_roll_in_delegate c delegate delegate_pk =
    consume_roll_change c delegate
    >>=? fun c ->
    (* beginning:
       delegate : delegate_head -> ...
       limbo : roll -> limbo_successor -> ...
    *)
    Storage.Roll.Delegate_roll_list.get_option c delegate
    >>=? fun delegate_head ->
    get_limbo_roll c
    >>=? fun (roll, c) ->
    Storage.Roll.Owner.init c roll delegate_pk
    >>=? fun c ->
    Storage.Roll.Successor.get_option c roll
    >>=? fun limbo_successor ->
    Storage.Roll.Limbo.set_option c limbo_successor
    >>= fun c ->
    (* delegate : delegate_head -> ...
       roll ------v
       limbo : limbo_successor -> ... *)
    Storage.Roll.Successor.set_option c roll delegate_head
    >>= fun c ->
    (* delegate : delegate_head -> ...
       roll ------^
       limbo : limbo_successor -> ... *)
    Storage.Roll.Delegate_roll_list.init_set c delegate roll
    >>= fun c ->
    (* delegate : roll -> delegate_head -> ...
       limbo : limbo_successor -> ... *)
    return c

  let ensure_inited c delegate =
    Storage.Roll.Delegate_change.mem c delegate
    >>= function
    | true ->
        return c
    | false ->
        Storage.Roll.Delegate_change.init c delegate Tez_repr.zero

  let is_inactive c delegate =
    Storage.Contract.Inactive_delegate.mem
      c
      (Contract_repr.implicit_contract delegate)
    >>= fun inactive ->
    if inactive then return inactive
    else
      Storage.Contract.Delegate_desactivation.get_option
        c
        (Contract_repr.implicit_contract delegate)
      >>=? function
      | Some last_active_cycle ->
          let {Level_repr.cycle = current_cycle} =
            Raw_context.current_level c
          in
          return Cycle_repr.(last_active_cycle < current_cycle)
      | None ->
          (* This case is only when called from `set_active`, when creating
             a contract. *)
          return_false

  let add_amount c delegate amount =
    ensure_inited c delegate
    >>=? fun c ->
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    Lwt.return Tez_repr.(amount +? change)
    >>=? fun change ->
    Storage.Roll.Delegate_change.set c delegate change
    >>=? fun c ->
    delegate_pubkey c delegate
    >>=? fun delegate_pk ->
    let rec loop c change =
      if Tez_repr.(change < tokens_per_roll) then return c
      else
        Lwt.return Tez_repr.(change -? tokens_per_roll)
        >>=? fun change ->
        create_roll_in_delegate c delegate delegate_pk
        >>=? fun c -> loop c change
    in
    is_inactive c delegate
    >>=? fun inactive ->
    if inactive then return c
    else
      loop c change
      >>=? fun c ->
      Storage.Roll.Delegate_roll_list.get_option c delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          return c
      | Some _ ->
          Storage.Active_delegates_with_rolls.add c delegate
          >>= fun c -> return c

  let remove_amount c delegate amount =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    let rec loop c change =
      if Tez_repr.(amount <= change) then return (c, change)
      else
        pop_roll_from_delegate c delegate
        >>=? fun (_, c) ->
        Lwt.return Tez_repr.(change +? tokens_per_roll)
        >>=? fun change -> loop c change
    in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    is_inactive c delegate
    >>=? fun inactive ->
    ( if inactive then return (c, change)
    else
      loop c change
      >>=? fun (c, change) ->
      Storage.Roll.Delegate_roll_list.get_option c delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          Storage.Active_delegates_with_rolls.del c delegate
          >>= fun c -> return (c, change)
      | Some _ ->
          return (c, change) )
    >>=? fun (c, change) ->
    Lwt.return Tez_repr.(change -? amount)
    >>=? fun change -> Storage.Roll.Delegate_change.set c delegate change

  let set_inactive ctxt delegate =
    ensure_inited ctxt delegate
    >>=? fun ctxt ->
    let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
    Storage.Roll.Delegate_change.get ctxt delegate
    >>=? fun change ->
    Storage.Contract.Inactive_delegate.add
      ctxt
      (Contract_repr.implicit_contract delegate)
    >>= fun ctxt ->
    Storage.Active_delegates_with_rolls.del ctxt delegate
    >>= fun ctxt ->
    let rec loop ctxt change =
      Storage.Roll.Delegate_roll_list.get_option ctxt delegate
      >>=? function
      | None ->
          return (ctxt, change)
      | Some _roll ->
          pop_roll_from_delegate ctxt delegate
          >>=? fun (_, ctxt) ->
          Lwt.return Tez_repr.(change +? tokens_per_roll)
          >>=? fun change -> loop ctxt change
    in
    loop ctxt change
    >>=? fun (ctxt, change) ->
    Storage.Roll.Delegate_change.set ctxt delegate change
    >>=? fun ctxt -> return ctxt

  let set_active ctxt delegate =
    is_inactive ctxt delegate
    >>=? fun inactive ->
    let current_cycle = (Raw_context.current_level ctxt).cycle in
    let preserved_cycles = Constants_storage.preserved_cycles ctxt in
    (* When the delegate is new or inactive, she will become active in
       `1+preserved_cycles`, and we allow `preserved_cycles` for the
       delegate to start baking. When the delegate is active, we only
       give her at least `preserved_cycles` after the current cycle
       before to be deactivated.  *)
    Storage.Contract.Delegate_desactivation.get_option
      ctxt
      (Contract_repr.implicit_contract delegate)
    >>=? fun current_expiration ->
    let expiration =
      match current_expiration with
      | None ->
          Cycle_repr.add current_cycle (1 + (2 * preserved_cycles))
      | Some current_expiration ->
          let delay =
            if inactive then 1 + (2 * preserved_cycles)
            else 1 + preserved_cycles
          in
          let updated = Cycle_repr.add current_cycle delay in
          Cycle_repr.max current_expiration updated
    in
    Storage.Contract.Delegate_desactivation.init_set
      ctxt
      (Contract_repr.implicit_contract delegate)
      expiration
    >>= fun ctxt ->
    if not inactive then return ctxt
    else
      ensure_inited ctxt delegate
      >>=? fun ctxt ->
      let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
      Storage.Roll.Delegate_change.get ctxt delegate
      >>=? fun change ->
      Storage.Contract.Inactive_delegate.del
        ctxt
        (Contract_repr.implicit_contract delegate)
      >>= fun ctxt ->
      delegate_pubkey ctxt delegate
      >>=? fun delegate_pk ->
      let rec loop ctxt change =
        if Tez_repr.(change < tokens_per_roll) then return ctxt
        else
          Lwt.return Tez_repr.(change -? tokens_per_roll)
          >>=? fun change ->
          create_roll_in_delegate ctxt delegate delegate_pk
          >>=? fun ctxt -> loop ctxt change
      in
      loop ctxt change
      >>=? fun ctxt ->
      Storage.Roll.Delegate_roll_list.get_option ctxt delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          return ctxt
      | Some _ ->
          Storage.Active_delegates_with_rolls.add ctxt delegate
          >>= fun ctxt -> return ctxt
end

module Contract = struct
  let add_amount c contract amount =
    get_contract_delegate c contract
    >>=? function
    | None -> return c | Some delegate -> Delegate.add_amount c delegate amount

  let remove_amount c contract amount =
    get_contract_delegate c contract
    >>=? function
    | None ->
        return c
    | Some delegate ->
        Delegate.remove_amount c delegate amount
end

let init ctxt = Storage.Roll.Next.init ctxt Roll_repr.first

let init_first_cycles ctxt =
  let preserved = Constants_storage.preserved_cycles ctxt in
  (* Precompute rolls for cycle (0 --> preserved_cycles) *)
  List.fold_left
    (fun ctxt c ->
      ctxt
      >>=? fun ctxt ->
      let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
      Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
      >>=? fun ctxt ->
      snapshot_rolls_for_cycle ctxt cycle
      >>=? fun ctxt -> freeze_rolls_for_cycle ctxt cycle)
    (return ctxt)
    (0 --> preserved)
  >>=? fun ctxt ->
  let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in
  (* Precomputed a snapshot for cycle (preserved_cycles + 1) *)
  Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
  >>=? fun ctxt ->
  snapshot_rolls_for_cycle ctxt cycle
  >>=? fun ctxt ->
  (* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *)
  let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in
  Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
  >>=? fun ctxt -> return ctxt

let snapshot_rolls ctxt =
  let current_level = Raw_context.current_level ctxt in
  let preserved = Constants_storage.preserved_cycles ctxt in
  let cycle = Cycle_repr.add current_level.cycle (preserved + 2) in
  snapshot_rolls_for_cycle ctxt cycle

let cycle_end ctxt last_cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.sub last_cycle preserved with
  | None ->
      return ctxt
  | Some cleared_cycle ->
      clear_cycle ctxt cleared_cycle )
  >>=? fun ctxt ->
  let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved + 1) in
  freeze_rolls_for_cycle ctxt frozen_roll_cycle
  >>=? fun ctxt ->
  Storage.Roll.Snapshot_for_cycle.init
    ctxt
    (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle))
    0
  >>=? fun ctxt -> return ctxt

let update_tokens_per_roll ctxt new_tokens_per_roll =
  let constants = Raw_context.constants ctxt in
  let old_tokens_per_roll = constants.tokens_per_roll in
  Raw_context.patch_constants ctxt (fun constants ->
      {constants with Constants_repr.tokens_per_roll = new_tokens_per_roll})
  >>= fun ctxt ->
  let decrease = Tez_repr.(new_tokens_per_roll < old_tokens_per_roll) in
  ( if decrease then
    Lwt.return Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll)
  else Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) )
  >>=? fun abs_diff ->
  Storage.Delegates.fold ctxt (Ok ctxt) (fun pkh ctxt ->
      Lwt.return ctxt
      >>=? fun ctxt ->
      count_rolls ctxt pkh
      >>=? fun rolls ->
      Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls)
      >>=? fun amount ->
      if decrease then Delegate.add_amount ctxt pkh amount
      else Delegate.remove_amount ctxt pkh amount)
src/proto_alpha/lib_protocol/roll_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Misc.

Definition get_contract_delegate
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha.Storage.Contract.Delegate.value)) :=
  Tezos_raw_protocol_alpha.Storage.Contract.Delegate.get_option c contract.

Definition delegate_pubkey
  (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Contract.Manager.get_option ctxt
      (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | None | Some (Manager_repr.Hash _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Unregistered_delegate delegate)
      | Some (Manager_repr.Public_key pk) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return pk
      end).

Definition clear_cycle
  (c : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.get c cycle)
    (fun index =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.delete c cycle)
        (fun c =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Roll.Last_for_snapshot.delete
              (c, cycle) index)
            (fun c =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_alpha.Storage.Roll.Owner.delete_snapshot c
                  (cycle, index))
                (fun c =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    c)))).

Definition fold {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
  (f :
    Tezos_raw_protocol_alpha.Roll_repr.roll ->
      Tezos_raw_protocol_alpha.Storage.Roll.Owner.value ->
        A ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              A)) (init : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Roll.Next.get ctxt)
    (fun last =>
      let fix loop
        (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Owner.context) (roll :
        Tezos_raw_protocol_alpha.Roll_repr.roll) (acc :
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A))
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          acc
          (fun acc =>
            if Tezos_raw_protocol_alpha.Roll_repr.op_eq roll last then
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                acc
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Roll.Owner.get_option ctxt
                  roll)
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    loop ctxt (Tezos_raw_protocol_alpha.Roll_repr.succ roll)
                      (Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        acc)
                  | Some delegate =>
                    loop ctxt (Tezos_raw_protocol_alpha.Roll_repr.succ roll)
                      (f roll delegate acc)
                  end)) in
      loop ctxt Tezos_raw_protocol_alpha.Roll_repr.first
        (Tezos_protocol_environment_alpha__Environment.Error_monad._return init)).

Definition snapshot_rolls_for_cycle
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.get ctxt cycle)
    (fun index =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.set ctxt cycle
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
            index 1))
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Roll.Owner.snapshot ctxt
              (cycle, index))
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Roll.Next.get ctxt)
                (fun last =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Storage.Roll.Last_for_snapshot.init
                      (ctxt, cycle) index last)
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        ctxt))))).

Definition freeze_rolls_for_cycle
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Roll.Owner.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.get ctxt cycle)
    (fun max_index =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Seed.For_cycle.get ctxt cycle)
        (fun seed =>
          let rd :=
            Tezos_raw_protocol_alpha.Seed_repr.initialize_new seed
              (cons
                (Tezos_protocol_environment_alpha__Environment.MBytes.of_string
                  "roll_snapshot" % string) []) in
          let seq := Tezos_raw_protocol_alpha.Seed_repr.sequence rd 0 in
          let selected_index :=
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                (Tezos_raw_protocol_alpha.Seed_repr.take_int32 seq
                  (Tezos_protocol_environment_alpha__Environment.Int32.of_int
                    max_index))
                Tezos_protocol_environment_alpha__Environment.Pervasives.fst)
              Tezos_protocol_environment_alpha__Environment.Int32.to_int in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.set ctxt
              cycle selected_index)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                  (fun ctxt =>
                    fun index =>
                      if
                        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                          index selected_index then
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          ctxt
                      else
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                          (Tezos_raw_protocol_alpha.Storage.Roll.Owner.delete_snapshot
                            ctxt (cycle, index))
                          (fun ctxt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Storage.Roll.Last_for_snapshot.delete
                                (ctxt, cycle) index)
                              (fun ctxt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  ctxt))) ctxt
                  (Tezos_raw_protocol_alpha.Misc.op_minus_minus_gt 0
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                      max_index 1)))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt)))).

Module Random.
  Definition int32_to_bytes (i : int32)
    : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
    let b := Tezos_protocol_environment_alpha__Environment.MBytes.create 4 in
    Tezos_protocol_environment_alpha__Environment.MBytes.set_int32 b 0 i;
    b.
  
  Definition level_random
    (seed : Tezos_raw_protocol_alpha.Seed_repr.seed) (use : string)
    (level : Tezos_raw_protocol_alpha.Level_repr.t)
    : Tezos_raw_protocol_alpha.Seed_repr.t :=
    let position := Level_repr.cycle_position level in
    Tezos_raw_protocol_alpha.Seed_repr.initialize_new seed
      (cons
        (Tezos_protocol_environment_alpha__Environment.MBytes.of_string
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
            "level " % string
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
              use ":" % string))) (cons (int32_to_bytes position) [])).
  
  Definition owner
    (c : Tezos_raw_protocol_alpha.Raw_context.t) (kind : string)
    (level : Tezos_raw_protocol_alpha.Level_repr.t) (offset : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
    let cycle := Level_repr.cycle level in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Seed_storage.for_cycle c cycle)
      (fun random_seed =>
        let rd := level_random random_seed kind level in
        let sequence :=
          Tezos_raw_protocol_alpha.Seed_repr.sequence rd
            (Tezos_protocol_environment_alpha__Environment.Int32.of_int offset)
          in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.get c cycle)
          (fun index =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Storage.Roll.Last_for_snapshot.get
                (c, cycle) index)
              (fun bound =>
                let fix loop
                  (sequence : Tezos_raw_protocol_alpha.Seed_repr.sequence)
                  : Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                      Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
                  match Tezos_raw_protocol_alpha.Roll_repr.random sequence bound
                    with
                  | (roll, sequence) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.get_option
                        c ((cycle, index), roll))
                      (fun function_parameter =>
                        match function_parameter with
                        | None => loop sequence
                        | Some delegate =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            delegate
                        end)
                  end in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_raw_protocol_alpha.Storage.Roll.Owner.snapshot_exists c
                    (cycle, index))
                  (fun snapshot_exists =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
                        snapshot_exists (No_roll_snapshot_for_cycle cycle))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt => loop sequence
                        end))))).
End Random.

Definition baking_rights_owner
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (level : Tezos_raw_protocol_alpha.Level_repr.t) (priority : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
  Random.owner c "baking" % string level priority.

Definition endorsement_rights_owner
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (level : Tezos_raw_protocol_alpha.Level_repr.t) (slot : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
  Random.owner c "endorsement" % string level slot.

Definition traverse_rolls
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Successor.context)
  (head : Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
  let fix loop
    (acc : list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value) (roll :
    Tezos_raw_protocol_alpha.Storage.Roll.Successor.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Storage.Roll.Successor.get_option ctxt roll)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (Tezos_protocol_environment_alpha__Environment.List.rev acc)
        | Some next => loop (cons next acc) next
        end) in
  loop (cons head []) head.

Definition get_rolls
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
  (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.get_option ctxt
      delegate)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_nil
      | Some head_roll => traverse_rolls ctxt head_roll
      end).

Definition count_rolls
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
  (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.get_option ctxt
      delegate)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return 0
      | Some head_roll =>
        let fix loop
          (acc : Z) (roll : Tezos_raw_protocol_alpha.Storage.Roll.Successor.key)
          : Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              Z) :=
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Roll.Successor.get_option ctxt
              roll)
            (fun function_parameter =>
              match function_parameter with
              | None =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  acc
              | Some next =>
                loop
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.succ
                    acc) next
              end) in
        loop 1 head_roll
      end).

Definition get_change
  (c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
  (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.get_option c delegate)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          Tezos_raw_protocol_alpha.Tez_repr.zero
      | Some change =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return change
      end).

Module Delegate.
  Definition fresh_roll (c : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Storage.Roll.Next.value *
          Tezos_raw_protocol_alpha.Raw_context.t)) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Storage.Roll.Next.get c)
      (fun roll =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Roll.Next.set c
            (Tezos_raw_protocol_alpha.Roll_repr.succ roll))
          (fun c =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (roll, c))).
  
  Definition get_limbo_roll
    (c : Tezos_raw_protocol_alpha.Storage.Roll.Limbo.context)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Storage.Roll.Next.value *
          Tezos_raw_protocol_alpha.Raw_context.t)) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Storage.Roll.Limbo.get_option c)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (fresh_roll c)
            (fun function_parameter =>
              match function_parameter with
              | (roll, c) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Roll.Limbo.init c roll)
                  (fun c =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (roll, c))
              end)
        | Some roll =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (roll, c)
        end).
  
  Definition consume_roll_change
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    let tokens_per_roll :=
      Tezos_raw_protocol_alpha.Constants_storage.tokens_per_roll c in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
            Consume_roll_change
            (Tezos_protocol_environment_alpha__Environment.Lwt._return
              (Tezos_raw_protocol_alpha.Tez_repr.op_minus_question change
                tokens_per_roll)))
          (fun new_change =>
            Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.set c delegate
              new_change)).
  
  Definition recover_roll_change
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    let tokens_per_roll :=
      Tezos_raw_protocol_alpha.Constants_storage.tokens_per_roll c in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question change
              tokens_per_roll))
          (fun new_change =>
            Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.set c delegate
              new_change)).
  
  Definition pop_roll_from_delegate
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.value *
          Tezos_raw_protocol_alpha.Raw_context.t)) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (recover_roll_change c delegate)
      (fun c =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Roll.Limbo.get_option c)
          (fun limbo_head =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.get_option
                c delegate)
              (fun function_parameter =>
                match function_parameter with
                | None =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                    No_roll_for_delegate
                | Some roll =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Storage.Roll.Owner.delete c roll)
                    (fun c =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Storage.Roll.Successor.get_option
                          c roll)
                        (fun successor_roll =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.set_option
                              c delegate successor_roll)
                            (fun c =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                (Tezos_raw_protocol_alpha.Storage.Roll.Successor.set_option
                                  c roll limbo_head)
                                (fun c =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                    (Tezos_raw_protocol_alpha.Storage.Roll.Limbo.init_set
                                      c roll)
                                    (fun c =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                        (roll, c))))))
                end))).
  
  Definition create_roll_in_delegate
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    (delegate_pk : Tezos_raw_protocol_alpha.Storage.Roll.Owner.value)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (consume_roll_change c delegate)
      (fun c =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.get_option c
            delegate)
          (fun delegate_head =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (get_limbo_roll c)
              (fun function_parameter =>
                match function_parameter with
                | (roll, c) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Storage.Roll.Owner.init c roll
                      delegate_pk)
                    (fun c =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Storage.Roll.Successor.get_option
                          c roll)
                        (fun limbo_successor =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (Tezos_raw_protocol_alpha.Storage.Roll.Limbo.set_option
                              c limbo_successor)
                            (fun c =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                (Tezos_raw_protocol_alpha.Storage.Roll.Successor.set_option
                                  c roll delegate_head)
                                (fun c =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                    (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.init_set
                                      c delegate roll)
                                    (fun c =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                        c)))))
                end))).
  
  Definition ensure_inited
    (c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
      (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.mem c delegate)
      (fun function_parameter =>
        match function_parameter with
        | true =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return c
        | false =>
          Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.init c delegate
            Tezos_raw_protocol_alpha.Tez_repr.zero
        end).
  
  Definition is_inactive
    (c : Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.context)
    (delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
      (Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.mem c
        (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate))
      (fun inactive =>
        if inactive then
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            inactive
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.get_option
              c
              (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate))
            (fun function_parameter =>
              match function_parameter with
              | Some last_active_cycle =>
                match Tezos_raw_protocol_alpha.Raw_context.current_level c with
                | {| Level_repr.cycle := current_cycle |} =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (Tezos_raw_protocol_alpha.Cycle_repr.op_lt last_active_cycle
                      current_cycle)
                end
              | None =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.return_false
              end)).
  
  Definition add_amount
    (c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (ensure_inited c delegate)
      (fun c =>
        let tokens_per_roll :=
          Tezos_raw_protocol_alpha.Constants_storage.tokens_per_roll c in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.get c delegate)
          (fun change =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question amount
                  change))
              (fun change =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.set c
                    delegate change)
                  (fun c =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (delegate_pubkey c delegate)
                      (fun delegate_pk =>
                        let fix loop
                          (c : Tezos_raw_protocol_alpha.Raw_context.context)
                          (change : Tezos_raw_protocol_alpha.Tez_repr.t)
                          : Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                              Tezos_raw_protocol_alpha.Raw_context.context) :=
                          if
                            Tezos_raw_protocol_alpha.Tez_repr.op_lt change
                              tokens_per_roll then
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              c
                          else
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                (Tezos_raw_protocol_alpha.Tez_repr.op_minus_question
                                  change tokens_per_roll))
                              (fun change =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (create_roll_in_delegate c delegate
                                    delegate_pk) (fun c => loop c change)) in
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (is_inactive c delegate)
                          (fun inactive =>
                            if inactive then
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                c
                            else
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (loop c change)
                                (fun c =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.get_option
                                      c delegate)
                                    (fun rolls =>
                                      match rolls with
                                      | None =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                          c
                                      | Some _ =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                          (Tezos_raw_protocol_alpha.Storage.Active_delegates_with_rolls.add
                                            c delegate)
                                          (fun c =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                              c)
                                      end)))))))).
  
  Definition remove_amount
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    let tokens_per_roll :=
      Tezos_raw_protocol_alpha.Constants_storage.tokens_per_roll c in
    let fix loop
      (c : Tezos_raw_protocol_alpha.Raw_context.context) (change :
      Tezos_raw_protocol_alpha.Tez_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.context *
            Tezos_raw_protocol_alpha.Tez_repr.t)) :=
      if Tezos_raw_protocol_alpha.Tez_repr.op_lt_eq amount change then
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (c, change)
      else
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (pop_roll_from_delegate c delegate)
          (fun function_parameter =>
            match function_parameter with
            | (_, c) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question change
                    tokens_per_roll)) (fun change => loop c change)
            end) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (is_inactive c delegate)
          (fun inactive =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (if inactive then
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (c, change)
              else
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (loop c change)
                  (fun function_parameter =>
                    match function_parameter with
                    | (c, change) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.get_option
                          c delegate)
                        (fun rolls =>
                          match rolls with
                          | None =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (Tezos_raw_protocol_alpha.Storage.Active_delegates_with_rolls.del
                                c delegate)
                              (fun c =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  (c, change))
                          | Some _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              (c, change)
                          end)
                    end))
              (fun function_parameter =>
                match function_parameter with
                | (c, change) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Tez_repr.op_minus_question
                        change amount))
                    (fun change =>
                      Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.set
                        c delegate change)
                end))).
  
  Definition set_inactive
    (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (ensure_inited ctxt delegate)
      (fun ctxt =>
        let tokens_per_roll :=
          Tezos_raw_protocol_alpha.Constants_storage.tokens_per_roll ctxt in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.get ctxt
            delegate)
          (fun change =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
              (Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.add
                ctxt
                (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract
                  delegate))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_raw_protocol_alpha.Storage.Active_delegates_with_rolls.del
                    ctxt delegate)
                  (fun ctxt =>
                    let fix loop
                      (ctxt :
                      Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
                      (change : Tezos_raw_protocol_alpha.Tez_repr.t)
                      : Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                          (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context
                            * Tezos_raw_protocol_alpha.Tez_repr.t)) :=
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.get_option
                          ctxt delegate)
                        (fun function_parameter =>
                          match function_parameter with
                          | None =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              (ctxt, change)
                          | Some _roll =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (pop_roll_from_delegate ctxt delegate)
                              (fun function_parameter =>
                                match function_parameter with
                                | (_, ctxt) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                      (Tezos_raw_protocol_alpha.Tez_repr.op_plus_question
                                        change tokens_per_roll))
                                    (fun change => loop ctxt change)
                                end)
                          end) in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (loop ctxt change)
                      (fun function_parameter =>
                        match function_parameter with
                        | (ctxt, change) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.set
                              ctxt delegate change)
                            (fun ctxt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                ctxt)
                        end))))).
  
  Definition set_active
    (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.context)
    (delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (is_inactive ctxt delegate)
      (fun inactive =>
        let current_cycle :=
          cycle (Tezos_raw_protocol_alpha.Raw_context.current_level ctxt) in
        let preserved_cycles :=
          Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles ctxt in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.get_option
            ctxt
            (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract delegate))
          (fun current_expiration =>
            let expiration :=
              match current_expiration with
              | None =>
                Tezos_raw_protocol_alpha.Cycle_repr.add current_cycle
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                    1
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
                      2 preserved_cycles))
              | Some current_expiration =>
                let delay :=
                  if inactive then
                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                      1
                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
                        2 preserved_cycles)
                  else
                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                      1 preserved_cycles in
                let updated :=
                  Tezos_raw_protocol_alpha.Cycle_repr.add current_cycle delay in
                Tezos_raw_protocol_alpha.Cycle_repr.max current_expiration
                  updated
              end in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
              (Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.init_set
                ctxt
                (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract
                  delegate) expiration)
              (fun ctxt =>
                if
                  Tezos_protocol_environment_alpha__Environment.Pervasives.not
                    inactive then
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt
                else
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (ensure_inited ctxt delegate)
                    (fun ctxt =>
                      let tokens_per_roll :=
                        Tezos_raw_protocol_alpha.Constants_storage.tokens_per_roll
                          ctxt in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.get
                          ctxt delegate)
                        (fun change =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.del
                              ctxt
                              (Tezos_raw_protocol_alpha.Contract_repr.implicit_contract
                                delegate))
                            (fun ctxt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (delegate_pubkey ctxt delegate)
                                (fun delegate_pk =>
                                  let fix loop
                                    (ctxt :
                                    Tezos_raw_protocol_alpha.Raw_context.context)
                                    (change :
                                    Tezos_raw_protocol_alpha.Tez_repr.t)
                                    : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                        Tezos_raw_protocol_alpha.Raw_context.context) :=
                                    if
                                      Tezos_raw_protocol_alpha.Tez_repr.op_lt
                                        change tokens_per_roll then
                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                        ctxt
                                    else
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                          (Tezos_raw_protocol_alpha.Tez_repr.op_minus_question
                                            change tokens_per_roll))
                                        (fun change =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (create_roll_in_delegate ctxt
                                              delegate delegate_pk)
                                            (fun ctxt => loop ctxt change)) in
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (loop ctxt change)
                                    (fun ctxt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.get_option
                                          ctxt delegate)
                                        (fun rolls =>
                                          match rolls with
                                          | None =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                              ctxt
                                          | Some _ =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                              (Tezos_raw_protocol_alpha.Storage.Active_delegates_with_rolls.add
                                                ctxt delegate)
                                              (fun ctxt =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                  ctxt)
                                          end))))))))).
End Delegate.

Module Contract.
  Definition add_amount
    (c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
    (contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
    (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (get_contract_delegate c contract)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return c
        | Some delegate => Delegate.add_amount c delegate amount
        end).
  
  Definition remove_amount
    (c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
    (contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
    (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (get_contract_delegate c contract)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return c
        | Some delegate => Delegate.remove_amount c delegate amount
        end).
End Contract.

Definition init (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Roll.Next.init ctxt
    Tezos_raw_protocol_alpha.Roll_repr.first.

Definition init_first_cycles
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let preserved :=
    Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.List.fold_left
      (fun ctxt =>
        fun c =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            ctxt
            (fun ctxt =>
              let cycle :=
                Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn
                  (Tezos_protocol_environment_alpha__Environment.Int32.of_int c)
                in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.init
                  ctxt cycle 0)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (snapshot_rolls_for_cycle ctxt cycle)
                    (fun ctxt => freeze_rolls_for_cycle ctxt cycle))))
      (Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt)
      (Tezos_raw_protocol_alpha.Misc.op_minus_minus_gt 0 preserved))
    (fun ctxt =>
      let cycle :=
        Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn
          (Tezos_protocol_environment_alpha__Environment.Int32.of_int
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
              preserved 1)) in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.init ctxt
          cycle 0)
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (snapshot_rolls_for_cycle ctxt cycle)
            (fun ctxt =>
              let cycle :=
                Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn
                  (Tezos_protocol_environment_alpha__Environment.Int32.of_int
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                      preserved 2)) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.init
                  ctxt cycle 0)
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ctxt)))).

Definition snapshot_rolls (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let current_level := Tezos_raw_protocol_alpha.Raw_context.current_level ctxt
    in
  let preserved :=
    Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles ctxt in
  let cycle :=
    Tezos_raw_protocol_alpha.Cycle_repr.add (cycle current_level)
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
        preserved 2) in
  snapshot_rolls_for_cycle ctxt cycle.

Definition cycle_end
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let preserved :=
    Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    match Tezos_raw_protocol_alpha.Cycle_repr.sub last_cycle preserved with
    | None =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt
    | Some cleared_cycle => clear_cycle ctxt cleared_cycle
    end
    (fun ctxt =>
      let frozen_roll_cycle :=
        Tezos_raw_protocol_alpha.Cycle_repr.add last_cycle
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
            preserved 1) in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (freeze_rolls_for_cycle ctxt frozen_roll_cycle)
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.init ctxt
              (Tezos_raw_protocol_alpha.Cycle_repr.succ
                (Tezos_raw_protocol_alpha.Cycle_repr.succ frozen_roll_cycle)) 0)
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ctxt))).

Definition update_tokens_per_roll
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (new_tokens_per_roll : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.context) :=
  let constants := Tezos_raw_protocol_alpha.Raw_context.constants ctxt in
  let old_tokens_per_roll := tokens_per_roll constants in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_raw_protocol_alpha.Raw_context.patch_constants ctxt
      (fun constants => record))
    (fun ctxt =>
      let decrease :=
        Tezos_raw_protocol_alpha.Tez_repr.op_lt new_tokens_per_roll
          old_tokens_per_roll in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (if decrease then
          Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Tez_repr.op_minus_question
              old_tokens_per_roll new_tokens_per_roll)
        else
          Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Tez_repr.op_minus_question
              new_tokens_per_roll old_tokens_per_roll))
        (fun abs_diff =>
          Tezos_raw_protocol_alpha.Storage.Delegates.fold ctxt (inl ctxt)
            (fun pkh =>
              fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    ctxt)
                  (fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (count_rolls ctxt pkh)
                      (fun rolls =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_protocol_environment_alpha__Environment.Lwt._return
                            (Tezos_raw_protocol_alpha.Tez_repr.op_star_question
                              abs_diff
                              (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                rolls)))
                          (fun amount =>
                            if decrease then
                              Delegate.add_amount ctxt pkh amount
                            else
                              Delegate.remove_amount ctxt pkh amount)))))).
src/proto_alpha/lib_protocol/roll_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**

   Basic roll manipulation.

   If storage related to roll (a.k.a. `Storage.Roll`) are not used
   outside of this module, this interface enforces the invariant that a
   roll is always either in the limbo list or in a contract list.

*)

type error +=
  | Consume_roll_change
  | No_roll_for_delegate
  | No_roll_snapshot_for_cycle of Cycle_repr.t
  | Unregistered_delegate of Signature.Public_key_hash.t

(* `Permanent *)

val init : Raw_context.t -> Raw_context.t tzresult Lwt.t

val init_first_cycles : Raw_context.t -> Raw_context.t tzresult Lwt.t

val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t

val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t

val fold :
  Raw_context.t ->
  f:(Roll_repr.roll -> Signature.Public_key.t -> 'a -> 'a tzresult Lwt.t) ->
  'a ->
  'a tzresult Lwt.t

val baking_rights_owner :
  Raw_context.t ->
  Level_repr.t ->
  priority:int ->
  Signature.Public_key.t tzresult Lwt.t

val endorsement_rights_owner :
  Raw_context.t ->
  Level_repr.t ->
  slot:int ->
  Signature.Public_key.t tzresult Lwt.t

module Delegate : sig
  val is_inactive :
    Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t

  val add_amount :
    Raw_context.t ->
    Signature.Public_key_hash.t ->
    Tez_repr.t ->
    Raw_context.t tzresult Lwt.t

  val remove_amount :
    Raw_context.t ->
    Signature.Public_key_hash.t ->
    Tez_repr.t ->
    Raw_context.t tzresult Lwt.t

  val set_inactive :
    Raw_context.t ->
    Signature.Public_key_hash.t ->
    Raw_context.t tzresult Lwt.t

  val set_active :
    Raw_context.t ->
    Signature.Public_key_hash.t ->
    Raw_context.t tzresult Lwt.t
end

module Contract : sig
  val add_amount :
    Raw_context.t ->
    Contract_repr.t ->
    Tez_repr.t ->
    Raw_context.t tzresult Lwt.t

  val remove_amount :
    Raw_context.t ->
    Contract_repr.t ->
    Tez_repr.t ->
    Raw_context.t tzresult Lwt.t
end

val delegate_pubkey :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Signature.Public_key.t tzresult Lwt.t

val get_rolls :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Roll_repr.t list tzresult Lwt.t

val get_change :
  Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t

val update_tokens_per_roll :
  Raw_context.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t

(**/**)

val get_contract_delegate :
  Raw_context.t ->
  Contract_repr.t ->
  Signature.Public_key_hash.t option tzresult Lwt.t
src/proto_alpha/lib_protocol/roll_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

Parameter init :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).

Parameter init_first_cycles :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).

Parameter cycle_end :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter snapshot_rolls :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).

Parameter fold : forall {a : Type},
Tezos_raw_protocol_alpha.Raw_context.t ->
  (Tezos_raw_protocol_alpha.Roll_repr.roll ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t ->
      a ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult a))
    ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult a).

Parameter baking_rights_owner :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Level_repr.t ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t).

Parameter endorsement_rights_owner :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Level_repr.t ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t).

Module Delegate.
  Parameter is_inactive : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool).
  
  Parameter add_amount : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_raw_protocol_alpha.Tez_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).
  
  Parameter remove_amount : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_raw_protocol_alpha.Tez_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).
  
  Parameter set_inactive : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).
  
  Parameter set_active : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).
End Delegate.

Module Contract.
  Parameter add_amount : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_raw_protocol_alpha.Contract_repr.t ->
      Tezos_raw_protocol_alpha.Tez_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).
  
  Parameter remove_amount : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_raw_protocol_alpha.Contract_repr.t ->
      Tezos_raw_protocol_alpha.Tez_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).
End Contract.

Parameter delegate_pubkey :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t).

Parameter get_rolls :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list Tezos_raw_protocol_alpha.Roll_repr.t)).

Parameter get_change :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Tez_repr.t).

Parameter update_tokens_per_roll :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Tez_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter get_contract_delegate :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Contract_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)).
src/proto_alpha/lib_protocol/script_expr_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let script_expr_hash = "\013\044\064\027" (* expr(54) *)

include Blake2B.Make
          (Base58)
          (struct
            let name = "script_expr"

            let title = "A script expression ID"

            let b58check_prefix = script_expr_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "expr" 54
src/proto_alpha/lib_protocol/script_expr_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition script_expr_hash : string := "
,@" % string.
src/proto_alpha/lib_protocol/script_int_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type n = Natural_tag

type z = Integer_tag

type 't num = Z.t

let compare x y = Z.compare x y

let zero = Z.zero

let zero_n = Z.zero

let to_string x = Z.to_string x

let of_string s = try Some (Z.of_string s) with _ -> None

let to_int64 x = try Some (Z.to_int64 x) with _ -> None

let of_int64 n = Z.of_int64 n

let to_int x = try Some (Z.to_int x) with _ -> None

let of_int n = Z.of_int n

let of_zint x = x

let to_zint x = x

let add x y = Z.add x y

let sub x y = Z.sub x y

let mul x y = Z.mul x y

let ediv x y =
  try
    let (q, r) = Z.ediv_rem x y in
    Some (q, r)
  with _ -> None

let add_n = add

let mul_n = mul

let ediv_n = ediv

let abs x = Z.abs x

let is_nat x = if Compare.Z.(x < Z.zero) then None else Some x

let neg x = Z.neg x

let int x = x

let shift_left x y =
  if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
  else
    let y = Z.to_int y in
    Some (Z.shift_left x y)

let shift_right x y =
  if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
  else
    let y = Z.to_int y in
    Some (Z.shift_right x y)

let shift_left_n = shift_left

let shift_right_n = shift_right

let logor x y = Z.logor x y

let logxor x y = Z.logxor x y

let logand x y = Z.logand x y

let lognot x = Z.lognot x
src/proto_alpha/lib_protocol/script_int_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive n : Type :=
| Natural_tag : n.

Inductive z : Type :=
| Integer_tag : z.

Definition num (t : Type) := Tezos_protocol_environment_alpha__Environment.Z.t.

Definition compare
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t) : Z :=
  Tezos_protocol_environment_alpha__Environment.Z.compare x y.

Definition zero : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.zero.

Definition zero_n : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.zero.

Definition to_string (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : string := Tezos_protocol_environment_alpha__Environment.Z.to_string x.

Definition of_string (s : string)
  : option Tezos_protocol_environment_alpha__Environment.Z.t := try.

Definition to_int64 (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option int64 := try.

Definition of_int64 (n : int64)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int64 n.

Definition to_int (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option Z := try.

Definition of_int (n : Z) : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int n.

Definition of_zint {A : Type} (x : A) : A := x.

Definition to_zint {A : Type} (x : A) : A := x.

Definition add
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.add x y.

Definition sub
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.sub x y.

Definition mul
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.mul x y.

Definition ediv
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option
    (Tezos_protocol_environment_alpha__Environment.Z.t *
      Tezos_protocol_environment_alpha__Environment.Z.t) := try.

Definition add_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t := add.

Definition mul_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t := mul.

Definition ediv_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      option
        (Tezos_protocol_environment_alpha__Environment.Z.t *
          Tezos_protocol_environment_alpha__Environment.Z.t) := ediv.

Definition abs (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.abs x.

Definition is_nat
  (x :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : option
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      x Tezos_protocol_environment_alpha__Environment.Z.zero then
    None
  else
    Some x.

Definition neg (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.neg x.

Definition int {A : Type} (x : A) : A := x.

Definition shift_left
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option Tezos_protocol_environment_alpha__Environment.Z.t :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      (Tezos_protocol_environment_alpha__Environment.Z.compare y
        (Tezos_protocol_environment_alpha__Environment.Z.of_int 256)) 0 then
    None
  else
    let y := Tezos_protocol_environment_alpha__Environment.Z.to_int y in
    Some (Tezos_protocol_environment_alpha__Environment.Z.shift_left x y).

Definition shift_right
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option Tezos_protocol_environment_alpha__Environment.Z.t :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      (Tezos_protocol_environment_alpha__Environment.Z.compare y
        (Tezos_protocol_environment_alpha__Environment.Z.of_int 256)) 0 then
    None
  else
    let y := Tezos_protocol_environment_alpha__Environment.Z.to_int y in
    Some (Tezos_protocol_environment_alpha__Environment.Z.shift_right x y).

Definition shift_left_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      option Tezos_protocol_environment_alpha__Environment.Z.t := shift_left.

Definition shift_right_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      option Tezos_protocol_environment_alpha__Environment.Z.t := shift_right.

Definition logor
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.logor x y.

Definition logxor
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.logxor x y.

Definition logand
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.logand x y.

Definition lognot (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.lognot x.
src/proto_alpha/lib_protocol/script_int_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The types for arbitraty precision integers in Michelson.
    The type variable ['t] is always [n] or [z],
    [n num] and [z num] are incompatible.

    This is internally a [Z.t].
    This module mostly adds signedness preservation guarantees. *)
type 't num

(** Flag for natural numbers. *)
and n = Natural_tag

(** Flag for relative numbers. *)
and z = Integer_tag

(** Natural zero. *)
val zero_n : n num

(** Relative zero. *)
val zero : z num

(** Compare two numbers as if they were *)
val compare : 'a num -> 'a num -> int

(** Conversion to an OCaml [string] in decimal notation. *)
val to_string : _ num -> string

(** Conversion from an OCaml [string].
    Returns [None] in case of an invalid notation.
    Supports [+] and [-] sign modifiers, and [0x], [0o] and [0b] base modifiers. *)
val of_string : string -> z num option

(** Conversion to an OCaml [int64], returns [None] on overflow. *)
val to_int64 : _ num -> int64 option

(** Conversion from an OCaml [int]. *)
val of_int64 : int64 -> z num

(** Conversion to an OCaml [int], returns [None] on overflow. *)
val to_int : _ num -> int option

(** Conversion from an OCaml [int64]. *)
val of_int : int -> z num

(** Conversion from a Zarith integer ([Z.t]). *)
val of_zint : Z.t -> z num

(** Conversion to a Zarith integer ([Z.t]). *)
val to_zint : 'a num -> Z.t

(** Addition between naturals. *)
val add_n : n num -> n num -> n num

(** Multiplication between naturals. *)
val mul_n : n num -> n num -> n num

(** Euclidean division between naturals.
    [ediv_n n d] returns [None] if divisor is zero,
    or [Some (q, r)] where [n = d * q + r] and [[0 <= r < d]] otherwise. *)
val ediv_n : n num -> n num -> (n num * n num) option

(** Sign agnostic addition.
    Use {!add_n} when working with naturals to preserve the sign. *)
val add : _ num -> _ num -> z num

(** Sign agnostic subtraction.
    Use {!sub_n} when working with naturals to preserve the sign. *)
val sub : _ num -> _ num -> z num

(** Sign agnostic multiplication.
    Use {!mul_n} when working with naturals to preserve the sign. *)
val mul : _ num -> _ num -> z num

(** Sign agnostic euclidean division.
    [ediv n d] returns [None] if divisor is zero,
    or [Some (q, r)] where [n = d * q + r] and [[0 <= r < |d|]] otherwise.
    Use {!ediv_n} when working with naturals to preserve the sign. *)
val ediv : _ num -> _ num -> (z num * n num) option

(** Compute the absolute value of a relative, turning it into a natural. *)
val abs : z num -> n num

(** Partial identity over [N]. *)
val is_nat : z num -> n num option

(** Negates a number. *)
val neg : _ num -> z num

(** Turns a natural into a relative, not changing its value. *)
val int : n num -> z num

(** Reverses each bit in the representation of the number.
    Also applies to the sign. *)
val lognot : _ num -> z num

(** Shifts the natural to the left of a number of bits between 0 and 256.
    Returns [None] if the amount is too high. *)
val shift_left_n : n num -> n num -> n num option

(** Shifts the natural to the right of a number of bits between 0 and 256.
    Returns [None] if the amount is too high. *)
val shift_right_n : n num -> n num -> n num option

(** Shifts the number to the left of a number of bits between 0 and 256.
    Returns [None] if the amount is too high. *)
val shift_left : 'a num -> n num -> 'a num option

(** Shifts the number to the right of a number of bits between 0 and 256.
    Returns [None] if the amount is too high. *)
val shift_right : 'a num -> n num -> 'a num option

(** Applies a boolean or operation to each bit. *)
val logor : 'a num -> 'a num -> 'a num

(** Applies a boolean and operation to each bit. *)
val logand : _ num -> n num -> n num

(** Applies a boolean xor operation to each bit. *)
val logxor : n num -> n num -> n num
src/proto_alpha/lib_protocol/script_int_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive n : Type :=
| Natural_tag : n

with z : Type :=
| Integer_tag : z.

Parameter zero_n : num n.

Parameter zero : num z.

Parameter compare : forall {a : Type}, (num a) -> (num a) -> Z.

Parameter to_string : forall {_ : Type}, (num _) -> string.

Parameter of_string : string -> option (num z).

Parameter to_int64 : forall {_ : Type}, (num _) -> option int64.

Parameter of_int64 : int64 -> num z.

Parameter to_int : forall {_ : Type}, (num _) -> option Z.

Parameter of_int : Z -> num z.

Parameter of_zint : Tezos_protocol_environment_alpha__Environment.Z.t -> num z.

Parameter to_zint : forall {a : Type},
(num a) -> Tezos_protocol_environment_alpha__Environment.Z.t.

Parameter add_n : (num n) -> (num n) -> num n.

Parameter mul_n : (num n) -> (num n) -> num n.

Parameter ediv_n : (num n) -> (num n) -> option ((num n) * (num n)).

Parameter add : forall {_ : Type}, (num _) -> (num _) -> num z.

Parameter sub : forall {_ : Type}, (num _) -> (num _) -> num z.

Parameter mul : forall {_ : Type}, (num _) -> (num _) -> num z.

Parameter ediv : forall {_ : Type},
(num _) -> (num _) -> option ((num z) * (num n)).

Parameter abs : (num z) -> num n.

Parameter is_nat : (num z) -> option (num n).

Parameter neg : forall {_ : Type}, (num _) -> num z.

Parameter int : (num n) -> num z.

Parameter lognot : forall {_ : Type}, (num _) -> num z.

Parameter shift_left_n : (num n) -> (num n) -> option (num n).

Parameter shift_right_n : (num n) -> (num n) -> option (num n).

Parameter shift_left : forall {a : Type}, (num a) -> (num n) -> option (num a).

Parameter shift_right : forall {a : Type}, (num a) -> (num n) -> option (num a).

Parameter logor : forall {a : Type}, (num a) -> (num a) -> num a.

Parameter logand : forall {_ : Type}, (num _) -> (num n) -> num n.

Parameter logxor : (num n) -> (num n) -> num n.
src/proto_alpha/lib_protocol/script_interpreter.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script
open Script_typed_ir
open Script_ir_translator

(* ---- Run-time errors -----------------------------------------------------*)

type execution_trace =
  (Script.location * Gas.t * (Script.expr * string option) list) list

type error +=
  | Reject of Script.location * Script.expr * execution_trace option

type error += Overflow of Script.location * execution_trace option

type error += Runtime_contract_error : Contract.t * Script.expr -> error

type error += Bad_contract_parameter of Contract.t (* `Permanent *)

type error += Cannot_serialize_log

type error += Cannot_serialize_failure

type error += Cannot_serialize_storage

let () =
  let open Data_encoding in
  let trace_encoding =
    list
    @@ obj3
         (req "location" Script.location_encoding)
         (req "gas" Gas.encoding)
         (req
            "stack"
            (list (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))
  in
  (* Reject *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.script_rejected"
    ~title:"Script failed"
    ~description:"A FAILWITH instruction was reached"
    (obj3
       (req "location" Script.location_encoding)
       (req "with" Script.expr_encoding)
       (opt "trace" trace_encoding))
    (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
    (fun (loc, v, trace) -> Reject (loc, v, trace)) ;
  (* Overflow *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.script_overflow"
    ~title:"Script failed (overflow error)"
    ~description:
      "A FAIL instruction was reached due to the detection of an overflow"
    (obj2
       (req "location" Script.location_encoding)
       (opt "trace" trace_encoding))
    (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None)
    (fun (loc, trace) -> Overflow (loc, trace)) ;
  (* Runtime contract error *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.runtime_error"
    ~title:"Script runtime error"
    ~description:"Toplevel error for all runtime script errors"
    (obj2
       (req "contract_handle" Contract.encoding)
       (req "contract_code" Script.expr_encoding))
    (function
      | Runtime_contract_error (contract, expr) ->
          Some (contract, expr)
      | _ ->
          None)
    (fun (contract, expr) -> Runtime_contract_error (contract, expr)) ;
  (* Bad contract parameter *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_contract_parameter"
    ~title:"Contract supplied an invalid parameter"
    ~description:
      "Either no parameter was supplied to a contract with a non-unit \
       parameter type, a non-unit parameter was passed to an account, or a \
       parameter was supplied of the wrong type"
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Bad_contract_parameter c -> Some c | _ -> None)
    (fun c -> Bad_contract_parameter c) ;
  (* Cannot serialize log *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_log"
    ~title:"Not enough gas to serialize execution trace"
    ~description:
      "Execution trace with stacks was to big to be serialized with the \
       provided gas"
    Data_encoding.empty
    (function Cannot_serialize_log -> Some () | _ -> None)
    (fun () -> Cannot_serialize_log) ;
  (* Cannot serialize failure *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_failure"
    ~title:"Not enough gas to serialize argument of FAILWITH"
    ~description:
      "Argument of FAILWITH was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_failure -> Some () | _ -> None)
    (fun () -> Cannot_serialize_failure) ;
  (* Cannot serialize storage *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_storage"
    ~title:"Not enough gas to serialize execution storage"
    ~description:
      "The returned storage was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_storage -> Some () | _ -> None)
    (fun () -> Cannot_serialize_storage)

(* ---- interpreter ---------------------------------------------------------*)

type 'tys stack =
  | Item : 'ty * 'rest stack -> ('ty * 'rest) stack
  | Empty : end_of_stack stack

let unparse_stack ctxt (stack, stack_ty) =
  (* We drop the gas limit as this function is only used for debugging/errors. *)
  let ctxt = Gas.set_unlimited ctxt in
  let rec unparse_stack :
      type a.
      a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t
      = function
    | (Empty, Empty_t) ->
        return_nil
    | (Item (v, rest), Item_t (ty, rest_ty, annot)) ->
        unparse_data ctxt Readable ty v
        >>=? fun (data, _ctxt) ->
        unparse_stack (rest, rest_ty)
        >>=? fun rest ->
        let annot =
          match Script_ir_annot.unparse_var_annot annot with
          | [] ->
              None
          | [a] ->
              Some a
          | _ ->
              assert false
        in
        let data = Micheline.strip_locations data in
        return ((data, annot) :: rest)
  in
  unparse_stack (stack, stack_ty)

module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter

let rec interp_stack_prefix_preserving_operation :
    type fbef bef faft aft result.
    (fbef stack -> (faft stack * result) tzresult Lwt.t) ->
    (fbef, faft, bef, aft) stack_prefix_preservation_witness ->
    bef stack ->
    (aft stack * result) tzresult Lwt.t =
 fun f n stk ->
  match (n, stk) with
  | ( Prefix
        (Prefix
          (Prefix
            (Prefix
              (Prefix
                (Prefix
                  (Prefix
                    (Prefix
                      (Prefix
                        (Prefix
                          (Prefix
                            (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))),
      Item
        ( v0,
          Item
            ( v1,
              Item
                ( v2,
                  Item
                    ( v3,
                      Item
                        ( v4,
                          Item
                            ( v5,
                              Item
                                ( v6,
                                  Item
                                    ( v7,
                                      Item
                                        ( v8,
                                          Item
                                            ( v9,
                                              Item
                                                ( va,
                                                  Item
                                                    ( vb,
                                                      Item
                                                        ( vc,
                                                          Item
                                                            ( vd,
                                                              Item
                                                                ( ve,
                                                                  Item
                                                                    (vf, rest)
                                                                ) ) ) ) ) ) )
                                    ) ) ) ) ) ) ) ) ) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) ->
      return
        ( Item
            ( v0,
              Item
                ( v1,
                  Item
                    ( v2,
                      Item
                        ( v3,
                          Item
                            ( v4,
                              Item
                                ( v5,
                                  Item
                                    ( v6,
                                      Item
                                        ( v7,
                                          Item
                                            ( v8,
                                              Item
                                                ( v9,
                                                  Item
                                                    ( va,
                                                      Item
                                                        ( vb,
                                                          Item
                                                            ( vc,
                                                              Item
                                                                ( vd,
                                                                  Item
                                                                    ( ve,
                                                                      Item
                                                                        ( vf,
                                                                          rest'
                                                                        ) ) )
                                                            ) ) ) ) ) ) ) ) )
                        ) ) ) ),
          result )
  | ( Prefix (Prefix (Prefix (Prefix n))),
      Item (v0, Item (v1, Item (v2, Item (v3, rest)))) ) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) ->
      return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result)
  | (Prefix n, Item (v, rest)) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) -> return (Item (v, rest'), result)
  | (Rest, v) ->
      f v

type step_constants = {
  source : Contract.t;
  payer : Contract.t;
  self : Contract.t;
  amount : Tez.t;
  chain_id : Chain_id.t;
}

let rec step :
    type b a.
    ?log:execution_trace ref ->
    context ->
    step_constants ->
    (b, a) descr ->
    b stack ->
    (a stack * context) tzresult Lwt.t =
 fun ?log ctxt step_constants ({instr; loc; _} as descr) stack ->
  Lwt.return (Gas.consume ctxt Interp_costs.cycle)
  >>=? fun ctxt ->
  let logged_return :
      type a b.
      (b, a) descr -> a stack * context -> (a stack * context) tzresult Lwt.t =
   fun descr (ret, ctxt) ->
    match log with
    | None ->
        return (ret, ctxt)
    | Some log ->
        trace Cannot_serialize_log (unparse_stack ctxt (ret, descr.aft))
        >>=? fun stack ->
        log := (descr.loc, Gas.level ctxt, stack) :: !log ;
        return (ret, ctxt)
  in
  let get_log (log : execution_trace ref option) =
    Option.map ~f:(fun l -> List.rev !l) log
  in
  let consume_gas_terop :
      type ret arg1 arg2 arg3 rest.
      (_ * (_ * (_ * rest)), ret * rest) descr ->
      (arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3 ->
      (arg1 -> arg2 -> arg3 -> Gas.cost) ->
      rest stack ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, x1, x2, x3) cost_func rest ->
    Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3))
    >>=? fun ctxt -> logged_return descr (Item (op x1 x2 x3, rest), ctxt)
  in
  let consume_gas_binop :
      type ret arg1 arg2 rest.
      (_ * (_ * rest), ret * rest) descr ->
      (arg1 -> arg2 -> ret) * arg1 * arg2 ->
      (arg1 -> arg2 -> Gas.cost) ->
      rest stack ->
      context ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, x1, x2) cost_func rest ctxt ->
    Lwt.return (Gas.consume ctxt (cost_func x1 x2))
    >>=? fun ctxt -> logged_return descr (Item (op x1 x2, rest), ctxt)
  in
  let consume_gas_unop :
      type ret arg rest.
      (_ * rest, ret * rest) descr ->
      (arg -> ret) * arg ->
      (arg -> Gas.cost) ->
      rest stack ->
      context ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, arg) cost_func rest ctxt ->
    Lwt.return (Gas.consume ctxt (cost_func arg))
    >>=? fun ctxt -> logged_return descr (Item (op arg, rest), ctxt)
  in
  let logged_return : a stack * context -> (a stack * context) tzresult Lwt.t =
    logged_return descr
  in
  match (instr, stack) with
  (* stack ops *)
  | (Drop, Item (_, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (rest, ctxt)
  | (Dup, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (Item (v, Item (v, rest)), ctxt)
  | (Swap, Item (vi, Item (vo, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (Item (vo, Item (vi, rest)), ctxt)
  | (Const v, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt -> logged_return (Item (v, rest), ctxt)
  (* options *)
  | (Cons_some, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (Some v, rest), ctxt)
  | (Cons_none _, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data)
      >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (If_none (bt, _), Item (None, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt rest
  | (If_none (_, bf), Item (Some v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest))
  (* pairs *)
  | (Cons_pair, Item (a, Item (b, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair)
      >>=? fun ctxt -> logged_return (Item ((a, b), rest), ctxt)
  (* Peephole optimization for UNPAIR *)
  | ( Seq
        ( {instr = Dup; _},
          { instr =
              Seq
                ( {instr = Car; _},
                  { instr = Seq ({instr = Dip {instr = Cdr}}, {instr = Nop; _});
                    _ } );
            _ } ),
      Item ((a, b), rest) ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (a, Item (b, rest)), ctxt)
  | (Car, Item ((a, _), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (a, rest), ctxt)
  | (Cdr, Item ((_, b), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (b, rest), ctxt)
  (* unions *)
  | (Left, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (L v, rest), ctxt)
  | (Right, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (R v, rest), ctxt)
  | (If_left (bt, _), Item (L v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt (Item (v, rest))
  | (If_left (_, bf), Item (R v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest))
  (* lists *)
  | (Cons_list, Item (hd, Item (tl, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.cons)
      >>=? fun ctxt -> logged_return (Item (hd :: tl, rest), ctxt)
  | (Nil, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data)
      >>=? fun ctxt -> logged_return (Item ([], rest), ctxt)
  | (If_cons (_, bf), Item ([], rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf rest
  | (If_cons (bt, _), Item (hd :: tl, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt ->
      step ?log ctxt step_constants bt (Item (hd, Item (tl, rest)))
  | (List_map body, Item (l, rest)) ->
      let rec loop rest ctxt l acc =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_map)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (Item (List.rev acc, rest), ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, rest))
            >>=? fun (Item (hd, rest), ctxt) -> loop rest ctxt tl (hd :: acc)
      in
      loop rest ctxt l [] >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (List_size, Item (list, rest)) ->
      Lwt.return
        (List.fold_left
           (fun acc _ ->
             acc
             >>? fun (size, ctxt) ->
             Gas.consume ctxt Interp_costs.loop_size
             >>? fun ctxt -> ok (size + 1 (* FIXME: overflow *), ctxt))
           (ok (0, ctxt))
           list)
      >>=? fun (len, ctxt) ->
      logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt)
  | (List_iter body, Item (l, init)) ->
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  (* sets *)
  | (Empty_set t, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_set)
      >>=? fun ctxt -> logged_return (Item (empty_set t, rest), ctxt)
  | (Set_iter body, Item (set, init)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set))
      >>=? fun ctxt ->
      let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (Set_mem, Item (v, Item (set, rest))) ->
      consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt
  | (Set_update, Item (v, Item (presence, Item (set, rest)))) ->
      consume_gas_terop
        descr
        (set_update, v, presence, set)
        Interp_costs.set_update
        rest
  | (Set_size, Item (set, rest)) ->
      consume_gas_unop
        descr
        (set_size, set)
        (fun _ -> Interp_costs.set_size)
        rest
        ctxt
  (* maps *)
  | (Empty_map (t, _), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
      >>=? fun ctxt -> logged_return (Item (empty_map t, rest), ctxt)
  | (Map_map body, Item (map, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map))
      >>=? fun ctxt ->
      let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
      let rec loop rest ctxt l acc =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_map)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (acc, ctxt)
        | ((k, _) as hd) :: tl ->
            step ?log ctxt step_constants body (Item (hd, rest))
            >>=? fun (Item (hd, rest), ctxt) ->
            loop rest ctxt tl (map_update k (Some hd) acc)
      in
      loop rest ctxt l (empty_map (map_key_ty map))
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Map_iter body, Item (map, init)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map))
      >>=? fun ctxt ->
      let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (Map_mem, Item (v, Item (map, rest))) ->
      consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt
  | (Map_get, Item (v, Item (map, rest))) ->
      consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt
  | (Map_update, Item (k, Item (v, Item (map, rest)))) ->
      consume_gas_terop
        descr
        (map_update, k, v, map)
        Interp_costs.map_update
        rest
  | (Map_size, Item (map, rest)) ->
      consume_gas_unop
        descr
        (map_size, map)
        (fun _ -> Interp_costs.map_size)
        rest
        ctxt
  (* Big map operations *)
  | (Empty_big_map (tk, tv), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt)
  | (Big_map_mem, Item (key, Item (map, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff))
      >>=? fun ctxt ->
      Script_ir_translator.big_map_mem ctxt key map
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Big_map_get, Item (key, Item (map, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff))
      >>=? fun ctxt ->
      Script_ir_translator.big_map_get ctxt key map
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Big_map_update, Item (key, Item (maybe_value, Item (map, rest)))) ->
      consume_gas_terop
        descr
        (Script_ir_translator.big_map_update, key, maybe_value, map)
        (fun k v m -> Interp_costs.map_update k (Some v) m.diff)
        rest
  (* timestamp operations *)
  | (Add_seconds_to_timestamp, Item (n, Item (t, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.add_delta, t, n)
        Interp_costs.add_timestamp
        rest
        ctxt
  | (Add_timestamp_to_seconds, Item (t, Item (n, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.add_delta, t, n)
        Interp_costs.add_timestamp
        rest
        ctxt
  | (Sub_timestamp_seconds, Item (t, Item (s, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.sub_delta, t, s)
        Interp_costs.sub_timestamp
        rest
        ctxt
  | (Diff_timestamps, Item (t1, Item (t2, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.diff, t1, t2)
        Interp_costs.diff_timestamps
        rest
        ctxt
  (* string operations *)
  | (Concat_string_pair, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y]))
      >>=? fun ctxt ->
      let s = String.concat "" [x; y] in
      logged_return (Item (s, rest), ctxt)
  | (Concat_string, Item (ss, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss))
      >>=? fun ctxt ->
      let s = String.concat "" ss in
      logged_return (Item (s, rest), ctxt)
  | (Slice_string, Item (offset, Item (length, Item (s, rest)))) ->
      let s_length = Z.of_int (String.length s) in
      let offset = Script_int.to_zint offset in
      let length = Script_int.to_zint length in
      if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
        Lwt.return
          (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length)))
        >>=? fun ctxt ->
        logged_return
          ( Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest),
            ctxt )
      else
        Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0))
        >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (String_size, Item (s, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt)
  (* bytes operations *)
  | (Concat_bytes_pair, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y]))
      >>=? fun ctxt ->
      let s = MBytes.concat "" [x; y] in
      logged_return (Item (s, rest), ctxt)
  | (Concat_bytes, Item (ss, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss))
      >>=? fun ctxt ->
      let s = MBytes.concat "" ss in
      logged_return (Item (s, rest), ctxt)
  | (Slice_bytes, Item (offset, Item (length, Item (s, rest)))) ->
      let s_length = Z.of_int (MBytes.length s) in
      let offset = Script_int.to_zint offset in
      let length = Script_int.to_zint length in
      if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
        Lwt.return
          (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length)))
        >>=? fun ctxt ->
        logged_return
          ( Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest),
            ctxt )
      else
        Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0))
        >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (Bytes_size, Item (s, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt)
  (* currency operations *)
  | (Add_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return Tez.(x +? y)
      >>=? fun res -> logged_return (Item (res, rest), ctxt)
  | (Sub_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return Tez.(x -? y)
      >>=? fun res -> logged_return (Item (res, rest), ctxt)
  | (Mul_teznat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64)
      >>=? fun ctxt ->
      match Script_int.to_int64 y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some y ->
          Lwt.return Tez.(x *? y)
          >>=? fun res -> logged_return (Item (res, rest), ctxt) )
  | (Mul_nattez, Item (y, Item (x, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64)
      >>=? fun ctxt ->
      match Script_int.to_int64 y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some y ->
          Lwt.return Tez.(x *? y)
          >>=? fun res -> logged_return (Item (res, rest), ctxt) )
  (* boolean operations *)
  | (Or, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (( || ), x, y) Interp_costs.bool_binop rest ctxt
  | (And, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (( && ), x, y) Interp_costs.bool_binop rest ctxt
  | (Xor, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Compare.Bool.( <> ), x, y)
        Interp_costs.bool_binop
        rest
        ctxt
  | (Not, Item (x, rest)) ->
      consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt
  (* integer operations *)
  | (Is_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt
  | (Abs_int, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
  | (Int_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
  | (Neg_int, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
  | (Neg_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
  | (Add_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.add_n, x, y)
        Interp_costs.add
        rest
        ctxt
  | (Sub_int, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt
  | (Mul_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.mul_n, x, y)
        Interp_costs.mul
        rest
        ctxt
  | (Ediv_teznat, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      let x = Script_int.of_int64 (Tez.to_mutez x) in
      consume_gas_binop
        descr
        ( (fun x y ->
            match Script_int.ediv x y with
            | None ->
                None
            | Some (q, r) -> (
              match (Script_int.to_int64 q, Script_int.to_int64 r) with
              | (Some q, Some r) -> (
                match (Tez.of_mutez q, Tez.of_mutez r) with
                | (Some q, Some r) ->
                    Some (q, r)
                (* Cannot overflow *)
                | _ ->
                    assert false )
              (* Cannot overflow *)
              | _ ->
                  assert false )),
          x,
          y )
        Interp_costs.div
        rest
        ctxt
  | (Ediv_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
      let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
      consume_gas_binop
        descr
        ( (fun x y ->
            match Script_int.ediv_n x y with
            | None ->
                None
            | Some (q, r) -> (
              match Script_int.to_int64 r with
              | None ->
                  assert false (* Cannot overflow *)
              | Some r -> (
                match Tez.of_mutez r with
                | None ->
                    assert false (* Cannot overflow *)
                | Some r ->
                    Some (q, r) ) )),
          x,
          y )
        Interp_costs.div
        rest
        ctxt
  | (Ediv_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv_n, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Lsl_nat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y))
      >>=? fun ctxt ->
      match Script_int.shift_left_n x y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some x ->
          logged_return (Item (x, rest), ctxt) )
  | (Lsr_nat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y))
      >>=? fun ctxt ->
      match Script_int.shift_right_n x y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some r ->
          logged_return (Item (r, rest), ctxt) )
  | (Or_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logor, x, y)
        Interp_costs.logor
        rest
        ctxt
  | (And_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logand, x, y)
        Interp_costs.logand
        rest
        ctxt
  | (And_int_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logand, x, y)
        Interp_costs.logand
        rest
        ctxt
  | (Xor_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logxor, x, y)
        Interp_costs.logxor
        rest
        ctxt
  | (Not_int, Item (x, rest)) ->
      consume_gas_unop
        descr
        (Script_int.lognot, x)
        Interp_costs.lognot
        rest
        ctxt
  | (Not_nat, Item (x, rest)) ->
      consume_gas_unop
        descr
        (Script_int.lognot, x)
        Interp_costs.lognot
        rest
        ctxt
  (* control *)
  | (Seq (hd, tl), stack) ->
      step ?log ctxt step_constants hd stack
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants tl trans
  | (If (bt, _), Item (true, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt rest
  | (If (_, bf), Item (false, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf rest
  | (Loop body, Item (true, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt ->
      step ?log ctxt step_constants body rest
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans
  | (Loop _, Item (false, rest)) ->
      logged_return (rest, ctxt)
  | (Loop_left body, Item (L v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt ->
      step ?log ctxt step_constants body (Item (v, rest))
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans
  | (Loop_left _, Item (R v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt -> logged_return (Item (v, rest), ctxt)
  | (Dip b, Item (ign, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt ->
      step ?log ctxt step_constants b rest
      >>=? fun (res, ctxt) -> logged_return (Item (ign, res), ctxt)
  | (Exec, Item (arg, Item (lam, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.exec)
      >>=? fun ctxt ->
      interp ?log ctxt step_constants lam arg
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Apply capture_ty, Item (capture, Item (lam, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.apply)
      >>=? fun ctxt ->
      let (Lam (descr, expr)) = lam in
      let (Item_t (full_arg_ty, _, _)) = descr.bef in
      unparse_data ctxt Optimized capture_ty capture
      >>=? fun (const_expr, ctxt) ->
      unparse_ty ctxt capture_ty
      >>=? fun (ty_expr, ctxt) ->
      match full_arg_ty with
      | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _, _) ->
          let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in
          let const_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = Item_t (capture_ty, arg_stack_ty, None);
                instr = Const capture;
              }
              : (_, _) descr )
          in
          let pair_descr =
            ( {
                loc = descr.loc;
                bef = Item_t (capture_ty, arg_stack_ty, None);
                aft = Item_t (full_arg_ty, Empty_t, None);
                instr = Cons_pair;
              }
              : (_, _) descr )
          in
          let seq_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = Item_t (full_arg_ty, Empty_t, None);
                instr = Seq (const_descr, pair_descr);
              }
              : (_, _) descr )
          in
          let full_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = descr.aft;
                instr = Seq (seq_descr, descr);
              }
              : (_, _) descr )
          in
          let full_expr =
            Micheline.Seq
              ( 0,
                [ Prim (0, I_PUSH, [ty_expr; const_expr], []);
                  Prim (0, I_PAIR, [], []);
                  expr ] )
          in
          let lam' = Lam (full_descr, full_expr) in
          logged_return (Item (lam', rest), ctxt)
      | _ ->
          assert false )
  | (Lambda lam, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt -> logged_return (Item (lam, rest), ctxt)
  | (Failwith tv, Item (v, _)) ->
      trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)
      >>=? fun (v, _ctxt) ->
      let v = Micheline.strip_locations v in
      fail (Reject (loc, v, get_log log))
  | (Nop, stack) ->
      logged_return (stack, ctxt)
  (* comparison *)
  | (Compare ty, Item (a, Item (b, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b))
      >>=? fun ctxt ->
      logged_return
        ( Item
            ( Script_int.of_int
              @@ Script_ir_translator.compare_comparable ty a b,
              rest ),
          ctxt )
  (* comparators *)
  | (Eq, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres = 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Neq, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres <> 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Lt, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres < 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Le, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres <= 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Gt, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres > 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Ge, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres >= 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  (* packing *)
  | (Pack t, Item (value, rest)) ->
      Script_ir_translator.pack_data ctxt t value
      >>=? fun (bytes, ctxt) -> logged_return (Item (bytes, rest), ctxt)
  | (Unpack t, Item (bytes, rest)) ->
      Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes))
      >>=? fun () ->
      if
        Compare.Int.(MBytes.length bytes >= 1)
        && Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05)
      then
        let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
        match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
        | None ->
            Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes))
            >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
        | Some expr -> (
            Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr))
            >>=? fun ctxt ->
            parse_data ctxt ~legacy:false t (Micheline.root expr)
            >>= function
            | Ok (value, ctxt) ->
                logged_return (Item (Some value, rest), ctxt)
            | Error _ignored ->
                Lwt.return
                  (Gas.consume ctxt (Interp_costs.unpack_failed bytes))
                >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) )
      else logged_return (Item (None, rest), ctxt)
  (* protocol *)
  | (Address, Item ((_, address), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.address)
      >>=? fun ctxt -> logged_return (Item (address, rest), ctxt)
  | (Contract (t, entrypoint), Item (contract, rest)) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.contract)
      >>=? fun ctxt ->
      match (contract, entrypoint) with
      | ((contract, "default"), entrypoint)
      | ((contract, entrypoint), "default") ->
          Script_ir_translator.parse_contract_for_script
            ~legacy:false
            ctxt
            loc
            t
            contract
            ~entrypoint
          >>=? fun (ctxt, maybe_contract) ->
          logged_return (Item (maybe_contract, rest), ctxt)
      | _ ->
          logged_return (Item (None, rest), ctxt) )
  | ( Transfer_tokens,
      Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) )
    ->
      Lwt.return (Gas.consume ctxt Interp_costs.transfer)
      >>=? fun ctxt ->
      collect_big_maps ctxt tp p
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        tp
        p
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (p, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized tp p
      >>=? fun (p, ctxt) ->
      let operation =
        Transaction
          {
            amount;
            destination;
            entrypoint;
            parameters = Script.lazy_expr (Micheline.strip_locations p);
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              rest ),
          ctxt )
  | ( Create_account,
      Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest))))
    ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_account)
      >>=? fun ctxt ->
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      (* store in optimized binary representation - as unparsed with [Optimized]. *)
      let manager_bytes =
        Data_encoding.Binary.to_bytes_exn
          Signature.Public_key_hash.encoding
          manager
      in
      let storage =
        Script_repr.lazy_expr @@ Micheline.strip_locations
        @@ Micheline.Bytes (0, manager_bytes)
      in
      let script = {code = Legacy_support.manager_script_code; storage} in
      let operation =
        Origination {credit; delegate; preorigination = Some contract; script}
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                None ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | (Implicit_account, Item (key, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.implicit_account)
      >>=? fun ctxt ->
      let contract = Contract.implicit_contract key in
      logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt)
  | ( Create_contract (storage_type, param_type, Lam (_, code), root_name),
      Item
        ( manager,
          Item
            ( delegate,
              Item
                ( spendable,
                  Item (delegatable, Item (credit, Item (init, rest))) ) ) ) )
    ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_contract)
      >>=? fun ctxt ->
      unparse_ty ctxt param_type
      >>=? fun (unparsed_param_type, ctxt) ->
      let unparsed_param_type =
        Script_ir_translator.add_field_annot
          (Option.map ~f:(fun n -> `Field_annot n) root_name)
          None
          unparsed_param_type
      in
      unparse_ty ctxt storage_type
      >>=? fun (unparsed_storage_type, ctxt) ->
      let code =
        Script.lazy_expr
        @@ Micheline.strip_locations
             (Seq
                ( 0,
                  [ Prim (0, K_parameter, [unparsed_param_type], []);
                    Prim (0, K_storage, [unparsed_storage_type], []);
                    Prim (0, K_code, [code], []) ] ))
      in
      collect_big_maps ctxt storage_type init
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        storage_type
        init
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (init, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized storage_type init
      >>=? fun (storage, ctxt) ->
      let storage = Script.lazy_expr @@ Micheline.strip_locations storage in
      ( if spendable then
        Legacy_support.add_do
          ~manager_pkh:manager
          ~script_code:code
          ~script_storage:storage
      else if delegatable then
        Legacy_support.add_set_delegate
          ~manager_pkh:manager
          ~script_code:code
          ~script_storage:storage
      else if Legacy_support.has_default_entrypoint code then
        Legacy_support.add_root_entrypoint code
        >>=? fun code -> return (code, storage)
      else return (code, storage) )
      >>=? fun (code, storage) ->
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      let operation =
        Origination
          {
            credit;
            delegate;
            preorigination = Some contract;
            script = {code; storage};
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | ( Create_contract_2 (storage_type, param_type, Lam (_, code), root_name),
      (* Removed the instruction's arguments manager, spendable and delegatable *)
    Item (delegate, Item (credit, Item (init, rest))) ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_contract)
      >>=? fun ctxt ->
      unparse_ty ctxt param_type
      >>=? fun (unparsed_param_type, ctxt) ->
      let unparsed_param_type =
        Script_ir_translator.add_field_annot
          (Option.map ~f:(fun n -> `Field_annot n) root_name)
          None
          unparsed_param_type
      in
      unparse_ty ctxt storage_type
      >>=? fun (unparsed_storage_type, ctxt) ->
      let code =
        Micheline.strip_locations
          (Seq
             ( 0,
               [ Prim (0, K_parameter, [unparsed_param_type], []);
                 Prim (0, K_storage, [unparsed_storage_type], []);
                 Prim (0, K_code, [code], []) ] ))
      in
      collect_big_maps ctxt storage_type init
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        storage_type
        init
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (init, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized storage_type init
      >>=? fun (storage, ctxt) ->
      let storage = Micheline.strip_locations storage in
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      let operation =
        Origination
          {
            credit;
            delegate;
            preorigination = Some contract;
            script =
              {
                code = Script.lazy_expr code;
                storage = Script.lazy_expr storage;
              };
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | (Set_delegate, Item (delegate, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_account)
      >>=? fun ctxt ->
      let operation = Delegation delegate in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                None ),
              rest ),
          ctxt )
  | (Balance, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.balance)
      >>=? fun ctxt ->
      Contract.get_balance ctxt step_constants.self
      >>=? fun balance -> logged_return (Item (balance, rest), ctxt)
  | (Now, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.now)
      >>=? fun ctxt ->
      let now = Script_timestamp.now ctxt in
      logged_return (Item (now, rest), ctxt)
  | (Check_signature, Item (key, Item (signature, Item (message, rest)))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message))
      >>=? fun ctxt ->
      let res = Signature.check key signature message in
      logged_return (Item (res, rest), ctxt)
  | (Hash_key, Item (key, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.hash_key)
      >>=? fun ctxt ->
      logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
  | (Blake2b, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.blake2b bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Sha256, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.sha256 bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Sha512, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.sha512 bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Steps_to_quota, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota)
      >>=? fun ctxt ->
      let steps =
        match Gas.level ctxt with
        | Limited {remaining} ->
            remaining
        | Unaccounted ->
            Z.of_string "99999999"
      in
      logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
  | (Source, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.source)
      >>=? fun ctxt ->
      logged_return (Item ((step_constants.payer, "default"), rest), ctxt)
  | (Sender, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.source)
      >>=? fun ctxt ->
      logged_return (Item ((step_constants.source, "default"), rest), ctxt)
  | (Self (t, entrypoint), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.self)
      >>=? fun ctxt ->
      logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt)
  | (Amount, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.amount)
      >>=? fun ctxt -> logged_return (Item (step_constants.amount, rest), ctxt)
  | (Dig (n, n'), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun (Item (v, rest)) -> return (rest, v))
        n'
        stack
      >>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt)
  | (Dug (n, n'), Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk -> return (Item (v, stk), ()))
        n'
        rest
      >>=? fun (aft, ()) -> logged_return (aft, ctxt)
  | (Dipn (n, n', b), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk ->
          step ?log ctxt step_constants b stk
          >>=? fun (res, ctxt') -> return (res, ctxt'))
        n'
        stack
      >>=? fun (aft, ctxt') -> logged_return (aft, ctxt')
  | (Dropn (n, n'), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk -> return (stk, stk))
        n'
        stack
      >>=? fun (_, rest) -> logged_return (rest, ctxt)
  | (ChainId, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.chain_id)
      >>=? fun ctxt ->
      logged_return (Item (step_constants.chain_id, rest), ctxt)

and interp :
    type p r.
    ?log:execution_trace ref ->
    context ->
    step_constants ->
    (p, r) lambda ->
    p ->
    (r * context) tzresult Lwt.t =
 fun ?log ctxt step_constants (Lam (code, _)) arg ->
  let stack = Item (arg, Empty) in
  ( match log with
  | None ->
      return_unit
  | Some log ->
      trace Cannot_serialize_log (unparse_stack ctxt (stack, code.bef))
      >>=? fun stack ->
      log := (code.loc, Gas.level ctxt, stack) :: !log ;
      return_unit )
  >>=? fun () ->
  step ?log ctxt step_constants code stack
  >>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt)

(* ---- contract handling ---------------------------------------------------*)
and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg :
    ( Script.expr
    * packed_internal_operation list
    * context
    * Contract.big_map_diff option )
    tzresult
    Lwt.t =
  parse_script ctxt unparsed_script ~legacy:true
  >>=? fun (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) ->
  trace
    (Bad_contract_parameter step_constants.self)
    (Lwt.return (find_entrypoint arg_type ~root_name entrypoint))
  >>=? fun (box, _) ->
  trace
    (Bad_contract_parameter step_constants.self)
    (parse_data ctxt ~legacy:false arg_type (box arg))
  >>=? fun (arg, ctxt) ->
  Script.force_decode ctxt unparsed_script.code
  >>=? fun (script_code, ctxt) ->
  Script_ir_translator.collect_big_maps ctxt arg_type arg
  >>=? fun (to_duplicate, ctxt) ->
  Script_ir_translator.collect_big_maps ctxt storage_type storage
  >>=? fun (to_update, ctxt) ->
  trace
    (Runtime_contract_error (step_constants.self, script_code))
    (interp ?log ctxt step_constants code (arg, storage))
  >>=? fun ((ops, storage), ctxt) ->
  Script_ir_translator.extract_big_map_diff
    ctxt
    mode
    ~temporary:false
    ~to_duplicate
    ~to_update
    storage_type
    storage
  >>=? fun (storage, big_map_diff, ctxt) ->
  trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage)
  >>=? fun (storage, ctxt) ->
  let (ops, op_diffs) = List.split ops in
  let big_map_diff =
    match
      List.flatten
        (List.map (Option.unopt ~default:[]) (op_diffs @ [big_map_diff]))
    with
    | [] ->
        None
    | diff ->
        Some diff
  in
  return (Micheline.strip_locations storage, ops, ctxt, big_map_diff)

type execution_result = {
  ctxt : context;
  storage : Script.expr;
  big_map_diff : Contract.big_map_diff option;
  operations : packed_internal_operation list;
}

let trace ctxt mode step_constants ~script ~entrypoint ~parameter =
  let log = ref [] in
  execute
    ~log
    ctxt
    mode
    step_constants
    ~entrypoint
    script
    (Micheline.root parameter)
  >>=? fun (storage, operations, ctxt, big_map_diff) ->
  let trace = List.rev !log in
  return ({ctxt; storage; big_map_diff; operations}, trace)

let execute ctxt mode step_constants ~script ~entrypoint ~parameter =
  execute
    ctxt
    mode
    step_constants
    ~entrypoint
    script
    (Micheline.root parameter)
  >>=? fun (storage, operations, ctxt, big_map_diff) ->
  return {ctxt; storage; big_map_diff; operations}
src/proto_alpha/lib_protocol/script_interpreter.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_raw_protocol_alpha.Alpha_context.Script.

Import Tezos_raw_protocol_alpha.Script_typed_ir.

Import Tezos_raw_protocol_alpha.Script_ir_translator.

Definition execution_trace :=
  list
    (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
      Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))).

Inductive stack : forall (tys : Type), Type :=
| Item : forall {rest ty : Type}, ty -> (stack rest) -> stack (ty * rest)
| Empty : stack Tezos_raw_protocol_alpha.Script_typed_ir.end_of_stack.

Definition unparse_stack {A : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (function_parameter :
    (stack A) * (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty A))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))) :=
  match function_parameter with
  | (stack, stack_ty) =>
    let ctxt := Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited ctxt in
    let fix unparse_stack {a : Type}
      (function_parameter :
      (stack a) * (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a))
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
              (option string)))) :=
      match function_parameter with
      | (Empty, Empty_t) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_nil
      | (Item v rest, Item_t ty rest_ty annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data ctxt
            Readable ty v)
          (fun function_parameter =>
            match function_parameter with
            | (data, _ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (unparse_stack (rest, rest_ty))
                (fun rest =>
                  let annot :=
                    match
                      Tezos_raw_protocol_alpha.Script_ir_annot.unparse_var_annot
                        annot with
                    | [] => None
                    | cons a [] => Some a
                    | _ => false
                    end in
                  let data :=
                    Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                      data in
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (cons (data, annot) rest))
            end)
      end in
    unparse_stack (stack, stack_ty)
  end.

Fixpoint interp_stack_prefix_preserving_operation
  {aft bef faft fbef result : Type}
  (f :
    (stack fbef) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((stack faft) * result)))
  (n :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
      fbef faft bef aft) (stk : stack bef)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((stack aft) * result)) :=
  match (n, stk) with
  |
    (Prefix
      (Prefix
        (Prefix
          (Prefix
            (Prefix
              (Prefix
                (Prefix
                  (Prefix
                    (Prefix
                      (Prefix
                        (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))),
      Item v0
        (Item v1
          (Item v2
            (Item v3
              (Item v4
                (Item v5
                  (Item v6
                    (Item v7
                      (Item v8
                        (Item v9
                          (Item va
                            (Item vb
                              (Item vc (Item vd (Item ve (Item vf rest))))))))))))))))
    =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        match function_parameter with
        | (rest', result) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            ((Item v0
              (Item v1
                (Item v2
                  (Item v3
                    (Item v4
                      (Item v5
                        (Item v6
                          (Item v7
                            (Item v8
                              (Item v9
                                (Item va
                                  (Item vb
                                    (Item vc (Item vd (Item ve (Item vf rest')))))))))))))))),
              result)
        end)
  |
    (Prefix (Prefix (Prefix (Prefix n))),
      Item v0 (Item v1 (Item v2 (Item v3 rest)))) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        match function_parameter with
        | (rest', result) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            ((Item v0 (Item v1 (Item v2 (Item v3 rest')))), result)
        end)
  | (Prefix n, Item v rest) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        match function_parameter with
        | (rest', result) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            ((Item v rest'), result)
        end)
  | (Rest, v) => f v
  end.

Record step_constants := {
  source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  self : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  amount : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  }.

Fixpoint step {a b : Type}
  (log :
    option
      (Tezos_protocol_environment_alpha__Environment.Pervasives.ref
        execution_trace))
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (step_constants : step_constants)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.descr b a)
  : (stack b) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | {| loc := loc; instr := instr |} as descr =>
    fun stack =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
            Interp_costs.cycle))
        (fun ctxt =>
          let logged_return
            (descr : Tezos_raw_protocol_alpha.Script_typed_ir.descr b a)
            (function_parameter :
            (stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)
            : Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                ((stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
            match function_parameter with
            | (ret, ctxt) =>
              match log with
              | None =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (ret, ctxt)
              | Some log =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                    Cannot_serialize_log (unparse_stack ctxt (ret, (aft descr))))
                  (fun stack =>
                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
                      log
                      (cons
                        ((loc descr),
                          (Tezos_raw_protocol_alpha.Alpha_context.Gas.level ctxt),
                          stack)
                        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
                          log));
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (ret, ctxt))
              end
            end in
          let get_log
            (log :
            option
              (Tezos_protocol_environment_alpha__Environment.Pervasives.ref
                execution_trace))
            : option
              (list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
                  Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
                  (list
                    (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                      (option string))))) :=
            Tezos_protocol_environment_alpha__Environment.Option.map
              (fun l =>
                Tezos_protocol_environment_alpha__Environment.List.rev
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
                    l)) log in
          let consume_gas_terop {C D E arg1 arg2 arg3 rest ret : Type}
            (descr :
            Tezos_raw_protocol_alpha.Script_typed_ir.descr
              (C * (D * (E * rest))) (ret * rest)) (function_parameter :
            (arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3)
            : (arg1 ->
              arg2 -> arg3 -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost)
              ->
              (stack rest) ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    ((stack (ret * rest)) *
                      Tezos_raw_protocol_alpha.Alpha_context.context)) :=
            match function_parameter with
            | (op, x1, x2, x3) =>
              fun cost_func =>
                fun rest =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        (cost_func x1 x2 x3)))
                    (fun ctxt =>
                      logged_return descr ((Item (op x1 x2 x3) rest), ctxt))
            end in
          let consume_gas_binop {C D arg1 arg2 rest ret : Type}
            (descr :
            Tezos_raw_protocol_alpha.Script_typed_ir.descr (C * (D * rest))
              (ret * rest)) (function_parameter :
            (arg1 -> arg2 -> ret) * arg1 * arg2)
            : (arg1 -> arg2 -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost)
              ->
              (stack rest) ->
                Tezos_raw_protocol_alpha.Alpha_context.context ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                      ((stack (ret * rest)) *
                        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
            match function_parameter with
            | (op, x1, x2) =>
              fun cost_func =>
                fun rest =>
                  fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                          (cost_func x1 x2)))
                      (fun ctxt =>
                        logged_return descr ((Item (op x1 x2) rest), ctxt))
            end in
          let consume_gas_unop {C arg rest ret : Type}
            (descr :
            Tezos_raw_protocol_alpha.Script_typed_ir.descr (C * rest)
              (ret * rest)) (function_parameter : (arg -> ret) * arg)
            : (arg -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost) ->
              (stack rest) ->
                Tezos_raw_protocol_alpha.Alpha_context.context ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                      ((stack (ret * rest)) *
                        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
            match function_parameter with
            | (op, arg) =>
              fun cost_func =>
                fun rest =>
                  fun ctxt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                          (cost_func arg)))
                      (fun ctxt =>
                        logged_return descr ((Item (op arg) rest), ctxt))
            end in
          let logged_return := logged_return descr in
          match (instr, stack) with
          | (Drop, Item _ rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.stack_op))
              (fun ctxt => logged_return (rest, ctxt))
          | (Dup, Item v rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.stack_op))
              (fun ctxt => logged_return ((Item v (Item v rest)), ctxt))
          | (Swap, Item vi (Item vo rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.stack_op))
              (fun ctxt => logged_return ((Item vo (Item vi rest)), ctxt))
          | (Const v, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.push))
              (fun ctxt => logged_return ((Item v rest), ctxt))
          | (Cons_some, Item v rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.wrap))
              (fun ctxt => logged_return ((Item (Some v) rest), ctxt))
          | (Cons_none _, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.variant_no_data))
              (fun ctxt => logged_return ((Item None rest), ctxt))
          | (If_none bt _, Item None rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.branch))
              (fun ctxt => step log ctxt step_constants bt rest)
          | (If_none _ bf, Item (Some v) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.branch))
              (fun ctxt => step log ctxt step_constants bf (Item v rest))
          | (Cons_pair, Item a (Item b rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.pair))
              (fun ctxt => logged_return ((Item (a, b) rest), ctxt))
          |
            (Seq {| instr := Dup |} {|
              instr :=
                Seq {| instr := Car |} {|
                  instr :=
                    Seq {|
                      instr := Dip {| instr := Cdr |}
                        |}
                      {|
                      instr := Nop
                        |}
                    |}
                |}, Item (a, b) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.pair_access))
              (fun ctxt => logged_return ((Item a (Item b rest)), ctxt))
          | (Car, Item (a, _) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.pair_access))
              (fun ctxt => logged_return ((Item a rest), ctxt))
          | (Cdr, Item (_, b) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.pair_access))
              (fun ctxt => logged_return ((Item b rest), ctxt))
          | (Left, Item v rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.wrap))
              (fun ctxt => logged_return ((Item (L v) rest), ctxt))
          | (Right, Item v rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.wrap))
              (fun ctxt => logged_return ((Item (R v) rest), ctxt))
          | (If_left bt _, Item (L v) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.branch))
              (fun ctxt => step log ctxt step_constants bt (Item v rest))
          | (If_left _ bf, Item (R v) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.branch))
              (fun ctxt => step log ctxt step_constants bf (Item v rest))
          | (Cons_list, Item hd (Item tl rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.cons))
              (fun ctxt => logged_return ((Item (cons hd tl) rest), ctxt))
          | (Nil, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.variant_no_data))
              (fun ctxt => logged_return ((Item [] rest), ctxt))
          | (If_cons _ bf, Item [] rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.branch))
              (fun ctxt => step log ctxt step_constants bf rest)
          | (If_cons bt _, Item (cons hd tl) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.branch))
              (fun ctxt =>
                step log ctxt step_constants bt (Item hd (Item tl rest)))
          | (List_map body, Item l rest) =>
            let fix loop
              (rest : stack op_dollar_4_9) (ctxt :
              Tezos_raw_protocol_alpha__Alpha_context.context) (l :
              list op_dollar_4_8) (acc : list op_dollar_5_0)
              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  ((stack ((list op_dollar_5_0) * op_dollar_4_9)) *
                    Tezos_raw_protocol_alpha__Alpha_context.context)) :=
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Interp_costs.loop_map))
                (fun ctxt =>
                  match l with
                  | [] =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      ((Item
                        (Tezos_protocol_environment_alpha__Environment.List.rev
                          acc) rest), ctxt)
                  | cons hd tl =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (step log ctxt step_constants body (Item hd rest))
                      (fun function_parameter =>
                        match function_parameter with
                        | (Item hd rest, ctxt) =>
                          loop rest ctxt tl (cons hd acc)
                        end)
                  end) in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (loop rest ctxt l [])
              (fun function_parameter =>
                match function_parameter with
                | (res, ctxt) => logged_return (res, ctxt)
                end)
          | (List_size, Item list rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_protocol_environment_alpha__Environment.List.fold_left
                  (fun acc =>
                    fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                          acc
                          (fun function_parameter =>
                            match function_parameter with
                            | (size, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                  ctxt Interp_costs.loop_size)
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                    ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                                      size 1), ctxt))
                            end)
                      end)
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                    (0, ctxt)) list))
              (fun function_parameter =>
                match function_parameter with
                | (len, ctxt) =>
                  logged_return
                    ((Item
                      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs
                        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int
                          len)) rest), ctxt)
                end)
          | (List_iter body, Item l init) =>
            let fix loop
              (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
              list op_dollar_5_3) (stack : stack op_dollar_5_4)
              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  ((stack op_dollar_5_4) *
                    Tezos_raw_protocol_alpha__Alpha_context.context)) :=
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Interp_costs.loop_iter))
                (fun ctxt =>
                  match l with
                  | [] =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (stack, ctxt)
                  | cons hd tl =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (step log ctxt step_constants body (Item hd stack))
                      (fun function_parameter =>
                        match function_parameter with
                        | (stack, ctxt) => loop ctxt tl stack
                        end)
                  end) in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (loop ctxt l init)
              (fun function_parameter =>
                match function_parameter with
                | (res, ctxt) => logged_return (res, ctxt)
                end)
          | (Empty_set t, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.empty_set))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Tezos_raw_protocol_alpha.Script_ir_translator.empty_set t)
                    rest), ctxt))
          | (Set_iter body, Item set init) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.set_to_list set)))
              (fun ctxt =>
                let l :=
                  Tezos_protocol_environment_alpha__Environment.List.rev
                    (Tezos_raw_protocol_alpha.Script_ir_translator.set_fold
                      (fun e => fun acc => cons e acc) set []) in
                let fix loop
                  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
                  list op_dollar_5_6) (stack : stack op_dollar_5_7)
                  : Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                      ((stack op_dollar_5_7) *
                        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        Interp_costs.loop_iter))
                    (fun ctxt =>
                      match l with
                      | [] =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (stack, ctxt)
                      | cons hd tl =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (step log ctxt step_constants body (Item hd stack))
                          (fun function_parameter =>
                            match function_parameter with
                            | (stack, ctxt) => loop ctxt tl stack
                            end)
                      end) in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (loop ctxt l init)
                  (fun function_parameter =>
                    match function_parameter with
                    | (res, ctxt) => logged_return (res, ctxt)
                    end))
          | (Set_mem, Item v (Item set rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Script_ir_translator.set_mem, v, set)
              Interp_costs.set_mem rest ctxt
          | (Set_update, Item v (Item presence (Item set rest))) =>
            consume_gas_terop descr
              (Tezos_raw_protocol_alpha.Script_ir_translator.set_update, v,
                presence, set) Interp_costs.set_update rest
          | (Set_size, Item set rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Script_ir_translator.set_size, set)
              (fun function_parameter =>
                match function_parameter with
                | _ => Interp_costs.set_size
                end) rest ctxt
          | (Empty_map t _, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.empty_map))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Tezos_raw_protocol_alpha.Script_ir_translator.empty_map t)
                    rest), ctxt))
          | (Map_map body, Item map rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.map_to_list map)))
              (fun ctxt =>
                let l :=
                  Tezos_protocol_environment_alpha__Environment.List.rev
                    (Tezos_raw_protocol_alpha.Script_ir_translator.map_fold
                      (fun k => fun v => fun acc => cons (k, v) acc) map []) in
                let fix loop
                  (rest : stack op_dollar_6_8) (ctxt :
                  Tezos_raw_protocol_alpha__Alpha_context.context) (l :
                  list (op_dollar_6_6 * op_dollar_6_7)) (acc :
                  Tezos_raw_protocol_alpha.Script_typed_ir.map op_dollar_6_6
                    op_dollar_6_9)
                  : Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                      ((Tezos_raw_protocol_alpha.Script_typed_ir.map
                        op_dollar_6_6 op_dollar_6_9) *
                        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        Interp_costs.loop_map))
                    (fun ctxt =>
                      match l with
                      | [] =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (acc, ctxt)
                      | cons ((k, _) as hd) tl =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (step log ctxt step_constants body (Item hd rest))
                          (fun function_parameter =>
                            match function_parameter with
                            | (Item hd rest, ctxt) =>
                              loop rest ctxt tl
                                (Tezos_raw_protocol_alpha.Script_ir_translator.map_update
                                  k (Some hd) acc)
                            end)
                      end) in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (loop rest ctxt l
                    (Tezos_raw_protocol_alpha.Script_ir_translator.empty_map
                      (Tezos_raw_protocol_alpha.Script_ir_translator.map_key_ty
                        map)))
                  (fun function_parameter =>
                    match function_parameter with
                    | (res, ctxt) => logged_return ((Item res rest), ctxt)
                    end))
          | (Map_iter body, Item map init) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.map_to_list map)))
              (fun ctxt =>
                let l :=
                  Tezos_protocol_environment_alpha__Environment.List.rev
                    (Tezos_raw_protocol_alpha.Script_ir_translator.map_fold
                      (fun k => fun v => fun acc => cons (k, v) acc) map []) in
                let fix loop
                  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
                  list (op_dollar_7_0 * op_dollar_7_1)) (stack :
                  stack op_dollar_7_2)
                  : Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                      ((stack op_dollar_7_2) *
                        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        Interp_costs.loop_iter))
                    (fun ctxt =>
                      match l with
                      | [] =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (stack, ctxt)
                      | cons hd tl =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (step log ctxt step_constants body (Item hd stack))
                          (fun function_parameter =>
                            match function_parameter with
                            | (stack, ctxt) => loop ctxt tl stack
                            end)
                      end) in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (loop ctxt l init)
                  (fun function_parameter =>
                    match function_parameter with
                    | (res, ctxt) => logged_return (res, ctxt)
                    end))
          | (Map_mem, Item v (Item map rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Script_ir_translator.map_mem, v, map)
              Interp_costs.map_mem rest ctxt
          | (Map_get, Item v (Item map rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Script_ir_translator.map_get, v, map)
              Interp_costs.map_get rest ctxt
          | (Map_update, Item k (Item v (Item map rest))) =>
            consume_gas_terop descr
              (Tezos_raw_protocol_alpha.Script_ir_translator.map_update, k, v,
                map) Interp_costs.map_update rest
          | (Map_size, Item map rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Script_ir_translator.map_size, map)
              (fun function_parameter =>
                match function_parameter with
                | _ => Interp_costs.map_size
                end) rest ctxt
          | (Empty_big_map tk tv, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.empty_map))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Tezos_raw_protocol_alpha.Script_ir_translator.empty_big_map
                      tk tv) rest), ctxt))
          | (Big_map_mem, Item key (Item map rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.map_mem key (diff map))))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Script_ir_translator.big_map_mem
                    ctxt key map)
                  (fun function_parameter =>
                    match function_parameter with
                    | (res, ctxt) => logged_return ((Item res rest), ctxt)
                    end))
          | (Big_map_get, Item key (Item map rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.map_get key (diff map))))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Script_ir_translator.big_map_get
                    ctxt key map)
                  (fun function_parameter =>
                    match function_parameter with
                    | (res, ctxt) => logged_return ((Item res rest), ctxt)
                    end))
          | (Big_map_update, Item key (Item maybe_value (Item map rest))) =>
            consume_gas_terop descr
              (Tezos_raw_protocol_alpha.Script_ir_translator.big_map_update,
                key, maybe_value, map)
              (fun k =>
                fun v => fun m => Interp_costs.map_update k (Some v) (diff m))
              rest
          | (Add_seconds_to_timestamp, Item n (Item t rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.add_delta,
                t, n) Interp_costs.add_timestamp rest ctxt
          | (Add_timestamp_to_seconds, Item t (Item n rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.add_delta,
                t, n) Interp_costs.add_timestamp rest ctxt
          | (Sub_timestamp_seconds, Item t (Item s rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.sub_delta,
                t, s) Interp_costs.sub_timestamp rest ctxt
          | (Diff_timestamps, Item t1 (Item t2 rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.diff, t1,
                t2) Interp_costs.diff_timestamps rest ctxt
          | (Concat_string_pair, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.concat_string (cons x (cons y [])))))
              (fun ctxt =>
                let s :=
                  Tezos_protocol_environment_alpha__Environment.String.concat
                    "" % string (cons x (cons y [])) in
                logged_return ((Item s rest), ctxt))
          | (Concat_string, Item ss rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.concat_string ss)))
              (fun ctxt =>
                let s :=
                  Tezos_protocol_environment_alpha__Environment.String.concat
                    "" % string ss in
                logged_return ((Item s rest), ctxt))
          | (Slice_string, Item offset (Item length (Item s rest))) =>
            let s_length :=
              Tezos_protocol_environment_alpha__Environment.Z.of_int
                (Tezos_protocol_environment_alpha__Environment.String.length s)
              in
            let offset :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_zint offset
              in
            let length :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_zint length
              in
            if
              Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                  offset s_length)
                (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
                  (Tezos_protocol_environment_alpha__Environment.Z.add offset
                    length) s_length) then
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    (Interp_costs.slice_string
                      (Tezos_protocol_environment_alpha__Environment.Z.to_int
                        length))))
                (fun ctxt =>
                  logged_return
                    ((Item
                      (Some
                        (Tezos_protocol_environment_alpha__Environment.String.sub
                          s
                          (Tezos_protocol_environment_alpha__Environment.Z.to_int
                            offset)
                          (Tezos_protocol_environment_alpha__Environment.Z.to_int
                            length))) rest), ctxt))
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    (Interp_costs.slice_string 0)))
                (fun ctxt => logged_return ((Item None rest), ctxt))
          | (String_size, Item s rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.push))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs
                      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int
                        (Tezos_protocol_environment_alpha__Environment.String.length
                          s))) rest), ctxt))
          | (Concat_bytes_pair, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.concat_bytes (cons x (cons y [])))))
              (fun ctxt =>
                let s :=
                  Tezos_protocol_environment_alpha__Environment.MBytes.concat
                    "" % string (cons x (cons y [])) in
                logged_return ((Item s rest), ctxt))
          | (Concat_bytes, Item ss rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.concat_bytes ss)))
              (fun ctxt =>
                let s :=
                  Tezos_protocol_environment_alpha__Environment.MBytes.concat
                    "" % string ss in
                logged_return ((Item s rest), ctxt))
          | (Slice_bytes, Item offset (Item length (Item s rest))) =>
            let s_length :=
              Tezos_protocol_environment_alpha__Environment.Z.of_int
                (Tezos_protocol_environment_alpha__Environment.MBytes.length s)
              in
            let offset :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_zint offset
              in
            let length :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_zint length
              in
            if
              Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                  offset s_length)
                (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
                  (Tezos_protocol_environment_alpha__Environment.Z.add offset
                    length) s_length) then
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    (Interp_costs.slice_string
                      (Tezos_protocol_environment_alpha__Environment.Z.to_int
                        length))))
                (fun ctxt =>
                  logged_return
                    ((Item
                      (Some
                        (Tezos_protocol_environment_alpha__Environment.MBytes.sub
                          s
                          (Tezos_protocol_environment_alpha__Environment.Z.to_int
                            offset)
                          (Tezos_protocol_environment_alpha__Environment.Z.to_int
                            length))) rest), ctxt))
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    (Interp_costs.slice_string 0)))
                (fun ctxt => logged_return ((Item None rest), ctxt))
          | (Bytes_size, Item s rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.push))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs
                      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int
                        (Tezos_protocol_environment_alpha__Environment.MBytes.length
                          s))) rest), ctxt))
          | (Add_tez, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.int64_op))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_plus_question
                      x y)) (fun res => logged_return ((Item res rest), ctxt)))
          | (Sub_tez, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.int64_op))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_minus_question
                      x y)) (fun res => logged_return ((Item res rest), ctxt)))
          | (Mul_teznat, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.int64_op))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                      Interp_costs.z_to_int64))
                  (fun ctxt =>
                    match
                      Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_int64
                        y with
                    | None =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                        (Overflow loc (get_log log))
                    | Some y =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_star_question
                            x y))
                        (fun res => logged_return ((Item res rest), ctxt))
                    end))
          | (Mul_nattez, Item y (Item x rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.int64_op))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                      Interp_costs.z_to_int64))
                  (fun ctxt =>
                    match
                      Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_int64
                        y with
                    | None =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                        (Overflow loc (get_log log))
                    | Some y =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Alpha_context.Tez.op_star_question
                            x y))
                        (fun res => logged_return ((Item res rest), ctxt))
                    end))
          | (Or, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe,
                x, y) Interp_costs.bool_binop rest ctxt
          | (And, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and,
                x, y) Interp_costs.bool_binop rest ctxt
          | (Xor, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_gt),
                x, y) Interp_costs.bool_binop rest ctxt
          | (Not, Item x rest) =>
            consume_gas_unop descr
              (Tezos_protocol_environment_alpha__Environment.Pervasives.not, x)
              Interp_costs.bool_unop rest ctxt
          | (Is_nat, Item x rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.is_nat, x)
              Interp_costs.abs rest ctxt
          | (Abs_int, Item x rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs, x)
              Interp_costs.abs rest ctxt
          | (Int_nat, Item x rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.int, x)
              Interp_costs.int rest ctxt
          | (Neg_int, Item x rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.neg, x)
              Interp_costs.neg rest ctxt
          | (Neg_nat, Item x rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.neg, x)
              Interp_costs.neg rest ctxt
          | (Add_intint, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.add, x, y)
              Interp_costs.add rest ctxt
          | (Add_intnat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.add, x, y)
              Interp_costs.add rest ctxt
          | (Add_natint, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.add, x, y)
              Interp_costs.add rest ctxt
          | (Add_natnat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.add_n, x, y)
              Interp_costs.add rest ctxt
          | (Sub_int, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.sub, x, y)
              Interp_costs.sub rest ctxt
          | (Mul_intint, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.mul, x, y)
              Interp_costs.mul rest ctxt
          | (Mul_intnat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.mul, x, y)
              Interp_costs.mul rest ctxt
          | (Mul_natint, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.mul, x, y)
              Interp_costs.mul rest ctxt
          | (Mul_natnat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.mul_n, x, y)
              Interp_costs.mul rest ctxt
          | (Ediv_teznat, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.int64_to_z))
              (fun ctxt =>
                let x :=
                  Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int64
                    (Tezos_raw_protocol_alpha.Alpha_context.Tez.to_mutez x) in
                consume_gas_binop descr
                  ((fun x =>
                    fun y =>
                      match
                        Tezos_raw_protocol_alpha.Alpha_context.Script_int.ediv x
                          y with
                      | None => None
                      | Some (q, r) =>
                        match
                          ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_int64
                            q),
                            (Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_int64
                              r)) with
                        | (Some q, Some r) =>
                          match
                            ((Tezos_raw_protocol_alpha.Alpha_context.Tez.of_mutez
                              q),
                              (Tezos_raw_protocol_alpha.Alpha_context.Tez.of_mutez
                                r)) with
                          | (Some q, Some r) => Some (q, r)
                          | _ => false
                          end
                        | _ => false
                        end
                      end), x, y) Interp_costs.div rest ctxt)
          | (Ediv_tez, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.int64_to_z))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                      Interp_costs.int64_to_z))
                  (fun ctxt =>
                    let x :=
                      Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs
                        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int64
                          (Tezos_raw_protocol_alpha.Alpha_context.Tez.to_mutez x))
                      in
                    let y :=
                      Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs
                        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int64
                          (Tezos_raw_protocol_alpha.Alpha_context.Tez.to_mutez y))
                      in
                    consume_gas_binop descr
                      ((fun x =>
                        fun y =>
                          match
                            Tezos_raw_protocol_alpha.Alpha_context.Script_int.ediv_n
                              x y with
                          | None => None
                          | Some (q, r) =>
                            match
                              Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_int64
                                r with
                            | None => false
                            | Some r =>
                              match
                                Tezos_raw_protocol_alpha.Alpha_context.Tez.of_mutez
                                  r with
                              | None => false
                              | Some r => Some (q, r)
                              end
                            end
                          end), x, y) Interp_costs.div rest ctxt))
          | (Ediv_intint, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.ediv, x, y)
              Interp_costs.div rest ctxt
          | (Ediv_intnat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.ediv, x, y)
              Interp_costs.div rest ctxt
          | (Ediv_natint, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.ediv, x, y)
              Interp_costs.div rest ctxt
          | (Ediv_natnat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.ediv_n, x, y)
              Interp_costs.div rest ctxt
          | (Lsl_nat, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.shift_left x y)))
              (fun ctxt =>
                match
                  Tezos_raw_protocol_alpha.Alpha_context.Script_int.shift_left_n
                    x y with
                | None =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                    (Overflow loc (get_log log))
                | Some x => logged_return ((Item x rest), ctxt)
                end)
          | (Lsr_nat, Item x (Item y rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.shift_right x y)))
              (fun ctxt =>
                match
                  Tezos_raw_protocol_alpha.Alpha_context.Script_int.shift_right_n
                    x y with
                | None =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                    (Overflow loc (get_log log))
                | Some r => logged_return ((Item r rest), ctxt)
                end)
          | (Or_nat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.logor, x, y)
              Interp_costs.logor rest ctxt
          | (And_nat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.logand, x, y)
              Interp_costs.logand rest ctxt
          | (And_int_nat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.logand, x, y)
              Interp_costs.logand rest ctxt
          | (Xor_nat, Item x (Item y rest)) =>
            consume_gas_binop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.logxor, x, y)
              Interp_costs.logxor rest ctxt
          | (Not_int, Item x rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.lognot, x)
              Interp_costs.lognot rest ctxt
          | (Not_nat, Item x rest) =>
            consume_gas_unop descr
              (Tezos_raw_protocol_alpha.Alpha_context.Script_int.lognot, x)
              Interp_costs.lognot rest ctxt
          | (Seq hd tl, stack) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (step log ctxt step_constants hd stack)
              (fun function_parameter =>
                match function_parameter with
                | (trans, ctxt) => step log ctxt step_constants tl trans
                end)
          | (If bt _, Item true rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.branch))
              (fun ctxt => step log ctxt step_constants bt rest)
          | (If _ bf, Item false rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.branch))
              (fun ctxt => step log ctxt step_constants bf rest)
          | (Loop body, Item true rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.loop_cycle))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (step log ctxt step_constants body rest)
                  (fun function_parameter =>
                    match function_parameter with
                    | (trans, ctxt) => step log ctxt step_constants descr trans
                    end))
          | (Loop _, Item false rest) => logged_return (rest, ctxt)
          | (Loop_left body, Item (L v) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.loop_cycle))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (step log ctxt step_constants body (Item v rest))
                  (fun function_parameter =>
                    match function_parameter with
                    | (trans, ctxt) => step log ctxt step_constants descr trans
                    end))
          | (Loop_left _, Item (R v) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.loop_cycle))
              (fun ctxt => logged_return ((Item v rest), ctxt))
          | (Dip b, Item ign rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.stack_op))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (step log ctxt step_constants b rest)
                  (fun function_parameter =>
                    match function_parameter with
                    | (res, ctxt) => logged_return ((Item ign res), ctxt)
                    end))
          | (Exec, Item arg (Item lam rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.exec))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (interp log ctxt step_constants lam arg)
                  (fun function_parameter =>
                    match function_parameter with
                    | (res, ctxt) => logged_return ((Item res rest), ctxt)
                    end))
          | (Apply capture_ty, Item capture (Item lam rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.apply))
              (fun ctxt =>
                match lam with
                | Lam descr expr =>
                  match bef descr with
                  | Item_t full_arg_ty _ _ =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data
                        ctxt Optimized capture_ty capture)
                      (fun function_parameter =>
                        match function_parameter with
                        | (const_expr, ctxt) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_ty
                              ctxt capture_ty)
                            (fun function_parameter =>
                              match function_parameter with
                              | (ty_expr, ctxt) =>
                                match full_arg_ty with
                                | Pair_t (capture_ty, _, _) (arg_ty, _, _) _ _
                                  =>
                                  let arg_stack_ty := Item_t arg_ty Empty_t None
                                    in
                                  let const_descr :=
                                    {| loc := loc descr; bef := arg_stack_ty;
                                      aft := Item_t capture_ty arg_stack_ty None;
                                      instr := Const capture |} in
                                  let pair_descr :=
                                    {| loc := loc descr;
                                      bef := Item_t capture_ty arg_stack_ty None;
                                      aft := Item_t full_arg_ty Empty_t None;
                                      instr := Cons_pair |} in
                                  let seq_descr :=
                                    {| loc := loc descr; bef := arg_stack_ty;
                                      aft := Item_t full_arg_ty Empty_t None;
                                      instr := Seq const_descr pair_descr |} in
                                  let full_descr :=
                                    {| loc := loc descr; bef := arg_stack_ty;
                                      aft := aft descr;
                                      instr := Seq seq_descr descr |} in
                                  let full_expr :=
                                    Micheline.Seq 0
                                      (cons
                                        (Prim 0 I_PUSH
                                          (cons ty_expr (cons const_expr [])) [])
                                        (cons (Prim 0 I_PAIR [] [])
                                          (cons expr []))) in
                                  let lam' := Lam full_descr full_expr in
                                  logged_return ((Item lam' rest), ctxt)
                                | _ => false
                                end
                              end)
                        end)
                  end
                end)
          | (Lambda lam, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.push))
              (fun ctxt => logged_return ((Item lam rest), ctxt))
          | (Failwith tv, Item v _) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                Cannot_serialize_failure
                (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data ctxt
                  Optimized tv v))
              (fun function_parameter =>
                match function_parameter with
                | (v, _ctxt) =>
                  let v :=
                    Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                      v in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                    (Reject loc v (get_log log))
                end)
          | (Nop, stack) => logged_return (stack, ctxt)
          | (Compare ty, Item a (Item b rest)) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.compare ty a b)))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int
                      (Tezos_raw_protocol_alpha.Script_ir_translator.compare_comparable
                        ty a b)) rest), ctxt))
          | (Eq, Item cmpres rest) =>
            let cmpres :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare cmpres
                Tezos_raw_protocol_alpha.Alpha_context.Script_int.zero in
            let cmpres :=
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                cmpres 0 in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.compare_res))
              (fun ctxt => logged_return ((Item cmpres rest), ctxt))
          | (Neq, Item cmpres rest) =>
            let cmpres :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare cmpres
                Tezos_raw_protocol_alpha.Alpha_context.Script_int.zero in
            let cmpres :=
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_gt)
                cmpres 0 in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.compare_res))
              (fun ctxt => logged_return ((Item cmpres rest), ctxt))
          | (Lt, Item cmpres rest) =>
            let cmpres :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare cmpres
                Tezos_raw_protocol_alpha.Alpha_context.Script_int.zero in
            let cmpres :=
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                cmpres 0 in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.compare_res))
              (fun ctxt => logged_return ((Item cmpres rest), ctxt))
          | (Le, Item cmpres rest) =>
            let cmpres :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare cmpres
                Tezos_raw_protocol_alpha.Alpha_context.Script_int.zero in
            let cmpres :=
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
                cmpres 0 in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.compare_res))
              (fun ctxt => logged_return ((Item cmpres rest), ctxt))
          | (Gt, Item cmpres rest) =>
            let cmpres :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare cmpres
                Tezos_raw_protocol_alpha.Alpha_context.Script_int.zero in
            let cmpres :=
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                cmpres 0 in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.compare_res))
              (fun ctxt => logged_return ((Item cmpres rest), ctxt))
          | (Ge, Item cmpres rest) =>
            let cmpres :=
              Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare cmpres
                Tezos_raw_protocol_alpha.Alpha_context.Script_int.zero in
            let cmpres :=
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                cmpres 0 in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.compare_res))
              (fun ctxt => logged_return ((Item cmpres rest), ctxt))
          | (Pack t, Item value rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Script_ir_translator.pack_data ctxt t
                value)
              (fun function_parameter =>
                match function_parameter with
                | (bytes, ctxt) => logged_return ((Item string rest), ctxt)
                end)
          | (Unpack t, Item bytes rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.check_enough ctxt
                  (Tezos_raw_protocol_alpha.Alpha_context.Script.serialized_cost
                    string)))
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  if
                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                        (Tezos_protocol_environment_alpha__Environment.MBytes.length
                          string) 1)
                      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                        (Tezos_protocol_environment_alpha__Environment.MBytes.get_uint8
                          string 0) 5) then
                    let bytes :=
                      Tezos_protocol_environment_alpha__Environment.MBytes.sub
                        string 1
                        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                          (Tezos_protocol_environment_alpha__Environment.MBytes.length
                            string) 1) in
                    match
                      Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                        Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding
                        string with
                    | None =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                            ctxt (Interp_costs.unpack_failed string)))
                        (fun ctxt => logged_return ((Item None rest), ctxt))
                    | Some expr =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                            ctxt
                            (Tezos_raw_protocol_alpha.Alpha_context.Script.deserialized_cost
                              expr)))
                        (fun ctxt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (Tezos_raw_protocol_alpha.Script_ir_translator.parse_data
                              None ctxt false t
                              (Tezos_protocol_environment_alpha__Environment.Micheline.root
                                expr))
                            (fun function_parameter =>
                              match function_parameter with
                              | inl (value, ctxt) =>
                                logged_return ((Item (Some value) rest), ctxt)
                              | inr _ignored =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                      ctxt (Interp_costs.unpack_failed string)))
                                  (fun ctxt =>
                                    logged_return ((Item None rest), ctxt))
                              end))
                    end
                  else
                    logged_return ((Item None rest), ctxt)
                end)
          | (Address, Item (_, address) rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.address))
              (fun ctxt => logged_return ((Item address rest), ctxt))
          | (Contract t entrypoint, Item contract rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.contract))
              (fun ctxt =>
                match (contract, entrypoint) with
                |
                  ((contract, "default" % string), entrypoint) |
                    ((contract, entrypoint), "default" % string) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_raw_protocol_alpha.Script_ir_translator.parse_contract_for_script
                      false ctxt loc t contract entrypoint)
                    (fun function_parameter =>
                      match function_parameter with
                      | (ctxt, maybe_contract) =>
                        logged_return ((Item maybe_contract rest), ctxt)
                      end)
                | _ => logged_return ((Item None rest), ctxt)
                end)
          |
            (Transfer_tokens,
              Item p (Item amount (Item (tp, (destination, entrypoint)) rest)))
            =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.transfer))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Script_ir_translator.collect_big_maps
                    ctxt tp p)
                  (fun function_parameter =>
                    match function_parameter with
                    | (to_duplicate, ctxt) =>
                      let to_update :=
                        Tezos_raw_protocol_alpha.Script_ir_translator.no_big_map_id
                        in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Script_ir_translator.extract_big_map_diff
                          ctxt Optimized true to_duplicate to_update tp p)
                        (fun function_parameter =>
                          match function_parameter with
                          | (p, big_map_diff, ctxt) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data
                                ctxt Optimized tp p)
                              (fun function_parameter =>
                                match function_parameter with
                                | (p, ctxt) =>
                                  let operation :=
                                    Transaction
                                      {| amount := amount;
                                        parameters :=
                                          Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                                            (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                              p); entrypoint := entrypoint;
                                        destination := destination |} in
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                      (Tezos_raw_protocol_alpha.Alpha_context.fresh_internal_nonce
                                        ctxt))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (ctxt, nonce) =>
                                        logged_return
                                          ((Item
                                            ((Internal_operation
                                              {| source := self step_constants;
                                                operation := operation;
                                                nonce := nonce |}), big_map_diff)
                                            rest), ctxt)
                                      end)
                                end)
                          end)
                    end))
          |
            (Create_account,
              Item manager
                (Item delegate (Item _delegatable (Item credit rest)))) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.create_account))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Alpha_context.Contract.fresh_contract_from_current_nonce
                    ctxt)
                  (fun function_parameter =>
                    match function_parameter with
                    | (ctxt, contract) =>
                      let manager_bytes :=
                        Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
                          manager in
                      let storage :=
                        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                          Tezos_raw_protocol_alpha.Script_repr.lazy_expr
                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                            Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                            (Micheline.Bytes 0 manager_bytes)) in
                      let script :=
                        {|
                          code :=
                            Tezos_raw_protocol_alpha.Alpha_context.Script.Legacy_support.manager_script_code;
                          storage := storage |} in
                      let operation :=
                        Origination
                          {| delegate := delegate; script := script;
                            credit := credit; preorigination := Some contract |}
                        in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_raw_protocol_alpha.Alpha_context.fresh_internal_nonce
                            ctxt))
                        (fun function_parameter =>
                          match function_parameter with
                          | (ctxt, nonce) =>
                            logged_return
                              ((Item
                                ((Internal_operation
                                  {| source := self step_constants;
                                    operation := operation; nonce := nonce |}),
                                  None)
                                (Item (contract, "default" % string) rest)),
                                ctxt)
                          end)
                    end))
          | (Implicit_account, Item key rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.implicit_account))
              (fun ctxt =>
                let contract :=
                  Tezos_raw_protocol_alpha.Alpha_context.Contract.implicit_contract
                    key in
                logged_return
                  ((Item ((Unit_t None), (contract, "default" % string)) rest),
                    ctxt))
          |
            (Create_contract storage_type param_type (Lam _ code) root_name,
              Item manager
                (Item delegate
                  (Item spendable
                    (Item delegatable (Item credit (Item init rest)))))) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.create_contract))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_ty ctxt
                    param_type)
                  (fun function_parameter =>
                    match function_parameter with
                    | (unparsed_param_type, ctxt) =>
                      let unparsed_param_type :=
                        Tezos_raw_protocol_alpha.Script_ir_translator.add_field_annot
                          (Tezos_protocol_environment_alpha__Environment.Option.map
                            (fun n => variant) root_name) None
                          unparsed_param_type in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_ty
                          ctxt storage_type)
                        (fun function_parameter =>
                          match function_parameter with
                          | (unparsed_storage_type, ctxt) =>
                            let code :=
                              Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                                (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                  (Seq 0
                                    (cons
                                      (Prim 0 K_parameter
                                        (cons unparsed_param_type []) [])
                                      (cons
                                        (Prim 0 K_storage
                                          (cons unparsed_storage_type []) [])
                                        (cons (Prim 0 K_code (cons code []) [])
                                          []))))) in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Script_ir_translator.collect_big_maps
                                ctxt storage_type init)
                              (fun function_parameter =>
                                match function_parameter with
                                | (to_duplicate, ctxt) =>
                                  let to_update :=
                                    Tezos_raw_protocol_alpha.Script_ir_translator.no_big_map_id
                                    in
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Script_ir_translator.extract_big_map_diff
                                      ctxt Optimized true to_duplicate to_update
                                      storage_type init)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (init, big_map_diff, ctxt) =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data
                                            ctxt Optimized storage_type init)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (storage, ctxt) =>
                                              let storage :=
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                    storage) in
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (if spendable then
                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.Legacy_support.add_do
                                                    manager code storage
                                                else
                                                  if delegatable then
                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.Legacy_support.add_set_delegate
                                                      manager code storage
                                                  else
                                                    if
                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.Legacy_support.has_default_entrypoint
                                                        code then
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (Tezos_raw_protocol_alpha.Alpha_context.Script.Legacy_support.add_root_entrypoint
                                                          code)
                                                        (fun code =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                            (code, storage))
                                                    else
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                        (code, storage))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (code, storage) =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (Tezos_raw_protocol_alpha.Alpha_context.Contract.fresh_contract_from_current_nonce
                                                        ctxt)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | (ctxt, contract) =>
                                                          let operation :=
                                                            Origination
                                                              {|
                                                                delegate :=
                                                                  delegate;
                                                                script :=
                                                                  {|
                                                                    code := code;
                                                                    storage :=
                                                                      storage |};
                                                                credit := credit;
                                                                preorigination :=
                                                                  Some contract
                                                                |} in
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                              (Tezos_raw_protocol_alpha.Alpha_context.fresh_internal_nonce
                                                                ctxt))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | (ctxt, nonce) =>
                                                                logged_return
                                                                  ((Item
                                                                    ((Internal_operation
                                                                      {|
                                                                        source :=
                                                                          self
                                                                            step_constants;
                                                                        operation :=
                                                                          operation;
                                                                        nonce :=
                                                                          nonce
                                                                        |}),
                                                                      big_map_diff)
                                                                    (Item
                                                                      (contract,
                                                                        "default"
                                                                          %
                                                                          string)
                                                                      rest)),
                                                                    ctxt)
                                                              end)
                                                        end)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end))
          |
            (Create_contract_2 storage_type param_type (Lam _ code) root_name,
              Item delegate (Item credit (Item init rest))) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.create_contract))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_ty ctxt
                    param_type)
                  (fun function_parameter =>
                    match function_parameter with
                    | (unparsed_param_type, ctxt) =>
                      let unparsed_param_type :=
                        Tezos_raw_protocol_alpha.Script_ir_translator.add_field_annot
                          (Tezos_protocol_environment_alpha__Environment.Option.map
                            (fun n => variant) root_name) None
                          unparsed_param_type in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_ty
                          ctxt storage_type)
                        (fun function_parameter =>
                          match function_parameter with
                          | (unparsed_storage_type, ctxt) =>
                            let code :=
                              Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                (Seq 0
                                  (cons
                                    (Prim 0 K_parameter
                                      (cons unparsed_param_type []) [])
                                    (cons
                                      (Prim 0 K_storage
                                        (cons unparsed_storage_type []) [])
                                      (cons (Prim 0 K_code (cons code []) []) []))))
                              in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_alpha.Script_ir_translator.collect_big_maps
                                ctxt storage_type init)
                              (fun function_parameter =>
                                match function_parameter with
                                | (to_duplicate, ctxt) =>
                                  let to_update :=
                                    Tezos_raw_protocol_alpha.Script_ir_translator.no_big_map_id
                                    in
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_raw_protocol_alpha.Script_ir_translator.extract_big_map_diff
                                      ctxt Optimized true to_duplicate to_update
                                      storage_type init)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (init, big_map_diff, ctxt) =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data
                                            ctxt Optimized storage_type init)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (storage, ctxt) =>
                                              let storage :=
                                                Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                  storage in
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_raw_protocol_alpha.Alpha_context.Contract.fresh_contract_from_current_nonce
                                                  ctxt)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (ctxt, contract) =>
                                                    let operation :=
                                                      Origination
                                                        {| delegate := delegate;
                                                          script :=
                                                            {|
                                                              code :=
                                                                Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                                                                  code;
                                                              storage :=
                                                                Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                                                                  storage |};
                                                          credit := credit;
                                                          preorigination :=
                                                            Some contract |} in
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                        (Tezos_raw_protocol_alpha.Alpha_context.fresh_internal_nonce
                                                          ctxt))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | (ctxt, nonce) =>
                                                          logged_return
                                                            ((Item
                                                              ((Internal_operation
                                                                {|
                                                                  source :=
                                                                    self
                                                                      step_constants;
                                                                  operation :=
                                                                    operation;
                                                                  nonce := nonce
                                                                  |}),
                                                                big_map_diff)
                                                              (Item
                                                                (contract,
                                                                  "default" %
                                                                    string) rest)),
                                                              ctxt)
                                                        end)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end))
          | (Set_delegate, Item delegate rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.create_account))
              (fun ctxt =>
                let operation := Delegation delegate in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (Tezos_raw_protocol_alpha.Alpha_context.fresh_internal_nonce
                      ctxt))
                  (fun function_parameter =>
                    match function_parameter with
                    | (ctxt, nonce) =>
                      logged_return
                        ((Item
                          ((Internal_operation
                            {| source := self step_constants;
                              operation := operation; nonce := nonce |}), None)
                          rest), ctxt)
                    end))
          | (Balance, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.balance))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_balance
                    ctxt (self step_constants))
                  (fun balance => logged_return ((Item balance rest), ctxt)))
          | (Now, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.now))
              (fun ctxt =>
                let now :=
                  Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.now
                    ctxt in
                logged_return ((Item now rest), ctxt))
          | (Check_signature, Item key (Item signature (Item message rest))) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.check_signature key message)))
              (fun ctxt =>
                let res :=
                  Tezos_protocol_environment_alpha__Environment.Signature.check
                    None key signature message in
                logged_return ((Item res rest), ctxt))
          | (Hash_key, Item key rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.hash_key))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                      key) rest), ctxt))
          | (Blake2b, Item bytes rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.hash_blake2b string)))
              (fun ctxt =>
                let hash :=
                  Tezos_protocol_environment_alpha__Environment.Raw_hashes.blake2b
                    string in
                logged_return ((Item hash rest), ctxt))
          | (Sha256, Item bytes rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.hash_sha256 string)))
              (fun ctxt =>
                let hash :=
                  Tezos_protocol_environment_alpha__Environment.Raw_hashes.sha256
                    string in
                logged_return ((Item hash rest), ctxt))
          | (Sha512, Item bytes rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.hash_sha512 string)))
              (fun ctxt =>
                let hash :=
                  Tezos_protocol_environment_alpha__Environment.Raw_hashes.sha512
                    string in
                logged_return ((Item hash rest), ctxt))
          | (Steps_to_quota, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.steps_to_quota))
              (fun ctxt =>
                let steps :=
                  match Tezos_raw_protocol_alpha.Alpha_context.Gas.level ctxt
                    with
                  | Limited {| remaining := remaining |} => remaining
                  | Unaccounted =>
                    Tezos_protocol_environment_alpha__Environment.Z.of_string
                      "99999999" % string
                  end in
                logged_return
                  ((Item
                    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs
                      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_zint
                        steps)) rest), ctxt))
          | (Source, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.source))
              (fun ctxt =>
                logged_return
                  ((Item ((payer step_constants), "default" % string) rest),
                    ctxt))
          | (Sender, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.source))
              (fun ctxt =>
                logged_return
                  ((Item ((source step_constants), "default" % string) rest),
                    ctxt))
          | (Self t entrypoint, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.self))
              (fun ctxt =>
                logged_return
                  ((Item (t, ((self step_constants), entrypoint)) rest), ctxt))
          | (Amount, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.amount))
              (fun ctxt =>
                logged_return ((Item (amount step_constants) rest), ctxt))
          | (Dig n n', stack) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.stack_n_op n)))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (interp_stack_prefix_preserving_operation
                    (fun function_parameter =>
                      match function_parameter with
                      | Item v rest =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (rest, v)
                      end) n' stack)
                  (fun function_parameter =>
                    match function_parameter with
                    | (aft, x) => logged_return ((Item x aft), ctxt)
                    end))
          | (Dug n n', Item v rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.stack_n_op n)))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (interp_stack_prefix_preserving_operation
                    (fun stk =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        ((Item v stk), tt)) n' rest)
                  (fun function_parameter =>
                    match function_parameter with
                    | (aft, tt) => logged_return (aft, ctxt)
                    end))
          | (Dipn n n' b, stack) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.stack_n_op n)))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (interp_stack_prefix_preserving_operation
                    (fun stk =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (step log ctxt step_constants b stk)
                        (fun function_parameter =>
                          match function_parameter with
                          | (res, ctxt') =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              (res, ctxt')
                          end)) n' stack)
                  (fun function_parameter =>
                    match function_parameter with
                    | (aft, ctxt') => logged_return (aft, ctxt')
                    end))
          | (Dropn n n', stack) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Interp_costs.stack_n_op n)))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (interp_stack_prefix_preserving_operation
                    (fun stk =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        (stk, stk)) n' stack)
                  (fun function_parameter =>
                    match function_parameter with
                    | (_, rest) => logged_return (rest, ctxt)
                    end))
          | (ChainId, rest) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Interp_costs.chain_id))
              (fun ctxt =>
                logged_return ((Item (chain_id step_constants) rest), ctxt))
          end)
  end

with interp {p r : Type}
  (log :
    option
      (Tezos_protocol_environment_alpha__Environment.Pervasives.ref
        execution_trace))
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (step_constants : step_constants)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.lambda p r)
  : p ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (r * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | Lam code _ =>
    fun arg =>
      let stack := Item arg Empty in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        match log with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
        | Some log =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
              Cannot_serialize_log (unparse_stack ctxt (stack, (bef code))))
            (fun stack =>
              Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
                log
                (cons
                  ((loc code),
                    (Tezos_raw_protocol_alpha.Alpha_context.Gas.level ctxt),
                    stack)
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
                    log));
              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit)
        end
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (step log ctxt step_constants code stack)
              (fun function_parameter =>
                match function_parameter with
                | (Item ret Empty, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (ret, ctxt)
                end)
          end)
  end

with execute
  (log :
    option
      (Tezos_protocol_environment_alpha__Environment.Pervasives.ref
        execution_trace))
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (step_constants : step_constants) (entrypoint : string)
  (unparsed_script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
  (arg : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        (list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
        * Tezos_raw_protocol_alpha.Alpha_context.context *
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Script_ir_translator.parse_script None ctxt true
      unparsed_script)
    (fun function_parameter =>
      match function_parameter with
      |
        (Ex_script {|
          code := code;
            arg_type := arg_type;
            storage := storage;
            storage_type := storage_type;
            root_name := root_name
            |}, ctxt) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
            (Bad_contract_parameter (self step_constants))
            (Tezos_protocol_environment_alpha__Environment.Lwt._return
              (Tezos_raw_protocol_alpha.Script_ir_translator.find_entrypoint
                arg_type root_name entrypoint)))
          (fun function_parameter =>
            match function_parameter with
            | (box, _) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                  (Bad_contract_parameter (self step_constants))
                  (Tezos_raw_protocol_alpha.Script_ir_translator.parse_data None
                    ctxt false arg_type (box arg)))
                (fun function_parameter =>
                  match function_parameter with
                  | (arg, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                        ctxt (code unparsed_script))
                      (fun function_parameter =>
                        match function_parameter with
                        | (script_code, ctxt) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_raw_protocol_alpha.Script_ir_translator.collect_big_maps
                              ctxt arg_type arg)
                            (fun function_parameter =>
                              match function_parameter with
                              | (to_duplicate, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_raw_protocol_alpha.Script_ir_translator.collect_big_maps
                                    ctxt storage_type storage)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (to_update, ctxt) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                          (Runtime_contract_error
                                            (self step_constants) script_code)
                                          (interp log ctxt step_constants code
                                            (arg, storage)))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | ((ops, storage), ctxt) =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (Tezos_raw_protocol_alpha.Script_ir_translator.extract_big_map_diff
                                                ctxt mode false to_duplicate
                                                to_update storage_type storage)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (storage, big_map_diff, ctxt)
                                                  =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                                      Cannot_serialize_storage
                                                      (Tezos_raw_protocol_alpha.Script_ir_translator.unparse_data
                                                        ctxt mode storage_type
                                                        storage))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | (storage, ctxt) =>
                                                        match
                                                          Tezos_protocol_environment_alpha__Environment.List.split
                                                            ops with
                                                        | (ops, op_diffs) =>
                                                          let big_map_diff :=
                                                            match
                                                              Tezos_protocol_environment_alpha__Environment.List.flatten
                                                                (Tezos_protocol_environment_alpha__Environment.List.map
                                                                  (Tezos_protocol_environment_alpha__Environment.Option.unopt
                                                                    [])
                                                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                                                    op_diffs
                                                                    (cons
                                                                      big_map_diff
                                                                      []))) with
                                                            | [] => None
                                                            | diff => Some diff
                                                            end in
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                            ((Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                              storage), ops,
                                                              ctxt, big_map_diff)
                                                        end
                                                      end)
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      end).

Record execution_result := {
  ctxt : Tezos_raw_protocol_alpha.Alpha_context.context;
  storage : Tezos_raw_protocol_alpha.Alpha_context.Script.expr;
  big_map_diff :
    option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff;
  operations :
    list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation }.

Definition trace
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (step_constants : step_constants)
  (script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
  (entrypoint : string)
  (parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (execution_result *
        (list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
            (list
              (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                (option string))))))) :=
  let log := Tezos_protocol_environment_alpha__Environment.Pervasives.ref [] in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (execute (Some log) ctxt mode step_constants entrypoint script
      (Tezos_protocol_environment_alpha__Environment.Micheline.root parameter))
    (fun function_parameter =>
      match function_parameter with
      | (storage, operations, ctxt, big_map_diff) =>
        let trace :=
          Tezos_protocol_environment_alpha__Environment.List.rev
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
              log) in
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          ({| ctxt := ctxt; storage := storage; big_map_diff := big_map_diff;
            operations := operations |}, trace)
      end).

Definition execute
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (step_constants : step_constants)
  (script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
  (entrypoint : string)
  (parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      execution_result) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (execute None ctxt mode step_constants entrypoint script
      (Tezos_protocol_environment_alpha__Environment.Micheline.root parameter))
    (fun function_parameter =>
      match function_parameter with
      | (storage, operations, ctxt, big_map_diff) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          {| ctxt := ctxt; storage := storage; big_map_diff := big_map_diff;
            operations := operations |}
      end).
src/proto_alpha/lib_protocol/script_interpreter.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type execution_trace =
  (Script.location * Gas.t * (Script.expr * string option) list) list

type error +=
  | Reject of Script.location * Script.expr * execution_trace option

type error += Overflow of Script.location * execution_trace option

type error += Runtime_contract_error : Contract.t * Script.expr -> error

type error += Bad_contract_parameter of Contract.t (* `Permanent *)

type error += Cannot_serialize_log

type error += Cannot_serialize_failure

type error += Cannot_serialize_storage

type execution_result = {
  ctxt : context;
  storage : Script.expr;
  big_map_diff : Contract.big_map_diff option;
  operations : packed_internal_operation list;
}

type step_constants = {
  source : Contract.t;
  payer : Contract.t;
  self : Contract.t;
  amount : Tez.t;
  chain_id : Chain_id.t;
}

type 'tys stack =
  | Item : 'ty * 'rest stack -> ('ty * 'rest) stack
  | Empty : Script_typed_ir.end_of_stack stack

val step :
  ?log:execution_trace ref ->
  context ->
  step_constants ->
  ('bef, 'aft) Script_typed_ir.descr ->
  'bef stack ->
  ('aft stack * context) tzresult Lwt.t

val execute :
  Alpha_context.t ->
  Script_ir_translator.unparsing_mode ->
  step_constants ->
  script:Script.t ->
  entrypoint:string ->
  parameter:Script.expr ->
  execution_result tzresult Lwt.t

val trace :
  Alpha_context.t ->
  Script_ir_translator.unparsing_mode ->
  step_constants ->
  script:Script.t ->
  entrypoint:string ->
  parameter:Script.expr ->
  (execution_result * execution_trace) tzresult Lwt.t
src/proto_alpha/lib_protocol/script_interpreter.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition execution_trace :=
  list
    (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
      Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))).

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

extensible_type

Record execution_result := {
  ctxt : Tezos_raw_protocol_alpha.Alpha_context.context;
  storage : Tezos_raw_protocol_alpha.Alpha_context.Script.expr;
  big_map_diff :
    option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff;
  operations :
    list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation }.

Record step_constants := {
  source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  self : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  amount : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  }.

Inductive stack : forall (tys : Type), Type :=
| Item : forall {rest ty : Type}, ty -> (stack rest) -> stack (ty * rest)
| Empty : stack Tezos_raw_protocol_alpha.Script_typed_ir.end_of_stack.

Parameter step : forall {aft bef : Type},
(option
  (Tezos_protocol_environment_alpha__Environment.Pervasives.ref execution_trace))
  ->
  Tezos_raw_protocol_alpha.Alpha_context.context ->
    step_constants ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) ->
        (stack bef) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              ((stack aft) * Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter execute :
Tezos_raw_protocol_alpha.Alpha_context.t ->
  Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode ->
    step_constants ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.t ->
        string ->
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                execution_result).

Parameter trace :
Tezos_raw_protocol_alpha.Alpha_context.t ->
  Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode ->
    step_constants ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.t ->
        string ->
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (execution_result * execution_trace)).
src/proto_alpha/lib_protocol/script_ir_annot.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Micheline
open Script_tc_errors
open Script_typed_ir

let default_now_annot = Some (`Var_annot "now")

let default_amount_annot = Some (`Var_annot "amount")

let default_balance_annot = Some (`Var_annot "balance")

let default_steps_annot = Some (`Var_annot "steps")

let default_source_annot = Some (`Var_annot "source")

let default_sender_annot = Some (`Var_annot "sender")

let default_self_annot = Some (`Var_annot "self")

let default_arg_annot = Some (`Var_annot "arg")

let default_param_annot = Some (`Var_annot "parameter")

let default_storage_annot = Some (`Var_annot "storage")

let default_car_annot = Some (`Field_annot "car")

let default_cdr_annot = Some (`Field_annot "cdr")

let default_contract_annot = Some (`Field_annot "contract")

let default_addr_annot = Some (`Field_annot "address")

let default_manager_annot = Some (`Field_annot "manager")

let default_pack_annot = Some (`Field_annot "packed")

let default_unpack_annot = Some (`Field_annot "unpacked")

let default_slice_annot = Some (`Field_annot "slice")

let default_elt_annot = Some (`Field_annot "elt")

let default_key_annot = Some (`Field_annot "key")

let default_hd_annot = Some (`Field_annot "hd")

let default_tl_annot = Some (`Field_annot "tl")

let default_some_annot = Some (`Field_annot "some")

let default_left_annot = Some (`Field_annot "left")

let default_right_annot = Some (`Field_annot "right")

let default_binding_annot = Some (`Field_annot "bnd")

let unparse_type_annot : type_annot option -> string list = function
  | None ->
      []
  | Some (`Type_annot a) ->
      [":" ^ a]

let unparse_var_annot : var_annot option -> string list = function
  | None ->
      []
  | Some (`Var_annot a) ->
      ["@" ^ a]

let unparse_field_annot : field_annot option -> string list = function
  | None ->
      []
  | Some (`Field_annot a) ->
      ["%" ^ a]

let field_to_var_annot : field_annot option -> var_annot option = function
  | None ->
      None
  | Some (`Field_annot s) ->
      Some (`Var_annot s)

let type_to_var_annot : type_annot option -> var_annot option = function
  | None ->
      None
  | Some (`Type_annot s) ->
      Some (`Var_annot s)

let var_to_field_annot : var_annot option -> field_annot option = function
  | None ->
      None
  | Some (`Var_annot s) ->
      Some (`Field_annot s)

let default_annot ~default = function None -> default | annot -> annot

let gen_access_annot :
    var_annot option ->
    ?default:field_annot option ->
    field_annot option ->
    var_annot option =
 fun value_annot ?(default = None) field_annot ->
  match (value_annot, field_annot, default) with
  | (None, None, _) | (Some _, None, None) | (None, Some (`Field_annot ""), _)
    ->
      None
  | (None, Some (`Field_annot f), _) ->
      Some (`Var_annot f)
  | ( Some (`Var_annot v),
      (None | Some (`Field_annot "")),
      Some (`Field_annot f) ) ->
      Some (`Var_annot (String.concat "." [v; f]))
  | (Some (`Var_annot v), Some (`Field_annot f), _) ->
      Some (`Var_annot (String.concat "." [v; f]))

let merge_type_annot :
    legacy:bool ->
    type_annot option ->
    type_annot option ->
    type_annot option tzresult =
 fun ~legacy annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      ok None
  | (Some (`Type_annot a1), Some (`Type_annot a2)) ->
      if legacy || String.equal a1 a2 then ok annot1
      else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))

let merge_field_annot :
    legacy:bool ->
    field_annot option ->
    field_annot option ->
    field_annot option tzresult =
 fun ~legacy annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      ok None
  | (Some (`Field_annot a1), Some (`Field_annot a2)) ->
      if legacy || String.equal a1 a2 then ok annot1
      else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2))

let merge_var_annot : var_annot option -> var_annot option -> var_annot option
    =
 fun annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      None
  | (Some (`Var_annot a1), Some (`Var_annot a2)) ->
      if String.equal a1 a2 then annot1 else None

let error_unexpected_annot loc annot =
  match annot with [] -> ok () | _ :: _ -> error (Unexpected_annotation loc)

let fail_unexpected_annot loc annot =
  Lwt.return (error_unexpected_annot loc annot)

let parse_annots loc ?(allow_special_var = false)
    ?(allow_special_field = false) l =
  (* allow emtpty annotations as wildcards but otherwise only accept
     annotations that start with [a-zA-Z_] *)
  let sub_or_wildcard ~specials wrap s acc =
    let len = String.length s in
    if Compare.Int.(len = 1) then ok @@ (wrap None :: acc)
    else
      match s.[1] with
      | 'a' .. 'z' | 'A' .. 'Z' | '_' ->
          ok @@ (wrap (Some (String.sub s 1 (len - 1))) :: acc)
      | '@' when Compare.Int.(len = 2) && List.mem '@' specials ->
          ok @@ (wrap (Some "@") :: acc)
      | '%' when List.mem '%' specials ->
          if Compare.Int.(len = 2) then ok @@ (wrap (Some "%") :: acc)
          else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then
            ok @@ (wrap (Some "%%") :: acc)
          else error (Unexpected_annotation loc)
      | _ ->
          error (Unexpected_annotation loc)
  in
  List.fold_left
    (fun acc s ->
      acc
      >>? fun acc ->
      if Compare.Int.(String.length s = 0) then
        error (Unexpected_annotation loc)
      else
        match s.[0] with
        | ':' ->
            sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc
        | '@' ->
            sub_or_wildcard
              ~specials:(if allow_special_var then ['%'] else [])
              (fun a -> `Var_annot a)
              s
              acc
        | '%' ->
            sub_or_wildcard
              ~specials:(if allow_special_field then ['@'] else [])
              (fun a -> `Field_annot a)
              s
              acc
        | _ ->
            error (Unexpected_annotation loc))
    (ok [])
    l
  >|? List.rev

let opt_var_of_var_opt = function
  | `Var_annot None ->
      None
  | `Var_annot (Some a) ->
      Some (`Var_annot a)

let opt_field_of_field_opt = function
  | `Field_annot None ->
      None
  | `Field_annot (Some a) ->
      Some (`Field_annot a)

let opt_type_of_type_opt = function
  | `Type_annot None ->
      None
  | `Type_annot (Some a) ->
      Some (`Type_annot a)

let classify_annot loc l :
    (var_annot option list * type_annot option list * field_annot option list)
    tzresult =
  try
    let (_, rv, _, rt, _, rf) =
      List.fold_left
        (fun (in_v, rv, in_t, rt, in_f, rf) a ->
          match (a, in_v, rv, in_t, rt, in_f, rf) with
          | ((`Var_annot _ as a), true, _, _, _, _, _)
          | ((`Var_annot _ as a), false, [], _, _, _, _) ->
              (true, opt_var_of_var_opt a :: rv, false, rt, false, rf)
          | ((`Type_annot _ as a), _, _, true, _, _, _)
          | ((`Type_annot _ as a), _, _, false, [], _, _) ->
              (false, rv, true, opt_type_of_type_opt a :: rt, false, rf)
          | ((`Field_annot _ as a), _, _, _, _, true, _)
          | ((`Field_annot _ as a), _, _, _, _, false, []) ->
              (false, rv, false, rt, true, opt_field_of_field_opt a :: rf)
          | _ ->
              raise Exit)
        (false, [], false, [], false, [])
        l
    in
    ok (List.rev rv, List.rev rt, List.rev rf)
  with Exit -> error (Ungrouped_annotations loc)

let get_one_annot loc = function
  | [] ->
      ok None
  | [a] ->
      ok a
  | _ ->
      error (Unexpected_annotation loc)

let get_two_annot loc = function
  | [] ->
      ok (None, None)
  | [a] ->
      ok (a, None)
  | [a; b] ->
      ok (a, b)
  | _ ->
      error (Unexpected_annotation loc)

let parse_type_annot : int -> string list -> type_annot option tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types

let parse_type_field_annot :
    int -> string list -> (type_annot option * field_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  get_one_annot loc types
  >>? fun t -> get_one_annot loc fields >|? fun f -> (t, f)

let parse_composed_type_annot :
    int ->
    string list ->
    (type_annot option * field_annot option * field_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  get_one_annot loc types
  >>? fun t -> get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2)

let parse_field_annot : int -> string list -> field_annot option tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  error_unexpected_annot loc types >>? fun () -> get_one_annot loc fields

let extract_field_annot :
    Script.node -> (Script.node * field_annot option) tzresult = function
  | Prim (loc, prim, args, annot) ->
      let rec extract_first acc = function
        | [] ->
            (None, annot)
        | s :: rest ->
            if Compare.Int.(String.length s > 0) && Compare.Char.(s.[0] = '%')
            then (Some s, List.rev_append acc rest)
            else extract_first (s :: acc) rest
      in
      let (field_annot, annot) = extract_first [] annot in
      let field_annot =
        match field_annot with
        | None ->
            None
        | Some field_annot ->
            Some
              (`Field_annot
                (String.sub field_annot 1 (String.length field_annot - 1)))
      in
      ok (Prim (loc, prim, args, annot), field_annot)
  | expr ->
      ok (expr, None)

let check_correct_field :
    field_annot option -> field_annot option -> unit tzresult =
 fun f1 f2 ->
  match (f1, f2) with
  | (None, _) | (_, None) ->
      ok ()
  | (Some (`Field_annot s1), Some (`Field_annot s2)) ->
      if String.equal s1 s2 then ok ()
      else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2))

let parse_var_annot :
    int ->
    ?default:var_annot option ->
    string list ->
    var_annot option tzresult =
 fun loc ?default annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  error_unexpected_annot loc fields
  >>? fun () ->
  get_one_annot loc vars
  >|? function
  | Some _ as a ->
      a
  | None -> (
    match default with Some a -> a | None -> None )

let split_last_dot = function
  | None ->
      (None, None)
  | Some (`Field_annot s) -> (
    match String.rindex_opt s '.' with
    | None ->
        (None, Some (`Field_annot s))
    | Some i ->
        let s1 = String.sub s 0 i in
        let s2 = String.sub s (i + 1) (String.length s - i - 1) in
        let f =
          if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr"
          then None
          else Some (`Field_annot s2)
        in
        (Some (`Var_annot s1), f) )

let common_prefix v1 v2 =
  match (v1, v2) with
  | (Some (`Var_annot s1), Some (`Var_annot s2))
    when Compare.String.equal s1 s2 ->
      v1
  | (Some _, None) ->
      v1
  | (None, Some _) ->
      v2
  | (_, _) ->
      None

let parse_constr_annot :
    int ->
    ?if_special_first:field_annot option ->
    ?if_special_second:field_annot option ->
    string list ->
    ( var_annot option
    * type_annot option
    * field_annot option
    * field_annot option )
    tzresult =
 fun loc ?if_special_first ?if_special_second annot ->
  parse_annots ~allow_special_field:true loc annot
  >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  get_one_annot loc vars
  >>? fun v ->
  get_one_annot loc types
  >>? fun t ->
  get_two_annot loc fields
  >>? fun (f1, f2) ->
  ( match (if_special_first, f1) with
  | (Some special_var, Some (`Field_annot "@")) ->
      ok (split_last_dot special_var)
  | (None, Some (`Field_annot "@")) ->
      error (Unexpected_annotation loc)
  | (_, _) ->
      ok (v, f1) )
  >>? fun (v1, f1) ->
  ( match (if_special_second, f2) with
  | (Some special_var, Some (`Field_annot "@")) ->
      ok (split_last_dot special_var)
  | (None, Some (`Field_annot "@")) ->
      error (Unexpected_annotation loc)
  | (_, _) ->
      ok (v, f2) )
  >|? fun (v2, f2) ->
  let v = match v with None -> common_prefix v1 v2 | Some _ -> v in
  (v, t, f1, f2)

let parse_two_var_annot :
    int -> string list -> (var_annot option * var_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  error_unexpected_annot loc fields >>? fun () -> get_two_annot loc vars

let parse_destr_annot :
    int ->
    string list ->
    default_accessor:field_annot option ->
    field_name:field_annot option ->
    pair_annot:var_annot option ->
    value_annot:var_annot option ->
    (var_annot option * field_annot option) tzresult =
 fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot ->
  parse_annots loc ~allow_special_var:true annot
  >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  get_one_annot loc vars
  >>? fun v ->
  get_one_annot loc fields
  >|? fun f ->
  let default =
    gen_access_annot pair_annot field_name ~default:default_accessor
  in
  let v =
    match v with
    | Some (`Var_annot "%") ->
        field_to_var_annot field_name
    | Some (`Var_annot "%%") ->
        default
    | Some _ ->
        v
    | None ->
        value_annot
  in
  (v, f)

let parse_entrypoint_annot :
    int ->
    ?default:var_annot option ->
    string list ->
    (var_annot option * field_annot option) tzresult =
 fun loc ?default annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  get_one_annot loc fields
  >>? fun f ->
  get_one_annot loc vars
  >|? function
  | Some _ as a ->
      (a, f)
  | None -> (
    match default with Some a -> (a, f) | None -> (None, f) )

let parse_var_type_annot :
    int -> string list -> (var_annot option * type_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc fields
  >>? fun () ->
  get_one_annot loc vars
  >>? fun v -> get_one_annot loc types >|? fun t -> (v, t)
src/proto_alpha/lib_protocol/script_ir_annot.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_protocol_environment_alpha__Environment.Micheline.

Import Tezos_raw_protocol_alpha.Script_tc_errors.

Import Tezos_raw_protocol_alpha.Script_typed_ir.

Definition default_now_annot : option variant := Some variant.

Definition default_amount_annot : option variant := Some variant.

Definition default_balance_annot : option variant := Some variant.

Definition default_steps_annot : option variant := Some variant.

Definition default_source_annot : option variant := Some variant.

Definition default_sender_annot : option variant := Some variant.

Definition default_self_annot : option variant := Some variant.

Definition default_arg_annot : option variant := Some variant.

Definition default_param_annot : option variant := Some variant.

Definition default_storage_annot : option variant := Some variant.

Definition default_car_annot : option variant := Some variant.

Definition default_cdr_annot : option variant := Some variant.

Definition default_contract_annot : option variant := Some variant.

Definition default_addr_annot : option variant := Some variant.

Definition default_manager_annot : option variant := Some variant.

Definition default_pack_annot : option variant := Some variant.

Definition default_unpack_annot : option variant := Some variant.

Definition default_slice_annot : option variant := Some variant.

Definition default_elt_annot : option variant := Some variant.

Definition default_key_annot : option variant := Some variant.

Definition default_hd_annot : option variant := Some variant.

Definition default_tl_annot : option variant := Some variant.

Definition default_some_annot : option variant := Some variant.

Definition default_left_annot : option variant := Some variant.

Definition default_right_annot : option variant := Some variant.

Definition default_binding_annot : option variant := Some variant.

Definition unparse_type_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) : list string :=
  match function_parameter with
  | None => []
  | Some (Type_annot a) =>
    cons
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
        ":" % string a) []
  end.

Definition unparse_var_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) : list string :=
  match function_parameter with
  | None => []
  | Some (Var_annot a) =>
    cons
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
        "@" % string a) []
  end.

Definition unparse_field_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  : list string :=
  match function_parameter with
  | None => []
  | Some (Field_annot a) =>
    cons
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
        "%" % string a) []
  end.

Definition field_to_var_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
  match function_parameter with
  | None => None
  | Some (Field_annot s) => Some variant
  end.

Definition type_to_var_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
  match function_parameter with
  | None => None
  | Some (Type_annot s) => Some variant
  end.

Definition var_to_field_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot :=
  match function_parameter with
  | None => None
  | Some (Var_annot s) => Some variant
  end.

Definition default_annot {A : Type}
  (default : option A) (function_parameter : option A) : option A :=
  match function_parameter with
  | None => default
  | annot => annot
  end.

Definition gen_access_annot
  (value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (op_star_o_p_t_star :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  : (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
    option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
  let default :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => None
    end in
  fun field_annot =>
    match (value_annot, field_annot, default) with
    |
      (None, None, _) | (Some _, None, None) |
        (None, Some (Field_annot "" % string), _) => None
    | (None, Some (Field_annot f), _) => Some variant
    |
      (Some (Var_annot v), None | Some (Field_annot "" % string),
        Some (Field_annot f)) => Some variant
    | (Some (Var_annot v), Some (Field_annot f), _) => Some variant
    end.

Definition merge_type_annot
  (legacy : bool)
  (annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
  (annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok None
  | (Some (Type_annot a1), Some (Type_annot a2)) =>
    if
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
        legacy
        (Tezos_protocol_environment_alpha__Environment.String.equal a1 a2) then
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok annot1
    else
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Inconsistent_annotations
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
            ":" % string a1)
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
            ":" % string a2))
  end.

Definition merge_field_annot
  (legacy : bool)
  (annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok None
  | (Some (Field_annot a1), Some (Field_annot a2)) =>
    if
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
        legacy
        (Tezos_protocol_environment_alpha__Environment.String.equal a1 a2) then
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok annot1
    else
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Inconsistent_annotations
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
            "%" % string a1)
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
            "%" % string a2))
  end.

Definition merge_var_annot
  (annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) => None
  | (Some (Var_annot a1), Some (Var_annot a2)) =>
    if Tezos_protocol_environment_alpha__Environment.String.equal a1 a2 then
      annot1
    else
      None
  end.

Definition error_unexpected_annot {A : Type}
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (annot : list A)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  match annot with
  | [] => Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
  | cons _ _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      (Unexpected_annotation loc)
  end.

Definition fail_unexpected_annot {A : Type}
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (annot : list A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (error_unexpected_annot loc annot).

Definition parse_annots
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (op_star_o_p_t_star : option bool)
  : (option bool) ->
    (list string) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list variant) :=
  let allow_special_var :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun op_star_o_p_t_star =>
    let allow_special_field :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun l =>
      let sub_or_wildcard {A : Type}
        (specials : list ascii) (wrap : (option string) -> A) (s : string) (acc
        : list A)
        : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list A) :=
        let len := Tezos_protocol_environment_alpha__Environment.String.length s
          in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            len 1 then
          Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Error_monad.ok
            (cons (wrap None) acc)
        else
          match Tezos_protocol_environment_alpha__Environment.String.get s 1
            with
          |
            "a" % char |
              "b" % char |
                "c" % char |
                  "d" % char |
                    "e" % char |
                      "f" % char |
                        "g" % char |
                          "h" % char |
                            "i" % char |
                              "j" % char |
                                "k" % char |
                                  "l" % char |
                                    "m" % char |
                                      "n" % char |
                                        "o" % char |
                                          "p" % char |
                                            "q" % char |
                                              "r" % char |
                                                "s" % char |
                                                  "t" % char |
                                                    "u" % char |
                                                      "v" % char |
                                                        "w" % char |
                                                          "x" % char |
                                                            "y" % char |
                                                              "z" % char |
              "A" % char |
                "B" % char |
                  "C" % char |
                    "D" % char |
                      "E" % char |
                        "F" % char |
                          "G" % char |
                            "H" % char |
                              "I" % char |
                                "J" % char |
                                  "K" % char |
                                    "L" % char |
                                      "M" % char |
                                        "N" % char |
                                          "O" % char |
                                            "P" % char |
                                              "Q" % char |
                                                "R" % char |
                                                  "S" % char |
                                                    "T" % char |
                                                      "U" % char |
                                                        "V" % char |
                                                          "W" % char |
                                                            "X" % char |
                                                              "Y" % char |
                                                                "Z" % char |
              "_" % char =>
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
              Tezos_protocol_environment_alpha__Environment.Error_monad.ok
              (cons
                (wrap
                  (Some
                    (Tezos_protocol_environment_alpha__Environment.String.sub s
                      1
                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                        len 1)))) acc)
          | _ =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Unexpected_annotation loc)
          end in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_protocol_environment_alpha__Environment.List.fold_left
          (fun acc =>
            fun s =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                acc
                (fun acc =>
                  if
                    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                      (Tezos_protocol_environment_alpha__Environment.String.length
                        s) 0 then
                    Tezos_protocol_environment_alpha__Environment.Error_monad.error
                      (Unexpected_annotation loc)
                  else
                    match
                      Tezos_protocol_environment_alpha__Environment.String.get s
                        0 with
                    | ":" % char => sub_or_wildcard [] (fun a => variant) s acc
                    | "@" % char =>
                      sub_or_wildcard
                        (if allow_special_var then
                          cons "%" % char []
                        else
                          []) (fun a => variant) s acc
                    | "%" % char =>
                      sub_or_wildcard
                        (if allow_special_field then
                          cons "@" % char []
                        else
                          []) (fun a => variant) s acc
                    | _ =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.error
                        (Unexpected_annotation loc)
                    end))
          (Tezos_protocol_environment_alpha__Environment.Error_monad.ok []) l)
        Tezos_protocol_environment_alpha__Environment.List.rev.

Definition opt_var_of_var_opt (function_parameter : variant) : option variant :=
  match function_parameter with
  | Var_annot None => None
  | Var_annot (Some a) => Some variant
  end.

Definition opt_field_of_field_opt (function_parameter : variant)
  : option variant :=
  match function_parameter with
  | Field_annot None => None
  | Field_annot (Some a) => Some variant
  end.

Definition opt_type_of_type_opt (function_parameter : variant)
  : option variant :=
  match function_parameter with
  | Type_annot None => None
  | Type_annot (Some a) => Some variant
  end.

Definition classify_annot
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (l : list variant)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((list (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) *
      (list (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)) *
      (list (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
  try.

Definition get_one_annot {A : Type}
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (function_parameter : list (option A))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option A) :=
  match function_parameter with
  | [] => Tezos_protocol_environment_alpha__Environment.Error_monad.ok None
  | cons a [] => Tezos_protocol_environment_alpha__Environment.Error_monad.ok a
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      (Unexpected_annotation loc)
  end.

Definition get_two_annot {A : Type}
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (function_parameter : list (option A))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option A) * (option A)) :=
  match function_parameter with
  | [] =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok (None, None)
  | cons a [] =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok (a, None)
  | cons a (cons b []) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok (a, b)
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      (Unexpected_annotation loc)
  end.

Definition parse_type_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc vars)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (error_unexpected_annot loc fields)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => get_one_annot loc types
                  end)
            end)
      end).

Definition parse_type_field_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc vars)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (get_one_annot loc types)
                (fun t =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                    (get_one_annot loc fields) (fun f => (t, f)))
            end)
      end).

Definition parse_composed_type_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc vars)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (get_one_annot loc types)
                (fun t =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                    (get_two_annot loc fields)
                    (fun function_parameter =>
                      match function_parameter with
                      | (f1, f2) => (t, f1, f2)
                      end))
            end)
      end).

Definition parse_field_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc vars)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (error_unexpected_annot loc types)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => get_one_annot loc fields
                  end)
            end)
      end).

Definition extract_field_annot
  (function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  match function_parameter with
  | Prim loc prim args annot =>
    let fix extract_first (acc : list string) (function_parameter : list string)
      : (option string) *
        Tezos_protocol_environment_alpha__Environment.Micheline.annot :=
      match function_parameter with
      | [] => (None, annot)
      | cons s rest =>
        if
          Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
              (Tezos_protocol_environment_alpha__Environment.String.length s) 0)
            (Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              (Tezos_protocol_environment_alpha__Environment.String.get s 0)
              "%" % char) then
          ((Some s),
            (Tezos_protocol_environment_alpha__Environment.List.rev_append acc
              rest))
        else
          extract_first (cons s acc) rest
      end in
    match extract_first [] annot with
    | (field_annot, annot) =>
      let field_annot :=
        match field_annot with
        | None => None
        | Some field_annot => Some variant
        end in
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
        ((Prim loc prim args annot), field_annot)
    end
  | expr =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok (expr, None)
  end.

Definition check_correct_field
  (f1 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (f2 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  match (f1, f2) with
  | (None, _) | (_, None) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
  | (Some (Field_annot s1), Some (Field_annot s2)) =>
    if Tezos_protocol_environment_alpha__Environment.String.equal s1 s2 then
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    else
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Inconsistent_field_annotations
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
            "%" % string s1)
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
            "%" % string s2))
  end.

Definition parse_var_annot
  (loc : Z)
  (default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc types)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (error_unexpected_annot loc fields)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                      (get_one_annot loc vars)
                      (fun function_parameter =>
                        match function_parameter with
                        | (Some _) as a => a
                        | None =>
                          match default with
                          | Some a => a
                          | None => None
                          end
                        end)
                  end)
            end)
      end).

Definition split_last_dot (function_parameter : option variant)
  : (option variant) * (option variant) :=
  match function_parameter with
  | None => (None, None)
  | Some (Field_annot s) =>
    match
      Tezos_protocol_environment_alpha__Environment.String.rindex_opt s
        "." % char with
    | None => (None, (Some variant))
    | Some i =>
      let s1 := Tezos_protocol_environment_alpha__Environment.String.sub s 0 i
        in
      let s2 :=
        Tezos_protocol_environment_alpha__Environment.String.sub s
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus i 1)
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
              (Tezos_protocol_environment_alpha__Environment.String.length s) i)
            1) in
      let f :=
        if
          Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
              s2 "car" % string)
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
              s2 "cdr" % string) then
          None
        else
          Some variant in
      ((Some variant), f)
    end
  end.

Definition common_prefix (v1 : option variant) (v2 : option variant)
  : option variant :=
  match (v1, v2) with
  | (Some _, None) => v1
  | (None, Some _) => v2
  | (_, _) => None
  end.

Definition parse_constr_annot
  (loc : Z)
  (if_special_first :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  (if_special_second :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None (Some true) annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (get_one_annot loc vars)
          (fun v =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
              (get_one_annot loc types)
              (fun t =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (get_two_annot loc fields)
                  (fun function_parameter =>
                    match function_parameter with
                    | (f1, f2) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                        match (if_special_first, f1) with
                        | (Some special_var, Some (Field_annot "@" % string)) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                            (split_last_dot special_var)
                        | (None, Some (Field_annot "@" % string)) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.error
                            (Unexpected_annotation loc)
                        | (_, _) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                            (v, f1)
                        end
                        (fun function_parameter =>
                          match function_parameter with
                          | (v1, f1) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                              match (if_special_second, f2) with
                              |
                                (Some special_var,
                                  Some (Field_annot "@" % string)) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                  (split_last_dot special_var)
                              | (None, Some (Field_annot "@" % string)) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.error
                                  (Unexpected_annotation loc)
                              | (_, _) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                  (v, f2)
                              end
                              (fun function_parameter =>
                                match function_parameter with
                                | (v2, f2) =>
                                  let v :=
                                    match v with
                                    | None => common_prefix v1 v2
                                    | Some _ => v
                                    end in
                                  (v, t, f1, f2)
                                end)
                          end)
                    end)))
      end).

Definition parse_two_var_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc types)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (error_unexpected_annot loc fields)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => get_two_annot loc vars
                  end)
            end)
      end).

Definition parse_destr_annot
  (loc : Z) (annot : list string)
  (default_accessor :
    option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (field_name : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (pair_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc (Some true) None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc types)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (get_one_annot loc vars)
                (fun v =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                    (get_one_annot loc fields)
                    (fun f =>
                      let default :=
                        gen_access_annot pair_annot (Some default_accessor)
                          field_name in
                      let v :=
                        match v with
                        | Some (Var_annot "%" % string) =>
                          field_to_var_annot field_name
                        | Some (Var_annot "%%" % string) => default
                        | Some _ => v
                        | None => value_annot
                        end in
                      (v, f)))
            end)
      end).

Definition parse_entrypoint_annot
  (loc : Z)
  (default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc types)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (get_one_annot loc fields)
                (fun f =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                    (get_one_annot loc vars)
                    (fun function_parameter =>
                      match function_parameter with
                      | (Some _) as a => (a, f)
                      | None =>
                        match default with
                        | Some a => (a, f)
                        | None => (None, f)
                        end
                      end))
            end)
      end).

Definition parse_var_type_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      match function_parameter with
      | (vars, types, fields) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (error_unexpected_annot loc fields)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (get_one_annot loc vars)
                (fun v =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                    (get_one_annot loc types) (fun t => (v, t)))
            end)
      end).
src/proto_alpha/lib_protocol/script_ir_annot.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script_typed_ir

(** Default annotations *)

val default_now_annot : var_annot option

val default_amount_annot : var_annot option

val default_balance_annot : var_annot option

val default_steps_annot : var_annot option

val default_source_annot : var_annot option

val default_sender_annot : var_annot option

val default_self_annot : var_annot option

val default_arg_annot : var_annot option

val default_param_annot : var_annot option

val default_storage_annot : var_annot option

val default_car_annot : field_annot option

val default_cdr_annot : field_annot option

val default_contract_annot : field_annot option

val default_addr_annot : field_annot option

val default_manager_annot : field_annot option

val default_pack_annot : field_annot option

val default_unpack_annot : field_annot option

val default_slice_annot : field_annot option

val default_elt_annot : field_annot option

val default_key_annot : field_annot option

val default_hd_annot : field_annot option

val default_tl_annot : field_annot option

val default_some_annot : field_annot option

val default_left_annot : field_annot option

val default_right_annot : field_annot option

val default_binding_annot : field_annot option

(** Unparse annotations to their string representation *)

val unparse_type_annot : type_annot option -> string list

val unparse_var_annot : var_annot option -> string list

val unparse_field_annot : field_annot option -> string list

(** Convertions functions between different annotation kinds *)

val field_to_var_annot : field_annot option -> var_annot option

val type_to_var_annot : type_annot option -> var_annot option

val var_to_field_annot : var_annot option -> field_annot option

(** Replace an annotation by its default value if it is [None] *)
val default_annot : default:'a option -> 'a option -> 'a option

(** Generate annotation for field accesses, of the form [var.field1.field2] *)
val gen_access_annot :
  var_annot option ->
  ?default:field_annot option ->
  field_annot option ->
  var_annot option

(** Merge type annotations.
    @return an error {!Inconsistent_type_annotations} if they are both present
    and different, unless [legacy] *)
val merge_type_annot :
  legacy:bool ->
  type_annot option ->
  type_annot option ->
  type_annot option tzresult

(** Merge field annotations.
    @return an error {!Inconsistent_type_annotations} if they are both present
    and different, unless [legacy] *)
val merge_field_annot :
  legacy:bool ->
  field_annot option ->
  field_annot option ->
  field_annot option tzresult

(** Merge variable annotations, does not fail ([None] if different). *)
val merge_var_annot : var_annot option -> var_annot option -> var_annot option

(** @return an error {!Unexpected_annotation} in the monad the list is not empty. *)
val error_unexpected_annot : int -> 'a list -> unit tzresult

(** Same as {!error_unexpected_annot} in Lwt. *)
val fail_unexpected_annot : int -> 'a list -> unit tzresult Lwt.t

(** Parse a type annotation only. *)
val parse_type_annot : int -> string list -> type_annot option tzresult

(** Parse a field annotation only. *)
val parse_field_annot : int -> string list -> field_annot option tzresult

(** Parse an annotation for composed types, of the form
    [:ty_name %field] in any order. *)
val parse_type_field_annot :
  int -> string list -> (type_annot option * field_annot option) tzresult

(** Parse an annotation for composed types, of the form
    [:ty_name %field1 %field2] in any order. *)
val parse_composed_type_annot :
  int ->
  string list ->
  (type_annot option * field_annot option * field_annot option) tzresult

(** Extract and remove a field annotation from a node *)
val extract_field_annot :
  Script.node -> (Script.node * field_annot option) tzresult

(** Check that field annotations match, used for field accesses. *)
val check_correct_field :
  field_annot option -> field_annot option -> unit tzresult

(** Instruction annotations parsing *)

(** Parse a variable annotation, replaced by a default value if [None]. *)
val parse_var_annot :
  int -> ?default:var_annot option -> string list -> var_annot option tzresult

val parse_constr_annot :
  int ->
  ?if_special_first:field_annot option ->
  ?if_special_second:field_annot option ->
  string list ->
  ( var_annot option
  * type_annot option
  * field_annot option
  * field_annot option )
  tzresult

val parse_two_var_annot :
  int -> string list -> (var_annot option * var_annot option) tzresult

val parse_destr_annot :
  int ->
  string list ->
  default_accessor:field_annot option ->
  field_name:field_annot option ->
  pair_annot:var_annot option ->
  value_annot:var_annot option ->
  (var_annot option * field_annot option) tzresult

val parse_entrypoint_annot :
  int ->
  ?default:var_annot option ->
  string list ->
  (var_annot option * field_annot option) tzresult

val parse_var_type_annot :
  int -> string list -> (var_annot option * type_annot option) tzresult
src/proto_alpha/lib_protocol/script_ir_annot.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter default_now_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_amount_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_balance_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_steps_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_source_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_sender_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_self_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_arg_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_param_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_storage_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter default_car_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_cdr_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_contract_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_addr_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_manager_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_pack_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_unpack_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_slice_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_elt_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_key_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_hd_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_tl_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_some_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_left_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_right_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_binding_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter unparse_type_annot :
(option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) -> list string.

Parameter unparse_var_annot :
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) -> list string.

Parameter unparse_field_annot :
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) -> list string.

Parameter field_to_var_annot :
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
  option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter type_to_var_annot :
(option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) ->
  option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter var_to_field_annot :
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) ->
  option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot.

Parameter default_annot : forall {a : Type},
(option a) -> (option a) -> option a.

Parameter gen_access_annot :
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) ->
  (option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) ->
    (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
      option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter merge_type_annot :
bool ->
  (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) ->
    (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot).

Parameter merge_field_annot :
bool ->
  (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
    (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot).

Parameter merge_var_annot :
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) ->
  (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) ->
    option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot.

Parameter error_unexpected_annot : forall {a : Type},
Z ->
  (list a) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.

Parameter fail_unexpected_annot : forall {a : Type},
Z ->
  (list a) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit).

Parameter parse_type_annot :
Z ->
  (list string) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot).

Parameter parse_field_annot :
Z ->
  (list string) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot).

Parameter parse_type_field_annot :
Z ->
  (list string) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)).

Parameter parse_composed_type_annot :
Z ->
  (list string) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)).

Parameter extract_field_annot :
Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)).

Parameter check_correct_field :
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
  (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit.

Parameter parse_var_annot :
Z ->
  (option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) ->
    (list string) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot).

Parameter parse_constr_annot :
Z ->
  (option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) ->
    (option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) ->
      (list string) ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
            (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
            (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
            (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)).

Parameter parse_two_var_annot :
Z ->
  (list string) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)).

Parameter parse_destr_annot :
Z ->
  (list string) ->
    (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
        (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) ->
          (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) ->
            Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
                (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)).

Parameter parse_entrypoint_annot :
Z ->
  (option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) ->
    (list string) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
          (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)).

Parameter parse_var_type_annot :
Z ->
  (list string) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)).
src/proto_alpha/lib_protocol/script_ir_translator.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Micheline
open Script
open Script_typed_ir
open Script_tc_errors
open Script_ir_annot
module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse

type ex_comparable_ty =
  | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty

type ex_ty = Ex_ty : 'a ty -> ex_ty

type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty

type tc_context =
  | Lambda : tc_context
  | Dip : 'a stack_ty * tc_context -> tc_context
  | Toplevel : {
      storage_type : 'sto ty;
      param_type : 'param ty;
      root_name : string option;
      legacy_create_contract_literal : bool;
    }
      -> tc_context

type unparsing_mode = Optimized | Readable

type type_logger =
  int ->
  (Script.expr * Script.annot) list ->
  (Script.expr * Script.annot) list ->
  unit

let add_dip ty annot prev =
  match prev with
  | Lambda | Toplevel _ ->
      Dip (Item_t (ty, Empty_t, annot), prev)
  | Dip (stack, _) ->
      Dip (Item_t (ty, stack, annot), prev)

(* ---- Type size accounting ------------------------------------------------*)

let rec comparable_type_size : type t a. (t, a) comparable_struct -> int =
 fun ty ->
  (* No wildcard to force the update when comparable_ty chages. *)
  match ty with
  | Int_key _ ->
      1
  | Nat_key _ ->
      1
  | String_key _ ->
      1
  | Bytes_key _ ->
      1
  | Mutez_key _ ->
      1
  | Bool_key _ ->
      1
  | Key_hash_key _ ->
      1
  | Timestamp_key _ ->
      1
  | Address_key _ ->
      1
  | Pair_key (_, (t, _), _) ->
      1 + comparable_type_size t

let rec type_size : type t. t ty -> int =
 fun ty ->
  match ty with
  | Unit_t _ ->
      1
  | Int_t _ ->
      1
  | Nat_t _ ->
      1
  | Signature_t _ ->
      1
  | Bytes_t _ ->
      1
  | String_t _ ->
      1
  | Mutez_t _ ->
      1
  | Key_hash_t _ ->
      1
  | Key_t _ ->
      1
  | Timestamp_t _ ->
      1
  | Address_t _ ->
      1
  | Bool_t _ ->
      1
  | Operation_t _ ->
      1
  | Pair_t ((l, _, _), (r, _, _), _, _) ->
      1 + type_size l + type_size r
  | Union_t ((l, _), (r, _), _, _) ->
      1 + type_size l + type_size r
  | Lambda_t (arg, ret, _) ->
      1 + type_size arg + type_size ret
  | Option_t (t, _, _) ->
      1 + type_size t
  | List_t (t, _, _) ->
      1 + type_size t
  | Set_t (k, _) ->
      1 + comparable_type_size k
  | Map_t (k, v, _, _) ->
      1 + comparable_type_size k + type_size v
  | Big_map_t (k, v, _) ->
      1 + comparable_type_size k + type_size v
  | Contract_t (arg, _) ->
      1 + type_size arg
  | Chain_id_t _ ->
      1

let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int =
 fun stack ~up_to ->
  match stack with
  | Empty_t ->
      0
  | Item_t (head, tail, _annot) ->
      if Compare.Int.(up_to > 0) then
        Compare.Int.max
          (type_size head)
          (type_size_of_stack_head tail ~up_to:(up_to - 1))
      else 0

(* This is the depth of the stack to inspect for sizes overflow. We
   only need to check the produced types that can be larger than the
   arguments. That's why Swap is 0 for instance as no type grows.
   Constant sized types are not checked: it is assumed they are lower
   than the bound (otherwise every program would be rejected). *)
let number_of_generated_growing_types : type b a. (b, a) instr -> int =
  function
  | Drop ->
      0
  | Dup ->
      0
  | Swap ->
      0
  | Const _ ->
      1
  | Cons_pair ->
      1
  | Car ->
      0
  | Cdr ->
      0
  | Cons_some ->
      1
  | Cons_none _ ->
      1
  | If_none _ ->
      0
  | Left ->
      0
  | Right ->
      0
  | If_left _ ->
      0
  | Cons_list ->
      1
  | Nil ->
      1
  | If_cons _ ->
      0
  | List_map _ ->
      1
  | List_size ->
      0
  | List_iter _ ->
      1
  | Empty_set _ ->
      1
  | Set_iter _ ->
      0
  | Set_mem ->
      0
  | Set_update ->
      0
  | Set_size ->
      0
  | Empty_map _ ->
      1
  | Map_map _ ->
      1
  | Map_iter _ ->
      1
  | Map_mem ->
      0
  | Map_get ->
      0
  | Map_update ->
      0
  | Map_size ->
      0
  | Empty_big_map _ ->
      1
  | Big_map_get ->
      0
  | Big_map_update ->
      0
  | Big_map_mem ->
      0
  | Concat_string ->
      0
  | Concat_string_pair ->
      0
  | Slice_string ->
      0
  | String_size ->
      0
  | Concat_bytes ->
      0
  | Concat_bytes_pair ->
      0
  | Slice_bytes ->
      0
  | Bytes_size ->
      0
  | Add_seconds_to_timestamp ->
      0
  | Add_timestamp_to_seconds ->
      0
  | Sub_timestamp_seconds ->
      0
  | Diff_timestamps ->
      0
  | Add_tez ->
      0
  | Sub_tez ->
      0
  | Mul_teznat ->
      0
  | Mul_nattez ->
      0
  | Ediv_teznat ->
      0
  | Ediv_tez ->
      0
  | Or ->
      0
  | And ->
      0
  | Xor ->
      0
  | Not ->
      0
  | Is_nat ->
      0
  | Neg_nat ->
      0
  | Neg_int ->
      0
  | Abs_int ->
      0
  | Int_nat ->
      0
  | Add_intint ->
      0
  | Add_intnat ->
      0
  | Add_natint ->
      0
  | Add_natnat ->
      0
  | Sub_int ->
      0
  | Mul_intint ->
      0
  | Mul_intnat ->
      0
  | Mul_natint ->
      0
  | Mul_natnat ->
      0
  | Ediv_intint ->
      0
  | Ediv_intnat ->
      0
  | Ediv_natint ->
      0
  | Ediv_natnat ->
      0
  | Lsl_nat ->
      0
  | Lsr_nat ->
      0
  | Or_nat ->
      0
  | And_nat ->
      0
  | And_int_nat ->
      0
  | Xor_nat ->
      0
  | Not_nat ->
      0
  | Not_int ->
      0
  | Seq _ ->
      0
  | If _ ->
      0
  | Loop _ ->
      0
  | Loop_left _ ->
      0
  | Dip _ ->
      0
  | Exec ->
      0
  | Apply _ ->
      0
  | Lambda _ ->
      1
  | Failwith _ ->
      1
  | Nop ->
      0
  | Compare _ ->
      1
  | Eq ->
      0
  | Neq ->
      0
  | Lt ->
      0
  | Gt ->
      0
  | Le ->
      0
  | Ge ->
      0
  | Address ->
      0
  | Contract _ ->
      1
  | Transfer_tokens ->
      1
  | Create_account ->
      0
  | Implicit_account ->
      0
  | Create_contract _ ->
      1
  | Create_contract_2 _ ->
      1
  | Now ->
      0
  | Balance ->
      0
  | Check_signature ->
      0
  | Hash_key ->
      0
  | Blake2b ->
      0
  | Sha256 ->
      0
  | Sha512 ->
      0
  | Steps_to_quota ->
      0
  | Source ->
      0
  | Sender ->
      0
  | Self _ ->
      1
  | Amount ->
      0
  | Set_delegate ->
      0
  | Pack _ ->
      0
  | Unpack _ ->
      1
  | Dig _ ->
      0
  | Dug _ ->
      0
  | Dipn _ ->
      0
  | Dropn _ ->
      0
  | ChainId ->
      0

(* ---- Error helpers -------------------------------------------------------*)

let location = function
  | Prim (loc, _, _, _)
  | Int (loc, _)
  | String (loc, _)
  | Bytes (loc, _)
  | Seq (loc, _) ->
      loc

let kind = function
  | Int _ ->
      Int_kind
  | String _ ->
      String_kind
  | Bytes _ ->
      Bytes_kind
  | Prim _ ->
      Prim_kind
  | Seq _ ->
      Seq_kind

let namespace = function
  | K_parameter | K_storage | K_code ->
      Keyword_namespace
  | D_False
  | D_Elt
  | D_Left
  | D_None
  | D_Pair
  | D_Right
  | D_Some
  | D_True
  | D_Unit ->
      Constant_namespace
  | I_PACK
  | I_UNPACK
  | I_BLAKE2B
  | I_SHA256
  | I_SHA512
  | I_ABS
  | I_ADD
  | I_AMOUNT
  | I_AND
  | I_BALANCE
  | I_CAR
  | I_CDR
  | I_CHAIN_ID
  | I_CHECK_SIGNATURE
  | I_COMPARE
  | I_CONCAT
  | I_CONS
  | I_CREATE_ACCOUNT
  | I_CREATE_CONTRACT
  | I_IMPLICIT_ACCOUNT
  | I_DIP
  | I_DROP
  | I_DUP
  | I_EDIV
  | I_EMPTY_BIG_MAP
  | I_EMPTY_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | I_APPLY
  | I_FAILWITH
  | I_GE
  | I_GET
  | I_GT
  | I_HASH_KEY
  | I_IF
  | I_IF_CONS
  | I_IF_LEFT
  | I_IF_NONE
  | I_INT
  | I_LAMBDA
  | I_LE
  | I_LEFT
  | I_LOOP
  | I_LSL
  | I_LSR
  | I_LT
  | I_MAP
  | I_MEM
  | I_MUL
  | I_NEG
  | I_NEQ
  | I_NIL
  | I_NONE
  | I_NOT
  | I_NOW
  | I_OR
  | I_PAIR
  | I_PUSH
  | I_RIGHT
  | I_SIZE
  | I_SOME
  | I_SOURCE
  | I_SENDER
  | I_SELF
  | I_SLICE
  | I_STEPS_TO_QUOTA
  | I_SUB
  | I_SWAP
  | I_TRANSFER_TOKENS
  | I_SET_DELEGATE
  | I_UNIT
  | I_UPDATE
  | I_XOR
  | I_ITER
  | I_LOOP_LEFT
  | I_ADDRESS
  | I_CONTRACT
  | I_ISNAT
  | I_CAST
  | I_RENAME
  | I_DIG
  | I_DUG ->
      Instr_namespace
  | T_bool
  | T_contract
  | T_int
  | T_key
  | T_key_hash
  | T_lambda
  | T_list
  | T_map
  | T_big_map
  | T_nat
  | T_option
  | T_or
  | T_pair
  | T_set
  | T_signature
  | T_string
  | T_bytes
  | T_mutez
  | T_timestamp
  | T_unit
  | T_operation
  | T_address
  | T_chain_id ->
      Type_namespace

let unexpected expr exp_kinds exp_ns exp_prims =
  match expr with
  | Int (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind)
  | String (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind)
  | Bytes (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind)
  | Seq (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind)
  | Prim (loc, name, _, _) -> (
    match (namespace name, exp_ns) with
    | (Type_namespace, Type_namespace)
    | (Instr_namespace, Instr_namespace)
    | (Constant_namespace, Constant_namespace) ->
        Invalid_primitive (loc, exp_prims, name)
    | (ns, _) ->
        Invalid_namespace (loc, name, exp_ns, ns) )

let check_kind kinds expr =
  let kind = kind expr in
  if List.mem kind kinds then return_unit
  else
    let loc = location expr in
    fail (Invalid_kind (loc, kinds, kind))

(* ---- Sets and Maps -------------------------------------------------------*)

let wrap_compare compare a b =
  let res = compare a b in
  if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1

let rec compare_comparable :
    type a s. (a, s) comparable_struct -> a -> a -> int =
 fun kind ->
  match kind with
  | String_key _ ->
      wrap_compare Compare.String.compare
  | Bool_key _ ->
      wrap_compare Compare.Bool.compare
  | Mutez_key _ ->
      wrap_compare Tez.compare
  | Key_hash_key _ ->
      wrap_compare Signature.Public_key_hash.compare
  | Int_key _ ->
      wrap_compare Script_int.compare
  | Nat_key _ ->
      wrap_compare Script_int.compare
  | Timestamp_key _ ->
      wrap_compare Script_timestamp.compare
  | Address_key _ ->
      wrap_compare
      @@ fun (x, ex) (y, ey) ->
      let lres = Contract.compare x y in
      if Compare.Int.(lres = 0) then Compare.String.compare ex ey else lres
  | Bytes_key _ ->
      wrap_compare MBytes.compare
  | Pair_key ((tl, _), (tr, _), _) ->
      fun (lx, rx) (ly, ry) ->
        let lres = compare_comparable tl lx ly in
        if Compare.Int.(lres = 0) then compare_comparable tr rx ry else lres

let empty_set : type a. a comparable_ty -> a set =
 fun ty ->
  let module OPS = Set.Make (struct
    type t = a

    let compare = compare_comparable ty
  end) in
  ( module struct
    type elt = a

    let elt_ty = ty

    module OPS = OPS

    let boxed = OPS.empty

    let size = 0
  end )

let set_update : type a. a -> bool -> a set -> a set =
 fun v b (module Box) ->
  ( module struct
    type elt = a

    let elt_ty = Box.elt_ty

    module OPS = Box.OPS

    let boxed =
      if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed

    let size =
      let mem = Box.OPS.mem v Box.boxed in
      if mem then if b then Box.size else Box.size - 1
      else if b then Box.size + 1
      else Box.size
  end )

let set_mem : type elt. elt -> elt set -> bool =
 fun v (module Box) -> Box.OPS.mem v Box.boxed

let set_fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc =
 fun f (module Box) -> Box.OPS.fold f Box.boxed

let set_size : type elt. elt set -> Script_int.n Script_int.num =
 fun (module Box) -> Script_int.(abs (of_int Box.size))

let map_key_ty : type a b. (a, b) map -> a comparable_ty =
 fun (module Box) -> Box.key_ty

let empty_map : type a b. a comparable_ty -> (a, b) map =
 fun ty ->
  let module OPS = Map.Make (struct
    type t = a

    let compare = compare_comparable ty
  end) in
  ( module struct
    type key = a

    type value = b

    let key_ty = ty

    module OPS = OPS

    let boxed = (OPS.empty, 0)
  end )

let map_get : type key value. key -> (key, value) map -> value option =
 fun k (module Box) -> Box.OPS.find_opt k (fst Box.boxed)

let map_update : type a b. a -> b option -> (a, b) map -> (a, b) map =
 fun k v (module Box) ->
  ( module struct
    type key = a

    type value = b

    let key_ty = Box.key_ty

    module OPS = Box.OPS

    let boxed =
      let (map, size) = Box.boxed in
      let contains = Box.OPS.mem k map in
      match v with
      | Some v ->
          (Box.OPS.add k v map, size + if contains then 0 else 1)
      | None ->
          (Box.OPS.remove k map, size - if contains then 1 else 0)
  end )

let map_set : type a b. a -> b -> (a, b) map -> (a, b) map =
 fun k v (module Box) ->
  ( module struct
    type key = a

    type value = b

    let key_ty = Box.key_ty

    module OPS = Box.OPS

    let boxed =
      let (map, size) = Box.boxed in
      (Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1)
  end )

let map_mem : type key value. key -> (key, value) map -> bool =
 fun k (module Box) -> Box.OPS.mem k (fst Box.boxed)

let map_fold :
    type key value acc.
    (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc =
 fun f (module Box) -> Box.OPS.fold f (fst Box.boxed)

let map_size : type key value. (key, value) map -> Script_int.n Script_int.num
    =
 fun (module Box) -> Script_int.(abs (of_int (snd Box.boxed)))

(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*)

let rec ty_of_comparable_ty : type a s. (a, s) comparable_struct -> a ty =
  function
  | Int_key tname ->
      Int_t tname
  | Nat_key tname ->
      Nat_t tname
  | String_key tname ->
      String_t tname
  | Bytes_key tname ->
      Bytes_t tname
  | Mutez_key tname ->
      Mutez_t tname
  | Bool_key tname ->
      Bool_t tname
  | Key_hash_key tname ->
      Key_hash_t tname
  | Timestamp_key tname ->
      Timestamp_t tname
  | Address_key tname ->
      Address_t tname
  | Pair_key ((l, al), (r, ar), tname) ->
      Pair_t
        ( (ty_of_comparable_ty l, al, None),
          (ty_of_comparable_ty r, ar, None),
          tname,
          false )

let rec comparable_ty_of_ty : type a. a ty -> a comparable_ty option = function
  | Int_t tname ->
      Some (Int_key tname)
  | Nat_t tname ->
      Some (Nat_key tname)
  | String_t tname ->
      Some (String_key tname)
  | Bytes_t tname ->
      Some (Bytes_key tname)
  | Mutez_t tname ->
      Some (Mutez_key tname)
  | Bool_t tname ->
      Some (Bool_key tname)
  | Key_hash_t tname ->
      Some (Key_hash_key tname)
  | Timestamp_t tname ->
      Some (Timestamp_key tname)
  | Address_t tname ->
      Some (Address_key tname)
  | Pair_t ((l, al, _), (r, ar, _), pname, _) -> (
    match comparable_ty_of_ty r with
    | None ->
        None
    | Some rty -> (
      match comparable_ty_of_ty l with
      | None ->
          None
      | Some (Pair_key _) ->
          None (* not a comb *)
      | Some (Int_key tname) ->
          Some (Pair_key ((Int_key tname, al), (rty, ar), pname))
      | Some (Nat_key tname) ->
          Some (Pair_key ((Nat_key tname, al), (rty, ar), pname))
      | Some (String_key tname) ->
          Some (Pair_key ((String_key tname, al), (rty, ar), pname))
      | Some (Bytes_key tname) ->
          Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname))
      | Some (Mutez_key tname) ->
          Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname))
      | Some (Bool_key tname) ->
          Some (Pair_key ((Bool_key tname, al), (rty, ar), pname))
      | Some (Key_hash_key tname) ->
          Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname))
      | Some (Timestamp_key tname) ->
          Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname))
      | Some (Address_key tname) ->
          Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) ) )
  | _ ->
      None

let add_field_annot a var = function
  | Prim (loc, prim, args, annots) ->
      Prim
        ( loc,
          prim,
          args,
          annots @ unparse_field_annot a @ unparse_var_annot var )
  | expr ->
      expr

let rec unparse_comparable_ty :
    type a s. (a, s) comparable_struct -> Script.node = function
  | Int_key tname ->
      Prim (-1, T_int, [], unparse_type_annot tname)
  | Nat_key tname ->
      Prim (-1, T_nat, [], unparse_type_annot tname)
  | String_key tname ->
      Prim (-1, T_string, [], unparse_type_annot tname)
  | Bytes_key tname ->
      Prim (-1, T_bytes, [], unparse_type_annot tname)
  | Mutez_key tname ->
      Prim (-1, T_mutez, [], unparse_type_annot tname)
  | Bool_key tname ->
      Prim (-1, T_bool, [], unparse_type_annot tname)
  | Key_hash_key tname ->
      Prim (-1, T_key_hash, [], unparse_type_annot tname)
  | Timestamp_key tname ->
      Prim (-1, T_timestamp, [], unparse_type_annot tname)
  | Address_key tname ->
      Prim (-1, T_address, [], unparse_type_annot tname)
  | Pair_key ((l, al), (r, ar), pname) ->
      let tl = add_field_annot al None (unparse_comparable_ty l) in
      let tr = add_field_annot ar None (unparse_comparable_ty r) in
      Prim (-1, T_pair, [tl; tr], unparse_type_annot pname)

let rec unparse_ty_no_lwt :
    type a. context -> a ty -> (Script.node * context) tzresult =
 fun ctxt ty ->
  Gas.consume ctxt Unparse_costs.cycle
  >>? fun ctxt ->
  let return ctxt (name, args, annot) =
    let result = Prim (-1, name, args, annot) in
    Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot)
    >>? fun ctxt -> ok (result, ctxt)
  in
  match ty with
  | Unit_t tname ->
      return ctxt (T_unit, [], unparse_type_annot tname)
  | Int_t tname ->
      return ctxt (T_int, [], unparse_type_annot tname)
  | Nat_t tname ->
      return ctxt (T_nat, [], unparse_type_annot tname)
  | String_t tname ->
      return ctxt (T_string, [], unparse_type_annot tname)
  | Bytes_t tname ->
      return ctxt (T_bytes, [], unparse_type_annot tname)
  | Mutez_t tname ->
      return ctxt (T_mutez, [], unparse_type_annot tname)
  | Bool_t tname ->
      return ctxt (T_bool, [], unparse_type_annot tname)
  | Key_hash_t tname ->
      return ctxt (T_key_hash, [], unparse_type_annot tname)
  | Key_t tname ->
      return ctxt (T_key, [], unparse_type_annot tname)
  | Timestamp_t tname ->
      return ctxt (T_timestamp, [], unparse_type_annot tname)
  | Address_t tname ->
      return ctxt (T_address, [], unparse_type_annot tname)
  | Signature_t tname ->
      return ctxt (T_signature, [], unparse_type_annot tname)
  | Operation_t tname ->
      return ctxt (T_operation, [], unparse_type_annot tname)
  | Chain_id_t tname ->
      return ctxt (T_chain_id, [], unparse_type_annot tname)
  | Contract_t (ut, tname) ->
      unparse_ty_no_lwt ctxt ut
      >>? fun (t, ctxt) ->
      return ctxt (T_contract, [t], unparse_type_annot tname)
  | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt utl
      >>? fun (utl, ctxt) ->
      let tl = add_field_annot l_field l_var utl in
      unparse_ty_no_lwt ctxt utr
      >>? fun (utr, ctxt) ->
      let tr = add_field_annot r_field r_var utr in
      return ctxt (T_pair, [tl; tr], annot)
  | Union_t ((utl, l_field), (utr, r_field), tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt utl
      >>? fun (utl, ctxt) ->
      let tl = add_field_annot l_field None utl in
      unparse_ty_no_lwt ctxt utr
      >>? fun (utr, ctxt) ->
      let tr = add_field_annot r_field None utr in
      return ctxt (T_or, [tl; tr], annot)
  | Lambda_t (uta, utr, tname) ->
      unparse_ty_no_lwt ctxt uta
      >>? fun (ta, ctxt) ->
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_lambda, [ta; tr], unparse_type_annot tname)
  | Option_t (ut, tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt ut
      >>? fun (ut, ctxt) -> return ctxt (T_option, [ut], annot)
  | List_t (ut, tname, _) ->
      unparse_ty_no_lwt ctxt ut
      >>? fun (t, ctxt) -> return ctxt (T_list, [t], unparse_type_annot tname)
  | Set_t (ut, tname) ->
      let t = unparse_comparable_ty ut in
      return ctxt (T_set, [t], unparse_type_annot tname)
  | Map_t (uta, utr, tname, _) ->
      let ta = unparse_comparable_ty uta in
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_map, [ta; tr], unparse_type_annot tname)
  | Big_map_t (uta, utr, tname) ->
      let ta = unparse_comparable_ty uta in
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_big_map, [ta; tr], unparse_type_annot tname)

let unparse_ty ctxt ty = Lwt.return (unparse_ty_no_lwt ctxt ty)

let rec strip_var_annots = function
  | (Int _ | String _ | Bytes _) as atom ->
      atom
  | Seq (loc, args) ->
      Seq (loc, List.map strip_var_annots args)
  | Prim (loc, name, args, annots) ->
      let not_var_annot s = Compare.Char.(s.[0] <> '@') in
      let annots = List.filter not_var_annot annots in
      Prim (loc, name, List.map strip_var_annots args, annots)

let serialize_ty_for_error ctxt ty =
  unparse_ty_no_lwt ctxt ty
  |> record_trace Cannot_serialize_error
  >|? fun (ty, ctxt) -> (strip_locations (strip_var_annots ty), ctxt)

let rec unparse_stack :
    type a.
    context ->
    a stack_ty ->
    ((Script.expr * Script.annot) list * context) tzresult Lwt.t =
 fun ctxt -> function
  | Empty_t ->
      return ([], ctxt)
  | Item_t (ty, rest, annot) ->
      unparse_ty ctxt ty
      >>=? fun (uty, ctxt) ->
      unparse_stack ctxt rest
      >>=? fun (urest, ctxt) ->
      return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt)

let serialize_stack_for_error ctxt stack_ty =
  trace Cannot_serialize_error (unparse_stack ctxt stack_ty)

let name_of_ty : type a. a ty -> type_annot option = function
  | Unit_t tname ->
      tname
  | Int_t tname ->
      tname
  | Nat_t tname ->
      tname
  | String_t tname ->
      tname
  | Bytes_t tname ->
      tname
  | Mutez_t tname ->
      tname
  | Bool_t tname ->
      tname
  | Key_hash_t tname ->
      tname
  | Key_t tname ->
      tname
  | Timestamp_t tname ->
      tname
  | Address_t tname ->
      tname
  | Signature_t tname ->
      tname
  | Operation_t tname ->
      tname
  | Chain_id_t tname ->
      tname
  | Contract_t (_, tname) ->
      tname
  | Pair_t (_, _, tname, _) ->
      tname
  | Union_t (_, _, tname, _) ->
      tname
  | Lambda_t (_, _, tname) ->
      tname
  | Option_t (_, tname, _) ->
      tname
  | List_t (_, tname, _) ->
      tname
  | Set_t (_, tname) ->
      tname
  | Map_t (_, _, tname, _) ->
      tname
  | Big_map_t (_, _, tname) ->
      tname

(* ---- Equality witnesses --------------------------------------------------*)

type ('ta, 'tb) eq = Eq : ('same, 'same) eq

let comparable_ty_eq :
    type ta tb.
    context ->
    ta comparable_ty ->
    tb comparable_ty ->
    (ta comparable_ty, tb comparable_ty) eq tzresult =
 fun ctxt ta tb ->
  match (ta, tb) with
  | (Int_key _, Int_key _) ->
      Ok Eq
  | (Nat_key _, Nat_key _) ->
      Ok Eq
  | (String_key _, String_key _) ->
      Ok Eq
  | (Bytes_key _, Bytes_key _) ->
      Ok Eq
  | (Mutez_key _, Mutez_key _) ->
      Ok Eq
  | (Bool_key _, Bool_key _) ->
      Ok Eq
  | (Key_hash_key _, Key_hash_key _) ->
      Ok Eq
  | (Timestamp_key _, Timestamp_key _) ->
      Ok Eq
  | (Address_key _, Address_key _) ->
      Ok Eq
  | (_, _) ->
      serialize_ty_for_error ctxt (ty_of_comparable_ty ta)
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt (ty_of_comparable_ty tb)
      >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))

let record_inconsistent ctxt ta tb =
  record_trace_eval (fun () ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >|? fun (tb, _ctxt) -> Inconsistent_types (ta, tb))

let record_inconsistent_type_annotations ctxt loc ta tb =
  record_trace_eval (fun () ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >|? fun (tb, _ctxt) -> Inconsistent_type_annotations (loc, ta, tb))

let rec ty_eq :
    type ta tb.
    context -> ta ty -> tb ty -> ((ta ty, tb ty) eq * context) tzresult =
 fun ctxt ta tb ->
  let ok (eq : (ta ty, tb ty) eq) ctxt nb_args :
      ((ta ty, tb ty) eq * context) tzresult =
    Gas.consume ctxt (Typecheck_costs.type_ (2 * nb_args))
    >>? fun ctxt -> Ok (eq, ctxt)
  in
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match (ta, tb) with
  | (Unit_t _, Unit_t _) ->
      ok Eq ctxt 0
  | (Int_t _, Int_t _) ->
      ok Eq ctxt 0
  | (Nat_t _, Nat_t _) ->
      ok Eq ctxt 0
  | (Key_t _, Key_t _) ->
      ok Eq ctxt 0
  | (Key_hash_t _, Key_hash_t _) ->
      ok Eq ctxt 0
  | (String_t _, String_t _) ->
      ok Eq ctxt 0
  | (Bytes_t _, Bytes_t _) ->
      ok Eq ctxt 0
  | (Signature_t _, Signature_t _) ->
      ok Eq ctxt 0
  | (Mutez_t _, Mutez_t _) ->
      ok Eq ctxt 0
  | (Timestamp_t _, Timestamp_t _) ->
      ok Eq ctxt 0
  | (Chain_id_t _, Chain_id_t _) ->
      ok Eq ctxt 0
  | (Address_t _, Address_t _) ->
      ok Eq ctxt 0
  | (Bool_t _, Bool_t _) ->
      ok Eq ctxt 0
  | (Operation_t _, Operation_t _) ->
      ok Eq ctxt 0
  | (Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _)) ->
      comparable_ty_eq ctxt tal tbl
      >>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _)) ->
      comparable_ty_eq ctxt tal tbl
      >>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Set_t (ea, _), Set_t (eb, _)) ->
      comparable_ty_eq ctxt ea eb
      >>? (fun Eq -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | ( Pair_t ((tal, _, _), (tar, _, _), _, _),
      Pair_t ((tbl, _, _), (tbr, _, _), _, _) ) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Union_t ((tal, _), (tar, _), _, _), Union_t ((tbl, _), (tbr, _), _, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Contract_t (tal, _), Contract_t (tbl, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (Option_t (tva, _, _), Option_t (tvb, _, _)) ->
      ty_eq ctxt tva tvb
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (List_t (tva, _, _), List_t (tvb, _, _)) ->
      ty_eq ctxt tva tvb
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (_, _) ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))

let rec stack_ty_eq :
    type ta tb.
    context ->
    int ->
    ta stack_ty ->
    tb stack_ty ->
    ((ta stack_ty, tb stack_ty) eq * context) tzresult =
 fun ctxt lvl ta tb ->
  match (ta, tb) with
  | (Item_t (tva, ra, _), Item_t (tvb, rb, _)) ->
      ty_eq ctxt tva tvb
      |> record_trace (Bad_stack_item lvl)
      >>? fun (Eq, ctxt) ->
      stack_ty_eq ctxt (lvl + 1) ra rb
      >>? fun (Eq, ctxt) ->
      (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
  | (Empty_t, Empty_t) ->
      Ok (Eq, ctxt)
  | (_, _) ->
      error Bad_stack_length

let merge_comparable_types :
    type ta.
    legacy:bool ->
    ta comparable_ty ->
    ta comparable_ty ->
    ta comparable_ty tzresult =
 fun ~legacy ta tb ->
  match (ta, tb) with
  | (Int_key annot_a, Int_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Int_key annot
  | (Nat_key annot_a, Nat_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Nat_key annot
  | (String_key annot_a, String_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> String_key annot
  | (Bytes_key annot_a, Bytes_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bytes_key annot
  | (Mutez_key annot_a, Mutez_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Mutez_key annot
  | (Bool_key annot_a, Bool_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bool_key annot
  | (Key_hash_key annot_a, Key_hash_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Key_hash_key annot
  | (Timestamp_key annot_a, Timestamp_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Timestamp_key annot
  | (Address_key annot_a, Address_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Address_key annot
  | (_, _) ->
      assert false

(* FIXME: fix injectivity of some types *)

let merge_types :
    type b.
    legacy:bool ->
    context ->
    Script.location ->
    b ty ->
    b ty ->
    (b ty * context) tzresult =
 fun ~legacy ->
  let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult =
   fun ctxt ty1 ty2 ->
    match (ty1, ty2) with
    | (Unit_t tn1, Unit_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Unit_t tname, ctxt)
    | (Int_t tn1, Int_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Int_t tname, ctxt)
    | (Nat_t tn1, Nat_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Nat_t tname, ctxt)
    | (Key_t tn1, Key_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Key_t tname, ctxt)
    | (Key_hash_t tn1, Key_hash_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Key_hash_t tname, ctxt)
    | (String_t tn1, String_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (String_t tname, ctxt)
    | (Bytes_t tn1, Bytes_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bytes_t tname, ctxt)
    | (Signature_t tn1, Signature_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Signature_t tname, ctxt)
    | (Mutez_t tn1, Mutez_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Mutez_t tname, ctxt)
    | (Timestamp_t tn1, Timestamp_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Timestamp_t tname, ctxt)
    | (Address_t tn1, Address_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Address_t tname, ctxt)
    | (Bool_t tn1, Bool_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bool_t tname, ctxt)
    | (Chain_id_t tn1, Chain_id_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Chain_id_t tname, ctxt)
    | (Operation_t tn1, Operation_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Operation_t tname, ctxt)
    | (Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tar tbr
        >>? fun (value, ctxt) ->
        ty_eq ctxt tar value
        >>? fun (Eq, ctxt) ->
        merge_comparable_types ~legacy tal tbl
        >|? fun tk -> (Map_t (tk, value, tname, has_big_map), ctxt)
    | (Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tar tbr
        >>? fun (value, ctxt) ->
        ty_eq ctxt tar value
        >>? fun (Eq, ctxt) ->
        merge_comparable_types ~legacy tal tbl
        >|? fun tk -> (Big_map_t (tk, value, tname), ctxt)
    | (Set_t (ea, tn1), Set_t (eb, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_comparable_types ~legacy ea eb
        >|? fun e -> (Set_t (e, tname), ctxt)
    | ( Pair_t
          ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map),
        Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) ) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_field_annot ~legacy l_field1 l_field2
        >>? fun l_field ->
        merge_field_annot ~legacy r_field1 r_field2
        >>? fun r_field ->
        let l_var = merge_var_annot l_var1 l_var2 in
        let r_var = merge_var_annot r_var1 r_var2 in
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) ->
        ( Pair_t
            ( (left_ty, l_field, l_var),
              (right_ty, r_field, r_var),
              tname,
              has_big_map ),
          ctxt )
    | ( Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map),
        Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) ) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_field_annot ~legacy tal_annot tbl_annot
        >>? fun left_annot ->
        merge_field_annot ~legacy tar_annot tbr_annot
        >>? fun right_annot ->
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) ->
        ( Union_t
            ((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map),
          ctxt )
    | (Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) -> (Lambda_t (left_ty, right_ty, tname), ctxt)
    | (Contract_t (tal, tn1), Contract_t (tbl, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tal tbl
        >|? fun (arg_ty, ctxt) -> (Contract_t (arg_ty, tname), ctxt)
    | (Option_t (tva, tn1, has_big_map), Option_t (tvb, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tva tvb
        >|? fun (ty, ctxt) -> (Option_t (ty, tname, has_big_map), ctxt)
    | (List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tva tvb
        >|? fun (ty, ctxt) -> (List_t (ty, tname, has_big_map), ctxt)
    | (_, _) ->
        assert false
  in
  fun ctxt loc ty1 ty2 ->
    record_inconsistent_type_annotations ctxt loc ty1 ty2 (help ctxt ty1 ty2)

let merge_stacks :
    type ta.
    legacy:bool ->
    Script.location ->
    context ->
    ta stack_ty ->
    ta stack_ty ->
    (ta stack_ty * context) tzresult =
 fun ~legacy loc ->
  let rec help :
      type a.
      context -> a stack_ty -> a stack_ty -> (a stack_ty * context) tzresult =
   fun ctxt stack1 stack2 ->
    match (stack1, stack2) with
    | (Empty_t, Empty_t) ->
        ok (Empty_t, ctxt)
    | (Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2)) ->
        let annot = merge_var_annot annot1 annot2 in
        merge_types ~legacy ctxt loc ty1 ty2
        >>? fun (ty, ctxt) ->
        help ctxt rest1 rest2
        >|? fun (rest, ctxt) -> (Item_t (ty, rest, annot), ctxt)
  in
  help

let has_big_map : type t. t ty -> bool = function
  | Unit_t _ ->
      false
  | Int_t _ ->
      false
  | Nat_t _ ->
      false
  | Signature_t _ ->
      false
  | String_t _ ->
      false
  | Bytes_t _ ->
      false
  | Mutez_t _ ->
      false
  | Key_hash_t _ ->
      false
  | Key_t _ ->
      false
  | Timestamp_t _ ->
      false
  | Address_t _ ->
      false
  | Bool_t _ ->
      false
  | Lambda_t (_, _, _) ->
      false
  | Set_t (_, _) ->
      false
  | Big_map_t (_, _, _) ->
      true
  | Contract_t (_, _) ->
      false
  | Operation_t _ ->
      false
  | Chain_id_t _ ->
      false
  | Pair_t (_, _, _, has_big_map) ->
      has_big_map
  | Union_t (_, _, _, has_big_map) ->
      has_big_map
  | Option_t (_, _, has_big_map) ->
      has_big_map
  | List_t (_, _, has_big_map) ->
      has_big_map
  | Map_t (_, _, _, has_big_map) ->
      has_big_map

(* ---- Type checker results -------------------------------------------------*)

type 'bef judgement =
  | Typed : ('bef, 'aft) descr -> 'bef judgement
  | Failed : {
      descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr;
    }
      -> 'bef judgement

(* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*)

type ('t, 'f, 'b) branch = {
  branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr;
}
[@@unboxed]

let merge_branches :
    type bef a b.
    legacy:bool ->
    context ->
    int ->
    a judgement ->
    b judgement ->
    (a, b, bef) branch ->
    (bef judgement * context) tzresult Lwt.t =
 fun ~legacy ctxt loc btr bfr {branch} ->
  match (btr, bfr) with
  | (Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf)) ->
      let unmatched_branches () =
        serialize_stack_for_error ctxt aftbt
        >>=? fun (aftbt, ctxt) ->
        serialize_stack_for_error ctxt aftbf
        >>|? fun (aftbf, _ctxt) -> Unmatched_branches (loc, aftbt, aftbf)
      in
      trace_eval
        unmatched_branches
        ( Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf)
        >>=? fun (Eq, ctxt) ->
        Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf)
        >>=? fun (merged_stack, ctxt) ->
        return
          ( Typed
              (branch
                 {dbt with aft = merged_stack}
                 {dbf with aft = merged_stack}),
            ctxt ) )
  | (Failed {descr = descrt}, Failed {descr = descrf}) ->
      let descr ret = branch (descrt ret) (descrf ret) in
      return (Failed {descr}, ctxt)
  | (Typed dbt, Failed {descr = descrf}) ->
      return (Typed (branch dbt (descrf dbt.aft)), ctxt)
  | (Failed {descr = descrt}, Typed dbf) ->
      return (Typed (branch (descrt dbf.aft) dbf), ctxt)

let rec parse_comparable_ty :
    context -> Script.node -> (ex_comparable_ty * context) tzresult =
 fun ctxt ty ->
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  Gas.consume ctxt (Typecheck_costs.type_ 0)
  >>? fun ctxt ->
  match ty with
  | Prim (loc, T_int, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Int_key tname), ctxt)
  | Prim (loc, T_nat, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Nat_key tname), ctxt)
  | Prim (loc, T_string, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (String_key tname), ctxt)
  | Prim (loc, T_bytes, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Bytes_key tname), ctxt)
  | Prim (loc, T_mutez, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Mutez_key tname), ctxt)
  | Prim (loc, T_bool, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Bool_key tname), ctxt)
  | Prim (loc, T_key_hash, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Key_hash_key tname), ctxt)
  | Prim (loc, T_timestamp, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Timestamp_key tname), ctxt)
  | Prim (loc, T_address, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Address_key tname), ctxt)
  | Prim
      ( loc,
        ( ( T_int
          | T_nat
          | T_string
          | T_mutez
          | T_bool
          | T_key
          | T_address
          | T_timestamp ) as prim ),
        l,
        _ ) ->
      error (Invalid_arity (loc, prim, 0, List.length l))
  | Prim
      ( loc,
        ( T_pair
        | T_or
        | T_set
        | T_map
        | T_list
        | T_option
        | T_lambda
        | T_unit
        | T_signature
        | T_contract ),
        _,
        _ ) ->
      error (Comparable_type_expected (loc, Micheline.strip_locations ty))
  | expr ->
      error
      @@ unexpected
           expr
           []
           Type_namespace
           [ T_int;
             T_nat;
             T_string;
             T_mutez;
             T_bool;
             T_key;
             T_key_hash;
             T_timestamp ]

and parse_packable_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:false
    ~allow_operation:false
    ~allow_contract:legacy

and parse_parameter_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:true
    ~allow_operation:false
    ~allow_contract:true

and parse_any_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:true
    ~allow_operation:true
    ~allow_contract:true

and parse_ty :
    context ->
    legacy:bool ->
    allow_big_map:bool ->
    allow_operation:bool ->
    allow_contract:bool ->
    Script.node ->
    (ex_ty * context) tzresult =
 fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node ->
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match node with
  | Prim (loc, T_unit, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Unit_t ty_name), ctxt)
  | Prim (loc, T_int, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Int_t ty_name), ctxt)
  | Prim (loc, T_nat, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Nat_t ty_name), ctxt)
  | Prim (loc, T_string, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (String_t ty_name), ctxt)
  | Prim (loc, T_bytes, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Bytes_t ty_name), ctxt)
  | Prim (loc, T_mutez, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Mutez_t ty_name), ctxt)
  | Prim (loc, T_bool, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Bool_t ty_name), ctxt)
  | Prim (loc, T_key, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Key_t ty_name), ctxt)
  | Prim (loc, T_key_hash, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Key_hash_t ty_name), ctxt)
  | Prim (loc, T_timestamp, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Timestamp_t ty_name), ctxt)
  | Prim (loc, T_address, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Address_t ty_name), ctxt)
  | Prim (loc, T_signature, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Signature_t ty_name), ctxt)
  | Prim (loc, T_operation, [], annot) ->
      if allow_operation then
        parse_type_annot loc annot
        >>? fun ty_name ->
        Gas.consume ctxt (Typecheck_costs.type_ 0)
        >|? fun ctxt -> (Ex_ty (Operation_t ty_name), ctxt)
      else error (Unexpected_operation loc)
  | Prim (loc, T_chain_id, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Chain_id_t ty_name), ctxt)
  | Prim (loc, T_contract, [utl], annot) ->
      if allow_contract then
        parse_parameter_ty ctxt ~legacy utl
        >>? fun (Ex_ty tl, ctxt) ->
        parse_type_annot loc annot
        >>? fun ty_name ->
        Gas.consume ctxt (Typecheck_costs.type_ 1)
        >|? fun ctxt -> (Ex_ty (Contract_t (tl, ty_name)), ctxt)
      else error (Unexpected_contract loc)
  | Prim (loc, T_pair, [utl; utr], annot) ->
      extract_field_annot utl
      >>? fun (utl, left_field) ->
      extract_field_annot utr
      >>? fun (utr, right_field) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
      >>? fun (Ex_ty tl, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt ->
      ( Ex_ty
          (Pair_t
             ( (tl, left_field, None),
               (tr, right_field, None),
               ty_name,
               has_big_map tl || has_big_map tr )),
        ctxt )
  | Prim (loc, T_or, [utl; utr], annot) ->
      extract_field_annot utl
      >>? fun (utl, left_constr) ->
      extract_field_annot utr
      >>? fun (utr, right_constr) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
      >>? fun (Ex_ty tl, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt ->
      ( Ex_ty
          (Union_t
             ( (tl, left_constr),
               (tr, right_constr),
               ty_name,
               has_big_map tl || has_big_map tr )),
        ctxt )
  | Prim (loc, T_lambda, [uta; utr], annot) ->
      parse_any_ty ctxt ~legacy uta
      >>? fun (Ex_ty ta, ctxt) ->
      parse_any_ty ctxt ~legacy utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt)
  | Prim (loc, T_option, [ut], annot) ->
      ( if legacy then
        (* legacy semantics with (broken) field annotations *)
        extract_field_annot ut
        >>? fun (ut, _some_constr) ->
        parse_composed_type_annot loc annot
        >>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name)
      else parse_type_annot loc annot >>? fun ty_name -> ok (ut, ty_name) )
      >>? fun (ut, ty_name) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
      >>? fun (Ex_ty t, ctxt) ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt)
  | Prim (loc, T_list, [ut], annot) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
      >>? fun (Ex_ty t, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 1)
      >|? fun ctxt -> (Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt)
  | Prim (loc, T_set, [ut], annot) ->
      parse_comparable_ty ctxt ut
      >>? fun (Ex_comparable_ty t, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 1)
      >|? fun ctxt -> (Ex_ty (Set_t (t, ty_name)), ctxt)
  | Prim (loc, T_map, [uta; utr], annot) ->
      parse_comparable_ty ctxt uta
      >>? fun (Ex_comparable_ty ta, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt)
  | Prim (loc, T_big_map, args, annot) when allow_big_map ->
      parse_big_map_ty ctxt ~legacy loc args annot
      >>? fun (big_map_ty, ctxt) ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (big_map_ty, ctxt)
  | Prim (loc, T_big_map, _, _) ->
      error (Unexpected_big_map loc)
  | Prim
      ( loc,
        ( ( T_unit
          | T_signature
          | T_int
          | T_nat
          | T_string
          | T_bytes
          | T_mutez
          | T_bool
          | T_key
          | T_key_hash
          | T_timestamp
          | T_address ) as prim ),
        l,
        _ ) ->
      error (Invalid_arity (loc, prim, 0, List.length l))
  | Prim (loc, ((T_set | T_list | T_option | T_contract) as prim), l, _) ->
      error (Invalid_arity (loc, prim, 1, List.length l))
  | Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) ->
      error (Invalid_arity (loc, prim, 2, List.length l))
  | expr ->
      error
      @@ unexpected
           expr
           []
           Type_namespace
           [ T_pair;
             T_or;
             T_set;
             T_map;
             T_list;
             T_option;
             T_lambda;
             T_unit;
             T_signature;
             T_contract;
             T_int;
             T_nat;
             T_operation;
             T_string;
             T_bytes;
             T_mutez;
             T_bool;
             T_key;
             T_key_hash;
             T_timestamp;
             T_chain_id ]

and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot =
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match args with
  | [key_ty; value_ty] ->
      parse_comparable_ty ctxt key_ty
      >>? fun (Ex_comparable_ty key_ty, ctxt) ->
      parse_packable_ty ctxt ~legacy value_ty
      >>? fun (Ex_ty value_ty, ctxt) ->
      parse_type_annot big_map_loc map_annot
      >|? fun map_name ->
      let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in
      (Ex_ty big_map_ty, ctxt)
  | args ->
      error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)

and parse_storage_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy node ->
  match node with
  | Prim
      ( loc,
        T_pair,
        [Prim (big_map_loc, T_big_map, args, map_annot); remaining_storage],
        storage_annot )
    when legacy -> (
    match storage_annot with
    | [] ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          node
    | [single]
      when Compare.Int.(String.length single > 0)
           && Compare.Char.(single.[0] = '%') ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          node
    | _ ->
        (* legacy semantics of big maps used the wrong annotation parser *)
        Gas.consume ctxt Typecheck_costs.cycle
        >>? fun ctxt ->
        parse_big_map_ty ctxt ~legacy big_map_loc args map_annot
        >>? fun (Ex_ty big_map_ty, ctxt) ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          remaining_storage
        >>? fun (Ex_ty remaining_storage, ctxt) ->
        parse_composed_type_annot loc storage_annot
        >>? fun (ty_name, map_field, storage_field) ->
        Gas.consume ctxt (Typecheck_costs.type_ 5)
        >|? fun ctxt ->
        ( Ex_ty
            (Pair_t
               ( (big_map_ty, map_field, None),
                 (remaining_storage, storage_field, None),
                 ty_name,
                 true )),
          ctxt ) )
  | _ ->
      parse_ty
        ctxt
        ~legacy
        ~allow_big_map:true
        ~allow_operation:false
        ~allow_contract:legacy
        node

let check_packable ~legacy loc root =
  let rec check : type t. t ty -> unit tzresult = function
    | Big_map_t _ ->
        error (Unexpected_big_map loc)
    | Operation_t _ ->
        error (Unexpected_operation loc)
    | Unit_t _ ->
        ok ()
    | Int_t _ ->
        ok ()
    | Nat_t _ ->
        ok ()
    | Signature_t _ ->
        ok ()
    | String_t _ ->
        ok ()
    | Bytes_t _ ->
        ok ()
    | Mutez_t _ ->
        ok ()
    | Key_hash_t _ ->
        ok ()
    | Key_t _ ->
        ok ()
    | Timestamp_t _ ->
        ok ()
    | Address_t _ ->
        ok ()
    | Bool_t _ ->
        ok ()
    | Chain_id_t _ ->
        ok ()
    | Pair_t ((l_ty, _, _), (r_ty, _, _), _, _) ->
        check l_ty >>? fun () -> check r_ty
    | Union_t ((l_ty, _), (r_ty, _), _, _) ->
        check l_ty >>? fun () -> check r_ty
    | Option_t (v_ty, _, _) ->
        check v_ty
    | List_t (elt_ty, _, _) ->
        check elt_ty
    | Set_t (_, _) ->
        ok ()
    | Map_t (_, elt_ty, _, _) ->
        check elt_ty
    | Lambda_t (_l_ty, _r_ty, _) ->
        ok ()
    | Contract_t (_, _) when legacy ->
        ok ()
    | Contract_t (_, _) ->
        error (Unexpected_contract loc)
  in
  check root

type ex_script = Ex_script : ('a, 'c) script -> ex_script

type _ dig_proof_argument =
  | Dig_proof_argument :
      ( ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * ('x ty * var_annot option)
      * 'aft stack_ty )
      -> 'bef dig_proof_argument

type (_, _) dug_proof_argument =
  | Dug_proof_argument :
      ( ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * unit
      * 'aft stack_ty )
      -> ('bef, 'x) dug_proof_argument

type _ dipn_proof_argument =
  | Dipn_proof_argument :
      ( ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      * (context * ('fbef, 'faft) descr)
      * 'aft stack_ty )
      -> 'bef dipn_proof_argument

type _ dropn_proof_argument =
  | Dropn_proof_argument :
      ( ('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * 'rest stack_ty
      * 'aft stack_ty )
      -> 'bef dropn_proof_argument

(* Lwt versions *)
let parse_var_annot loc ?default annot =
  Lwt.return (parse_var_annot loc ?default annot)

let parse_entrypoint_annot loc ?default annot =
  Lwt.return (parse_entrypoint_annot loc ?default annot)

let parse_constr_annot loc ?if_special_first ?if_special_second annot =
  Lwt.return
    (parse_constr_annot loc ?if_special_first ?if_special_second annot)

let parse_two_var_annot loc annot = Lwt.return (parse_two_var_annot loc annot)

let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot
    ~value_annot =
  Lwt.return
    (parse_destr_annot
       loc
       annot
       ~default_accessor
       ~field_name
       ~pair_annot
       ~value_annot)

let parse_var_type_annot loc annot =
  Lwt.return (parse_var_type_annot loc annot)

let find_entrypoint (type full) (full : full ty) ~root_name entrypoint =
  let rec find_entrypoint :
      type t. t ty -> string -> (Script.node -> Script.node) * ex_ty =
   fun t entrypoint ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) -> (
        if
          match al with
          | None ->
              false
          | Some (`Field_annot l) ->
              Compare.String.(l = entrypoint)
        then ((fun e -> Prim (0, D_Left, [e], [])), Ex_ty tl)
        else if
          match ar with
          | None ->
              false
          | Some (`Field_annot r) ->
              Compare.String.(r = entrypoint)
        then ((fun e -> Prim (0, D_Right, [e], [])), Ex_ty tr)
        else
          try
            let (f, t) = find_entrypoint tl entrypoint in
            ((fun e -> Prim (0, D_Left, [f e], [])), t)
          with Not_found ->
            let (f, t) = find_entrypoint tr entrypoint in
            ((fun e -> Prim (0, D_Right, [f e], [])), t) )
    | _ ->
        raise Not_found
  in
  let entrypoint =
    if Compare.String.(entrypoint = "") then "default" else entrypoint
  in
  if Compare.Int.(String.length entrypoint > 31) then
    error (Entrypoint_name_too_long entrypoint)
  else
    match root_name with
    | Some root_name when Compare.String.(entrypoint = root_name) ->
        ok ((fun e -> e), Ex_ty full)
    | _ -> (
      try ok (find_entrypoint full entrypoint)
      with Not_found -> (
        match entrypoint with
        | "default" ->
            ok ((fun e -> e), Ex_ty full)
        | _ ->
            error (No_such_entrypoint entrypoint) ) )

let find_entrypoint_for_type (type full exp) ~(full : full ty)
    ~(expected : exp ty) ~root_name entrypoint ctxt :
    (context * string * exp ty) tzresult =
  match (entrypoint, root_name) with
  | ("default", Some "root") -> (
    match find_entrypoint full ~root_name entrypoint with
    | Error _ as err ->
        err
    | Ok (_, Ex_ty ty) -> (
      match ty_eq ctxt expected ty with
      | Ok (Eq, ctxt) ->
          ok (ctxt, "default", (ty : exp ty))
      | Error _ ->
          ty_eq ctxt expected full
          >>? fun (Eq, ctxt) -> ok (ctxt, "root", (full : exp ty)) ) )
  | _ ->
      find_entrypoint full ~root_name entrypoint
      >>? fun (_, Ex_ty ty) ->
      ty_eq ctxt expected ty
      >>? fun (Eq, ctxt) -> ok (ctxt, entrypoint, (ty : exp ty))

module Entrypoints = Set.Make (String)

exception Duplicate of string

exception Too_long of string

let well_formed_entrypoints (type full) (full : full ty) ~root_name =
  let merge path annot (type t) (ty : t ty) reachable
      ((first_unreachable, all) as acc) =
    match annot with
    | None | Some (`Field_annot "") -> (
        if reachable then acc
        else
          match ty with
          | Union_t _ ->
              acc
          | _ -> (
            match first_unreachable with
            | None ->
                (Some (List.rev path), all)
            | Some _ ->
                acc ) )
    | Some (`Field_annot name) ->
        if Compare.Int.(String.length name > 31) then raise (Too_long name)
        else if Entrypoints.mem name all then raise (Duplicate name)
        else (first_unreachable, Entrypoints.add name all)
  in
  let rec check :
      type t.
      t ty ->
      prim list ->
      bool ->
      prim list option * Entrypoints.t ->
      prim list option * Entrypoints.t =
   fun t path reachable acc ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) ->
        let acc = merge (D_Left :: path) al tl reachable acc in
        let acc = merge (D_Right :: path) ar tr reachable acc in
        let acc =
          check
            tl
            (D_Left :: path)
            (match al with Some _ -> true | None -> reachable)
            acc
        in
        check
          tr
          (D_Right :: path)
          (match ar with Some _ -> true | None -> reachable)
          acc
    | _ ->
        acc
  in
  try
    let (init, reachable) =
      match root_name with
      | None | Some "" ->
          (Entrypoints.empty, false)
      | Some name ->
          (Entrypoints.singleton name, true)
    in
    let (first_unreachable, all) = check full [] reachable (None, init) in
    if not (Entrypoints.mem "default" all) then ok ()
    else
      match first_unreachable with
      | None ->
          ok ()
      | Some path ->
          error (Unreachable_entrypoint path)
  with
  | Duplicate name ->
      error (Duplicate_entrypoint name)
  | Too_long name ->
      error (Entrypoint_name_too_long name)

let rec parse_data :
    type a.
    ?type_logger:type_logger ->
    context ->
    legacy:bool ->
    a ty ->
    Script.node ->
    (a * context) tzresult Lwt.t =
 fun ?type_logger ctxt ~legacy ty script_data ->
  Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
  >>=? fun ctxt ->
  let error () =
    Lwt.return (serialize_ty_for_error ctxt ty)
    >>|? fun (ty, _ctxt) ->
    Invalid_constant (location script_data, strip_locations script_data, ty)
  in
  let traced body = trace_eval error body in
  let parse_items ?type_logger loc ctxt expr key_type value_type items
      item_wrapper =
    let length = List.length items in
    fold_left_s
      (fun (last_value, map, ctxt) item ->
        Lwt.return (Gas.consume ctxt (Typecheck_costs.map_element length))
        >>=? fun ctxt ->
        match item with
        | Prim (_, D_Elt, [k; v], _) ->
            parse_comparable_data ?type_logger ctxt key_type k
            >>=? fun (k, ctxt) ->
            parse_data ?type_logger ctxt ~legacy value_type v
            >>=? fun (v, ctxt) ->
            ( match last_value with
            | Some value ->
                if Compare.Int.(0 <= compare_comparable key_type value k) then
                  if Compare.Int.(0 = compare_comparable key_type value k) then
                    fail (Duplicate_map_keys (loc, strip_locations expr))
                  else fail (Unordered_map_keys (loc, strip_locations expr))
                else return_unit
            | None ->
                return_unit )
            >>=? fun () ->
            return (Some k, map_update k (Some (item_wrapper v)) map, ctxt)
        | Prim (loc, D_Elt, l, _) ->
            fail @@ Invalid_arity (loc, D_Elt, 2, List.length l)
        | Prim (loc, name, _, _) ->
            fail @@ Invalid_primitive (loc, [D_Elt], name)
        | Int _ | String _ | Bytes _ | Seq _ ->
            error () >>=? fail)
      (None, empty_map key_type, ctxt)
      items
    |> traced
    >>|? fun (_, items, ctxt) -> (items, ctxt)
  in
  match (ty, script_data) with
  (* Unit *)
  | (Unit_t _, Prim (loc, D_Unit, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.unit)
      >>|? fun ctxt -> ((() : a), ctxt)
  | (Unit_t _, Prim (loc, D_Unit, l, _)) ->
      traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l)))
  | (Unit_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Unit]))
  (* Booleans *)
  | (Bool_t _, Prim (loc, D_True, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
      >>|? fun ctxt -> (true, ctxt)
  | (Bool_t _, Prim (loc, D_False, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
      >>|? fun ctxt -> (false, ctxt)
  | (Bool_t _, Prim (loc, ((D_True | D_False) as c), l, _)) ->
      traced (fail (Invalid_arity (loc, c, 0, List.length l)))
  | (Bool_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_True; D_False]))
  (* Strings *)
  | (String_t _, String (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v)))
      >>=? fun ctxt ->
      let rec check_printable_ascii i =
        if Compare.Int.(i < 0) then true
        else
          match v.[i] with
          | '\n' | '\x20' .. '\x7E' ->
              check_printable_ascii (i - 1)
          | _ ->
              false
      in
      if check_printable_ascii (String.length v - 1) then return (v, ctxt)
      else error () >>=? fail
  | (String_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [String_kind], kind expr)))
  (* Byte sequences *)
  | (Bytes_t _, Bytes (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v)))
      >>=? fun ctxt -> return (v, ctxt)
  | (Bytes_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Bytes_kind], kind expr)))
  (* Integers *)
  | (Int_t _, Int (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt -> return (Script_int.of_zint v, ctxt)
  | (Nat_t _, Int (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt ->
      let v = Script_int.of_zint v in
      if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then
        return (Script_int.abs v, ctxt)
      else error () >>=? fail
  | (Int_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  | (Nat_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  (* Tez amounts *)
  | (Mutez_t _, Int (_, v)) -> (
      Lwt.return
        ( Gas.consume ctxt Typecheck_costs.tez
        >>? fun ctxt ->
        Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 )
      >>=? fun ctxt ->
      try
        match Tez.of_mutez (Z.to_int64 v) with
        | None ->
            raise Exit
        | Some tez ->
            return (tez, ctxt)
      with _ -> error () >>=? fail )
  | (Mutez_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  (* Timestamps *)
  | (Timestamp_t _, Int (_, v))
  (* As unparsed with [Optimized] or out of bounds [Readable]. *) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt -> return (Script_timestamp.of_zint v, ctxt)
  | (Timestamp_t _, String (_, s)) (* As unparsed with [Redable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp)
      >>=? fun ctxt ->
      match Script_timestamp.of_string s with
      | Some v ->
          return (v, ctxt)
      | None ->
          error () >>=? fail )
  | (Timestamp_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Int_kind], kind expr)))
  (* IDs *)
  | (Key_t _, Bytes (_, bytes)) -> (
      (* As unparsed with [Optimized]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes
      with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_t _, String (_, s)) -> (
      (* As unparsed with [Readable]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key)
      >>=? fun ctxt ->
      match Signature.Public_key.of_b58check_opt s with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  | (Key_hash_t _, Bytes (_, bytes)) -> (
      (* As unparsed with [Optimized]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes
      with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_hash_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
      >>=? fun ctxt ->
      match Signature.Public_key_hash.of_b58check_opt s with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_hash_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Signatures *)
  | (Signature_t _, Bytes (_, bytes)) (* As unparsed with [Optimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
      >>=? fun ctxt ->
      match Data_encoding.Binary.of_bytes Signature.encoding bytes with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Signature_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
      >>=? fun ctxt ->
      match Signature.of_b58check_opt s with
      | Some s ->
          return (s, ctxt)
      | None ->
          error () >>=? fail )
  | (Signature_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Operations *)
  | (Operation_t _, _) ->
      (* operations cannot appear in parameters or storage,
           the protocol should never parse the bytes of an operation *)
      assert false
  (* Chain_ids *)
  | (Chain_id_t _, Bytes (_, bytes)) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
      >>=? fun ctxt ->
      match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Chain_id_t _, String (_, s)) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
      >>=? fun ctxt ->
      match Chain_id.of_b58check_opt s with
      | Some s ->
          return (s, ctxt)
      | None ->
          error () >>=? fail )
  | (Chain_id_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Addresses *)
  | (Address_t _, Bytes (loc, bytes)) (* As unparsed with [O[ptimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes
          Data_encoding.(tup2 Contract.encoding Variable.string)
          bytes
      with
      | Some (c, entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            fail (Entrypoint_name_too_long entrypoint)
          else
            ( match entrypoint with
            | "" ->
                return "default"
            | "default" ->
                fail (Unexpected_annotation loc)
            | name ->
                return name )
            >>=? fun entrypoint -> return ((c, entrypoint), ctxt)
      | None ->
          error () >>=? fail )
  | (Address_t _, String (loc, s)) (* As unparsed with [Readable]. *) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      ( match String.index_opt s '%' with
      | None ->
          return (s, "default")
      | Some pos -> (
          let len = String.length s - pos - 1 in
          let name = String.sub s (pos + 1) len in
          if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
          else
            match (String.sub s 0 pos, name) with
            | (_, "default") ->
                traced (fail (Unexpected_annotation loc))
            | addr_and_name ->
                return addr_and_name ) )
      >>=? fun (addr, entrypoint) ->
      Lwt.return (Contract.of_b58check addr)
      >>=? fun c -> return ((c, entrypoint), ctxt)
  | (Address_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Contracts *)
  | (Contract_t (ty, _), Bytes (loc, bytes))
  (* As unparsed with [Optimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes
          Data_encoding.(tup2 Contract.encoding Variable.string)
          bytes
      with
      | Some (c, entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            fail (Entrypoint_name_too_long entrypoint)
          else
            ( match entrypoint with
            | "" ->
                return "default"
            | "default" ->
                traced (fail (Unexpected_annotation loc))
            | name ->
                return name )
            >>=? fun entrypoint ->
            traced (parse_contract ~legacy ctxt loc ty c ~entrypoint)
            >>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
      | None ->
          error () >>=? fail )
  | (Contract_t (ty, _), String (loc, s)) (* As unparsed with [Readable]. *) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      ( match String.index_opt s '%' with
      | None ->
          return (s, "default")
      | Some pos -> (
          let len = String.length s - pos - 1 in
          let name = String.sub s (pos + 1) len in
          if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
          else
            match (String.sub s 0 pos, name) with
            | (_, "default") ->
                traced (fail (Unexpected_annotation loc))
            | addr_and_name ->
                return addr_and_name ) )
      >>=? fun (addr, entrypoint) ->
      traced (Lwt.return (Contract.of_b58check addr))
      >>=? fun c ->
      parse_contract ~legacy ctxt loc ty c ~entrypoint
      >>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
  | (Contract_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Pairs *)
  | (Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [va; vb], annot))
    ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.pair)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy ta va
      >>=? fun (va, ctxt) ->
      parse_data ?type_logger ctxt ~legacy tb vb
      >>=? fun (vb, ctxt) -> return ((va, vb), ctxt)
  | (Pair_t _, Prim (loc, D_Pair, l, _)) ->
      fail @@ Invalid_arity (loc, D_Pair, 2, List.length l)
  | (Pair_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Pair]))
  (* Unions *)
  | (Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [v], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.union)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy tl v
      >>=? fun (v, ctxt) -> return (L v, ctxt)
  | (Union_t _, Prim (loc, D_Left, l, _)) ->
      fail @@ Invalid_arity (loc, D_Left, 1, List.length l)
  | (Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [v], annot)) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.union)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy tr v
      >>=? fun (v, ctxt) -> return (R v, ctxt)
  | (Union_t _, Prim (loc, D_Right, l, _)) ->
      fail @@ Invalid_arity (loc, D_Right, 1, List.length l)
  | (Union_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Left; D_Right]))
  (* Lambdas *)
  | (Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr)) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.lambda)
      >>=? fun ctxt ->
      traced
      @@ parse_returning
           Lambda
           ?type_logger
           ctxt
           ~legacy
           (ta, Some (`Var_annot "@arg"))
           tr
           script_instr
  | (Lambda_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Options *)
  | (Option_t (t, _, _), Prim (loc, D_Some, [v], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.some)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy t v
      >>=? fun (v, ctxt) -> return (Some v, ctxt)
  | (Option_t _, Prim (loc, D_Some, l, _)) ->
      fail @@ Invalid_arity (loc, D_Some, 1, List.length l)
  | (Option_t (_, _, _), Prim (loc, D_None, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.none)
      >>=? fun ctxt -> return (None, ctxt)
  | (Option_t _, Prim (loc, D_None, l, _)) ->
      fail @@ Invalid_arity (loc, D_None, 0, List.length l)
  | (Option_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Some; D_None]))
  (* Lists *)
  | (List_t (t, _ty_name, _), Seq (_loc, items)) ->
      traced
      @@ fold_right_s
           (fun v (rest, ctxt) ->
             Lwt.return (Gas.consume ctxt Typecheck_costs.list_element)
             >>=? fun ctxt ->
             parse_data ?type_logger ctxt ~legacy t v
             >>=? fun (v, ctxt) -> return (v :: rest, ctxt))
           items
           ([], ctxt)
  | (List_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Sets *)
  | (Set_t (t, _ty_name), (Seq (loc, vs) as expr)) ->
      let length = List.length vs in
      traced
      @@ fold_left_s
           (fun (last_value, set, ctxt) v ->
             Lwt.return (Gas.consume ctxt (Typecheck_costs.set_element length))
             >>=? fun ctxt ->
             parse_comparable_data ?type_logger ctxt t v
             >>=? fun (v, ctxt) ->
             ( match last_value with
             | Some value ->
                 if Compare.Int.(0 <= compare_comparable t value v) then
                   if Compare.Int.(0 = compare_comparable t value v) then
                     fail (Duplicate_set_values (loc, strip_locations expr))
                   else fail (Unordered_set_values (loc, strip_locations expr))
                 else return_unit
             | None ->
                 return_unit )
             >>=? fun () ->
             Lwt.return
               (Gas.consume
                  ctxt
                  (Michelson_v1_gas.Cost_of.Legacy.set_update v false set))
             >>=? fun ctxt -> return (Some v, set_update v true set, ctxt))
           (None, empty_set t, ctxt)
           vs
      >>|? fun (_, set, ctxt) -> (set, ctxt)
  | (Set_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Maps *)
  | (Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr)) ->
      parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
  | (Map_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  | (Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr)) ->
      parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x)
      >>|? fun (diff, ctxt) ->
      ( {id = None; diff; key_type = ty_of_comparable_ty tk; value_type = tv},
        ctxt )
  | (Big_map_t (tk, tv, _ty_name), Int (loc, id)) -> (
      Big_map.exists ctxt id
      >>=? function
      | (_, None) ->
          traced (fail (Invalid_big_map (loc, id)))
      | (ctxt, Some (btk, btv)) ->
          Lwt.return
            ( parse_comparable_ty ctxt (Micheline.root btk)
            >>? fun (Ex_comparable_ty btk, ctxt) ->
            parse_packable_ty ctxt ~legacy (Micheline.root btv)
            >>? fun (Ex_ty btv, ctxt) ->
            comparable_ty_eq ctxt tk btk
            >>? fun Eq ->
            ty_eq ctxt tv btv
            >>? fun (Eq, ctxt) ->
            ok
              ( {
                  id = Some id;
                  diff = empty_map tk;
                  key_type = ty_of_comparable_ty tk;
                  value_type = tv;
                },
                ctxt ) ) )
  | (Big_map_t (_tk, _tv, _), expr) ->
      traced
        (fail (Invalid_kind (location expr, [Seq_kind; Int_kind], kind expr)))

and parse_comparable_data :
    type a.
    ?type_logger:type_logger ->
    context ->
    a comparable_ty ->
    Script.node ->
    (a * context) tzresult Lwt.t =
 fun ?type_logger ctxt ty script_data ->
  parse_data
    ?type_logger
    ctxt
    ~legacy:false
    (ty_of_comparable_ty ty)
    script_data

and parse_returning :
    type arg ret.
    ?type_logger:type_logger ->
    tc_context ->
    context ->
    legacy:bool ->
    arg ty * var_annot option ->
    ret ty ->
    Script.node ->
    ((arg, ret) lambda * context) tzresult Lwt.t =
 fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr ->
  parse_instr
    ?type_logger
    tc_context
    ctxt
    ~legacy
    script_instr
    (Item_t (arg, Empty_t, arg_annot))
  >>=? function
  | (Typed ({loc; aft = Item_t (ty, Empty_t, _) as stack_ty; _} as descr), ctxt)
    ->
      trace_eval
        (fun () ->
          Lwt.return (serialize_ty_for_error ctxt ret)
          >>=? fun (ret, ctxt) ->
          serialize_stack_for_error ctxt stack_ty
          >>|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret))
        ( Lwt.return (ty_eq ctxt ty ret)
        >>=? fun (Eq, ctxt) ->
        Lwt.return (merge_types ~legacy ctxt loc ty ret)
        >>=? fun (_ret, ctxt) ->
        return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt) )
  | (Typed {loc; aft = stack_ty; _}, ctxt) ->
      Lwt.return (serialize_ty_for_error ctxt ret)
      >>=? fun (ret, ctxt) ->
      serialize_stack_for_error ctxt stack_ty
      >>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret))
  | (Failed {descr}, ctxt) ->
      return
        ( ( Lam (descr (Item_t (ret, Empty_t, None)), script_instr)
            : (arg, ret) lambda ),
          ctxt )

and parse_int32 (n : (location, prim) Micheline.node) : int tzresult =
  let error' () =
    Invalid_syntactic_constant
      ( location n,
        strip_locations n,
        "a positive 32-bit integer (between 0 and "
        ^ Int32.to_string Int32.max_int
        ^ ")" )
  in
  match n with
  | Micheline.Int (_, n') -> (
    try
      let n'' = Z.to_int n' in
      if
        Compare.Int.(0 <= n'')
        && Compare.Int.(n'' <= Int32.to_int Int32.max_int)
      then ok n''
      else error @@ error' ()
    with _ -> error @@ error' () )
  | _ ->
      error @@ error' ()

and parse_instr :
    type bef.
    ?type_logger:type_logger ->
    tc_context ->
    context ->
    legacy:bool ->
    Script.node ->
    bef stack_ty ->
    (bef judgement * context) tzresult Lwt.t =
 fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty ->
  let _check_item check loc name n m =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n) @@ Lwt.return check
  in
  let check_item_ty (type a b) ctxt (exp : a ty) (got : b ty) loc name n m :
      ((a, b) eq * a ty * context) tzresult Lwt.t =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n)
    @@ Lwt.return
         ( ty_eq ctxt exp got
         >>? fun (Eq, ctxt) ->
         merge_types ~legacy ctxt loc exp got
         >>? fun (ty, ctxt) -> ok ((Eq : (a, b) eq), (ty : a ty), ctxt) )
  in
  let check_item_comparable_ty (type a b) (exp : a comparable_ty)
      (got : b comparable_ty) loc name n m :
      ((a, b) eq * a comparable_ty) tzresult Lwt.t =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n)
    @@ Lwt.return
         ( comparable_ty_eq ctxt exp got
         >>? fun Eq ->
         merge_comparable_types ~legacy exp got
         >>? fun ty -> ok ((Eq : (a, b) eq), (ty : a comparable_ty)) )
  in
  let log_stack ctxt loc stack_ty aft =
    match (type_logger, script_instr) with
    | (None, _) | (Some _, (Seq (-1, _) | Int _ | String _ | Bytes _)) ->
        return_unit
    | (Some log, (Prim _ | Seq _)) ->
        (* Unparsing for logging done in an unlimited context as this
             is used only by the client and not the protocol *)
        let ctxt = Gas.set_unlimited ctxt in
        unparse_stack ctxt stack_ty
        >>=? fun (stack_ty, _) ->
        unparse_stack ctxt aft
        >>=? fun (aft, _) -> log loc stack_ty aft ; return_unit
  in
  let outer_return = return in
  let return :
      type bef.
      context -> bef judgement -> (bef judgement * context) tzresult Lwt.t =
   fun ctxt judgement ->
    match judgement with
    | Typed {instr; loc; aft; _} ->
        let maximum_type_size = Constants.michelson_maximum_type_size ctxt in
        let type_size =
          type_size_of_stack_head
            aft
            ~up_to:(number_of_generated_growing_types instr)
        in
        if Compare.Int.(type_size > maximum_type_size) then
          fail (Type_too_large (loc, type_size, maximum_type_size))
        else return (judgement, ctxt)
    | Failed _ ->
        return (judgement, ctxt)
  in
  let typed ctxt loc instr aft =
    log_stack ctxt loc stack_ty aft
    >>=? fun () ->
    Lwt.return @@ Gas.consume ctxt (Typecheck_costs.instr instr)
    >>=? fun ctxt -> return ctxt (Typed {loc; instr; bef = stack_ty; aft})
  in
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle
  >>=? fun ctxt ->
  match (script_instr, stack_ty) with
  (* stack ops *)
  | (Prim (loc, I_DROP, [], annot), Item_t (_, rest, _)) ->
      ( fail_unexpected_annot loc annot >>=? fun () -> typed ctxt loc Drop rest
        : (bef judgement * context) tzresult Lwt.t )
  | (Prim (loc, I_DROP, [n], result_annot), whole_stack) ->
      Lwt.return (parse_int32 n)
      >>=? fun whole_n ->
      let rec make_proof_argument :
          type tstk.
          int -> tstk stack_ty -> tstk dropn_proof_argument tzresult Lwt.t =
       fun n stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) ->
            outer_return @@ Dropn_proof_argument (Rest, rest, rest)
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) rest
            >>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) ->
            outer_return
            @@ Dropn_proof_argument
                 (Prefix n', stack_after_drops, Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt whole_stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DROP, whole_n, whole_stack))
      in
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument whole_n whole_stack
      >>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) ->
      typed ctxt loc (Dropn (whole_n, n')) stack_after_drops
  | (Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _) ->
      (* Technically, the arities 0 and 1 are allowed but the error only mentions 1.
           However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *)
      fail (Invalid_arity (loc, I_DROP, 1, List.length l))
  | (Prim (loc, I_DUP, [], annot), Item_t (v, rest, stack_annot)) ->
      parse_var_annot loc annot ~default:stack_annot
      >>=? fun annot ->
      typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot))
  | (Prim (loc, I_DIG, [n], result_annot), stack) ->
      let rec make_proof_argument :
          type tstk.
          int -> tstk stack_ty -> tstk dig_proof_argument tzresult Lwt.t =
       fun n stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, Item_t (v, rest, annot)) ->
            outer_return @@ Dig_proof_argument (Rest, (v, annot), rest)
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) rest
            >>=? fun (Dig_proof_argument (n', (x, xv), aft')) ->
            outer_return
            @@ Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DIG, 1, whole_stack))
      in
      Lwt.return (parse_int32 n)
      >>=? fun n ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument n stack
      >>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) ->
      typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot))
  | (Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_DIG, 1, List.length l))
  | (Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot))
    ->
      Lwt.return (parse_int32 n)
      >>=? fun whole_n ->
      let rec make_proof_argument :
          type tstk x.
          int ->
          x ty ->
          var_annot option ->
          tstk stack_ty ->
          (tstk, x) dug_proof_argument tzresult Lwt.t =
       fun n x stack_annot stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) ->
            outer_return
            @@ Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot))
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) x stack_annot rest
            >>=? fun (Dug_proof_argument (n', (), aft')) ->
            outer_return
            @@ Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt whole_stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DUG, whole_n, whole_stack))
      in
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument whole_n x stack_annot whole_stack
      >>=? fun (Dug_proof_argument (n', (), aft)) ->
      typed ctxt loc (Dug (whole_n, n')) aft
  | (Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack)) ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_DUG, 1, stack))
  | (Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_DUG, 1, List.length l))
  | ( Prim (loc, I_SWAP, [], annot),
      Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) ) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      typed
        ctxt
        loc
        Swap
        (Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot))
  | (Prim (loc, I_PUSH, [t; d], annot), stack) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_data ?type_logger ctxt ~legacy t d
      >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot))
  | (Prim (loc, I_UNIT, [], annot), stack) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot))
  (* options *)
  | (Prim (loc, I_SOME, [], annot), Item_t (t, rest, _)) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        Cons_some
        (Item_t (Option_t (t, ty_name, has_big_map t), rest, annot))
  | (Prim (loc, I_NONE, [t], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Cons_none t)
        (Item_t (Option_t (t, ty_name, has_big_map t), stack, annot))
  | ( Prim (loc, I_IF_NONE, [bt; bf], annot),
      (Item_t (Option_t (t, _, _), rest, option_annot) as bef) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let annot = gen_access_annot option_annot default_some_annot in
      parse_instr ?type_logger tc_context ctxt ~legacy bt rest
      >>=? fun (btr, ctxt) ->
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bf
        (Item_t (t, rest, annot))
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_none (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  (* pairs *)
  | ( Prim (loc, I_PAIR, [], annot),
      Item_t (a, Item_t (b, rest, snd_annot), fst_annot) ) ->
      parse_constr_annot
        loc
        annot
        ~if_special_first:(var_to_field_annot fst_annot)
        ~if_special_second:(var_to_field_annot snd_annot)
      >>=? fun (annot, ty_name, l_field, r_field) ->
      typed
        ctxt
        loc
        Cons_pair
        (Item_t
           ( Pair_t
               ( (a, l_field, fst_annot),
                 (b, r_field, snd_annot),
                 ty_name,
                 has_big_map a || has_big_map b ),
             rest,
             annot ))
  | ( Prim (loc, I_CAR, [], annot),
      Item_t
        (Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot)
    ) ->
      parse_destr_annot
        loc
        annot
        ~pair_annot
        ~value_annot:a_annot
        ~field_name:expected_field_annot
        ~default_accessor:default_car_annot
      >>=? fun (annot, field_annot) ->
      Lwt.return @@ check_correct_field field_annot expected_field_annot
      >>=? fun () -> typed ctxt loc Car (Item_t (a, rest, annot))
  | ( Prim (loc, I_CDR, [], annot),
      Item_t
        (Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot)
    ) ->
      parse_destr_annot
        loc
        annot
        ~pair_annot
        ~value_annot:b_annot
        ~field_name:expected_field_annot
        ~default_accessor:default_cdr_annot
      >>=? fun (annot, field_annot) ->
      Lwt.return @@ check_correct_field field_annot expected_field_annot
      >>=? fun () -> typed ctxt loc Cdr (Item_t (b, rest, annot))
  (* unions *)
  | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest, stack_annot)) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tr
      >>=? fun (Ex_ty tr, ctxt) ->
      parse_constr_annot
        loc
        annot
        ~if_special_first:(var_to_field_annot stack_annot)
      >>=? fun (annot, tname, l_field, r_field) ->
      typed
        ctxt
        loc
        Left
        (Item_t
           ( Union_t
               ( (tl, l_field),
                 (tr, r_field),
                 tname,
                 has_big_map tl || has_big_map tr ),
             rest,
             annot ))
  | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest, stack_annot)) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tl
      >>=? fun (Ex_ty tl, ctxt) ->
      parse_constr_annot
        loc
        annot
        ~if_special_second:(var_to_field_annot stack_annot)
      >>=? fun (annot, tname, l_field, r_field) ->
      typed
        ctxt
        loc
        Right
        (Item_t
           ( Union_t
               ( (tl, l_field),
                 (tr, r_field),
                 tname,
                 has_big_map tl || has_big_map tr ),
             rest,
             annot ))
  | ( Prim (loc, I_IF_LEFT, [bt; bf], annot),
      ( Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot)
      as bef ) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let left_annot =
        gen_access_annot union_annot l_field ~default:default_left_annot
      in
      let right_annot =
        gen_access_annot union_annot r_field ~default:default_right_annot
      in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bt
        (Item_t (tl, rest, left_annot))
      >>=? fun (btr, ctxt) ->
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bf
        (Item_t (tr, rest, right_annot))
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_left (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  (* lists *)
  | (Prim (loc, I_NIL, [t], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        Nil
        (Item_t (List_t (t, ty_name, has_big_map t), stack, annot))
  | ( Prim (loc, I_CONS, [], annot),
      Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) ) ->
      check_item_ty ctxt tv t loc I_CONS 1 2
      >>=? fun (Eq, t, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Cons_list
        (Item_t (List_t (t, ty_name, has_big_map), rest, annot))
  | ( Prim (loc, I_IF_CONS, [bt; bf], annot),
      (Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let hd_annot = gen_access_annot list_annot default_hd_annot in
      let tl_annot = gen_access_annot list_annot default_tl_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bt
        (Item_t
           ( t,
             Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot),
             hd_annot ))
      >>=? fun (btr, ctxt) ->
      parse_instr ?type_logger tc_context ctxt ~legacy bf rest
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_cons (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _)) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_MAP, [body], annot),
      Item_t (List_t (elt, _, _), starting_rest, list_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_type_annot loc annot
      >>=? fun (ret_annot, list_ty_name) ->
      let elt_annot = gen_access_annot list_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, starting_rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
          let invalid_map_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
          in
          trace_eval
            invalid_map_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
            >>=? fun (rest, ctxt) ->
            typed
              ctxt
              loc
              (List_map ibody)
              (Item_t
                 (List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot))
            )
      | Typed {aft; _} ->
          serialize_stack_for_error ctxt aft
          >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
      | Failed _ ->
          fail (Invalid_map_block_fail loc) )
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (List_t (elt, _, _), rest, list_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let elt_annot = gen_access_annot list_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (List_iter (descr rest)) rest )
  (* sets *)
  | (Prim (loc, I_EMPTY_SET, [t], annot), rest) ->
      Lwt.return @@ parse_comparable_ty ctxt t
      >>=? fun (Ex_comparable_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot))
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (Set_t (comp_elt, _), rest, set_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let elt_annot = gen_access_annot set_annot default_elt_annot in
      let elt = ty_of_comparable_ty comp_elt in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (Set_iter (descr rest)) rest )
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (v, Item_t (Set_t (elt, _), rest, _), _) ) ->
      let elt = ty_of_comparable_ty elt in
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      check_item_ty ctxt elt v loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( v,
          Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _),
          _ ) ) -> (
    match comparable_ty_of_ty v with
    | None ->
        unparse_ty ctxt v
        >>=? fun (v, _ctxt) ->
        fail (Comparable_type_expected (loc, Micheline.strip_locations v))
    | Some v ->
        parse_var_annot loc annot ~default:set_annot
        >>=? fun annot ->
        check_item_comparable_ty elt v loc I_UPDATE 1 3
        >>=? fun (Eq, elt) ->
        typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) )
  | (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot))
  (* maps *)
  | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) ->
      Lwt.return @@ parse_comparable_ty ctxt tk
      >>=? fun (Ex_comparable_ty tk, ctxt) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tv
      >>=? fun (Ex_ty tv, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Empty_map (tk, tv))
        (Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot))
  | ( Prim (loc, I_MAP, [body], annot),
      Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) ) -> (
      let k = ty_of_comparable_ty ck in
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_type_annot loc annot
      >>=? fun (ret_annot, ty_name) ->
      let k_name = field_to_var_annot default_key_annot in
      let e_name = field_to_var_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t
           ( Pair_t
               ((k, None, k_name), (elt, None, e_name), None, has_big_map elt),
             starting_rest,
             None ))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
          let invalid_map_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
          in
          trace_eval
            invalid_map_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
            >>=? fun (rest, ctxt) ->
            typed
              ctxt
              loc
              (Map_map ibody)
              (Item_t
                 (Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot))
            )
      | Typed {aft; _} ->
          serialize_stack_for_error ctxt aft
          >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
      | Failed _ ->
          fail (Invalid_map_block_fail loc) )
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let k_name = field_to_var_annot default_key_annot in
      let e_name = field_to_var_annot default_elt_annot in
      let key = ty_of_comparable_ty comp_elt in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t
           ( Pair_t
               ( (key, None, k_name),
                 (element_ty, None, e_name),
                 None,
                 has_big_map element_ty ),
             rest,
             None ))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (Map_iter (descr rest)) rest )
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot))
  | ( Prim (loc, I_GET, [], annot),
      Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_GET 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Map_get
        (Item_t (Option_t (elt, None, has_big_map), rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( vk,
          Item_t
            ( Option_t (vv, _, _),
              Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot),
              _ ),
          _ ) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_UPDATE 1 3
      >>=? fun (Eq, _, ctxt) ->
      check_item_ty ctxt vv v loc I_UPDATE 2 3
      >>=? fun (Eq, v, ctxt) ->
      parse_var_annot loc annot ~default:map_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Map_update
        (Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _, _), rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot))
  (* big_map *)
  | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) ->
      Lwt.return @@ parse_comparable_ty ctxt tk
      >>=? fun (Ex_comparable_ty tk, ctxt) ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy tv
      >>=? fun (Ex_ty tv, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Empty_big_map (tk, tv))
        (Item_t (Big_map_t (tk, tv, ty_name), stack, annot))
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty map_key in
      check_item_ty ctxt set_key k loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot))
  | ( Prim (loc, I_GET, [], annot),
      Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_GET 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Big_map_get
        (Item_t (Option_t (elt, None, has_big_map elt), rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( set_key,
          Item_t
            ( Option_t (set_value, _, _),
              Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot),
              _ ),
          _ ) ) ->
      let k = ty_of_comparable_ty map_key in
      check_item_ty ctxt set_key k loc I_UPDATE 1 3
      >>=? fun (Eq, _, ctxt) ->
      check_item_ty ctxt set_value map_value loc I_UPDATE 2 3
      >>=? fun (Eq, map_value, ctxt) ->
      parse_var_annot loc annot ~default:map_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Big_map_update
        (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot))
  (* control *)
  | (Seq (loc, []), stack) ->
      typed ctxt loc Nop stack
  | (Seq (loc, [single]), stack) -> (
      parse_instr ?type_logger tc_context ctxt ~legacy single stack
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as instr) ->
          let nop = {bef = aft; loc; aft; instr = Nop} in
          typed ctxt loc (Seq (instr, nop)) aft
      | Failed {descr; _} ->
          let descr aft =
            let nop = {bef = aft; loc; aft; instr = Nop} in
            let descr = descr aft in
            {descr with instr = Seq (descr, nop)}
          in
          return ctxt (Failed {descr}) )
  | (Seq (loc, hd :: tl), stack) -> (
      parse_instr ?type_logger tc_context ctxt ~legacy hd stack
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Failed _ ->
          fail (Fail_not_in_tail_position (Micheline.location hd))
      | Typed ({aft = middle; _} as ihd) -> (
          parse_instr
            ?type_logger
            tc_context
            ctxt
            ~legacy
            (Seq (-1, tl))
            middle
          >>=? fun (judgement, ctxt) ->
          match judgement with
          | Failed {descr} ->
              let descr ret =
                {loc; instr = Seq (ihd, descr ret); bef = stack; aft = ret}
              in
              return ctxt (Failed {descr})
          | Typed itl ->
              typed ctxt loc (Seq (ihd, itl)) itl.aft ) )
  | (Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t _, rest, _) as bef)) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      parse_instr ?type_logger tc_context ctxt ~legacy bt rest
      >>=? fun (btr, ctxt) ->
      parse_instr ?type_logger tc_context ctxt ~legacy bf rest
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf = {loc; instr = If (ibt, ibf); bef; aft = ibt.aft} in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  | ( Prim (loc, I_LOOP, [body], annot),
      (Item_t (Bool_t _, rest, _stack_annot) as stack) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      parse_instr ?type_logger tc_context ctxt ~legacy body rest
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ibody ->
          let unmatched_branches () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt stack
            >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
          in
          trace_eval
            unmatched_branches
            ( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
            >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest )
      | Failed {descr} ->
          let ibody = descr stack in
          typed ctxt loc (Loop ibody) rest )
  | ( Prim (loc, I_LOOP_LEFT, [body], annot),
      ( Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as
      stack ) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_annot loc annot
      >>=? fun annot ->
      let l_annot =
        gen_access_annot union_annot l_field ~default:default_left_annot
      in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (tl, rest, l_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ibody ->
          let unmatched_branches () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt stack
            >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
          in
          trace_eval
            unmatched_branches
            ( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
            >>=? fun (_stack, ctxt) ->
            typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
      | Failed {descr} ->
          let ibody = descr stack in
          typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
  | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy arg
      >>=? fun (Ex_ty arg, ctxt) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy ret
      >>=? fun (Ex_ty ret, ctxt) ->
      check_kind [Seq_kind] code
      >>=? fun () ->
      parse_var_annot loc annot
      >>=? fun annot ->
      parse_returning
        Lambda
        ?type_logger
        ctxt
        ~legacy
        (arg, default_arg_annot)
        ret
        code
      >>=? fun (lambda, ctxt) ->
      typed
        ctxt
        loc
        (Lambda lambda)
        (Item_t (Lambda_t (arg, ret, None), stack, annot))
  | ( Prim (loc, I_EXEC, [], annot),
      Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) ) ->
      check_item_ty ctxt arg param loc I_EXEC 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot))
  | ( Prim (loc, I_APPLY, [], annot),
      Item_t
        ( capture,
          Item_t
            ( Lambda_t
                ( Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _),
                  ret,
                  _ ),
              rest,
              _ ),
          _ ) ) ->
      Lwt.return @@ check_packable ~legacy:false loc capture_ty
      >>=? fun () ->
      check_item_ty ctxt capture capture_ty loc I_APPLY 1 2
      >>=? fun (Eq, capture_ty, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        (Apply capture_ty)
        (Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot))
  | (Prim (loc, I_DIP, [code], annot), Item_t (v, rest, stack_annot)) -> (
      fail_unexpected_annot loc annot
      >>=? fun () ->
      check_kind [Seq_kind] code
      >>=? fun () ->
      parse_instr
        ?type_logger
        (add_dip v stack_annot tc_context)
        ctxt
        ~legacy
        code
        rest
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed descr ->
          typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot))
      | Failed _ ->
          fail (Fail_not_in_tail_position loc) )
  | (Prim (loc, I_DIP, [n; code], result_annot), stack)
    when match parse_int32 n with Ok _ -> true | Error _ -> false ->
      let rec make_proof_argument :
          type tstk.
          int
          (* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) ->
          tc_context ->
          tstk stack_ty ->
          tstk dipn_proof_argument tzresult Lwt.t =
       fun n inner_tc_context stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) -> (
            parse_instr ?type_logger inner_tc_context ctxt ~legacy code rest
            >>=? fun (judgement, ctxt) ->
            match judgement with
            | Typed descr ->
                outer_return
                @@ Dipn_proof_argument (Rest, (ctxt, descr), descr.aft)
            | Failed _ ->
                fail (Fail_not_in_tail_position loc) )
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) (add_dip v annot tc_context) rest
            >>=? fun (Dipn_proof_argument (n', descr, aft')) ->
            outer_return
            @@ Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DIP, 1, whole_stack))
      in
      Lwt.return (parse_int32 n)
      >>=? fun n ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument n tc_context stack
      >>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) ->
      (* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *)
      typed new_ctxt loc (Dipn (n, n', descr)) aft
  | (Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _) ->
      (* Technically, the arities 1 and 2 are allowed but the error only mentions 2.
           However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *)
      fail (Invalid_arity (loc, I_DIP, 2, List.length l))
  | (Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _)) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let descr aft = {loc; instr = Failwith v; bef = stack_ty; aft} in
      log_stack ctxt loc stack_ty Empty_t
      >>=? fun () -> return ctxt (Failed {descr})
  (* timestamp operations *)
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Add_timestamp_to_seconds
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Add_seconds_to_timestamp
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Sub_timestamp_seconds
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot))
  (* string operations *)
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot))
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (List_t (String_t tname, _, _), rest, list_annot) ) ->
      parse_var_annot ~default:list_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot))
  | ( Prim (loc, I_SLICE, [], annot),
      Item_t
        ( Nat_t _,
          Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _),
          _ ) ) ->
      parse_var_annot
        ~default:(gen_access_annot string_annot default_slice_annot)
        loc
        annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Slice_string
        (Item_t (Option_t (String_t tname, None, false), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc String_size (Item_t (Nat_t None, rest, annot))
  (* bytes operations *)
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot))
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) ) ->
      parse_var_annot ~default:list_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot))
  | ( Prim (loc, I_SLICE, [], annot),
      Item_t
        ( Nat_t _,
          Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _),
          _ ) ) ->
      parse_var_annot
        ~default:(gen_access_annot bytes_annot default_slice_annot)
        loc
        annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Slice_bytes
        (Item_t (Option_t (Bytes_t tname, None, false), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot))
  (* currency operations *)
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      (* no type name check *)
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_teznat (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) ) ->
      (* no type name check *)
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_nattez (Item_t (Mutez_t tname, rest, annot))
  (* boolean operations *)
  | ( Prim (loc, I_OR, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_XOR, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Bool_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Not (Item_t (Bool_t tname, rest, annot))
  (* integer operations *)
  | (Prim (loc, I_ABS, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Abs_int (Item_t (Nat_t None, rest, annot))
  | (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t _, rest, int_annot)) ->
      parse_var_annot loc annot ~default:int_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Is_nat
        (Item_t (Option_t (Nat_t None, None, false), rest, annot))
  | (Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Int_nat (Item_t (Int_t None, rest, annot))
  | (Prim (loc, I_NEG, [], annot), Item_t (Int_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Neg_int (Item_t (Int_t tname, rest, annot))
  | (Prim (loc, I_NEG, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Neg_nat (Item_t (Int_t None, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Add_intnat (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Add_natint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun _tname ->
      typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_intnat (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_natint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_teznat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Mutez_t tname, None, None),
                     (Mutez_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_tez
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Nat_t None, None, None),
                     (Mutez_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_intint
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t tname, None, None),
                     (Nat_t None, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_intnat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t tname, None, None),
                     (Nat_t None, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_natint
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t None, None, None),
                     (Nat_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_natnat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Nat_t tname, None, None),
                     (Nat_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_LSL, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_LSR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_OR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc And_int_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_XOR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Int_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Not_int (Item_t (Int_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Not_nat (Item_t (Int_t None, rest, annot))
  (* comparison *)
  | (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest, _), _))
    -> (
      parse_var_annot loc annot
      >>=? fun annot ->
      check_item_ty ctxt t1 t2 loc I_COMPARE 1 2
      >>=? fun (Eq, t, ctxt) ->
      match comparable_ty_of_ty t with
      | None ->
          Lwt.return (serialize_ty_for_error ctxt t)
          >>=? fun (t, _ctxt) -> fail (Comparable_type_expected (loc, t))
      | Some key ->
          typed ctxt loc (Compare key) (Item_t (Int_t None, rest, annot)) )
  (* comparators *)
  | (Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Eq (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_NEQ, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Neq (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_LT, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Lt (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_GT, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Gt (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_LE, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Le (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_GE, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Ge (Item_t (Bool_t None, rest, annot))
  (* annotations *)
  | (Prim (loc, I_CAST, [cast_t], annot), Item_t (t, stack, item_annot)) ->
      parse_var_annot loc annot ~default:item_annot
      >>=? fun annot ->
      Lwt.return @@ parse_any_ty ctxt ~legacy cast_t
      >>=? fun (Ex_ty cast_t, ctxt) ->
      Lwt.return @@ ty_eq ctxt cast_t t
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc cast_t t
      >>=? fun (_, ctxt) -> typed ctxt loc Nop (Item_t (cast_t, stack, annot))
  | (Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      (* can erase annot *)
      typed ctxt loc Nop (Item_t (t, stack, annot))
  (* packing *)
  | (Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot)) ->
      Lwt.return
        (check_packable
           ~legacy:true
           (* allow to pack contracts for hash/signature checks *) loc
           t)
      >>=? fun () ->
      parse_var_annot
        loc
        annot
        ~default:(gen_access_annot unpacked_annot default_pack_annot)
      >>=? fun annot ->
      typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest, packed_annot))
    ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy ty
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      let annot =
        default_annot
          annot
          ~default:(gen_access_annot packed_annot default_unpack_annot)
      in
      typed
        ctxt
        loc
        (Unpack t)
        (Item_t
           ( Option_t (t, ty_name, false (* cannot unpack big_maps *)),
             rest,
             annot ))
  (* protocol *)
  | ( Prim (loc, I_ADDRESS, [], annot),
      Item_t (Contract_t _, rest, contract_annot) ) ->
      parse_var_annot
        loc
        annot
        ~default:(gen_access_annot contract_annot default_addr_annot)
      >>=? fun annot ->
      typed ctxt loc Address (Item_t (Address_t None, rest, annot))
  | ( Prim (loc, I_CONTRACT, [ty], annot),
      Item_t (Address_t _, rest, addr_annot) ) ->
      Lwt.return @@ parse_parameter_ty ctxt ~legacy ty
      >>=? fun (Ex_ty t, ctxt) ->
      parse_entrypoint_annot
        loc
        annot
        ~default:(gen_access_annot addr_annot default_contract_annot)
      >>=? fun (annot, entrypoint) ->
      ( Lwt.return
      @@
      match entrypoint with
      | None ->
          Ok "default"
      | Some (`Field_annot "default") ->
          error (Unexpected_annotation loc)
      | Some (`Field_annot entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            error (Entrypoint_name_too_long entrypoint)
          else Ok entrypoint )
      >>=? fun entrypoint ->
      typed
        ctxt
        loc
        (Contract (t, entrypoint))
        (Item_t (Option_t (Contract_t (t, None), None, false), rest, annot))
  | ( Prim (loc, I_TRANSFER_TOKENS, [], annot),
      Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _)
    ) ->
      check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot))
  | ( Prim (loc, I_SET_DELEGATE, [], annot),
      Item_t (Option_t (Key_hash_t _, _, _), rest, _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot))
  | ( Prim (loc, I_CREATE_ACCOUNT, [], annot),
      Item_t
        ( Key_hash_t _,
          Item_t
            ( Option_t (Key_hash_t _, _, _),
              Item_t (Bool_t _, Item_t (Mutez_t _, rest, _), _),
              _ ),
          _ ) ) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_two_var_annot loc annot
        >>=? fun (op_annot, addr_annot) ->
        typed
          ctxt
          loc
          Create_account
          (Item_t
             ( Operation_t None,
               Item_t (Address_t None, rest, addr_annot),
               op_annot ))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_CREATE_ACCOUNT)
  | (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _))
    ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Implicit_account
        (Item_t (Contract_t (Unit_t None, None), rest, annot))
  | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
      Item_t
        ( Key_hash_t _,
          Item_t
            ( Option_t (Key_hash_t _, _, _),
              Item_t
                ( Bool_t _,
                  Item_t
                    ( Bool_t _,
                      Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
                      _ ),
                  _ ),
              _ ),
          _ ) ) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_two_var_annot loc annot
        >>=? fun (op_annot, addr_annot) ->
        let cannonical_code = fst @@ Micheline.extract_locations code in
        Lwt.return @@ parse_toplevel ~legacy cannonical_code
        >>=? fun (arg_type, storage_type, code_field, root_name) ->
        trace
          (Ill_formed_type
             (Some "parameter", cannonical_code, location arg_type))
          (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
        >>=? fun (Ex_ty arg_type, ctxt) ->
        ( if legacy then Error_monad.return ()
        else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
        >>=? fun () ->
        trace
          (Ill_formed_type
             (Some "storage", cannonical_code, location storage_type))
          (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
        >>=? fun (Ex_ty storage_type, ctxt) ->
        let arg_annot =
          default_annot
            (type_to_var_annot (name_of_ty arg_type))
            ~default:default_param_annot
        in
        let storage_annot =
          default_annot
            (type_to_var_annot (name_of_ty storage_type))
            ~default:default_storage_annot
        in
        let arg_type_full =
          Pair_t
            ( (arg_type, None, arg_annot),
              (storage_type, None, storage_annot),
              None,
              has_big_map arg_type || has_big_map storage_type )
        in
        let ret_type_full =
          Pair_t
            ( (List_t (Operation_t None, None, false), None, None),
              (storage_type, None, None),
              None,
              has_big_map storage_type )
        in
        trace
          (Ill_typed_contract (cannonical_code, []))
          (parse_returning
             (Toplevel
                {
                  storage_type;
                  param_type = arg_type;
                  root_name;
                  legacy_create_contract_literal = true;
                })
             ctxt
             ~legacy
             ?type_logger
             (arg_type_full, None)
             ret_type_full
             code_field)
        >>=? fun ( ( Lam
                       ( { bef = Item_t (arg, Empty_t, _);
                           aft = Item_t (ret, Empty_t, _);
                           _ },
                         _ ) as lambda ),
                   ctxt ) ->
        Lwt.return @@ ty_eq ctxt arg arg_type_full
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
        >>=? fun (_, ctxt) ->
        Lwt.return @@ ty_eq ctxt ret ret_type_full
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
        >>=? fun (_, ctxt) ->
        Lwt.return @@ ty_eq ctxt storage_type ginit
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
        >>=? fun (_, ctxt) ->
        typed
          ctxt
          loc
          (Create_contract (storage_type, arg_type, lambda, root_name))
          (Item_t
             ( Operation_t None,
               Item_t (Address_t None, rest, addr_annot),
               op_annot ))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_CREATE_CONTRACT)
  | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
      (* Removed the instruction's arguments manager, spendable and delegatable *)
    Item_t
      ( Option_t (Key_hash_t _, _, _),
        Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
        _ ) ) ->
      parse_two_var_annot loc annot
      >>=? fun (op_annot, addr_annot) ->
      let cannonical_code = fst @@ Micheline.extract_locations code in
      Lwt.return @@ parse_toplevel ~legacy cannonical_code
      >>=? fun (arg_type, storage_type, code_field, root_name) ->
      trace
        (Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
        (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
      >>=? fun (Ex_ty arg_type, ctxt) ->
      ( if legacy then Error_monad.return ()
      else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
      >>=? fun () ->
      trace
        (Ill_formed_type
           (Some "storage", cannonical_code, location storage_type))
        (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
      >>=? fun (Ex_ty storage_type, ctxt) ->
      let arg_annot =
        default_annot
          (type_to_var_annot (name_of_ty arg_type))
          ~default:default_param_annot
      in
      let storage_annot =
        default_annot
          (type_to_var_annot (name_of_ty storage_type))
          ~default:default_storage_annot
      in
      let arg_type_full =
        Pair_t
          ( (arg_type, None, arg_annot),
            (storage_type, None, storage_annot),
            None,
            has_big_map arg_type || has_big_map storage_type )
      in
      let ret_type_full =
        Pair_t
          ( (List_t (Operation_t None, None, false), None, None),
            (storage_type, None, None),
            None,
            has_big_map storage_type )
      in
      trace
        (Ill_typed_contract (cannonical_code, []))
        (parse_returning
           (Toplevel
              {
                storage_type;
                param_type = arg_type;
                root_name;
                legacy_create_contract_literal = false;
              })
           ctxt
           ~legacy
           ?type_logger
           (arg_type_full, None)
           ret_type_full
           code_field)
      >>=? fun ( ( Lam
                     ( { bef = Item_t (arg, Empty_t, _);
                         aft = Item_t (ret, Empty_t, _);
                         _ },
                       _ ) as lambda ),
                 ctxt ) ->
      Lwt.return @@ ty_eq ctxt arg arg_type_full
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
      >>=? fun (_, ctxt) ->
      Lwt.return @@ ty_eq ctxt ret ret_type_full
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
      >>=? fun (_, ctxt) ->
      Lwt.return @@ ty_eq ctxt storage_type ginit
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
      >>=? fun (_, ctxt) ->
      typed
        ctxt
        loc
        (Create_contract_2 (storage_type, arg_type, lambda, root_name))
        (Item_t
           ( Operation_t None,
             Item_t (Address_t None, rest, addr_annot),
             op_annot ))
  | (Prim (loc, I_NOW, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_now_annot
      >>=? fun annot ->
      typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot))
  | (Prim (loc, I_AMOUNT, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_amount_annot
      >>=? fun annot ->
      typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot))
  | (Prim (loc, I_CHAIN_ID, [], annot), stack) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc ChainId (Item_t (Chain_id_t None, stack, annot))
  | (Prim (loc, I_BALANCE, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_balance_annot
      >>=? fun annot ->
      typed ctxt loc Balance (Item_t (Mutez_t None, stack, annot))
  | (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Hash_key (Item_t (Key_hash_t None, rest, annot))
  | ( Prim (loc, I_CHECK_SIGNATURE, [], annot),
      Item_t
        (Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) )
    ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Check_signature (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_BLAKE2B, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Blake2b (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_SHA256, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sha256 (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_SHA512, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sha512 (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_var_annot loc annot ~default:default_steps_annot
        >>=? fun annot ->
        typed ctxt loc Steps_to_quota (Item_t (Nat_t None, stack, annot))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_STEPS_TO_QUOTA)
  | (Prim (loc, I_SOURCE, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_source_annot
      >>=? fun annot ->
      typed ctxt loc Source (Item_t (Address_t None, stack, annot))
  | (Prim (loc, I_SENDER, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_sender_annot
      >>=? fun annot ->
      typed ctxt loc Sender (Item_t (Address_t None, stack, annot))
  | (Prim (loc, I_SELF, [], annot), stack) ->
      parse_entrypoint_annot loc annot ~default:default_self_annot
      >>=? fun (annot, entrypoint) ->
      let entrypoint =
        Option.unopt_map
          ~f:(fun (`Field_annot annot) -> annot)
          ~default:"default"
          entrypoint
      in
      let rec get_toplevel_type :
          tc_context -> (bef judgement * context) tzresult Lwt.t = function
        | Lambda ->
            fail (Self_in_lambda loc)
        | Dip (_, prev) ->
            get_toplevel_type prev
        | Toplevel
            {param_type; root_name; legacy_create_contract_literal = false} ->
            Lwt.return (find_entrypoint param_type ~root_name entrypoint)
            >>=? fun (_, Ex_ty param_type) ->
            typed
              ctxt
              loc
              (Self (param_type, entrypoint))
              (Item_t (Contract_t (param_type, None), stack, annot))
        | Toplevel
            {param_type; root_name = _; legacy_create_contract_literal = true}
          ->
            typed
              ctxt
              loc
              (Self (param_type, "default"))
              (Item_t (Contract_t (param_type, None), stack, annot))
      in
      get_toplevel_type tc_context
  (* Primitive parsing errors *)
  | ( Prim
        ( loc,
          ( ( I_DUP
            | I_SWAP
            | I_SOME
            | I_UNIT
            | I_PAIR
            | I_CAR
            | I_CDR
            | I_CONS
            | I_CONCAT
            | I_SLICE
            | I_MEM
            | I_UPDATE
            | I_MAP
            | I_GET
            | I_EXEC
            | I_FAILWITH
            | I_SIZE
            | I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_OR
            | I_AND
            | I_XOR
            | I_NOT
            | I_ABS
            | I_NEG
            | I_LSL
            | I_LSR
            | I_COMPARE
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE
            | I_TRANSFER_TOKENS
            | I_CREATE_ACCOUNT
            | I_SET_DELEGATE
            | I_NOW
            | I_IMPLICIT_ACCOUNT
            | I_AMOUNT
            | I_BALANCE
            | I_CHECK_SIGNATURE
            | I_HASH_KEY
            | I_SOURCE
            | I_SENDER
            | I_BLAKE2B
            | I_SHA256
            | I_SHA512
            | I_STEPS_TO_QUOTA
            | I_ADDRESS ) as name ),
          (_ :: _ as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 0, List.length l))
  | ( Prim
        ( loc,
          ( ( I_NONE
            | I_LEFT
            | I_RIGHT
            | I_NIL
            | I_MAP
            | I_ITER
            | I_EMPTY_SET
            | I_DIP
            | I_LOOP
            | I_LOOP_LEFT
            | I_CONTRACT ) as name ),
          (([] | _ :: _ :: _) as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 1, List.length l))
  | ( Prim
        ( loc,
          ( (I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS | I_EMPTY_MAP | I_IF)
          as name ),
          (([] | [_] | _ :: _ :: _ :: _) as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 2, List.length l))
  | (Prim (loc, I_LAMBDA, (([] | [_] | _ :: _ :: _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l))
  (* Stack errors *)
  | ( Prim
        ( loc,
          ( ( I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_AND
            | I_OR
            | I_XOR
            | I_LSL
            | I_LSR ) as name ),
          [],
          _ ),
      Item_t (ta, Item_t (tb, _, _), _) ) ->
      Lwt.return @@ serialize_ty_for_error ctxt ta
      >>=? fun (ta, ctxt) ->
      Lwt.return @@ serialize_ty_for_error ctxt tb
      >>=? fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb))
  | ( Prim
        ( loc,
          ( ( I_NEG
            | I_ABS
            | I_NOT
            | I_CONCAT
            | I_SIZE
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE ) as name ),
          [],
          _ ),
      Item_t (t, _, _) ) ->
      Lwt.return @@ serialize_ty_for_error ctxt t
      >>=? fun (t, _ctxt) -> fail (Undefined_unop (loc, name, t))
  | (Prim (loc, ((I_UPDATE | I_SLICE) as name), [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 3, stack))
  | (Prim (loc, I_CREATE_CONTRACT, _, _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack))
  | (Prim (loc, I_CREATE_ACCOUNT, [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack))
  | (Prim (loc, I_TRANSFER_TOKENS, [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack))
  | ( Prim
        ( loc,
          ( ( I_DROP
            | I_DUP
            | I_CAR
            | I_CDR
            | I_SOME
            | I_BLAKE2B
            | I_SHA256
            | I_SHA512
            | I_DIP
            | I_IF_NONE
            | I_LEFT
            | I_RIGHT
            | I_IF_LEFT
            | I_IF
            | I_LOOP
            | I_IF_CONS
            | I_IMPLICIT_ACCOUNT
            | I_NEG
            | I_ABS
            | I_INT
            | I_NOT
            | I_HASH_KEY
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE ) as name ),
          _,
          _ ),
      stack ) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 1, stack))
  | ( Prim
        ( loc,
          ( ( I_SWAP
            | I_PAIR
            | I_CONS
            | I_GET
            | I_MEM
            | I_EXEC
            | I_CHECK_SIGNATURE
            | I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_AND
            | I_OR
            | I_XOR
            | I_LSL
            | I_LSR ) as name ),
          _,
          _ ),
      stack ) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 2, stack))
  (* Generic parsing errors *)
  | (expr, _) ->
      fail
      @@ unexpected
           expr
           [Seq_kind]
           Instr_namespace
           [ I_DROP;
             I_DUP;
             I_DIG;
             I_DUG;
             I_SWAP;
             I_SOME;
             I_UNIT;
             I_PAIR;
             I_CAR;
             I_CDR;
             I_CONS;
             I_MEM;
             I_UPDATE;
             I_MAP;
             I_ITER;
             I_GET;
             I_EXEC;
             I_FAILWITH;
             I_SIZE;
             I_CONCAT;
             I_ADD;
             I_SUB;
             I_MUL;
             I_EDIV;
             I_OR;
             I_AND;
             I_XOR;
             I_NOT;
             I_ABS;
             I_INT;
             I_NEG;
             I_LSL;
             I_LSR;
             I_COMPARE;
             I_EQ;
             I_NEQ;
             I_LT;
             I_GT;
             I_LE;
             I_GE;
             I_TRANSFER_TOKENS;
             I_CREATE_ACCOUNT;
             I_CREATE_CONTRACT;
             I_NOW;
             I_AMOUNT;
             I_BALANCE;
             I_IMPLICIT_ACCOUNT;
             I_CHECK_SIGNATURE;
             I_BLAKE2B;
             I_SHA256;
             I_SHA512;
             I_HASH_KEY;
             I_STEPS_TO_QUOTA;
             I_PUSH;
             I_NONE;
             I_LEFT;
             I_RIGHT;
             I_NIL;
             I_EMPTY_SET;
             I_DIP;
             I_LOOP;
             I_IF_NONE;
             I_IF_LEFT;
             I_IF_CONS;
             I_EMPTY_MAP;
             I_IF;
             I_SOURCE;
             I_SENDER;
             I_SELF;
             I_LAMBDA ]

and parse_contract :
    type arg.
    legacy:bool ->
    context ->
    Script.location ->
    arg ty ->
    Contract.t ->
    entrypoint:string ->
    (context * arg typed_contract) tzresult Lwt.t =
 fun ~legacy ctxt loc arg contract ~entrypoint ->
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
  >>=? fun ctxt ->
  Contract.exists ctxt contract
  >>=? function
  | false ->
      fail (Invalid_contract (loc, contract))
  | true -> (
      Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
      >>=? fun ctxt ->
      trace (Invalid_contract (loc, contract))
      @@ Contract.get_script_code ctxt contract
      >>=? fun (ctxt, code) ->
      match code with
      | None ->
          Lwt.return
            ( ty_eq ctxt arg (Unit_t None)
            >>? fun (Eq, ctxt) ->
            match entrypoint with
            | "default" ->
                let contract : arg typed_contract =
                  (arg, (contract, entrypoint))
                in
                ok (ctxt, contract)
            | entrypoint ->
                error (No_such_entrypoint entrypoint) )
      | Some code ->
          Script.force_decode ctxt code
          >>=? fun (code, ctxt) ->
          Lwt.return
            ( parse_toplevel ~legacy:true code
            >>? fun (arg_type, _, _, root_name) ->
            parse_parameter_ty ctxt ~legacy:true arg_type
            >>? fun (Ex_ty targ, ctxt) ->
            let return ctxt targ entrypoint =
              merge_types ~legacy ctxt loc targ arg
              >>? fun (arg, ctxt) ->
              let contract : arg typed_contract =
                (arg, (contract, entrypoint))
              in
              ok (ctxt, contract)
            in
            find_entrypoint_for_type
              ~full:targ
              ~expected:arg
              ~root_name
              entrypoint
              ctxt
            >>? fun (ctxt, entrypoint, targ) ->
            merge_types ~legacy ctxt loc targ arg
            >>? fun (targ, ctxt) -> return ctxt targ entrypoint ) )

(* Same as the one above, but does not fail when the contact is missing or
   if the expected type doesn't match the actual one. In that case None is
   returned and some overapproximation of the typechecking gas is consumed.
   This can still fail on gas exhaustion. *)
and parse_contract_for_script :
    type arg.
    legacy:bool ->
    context ->
    Script.location ->
    arg ty ->
    Contract.t ->
    entrypoint:string ->
    (context * arg typed_contract option) tzresult Lwt.t =
 fun ~legacy ctxt loc arg contract ~entrypoint ->
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
  >>=? fun ctxt ->
  Contract.exists ctxt contract
  >>=? function
  | false ->
      return (ctxt, None)
  | true -> (
      Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
      >>=? fun ctxt ->
      trace (Invalid_contract (loc, contract))
      @@ Contract.get_script_code ctxt contract
      >>=? fun (ctxt, code) ->
      match code with
      (* can only fail because of gas *)
      | None -> (
        match entrypoint with
        | "default" ->
            Lwt.return
              ( match ty_eq ctxt arg (Unit_t None) with
              | Ok (Eq, ctxt) ->
                  let contract : arg typed_contract =
                    (arg, (contract, entrypoint))
                  in
                  ok (ctxt, Some contract)
              | Error _ ->
                  Gas.consume ctxt Typecheck_costs.cycle
                  >>? fun ctxt -> ok (ctxt, None) )
        | _ ->
            return (ctxt, None) )
      | Some code ->
          Script.force_decode ctxt code
          >>=? fun (code, ctxt) ->
          (* can only fail because of gas *)
          Lwt.return
            ( match parse_toplevel ~legacy:true code with
            | Error _ ->
                error (Invalid_contract (loc, contract))
            | Ok (arg_type, _, _, root_name) -> (
              match parse_parameter_ty ctxt ~legacy:true arg_type with
              | Error _ ->
                  error (Invalid_contract (loc, contract))
              | Ok (Ex_ty targ, ctxt) -> (
                match
                  find_entrypoint_for_type
                    ~full:targ
                    ~expected:arg
                    ~root_name
                    entrypoint
                    ctxt
                  >>? fun (ctxt, entrypoint, targ) ->
                  merge_types ~legacy ctxt loc targ arg
                  >>? fun (targ, ctxt) ->
                  merge_types ~legacy ctxt loc targ arg
                  >>? fun (arg, ctxt) ->
                  let contract : arg typed_contract =
                    (arg, (contract, entrypoint))
                  in
                  ok (ctxt, Some contract)
                with
                | Ok res ->
                    ok res
                | Error _ ->
                    (* overapproximation by checking if targ = targ,
                                                       can only fail because of gas *)
                    ty_eq ctxt targ targ
                    >>? fun (Eq, ctxt) ->
                    merge_types ~legacy ctxt loc targ targ
                    >>? fun (_, ctxt) -> ok (ctxt, None) ) ) ) )

and parse_toplevel :
    legacy:bool ->
    Script.expr ->
    (Script.node * Script.node * Script.node * string option) tzresult =
 fun ~legacy toplevel ->
  record_trace (Ill_typed_contract (toplevel, []))
  @@
  match root toplevel with
  | Int (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], Int_kind))
  | String (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], String_kind))
  | Bytes (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], Bytes_kind))
  | Prim (loc, _, _, _) ->
      error (Invalid_kind (loc, [Seq_kind], Prim_kind))
  | Seq (_, fields) -> (
      let rec find_fields p s c fields =
        match fields with
        | [] ->
            ok (p, s, c)
        | Int (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Int_kind))
        | String (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], String_kind))
        | Bytes (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Bytes_kind))
        | Seq (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Seq_kind))
        | Prim (loc, K_parameter, [arg], annot) :: rest -> (
          match p with
          | None ->
              find_fields (Some (arg, loc, annot)) s c rest
          | Some _ ->
              error (Duplicate_field (loc, K_parameter)) )
        | Prim (loc, K_storage, [arg], annot) :: rest -> (
          match s with
          | None ->
              find_fields p (Some (arg, loc, annot)) c rest
          | Some _ ->
              error (Duplicate_field (loc, K_storage)) )
        | Prim (loc, K_code, [arg], annot) :: rest -> (
          match c with
          | None ->
              find_fields p s (Some (arg, loc, annot)) rest
          | Some _ ->
              error (Duplicate_field (loc, K_code)) )
        | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _)
          :: _ ->
            error (Invalid_arity (loc, name, 1, List.length args))
        | Prim (loc, name, _, _) :: _ ->
            let allowed = [K_parameter; K_storage; K_code] in
            error (Invalid_primitive (loc, allowed, name))
      in
      find_fields None None None fields
      >>? function
      | (None, _, _) ->
          error (Missing_field K_parameter)
      | (Some _, None, _) ->
          error (Missing_field K_storage)
      | (Some _, Some _, None) ->
          error (Missing_field K_code)
      | (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot))
        ->
          let maybe_root_name =
            (* root name can be attached to either the parameter
                 primitive or the toplevel constructor *)
            Script_ir_annot.extract_field_annot p
            >>? fun (p, root_name) ->
            match root_name with
            | Some (`Field_annot root_name) ->
                ok (p, pannot, Some root_name)
            | None -> (
              match pannot with
              | [single]
                when Compare.Int.(String.length single > 0)
                     && Compare.Char.(single.[0] = '%') ->
                  ok
                    ( p,
                      [],
                      Some (String.sub single 1 (String.length single - 1)) )
              | _ ->
                  ok (p, pannot, None) )
          in
          if legacy then
            (* legacy semantics ignores spurious annotations *)
            let (p, root_name) =
              match maybe_root_name with
              | Ok (p, _, root_name) ->
                  (p, root_name)
              | Error _ ->
                  (p, None)
            in
            ok (p, s, c, root_name)
          else
            (* only one field annot is allowed to set the root entrypoint name *)
            maybe_root_name
            >>? fun (p, pannot, root_name) ->
            Script_ir_annot.error_unexpected_annot ploc pannot
            >>? fun () ->
            Script_ir_annot.error_unexpected_annot cloc carrot
            >>? fun () ->
            Script_ir_annot.error_unexpected_annot sloc sannot
            >>? fun () -> ok (p, s, c, root_name) )

let parse_script :
    ?type_logger:type_logger ->
    context ->
    legacy:bool ->
    Script.t ->
    (ex_script * context) tzresult Lwt.t =
 fun ?type_logger ctxt ~legacy {code; storage} ->
  Script.force_decode ctxt code
  >>=? fun (code, ctxt) ->
  Script.force_decode ctxt storage
  >>=? fun (storage, ctxt) ->
  Lwt.return @@ parse_toplevel ~legacy code
  >>=? fun (arg_type, storage_type, code_field, root_name) ->
  trace
    (Ill_formed_type (Some "parameter", code, location arg_type))
    (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
  >>=? fun (Ex_ty arg_type, ctxt) ->
  ( if legacy then return ()
  else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
  >>=? fun () ->
  trace
    (Ill_formed_type (Some "storage", code, location storage_type))
    (Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
  >>=? fun (Ex_ty storage_type, ctxt) ->
  let arg_annot =
    default_annot
      (type_to_var_annot (name_of_ty arg_type))
      ~default:default_param_annot
  in
  let storage_annot =
    default_annot
      (type_to_var_annot (name_of_ty storage_type))
      ~default:default_storage_annot
  in
  let arg_type_full =
    Pair_t
      ( (arg_type, None, arg_annot),
        (storage_type, None, storage_annot),
        None,
        has_big_map arg_type || has_big_map storage_type )
  in
  let ret_type_full =
    Pair_t
      ( (List_t (Operation_t None, None, false), None, None),
        (storage_type, None, None),
        None,
        has_big_map storage_type )
  in
  trace_eval
    (fun () ->
      Lwt.return @@ serialize_ty_for_error ctxt storage_type
      >>|? fun (storage_type, _ctxt) ->
      Ill_typed_data (None, storage, storage_type))
    (parse_data ?type_logger ctxt ~legacy storage_type (root storage))
  >>=? fun (storage, ctxt) ->
  trace
    (Ill_typed_contract (code, []))
    (parse_returning
       (Toplevel
          {
            storage_type;
            param_type = arg_type;
            root_name;
            legacy_create_contract_literal = false;
          })
       ctxt
       ~legacy
       ?type_logger
       (arg_type_full, None)
       ret_type_full
       code_field)
  >>=? fun (code, ctxt) ->
  return (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt)

let typecheck_code :
    context -> Script.expr -> (type_map * context) tzresult Lwt.t =
 fun ctxt code ->
  let legacy = false in
  Lwt.return @@ parse_toplevel ~legacy code
  >>=? fun (arg_type, storage_type, code_field, root_name) ->
  let type_map = ref [] in
  trace
    (Ill_formed_type (Some "parameter", code, location arg_type))
    (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
  >>=? fun (Ex_ty arg_type, ctxt) ->
  ( if legacy then return ()
  else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
  >>=? fun () ->
  trace
    (Ill_formed_type (Some "storage", code, location storage_type))
    (Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
  >>=? fun (Ex_ty storage_type, ctxt) ->
  let arg_annot =
    default_annot
      (type_to_var_annot (name_of_ty arg_type))
      ~default:default_param_annot
  in
  let storage_annot =
    default_annot
      (type_to_var_annot (name_of_ty storage_type))
      ~default:default_storage_annot
  in
  let arg_type_full =
    Pair_t
      ( (arg_type, None, arg_annot),
        (storage_type, None, storage_annot),
        None,
        has_big_map arg_type || has_big_map storage_type )
  in
  let ret_type_full =
    Pair_t
      ( (List_t (Operation_t None, None, false), None, None),
        (storage_type, None, None),
        None,
        has_big_map storage_type )
  in
  let result =
    parse_returning
      (Toplevel
         {
           storage_type;
           param_type = arg_type;
           root_name;
           legacy_create_contract_literal = false;
         })
      ctxt
      ~legacy
      ~type_logger:(fun loc bef aft ->
        type_map := (loc, (bef, aft)) :: !type_map)
      (arg_type_full, None)
      ret_type_full
      code_field
  in
  trace (Ill_typed_contract (code, !type_map)) result
  >>=? fun (Lam _, ctxt) -> return (!type_map, ctxt)

let typecheck_data :
    ?type_logger:type_logger ->
    context ->
    Script.expr * Script.expr ->
    context tzresult Lwt.t =
 fun ?type_logger ctxt (data, exp_ty) ->
  let legacy = false in
  trace
    (Ill_formed_type (None, exp_ty, 0))
    (Lwt.return @@ parse_packable_ty ctxt ~legacy (root exp_ty))
  >>=? fun (Ex_ty exp_ty, ctxt) ->
  trace_eval
    (fun () ->
      Lwt.return @@ serialize_ty_for_error ctxt exp_ty
      >>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty))
    (parse_data ?type_logger ctxt ~legacy exp_ty (root data))
  >>=? fun (_, ctxt) -> return ctxt

module Entrypoints_map = Map.Make (String)

let list_entrypoints (type full) (full : full ty) ctxt ~root_name =
  let merge path annot (type t) (ty : t ty) reachable
      ((unreachables, all) as acc) =
    match annot with
    | None | Some (`Field_annot "") -> (
        ok
        @@
        if reachable then acc
        else
          match ty with
          | Union_t _ ->
              acc
          | _ ->
              (List.rev path :: unreachables, all) )
    | Some (`Field_annot name) ->
        if Compare.Int.(String.length name > 31) then
          ok (List.rev path :: unreachables, all)
        else if Entrypoints_map.mem name all then
          ok (List.rev path :: unreachables, all)
        else
          unparse_ty_no_lwt ctxt ty
          >>? fun (unparsed_ty, _) ->
          ok
            ( unreachables,
              Entrypoints_map.add name (List.rev path, unparsed_ty) all )
  in
  let rec fold_tree :
      type t.
      t ty ->
      prim list ->
      bool ->
      prim list list * (prim list * Script.node) Entrypoints_map.t ->
      (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult =
   fun t path reachable acc ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) ->
        merge (D_Left :: path) al tl reachable acc
        >>? fun acc ->
        merge (D_Right :: path) ar tr reachable acc
        >>? fun acc ->
        fold_tree
          tl
          (D_Left :: path)
          (match al with Some _ -> true | None -> reachable)
          acc
        >>? fun acc ->
        fold_tree
          tr
          (D_Right :: path)
          (match ar with Some _ -> true | None -> reachable)
          acc
    | _ ->
        ok acc
  in
  unparse_ty_no_lwt ctxt full
  >>? fun (unparsed_full, _) ->
  let (init, reachable) =
    match root_name with
    | None | Some "" ->
        (Entrypoints_map.empty, false)
    | Some name ->
        (Entrypoints_map.singleton name ([], unparsed_full), true)
  in
  fold_tree full [] reachable ([], init)

(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*)

let rec unparse_data :
    type a.
    context ->
    unparsing_mode ->
    a ty ->
    a ->
    (Script.node * context) tzresult Lwt.t =
 fun ctxt mode ty a ->
  Lwt.return (Gas.consume ctxt Unparse_costs.cycle)
  >>=? fun ctxt ->
  match (ty, a) with
  | (Unit_t _, ()) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.unit)
      >>=? fun ctxt -> return (Prim (-1, D_Unit, [], []), ctxt)
  | (Int_t _, v) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
      >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
  | (Nat_t _, v) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
      >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
  | (String_t _, s) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.string s))
      >>=? fun ctxt -> return (String (-1, s), ctxt)
  | (Bytes_t _, s) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s))
      >>=? fun ctxt -> return (Bytes (-1, s), ctxt)
  | (Bool_t _, true) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.bool)
      >>=? fun ctxt -> return (Prim (-1, D_True, [], []), ctxt)
  | (Bool_t _, false) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.bool)
      >>=? fun ctxt -> return (Prim (-1, D_False, [], []), ctxt)
  | (Timestamp_t _, t) -> (
      Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t))
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          return (Int (-1, Script_timestamp.to_zint t), ctxt)
      | Readable -> (
        match Script_timestamp.to_notation t with
        | None ->
            return (Int (-1, Script_timestamp.to_zint t), ctxt)
        | Some s ->
            return (String (-1, s), ctxt) ) )
  | (Address_t _, (c, entrypoint)) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.contract)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let entrypoint =
            match entrypoint with "default" -> "" | name -> name
          in
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Data_encoding.(tup2 Contract.encoding Variable.string)
              (c, entrypoint)
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          let notation =
            match entrypoint with
            | "default" ->
                Contract.to_b58check c
            | entrypoint ->
                Contract.to_b58check c ^ "%" ^ entrypoint
          in
          return (String (-1, notation), ctxt) )
  | (Contract_t _, (_, (c, entrypoint))) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.contract)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let entrypoint =
            match entrypoint with "default" -> "" | name -> name
          in
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Data_encoding.(tup2 Contract.encoding Variable.string)
              (c, entrypoint)
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          let notation =
            match entrypoint with
            | "default" ->
                Contract.to_b58check c
            | entrypoint ->
                Contract.to_b58check c ^ "%" ^ entrypoint
          in
          return (String (-1, notation), ctxt) )
  | (Signature_t _, s) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.signature)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.to_b58check s), ctxt) )
  | (Mutez_t _, v) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.tez)
      >>=? fun ctxt -> return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
  | (Key_t _, k) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.key)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes =
            Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.Public_key.to_b58check k), ctxt) )
  | (Key_hash_t _, k) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.key_hash)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Signature.Public_key_hash.encoding
              k
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) )
  | (Operation_t _, (op, _big_map_diff)) ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn
          Operation.internal_operation_encoding
          op
      in
      Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes))
      >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
  | (Chain_id_t _, chain_id) ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id
      in
      Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes))
      >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
  | (Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r)) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.pair)
      >>=? fun ctxt ->
      unparse_data ctxt mode tl l
      >>=? fun (l, ctxt) ->
      unparse_data ctxt mode tr r
      >>=? fun (r, ctxt) -> return (Prim (-1, D_Pair, [l; r], []), ctxt)
  | (Union_t ((tl, _), _, _, _), L l) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.union)
      >>=? fun ctxt ->
      unparse_data ctxt mode tl l
      >>=? fun (l, ctxt) -> return (Prim (-1, D_Left, [l], []), ctxt)
  | (Union_t (_, (tr, _), _, _), R r) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.union)
      >>=? fun ctxt ->
      unparse_data ctxt mode tr r
      >>=? fun (r, ctxt) -> return (Prim (-1, D_Right, [r], []), ctxt)
  | (Option_t (t, _, _), Some v) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.some)
      >>=? fun ctxt ->
      unparse_data ctxt mode t v
      >>=? fun (v, ctxt) -> return (Prim (-1, D_Some, [v], []), ctxt)
  | (Option_t _, None) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.none)
      >>=? fun ctxt -> return (Prim (-1, D_None, [], []), ctxt)
  | (List_t (t, _, _), items) ->
      fold_left_s
        (fun (l, ctxt) element ->
          Lwt.return (Gas.consume ctxt Unparse_costs.list_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode t element
          >>=? fun (unparsed, ctxt) -> return (unparsed :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      return (Micheline.Seq (-1, List.rev items), ctxt)
  | (Set_t (t, _), set) ->
      let t = ty_of_comparable_ty t in
      fold_left_s
        (fun (l, ctxt) item ->
          Lwt.return (Gas.consume ctxt Unparse_costs.set_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode t item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        (set_fold (fun e acc -> e :: acc) set [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Map_t (kt, vt, _, _), map) ->
      let kt = ty_of_comparable_ty kt in
      fold_left_s
        (fun (l, ctxt) (k, v) ->
          Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode kt k
          >>=? fun (key, ctxt) ->
          unparse_data ctxt mode vt v
          >>=? fun (value, ctxt) ->
          return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
        ([], ctxt)
        (map_fold (fun k v acc -> (k, v) :: acc) map [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Big_map_t (kt, vt, _), {id = None; diff = (module Diff); _}) ->
      (* this branch is to allow roundtrip of big map literals *)
      let kt = ty_of_comparable_ty kt in
      fold_left_s
        (fun (l, ctxt) (k, v) ->
          Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode kt k
          >>=? fun (key, ctxt) ->
          unparse_data ctxt mode vt v
          >>=? fun (value, ctxt) ->
          return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
        ([], ctxt)
        (Diff.OPS.fold
           (fun k v acc ->
             match v with None -> acc | Some v -> (k, v) :: acc)
           (fst Diff.boxed)
           [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Big_map_t (_kt, _kv, _), {id = Some id; diff = (module Diff); _}) ->
      if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then
        return (Micheline.Int (-1, id), ctxt)
      else
        (* this can only be the result of an execution and the map
             must have been flushed at this point *)
        assert false
  | (Lambda_t _, Lam (_, original_code)) ->
      unparse_code ctxt mode original_code

(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
and unparse_code ctxt mode =
  let legacy = true in
  function
  | Prim (loc, I_PUSH, [ty; data], annot) ->
      Lwt.return (parse_packable_ty ctxt ~legacy ty)
      >>=? fun (Ex_ty t, ctxt) ->
      parse_data ctxt ~legacy t data
      >>=? fun (data, ctxt) ->
      unparse_data ctxt mode t data
      >>=? fun (data, ctxt) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot))
      >>=? fun ctxt -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)
  | Seq (loc, items) ->
      fold_left_s
        (fun (l, ctxt) item ->
          unparse_code ctxt mode item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      Lwt.return
        (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items)))
      >>=? fun ctxt -> return (Micheline.Seq (loc, List.rev items), ctxt)
  | Prim (loc, prim, items, annot) ->
      fold_left_s
        (fun (l, ctxt) item ->
          unparse_code ctxt mode item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot))
      >>=? fun ctxt -> return (Prim (loc, prim, List.rev items, annot), ctxt)
  | (Int _ | String _ | Bytes _) as atom ->
      return (atom, ctxt)

(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
let unparse_script ctxt mode {code; arg_type; storage; storage_type; root_name}
    =
  let (Lam (_, original_code)) = code in
  unparse_code ctxt mode original_code
  >>=? fun (code, ctxt) ->
  unparse_data ctxt mode storage_type storage
  >>=? fun (storage, ctxt) ->
  unparse_ty ctxt arg_type
  >>=? fun (arg_type, ctxt) ->
  unparse_ty ctxt storage_type
  >>=? fun (storage_type, ctxt) ->
  let arg_type =
    add_field_annot
      (Option.map ~f:(fun n -> `Field_annot n) root_name)
      None
      arg_type
  in
  let open Micheline in
  let code =
    Seq
      ( -1,
        [ Prim (-1, K_parameter, [arg_type], []);
          Prim (-1, K_storage, [storage_type], []);
          Prim (-1, K_code, [code], []) ] )
  in
  Lwt.return
    ( Gas.consume ctxt (Unparse_costs.seq_cost 3)
    >>? fun ctxt ->
    Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
    >>? fun ctxt ->
    Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
    >>? fun ctxt -> Gas.consume ctxt (Unparse_costs.prim_cost 1 []) )
  >>=? fun ctxt ->
  return
    ( {
        code = lazy_expr (strip_locations code);
        storage = lazy_expr (strip_locations storage);
      },
      ctxt )

let pack_data ctxt typ data =
  unparse_data ctxt Optimized typ data
  >>=? fun (unparsed, ctxt) ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      expr_encoding
      (Micheline.strip_locations unparsed)
  in
  Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
  >>=? fun ctxt ->
  let bytes = MBytes.concat "" [MBytes.of_string "\005"; bytes] in
  Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
  >>=? fun ctxt -> return (bytes, ctxt)

let hash_data ctxt typ data =
  pack_data ctxt typ data
  >>=? fun (bytes, ctxt) ->
  Lwt.return
  @@ Gas.consume
       ctxt
       (Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size)
  >>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [bytes]), ctxt)

(* ---------------- Big map -------------------------------------------------*)

let empty_big_map tk tv =
  {
    id = None;
    diff = empty_map tk;
    key_type = ty_of_comparable_ty tk;
    value_type = tv;
  }

let big_map_mem ctxt key {id; diff; key_type; _} =
  match (map_get key diff, id) with
  | (None, None) ->
      return (false, ctxt)
  | (None, Some id) ->
      hash_data ctxt key_type key
      >>=? fun (hash, ctxt) ->
      Alpha_context.Big_map.mem ctxt id hash
      >>=? fun (ctxt, res) -> return (res, ctxt)
  | (Some None, _) ->
      return (false, ctxt)
  | (Some (Some _), _) ->
      return (true, ctxt)

let big_map_get ctxt key {id; diff; key_type; value_type} =
  match (map_get key diff, id) with
  | (Some x, _) ->
      return (x, ctxt)
  | (None, None) ->
      return (None, ctxt)
  | (None, Some id) -> (
      hash_data ctxt key_type key
      >>=? fun (hash, ctxt) ->
      Alpha_context.Big_map.get_opt ctxt id hash
      >>=? function
      | (ctxt, None) ->
          return (None, ctxt)
      | (ctxt, Some value) ->
          parse_data ctxt ~legacy:true value_type (Micheline.root value)
          >>=? fun (x, ctxt) -> return (Some x, ctxt) )

let big_map_update key value ({diff; _} as map) =
  {map with diff = map_set key value diff}

module Ids = Set.Make (Compare.Z)

type big_map_ids = Ids.t

let no_big_map_id = Ids.empty

let diff_of_big_map ctxt fresh mode ~ids {id; key_type; value_type; diff} =
  Lwt.return
    (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff))
  >>=? fun ctxt ->
  ( match id with
  | Some id ->
      if Ids.mem id ids then
        fresh ctxt
        >>=? fun (ctxt, duplicate) ->
        return (ctxt, [Contract.Copy (id, duplicate)], duplicate)
      else
        (* The first occurence encountered of a big_map reuses the
             ID. This way, the payer is only charged for the diff.
             For this to work, this diff has to be put at the end of
             the global diff, otherwise the duplicates will use the
             updated version as a base. This is true because we add
             this diff first in the accumulator of
             `extract_big_map_updates`, and this accumulator is not
             reversed before being flattened. *)
        return (ctxt, [], id)
  | None ->
      fresh ctxt
      >>=? fun (ctxt, id) ->
      unparse_ty ctxt key_type
      >>=? fun (kt, ctxt) ->
      unparse_ty ctxt value_type
      >>=? fun (kv, ctxt) ->
      return
        ( ctxt,
          [ Contract.Alloc
              {
                big_map = id;
                key_type = Micheline.strip_locations kt;
                value_type = Micheline.strip_locations kv;
              } ],
          id ) )
  >>=? fun (ctxt, init, big_map) ->
  let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
  fold_left_s
    (fun (acc, ctxt) (key, value) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      hash_data ctxt key_type key
      >>=? fun (diff_key_hash, ctxt) ->
      unparse_data ctxt mode key_type key
      >>=? fun (key_node, ctxt) ->
      let diff_key = Micheline.strip_locations key_node in
      ( match value with
      | None ->
          return (None, ctxt)
      | Some x ->
          unparse_data ctxt mode value_type x
          >>=? fun (node, ctxt) ->
          return (Some (Micheline.strip_locations node), ctxt) )
      >>=? fun (diff_value, ctxt) ->
      let diff_item =
        Contract.Update {big_map; diff_key; diff_key_hash; diff_value}
      in
      return (diff_item :: acc, ctxt))
    ([], ctxt)
    pairs
  >>=? fun (diff, ctxt) -> return (init @ diff, big_map, ctxt)

let rec extract_big_map_updates :
    type a.
    context ->
    (context -> (context * Big_map.id) tzresult Lwt.t) ->
    unparsing_mode ->
    Ids.t ->
    Contract.big_map_diff list ->
    a ty ->
    a ->
    (context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t =
 fun ctxt fresh mode ids acc ty x ->
  match (ty, x) with
  | (Big_map_t (_, _, _), map) ->
      diff_of_big_map ctxt fresh mode ids map
      >>=? fun (diff, id, ctxt) ->
      let (module Map) = map.diff in
      let map = {map with diff = empty_map Map.key_ty; id = Some id} in
      return (ctxt, map, Ids.add id ids, diff :: acc)
  | (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc tyl xl
      >>=? fun (ctxt, xl, ids, acc) ->
      extract_big_map_updates ctxt fresh mode ids acc tyr xr
      >>=? fun (ctxt, xr, ids, acc) -> return (ctxt, (xl, xr), ids, acc)
  | (Union_t ((ty, _), (_, _), _, true), L x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, L x, ids, acc)
  | (Union_t ((_, _), (ty, _), _, true), R x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, R x, ids, acc)
  | (Option_t (ty, _, true), Some x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, Some x, ids, acc)
  | (List_t (ty, _, true), l) ->
      fold_left_s
        (fun (ctxt, l, ids, acc) x ->
          Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
          >>=? fun ctxt ->
          extract_big_map_updates ctxt fresh mode ids acc ty x
          >>=? fun (ctxt, x, ids, acc) -> return (ctxt, x :: l, ids, acc))
        (ctxt, [], ids, acc)
        l
      >>=? fun (ctxt, l, ids, acc) -> return (ctxt, List.rev l, ids, acc)
  | (Map_t (_, ty, _, true), ((module M) as m)) ->
      Lwt.return
        (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m))
      >>=? fun ctxt ->
      fold_left_s
        (fun (ctxt, m, ids, acc) (k, x) ->
          Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
          >>=? fun ctxt ->
          extract_big_map_updates ctxt fresh mode ids acc ty x
          >>=? fun (ctxt, x, ids, acc) ->
          return (ctxt, M.OPS.add k x m, ids, acc))
        (ctxt, M.OPS.empty, ids, acc)
        (M.OPS.bindings (fst M.boxed))
      >>=? fun (ctxt, m, ids, acc) ->
      let module M = struct
        module OPS = M.OPS

        type key = M.key

        type value = M.value

        let key_ty = M.key_ty

        let boxed = (m, snd M.boxed)
      end in
      return
        ( ctxt,
          (module M : Boxed_map with type key = M.key and type value = M.value),
          ids,
          acc )
  | (Option_t (_, _, true), None) ->
      return (ctxt, None, ids, acc)
  | (List_t (_, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Map_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Option_t (_, _, false), None) ->
      return (ctxt, None, ids, acc)
  | (Pair_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Union_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Option_t (_, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Chain_id_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Set_t (_, _), v) ->
      return (ctxt, v, ids, acc)
  | (Unit_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Int_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Nat_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Signature_t _, v) ->
      return (ctxt, v, ids, acc)
  | (String_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Bytes_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Mutez_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Key_hash_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Key_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Timestamp_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Address_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Bool_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Lambda_t (_, _, _), v) ->
      return (ctxt, v, ids, acc)
  | (Contract_t (_, _), v) ->
      return (ctxt, v, ids, acc)
  | (Operation_t _, _) ->
      assert false

(* called only on parameters and storage, which cannot contain operations *)

let collect_big_maps ctxt ty x =
  let rec collect :
      type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult =
   fun ctxt ty x acc ->
    match (ty, x) with
    | (Big_map_t (_, _, _), {id = Some id}) ->
        Gas.consume ctxt Typecheck_costs.cycle
        >>? fun ctxt -> ok (Ids.add id acc, ctxt)
    | (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
        collect ctxt tyl xl acc >>? fun (acc, ctxt) -> collect ctxt tyr xr acc
    | (Union_t ((ty, _), (_, _), _, true), L x) ->
        collect ctxt ty x acc
    | (Union_t ((_, _), (ty, _), _, true), R x) ->
        collect ctxt ty x acc
    | (Option_t (ty, _, true), Some x) ->
        collect ctxt ty x acc
    | (List_t (ty, _, true), l) ->
        List.fold_left
          (fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc)
          (ok (acc, ctxt))
          l
    | (Map_t (_, ty, _, true), m) ->
        map_fold
          (fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc)
          m
          (ok (acc, ctxt))
    | (List_t (_, _, false), _) ->
        ok (acc, ctxt)
    | (Map_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Big_map_t (_, _, _), {id = None}) ->
        ok (acc, ctxt)
    | (Option_t (_, _, true), None) ->
        ok (acc, ctxt)
    | (Option_t (_, _, false), _) ->
        ok (acc, ctxt)
    | (Union_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Pair_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Chain_id_t _, _) ->
        ok (acc, ctxt)
    | (Set_t (_, _), _) ->
        ok (acc, ctxt)
    | (Unit_t _, _) ->
        ok (acc, ctxt)
    | (Int_t _, _) ->
        ok (acc, ctxt)
    | (Nat_t _, _) ->
        ok (acc, ctxt)
    | (Signature_t _, _) ->
        ok (acc, ctxt)
    | (String_t _, _) ->
        ok (acc, ctxt)
    | (Bytes_t _, _) ->
        ok (acc, ctxt)
    | (Mutez_t _, _) ->
        ok (acc, ctxt)
    | (Key_hash_t _, _) ->
        ok (acc, ctxt)
    | (Key_t _, _) ->
        ok (acc, ctxt)
    | (Timestamp_t _, _) ->
        ok (acc, ctxt)
    | (Address_t _, _) ->
        ok (acc, ctxt)
    | (Bool_t _, _) ->
        ok (acc, ctxt)
    | (Lambda_t (_, _, _), _) ->
        ok (acc, ctxt)
    | (Contract_t (_, _), _) ->
        ok (acc, ctxt)
    | (Operation_t _, _) ->
        assert false
   (* called only on parameters and storage, which cannot contain operations *)
  in
  Lwt.return (collect ctxt ty x no_big_map_id)

let extract_big_map_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v =
  let to_duplicate = Ids.diff to_duplicate to_update in
  let fresh =
    if temporary then fun c -> return (Big_map.fresh_temporary c)
    else Big_map.fresh
  in
  extract_big_map_updates ctxt fresh mode to_duplicate [] ty v
  >>=? fun (ctxt, v, alive, diffs) ->
  let diffs =
    if temporary then diffs
    else
      let dead = Ids.diff to_update alive in
      Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs
  in
  match diffs with
  | [] ->
      return (v, None, ctxt)
  | diffs ->
      return (v, Some (List.flatten diffs (* do not reverse *)), ctxt)

let list_of_big_map_ids ids = Ids.elements ids
src/proto_alpha/lib_protocol/script_ir_translator.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_protocol_environment_alpha__Environment.Micheline.

Import Tezos_raw_protocol_alpha.Alpha_context.Script.

Import Tezos_raw_protocol_alpha.Script_typed_ir.

Import Tezos_raw_protocol_alpha.Script_tc_errors.

Import Tezos_raw_protocol_alpha.Script_ir_annot.

Inductive ex_comparable_ty : Type :=
| Ex_comparable_ty : forall {a : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) -> ex_comparable_ty.

Inductive ex_ty : Type :=
| Ex_ty : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
  ex_ty.

Inductive ex_stack_ty : Type :=
| Ex_stack_ty : forall {a : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) -> ex_stack_ty.

Inductive tc_context : Type :=
| Lambda : tc_context
| Dip : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
  -> tc_context -> tc_context
| Toplevel : forall {param sto : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty sto) ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty param) -> (option string) -> bool
  -> tc_context.

Inductive unparsing_mode : Type :=
| Optimized : unparsing_mode
| Readable : unparsing_mode.

Definition type_logger :=
  Z ->
    (list
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) ->
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) -> unit.

Definition add_dip {A : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (prev : tc_context) : tc_context :=
  match prev with
  | Lambda | Toplevel _ => Dip (Item_t ty Empty_t annot) prev
  | Dip stack _ => Dip (Item_t ty stack annot) prev
  end.

Fixpoint comparable_type_size {a t : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct t a) : Z :=
  match ty with
  | Int_key _ => 1
  | Nat_key _ => 1
  | String_key _ => 1
  | Bytes_key _ => 1
  | Mutez_key _ => 1
  | Bool_key _ => 1
  | Key_hash_key _ => 1
  | Timestamp_key _ => 1
  | Address_key _ => 1
  | Pair_key _ (t, _) _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
      (comparable_type_size t)
  end.

Fixpoint type_size {t : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) : Z :=
  match ty with
  | Unit_t _ => 1
  | Int_t _ => 1
  | Nat_t _ => 1
  | Signature_t _ => 1
  | Bytes_t _ => 1
  | String_t _ => 1
  | Mutez_t _ => 1
  | Key_hash_t _ => 1
  | Key_t _ => 1
  | Timestamp_t _ => 1
  | Address_t _ => 1
  | Bool_t _ => 1
  | Operation_t _ => 1
  | Pair_t (l, _, _) (r, _, _) _ _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
        (type_size l)) (type_size r)
  | Union_t (l, _) (r, _) _ _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
        (type_size l)) (type_size r)
  | Lambda_t arg ret _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
        (type_size arg)) (type_size ret)
  | Option_t t _ _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
      (type_size t)
  | List_t t _ _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
      (type_size t)
  | Set_t k _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
      (comparable_type_size k)
  | Map_t k v _ _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
        (comparable_type_size k)) (type_size v)
  | Big_map_t k v _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
        (comparable_type_size k)) (type_size v)
  | Contract_t arg _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
      (type_size arg)
  | Chain_id_t _ => 1
  end.

Fixpoint type_size_of_stack_head {st : Type}
  (stack : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty st) (up_to : Z)
  : Z :=
  match stack with
  | Empty_t => 0
  | Item_t head tail _annot =>
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        up_to 0 then
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
        (type_size head)
        (type_size_of_stack_head tail
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
            up_to 1))
    else
      0
  end.

Definition number_of_generated_growing_types {a b : Type}
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.instr b a)
  : Z :=
  match function_parameter with
  | Drop => 0
  | Dup => 0
  | Swap => 0
  | Const _ => 1
  | Cons_pair => 1
  | Car => 0
  | Cdr => 0
  | Cons_some => 1
  | Cons_none _ => 1
  | If_none _ _ => 0
  | Left => 0
  | Right => 0
  | If_left _ _ => 0
  | Cons_list => 1
  | Nil => 1
  | If_cons _ _ => 0
  | List_map _ => 1
  | List_size => 0
  | List_iter _ => 1
  | Empty_set _ => 1
  | Set_iter _ => 0
  | Set_mem => 0
  | Set_update => 0
  | Set_size => 0
  | Empty_map _ _ => 1
  | Map_map _ => 1
  | Map_iter _ => 1
  | Map_mem => 0
  | Map_get => 0
  | Map_update => 0
  | Map_size => 0
  | Empty_big_map _ _ => 1
  | Big_map_get => 0
  | Big_map_update => 0
  | Big_map_mem => 0
  | Concat_string => 0
  | Concat_string_pair => 0
  | Slice_string => 0
  | String_size => 0
  | Concat_bytes => 0
  | Concat_bytes_pair => 0
  | Slice_bytes => 0
  | Bytes_size => 0
  | Add_seconds_to_timestamp => 0
  | Add_timestamp_to_seconds => 0
  | Sub_timestamp_seconds => 0
  | Diff_timestamps => 0
  | Add_tez => 0
  | Sub_tez => 0
  | Mul_teznat => 0
  | Mul_nattez => 0
  | Ediv_teznat => 0
  | Ediv_tez => 0
  | Or => 0
  | And => 0
  | Xor => 0
  | Not => 0
  | Is_nat => 0
  | Neg_nat => 0
  | Neg_int => 0
  | Abs_int => 0
  | Int_nat => 0
  | Add_intint => 0
  | Add_intnat => 0
  | Add_natint => 0
  | Add_natnat => 0
  | Sub_int => 0
  | Mul_intint => 0
  | Mul_intnat => 0
  | Mul_natint => 0
  | Mul_natnat => 0
  | Ediv_intint => 0
  | Ediv_intnat => 0
  | Ediv_natint => 0
  | Ediv_natnat => 0
  | Lsl_nat => 0
  | Lsr_nat => 0
  | Or_nat => 0
  | And_nat => 0
  | And_int_nat => 0
  | Xor_nat => 0
  | Not_nat => 0
  | Not_int => 0
  | Seq _ _ => 0
  | If _ _ => 0
  | Loop _ => 0
  | Loop_left _ => 0
  | Dip _ => 0
  | Exec => 0
  | Apply _ => 0
  | Lambda _ => 1
  | Failwith _ => 1
  | Nop => 0
  | Compare _ => 1
  | Eq => 0
  | Neq => 0
  | Lt => 0
  | Gt => 0
  | Le => 0
  | Ge => 0
  | Address => 0
  | Contract _ _ => 1
  | Transfer_tokens => 1
  | Create_account => 0
  | Implicit_account => 0
  | Create_contract _ _ _ _ => 1
  | Create_contract_2 _ _ _ _ => 1
  | Now => 0
  | Balance => 0
  | Check_signature => 0
  | Hash_key => 0
  | Blake2b => 0
  | Sha256 => 0
  | Sha512 => 0
  | Steps_to_quota => 0
  | Source => 0
  | Sender => 0
  | Self _ _ => 1
  | Amount => 0
  | Set_delegate => 0
  | Pack _ => 0
  | Unpack _ => 1
  | Dig _ _ => 0
  | Dug _ _ => 0
  | Dipn _ _ _ => 0
  | Dropn _ _ => 0
  | ChainId => 0
  end.

Definition location {A B : Type}
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node A B) : A :=
  match function_parameter with
  | Prim loc _ _ _ | Int loc _ | String loc _ | Bytes loc _ | Seq loc _ => loc
  end.

Definition kind {A B : Type}
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_raw_protocol_alpha.Script_tc_errors.kind :=
  match function_parameter with
  | Int _ _ => Int_kind
  | String _ _ => String_kind
  | Bytes _ _ => Bytes_kind
  | Prim _ _ _ _ => Prim_kind
  | Seq _ _ => Seq_kind
  end.

Definition namespace
  (function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_raw_protocol_alpha.Script_tc_errors.namespace :=
  match function_parameter with
  | K_parameter | K_storage | K_code => Keyword_namespace
  |
    D_False | D_Elt | D_Left | D_None | D_Pair | D_Right | D_Some | D_True |
      D_Unit => Constant_namespace
  |
    I_PACK | I_UNPACK | I_BLAKE2B | I_SHA256 | I_SHA512 | I_ABS | I_ADD |
      I_AMOUNT | I_AND | I_BALANCE | I_CAR | I_CDR | I_CHAIN_ID |
      I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT | I_CONS | I_CREATE_ACCOUNT |
      I_CREATE_CONTRACT | I_IMPLICIT_ACCOUNT | I_DIP | I_DROP | I_DUP | I_EDIV |
      I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC | I_APPLY |
      I_FAILWITH | I_GE | I_GET | I_GT | I_HASH_KEY | I_IF | I_IF_CONS |
      I_IF_LEFT | I_IF_NONE | I_INT | I_LAMBDA | I_LE | I_LEFT | I_LOOP | I_LSL
      | I_LSR | I_LT | I_MAP | I_MEM | I_MUL | I_NEG | I_NEQ | I_NIL | I_NONE |
      I_NOT | I_NOW | I_OR | I_PAIR | I_PUSH | I_RIGHT | I_SIZE | I_SOME |
      I_SOURCE | I_SENDER | I_SELF | I_SLICE | I_STEPS_TO_QUOTA | I_SUB | I_SWAP
      | I_TRANSFER_TOKENS | I_SET_DELEGATE | I_UNIT | I_UPDATE | I_XOR | I_ITER
      | I_LOOP_LEFT | I_ADDRESS | I_CONTRACT | I_ISNAT | I_CAST | I_RENAME |
      I_DIG | I_DUG => Instr_namespace
  |
    T_bool | T_contract | T_int | T_key | T_key_hash | T_lambda | T_list | T_map
      | T_big_map | T_nat | T_option | T_or | T_pair | T_set | T_signature |
      T_string | T_bytes | T_mutez | T_timestamp | T_unit | T_operation |
      T_address | T_chain_id => Type_namespace
  end.

Definition unexpected
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.node
      Tezos_raw_protocol_alpha.Alpha_context.Script.location
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  (exp_kinds : list Tezos_raw_protocol_alpha.Script_tc_errors.kind)
  (exp_ns : Tezos_raw_protocol_alpha.Script_tc_errors.namespace)
  (exp_prims : list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
  match expr with
  | Int loc _ => Invalid_kind loc (cons Prim_kind exp_kinds) Int_kind
  | String loc _ => Invalid_kind loc (cons Prim_kind exp_kinds) String_kind
  | Bytes loc _ => Invalid_kind loc (cons Prim_kind exp_kinds) Bytes_kind
  | Seq loc _ => Invalid_kind loc (cons Prim_kind exp_kinds) Seq_kind
  | Prim loc name _ _ =>
    match ((namespace name), exp_ns) with
    |
      (Type_namespace, Type_namespace) | (Instr_namespace, Instr_namespace) |
        (Constant_namespace, Constant_namespace) =>
      Invalid_primitive loc exp_prims name
    | (ns, _) => Invalid_namespace loc name exp_ns ns
    end
  end.

Definition check_kind {A : Type}
  (kinds : list Tezos_raw_protocol_alpha.Script_tc_errors.kind)
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.node
      Tezos_raw_protocol_alpha.Alpha_context.Script.location A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let kind := kind expr in
  if Tezos_protocol_environment_alpha__Environment.List.mem kind kinds then
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  else
    let loc := location expr in
    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
      (Invalid_kind loc kinds kind).

Definition wrap_compare {A B : Type}
  (compare :
    A ->
      B ->
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (a : A) (b : B) : Z :=
  let res := compare a b in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
      res 0 then
    0
  else
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        res 0 then
      1
    else
      (-1).

Fixpoint compare_comparable {a s : Type}
  (kind : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
  : a -> a -> Z :=
  match kind with
  | String_key _ =>
    wrap_compare
      Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
  | Bool_key _ =>
    wrap_compare
      Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
  | Mutez_key _ =>
    wrap_compare Tezos_raw_protocol_alpha.Alpha_context.Tez.compare
  | Key_hash_key _ =>
    wrap_compare
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.compare
  | Int_key _ =>
    wrap_compare Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare
  | Nat_key _ =>
    wrap_compare Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare
  | Timestamp_key _ =>
    wrap_compare Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.compare
  | Address_key _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      wrap_compare
      (fun function_parameter =>
        match function_parameter with
        | (x, ex) =>
          fun function_parameter =>
            match function_parameter with
            | (y, ey) =>
              let lres :=
                Tezos_raw_protocol_alpha.Alpha_context.Contract.compare x y in
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  lres 0 then
                Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
                  ex ey
              else
                lres
            end
        end)
  | Bytes_key _ =>
    wrap_compare Tezos_protocol_environment_alpha__Environment.MBytes.compare
  | Pair_key (tl, _) (tr, _) _ =>
    fun function_parameter =>
      match function_parameter with
      | (lx, rx) =>
        fun function_parameter =>
          match function_parameter with
          | (ly, ry) =>
            let lres := compare_comparable tl lx ly in
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                lres 0 then
              compare_comparable tr rx ry
            else
              lres
          end
      end
  end.

Definition empty_set {a : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
  : Tezos_raw_protocol_alpha.Script_typed_ir.set a :=
  let OPS := unsupported_functor_application in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty := ty;
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS := OPS;
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed := OPS.empty;
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size := 0
      |}.

Definition set_update {a : Type}
  (v : a) (b : bool) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set a)
  : Tezos_raw_protocol_alpha.Script_typed_ir.set a :=
  let Box := projT2 Box in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed :=
        if b then
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.add)
            v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed)
        else
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.remove)
            v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size :=
        let mem :=
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
            v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed) in
        if mem then
          if b then
            Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)
          else
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
              Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size) 1
        else
          if b then
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
              Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size) 1
          else
            Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)
      |}.

Definition set_mem {elt : Type}
  (v : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt) : bool :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
    v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed).

Definition set_fold {acc elt : Type}
  (f : elt -> acc -> acc)
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt) : acc -> acc :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.fold)
    f Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed).

Definition set_size {elt : Type}
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
  : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
    Tezos_raw_protocol_alpha.Alpha_context.Script_int.n :=
  let Box := projT2 Box in
  Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int
      Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)).

Definition map_key_ty {a b : Type}
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
  : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty).

Definition empty_map {a b : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
  : Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
  let OPS := unsupported_functor_application in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty := ty;
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS := OPS
      |}.

Definition map_get {key value : Type}
  (k : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
  : option value :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.find_opt)
    k
    (Tezos_protocol_environment_alpha__Environment.Pervasives.fst
      Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).

Definition map_update {a b : Type}
  (k : a) (v : option b)
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
  : Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
  let Box := projT2 Box in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed :=
        match Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)
          with
        | (map, size) =>
          let contains :=
            Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
              k map in
          match v with
          | Some v =>
            ((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
              k v map),
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                size
                (if contains then
                  0
                else
                  1)))
          | None =>
            ((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.remove)
              k map),
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                size
                (if contains then
                  1
                else
                  0)))
          end
        end
      |}.

Definition map_set {a b : Type}
  (k : a) (v : b) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
  : Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
  let Box := projT2 Box in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed :=
        match Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)
          with
        | (map, size) =>
          ((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
            k v map),
            (if
              Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
                k map then
              size
            else
              Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                size 1))
        end
      |}.

Definition map_mem {key value : Type}
  (k : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
  : bool :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
    k
    (Tezos_protocol_environment_alpha__Environment.Pervasives.fst
      Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).

Definition map_fold {acc key value : Type}
  (f : key -> value -> acc -> acc)
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value) : acc -> acc :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.fold)
    f
    (Tezos_protocol_environment_alpha__Environment.Pervasives.fst
      Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).

Definition map_size {key value : Type}
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
  : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
    Tezos_raw_protocol_alpha.Alpha_context.Script_int.n :=
  let Box := projT2 Box in
  Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_int
      (Tezos_protocol_environment_alpha__Environment.Pervasives.snd
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))).

Fixpoint ty_of_comparable_ty {a s : Type}
  (function_parameter :
    Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
  : Tezos_raw_protocol_alpha.Script_typed_ir.ty a :=
  match function_parameter with
  | Int_key tname => Int_t tname
  | Nat_key tname => Nat_t tname
  | String_key tname => String_t tname
  | Bytes_key tname => Bytes_t tname
  | Mutez_key tname => Mutez_t tname
  | Bool_key tname => Bool_t tname
  | Key_hash_key tname => Key_hash_t tname
  | Timestamp_key tname => Timestamp_t tname
  | Address_key tname => Address_t tname
  | Pair_key (l, al) (r, ar) tname =>
    Pair_t ((ty_of_comparable_ty l), al, None)
      ((ty_of_comparable_ty r), ar, None) tname false
  end.

Fixpoint comparable_ty_of_ty {a : Type}
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  : option (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) :=
  match function_parameter with
  | Int_t tname => Some (Int_key tname)
  | Nat_t tname => Some (Nat_key tname)
  | String_t tname => Some (String_key tname)
  | Bytes_t tname => Some (Bytes_key tname)
  | Mutez_t tname => Some (Mutez_key tname)
  | Bool_t tname => Some (Bool_key tname)
  | Key_hash_t tname => Some (Key_hash_key tname)
  | Timestamp_t tname => Some (Timestamp_key tname)
  | Address_t tname => Some (Address_key tname)
  | Pair_t (l, al, _) (r, ar, _) pname _ =>
    match comparable_ty_of_ty r with
    | None => None
    | Some rty =>
      match comparable_ty_of_ty l with
      | None => None
      | Some (Pair_key _ _ _) => None
      | Some (Int_key tname) =>
        Some (Pair_key ((Int_key tname), al) (rty, ar) pname)
      | Some (Nat_key tname) =>
        Some (Pair_key ((Nat_key tname), al) (rty, ar) pname)
      | Some (String_key tname) =>
        Some (Pair_key ((String_key tname), al) (rty, ar) pname)
      | Some (Bytes_key tname) =>
        Some (Pair_key ((Bytes_key tname), al) (rty, ar) pname)
      | Some (Mutez_key tname) =>
        Some (Pair_key ((Mutez_key tname), al) (rty, ar) pname)
      | Some (Bool_key tname) =>
        Some (Pair_key ((Bool_key tname), al) (rty, ar) pname)
      | Some (Key_hash_key tname) =>
        Some (Pair_key ((Key_hash_key tname), al) (rty, ar) pname)
      | Some (Timestamp_key tname) =>
        Some (Pair_key ((Timestamp_key tname), al) (rty, ar) pname)
      | Some (Address_key tname) =>
        Some (Pair_key ((Address_key tname), al) (rty, ar) pname)
      end
    end
  | _ => None
  end.

Definition add_field_annot {A B : Type}
  (a : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (var : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
  match function_parameter with
  | Prim loc prim args annots =>
    Prim loc prim args
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at annots
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
          (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_field_annot a)
          (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_var_annot var)))
  | expr => expr
  end.

Fixpoint unparse_comparable_ty {a s : Type}
  (function_parameter :
    Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node :=
  match function_parameter with
  | Int_key tname =>
    Prim (-1) T_int []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | Nat_key tname =>
    Prim (-1) T_nat []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | String_key tname =>
    Prim (-1) T_string []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | Bytes_key tname =>
    Prim (-1) T_bytes []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | Mutez_key tname =>
    Prim (-1) T_mutez []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | Bool_key tname =>
    Prim (-1) T_bool []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | Key_hash_key tname =>
    Prim (-1) T_key_hash []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | Timestamp_key tname =>
    Prim (-1) T_timestamp []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | Address_key tname =>
    Prim (-1) T_address []
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname)
  | Pair_key (l, al) (r, ar) pname =>
    let tl := add_field_annot al None (unparse_comparable_ty l) in
    let tr := add_field_annot ar None (unparse_comparable_ty r) in
    Prim (-1) T_pair (cons tl (cons tr []))
      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot pname)
  end.

Fixpoint unparse_ty_no_lwt {a : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt Unparse_costs.cycle)
    (fun ctxt =>
      let _return {B : Type}
        (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
        (function_parameter :
        B *
          (list
            (Tezos_protocol_environment_alpha__Environment.Micheline.node Z B))
          * Tezos_protocol_environment_alpha__Environment.Micheline.annot)
        : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((Tezos_protocol_environment_alpha__Environment.Micheline.node Z B) *
            Tezos_raw_protocol_alpha__Alpha_context.context) :=
        match function_parameter with
        | (name, args, annot) =>
          let result := Prim (-1) name args annot in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Unparse_costs.prim_cost
                (Tezos_protocol_environment_alpha__Environment.List.length args)
                annot))
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                (result, ctxt))
        end in
      match ty with
      | Unit_t tname =>
        _return ctxt
          (T_unit, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Int_t tname =>
        _return ctxt
          (T_int, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Nat_t tname =>
        _return ctxt
          (T_nat, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | String_t tname =>
        _return ctxt
          (T_string, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Bytes_t tname =>
        _return ctxt
          (T_bytes, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Mutez_t tname =>
        _return ctxt
          (T_mutez, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Bool_t tname =>
        _return ctxt
          (T_bool, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Key_hash_t tname =>
        _return ctxt
          (T_key_hash, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Key_t tname =>
        _return ctxt
          (T_key, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Timestamp_t tname =>
        _return ctxt
          (T_timestamp, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Address_t tname =>
        _return ctxt
          (T_address, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Signature_t tname =>
        _return ctxt
          (T_signature, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Operation_t tname =>
        _return ctxt
          (T_operation, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Chain_id_t tname =>
        _return ctxt
          (T_chain_id, [],
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Contract_t ut tname =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            match function_parameter with
            | (t, ctxt) =>
              _return ctxt
                (T_contract, (cons t []),
                  (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot
                    tname))
            end)
      | Pair_t (utl, l_field, l_var) (utr, r_field, r_var) tname _ =>
        let annot :=
          Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (unparse_ty_no_lwt ctxt utl)
          (fun function_parameter =>
            match function_parameter with
            | (utl, ctxt) =>
              let tl := add_field_annot l_field l_var utl in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (unparse_ty_no_lwt ctxt utr)
                (fun function_parameter =>
                  match function_parameter with
                  | (utr, ctxt) =>
                    let tr := add_field_annot r_field r_var utr in
                    _return ctxt (T_pair, (cons tl (cons tr [])), annot)
                  end)
            end)
      | Union_t (utl, l_field) (utr, r_field) tname _ =>
        let annot :=
          Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (unparse_ty_no_lwt ctxt utl)
          (fun function_parameter =>
            match function_parameter with
            | (utl, ctxt) =>
              let tl := add_field_annot l_field None utl in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (unparse_ty_no_lwt ctxt utr)
                (fun function_parameter =>
                  match function_parameter with
                  | (utr, ctxt) =>
                    let tr := add_field_annot r_field None utr in
                    _return ctxt (T_or, (cons tl (cons tr [])), annot)
                  end)
            end)
      | Lambda_t uta utr tname =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (unparse_ty_no_lwt ctxt uta)
          (fun function_parameter =>
            match function_parameter with
            | (ta, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (unparse_ty_no_lwt ctxt utr)
                (fun function_parameter =>
                  match function_parameter with
                  | (tr, ctxt) =>
                    _return ctxt
                      (T_lambda, (cons ta (cons tr [])),
                        (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot
                          tname))
                  end)
            end)
      | Option_t ut tname _ =>
        let annot :=
          Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            match function_parameter with
            | (ut, ctxt) => _return ctxt (T_option, (cons ut []), annot)
            end)
      | List_t ut tname _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            match function_parameter with
            | (t, ctxt) =>
              _return ctxt
                (T_list, (cons t []),
                  (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot
                    tname))
            end)
      | Set_t ut tname =>
        let t := unparse_comparable_ty ut in
        _return ctxt
          (T_set, (cons t []),
            (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot tname))
      | Map_t uta utr tname _ =>
        let ta := unparse_comparable_ty uta in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (unparse_ty_no_lwt ctxt utr)
          (fun function_parameter =>
            match function_parameter with
            | (tr, ctxt) =>
              _return ctxt
                (T_map, (cons ta (cons tr [])),
                  (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot
                    tname))
            end)
      | Big_map_t uta utr tname =>
        let ta := unparse_comparable_ty uta in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (unparse_ty_no_lwt ctxt utr)
          (fun function_parameter =>
            match function_parameter with
            | (tr, ctxt) =>
              _return ctxt
                (T_big_map, (cons ta (cons tr [])),
                  (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_type_annot
                    tname))
            end)
      end).

Definition unparse_ty {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (unparse_ty_no_lwt ctxt ty).

Fixpoint strip_var_annots {A B : Type}
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
  match function_parameter with
  | (Int _ _ | String _ _ | Bytes _ _) as atom => atom
  | Seq loc args =>
    Seq loc
      (Tezos_protocol_environment_alpha__Environment.List.map strip_var_annots
        args)
  | Prim loc name args annots =>
    let not_var_annot (s : string) : bool :=
      Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_gt)
        (Tezos_protocol_environment_alpha__Environment.String.get s 0)
        "@" % char in
    let annots :=
      Tezos_protocol_environment_alpha__Environment.List.filter not_var_annot
        annots in
    Prim loc name
      (Tezos_protocol_environment_alpha__Environment.List.map strip_var_annots
        args) annots
  end.

Definition serialize_ty_for_error {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
      (unparse_ty_no_lwt ctxt ty)
      (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
        Cannot_serialize_error))
    (fun function_parameter =>
      match function_parameter with
      | (ty, ctxt) =>
        ((Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
          (strip_var_annots ty)), ctxt)
      end).

Fixpoint unparse_stack {a : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | Empty_t =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return ([], ctxt)
  | Item_t ty rest annot =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (unparse_ty ctxt ty)
      (fun function_parameter =>
        match function_parameter with
        | (uty, ctxt) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (unparse_stack ctxt rest)
            (fun function_parameter =>
              match function_parameter with
              | (urest, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ((cons
                    ((Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                      uty),
                      (Tezos_raw_protocol_alpha.Script_ir_annot.unparse_var_annot
                        annot)) urest), ctxt)
              end)
        end)
  end.

Definition serialize_stack_for_error {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (stack_ty : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.trace
    Cannot_serialize_error (unparse_stack ctxt stack_ty).

Definition name_of_ty {a : Type}
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot :=
  match function_parameter with
  | Unit_t tname => tname
  | Int_t tname => tname
  | Nat_t tname => tname
  | String_t tname => tname
  | Bytes_t tname => tname
  | Mutez_t tname => tname
  | Bool_t tname => tname
  | Key_hash_t tname => tname
  | Key_t tname => tname
  | Timestamp_t tname => tname
  | Address_t tname => tname
  | Signature_t tname => tname
  | Operation_t tname => tname
  | Chain_id_t tname => tname
  | Contract_t _ tname => tname
  | Pair_t _ _ tname _ => tname
  | Union_t _ _ tname _ => tname
  | Lambda_t _ _ tname => tname
  | Option_t _ tname _ => tname
  | List_t _ tname _ => tname
  | Set_t _ tname => tname
  | Map_t _ _ tname _ => tname
  | Big_map_t _ _ tname => tname
  end.

Inductive eq : forall (ta tb : Type), Type :=
| Eq : forall {same : Type}, eq same same.

Definition comparable_ty_eq {ta tb : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty tb)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (eq (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
      (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty tb)) :=
  match (ta, tb) with
  | (Int_key _, Int_key _) => inl Eq
  | (Nat_key _, Nat_key _) => inl Eq
  | (String_key _, String_key _) => inl Eq
  | (Bytes_key _, Bytes_key _) => inl Eq
  | (Mutez_key _, Mutez_key _) => inl Eq
  | (Bool_key _, Bool_key _) => inl Eq
  | (Key_hash_key _, Key_hash_key _) => inl Eq
  | (Timestamp_key _, Timestamp_key _) => inl Eq
  | (Address_key _, Address_key _) => inl Eq
  | (_, _) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (serialize_ty_for_error ctxt (ty_of_comparable_ty ta))
      (fun function_parameter =>
        match function_parameter with
        | (ta, ctxt) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (serialize_ty_for_error ctxt (ty_of_comparable_ty tb))
            (fun function_parameter =>
              match function_parameter with
              | (tb, _ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.error
                  (Inconsistent_types ta tb)
              end)
        end)
  end.

Definition record_inconsistent {A B C : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
  : (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace_eval
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (serialize_ty_for_error ctxt ta)
          (fun function_parameter =>
            match function_parameter with
            | (ta, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                (serialize_ty_for_error ctxt tb)
                (fun function_parameter =>
                  match function_parameter with
                  | (tb, _ctxt) => Inconsistent_types ta tb
                  end)
            end)
      end).

Definition record_inconsistent_type_annotations {A B C : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
  : (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace_eval
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (serialize_ty_for_error ctxt ta)
          (fun function_parameter =>
            match function_parameter with
            | (ta, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                (serialize_ty_for_error ctxt tb)
                (fun function_parameter =>
                  match function_parameter with
                  | (tb, _ctxt) => Inconsistent_type_annotations loc ta tb
                  end)
            end)
      end).

Fixpoint ty_eq {ta tb : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) *
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let ok
    (eq :
    eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) (ctxt :
    Tezos_raw_protocol_alpha__Alpha_context.context) (nb_args : Z)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
        (Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) *
        Tezos_raw_protocol_alpha.Alpha_context.context) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
        (Typecheck_costs.type_
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star 2
            nb_args))) (fun ctxt => inl (eq, ctxt)) in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
      Typecheck_costs.cycle)
    (fun ctxt =>
      match (ta, tb) with
      | (Unit_t _, Unit_t _) => ok Eq ctxt 0
      | (Int_t _, Int_t _) => ok Eq ctxt 0
      | (Nat_t _, Nat_t _) => ok Eq ctxt 0
      | (Key_t _, Key_t _) => ok Eq ctxt 0
      | (Key_hash_t _, Key_hash_t _) => ok Eq ctxt 0
      | (String_t _, String_t _) => ok Eq ctxt 0
      | (Bytes_t _, Bytes_t _) => ok Eq ctxt 0
      | (Signature_t _, Signature_t _) => ok Eq ctxt 0
      | (Mutez_t _, Mutez_t _) => ok Eq ctxt 0
      | (Timestamp_t _, Timestamp_t _) => ok Eq ctxt 0
      | (Chain_id_t _, Chain_id_t _) => ok Eq ctxt 0
      | (Address_t _, Address_t _) => ok Eq ctxt 0
      | (Bool_t _, Bool_t _) => ok Eq ctxt 0
      | (Operation_t _, Operation_t _) => ok Eq ctxt 0
      | (Map_t tal tar _ _, Map_t tbl tbr _ _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (comparable_ty_eq ctxt tal tbl)
            (fun function_parameter =>
              match function_parameter with
              | Eq =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (ty_eq ctxt tar tbr)
                  (fun function_parameter =>
                    match function_parameter with
                    | (Eq, ctxt) => ok Eq ctxt 2
                    end)
              end)) (record_inconsistent ctxt ta tb)
      | (Big_map_t tal tar _, Big_map_t tbl tbr _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (comparable_ty_eq ctxt tal tbl)
            (fun function_parameter =>
              match function_parameter with
              | Eq =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (ty_eq ctxt tar tbr)
                  (fun function_parameter =>
                    match function_parameter with
                    | (Eq, ctxt) => ok Eq ctxt 2
                    end)
              end)) (record_inconsistent ctxt ta tb)
      | (Set_t ea _, Set_t eb _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (comparable_ty_eq ctxt ea eb)
            (fun function_parameter =>
              match function_parameter with
              | Eq => ok Eq ctxt 1
              end)) (record_inconsistent ctxt ta tb)
      | (Pair_t (tal, _, _) (tar, _, _) _ _, Pair_t (tbl, _, _) (tbr, _, _) _ _)
        =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (ty_eq ctxt tar tbr)
                  (fun function_parameter =>
                    match function_parameter with
                    | (Eq, ctxt) => ok Eq ctxt 2
                    end)
              end)) (record_inconsistent ctxt ta tb)
      | (Union_t (tal, _) (tar, _) _ _, Union_t (tbl, _) (tbr, _) _ _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (ty_eq ctxt tar tbr)
                  (fun function_parameter =>
                    match function_parameter with
                    | (Eq, ctxt) => ok Eq ctxt 2
                    end)
              end)) (record_inconsistent ctxt ta tb)
      | (Lambda_t tal tar _, Lambda_t tbl tbr _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (ty_eq ctxt tar tbr)
                  (fun function_parameter =>
                    match function_parameter with
                    | (Eq, ctxt) => ok Eq ctxt 2
                    end)
              end)) (record_inconsistent ctxt ta tb)
      | (Contract_t tal _, Contract_t tbl _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) => ok Eq ctxt 1
              end)) (record_inconsistent ctxt ta tb)
      | (Option_t tva _ _, Option_t tvb _ _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (ty_eq ctxt tva tvb)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) => ok Eq ctxt 1
              end)) (record_inconsistent ctxt ta tb)
      | (List_t tva _ _, List_t tvb _ _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (ty_eq ctxt tva tvb)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) => ok Eq ctxt 1
              end)) (record_inconsistent ctxt ta tb)
      | (_, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (serialize_ty_for_error ctxt ta)
          (fun function_parameter =>
            match function_parameter with
            | (ta, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (serialize_ty_for_error ctxt tb)
                (fun function_parameter =>
                  match function_parameter with
                  | (tb, _ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.error
                      (Inconsistent_types ta tb)
                  end)
            end)
      end).

Fixpoint stack_ty_eq {ta tb : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (lvl : Z)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tb)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((eq (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta)
      (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tb)) *
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  match (ta, tb) with
  | (Item_t tva ra _, Item_t tvb rb _) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
        (ty_eq ctxt tva tvb)
        (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
          (Bad_stack_item lvl)))
      (fun function_parameter =>
        match function_parameter with
        | (Eq, ctxt) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (stack_ty_eq ctxt
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                lvl 1) ra rb)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) => inl (Eq, ctxt)
              end)
        end)
  | (Empty_t, Empty_t) => inl (Eq, ctxt)
  | (_, _) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Bad_stack_length
  end.

Definition merge_comparable_types {ta : Type}
  (legacy : bool)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta) :=
  match (ta, tb) with
  | (Int_key annot_a, Int_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => Int_key annot)
  | (Nat_key annot_a, Nat_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => Nat_key annot)
  | (String_key annot_a, String_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => String_key annot)
  | (Bytes_key annot_a, Bytes_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => Bytes_key annot)
  | (Mutez_key annot_a, Mutez_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => Mutez_key annot)
  | (Bool_key annot_a, Bool_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => Bool_key annot)
  | (Key_hash_key annot_a, Key_hash_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => Key_hash_key annot)
  | (Timestamp_key annot_a, Timestamp_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => Timestamp_key annot)
  | (Address_key annot_a, Address_key annot_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
      (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy annot_a
        annot_b) (fun annot => Address_key annot)
  | (_, _) => false
  end.

Definition merge_types {b : Type} (legacy : bool)
  : Tezos_raw_protocol_alpha.Alpha_context.context ->
    Tezos_raw_protocol_alpha.Alpha_context.Script.location ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty b) ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.ty b) ->
          Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_typed_ir.ty b) *
              Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let fix help {a : Type}
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (ty1 :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (ty2 :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((Tezos_raw_protocol_alpha.Script_typed_ir.ty a) *
        Tezos_raw_protocol_alpha.Alpha_context.context) :=
    match (ty1, ty2) with
    | (Unit_t tn1, Unit_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Unit_t tname), ctxt))
    | (Int_t tn1, Int_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Int_t tname), ctxt))
    | (Nat_t tn1, Nat_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Nat_t tname), ctxt))
    | (Key_t tn1, Key_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Key_t tname), ctxt))
    | (Key_hash_t tn1, Key_hash_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Key_hash_t tname), ctxt))
    | (String_t tn1, String_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((String_t tname), ctxt))
    | (Bytes_t tn1, Bytes_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Bytes_t tname), ctxt))
    | (Signature_t tn1, Signature_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Signature_t tname), ctxt))
    | (Mutez_t tn1, Mutez_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Mutez_t tname), ctxt))
    | (Timestamp_t tn1, Timestamp_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Timestamp_t tname), ctxt))
    | (Address_t tn1, Address_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Address_t tname), ctxt))
    | (Bool_t tn1, Bool_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Bool_t tname), ctxt))
    | (Chain_id_t tn1, Chain_id_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Chain_id_t tname), ctxt))
    | (Operation_t tn1, Operation_t tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2) (fun tname => ((Operation_t tname), ctxt))
    | (Map_t tal tar tn1 has_big_map, Map_t tbl tbr tn2 _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (help ctxt tar tbr)
            (fun function_parameter =>
              match function_parameter with
              | (value, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (ty_eq ctxt tar value)
                  (fun function_parameter =>
                    match function_parameter with
                    | (Eq, ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                        (merge_comparable_types legacy tal tbl)
                        (fun tk => ((Map_t tk value tname has_big_map), ctxt))
                    end)
              end))
    | (Big_map_t tal tar tn1, Big_map_t tbl tbr tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (help ctxt tar tbr)
            (fun function_parameter =>
              match function_parameter with
              | (value, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (ty_eq ctxt tar value)
                  (fun function_parameter =>
                    match function_parameter with
                    | (Eq, ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                        (merge_comparable_types legacy tal tbl)
                        (fun tk => ((Big_map_t tk value tname), ctxt))
                    end)
              end))
    | (Set_t ea tn1, Set_t eb tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
            (merge_comparable_types legacy ea eb)
            (fun e => ((Set_t e tname), ctxt)))
    |
      (Pair_t (tal, l_field1, l_var1) (tar, r_field1, r_var1) tn1 has_big_map,
        Pair_t (tbl, l_field2, l_var2) (tbr, r_field2, r_var2) tn2 _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (Tezos_raw_protocol_alpha.Script_ir_annot.merge_field_annot legacy
              l_field1 l_field2)
            (fun l_field =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_field_annot
                  legacy r_field1 r_field2)
                (fun r_field =>
                  let l_var :=
                    Tezos_raw_protocol_alpha.Script_ir_annot.merge_var_annot
                      l_var1 l_var2 in
                  let r_var :=
                    Tezos_raw_protocol_alpha.Script_ir_annot.merge_var_annot
                      r_var1 r_var2 in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                    (help ctxt tal tbl)
                    (fun function_parameter =>
                      match function_parameter with
                      | (left_ty, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                          (help ctxt tar tbr)
                          (fun function_parameter =>
                            match function_parameter with
                            | (right_ty, ctxt) =>
                              ((Pair_t (left_ty, l_field, l_var)
                                (right_ty, r_field, r_var) tname has_big_map),
                                ctxt)
                            end)
                      end))))
    |
      (Union_t (tal, tal_annot) (tar, tar_annot) tn1 has_big_map,
        Union_t (tbl, tbl_annot) (tbr, tbr_annot) tn2 _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (Tezos_raw_protocol_alpha.Script_ir_annot.merge_field_annot legacy
              tal_annot tbl_annot)
            (fun left_annot =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_field_annot
                  legacy tar_annot tbr_annot)
                (fun right_annot =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                    (help ctxt tal tbl)
                    (fun function_parameter =>
                      match function_parameter with
                      | (left_ty, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                          (help ctxt tar tbr)
                          (fun function_parameter =>
                            match function_parameter with
                            | (right_ty, ctxt) =>
                              ((Union_t (left_ty, left_annot)
                                (right_ty, right_annot) tname has_big_map), ctxt)
                            end)
                      end))))
    | (Lambda_t tal tar tn1, Lambda_t tbl tbr tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (help ctxt tal tbl)
            (fun function_parameter =>
              match function_parameter with
              | (left_ty, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                  (help ctxt tar tbr)
                  (fun function_parameter =>
                    match function_parameter with
                    | (right_ty, ctxt) =>
                      ((Lambda_t left_ty right_ty tname), ctxt)
                    end)
              end))
    | (Contract_t tal tn1, Contract_t tbl tn2) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
            (help ctxt tal tbl)
            (fun function_parameter =>
              match function_parameter with
              | (arg_ty, ctxt) => ((Contract_t arg_ty tname), ctxt)
              end))
    | (Option_t tva tn1 has_big_map, Option_t tvb tn2 _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
            (help ctxt tva tvb)
            (fun function_parameter =>
              match function_parameter with
              | (ty, ctxt) => ((Option_t ty tname has_big_map), ctxt)
              end))
    | (List_t tva tn1 has_big_map, List_t tvb tn2 _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot legacy tn1
          tn2)
        (fun tname =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
            (help ctxt tva tvb)
            (fun function_parameter =>
              match function_parameter with
              | (ty, ctxt) => ((List_t ty tname has_big_map), ctxt)
              end))
    | (_, _) => false
    end in
  fun ctxt =>
    fun loc =>
      fun ty1 =>
        fun ty2 =>
          record_inconsistent_type_annotations ctxt loc ty1 ty2
            (help ctxt ty1 ty2).

Definition merge_stacks {ta : Type}
  (legacy : bool) (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  : Tezos_raw_protocol_alpha.Alpha_context.context ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) *
            Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let fix help {a : Type}
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (stack1 :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) (stack2 :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) *
        Tezos_raw_protocol_alpha.Alpha_context.context) :=
    match (stack1, stack2) with
    | (Empty_t, Empty_t) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
        (Empty_t, ctxt)
    | (Item_t ty1 rest1 annot1, Item_t ty2 rest2 annot2) =>
      let annot :=
        Tezos_raw_protocol_alpha.Script_ir_annot.merge_var_annot annot1 annot2
        in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (merge_types legacy ctxt loc ty1 ty2)
        (fun function_parameter =>
          match function_parameter with
          | (ty, ctxt) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (help ctxt rest1 rest2)
              (fun function_parameter =>
                match function_parameter with
                | (rest, ctxt) => ((Item_t ty rest annot), ctxt)
                end)
          end)
    end in
  help.

Definition has_big_map {t : Type}
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) : bool :=
  match function_parameter with
  | Unit_t _ => false
  | Int_t _ => false
  | Nat_t _ => false
  | Signature_t _ => false
  | String_t _ => false
  | Bytes_t _ => false
  | Mutez_t _ => false
  | Key_hash_t _ => false
  | Key_t _ => false
  | Timestamp_t _ => false
  | Address_t _ => false
  | Bool_t _ => false
  | Lambda_t _ _ _ => false
  | Set_t _ _ => false
  | Big_map_t _ _ _ => true
  | Contract_t _ _ => false
  | Operation_t _ => false
  | Chain_id_t _ => false
  | Pair_t _ _ _ has_big_map => has_big_map
  | Union_t _ _ _ has_big_map => has_big_map
  | Option_t _ _ has_big_map => has_big_map
  | List_t _ _ has_big_map => has_big_map
  | Map_t _ _ _ has_big_map => has_big_map
  end.

Inductive judgement (bef : Type) : Type :=
| Typed : forall {aft : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) -> judgement bef
| Failed : forall {aft : Type},
  (((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft) ->
    Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) * (aft)) ->
  judgement bef.

Arguments Typed {_}.
Arguments Failed {_}.

Record branch {t f b : Type} := {
  branch :
    ((Tezos_raw_protocol_alpha.Script_typed_ir.descr t r) ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.descr f r) ->
        Tezos_raw_protocol_alpha.Script_typed_ir.descr b r) * (r) }.
Arguments branch : clear implicits.

Definition merge_branches {a b bef : Type}
  (legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (loc : Z) (btr : judgement a) (bfr : judgement b)
  (function_parameter : branch a b bef)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | {| branch := branch |} =>
    match (btr, bfr) with
    | (Typed ({| aft := aftbt |} as dbt), Typed ({| aft := aftbf |} as dbf)) =>
      let unmatched_branches (function_parameter : unit)
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
        match function_parameter with
        | tt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (serialize_stack_for_error ctxt aftbt)
            (fun function_parameter =>
              match function_parameter with
              | (aftbt, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                  (serialize_stack_for_error ctxt aftbf)
                  (fun function_parameter =>
                    match function_parameter with
                    | (aftbf, _ctxt) => Unmatched_branches loc aftbt aftbf
                    end)
              end)
        end in
      Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
        unmatched_branches
        (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (stack_ty_eq ctxt 1 aftbt aftbf))
          (fun function_parameter =>
            match function_parameter with
            | (Eq, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (merge_stacks legacy loc ctxt aftbt aftbf))
                (fun function_parameter =>
                  match function_parameter with
                  | (merged_stack, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      ((Typed (branch record record)), ctxt)
                  end)
            end))
    | (Failed {| descr := descrt |}, Failed {| descr := descrf |}) =>
      let descr {D : Type}
        (ret : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty D)
        : Tezos_raw_protocol_alpha.Script_typed_ir.descr bef D :=
        branch (descrt ret) (descrf ret) in
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        ((Failed {| descr := descr |}), ctxt)
    | (Typed dbt, Failed {| descr := descrf |}) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        ((Typed (branch dbt (descrf (aft dbt)))), ctxt)
    | (Failed {| descr := descrt |}, Typed dbf) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        ((Typed (branch (descrt (aft dbf)) dbf)), ctxt)
    end
  end.

Fixpoint parse_comparable_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (ex_comparable_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
      Typecheck_costs.cycle)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
          (Typecheck_costs.type_ 0))
        (fun ctxt =>
          match ty with
          | Prim loc T_int [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot) (fun tname => ((Ex_comparable_ty (Int_key tname)), ctxt))
          | Prim loc T_nat [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot) (fun tname => ((Ex_comparable_ty (Nat_key tname)), ctxt))
          | Prim loc T_string [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot)
              (fun tname => ((Ex_comparable_ty (String_key tname)), ctxt))
          | Prim loc T_bytes [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot)
              (fun tname => ((Ex_comparable_ty (Bytes_key tname)), ctxt))
          | Prim loc T_mutez [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot)
              (fun tname => ((Ex_comparable_ty (Mutez_key tname)), ctxt))
          | Prim loc T_bool [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot)
              (fun tname => ((Ex_comparable_ty (Bool_key tname)), ctxt))
          | Prim loc T_key_hash [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot)
              (fun tname => ((Ex_comparable_ty (Key_hash_key tname)), ctxt))
          | Prim loc T_timestamp [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot)
              (fun tname => ((Ex_comparable_ty (Timestamp_key tname)), ctxt))
          | Prim loc T_address [] annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot)
              (fun tname => ((Ex_comparable_ty (Address_key tname)), ctxt))
          |
            Prim loc
              ((T_int | T_nat | T_string | T_mutez | T_bool | T_key | T_address
                | T_timestamp) as prim) l _ =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Invalid_arity loc prim 0
                (Tezos_protocol_environment_alpha__Environment.List.length l))
          |
            Prim loc
              (T_pair | T_or | T_set | T_map | T_list | T_option | T_lambda |
                T_unit | T_signature | T_contract) _ _ =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Comparable_type_expected loc
                (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                  ty))
          | expr =>
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
              Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (unexpected expr [] Type_namespace
                (cons T_int
                  (cons T_nat
                    (cons T_string
                      (cons T_mutez
                        (cons T_bool
                          (cons T_key (cons T_key_hash (cons T_timestamp [])))))))))
          end))

with parse_packable_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  parse_ty ctxt legacy false false legacy

with parse_parameter_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  parse_ty ctxt legacy true false true

with parse_any_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  parse_ty ctxt legacy true true true

with parse_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (allow_big_map : bool) (allow_operation : bool) (allow_contract : bool)
  (node : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
      Typecheck_costs.cycle)
    (fun ctxt =>
      match node with
      | Prim loc T_unit [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Unit_t ty_name)), ctxt)))
      | Prim loc T_int [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Int_t ty_name)), ctxt)))
      | Prim loc T_nat [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Nat_t ty_name)), ctxt)))
      | Prim loc T_string [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (String_t ty_name)), ctxt)))
      | Prim loc T_bytes [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Bytes_t ty_name)), ctxt)))
      | Prim loc T_mutez [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Mutez_t ty_name)), ctxt)))
      | Prim loc T_bool [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Bool_t ty_name)), ctxt)))
      | Prim loc T_key [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Key_t ty_name)), ctxt)))
      | Prim loc T_key_hash [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Key_hash_t ty_name)), ctxt)))
      | Prim loc T_timestamp [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Timestamp_t ty_name)), ctxt)))
      | Prim loc T_address [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Address_t ty_name)), ctxt)))
      | Prim loc T_signature [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Signature_t ty_name)), ctxt)))
      | Prim loc T_operation [] annot =>
        if allow_operation then
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
            (fun ty_name =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Typecheck_costs.type_ 0))
                (fun ctxt => ((Ex_ty (Operation_t ty_name)), ctxt)))
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            (Unexpected_operation loc)
      | Prim loc T_chain_id [] annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc annot)
          (fun ty_name =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.type_ 0))
              (fun ctxt => ((Ex_ty (Chain_id_t ty_name)), ctxt)))
      | Prim loc T_contract (cons utl []) annot =>
        if allow_contract then
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (parse_parameter_ty ctxt legacy utl)
            (fun function_parameter =>
              match function_parameter with
              | (Ex_ty tl, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                    annot)
                  (fun ty_name =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        (Typecheck_costs.type_ 1))
                      (fun ctxt => ((Ex_ty (Contract_t tl ty_name)), ctxt)))
              end)
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            (Unexpected_contract loc)
      | Prim loc T_pair (cons utl (cons utr [])) annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.extract_field_annot utl)
          (fun function_parameter =>
            match function_parameter with
            | (utl, left_field) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.extract_field_annot
                  utr)
                (fun function_parameter =>
                  match function_parameter with
                  | (utr, right_field) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                      (parse_ty ctxt legacy allow_big_map allow_operation
                        allow_contract utl)
                      (fun function_parameter =>
                        match function_parameter with
                        | (Ex_ty tl, ctxt) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                            (parse_ty ctxt legacy allow_big_map allow_operation
                              allow_contract utr)
                            (fun function_parameter =>
                              match function_parameter with
                              | (Ex_ty tr, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                  (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot
                                    loc annot)
                                  (fun ty_name =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                        ctxt (Typecheck_costs.type_ 2))
                                      (fun ctxt =>
                                        ((Ex_ty
                                          (Pair_t (tl, left_field, None)
                                            (tr, right_field, None) ty_name
                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                                              (has_big_map tl) (has_big_map tr)))),
                                          ctxt)))
                              end)
                        end)
                  end)
            end)
      | Prim loc T_or (cons utl (cons utr [])) annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.extract_field_annot utl)
          (fun function_parameter =>
            match function_parameter with
            | (utl, left_constr) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.extract_field_annot
                  utr)
                (fun function_parameter =>
                  match function_parameter with
                  | (utr, right_constr) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                      (parse_ty ctxt legacy allow_big_map allow_operation
                        allow_contract utl)
                      (fun function_parameter =>
                        match function_parameter with
                        | (Ex_ty tl, ctxt) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                            (parse_ty ctxt legacy allow_big_map allow_operation
                              allow_contract utr)
                            (fun function_parameter =>
                              match function_parameter with
                              | (Ex_ty tr, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                  (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot
                                    loc annot)
                                  (fun ty_name =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                        ctxt (Typecheck_costs.type_ 2))
                                      (fun ctxt =>
                                        ((Ex_ty
                                          (Union_t (tl, left_constr)
                                            (tr, right_constr) ty_name
                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                                              (has_big_map tl) (has_big_map tr)))),
                                          ctxt)))
                              end)
                        end)
                  end)
            end)
      | Prim loc T_lambda (cons uta (cons utr [])) annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (parse_any_ty ctxt legacy uta)
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty ta, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (parse_any_ty ctxt legacy utr)
                (fun function_parameter =>
                  match function_parameter with
                  | (Ex_ty tr, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                      (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot
                        loc annot)
                      (fun ty_name =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                            ctxt (Typecheck_costs.type_ 2))
                          (fun ctxt => ((Ex_ty (Lambda_t ta tr ty_name)), ctxt)))
                  end)
            end)
      | Prim loc T_option (cons ut []) annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (if legacy then
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.extract_field_annot ut)
              (fun function_parameter =>
                match function_parameter with
                | (ut, _some_constr) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                    (Tezos_raw_protocol_alpha.Script_ir_annot.parse_composed_type_annot
                      loc annot)
                    (fun function_parameter =>
                      match function_parameter with
                      | (ty_name, _none_constr, _) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                          (ut, ty_name)
                      end)
                end)
          else
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                annot)
              (fun ty_name =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                  (ut, ty_name)))
          (fun function_parameter =>
            match function_parameter with
            | (ut, ty_name) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (parse_ty ctxt legacy allow_big_map allow_operation
                  allow_contract ut)
                (fun function_parameter =>
                  match function_parameter with
                  | (Ex_ty t, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        (Typecheck_costs.type_ 2))
                      (fun ctxt =>
                        ((Ex_ty (Option_t t ty_name (has_big_map t))), ctxt))
                  end)
            end)
      | Prim loc T_list (cons ut []) annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (parse_ty ctxt legacy allow_big_map allow_operation allow_contract ut)
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty t, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                  annot)
                (fun ty_name =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                      (Typecheck_costs.type_ 1))
                    (fun ctxt =>
                      ((Ex_ty (List_t t ty_name (has_big_map t))), ctxt)))
            end)
      | Prim loc T_set (cons ut []) annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (parse_comparable_ty ctxt ut)
          (fun function_parameter =>
            match function_parameter with
            | (Ex_comparable_ty t, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot loc
                  annot)
                (fun ty_name =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                      (Typecheck_costs.type_ 1))
                    (fun ctxt => ((Ex_ty (Set_t t ty_name)), ctxt)))
            end)
      | Prim loc T_map (cons uta (cons utr [])) annot =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (parse_comparable_ty ctxt uta)
          (fun function_parameter =>
            match function_parameter with
            | (Ex_comparable_ty ta, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (parse_ty ctxt legacy allow_big_map allow_operation
                  allow_contract utr)
                (fun function_parameter =>
                  match function_parameter with
                  | (Ex_ty tr, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                      (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot
                        loc annot)
                      (fun ty_name =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                            ctxt (Typecheck_costs.type_ 2))
                          (fun ctxt =>
                            ((Ex_ty (Map_t ta tr ty_name (has_big_map tr))),
                              ctxt)))
                  end)
            end)
      | Prim loc T_big_map _ _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.error
          (Unexpected_big_map loc)
      |
        Prim loc
          ((T_unit | T_signature | T_int | T_nat | T_string | T_bytes | T_mutez
            | T_bool | T_key | T_key_hash | T_timestamp | T_address) as prim) l
          _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.error
          (Invalid_arity loc prim 0
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | Prim loc ((T_set | T_list | T_option | T_contract) as prim) l _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.error
          (Invalid_arity loc prim 1
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | Prim loc ((T_pair | T_or | T_map | T_lambda) as prim) l _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.error
          (Invalid_arity loc prim 2
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | expr =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
          (unexpected expr [] Type_namespace
            (cons T_pair
              (cons T_or
                (cons T_set
                  (cons T_map
                    (cons T_list
                      (cons T_option
                        (cons T_lambda
                          (cons T_unit
                            (cons T_signature
                              (cons T_contract
                                (cons T_int
                                  (cons T_nat
                                    (cons T_operation
                                      (cons T_string
                                        (cons T_bytes
                                          (cons T_mutez
                                            (cons T_bool
                                              (cons T_key
                                                (cons T_key_hash
                                                  (cons T_timestamp
                                                    (cons T_chain_id []))))))))))))))))))))))
      end)

with parse_big_map_ty
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (legacy : bool)
  (big_map_loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (args :
    list
      (Tezos_protocol_environment_alpha__Environment.Micheline.node
        Tezos_raw_protocol_alpha.Alpha_context.Script.location
        Tezos_raw_protocol_alpha.Alpha_context.Script.prim))
  (map_annot : Tezos_protocol_environment_alpha__Environment.Micheline.annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (ex_ty * Tezos_raw_protocol_alpha__Alpha_context.context) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
      Typecheck_costs.cycle)
    (fun ctxt =>
      match args with
      | cons key_ty (cons value_ty []) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (parse_comparable_ty ctxt key_ty)
          (fun function_parameter =>
            match function_parameter with
            | (Ex_comparable_ty key_ty, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (parse_packable_ty ctxt legacy value_ty)
                (fun function_parameter =>
                  match function_parameter with
                  | (Ex_ty value_ty, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_question
                      (Tezos_raw_protocol_alpha.Script_ir_annot.parse_type_annot
                        big_map_loc map_annot)
                      (fun map_name =>
                        let big_map_ty := Big_map_t key_ty value_ty map_name in
                        ((Ex_ty big_map_ty), ctxt))
                  end)
            end)
      | args =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
          (Invalid_arity big_map_loc T_big_map 2
            (Tezos_protocol_environment_alpha__Environment.List.length args))
      end)

with parse_storage_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (node : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  match node with
  | _ => parse_ty ctxt legacy true false legacy node
  end.

Definition check_packable {A : Type}
  (legacy : bool) (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (root : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  let fix check {t : Type}
    (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty t)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
    match function_parameter with
    | Big_map_t _ _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Unexpected_big_map loc)
    | Operation_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Unexpected_operation loc)
    | Unit_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Int_t _ => Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Nat_t _ => Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Signature_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | String_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Bytes_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Mutez_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Key_hash_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Key_t _ => Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Timestamp_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Address_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Bool_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Chain_id_t _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Pair_t (l_ty, _, _) (r_ty, _, _) _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (check l_ty)
        (fun function_parameter =>
          match function_parameter with
          | tt => check r_ty
          end)
    | Union_t (l_ty, _) (r_ty, _) _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (check l_ty)
        (fun function_parameter =>
          match function_parameter with
          | tt => check r_ty
          end)
    | Option_t v_ty _ _ => check v_ty
    | List_t elt_ty _ _ => check elt_ty
    | Set_t _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Map_t _ elt_ty _ _ => check elt_ty
    | Lambda_t _l_ty _r_ty _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Contract_t _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok tt
    | Contract_t _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Unexpected_contract loc)
    end in
  check root.

Inductive ex_script : Type :=
| Ex_script : forall {a c : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.script a c) -> ex_script.

Inductive dig_proof_argument : forall (_ : Type), Type :=
| Dig_proof_argument : forall {aft bef rest x : Type},
  ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
    (x * rest) rest bef aft) *
    ((Tezos_raw_protocol_alpha.Script_typed_ir.ty x) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
  dig_proof_argument bef.

Inductive dug_proof_argument : forall (_ _ : Type), Type :=
| Dug_proof_argument : forall {aft bef rest x : Type},
  ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
    rest (x * rest) bef aft) * unit *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
  dug_proof_argument bef x.

Inductive dipn_proof_argument : forall (_ : Type), Type :=
| Dipn_proof_argument : forall {aft bef faft fbef : Type},
  ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
    fbef faft bef aft) *
    (Tezos_raw_protocol_alpha.Alpha_context.context *
      (Tezos_raw_protocol_alpha.Script_typed_ir.descr fbef faft)) *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
  dipn_proof_argument bef.

Inductive dropn_proof_argument : forall (_ : Type), Type :=
| Dropn_proof_argument : forall {aft bef rest : Type},
  ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
    rest rest bef aft) *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty rest) *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
  dropn_proof_argument bef.

Definition parse_var_annot
  (loc : Z)
  (default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (Tezos_raw_protocol_alpha.Script_ir_annot.parse_var_annot loc default annot).

Definition parse_entrypoint_annot
  (loc : Z)
  (default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (Tezos_raw_protocol_alpha.Script_ir_annot.parse_entrypoint_annot loc default
      annot).

Definition parse_constr_annot
  (loc : Z)
  (if_special_first :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  (if_special_second :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (Tezos_raw_protocol_alpha.Script_ir_annot.parse_constr_annot loc
      if_special_first if_special_second annot).

Definition parse_two_var_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (Tezos_raw_protocol_alpha.Script_ir_annot.parse_two_var_annot loc annot).

Definition parse_destr_annot
  (loc : Z) (annot : list string)
  (default_accessor :
    option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (field_name : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (pair_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (Tezos_raw_protocol_alpha.Script_ir_annot.parse_destr_annot loc annot
      default_accessor field_name pair_annot value_annot).

Definition parse_var_type_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot))) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (Tezos_raw_protocol_alpha.Script_ir_annot.parse_var_type_annot loc annot).

Definition find_entrypoint {A : Type}
  (full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (root_name :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (entrypoint :
    Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.node) * ex_ty) :=
  let fix find_entrypoint {t : Type}
    (t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (entrypoint : string)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.node) * ex_ty :=
    match t with
    | Union_t (tl, al) (tr, ar) _ _ =>
      if
        match al with
        | None => false
        | Some (Field_annot l) =>
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            l entrypoint
        end then
        ((fun e => Prim 0 D_Left (cons e []) []), (Ex_ty tl))
      else
        if
          match ar with
          | None => false
          | Some (Field_annot r) =>
            Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              r entrypoint
          end then
          ((fun e => Prim 0 D_Right (cons e []) []), (Ex_ty tr))
        else
          try
    | _ =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.raise
        OCaml.Not_found
    end in
  let entrypoint :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        entrypoint "" % string then
      "default" % string
    else
      entrypoint in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      (Tezos_protocol_environment_alpha__Environment.String.length entrypoint)
      31 then
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      (Entrypoint_name_too_long entrypoint)
  else
    match root_name with
    | _ => try
    end.

Definition find_entrypoint_for_type {A B : Type}
  (full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (expected : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
  (root_name :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (entrypoint :
    Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.context * string *
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty B)) :=
  match (entrypoint, root_name) with
  | ("default" % string, Some "root" % string) =>
    match find_entrypoint full root_name entrypoint with
    | (inr _) as err => err
    | inl (_, Ex_ty ty) =>
      match ty_eq ctxt expected ty with
      | inl (Eq, ctxt) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.ok
          (ctxt, "default" % string, ty)
      | inr _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
          (ty_eq ctxt expected full)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                (ctxt, "root" % string, full)
            end)
      end
    end
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
      (find_entrypoint full root_name entrypoint)
      (fun function_parameter =>
        match function_parameter with
        | (_, Ex_ty ty) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (ty_eq ctxt expected ty)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                  (ctxt, entrypoint, ty)
              end)
        end)
  end.

Definition well_formed_entrypoints {A : Type}
  (full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (root_name :
    option Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.elt))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  let merge {B C : Type}
    (path : list B) (annot : option variant) (ty :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (reachable : bool)
    (function_parameter :
    (option (list B)) *
      Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
    : (option (list B)) *
      Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
    match function_parameter with
    | (first_unreachable, all) as acc =>
      match annot with
      | None | Some (Field_annot "" % string) =>
        if reachable then
          acc
        else
          match ty with
          | Union_t _ _ _ _ => acc
          | _ =>
            match first_unreachable with
            | None =>
              ((Some
                (Tezos_protocol_environment_alpha__Environment.List.rev path)),
                all)
            | Some _ => acc
            end
          end
      | Some (Field_annot name) =>
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
            (Tezos_protocol_environment_alpha__Environment.String.length name)
            31 then
          Tezos_protocol_environment_alpha__Environment.Pervasives.raise
            (Too_long name)
        else
          if
            Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
              name all then
            Tezos_protocol_environment_alpha__Environment.Pervasives.raise
              (Duplicate name)
          else
            (first_unreachable,
              (Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.add)
                name all))
      end
    end in
  let fix check {t : Type}
    (t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (path :
    list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (reachable : bool)
    (acc :
    (option (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
      Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
    : (option (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
      Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
    match t with
    | Union_t (tl, al) (tr, ar) _ _ =>
      let acc := merge (cons D_Left path) al tl reachable acc in
      let acc := merge (cons D_Right path) ar tr reachable acc in
      let acc :=
        check tl (cons D_Left path)
          match al with
          | Some _ => true
          | None => reachable
          end acc in
      check tr (cons D_Right path)
        match ar with
        | Some _ => true
        | None => reachable
        end acc
    | _ => acc
    end in
  try.

Fixpoint parse_data {a : Type}
  (type_logger : option type_logger)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  (script_data : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (a * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
        Typecheck_costs.cycle))
    (fun ctxt =>
      let error (function_parameter : unit)
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
        match function_parameter with
        | tt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
            (Tezos_protocol_environment_alpha__Environment.Lwt._return
              (serialize_ty_for_error ctxt ty))
            (fun function_parameter =>
              match function_parameter with
              | (ty, _ctxt) =>
                Invalid_constant (location script_data)
                  (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                    script_data) ty
              end)
        end in
      let traced {B : Type}
        (body :
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B))
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
        Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
          error body in
      let parse_items {B C D E : Type}
        (type_logger : option type_logger) (loc :
        Tezos_raw_protocol_alpha.Alpha_context.Script.location) (ctxt :
        Tezos_raw_protocol_alpha__Alpha_context.context) (expr :
        Tezos_protocol_environment_alpha__Environment.Micheline.node B
          Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (key_type :
        Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty C) (value_type :
        Tezos_raw_protocol_alpha.Script_typed_ir.ty D) (items :
        list
          (Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) (item_wrapper :
        D -> E)
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_typed_ir.map C E) *
              Tezos_raw_protocol_alpha__Alpha_context.context)) :=
        let length :=
          Tezos_protocol_environment_alpha__Environment.List.length items in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
            (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
              (fun function_parameter =>
                match function_parameter with
                | (last_value, map, ctxt) =>
                  fun item =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                          (Typecheck_costs.map_element length)))
                      (fun ctxt =>
                        match item with
                        | Prim _ D_Elt (cons k (cons v [])) _ =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (parse_comparable_data type_logger ctxt key_type k)
                            (fun function_parameter =>
                              match function_parameter with
                              | (k, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (parse_data type_logger ctxt legacy value_type
                                    v)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (v, ctxt) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        match last_value with
                                        | Some value =>
                                          if
                                            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
                                              0
                                              (compare_comparable key_type value
                                                k) then
                                            if
                                              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                                                0
                                                (compare_comparable key_type
                                                  value k) then
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                                (Duplicate_map_keys loc
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                    expr))
                                            else
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                                (Unordered_map_keys loc
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                    expr))
                                          else
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                        | None =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                        end
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                              ((Some k),
                                                (map_update k
                                                  (Some (item_wrapper v)) map),
                                                ctxt)
                                          end)
                                    end)
                              end)
                        | Prim loc D_Elt l _ =>
                          Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                            Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                            (Invalid_arity loc D_Elt 2
                              (Tezos_protocol_environment_alpha__Environment.List.length
                                l))
                        | Prim loc name _ _ =>
                          Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                            Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                            (Invalid_primitive loc (cons D_Elt []) name)
                        | Int _ _ | String _ _ | Bytes _ _ | Seq _ _ =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (error tt)
                            Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                        end)
                end) (None, (empty_map key_type), ctxt) items) traced)
          (fun function_parameter =>
            match function_parameter with
            | (_, items, ctxt) => (items, ctxt)
            end) in
      match (ty, script_data) with
      | (Unit_t _, Prim loc D_Unit [] annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (if legacy then
            Tezos_protocol_environment_alpha__Environment.Error_monad._return tt
          else
            Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
              annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.unit)) (fun ctxt => (tt, ctxt))
            end)
      | (Unit_t _, Prim loc D_Unit l _) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_arity loc D_Unit 0
              (Tezos_protocol_environment_alpha__Environment.List.length l)))
      | (Unit_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (unexpected expr [] Constant_namespace (cons D_Unit [])))
      | (Bool_t _, Prim loc D_True [] annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (if legacy then
            Tezos_protocol_environment_alpha__Environment.Error_monad._return tt
          else
            Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
              annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.bool)) (fun ctxt => (true, ctxt))
            end)
      | (Bool_t _, Prim loc D_False [] annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (if legacy then
            Tezos_protocol_environment_alpha__Environment.Error_monad._return tt
          else
            Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
              annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.bool)) (fun ctxt => (false, ctxt))
            end)
      | (Bool_t _, Prim loc ((D_True | D_False) as c) l _) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_arity loc c 0
              (Tezos_protocol_environment_alpha__Environment.List.length l)))
      | (Bool_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (unexpected expr [] Constant_namespace
              (cons D_True (cons D_False []))))
      | (String_t _, String _ v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Typecheck_costs.string
                (Tezos_protocol_environment_alpha__Environment.String.length v))))
          (fun ctxt =>
            let fix check_printable_ascii
              (i :
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
              : bool :=
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                  i 0 then
                true
              else
                match
                  Tezos_protocol_environment_alpha__Environment.String.get v i
                  with
                |
                  "010" % char |
                    " " % char |
                      "!" % char |
                        """" % char |
                          "#" % char |
                            "$" % char |
                              "%" % char |
                                "&" % char |
                                  "'" % char |
                                    "(" % char |
                                      ")" % char |
                                        "*" % char |
                                          "+" % char |
                                            "," % char |
                                              "-" % char |
                                                "." % char |
                                                  "/" % char |
                                                    "0" % char |
                                                      "1" % char |
                                                        "2" % char |
                                                          "3" % char |
                                                            "4" % char |
                                                              "5" % char |
                                                                "6" % char |
                                                                  "7" % char |
                                                                    "8" % char |
                                                                      "9" % char
                                                                        |
                                                                        ":" %
                                                                          char |
                                                                          ";" %
                                                                            char
                                                                            |
                                                                            "<"
                                                                              %
                                                                              char
                                                                              |
                                                                              "="
                                                                                %
                                                                                char
                                                                                |
                                                                                ">"
                                                                                  %
                                                                                  char
                                                                                  |
                                                                                  "?"
                                                                                    %
                                                                                    char
                                                                                    |
                                                                                    "@"
                                                                                      %
                                                                                      char
                                                                                      |
                                                                                      "A"
                                                                                        %
                                                                                        char
                                                                                        |
                                                                                        "B"
                                                                                          %
                                                                                          char
                                                                                          |
                                                                                          "C"
                                                                                            %
                                                                                            char
                                                                                            |
                                                                                            "D"
                                                                                              %
                                                                                              char
                                                                                              |
                                                                                              "E"
                                                                                                %
                                                                                                char
                                                                                                |
                                                                                                "F"
                                                                                                  %
                                                                                                  char
                                                                                                  |
                                                                                                  "G"
                                                                                                    %
                                                                                                    char
                                                                                                    |
                                                                                                    "H"
                                                                                                      %
                                                                                                      char
                                                                                                      |
                                                                                                      "I"
                                                                                                        %
                                                                                                        char
                                                                                                        |
                                                                                                        "J"
                                                                                                          %
                                                                                                          char
                                                                                                          |
                                                                                                          "K"
                                                                                                            %
                                                                                                            char
                                                                                                            |
                                                                                                            "L"
                                                                                                              %
                                                                                                              char
                                                                                                              |
                                                                                                              "M"
                                                                                                                %
                                                                                                                char
                                                                                                                |
                                                                                                                "N"
                                                                                                                  %
                                                                                                                  char
                                                                                                                  |
                                                                                                                  "O"
                                                                                                                    %
                                                                                                                    char
                                                                                                                    |
                                                                                                                    "P"
                                                                                                                      %
                                                                                                                      char
                                                                                                                      |
                                                                                                                      "Q"
                                                                                                                        %
                                                                                                                        char
                                                                                                                        |
                                                                                                                        "R"
                                                                                                                          %
                                                                                                                          char
                                                                                                                          |
                                                                                                                          "S"
                                                                                                                            %
                                                                                                                            char
                                                                                                                            |
                                                                                                                            "T"
                                                                                                                              %
                                                                                                                              char
                                                                                                                              |
                                                                                                                              "U"
                                                                                                                                %
                                                                                                                                char
                                                                                                                                |
                                                                                                                                "V"
                                                                                                                                  %
                                                                                                                                  char
                                                                                                                                  |
                                                                                                                                  "W"
                                                                                                                                    %
                                                                                                                                    char
                                                                                                                                    |
                                                                                                                                    "X"
                                                                                                                                      %
                                                                                                                                      char
                                                                                                                                      |
                                                                                                                                      "Y"
                                                                                                                                        %
                                                                                                                                        char
                                                                                                                                        |
                                                                                                                                        "Z"
                                                                                                                                          %
                                                                                                                                          char
                                                                                                                                          |
                                                                                                                                          "["
                                                                                                                                            %
                                                                                                                                            char
                                                                                                                                            |
                                                                                                                                            "\"
                                                                                                                                              %
                                                                                                                                              char
                                                                                                                                              |
                                                                                                                                              "]"
                                                                                                                                                %
                                                                                                                                                char
                                                                                                                                                |
                                                                                                                                                "^"
                                                                                                                                                  %
                                                                                                                                                  char
                                                                                                                                                  |
                                                                                                                                                  "_"
                                                                                                                                                    %
                                                                                                                                                    char
                                                                                                                                                    |
                                                                                                                                                    "`"
                                                                                                                                                      %
                                                                                                                                                      char
                                                                                                                                                      |
                                                                                                                                                      "a"
                                                                                                                                                        %
                                                                                                                                                        char
                                                                                                                                                        |
                                                                                                                                                        "b"
                                                                                                                                                          %
                                                                                                                                                          char
                                                                                                                                                          |
                                                                                                                                                          "c"
                                                                                                                                                            %
                                                                                                                                                            char
                                                                                                                                                            |
                                                                                                                                                            "d"
                                                                                                                                                              %
                                                                                                                                                              char
                                                                                                                                                              |
                                                                                                                                                              "e"
                                                                                                                                                                %
                                                                                                                                                                char
                                                                                                                                                                |
                                                                                                                                                                "f"
                                                                                                                                                                  %
                                                                                                                                                                  char
                                                                                                                                                                  |
                                                                                                                                                                  "g"
                                                                                                                                                                    %
                                                                                                                                                                    char
                                                                                                                                                                    |
                                                                                                                                                                    "h"
                                                                                                                                                                      %
                                                                                                                                                                      char
                                                                                                                                                                      |
                                                                                                                                                                      "i"
                                                                                                                                                                        %
                                                                                                                                                                        char
                                                                                                                                                                        |
                                                                                                                                                                        "j"
                                                                                                                                                                          %
                                                                                                                                                                          char
                                                                                                                                                                          |
                                                                                                                                                                          "k"
                                                                                                                                                                            %
                                                                                                                                                                            char
                                                                                                                                                                            |
                                                                                                                                                                            "l"
                                                                                                                                                                              %
                                                                                                                                                                              char
                                                                                                                                                                              |
                                                                                                                                                                              "m"
                                                                                                                                                                                %
                                                                                                                                                                                char
                                                                                                                                                                                |
                                                                                                                                                                                "n"
                                                                                                                                                                                  %
                                                                                                                                                                                  char
                                                                                                                                                                                  |
                                                                                                                                                                                  "o"
                                                                                                                                                                                    %
                                                                                                                                                                                    char
                                                                                                                                                                                    |
                                                                                                                                                                                    "p"
                                                                                                                                                                                      %
                                                                                                                                                                                      char
                                                                                                                                                                                      |
                                                                                                                                                                                      "q"
                                                                                                                                                                                        %
                                                                                                                                                                                        char
                                                                                                                                                                                        |
                                                                                                                                                                                        "r"
                                                                                                                                                                                          %
                                                                                                                                                                                          char
                                                                                                                                                                                          |
                                                                                                                                                                                          "s"
                                                                                                                                                                                            %
                                                                                                                                                                                            char
                                                                                                                                                                                            |
                                                                                                                                                                                            "t"
                                                                                                                                                                                              %
                                                                                                                                                                                              char
                                                                                                                                                                                              |
                                                                                                                                                                                              "u"
                                                                                                                                                                                                %
                                                                                                                                                                                                char
                                                                                                                                                                                                |
                                                                                                                                                                                                "v"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  char
                                                                                                                                                                                                  |
                                                                                                                                                                                                  "w"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    char
                                                                                                                                                                                                    |
                                                                                                                                                                                                    "x"
                                                                                                                                                                                                      %
                                                                                                                                                                                                      char
                                                                                                                                                                                                      |
                                                                                                                                                                                                      "y"
                                                                                                                                                                                                        %
                                                                                                                                                                                                        char
                                                                                                                                                                                                        |
                                                                                                                                                                                                        "z"
                                                                                                                                                                                                          %
                                                                                                                                                                                                          char
                                                                                                                                                                                                          |
                                                                                                                                                                                                          "{"
                                                                                                                                                                                                            %
                                                                                                                                                                                                            char
                                                                                                                                                                                                            |
                                                                                                                                                                                                            "|"
                                                                                                                                                                                                              %
                                                                                                                                                                                                              char
                                                                                                                                                                                                              |
                                                                                                                                                                                                              "}"
                                                                                                                                                                                                                %
                                                                                                                                                                                                                char
                                                                                                                                                                                                                |
                                                                                                                                                                                                                "~"
                                                                                                                                                                                                                  %
                                                                                                                                                                                                                  char
                  =>
                  check_printable_ascii
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                      i 1)
                | _ => false
                end in
            if
              check_printable_ascii
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                  (Tezos_protocol_environment_alpha__Environment.String.length v)
                  1) then
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (v, ctxt)
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail)
      | (String_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons String_kind []) (kind expr)))
      | (Bytes_t _, Bytes _ v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Typecheck_costs.string
                (Tezos_protocol_environment_alpha__Environment.MBytes.length v))))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (v, ctxt))
      | (Bytes_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Bytes_kind []) (kind expr)))
      | (Int_t _, Int _ v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Typecheck_costs.z v)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_zint v),
                ctxt))
      | (Nat_t _, Int _ v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Typecheck_costs.z v)))
          (fun ctxt =>
            let v := Tezos_raw_protocol_alpha.Alpha_context.Script_int.of_zint v
              in
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
                (Tezos_raw_protocol_alpha.Alpha_context.Script_int.compare v
                  Tezos_raw_protocol_alpha.Alpha_context.Script_int.zero) 0 then
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.abs v), ctxt)
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail)
      | (Int_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Int_kind []) (kind expr)))
      | (Nat_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Int_kind []) (kind expr)))
      | (Mutez_t _, Int _ v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                Typecheck_costs.tez)
              (fun ctxt =>
                Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Tezos_raw_protocol_alpha.Michelson_v1_gas.Cost_of.Legacy.z_to_int64)))
          (fun ctxt => try)
      | (Mutez_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Int_kind []) (kind expr)))
      | (Timestamp_t _, Int _ v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Typecheck_costs.z v)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.of_zint
                v), ctxt))
      | (Timestamp_t _, String _ s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.string_timestamp))
          (fun ctxt =>
            match
              Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.of_string
                s with
            | Some v =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (v, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Timestamp_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons String_kind (cons Int_kind []))
              (kind expr)))
      | (Key_t _, Bytes _ bytes) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.key))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key.encoding
                string with
            | Some k =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (k, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Key_t _, String _ s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.key))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key.of_b58check_opt
                s with
            | Some k =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (k, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Key_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr)
              (cons String_kind (cons Bytes_kind [])) (kind expr)))
      | (Key_hash_t _, Bytes _ bytes) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.key_hash))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
                string with
            | Some k =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (k, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Key_hash_t _, String _ s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.key_hash))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.of_b58check_opt
                s with
            | Some k =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (k, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Key_hash_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr)
              (cons String_kind (cons Bytes_kind [])) (kind expr)))
      | (Signature_t _, Bytes _ bytes) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.signature))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                Tezos_protocol_environment_alpha__Environment.Signature.encoding
                string with
            | Some k =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (k, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Signature_t _, String _ s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.signature))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Signature.of_b58check_opt
                s with
            | Some s =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (s, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Signature_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr)
              (cons String_kind (cons Bytes_kind [])) (kind expr)))
      | (Operation_t _, _) => false
      | (Chain_id_t _, Bytes _ bytes) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.chain_id))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)
                string with
            | Some k =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (k, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Chain_id_t _, String _ s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.chain_id))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.of_b58check_opt)
                s with
            | Some s =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (s, ctxt)
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Chain_id_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr)
              (cons String_kind (cons Bytes_kind [])) (kind expr)))
      | (Address_t _, Bytes loc bytes) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.contract))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
                  Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding
                  Tezos_protocol_environment_alpha__Environment.Data_encoding.Variable.string)
                string with
            | Some (c, entrypoint) =>
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                  (Tezos_protocol_environment_alpha__Environment.String.length
                    entrypoint) 31 then
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                  (Entrypoint_name_too_long entrypoint)
              else
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  match entrypoint with
                  | "" % string =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      "default" % string
                  | "default" % string =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                      (Unexpected_annotation loc)
                  | name =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      name
                  end
                  (fun entrypoint =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      ((c, entrypoint), ctxt))
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Address_t _, String loc s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.contract))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              match
                Tezos_protocol_environment_alpha__Environment.String.index_opt s
                  "%" % char with
              | None =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (s, "default" % string)
              | Some pos =>
                let len :=
                  Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                      (Tezos_protocol_environment_alpha__Environment.String.length
                        s) pos) 1 in
                let name :=
                  Tezos_protocol_environment_alpha__Environment.String.sub s
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                      pos 1) len in
                if
                  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                    len 31 then
                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                    (Entrypoint_name_too_long name)
                else
                  match
                    ((Tezos_protocol_environment_alpha__Environment.String.sub s
                      0 pos), name) with
                  | (_, "default" % string) =>
                    traced
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                        (Unexpected_annotation loc))
                  | addr_and_name =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      addr_and_name
                  end
              end
              (fun function_parameter =>
                match function_parameter with
                | (addr, entrypoint) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Alpha_context.Contract.of_b58check
                        addr))
                    (fun c =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        ((c, entrypoint), ctxt))
                end))
      | (Address_t _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr)
              (cons String_kind (cons Bytes_kind [])) (kind expr)))
      | (Contract_t ty _, Bytes loc bytes) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.contract))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
                  Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding
                  Tezos_protocol_environment_alpha__Environment.Data_encoding.Variable.string)
                string with
            | Some (c, entrypoint) =>
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                  (Tezos_protocol_environment_alpha__Environment.String.length
                    entrypoint) 31 then
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                  (Entrypoint_name_too_long entrypoint)
              else
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  match entrypoint with
                  | "" % string =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      "default" % string
                  | "default" % string =>
                    traced
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                        (Unexpected_annotation loc))
                  | name =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      name
                  end
                  (fun entrypoint =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (traced (parse_contract legacy ctxt loc ty c entrypoint))
                      (fun function_parameter =>
                        match function_parameter with
                        | (ctxt, _) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            ((ty, (c, entrypoint)), ctxt)
                        end))
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (error tt)
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            end)
      | (Contract_t ty _, String loc s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.contract))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              match
                Tezos_protocol_environment_alpha__Environment.String.index_opt s
                  "%" % char with
              | None =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (s, "default" % string)
              | Some pos =>
                let len :=
                  Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                      (Tezos_protocol_environment_alpha__Environment.String.length
                        s) pos) 1 in
                let name :=
                  Tezos_protocol_environment_alpha__Environment.String.sub s
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                      pos 1) len in
                if
                  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                    len 31 then
                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                    (Entrypoint_name_too_long name)
                else
                  match
                    ((Tezos_protocol_environment_alpha__Environment.String.sub s
                      0 pos), name) with
                  | (_, "default" % string) =>
                    traced
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                        (Unexpected_annotation loc))
                  | addr_and_name =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      addr_and_name
                  end
              end
              (fun function_parameter =>
                match function_parameter with
                | (addr, entrypoint) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (traced
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Contract.of_b58check
                          addr)))
                    (fun c =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (parse_contract legacy ctxt loc ty c entrypoint)
                        (fun function_parameter =>
                          match function_parameter with
                          | (ctxt, _) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              ((ty, (c, entrypoint)), ctxt)
                          end))
                end))
      | (Contract_t _ _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr)
              (cons String_kind (cons Bytes_kind [])) (kind expr)))
      |
        (Pair_t (ta, _, _) (tb, _, _) _ _,
          Prim loc D_Pair (cons va (cons vb [])) annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (if legacy then
            Tezos_protocol_environment_alpha__Environment.Error_monad._return tt
          else
            Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
              annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.pair))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      traced (parse_data type_logger ctxt legacy ta va))
                    (fun function_parameter =>
                      match function_parameter with
                      | (va, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (parse_data type_logger ctxt legacy tb vb)
                          (fun function_parameter =>
                            match function_parameter with
                            | (vb, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                ((va, vb), ctxt)
                            end)
                      end))
            end)
      | (Pair_t _ _ _ _, Prim loc D_Pair l _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc D_Pair 2
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | (Pair_t _ _ _ _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (unexpected expr [] Constant_namespace (cons D_Pair [])))
      | (Union_t (tl, _) _ _ _, Prim loc D_Left (cons v []) annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (if legacy then
            Tezos_protocol_environment_alpha__Environment.Error_monad._return tt
          else
            Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
              annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.union))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      traced (parse_data type_logger ctxt legacy tl v))
                    (fun function_parameter =>
                      match function_parameter with
                      | (v, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          ((L v), ctxt)
                      end))
            end)
      | (Union_t _ _ _ _, Prim loc D_Left l _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc D_Left 1
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | (Union_t _ (tr, _) _ _, Prim loc D_Right (cons v []) annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
            annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.union))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      traced (parse_data type_logger ctxt legacy tr v))
                    (fun function_parameter =>
                      match function_parameter with
                      | (v, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          ((R v), ctxt)
                      end))
            end)
      | (Union_t _ _ _ _, Prim loc D_Right l _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc D_Right 1
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | (Union_t _ _ _ _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (unexpected expr [] Constant_namespace
              (cons D_Left (cons D_Right []))))
      | (Lambda_t ta tr _ty_name, (Seq _loc _) as script_instr) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Typecheck_costs.lambda))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
              traced
              (parse_returning type_logger Lambda ctxt legacy
                (ta, (Some variant)) tr script_instr))
      | (Lambda_t _ _ _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Seq_kind []) (kind expr)))
      | (Option_t t _ _, Prim loc D_Some (cons v []) annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (if legacy then
            Tezos_protocol_environment_alpha__Environment.Error_monad._return tt
          else
            Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
              annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.some))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      traced (parse_data type_logger ctxt legacy t v))
                    (fun function_parameter =>
                      match function_parameter with
                      | (v, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          ((Some v), ctxt)
                      end))
            end)
      | (Option_t _ _ _, Prim loc D_Some l _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc D_Some 1
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | (Option_t _ _ _, Prim loc D_None [] annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (if legacy then
            Tezos_protocol_environment_alpha__Environment.Error_monad._return tt
          else
            Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
              annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.none))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (None, ctxt))
            end)
      | (Option_t _ _ _, Prim loc D_None l _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc D_None 0
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | (Option_t _ _ _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (unexpected expr [] Constant_namespace
              (cons D_Some (cons D_None []))))
      | (List_t t _ty_name _, Seq _loc items) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_right_s
            (fun v =>
              fun function_parameter =>
                match function_parameter with
                | (rest, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        Typecheck_costs.list_element))
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (parse_data type_logger ctxt legacy t v)
                        (fun function_parameter =>
                          match function_parameter with
                          | (v, ctxt) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              ((cons v rest), ctxt)
                          end))
                end) items ([], ctxt))
      | (List_t _ _ _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Seq_kind []) (kind expr)))
      | (Set_t t _ty_name, (Seq loc vs) as expr) =>
        let length :=
          Tezos_protocol_environment_alpha__Environment.List.length vs in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            traced
            (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
              (fun function_parameter =>
                match function_parameter with
                | (last_value, set, ctxt) =>
                  fun v =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                          (Typecheck_costs.set_element length)))
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (parse_comparable_data type_logger ctxt t v)
                          (fun function_parameter =>
                            match function_parameter with
                            | (v, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                match last_value with
                                | Some value =>
                                  if
                                    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
                                      0 (compare_comparable t value v) then
                                    if
                                      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                                        0 (compare_comparable t value v) then
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                        (Duplicate_set_values loc
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                            expr))
                                    else
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                        (Unordered_set_values loc
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                            expr))
                                  else
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                | None =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                end
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                          ctxt
                                          (Tezos_raw_protocol_alpha.Michelson_v1_gas.Cost_of.Legacy.set_update
                                            v false set)))
                                      (fun ctxt =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                          ((Some v), (set_update v true set),
                                            ctxt))
                                  end)
                            end))
                end) (None, (empty_set t), ctxt) vs))
          (fun function_parameter =>
            match function_parameter with
            | (_, set, ctxt) => (set, ctxt)
            end)
      | (Set_t _ _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Seq_kind []) (kind expr)))
      | (Map_t tk tv _ty_name _, (Seq loc vs) as expr) =>
        parse_items type_logger loc ctxt expr tk tv vs (fun x => x)
      | (Map_t _ _ _ _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Seq_kind []) (kind expr)))
      | (Big_map_t tk tv _ty_name, (Seq loc vs) as expr) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
          (parse_items type_logger loc ctxt expr tk tv vs (fun x => Some x))
          (fun function_parameter =>
            match function_parameter with
            | (diff, ctxt) =>
              ({| id := None; diff := diff; key_type := ty_of_comparable_ty tk;
                value_type := tv |}, ctxt)
            end)
      | (Big_map_t tk tv _ty_name, Int loc id) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Alpha_context.Big_map._exists ctxt id)
          (fun function_parameter =>
            match function_parameter with
            | (_, None) =>
              traced
                (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                  (Invalid_big_map loc id))
            | (ctxt, Some (btk, btv)) =>
              Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (parse_comparable_ty ctxt
                    (Tezos_protocol_environment_alpha__Environment.Micheline.root
                      btk))
                  (fun function_parameter =>
                    match function_parameter with
                    | (Ex_comparable_ty btk, ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                        (parse_packable_ty ctxt legacy
                          (Tezos_protocol_environment_alpha__Environment.Micheline.root
                            btv))
                        (fun function_parameter =>
                          match function_parameter with
                          | (Ex_ty btv, ctxt) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                              (comparable_ty_eq ctxt tk btk)
                              (fun function_parameter =>
                                match function_parameter with
                                | Eq =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                    (ty_eq ctxt tv btv)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (Eq, ctxt) =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                          ({| id := Some id;
                                            diff := empty_map tk;
                                            key_type := ty_of_comparable_ty tk;
                                            value_type := tv |}, ctxt)
                                      end)
                                end)
                          end)
                    end))
            end)
      | (Big_map_t _tk _tv _, expr) =>
        traced
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Invalid_kind (location expr) (cons Seq_kind (cons Int_kind []))
              (kind expr)))
      end)

with parse_comparable_data {a : Type}
  (type_logger : option type_logger)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
  (script_data : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (a * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  parse_data type_logger ctxt false (ty_of_comparable_ty ty) script_data

with parse_returning {arg ret : Type}
  (type_logger : option type_logger) (tc_context : tc_context)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (function_parameter :
    (Tezos_raw_protocol_alpha.Script_typed_ir.ty arg) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  : (Tezos_raw_protocol_alpha.Script_typed_ir.ty ret) ->
    Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((Tezos_raw_protocol_alpha.Script_typed_ir.lambda arg ret) *
            Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | (arg, arg_annot) =>
    fun ret =>
      fun script_instr =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_instr type_logger tc_context ctxt legacy script_instr
            (Item_t arg Empty_t arg_annot))
          (fun function_parameter =>
            match function_parameter with
            |
              (Typed
                ({| loc := loc; aft := (Item_t ty Empty_t _) as stack_ty |} as
                  descr), ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (serialize_ty_for_error ctxt ret))
                      (fun function_parameter =>
                        match function_parameter with
                        | (ret, ctxt) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                            (serialize_stack_for_error ctxt stack_ty)
                            (fun function_parameter =>
                              match function_parameter with
                              | (stack_ty, _ctxt) => Bad_return loc stack_ty ret
                              end)
                        end)
                  end)
                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (ty_eq ctxt ty ret))
                  (fun function_parameter =>
                    match function_parameter with
                    | (Eq, ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (merge_types legacy ctxt loc ty ret))
                        (fun function_parameter =>
                          match function_parameter with
                          | (_ret, ctxt) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              ((Lam descr script_instr), ctxt)
                          end)
                    end))
            | (Typed {| loc := loc; aft := stack_ty |}, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (serialize_ty_for_error ctxt ret))
                (fun function_parameter =>
                  match function_parameter with
                  | (ret, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (serialize_stack_for_error ctxt stack_ty)
                      (fun function_parameter =>
                        match function_parameter with
                        | (stack_ty, _ctxt) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                            (Bad_return loc stack_ty ret)
                        end)
                  end)
            | (Failed {| descr := descr |}, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Lam (descr (Item_t ret Empty_t None)) script_instr), ctxt)
            end)
  end

with parse_int32
  (n :
    Tezos_protocol_environment_alpha__Environment.Micheline.node
      Tezos_raw_protocol_alpha.Alpha_context.Script.location
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z :=
  let error' (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
    match function_parameter with
    | tt =>
      Invalid_syntactic_constant (location n)
        (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
          n)
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
          "a positive 32-bit integer (between 0 and " % string
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
            (Tezos_protocol_environment_alpha__Environment.Int32.to_string
              Tezos_protocol_environment_alpha__Environment.Int32.max_int)
            ")" % string))
    end in
  match n with
  | Micheline.Int _ n' => try
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
      (error' tt)
  end

with parse_instr {bef : Type}
  (type_logger : option type_logger) (tc_context : tc_context)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (script_instr : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  (stack_ty : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty bef)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let _check_item {B : Type}
    (check :
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) (loc :
    Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
    Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      (Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
              (serialize_stack_for_error ctxt stack_ty)
              (fun function_parameter =>
                match function_parameter with
                | (stack_ty, _ctxt) => Bad_stack loc name m stack_ty
                end)
          end))
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
          (Bad_stack_item n))
        (Tezos_protocol_environment_alpha__Environment.Lwt._return check)) in
  let check_item_ty {B C : Type}
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (exp :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty B) (got :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (loc :
    Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
    Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((eq B C) * (Tezos_raw_protocol_alpha.Script_typed_ir.ty B) *
          Tezos_raw_protocol_alpha.Alpha_context.context)) :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      (Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
              (serialize_stack_for_error ctxt stack_ty)
              (fun function_parameter =>
                match function_parameter with
                | (stack_ty, _ctxt) => Bad_stack loc name m stack_ty
                end)
          end))
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
          (Bad_stack_item n))
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (ty_eq ctxt exp got)
            (fun function_parameter =>
              match function_parameter with
              | (Eq, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (merge_types legacy ctxt loc exp got)
                  (fun function_parameter =>
                    match function_parameter with
                    | (ty, ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                        (Eq, ty, ctxt)
                    end)
              end)))) in
  let check_item_comparable_ty {B C : Type}
    (exp : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty B) (got :
    Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty C) (loc :
    Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
    Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((eq B C) * (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty B))) :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      (Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
              (serialize_stack_for_error ctxt stack_ty)
              (fun function_parameter =>
                match function_parameter with
                | (stack_ty, _ctxt) => Bad_stack loc name m stack_ty
                end)
          end))
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
          (Bad_stack_item n))
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (comparable_ty_eq ctxt exp got)
            (fun function_parameter =>
              match function_parameter with
              | Eq =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  (merge_comparable_types legacy exp got)
                  (fun ty =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                      (Eq, ty))
              end)))) in
  let log_stack {B C : Type}
    (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (loc : Z) (stack_ty
    : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B) (aft :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty C)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
    match (type_logger, script_instr) with
    | (None, _) | (Some _, Seq (-1) _ | Int _ _ | String _ _ | Bytes _ _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
    | (Some log, Prim _ _ _ _ | Seq _ _) =>
      let ctxt := Tezos_raw_protocol_alpha.Alpha_context.Gas.set_unlimited ctxt
        in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (unparse_stack ctxt stack_ty)
        (fun function_parameter =>
          match function_parameter with
          | (stack_ty, _) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (unparse_stack ctxt aft)
              (fun function_parameter =>
                match function_parameter with
                | (aft, _) =>
                  log loc stack_ty aft;
                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                end)
          end)
    end in
  let outer_return :=
    Tezos_protocol_environment_alpha__Environment.Error_monad._return in
  let _return
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (judgement :
    judgement bef)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
    match judgement with
    | Typed {| loc := loc; aft := aft; instr := instr |} =>
      let maximum_type_size :=
        Tezos_raw_protocol_alpha.Alpha_context.Constants.michelson_maximum_type_size
          ctxt in
      let type_size :=
        type_size_of_stack_head aft (number_of_generated_growing_types instr) in
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
          type_size maximum_type_size then
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Type_too_large loc type_size maximum_type_size)
      else
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (judgement, ctxt)
    | Failed _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (judgement, ctxt)
    end in
  let typed {B : Type}
    (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (loc : Z) (instr :
    Tezos_raw_protocol_alpha.Script_typed_ir.instr bef B) (aft :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (log_stack ctxt loc stack_ty aft)
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
              Tezos_protocol_environment_alpha__Environment.Lwt._return
              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                (Typecheck_costs.instr instr)))
            (fun ctxt =>
              _return ctxt
                (Typed
                  {| loc := loc; bef := stack_ty; aft := aft; instr := instr |}))
        end) in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
        Typecheck_costs.cycle))
    (fun ctxt =>
      match (script_instr, stack_ty) with
      | (Prim loc I_DROP [] annot, Item_t _ rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
            annot)
          (fun function_parameter =>
            match function_parameter with
            | tt => typed ctxt loc Drop rest
            end)
      | (Prim loc I_DROP (cons n []) result_annot, whole_stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_int32 n))
          (fun whole_n =>
            let fix make_proof_argument {tstk : Type}
              (n : Z) (stk :
              Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  (dropn_proof_argument tstk)) :=
              match
                ((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  n 0), stk) with
              | (true, rest) =>
                Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  outer_return (Dropn_proof_argument (Rest, rest, rest))
              | (false, Item_t v rest annot) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (make_proof_argument
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                      n 1) rest)
                  (fun function_parameter =>
                    match function_parameter with
                    | Dropn_proof_argument (n', stack_after_drops, aft') =>
                      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                        outer_return
                        (Dropn_proof_argument
                          ((Prefix n'), stack_after_drops, (Item_t v aft' annot)))
                    end)
              | (_, _) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (serialize_stack_for_error ctxt whole_stack)
                  (fun function_parameter =>
                    match function_parameter with
                    | (whole_stack, _ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                        (Bad_stack loc I_DROP whole_n whole_stack)
                    end)
              end in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                loc result_annot)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (make_proof_argument whole_n whole_stack)
                    (fun function_parameter =>
                      match function_parameter with
                      | Dropn_proof_argument (n', stack_after_drops, _aft) =>
                        typed ctxt loc (Dropn whole_n n') stack_after_drops
                      end)
                end))
      | (Prim loc I_DROP ((cons _ (cons _ _)) as l) _, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc I_DROP 1
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | (Prim loc I_DUP [] annot, Item_t v rest stack_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc (Some stack_annot) annot)
          (fun annot =>
            typed ctxt loc Dup (Item_t v (Item_t v rest stack_annot) annot))
      | (Prim loc I_DIG (cons n []) result_annot, stack) =>
        let fix make_proof_argument {tstk : Type}
          (n : Z) (stk : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
          : Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (dig_proof_argument tstk)) :=
          match
            ((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              n 0), stk) with
          | (true, Item_t v rest annot) =>
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
              outer_return (Dig_proof_argument (Rest, (v, annot), rest))
          | (false, Item_t v rest annot) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (make_proof_argument
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                  n 1) rest)
              (fun function_parameter =>
                match function_parameter with
                | Dig_proof_argument (n', (x, xv), aft') =>
                  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                    outer_return
                    (Dig_proof_argument
                      ((Prefix n'), (x, xv), (Item_t v aft' annot)))
                end)
          | (_, _) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (serialize_stack_for_error ctxt stack)
              (fun function_parameter =>
                match function_parameter with
                | (whole_stack, _ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                    (Bad_stack loc I_DIG 1 whole_stack)
                end)
          end in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_int32 n))
          (fun n =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                loc result_annot)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (make_proof_argument n stack)
                    (fun function_parameter =>
                      match function_parameter with
                      | Dig_proof_argument (n', (x, stack_annot), aft) =>
                        typed ctxt loc (Dig n n') (Item_t x aft stack_annot)
                      end)
                end))
      | (Prim loc I_DIG (([] | cons _ (cons _ _)) as l) _, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc I_DIG 1
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      |
        (Prim loc I_DUG (cons n []) result_annot,
          Item_t x whole_stack stack_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_int32 n))
          (fun whole_n =>
            let fix make_proof_argument {tstk x : Type}
              (n : Z) (x : Tezos_raw_protocol_alpha.Script_typed_ir.ty x)
              (stack_annot :
              option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) (stk :
              Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  (dug_proof_argument tstk x)) :=
              match
                ((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  n 0), stk) with
              | (true, rest) =>
                Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  outer_return
                  (Dug_proof_argument (Rest, tt, (Item_t x rest stack_annot)))
              | (false, Item_t v rest annot) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (make_proof_argument
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                      n 1) x stack_annot rest)
                  (fun function_parameter =>
                    match function_parameter with
                    | Dug_proof_argument (n', tt, aft') =>
                      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                        outer_return
                        (Dug_proof_argument
                          ((Prefix n'), tt, (Item_t v aft' annot)))
                    end)
              | (_, _) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (serialize_stack_for_error ctxt whole_stack)
                  (fun function_parameter =>
                    match function_parameter with
                    | (whole_stack, _ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                        (Bad_stack loc I_DUG whole_n whole_stack)
                    end)
              end in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                loc result_annot)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (make_proof_argument whole_n x stack_annot whole_stack)
                    (fun function_parameter =>
                      match function_parameter with
                      | Dug_proof_argument (n', tt, aft) =>
                        typed ctxt loc (Dug whole_n n') aft
                      end)
                end))
      | (Prim loc I_DUG (cons _ []) result_annot, Empty_t as stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
            result_annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (serialize_stack_for_error ctxt stack)
                (fun function_parameter =>
                  match function_parameter with
                  | (stack, _ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                      (Bad_stack loc I_DUG 1 stack)
                  end)
            end)
      | (Prim loc I_DUG (([] | cons _ (cons _ _)) as l) _, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc I_DUG 1
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      |
        (Prim loc I_SWAP [] annot,
          Item_t v (Item_t w rest stack_annot) cur_top_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
            annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              typed ctxt loc Swap
                (Item_t w (Item_t v rest cur_top_annot) stack_annot)
            end)
      | (Prim loc I_PUSH (cons t (cons d [])) annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (parse_packable_ty ctxt legacy t))
              (fun function_parameter =>
                match function_parameter with
                | (Ex_ty t, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (parse_data type_logger ctxt legacy t d)
                    (fun function_parameter =>
                      match function_parameter with
                      | (v, ctxt) =>
                        typed ctxt loc (Const v) (Item_t t stack annot)
                      end)
                end))
      | (Prim loc I_UNIT [] annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_type_annot loc annot)
          (fun function_parameter =>
            match function_parameter with
            | (annot, ty_name) =>
              typed ctxt loc (Const tt) (Item_t (Unit_t ty_name) stack annot)
            end)
      | (Prim loc I_SOME [] annot, Item_t t rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_type_annot loc annot)
          (fun function_parameter =>
            match function_parameter with
            | (annot, ty_name) =>
              typed ctxt loc Cons_some
                (Item_t (Option_t t ty_name (has_big_map t)) rest annot)
            end)
      | (Prim loc I_NONE (cons t []) annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_any_ty ctxt legacy t))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty t, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_type_annot loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (annot, ty_name) =>
                    typed ctxt loc (Cons_none t)
                      (Item_t (Option_t t ty_name (has_big_map t)) stack annot)
                  end)
            end)
      |
        (Prim loc I_IF_NONE (cons bt (cons bf [])) annot,
          (Item_t (Option_t t _ _) rest option_annot) as bef) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) bt)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_kind (cons Seq_kind []) bf)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                        loc annot)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let annot :=
                            Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                              option_annot None
                              Tezos_raw_protocol_alpha.Script_ir_annot.default_some_annot
                            in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (parse_instr type_logger tc_context ctxt legacy bt
                              rest)
                            (fun function_parameter =>
                              match function_parameter with
                              | (btr, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (parse_instr type_logger tc_context ctxt
                                    legacy bf (Item_t t rest annot))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (bfr, ctxt) =>
                                      let branch {B : Type}
                                        (ibt :
                                        Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          op_dollar_5_7 B) (ibf :
                                        Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          (op_dollar_5_8 * op_dollar_5_7) B)
                                        : Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          ((option op_dollar_5_8) *
                                            op_dollar_5_7) B :=
                                        {| loc := loc; bef := bef;
                                          aft := aft ibt;
                                          instr := If_none ibt ibf |} in
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (merge_branches legacy ctxt loc btr bfr
                                          {| branch := branch |})
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (judgement, ctxt) =>
                                            _return ctxt judgement
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      | (Prim loc I_PAIR [] annot, Item_t a (Item_t b rest snd_annot) fst_annot)
        =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_constr_annot loc
            (Some
              (Tezos_raw_protocol_alpha.Script_ir_annot.var_to_field_annot
                fst_annot))
            (Some
              (Tezos_raw_protocol_alpha.Script_ir_annot.var_to_field_annot
                snd_annot)) annot)
          (fun function_parameter =>
            match function_parameter with
            | (annot, ty_name, l_field, r_field) =>
              typed ctxt loc Cons_pair
                (Item_t
                  (Pair_t (a, l_field, fst_annot) (b, r_field, snd_annot)
                    ty_name
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                      (has_big_map a) (has_big_map b))) rest annot)
            end)
      |
        (Prim loc I_CAR [] annot,
          Item_t (Pair_t (a, expected_field_annot, a_annot) _ _ _) rest
            pair_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_destr_annot loc annot
            Tezos_raw_protocol_alpha.Script_ir_annot.default_car_annot
            expected_field_annot pair_annot a_annot)
          (fun function_parameter =>
            match function_parameter with
            | (annot, field_annot) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Script_ir_annot.check_correct_field
                    field_annot expected_field_annot))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => typed ctxt loc Car (Item_t a rest annot)
                  end)
            end)
      |
        (Prim loc I_CDR [] annot,
          Item_t (Pair_t _ (b, expected_field_annot, b_annot) _ _) rest
            pair_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_destr_annot loc annot
            Tezos_raw_protocol_alpha.Script_ir_annot.default_cdr_annot
            expected_field_annot pair_annot b_annot)
          (fun function_parameter =>
            match function_parameter with
            | (annot, field_annot) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Script_ir_annot.check_correct_field
                    field_annot expected_field_annot))
                (fun function_parameter =>
                  match function_parameter with
                  | tt => typed ctxt loc Cdr (Item_t b rest annot)
                  end)
            end)
      | (Prim loc I_LEFT (cons tr []) annot, Item_t tl rest stack_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_any_ty ctxt legacy tr))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty tr, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_constr_annot loc
                  (Some
                    (Tezos_raw_protocol_alpha.Script_ir_annot.var_to_field_annot
                      stack_annot)) None annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (annot, tname, l_field, r_field) =>
                    typed ctxt loc Left
                      (Item_t
                        (Union_t (tl, l_field) (tr, r_field) tname
                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                            (has_big_map tl) (has_big_map tr))) rest annot)
                  end)
            end)
      | (Prim loc I_RIGHT (cons tl []) annot, Item_t tr rest stack_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_any_ty ctxt legacy tl))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty tl, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_constr_annot loc None
                  (Some
                    (Tezos_raw_protocol_alpha.Script_ir_annot.var_to_field_annot
                      stack_annot)) annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (annot, tname, l_field, r_field) =>
                    typed ctxt loc Right
                      (Item_t
                        (Union_t (tl, l_field) (tr, r_field) tname
                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                            (has_big_map tl) (has_big_map tr))) rest annot)
                  end)
            end)
      |
        (Prim loc I_IF_LEFT (cons bt (cons bf [])) annot,
          (Item_t (Union_t (tl, l_field) (tr, r_field) _ _) rest union_annot) as
            bef) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) bt)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_kind (cons Seq_kind []) bf)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                        loc annot)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let left_annot :=
                            Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                              union_annot
                              (Some
                                Tezos_raw_protocol_alpha.Script_ir_annot.default_left_annot)
                              l_field in
                          let right_annot :=
                            Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                              union_annot
                              (Some
                                Tezos_raw_protocol_alpha.Script_ir_annot.default_right_annot)
                              r_field in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (parse_instr type_logger tc_context ctxt legacy bt
                              (Item_t tl rest left_annot))
                            (fun function_parameter =>
                              match function_parameter with
                              | (btr, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (parse_instr type_logger tc_context ctxt
                                    legacy bf (Item_t tr rest right_annot))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (bfr, ctxt) =>
                                      let branch {B : Type}
                                        (ibt :
                                        Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          (op_dollar_7_7 * op_dollar_7_6) B)
                                        (ibf :
                                        Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          (op_dollar_7_8 * op_dollar_7_6) B)
                                        : Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          ((Tezos_raw_protocol_alpha.Script_typed_ir.union
                                            op_dollar_7_7 op_dollar_7_8) *
                                            op_dollar_7_6) B :=
                                        {| loc := loc; bef := bef;
                                          aft := aft ibt;
                                          instr := If_left ibt ibf |} in
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (merge_branches legacy ctxt loc btr bfr
                                          {| branch := branch |})
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (judgement, ctxt) =>
                                            _return ctxt judgement
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      | (Prim loc I_NIL (cons t []) annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_any_ty ctxt legacy t))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty t, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_type_annot loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (annot, ty_name) =>
                    typed ctxt loc Nil
                      (Item_t (List_t t ty_name (has_big_map t)) stack annot)
                  end)
            end)
      |
        (Prim loc I_CONS [] annot,
          Item_t tv (Item_t (List_t t ty_name has_big_map) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt tv t loc I_CONS 1 2)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, t, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc None annot)
                (fun annot =>
                  typed ctxt loc Cons_list
                    (Item_t (List_t t ty_name has_big_map) rest annot))
            end)
      |
        (Prim loc I_IF_CONS (cons bt (cons bf [])) annot,
          (Item_t (List_t t ty_name has_big_map) rest list_annot) as bef) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) bt)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_kind (cons Seq_kind []) bf)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                        loc annot)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let hd_annot :=
                            Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                              list_annot None
                              Tezos_raw_protocol_alpha.Script_ir_annot.default_hd_annot
                            in
                          let tl_annot :=
                            Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                              list_annot None
                              Tezos_raw_protocol_alpha.Script_ir_annot.default_tl_annot
                            in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (parse_instr type_logger tc_context ctxt legacy bt
                              (Item_t t
                                (Item_t (List_t t ty_name has_big_map) rest
                                  tl_annot) hd_annot))
                            (fun function_parameter =>
                              match function_parameter with
                              | (btr, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (parse_instr type_logger tc_context ctxt
                                    legacy bf rest)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (bfr, ctxt) =>
                                      let branch {B : Type}
                                        (ibt :
                                        Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          (op_dollar_8_6 *
                                            ((list op_dollar_8_6) *
                                              op_dollar_8_5)) B) (ibf :
                                        Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          op_dollar_8_5 B)
                                        : Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          ((list op_dollar_8_6) * op_dollar_8_5)
                                          B :=
                                        {| loc := loc; bef := bef;
                                          aft := aft ibt;
                                          instr := If_cons ibt ibf |} in
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (merge_branches legacy ctxt loc btr bfr
                                          {| branch := branch |})
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (judgement, ctxt) =>
                                            _return ctxt judgement
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      | (Prim loc I_SIZE [] annot, Item_t (List_t _ _ _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_type_annot loc annot)
          (fun function_parameter =>
            match function_parameter with
            | (annot, tname) =>
              typed ctxt loc List_size (Item_t (Nat_t tname) rest annot)
            end)
      |
        (Prim loc I_MAP (cons body []) annot,
          Item_t (List_t elt _ _) starting_rest list_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) body)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_type_annot loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (ret_annot, list_ty_name) =>
                    let elt_annot :=
                      Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                        list_annot None
                        Tezos_raw_protocol_alpha.Script_ir_annot.default_elt_annot
                      in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_instr type_logger tc_context ctxt legacy body
                        (Item_t elt starting_rest elt_annot))
                      (fun function_parameter =>
                        match function_parameter with
                        | (judgement, ctxt) =>
                          match judgement with
                          | Typed ({| aft := Item_t ret rest _ |} as ibody) =>
                            let invalid_map_body (function_parameter : unit)
                              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                  (serialize_stack_for_error ctxt (aft ibody))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (aft, _ctxt) => Invalid_map_body loc aft
                                    end)
                              end in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                              invalid_map_body
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (stack_ty_eq ctxt 1 rest starting_rest))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (Eq, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (merge_stacks legacy loc ctxt rest
                                          starting_rest))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (rest, ctxt) =>
                                          typed ctxt loc (List_map ibody)
                                            (Item_t
                                              (List_t ret list_ty_name
                                                (has_big_map ret)) rest
                                              ret_annot)
                                        end)
                                  end))
                          | Typed {| aft := aft |} =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (serialize_stack_for_error ctxt aft)
                              (fun function_parameter =>
                                match function_parameter with
                                | (aft, _ctxt) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                    (Invalid_map_body loc aft)
                                end)
                          | Failed _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                              (Invalid_map_block_fail loc)
                          end
                        end)
                  end)
            end)
      |
        (Prim loc I_ITER (cons body []) annot,
          Item_t (List_t elt _ _) rest list_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) body)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                  loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    let elt_annot :=
                      Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                        list_annot None
                        Tezos_raw_protocol_alpha.Script_ir_annot.default_elt_annot
                      in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_instr type_logger tc_context ctxt legacy body
                        (Item_t elt rest elt_annot))
                      (fun function_parameter =>
                        match function_parameter with
                        | (judgement, ctxt) =>
                          match judgement with
                          | Typed ({| aft := aft |} as ibody) =>
                            let invalid_iter_body (function_parameter : unit)
                              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (serialize_stack_for_error ctxt (aft ibody))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (aft, ctxt) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                        (serialize_stack_for_error ctxt rest)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (rest, _ctxt) =>
                                            Invalid_iter_body loc rest aft
                                          end)
                                    end)
                              end in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                              invalid_iter_body
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (stack_ty_eq ctxt 1 aft rest))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (Eq, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (merge_stacks legacy loc ctxt aft rest))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (rest, ctxt) =>
                                          typed ctxt loc (List_iter ibody) rest
                                        end)
                                  end))
                          | Failed {| descr := descr |} =>
                            typed ctxt loc (List_iter (descr rest)) rest
                          end
                        end)
                  end)
            end)
      | (Prim loc I_EMPTY_SET (cons t []) annot, rest) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_comparable_ty ctxt t))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_comparable_ty t, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_type_annot loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (annot, tname) =>
                    typed ctxt loc (Empty_set t)
                      (Item_t (Set_t t tname) rest annot)
                  end)
            end)
      |
        (Prim loc I_ITER (cons body []) annot,
          Item_t (Set_t comp_elt _) rest set_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) body)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                  loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    let elt_annot :=
                      Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                        set_annot None
                        Tezos_raw_protocol_alpha.Script_ir_annot.default_elt_annot
                      in
                    let elt := ty_of_comparable_ty comp_elt in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_instr type_logger tc_context ctxt legacy body
                        (Item_t elt rest elt_annot))
                      (fun function_parameter =>
                        match function_parameter with
                        | (judgement, ctxt) =>
                          match judgement with
                          | Typed ({| aft := aft |} as ibody) =>
                            let invalid_iter_body (function_parameter : unit)
                              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (serialize_stack_for_error ctxt (aft ibody))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (aft, ctxt) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                        (serialize_stack_for_error ctxt rest)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (rest, _ctxt) =>
                                            Invalid_iter_body loc rest aft
                                          end)
                                    end)
                              end in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                              invalid_iter_body
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (stack_ty_eq ctxt 1 aft rest))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (Eq, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (merge_stacks legacy loc ctxt aft rest))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (rest, ctxt) =>
                                          typed ctxt loc (Set_iter ibody) rest
                                        end)
                                  end))
                          | Failed {| descr := descr |} =>
                            typed ctxt loc (Set_iter (descr rest)) rest
                          end
                        end)
                  end)
            end)
      | (Prim loc I_MEM [] annot, Item_t v (Item_t (Set_t elt _) rest _) _) =>
        let elt := ty_of_comparable_ty elt in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_type_annot loc annot)
          (fun function_parameter =>
            match function_parameter with
            | (annot, tname) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_item_ty ctxt elt v loc I_MEM 1 2)
                (fun function_parameter =>
                  match function_parameter with
                  | (Eq, _, ctxt) =>
                    typed ctxt loc Set_mem (Item_t (Bool_t tname) rest annot)
                  end)
            end)
      |
        (Prim loc I_UPDATE [] annot,
          Item_t v
            (Item_t (Bool_t _) (Item_t (Set_t elt tname) rest set_annot) _) _)
        =>
        match comparable_ty_of_ty v with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (unparse_ty ctxt v)
            (fun function_parameter =>
              match function_parameter with
              | (v, _ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                  (Comparable_type_expected loc
                    (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                      v))
              end)
        | Some v =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (parse_var_annot loc (Some set_annot) annot)
            (fun annot =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_item_comparable_ty elt v loc I_UPDATE 1 3)
                (fun function_parameter =>
                  match function_parameter with
                  | (Eq, elt) =>
                    typed ctxt loc Set_update
                      (Item_t (Set_t elt tname) rest annot)
                  end))
        end
      | (Prim loc I_SIZE [] annot, Item_t (Set_t _ _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Set_size (Item_t (Nat_t None) rest annot))
      | (Prim loc I_EMPTY_MAP (cons tk (cons tv [])) annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_comparable_ty ctxt tk))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_comparable_ty tk, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (parse_any_ty ctxt legacy tv))
                (fun function_parameter =>
                  match function_parameter with
                  | (Ex_ty tv, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_var_type_annot loc annot)
                      (fun function_parameter =>
                        match function_parameter with
                        | (annot, ty_name) =>
                          typed ctxt loc (Empty_map tk tv)
                            (Item_t (Map_t tk tv ty_name (has_big_map tv)) stack
                              annot)
                        end)
                  end)
            end)
      |
        (Prim loc I_MAP (cons body []) annot,
          Item_t (Map_t ck elt _ _) starting_rest _map_annot) =>
        let k := ty_of_comparable_ty ck in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) body)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_type_annot loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (ret_annot, ty_name) =>
                    let k_name :=
                      Tezos_raw_protocol_alpha.Script_ir_annot.field_to_var_annot
                        Tezos_raw_protocol_alpha.Script_ir_annot.default_key_annot
                      in
                    let e_name :=
                      Tezos_raw_protocol_alpha.Script_ir_annot.field_to_var_annot
                        Tezos_raw_protocol_alpha.Script_ir_annot.default_elt_annot
                      in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_instr type_logger tc_context ctxt legacy body
                        (Item_t
                          (Pair_t (k, None, k_name) (elt, None, e_name) None
                            (has_big_map elt)) starting_rest None))
                      (fun function_parameter =>
                        match function_parameter with
                        | (judgement, ctxt) =>
                          match judgement with
                          | Typed ({| aft := Item_t ret rest _ |} as ibody) =>
                            let invalid_map_body (function_parameter : unit)
                              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                  (serialize_stack_for_error ctxt (aft ibody))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (aft, _ctxt) => Invalid_map_body loc aft
                                    end)
                              end in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                              invalid_map_body
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (stack_ty_eq ctxt 1 rest starting_rest))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (Eq, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (merge_stacks legacy loc ctxt rest
                                          starting_rest))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (rest, ctxt) =>
                                          typed ctxt loc (Map_map ibody)
                                            (Item_t
                                              (Map_t ck ret ty_name
                                                (has_big_map ret)) rest
                                              ret_annot)
                                        end)
                                  end))
                          | Typed {| aft := aft |} =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (serialize_stack_for_error ctxt aft)
                              (fun function_parameter =>
                                match function_parameter with
                                | (aft, _ctxt) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                                    (Invalid_map_body loc aft)
                                end)
                          | Failed _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                              (Invalid_map_block_fail loc)
                          end
                        end)
                  end)
            end)
      |
        (Prim loc I_ITER (cons body []) annot,
          Item_t (Map_t comp_elt element_ty _ _) rest _map_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) body)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                  loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    let k_name :=
                      Tezos_raw_protocol_alpha.Script_ir_annot.field_to_var_annot
                        Tezos_raw_protocol_alpha.Script_ir_annot.default_key_annot
                      in
                    let e_name :=
                      Tezos_raw_protocol_alpha.Script_ir_annot.field_to_var_annot
                        Tezos_raw_protocol_alpha.Script_ir_annot.default_elt_annot
                      in
                    let key := ty_of_comparable_ty comp_elt in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_instr type_logger tc_context ctxt legacy body
                        (Item_t
                          (Pair_t (key, None, k_name) (element_ty, None, e_name)
                            None (has_big_map element_ty)) rest None))
                      (fun function_parameter =>
                        match function_parameter with
                        | (judgement, ctxt) =>
                          match judgement with
                          | Typed ({| aft := aft |} as ibody) =>
                            let invalid_iter_body (function_parameter : unit)
                              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (serialize_stack_for_error ctxt (aft ibody))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (aft, ctxt) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                        (serialize_stack_for_error ctxt rest)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (rest, _ctxt) =>
                                            Invalid_iter_body loc rest aft
                                          end)
                                    end)
                              end in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                              invalid_iter_body
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (stack_ty_eq ctxt 1 aft rest))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (Eq, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (merge_stacks legacy loc ctxt aft rest))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (rest, ctxt) =>
                                          typed ctxt loc (Map_iter ibody) rest
                                        end)
                                  end))
                          | Failed {| descr := descr |} =>
                            typed ctxt loc (Map_iter (descr rest)) rest
                          end
                        end)
                  end)
            end)
      | (Prim loc I_MEM [] annot, Item_t vk (Item_t (Map_t ck _ _ _) rest _) _)
        =>
        let k := ty_of_comparable_ty ck in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt vk k loc I_MEM 1 2)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, _, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc None annot)
                (fun annot =>
                  typed ctxt loc Map_mem (Item_t (Bool_t None) rest annot))
            end)
      |
        (Prim loc I_GET [] annot,
          Item_t vk (Item_t (Map_t ck elt _ has_big_map) rest _) _) =>
        let k := ty_of_comparable_ty ck in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt vk k loc I_GET 1 2)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, _, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc None annot)
                (fun annot =>
                  typed ctxt loc Map_get
                    (Item_t (Option_t elt None has_big_map) rest annot))
            end)
      |
        (Prim loc I_UPDATE [] annot,
          Item_t vk
            (Item_t (Option_t vv _ _)
              (Item_t (Map_t ck v map_name has_big_map) rest map_annot) _) _) =>
        let k := ty_of_comparable_ty ck in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt vk k loc I_UPDATE 1 3)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, _, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_item_ty ctxt vv v loc I_UPDATE 2 3)
                (fun function_parameter =>
                  match function_parameter with
                  | (Eq, v, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_var_annot loc (Some map_annot) annot)
                      (fun annot =>
                        typed ctxt loc Map_update
                          (Item_t (Map_t ck v map_name has_big_map) rest annot))
                  end)
            end)
      | (Prim loc I_SIZE [] annot, Item_t (Map_t _ _ _ _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Map_size (Item_t (Nat_t None) rest annot))
      | (Prim loc I_EMPTY_BIG_MAP (cons tk (cons tv [])) annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_comparable_ty ctxt tk))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_comparable_ty tk, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (parse_packable_ty ctxt legacy tv))
                (fun function_parameter =>
                  match function_parameter with
                  | (Ex_ty tv, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_var_type_annot loc annot)
                      (fun function_parameter =>
                        match function_parameter with
                        | (annot, ty_name) =>
                          typed ctxt loc (Empty_big_map tk tv)
                            (Item_t (Big_map_t tk tv ty_name) stack annot)
                        end)
                  end)
            end)
      |
        (Prim loc I_MEM [] annot,
          Item_t set_key (Item_t (Big_map_t map_key _ _) rest _) _) =>
        let k := ty_of_comparable_ty map_key in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt set_key k loc I_MEM 1 2)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, _, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc None annot)
                (fun annot =>
                  typed ctxt loc Big_map_mem (Item_t (Bool_t None) rest annot))
            end)
      |
        (Prim loc I_GET [] annot,
          Item_t vk (Item_t (Big_map_t ck elt _) rest _) _) =>
        let k := ty_of_comparable_ty ck in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt vk k loc I_GET 1 2)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, _, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc None annot)
                (fun annot =>
                  typed ctxt loc Big_map_get
                    (Item_t (Option_t elt None (has_big_map elt)) rest annot))
            end)
      |
        (Prim loc I_UPDATE [] annot,
          Item_t set_key
            (Item_t (Option_t set_value _ _)
              (Item_t (Big_map_t map_key map_value map_name) rest map_annot) _)
            _) =>
        let k := ty_of_comparable_ty map_key in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt set_key k loc I_UPDATE 1 3)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, _, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_item_ty ctxt set_value map_value loc I_UPDATE 2 3)
                (fun function_parameter =>
                  match function_parameter with
                  | (Eq, map_value, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_var_annot loc (Some map_annot) annot)
                      (fun annot =>
                        typed ctxt loc Big_map_update
                          (Item_t (Big_map_t map_key map_value map_name) rest
                            annot))
                  end)
            end)
      | (Seq loc [], stack) => typed ctxt loc Nop stack
      | (Seq loc (cons single []), stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_instr type_logger tc_context ctxt legacy single stack)
          (fun function_parameter =>
            match function_parameter with
            | (judgement, ctxt) =>
              match judgement with
              | Typed ({| aft := aft |} as instr) =>
                let nop :=
                  {| loc := loc; bef := aft; aft := aft; instr := Nop |} in
                typed ctxt loc (Seq instr nop) aft
              | Failed {| descr := descr |} =>
                let descr {B : Type}
                  (aft : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
                  : Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
                  let nop :=
                    {| loc := loc; bef := aft; aft := aft; instr := Nop |} in
                  let descr := descr aft in
                  record in
                _return ctxt (Failed {| descr := descr |})
              end
            end)
      | (Seq loc (cons hd tl), stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_instr type_logger tc_context ctxt legacy hd stack)
          (fun function_parameter =>
            match function_parameter with
            | (judgement, ctxt) =>
              match judgement with
              | Failed _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                  (Fail_not_in_tail_position
                    (Tezos_protocol_environment_alpha__Environment.Micheline.location
                      hd))
              | Typed ({| aft := middle |} as ihd) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (parse_instr type_logger tc_context ctxt legacy (Seq (-1) tl)
                    middle)
                  (fun function_parameter =>
                    match function_parameter with
                    | (judgement, ctxt) =>
                      match judgement with
                      | Failed {| descr := descr |} =>
                        let descr {B : Type}
                          (ret :
                          Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
                          : Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
                          {| loc := loc; bef := stack; aft := ret;
                            instr := Seq ihd (descr ret) |} in
                        _return ctxt (Failed {| descr := descr |})
                      | Typed itl => typed ctxt loc (Seq ihd itl) (aft itl)
                      end
                    end)
              end
            end)
      |
        (Prim loc I_IF (cons bt (cons bf [])) annot,
          (Item_t (Bool_t _) rest _) as bef) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) bt)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_kind (cons Seq_kind []) bf)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                        loc annot)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (parse_instr type_logger tc_context ctxt legacy bt
                              rest)
                            (fun function_parameter =>
                              match function_parameter with
                              | (btr, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (parse_instr type_logger tc_context ctxt
                                    legacy bf rest)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (bfr, ctxt) =>
                                      let branch {B : Type}
                                        (ibt :
                                        Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          op_dollar_1_6_9 B) (ibf :
                                        Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          op_dollar_1_6_9 B)
                                        : Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                          (bool * op_dollar_1_6_9) B :=
                                        {| loc := loc; bef := bef;
                                          aft := aft ibt; instr := If ibt ibf |}
                                        in
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (merge_branches legacy ctxt loc btr bfr
                                          {| branch := branch |})
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (judgement, ctxt) =>
                                            _return ctxt judgement
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      |
        (Prim loc I_LOOP (cons body []) annot,
          (Item_t (Bool_t _) rest _stack_annot) as stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) body)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot
                  loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_instr type_logger tc_context ctxt legacy body rest)
                      (fun function_parameter =>
                        match function_parameter with
                        | (judgement, ctxt) =>
                          match judgement with
                          | Typed ibody =>
                            let unmatched_branches (function_parameter : unit)
                              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (serialize_stack_for_error ctxt (aft ibody))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (aft, ctxt) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                        (serialize_stack_for_error ctxt stack)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (stack, _ctxt) =>
                                            Unmatched_branches loc aft stack
                                          end)
                                    end)
                              end in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                              unmatched_branches
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (stack_ty_eq ctxt 1 (aft ibody) stack))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (Eq, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (merge_stacks legacy loc ctxt
                                          (aft ibody) stack))
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (_stack, ctxt) =>
                                          typed ctxt loc (Loop ibody) rest
                                        end)
                                  end))
                          | Failed {| descr := descr |} =>
                            let ibody := descr stack in
                            typed ctxt loc (Loop ibody) rest
                          end
                        end)
                  end)
            end)
      |
        (Prim loc I_LOOP_LEFT (cons body []) annot,
          (Item_t (Union_t (tl, l_field) (tr, _) _ _) rest union_annot) as stack)
        =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_kind (cons Seq_kind []) body)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc None annot)
                (fun annot =>
                  let l_annot :=
                    Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                      union_annot
                      (Some
                        Tezos_raw_protocol_alpha.Script_ir_annot.default_left_annot)
                      l_field in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (parse_instr type_logger tc_context ctxt legacy body
                      (Item_t tl rest l_annot))
                    (fun function_parameter =>
                      match function_parameter with
                      | (judgement, ctxt) =>
                        match judgement with
                        | Typed ibody =>
                          let unmatched_branches (function_parameter : unit)
                            : Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                            match function_parameter with
                            | tt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (serialize_stack_for_error ctxt (aft ibody))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (aft, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                      (serialize_stack_for_error ctxt stack)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (stack, _ctxt) =>
                                          Unmatched_branches loc aft stack
                                        end)
                                  end)
                            end in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                            unmatched_branches
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                Tezos_protocol_environment_alpha__Environment.Lwt._return
                                (stack_ty_eq ctxt 1 (aft ibody) stack))
                              (fun function_parameter =>
                                match function_parameter with
                                | (Eq, ctxt) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                                      (merge_stacks legacy loc ctxt (aft ibody)
                                        stack))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (_stack, ctxt) =>
                                        typed ctxt loc (Loop_left ibody)
                                          (Item_t tr rest annot)
                                      end)
                                end))
                        | Failed {| descr := descr |} =>
                          let ibody := descr stack in
                          typed ctxt loc (Loop_left ibody)
                            (Item_t tr rest annot)
                        end
                      end))
            end)
      | (Prim loc I_LAMBDA (cons arg (cons ret (cons code []))) annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_any_ty ctxt legacy arg))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty arg, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (parse_any_ty ctxt legacy ret))
                (fun function_parameter =>
                  match function_parameter with
                  | (Ex_ty ret, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (check_kind (cons Seq_kind []) code)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (parse_var_annot loc None annot)
                            (fun annot =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (parse_returning type_logger Lambda ctxt legacy
                                  (arg,
                                    Tezos_raw_protocol_alpha.Script_ir_annot.default_arg_annot)
                                  ret code)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (lambda, ctxt) =>
                                    typed ctxt loc (Lambda lambda)
                                      (Item_t (Lambda_t arg ret None) stack
                                        annot)
                                  end))
                        end)
                  end)
            end)
      |
        (Prim loc I_EXEC [] annot,
          Item_t arg (Item_t (Lambda_t param ret _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt arg param loc I_EXEC 1 2)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, _, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc None annot)
                (fun annot => typed ctxt loc Exec (Item_t ret rest annot))
            end)
      |
        (Prim loc I_APPLY [] annot,
          Item_t capture
            (Item_t
              (Lambda_t (Pair_t (capture_ty, _, _) (arg_ty, _, _) lam_annot _)
                ret _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (check_packable false loc capture_ty))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_item_ty ctxt capture capture_ty loc I_APPLY 1 2)
                (fun function_parameter =>
                  match function_parameter with
                  | (Eq, capture_ty, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_var_annot loc None annot)
                      (fun annot =>
                        typed ctxt loc (Apply capture_ty)
                          (Item_t (Lambda_t arg_ty ret lam_annot) rest annot))
                  end)
            end)
      | (Prim loc I_DIP (cons code []) annot, Item_t v rest stack_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
            annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_kind (cons Seq_kind []) code)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (parse_instr type_logger
                        (add_dip v stack_annot tc_context) ctxt legacy code rest)
                      (fun function_parameter =>
                        match function_parameter with
                        | (judgement, ctxt) =>
                          match judgement with
                          | Typed descr =>
                            typed ctxt loc (Dip descr)
                              (Item_t v (aft descr) stack_annot)
                          | Failed _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                              (Fail_not_in_tail_position loc)
                          end
                        end)
                  end)
            end)
      | (Prim loc I_DIP (([] | cons _ (cons _ (cons _ _))) as l) _, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc I_DIP 2
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      | (Prim loc I_FAILWITH [] annot, Item_t v _rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Script_ir_annot.fail_unexpected_annot loc
            annot)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let descr {B : Type}
                (aft : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
                : Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
                {| loc := loc; bef := stack_ty; aft := aft; instr := Failwith v
                  |} in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (log_stack ctxt loc stack_ty Empty_t)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => _return ctxt (Failed {| descr := descr |})
                  end)
            end)
      |
        (Prim loc I_ADD [] annot,
          Item_t (Timestamp_t tname) (Item_t (Int_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Add_timestamp_to_seconds
              (Item_t (Timestamp_t tname) rest annot))
      |
        (Prim loc I_ADD [] annot,
          Item_t (Int_t _) (Item_t (Timestamp_t tname) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Add_seconds_to_timestamp
              (Item_t (Timestamp_t tname) rest annot))
      |
        (Prim loc I_SUB [] annot,
          Item_t (Timestamp_t tname) (Item_t (Int_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Sub_timestamp_seconds
              (Item_t (Timestamp_t tname) rest annot))
      |
        (Prim loc I_SUB [] annot,
          Item_t (Timestamp_t tn1) (Item_t (Timestamp_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Diff_timestamps (Item_t (Int_t tname) rest annot)))
      |
        (Prim loc I_CONCAT [] annot,
          Item_t (String_t tn1) (Item_t (String_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Concat_string_pair
                  (Item_t (String_t tname) rest annot)))
      |
        (Prim loc I_CONCAT [] annot,
          Item_t (List_t (String_t tname) _ _) rest list_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc (Some list_annot) annot)
          (fun annot =>
            typed ctxt loc Concat_string (Item_t (String_t tname) rest annot))
      |
        (Prim loc I_SLICE [] annot,
          Item_t (Nat_t _)
            (Item_t (Nat_t _) (Item_t (String_t tname) rest string_annot) _) _)
        =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc
            (Some
              (Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                string_annot None
                Tezos_raw_protocol_alpha.Script_ir_annot.default_slice_annot))
            annot)
          (fun annot =>
            typed ctxt loc Slice_string
              (Item_t (Option_t (String_t tname) None false) rest annot))
      | (Prim loc I_SIZE [] annot, Item_t (String_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc String_size (Item_t (Nat_t None) rest annot))
      |
        (Prim loc I_CONCAT [] annot,
          Item_t (Bytes_t tn1) (Item_t (Bytes_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Concat_bytes_pair
                  (Item_t (Bytes_t tname) rest annot)))
      |
        (Prim loc I_CONCAT [] annot,
          Item_t (List_t (Bytes_t tname) _ _) rest list_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc (Some list_annot) annot)
          (fun annot =>
            typed ctxt loc Concat_bytes (Item_t (Bytes_t tname) rest annot))
      |
        (Prim loc I_SLICE [] annot,
          Item_t (Nat_t _)
            (Item_t (Nat_t _) (Item_t (Bytes_t tname) rest bytes_annot) _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc
            (Some
              (Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                bytes_annot None
                Tezos_raw_protocol_alpha.Script_ir_annot.default_slice_annot))
            annot)
          (fun annot =>
            typed ctxt loc Slice_bytes
              (Item_t (Option_t (Bytes_t tname) None false) rest annot))
      | (Prim loc I_SIZE [] annot, Item_t (Bytes_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Bytes_size (Item_t (Nat_t None) rest annot))
      |
        (Prim loc I_ADD [] annot,
          Item_t (Mutez_t tn1) (Item_t (Mutez_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Add_tez (Item_t (Mutez_t tname) rest annot)))
      |
        (Prim loc I_SUB [] annot,
          Item_t (Mutez_t tn1) (Item_t (Mutez_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Sub_tez (Item_t (Mutez_t tname) rest annot)))
      |
        (Prim loc I_MUL [] annot,
          Item_t (Mutez_t tname) (Item_t (Nat_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Mul_teznat (Item_t (Mutez_t tname) rest annot))
      |
        (Prim loc I_MUL [] annot,
          Item_t (Nat_t _) (Item_t (Mutez_t tname) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Mul_nattez (Item_t (Mutez_t tname) rest annot))
      |
        (Prim loc I_OR [] annot,
          Item_t (Bool_t tn1) (Item_t (Bool_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname => typed ctxt loc Or (Item_t (Bool_t tname) rest annot)))
      |
        (Prim loc I_AND [] annot,
          Item_t (Bool_t tn1) (Item_t (Bool_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc And (Item_t (Bool_t tname) rest annot)))
      |
        (Prim loc I_XOR [] annot,
          Item_t (Bool_t tn1) (Item_t (Bool_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Xor (Item_t (Bool_t tname) rest annot)))
      | (Prim loc I_NOT [] annot, Item_t (Bool_t tname) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Not (Item_t (Bool_t tname) rest annot))
      | (Prim loc I_ABS [] annot, Item_t (Int_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Abs_int (Item_t (Nat_t None) rest annot))
      | (Prim loc I_ISNAT [] annot, Item_t (Int_t _) rest int_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc (Some int_annot) annot)
          (fun annot =>
            typed ctxt loc Is_nat
              (Item_t (Option_t (Nat_t None) None false) rest annot))
      | (Prim loc I_INT [] annot, Item_t (Nat_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Int_nat (Item_t (Int_t None) rest annot))
      | (Prim loc I_NEG [] annot, Item_t (Int_t tname) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Neg_int (Item_t (Int_t tname) rest annot))
      | (Prim loc I_NEG [] annot, Item_t (Nat_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Neg_nat (Item_t (Int_t None) rest annot))
      |
        (Prim loc I_ADD [] annot,
          Item_t (Int_t tn1) (Item_t (Int_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Add_intint (Item_t (Int_t tname) rest annot)))
      |
        (Prim loc I_ADD [] annot,
          Item_t (Int_t tname) (Item_t (Nat_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Add_intnat (Item_t (Int_t tname) rest annot))
      |
        (Prim loc I_ADD [] annot,
          Item_t (Nat_t _) (Item_t (Int_t tname) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Add_natint (Item_t (Int_t tname) rest annot))
      |
        (Prim loc I_ADD [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Add_natnat (Item_t (Nat_t tname) rest annot)))
      |
        (Prim loc I_SUB [] annot,
          Item_t (Int_t tn1) (Item_t (Int_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Sub_int (Item_t (Int_t tname) rest annot)))
      |
        (Prim loc I_SUB [] annot,
          Item_t (Int_t tname) (Item_t (Nat_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Sub_int (Item_t (Int_t tname) rest annot))
      |
        (Prim loc I_SUB [] annot,
          Item_t (Nat_t _) (Item_t (Int_t tname) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Sub_int (Item_t (Int_t tname) rest annot))
      |
        (Prim loc I_SUB [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun _tname =>
                typed ctxt loc Sub_int (Item_t (Int_t None) rest annot)))
      |
        (Prim loc I_MUL [] annot,
          Item_t (Int_t tn1) (Item_t (Int_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Mul_intint (Item_t (Int_t tname) rest annot)))
      |
        (Prim loc I_MUL [] annot,
          Item_t (Int_t tname) (Item_t (Nat_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Mul_intnat (Item_t (Int_t tname) rest annot))
      |
        (Prim loc I_MUL [] annot,
          Item_t (Nat_t _) (Item_t (Int_t tname) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Mul_natint (Item_t (Int_t tname) rest annot))
      |
        (Prim loc I_MUL [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Mul_natnat (Item_t (Nat_t tname) rest annot)))
      |
        (Prim loc I_EDIV [] annot,
          Item_t (Mutez_t tname) (Item_t (Nat_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Ediv_teznat
              (Item_t
                (Option_t
                  (Pair_t ((Mutez_t tname), None, None)
                    ((Mutez_t tname), None, None) None false) None false) rest
                annot))
      |
        (Prim loc I_EDIV [] annot,
          Item_t (Mutez_t tn1) (Item_t (Mutez_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Ediv_tez
                  (Item_t
                    (Option_t
                      (Pair_t ((Nat_t None), None, None)
                        ((Mutez_t tname), None, None) None false) None false)
                    rest annot)))
      |
        (Prim loc I_EDIV [] annot,
          Item_t (Int_t tn1) (Item_t (Int_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Ediv_intint
                  (Item_t
                    (Option_t
                      (Pair_t ((Int_t tname), None, None)
                        ((Nat_t None), None, None) None false) None false) rest
                    annot)))
      |
        (Prim loc I_EDIV [] annot,
          Item_t (Int_t tname) (Item_t (Nat_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Ediv_intnat
              (Item_t
                (Option_t
                  (Pair_t ((Int_t tname), None, None) ((Nat_t None), None, None)
                    None false) None false) rest annot))
      |
        (Prim loc I_EDIV [] annot,
          Item_t (Nat_t tname) (Item_t (Int_t _) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Ediv_natint
              (Item_t
                (Option_t
                  (Pair_t ((Int_t None), None, None) ((Nat_t tname), None, None)
                    None false) None false) rest annot))
      |
        (Prim loc I_EDIV [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Ediv_natnat
                  (Item_t
                    (Option_t
                      (Pair_t ((Nat_t tname), None, None)
                        ((Nat_t tname), None, None) None false) None false) rest
                    annot)))
      |
        (Prim loc I_LSL [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Lsl_nat (Item_t (Nat_t tname) rest annot)))
      |
        (Prim loc I_LSR [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Lsr_nat (Item_t (Nat_t tname) rest annot)))
      |
        (Prim loc I_OR [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Or_nat (Item_t (Nat_t tname) rest annot)))
      |
        (Prim loc I_AND [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc And_nat (Item_t (Nat_t tname) rest annot)))
      |
        (Prim loc I_AND [] annot,
          Item_t (Int_t _) (Item_t (Nat_t tname) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc And_int_nat (Item_t (Nat_t tname) rest annot))
      |
        (Prim loc I_XOR [] annot,
          Item_t (Nat_t tn1) (Item_t (Nat_t tn2) rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Script_ir_annot.merge_type_annot
                  legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Xor_nat (Item_t (Nat_t tname) rest annot)))
      | (Prim loc I_NOT [] annot, Item_t (Int_t tname) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Not_int (Item_t (Int_t tname) rest annot))
      | (Prim loc I_NOT [] annot, Item_t (Nat_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Not_nat (Item_t (Int_t None) rest annot))
      | (Prim loc I_COMPARE [] annot, Item_t t1 (Item_t t2 rest _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (check_item_ty ctxt t1 t2 loc I_COMPARE 1 2)
              (fun function_parameter =>
                match function_parameter with
                | (Eq, t, ctxt) =>
                  match comparable_ty_of_ty t with
                  | None =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (serialize_ty_for_error ctxt t))
                      (fun function_parameter =>
                        match function_parameter with
                        | (t, _ctxt) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                            (Comparable_type_expected loc t)
                        end)
                  | Some key =>
                    typed ctxt loc (Compare key)
                      (Item_t (Int_t None) rest annot)
                  end
                end))
      | (Prim loc I_EQ [] annot, Item_t (Int_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Eq (Item_t (Bool_t None) rest annot))
      | (Prim loc I_NEQ [] annot, Item_t (Int_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Neq (Item_t (Bool_t None) rest annot))
      | (Prim loc I_LT [] annot, Item_t (Int_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Lt (Item_t (Bool_t None) rest annot))
      | (Prim loc I_GT [] annot, Item_t (Int_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Gt (Item_t (Bool_t None) rest annot))
      | (Prim loc I_LE [] annot, Item_t (Int_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Le (Item_t (Bool_t None) rest annot))
      | (Prim loc I_GE [] annot, Item_t (Int_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Ge (Item_t (Bool_t None) rest annot))
      | (Prim loc I_CAST (cons cast_t []) annot, Item_t t stack item_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc (Some item_annot) annot)
          (fun annot =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (parse_any_ty ctxt legacy cast_t))
              (fun function_parameter =>
                match function_parameter with
                | (Ex_ty cast_t, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (ty_eq ctxt cast_t t))
                    (fun function_parameter =>
                      match function_parameter with
                      | (Eq, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                            Tezos_protocol_environment_alpha__Environment.Lwt._return
                            (merge_types legacy ctxt loc cast_t t))
                          (fun function_parameter =>
                            match function_parameter with
                            | (_, ctxt) =>
                              typed ctxt loc Nop (Item_t cast_t stack annot)
                            end)
                      end)
                end))
      | (Prim loc I_RENAME [] annot, Item_t t stack _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Nop (Item_t t stack annot))
      | (Prim loc I_PACK [] annot, Item_t t rest unpacked_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (check_packable true loc t))
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc
                  (Some
                    (Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                      unpacked_annot None
                      Tezos_raw_protocol_alpha.Script_ir_annot.default_pack_annot))
                  annot)
                (fun annot =>
                  typed ctxt loc (Pack t) (Item_t (Bytes_t None) rest annot))
            end)
      |
        (Prim loc I_UNPACK (cons ty []) annot,
          Item_t (Bytes_t _) rest packed_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_packable_ty ctxt legacy ty))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty t, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_type_annot loc annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (annot, ty_name) =>
                    let annot :=
                      Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                        (Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                          packed_annot None
                          Tezos_raw_protocol_alpha.Script_ir_annot.default_unpack_annot)
                        annot in
                    typed ctxt loc (Unpack t)
                      (Item_t (Option_t t ty_name false) rest annot)
                  end)
            end)
      |
        (Prim loc I_ADDRESS [] annot,
          Item_t (Contract_t _ _) rest contract_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc
            (Some
              (Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                contract_annot None
                Tezos_raw_protocol_alpha.Script_ir_annot.default_addr_annot))
            annot)
          (fun annot =>
            typed ctxt loc Address (Item_t (Address_t None) rest annot))
      |
        (Prim loc I_CONTRACT (cons ty []) annot,
          Item_t (Address_t _) rest addr_annot) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (parse_parameter_ty ctxt legacy ty))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty t, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_entrypoint_annot loc
                  (Some
                    (Tezos_raw_protocol_alpha.Script_ir_annot.gen_access_annot
                      addr_annot None
                      Tezos_raw_protocol_alpha.Script_ir_annot.default_contract_annot))
                  annot)
                (fun function_parameter =>
                  match function_parameter with
                  | (annot, entrypoint) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                        match entrypoint with
                        | None => inl "default" % string
                        | Some (Field_annot "default" % string) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.error
                            (Unexpected_annotation loc)
                        | Some (Field_annot entrypoint) =>
                          if
                            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                              (Tezos_protocol_environment_alpha__Environment.String.length
                                entrypoint) 31 then
                            Tezos_protocol_environment_alpha__Environment.Error_monad.error
                              (Entrypoint_name_too_long entrypoint)
                          else
                            inl entrypoint
                        end)
                      (fun entrypoint =>
                        typed ctxt loc (Contract t entrypoint)
                          (Item_t (Option_t (Contract_t t None) None false) rest
                            annot))
                  end)
            end)
      |
        (Prim loc I_TRANSFER_TOKENS [] annot,
          Item_t p (Item_t (Mutez_t _) (Item_t (Contract_t cp _) rest _) _) _)
        =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4)
          (fun function_parameter =>
            match function_parameter with
            | (Eq, _, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (parse_var_annot loc None annot)
                (fun annot =>
                  typed ctxt loc Transfer_tokens
                    (Item_t (Operation_t None) rest annot))
            end)
      |
        (Prim loc I_SET_DELEGATE [] annot,
          Item_t (Option_t (Key_hash_t _) _ _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Set_delegate (Item_t (Operation_t None) rest annot))
      |
        (Prim loc I_CREATE_ACCOUNT [] annot,
          Item_t (Key_hash_t _)
            (Item_t (Option_t (Key_hash_t _) _ _)
              (Item_t (Bool_t _) (Item_t (Mutez_t _) rest _) _) _) _) =>
        if legacy then
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (parse_two_var_annot loc annot)
            (fun function_parameter =>
              match function_parameter with
              | (op_annot, addr_annot) =>
                typed ctxt loc Create_account
                  (Item_t (Operation_t None)
                    (Item_t (Address_t None) rest addr_annot) op_annot)
              end)
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Deprecated_instruction I_CREATE_ACCOUNT)
      | (Prim loc I_IMPLICIT_ACCOUNT [] annot, Item_t (Key_hash_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Implicit_account
              (Item_t (Contract_t (Unit_t None) None) rest annot))
      |
        (Prim loc I_CREATE_CONTRACT (cons ((Seq _ _) as code) []) annot,
          Item_t (Key_hash_t _)
            (Item_t (Option_t (Key_hash_t _) _ _)
              (Item_t (Bool_t _)
                (Item_t (Bool_t _) (Item_t (Mutez_t _) (Item_t ginit rest _) _)
                  _) _) _) _) =>
        if legacy then
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (parse_two_var_annot loc annot)
            (fun function_parameter =>
              match function_parameter with
              | (op_annot, addr_annot) =>
                let cannonical_code :=
                  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                    Tezos_protocol_environment_alpha__Environment.Pervasives.fst
                    (Tezos_protocol_environment_alpha__Environment.Micheline.extract_locations
                      code) in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                    Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (parse_toplevel legacy cannonical_code))
                  (fun function_parameter =>
                    match function_parameter with
                    | (arg_type, storage_type, code_field, root_name) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                          (Ill_formed_type (Some "parameter" % string)
                            cannonical_code (location arg_type))
                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                            Tezos_protocol_environment_alpha__Environment.Lwt._return
                            (parse_parameter_ty ctxt legacy arg_type)))
                        (fun function_parameter =>
                          match function_parameter with
                          | (Ex_ty arg_type, ctxt) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (if legacy then
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  tt
                              else
                                Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (well_formed_entrypoints arg_type root_name))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                      (Ill_formed_type (Some "storage" % string)
                                        cannonical_code (location storage_type))
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (parse_storage_ty ctxt legacy
                                          storage_type)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (Ex_ty storage_type, ctxt) =>
                                        let arg_annot :=
                                          Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                                            Tezos_raw_protocol_alpha.Script_ir_annot.default_param_annot
                                            (Tezos_raw_protocol_alpha.Script_ir_annot.type_to_var_annot
                                              (name_of_ty arg_type)) in
                                        let storage_annot :=
                                          Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                                            Tezos_raw_protocol_alpha.Script_ir_annot.default_storage_annot
                                            (Tezos_raw_protocol_alpha.Script_ir_annot.type_to_var_annot
                                              (name_of_ty storage_type)) in
                                        let arg_type_full :=
                                          Pair_t (arg_type, None, arg_annot)
                                            (storage_type, None, storage_annot)
                                            None
                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                                              (has_big_map arg_type)
                                              (has_big_map storage_type)) in
                                        let ret_type_full :=
                                          Pair_t
                                            ((List_t (Operation_t None) None
                                              false), None, None)
                                            (storage_type, None, None) None
                                            (has_big_map storage_type) in
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                            (Ill_typed_contract cannonical_code
                                              [])
                                            (parse_returning type_logger
                                              (Toplevel
                                                {| storage_type := storage_type;
                                                  param_type := arg_type;
                                                  root_name := root_name;
                                                  legacy_create_contract_literal :=
                                                    true |}) ctxt legacy
                                              (arg_type_full, None)
                                              ret_type_full code_field))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              ((Lam {|
                                                bef := Item_t arg Empty_t _;
                                                  aft := Item_t ret Empty_t _
                                                  |} _) as lambda, ctxt) =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                  (ty_eq ctxt arg arg_type_full))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (Eq, ctxt) =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                        (merge_types legacy ctxt
                                                          loc arg arg_type_full))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | (_, ctxt) =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                              Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                              (ty_eq ctxt ret
                                                                ret_type_full))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | (Eq, ctxt) =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                                    Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                    (merge_types
                                                                      legacy
                                                                      ctxt loc
                                                                      ret
                                                                      ret_type_full))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | (_, ctxt)
                                                                      =>
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                                          Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                          (ty_eq
                                                                            ctxt
                                                                            storage_type
                                                                            ginit))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          |
                                                                            (Eq,
                                                                              ctxt)
                                                                            =>
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                                                Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                                (merge_types
                                                                                  legacy
                                                                                  ctxt
                                                                                  loc
                                                                                  storage_type
                                                                                  ginit))
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  (_,
                                                                                    ctxt)
                                                                                  =>
                                                                                  typed
                                                                                    ctxt
                                                                                    loc
                                                                                    (Create_contract
                                                                                      storage_type
                                                                                      arg_type
                                                                                      lambda
                                                                                      root_name)
                                                                                    (Item_t
                                                                                      (Operation_t
                                                                                        None)
                                                                                      (Item_t
                                                                                        (Address_t
                                                                                          None)
                                                                                        rest
                                                                                        addr_annot)
                                                                                      op_annot)
                                                                                end)
                                                                          end)
                                                                    end)
                                                              end)
                                                        end)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end)
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Deprecated_instruction I_CREATE_CONTRACT)
      |
        (Prim loc I_CREATE_CONTRACT (cons ((Seq _ _) as code) []) annot,
          Item_t (Option_t (Key_hash_t _) _ _)
            (Item_t (Mutez_t _) (Item_t ginit rest _) _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_two_var_annot loc annot)
          (fun function_parameter =>
            match function_parameter with
            | (op_annot, addr_annot) =>
              let cannonical_code :=
                Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  Tezos_protocol_environment_alpha__Environment.Pervasives.fst
                  (Tezos_protocol_environment_alpha__Environment.Micheline.extract_locations
                    code) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (parse_toplevel legacy cannonical_code))
                (fun function_parameter =>
                  match function_parameter with
                  | (arg_type, storage_type, code_field, root_name) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                        (Ill_formed_type (Some "parameter" % string)
                          cannonical_code (location arg_type))
                        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                          Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (parse_parameter_ty ctxt legacy arg_type)))
                      (fun function_parameter =>
                        match function_parameter with
                        | (Ex_ty arg_type, ctxt) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (if legacy then
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                tt
                            else
                              Tezos_protocol_environment_alpha__Environment.Lwt._return
                                (well_formed_entrypoints arg_type root_name))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                    (Ill_formed_type (Some "storage" % string)
                                      cannonical_code (location storage_type))
                                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                                      (parse_storage_ty ctxt legacy storage_type)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (Ex_ty storage_type, ctxt) =>
                                      let arg_annot :=
                                        Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                                          Tezos_raw_protocol_alpha.Script_ir_annot.default_param_annot
                                          (Tezos_raw_protocol_alpha.Script_ir_annot.type_to_var_annot
                                            (name_of_ty arg_type)) in
                                      let storage_annot :=
                                        Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                                          Tezos_raw_protocol_alpha.Script_ir_annot.default_storage_annot
                                          (Tezos_raw_protocol_alpha.Script_ir_annot.type_to_var_annot
                                            (name_of_ty storage_type)) in
                                      let arg_type_full :=
                                        Pair_t (arg_type, None, arg_annot)
                                          (storage_type, None, storage_annot)
                                          None
                                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                                            (has_big_map arg_type)
                                            (has_big_map storage_type)) in
                                      let ret_type_full :=
                                        Pair_t
                                          ((List_t (Operation_t None) None false),
                                            None, None)
                                          (storage_type, None, None) None
                                          (has_big_map storage_type) in
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                          (Ill_typed_contract cannonical_code [])
                                          (parse_returning type_logger
                                            (Toplevel
                                              {| storage_type := storage_type;
                                                param_type := arg_type;
                                                root_name := root_name;
                                                legacy_create_contract_literal :=
                                                  false |}) ctxt legacy
                                            (arg_type_full, None) ret_type_full
                                            code_field))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            ((Lam {|
                                              bef := Item_t arg Empty_t _;
                                                aft := Item_t ret Empty_t _
                                                |} _) as lambda, ctxt) =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                (ty_eq ctxt arg arg_type_full))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (Eq, ctxt) =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                      (merge_types legacy ctxt
                                                        loc arg arg_type_full))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | (_, ctxt) =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                            Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                            (ty_eq ctxt ret
                                                              ret_type_full))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | (Eq, ctxt) =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                  (merge_types
                                                                    legacy ctxt
                                                                    loc ret
                                                                    ret_type_full))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | (_, ctxt) =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                        (ty_eq
                                                                          ctxt
                                                                          storage_type
                                                                          ginit))
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        |
                                                                          (Eq,
                                                                            ctxt)
                                                                          =>
                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                                              Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                              (merge_types
                                                                                legacy
                                                                                ctxt
                                                                                loc
                                                                                storage_type
                                                                                ginit))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                (_,
                                                                                  ctxt)
                                                                                =>
                                                                                typed
                                                                                  ctxt
                                                                                  loc
                                                                                  (Create_contract_2
                                                                                    storage_type
                                                                                    arg_type
                                                                                    lambda
                                                                                    root_name)
                                                                                  (Item_t
                                                                                    (Operation_t
                                                                                      None)
                                                                                    (Item_t
                                                                                      (Address_t
                                                                                        None)
                                                                                      rest
                                                                                      addr_annot)
                                                                                    op_annot)
                                                                              end)
                                                                        end)
                                                                  end)
                                                            end)
                                                      end)
                                                end)
                                          end)
                                    end)
                              end)
                        end)
                  end)
            end)
      | (Prim loc I_NOW [] annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc
            (Some Tezos_raw_protocol_alpha.Script_ir_annot.default_now_annot)
            annot)
          (fun annot =>
            typed ctxt loc Now (Item_t (Timestamp_t None) stack annot))
      | (Prim loc I_AMOUNT [] annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc
            (Some Tezos_raw_protocol_alpha.Script_ir_annot.default_amount_annot)
            annot)
          (fun annot =>
            typed ctxt loc Amount (Item_t (Mutez_t None) stack annot))
      | (Prim loc I_CHAIN_ID [] annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc ChainId (Item_t (Chain_id_t None) stack annot))
      | (Prim loc I_BALANCE [] annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc
            (Some Tezos_raw_protocol_alpha.Script_ir_annot.default_balance_annot)
            annot)
          (fun annot =>
            typed ctxt loc Balance (Item_t (Mutez_t None) stack annot))
      | (Prim loc I_HASH_KEY [] annot, Item_t (Key_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Hash_key (Item_t (Key_hash_t None) rest annot))
      |
        (Prim loc I_CHECK_SIGNATURE [] annot,
          Item_t (Key_t _)
            (Item_t (Signature_t _) (Item_t (Bytes_t _) rest _) _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Check_signature (Item_t (Bool_t None) rest annot))
      | (Prim loc I_BLAKE2B [] annot, Item_t (Bytes_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Blake2b (Item_t (Bytes_t None) rest annot))
      | (Prim loc I_SHA256 [] annot, Item_t (Bytes_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Sha256 (Item_t (Bytes_t None) rest annot))
      | (Prim loc I_SHA512 [] annot, Item_t (Bytes_t _) rest _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc None annot)
          (fun annot => typed ctxt loc Sha512 (Item_t (Bytes_t None) rest annot))
      | (Prim loc I_STEPS_TO_QUOTA [] annot, stack) =>
        if legacy then
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (parse_var_annot loc
              (Some Tezos_raw_protocol_alpha.Script_ir_annot.default_steps_annot)
              annot)
            (fun annot =>
              typed ctxt loc Steps_to_quota (Item_t (Nat_t None) stack annot))
        else
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
            (Deprecated_instruction I_STEPS_TO_QUOTA)
      | (Prim loc I_SOURCE [] annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc
            (Some Tezos_raw_protocol_alpha.Script_ir_annot.default_source_annot)
            annot)
          (fun annot =>
            typed ctxt loc Source (Item_t (Address_t None) stack annot))
      | (Prim loc I_SENDER [] annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_var_annot loc
            (Some Tezos_raw_protocol_alpha.Script_ir_annot.default_sender_annot)
            annot)
          (fun annot =>
            typed ctxt loc Sender (Item_t (Address_t None) stack annot))
      | (Prim loc I_SELF [] annot, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (parse_entrypoint_annot loc
            (Some Tezos_raw_protocol_alpha.Script_ir_annot.default_self_annot)
            annot)
          (fun function_parameter =>
            match function_parameter with
            | (annot, entrypoint) =>
              let entrypoint :=
                Tezos_protocol_environment_alpha__Environment.Option.unopt_map
                  (fun function_parameter =>
                    match function_parameter with
                    | Field_annot annot => annot
                    end) "default" % string entrypoint in
              let fix get_toplevel_type (function_parameter : tc_context)
                : Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    ((judgement bef) *
                      Tezos_raw_protocol_alpha.Alpha_context.context)) :=
                match function_parameter with
                | Lambda =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                    (Self_in_lambda loc)
                | Dip _ prev => get_toplevel_type prev
                |
                  Toplevel {|
                    param_type := param_type;
                      root_name := root_name;
                      legacy_create_contract_literal := false
                      |} =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (find_entrypoint param_type root_name entrypoint))
                    (fun function_parameter =>
                      match function_parameter with
                      | (_, Ex_ty param_type) =>
                        typed ctxt loc (Self param_type entrypoint)
                          (Item_t (Contract_t param_type None) stack annot)
                      end)
                |
                  Toplevel {|
                    param_type := param_type;
                      root_name := _;
                      legacy_create_contract_literal := true
                      |} =>
                  typed ctxt loc (Self param_type "default" % string)
                    (Item_t (Contract_t param_type None) stack annot)
                end in
              get_toplevel_type tc_context
            end)
      |
        (Prim loc
          ((I_DUP | I_SWAP | I_SOME | I_UNIT | I_PAIR | I_CAR | I_CDR | I_CONS |
            I_CONCAT | I_SLICE | I_MEM | I_UPDATE | I_MAP | I_GET | I_EXEC |
            I_FAILWITH | I_SIZE | I_ADD | I_SUB | I_MUL | I_EDIV | I_OR | I_AND
            | I_XOR | I_NOT | I_ABS | I_NEG | I_LSL | I_LSR | I_COMPARE | I_EQ |
            I_NEQ | I_LT | I_GT | I_LE | I_GE | I_TRANSFER_TOKENS |
            I_CREATE_ACCOUNT | I_SET_DELEGATE | I_NOW | I_IMPLICIT_ACCOUNT |
            I_AMOUNT | I_BALANCE | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE |
            I_SENDER | I_BLAKE2B | I_SHA256 | I_SHA512 | I_STEPS_TO_QUOTA |
            I_ADDRESS) as name) ((cons _ _) as l) _, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc name 0
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      |
        (Prim loc
          ((I_NONE | I_LEFT | I_RIGHT | I_NIL | I_MAP | I_ITER | I_EMPTY_SET |
            I_DIP | I_LOOP | I_LOOP_LEFT | I_CONTRACT) as name)
          (([] | cons _ (cons _ _)) as l) _, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc name 1
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      |
        (Prim loc
          ((I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS | I_EMPTY_MAP | I_IF) as
            name) (([] | cons _ [] | cons _ (cons _ (cons _ _))) as l) _, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc name 2
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      |
        (Prim loc I_LAMBDA
          (([] | cons _ [] | cons _ (cons _ (cons _ (cons _ _)))) as l) _, _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Invalid_arity loc I_LAMBDA 3
            (Tezos_protocol_environment_alpha__Environment.List.length l))
      |
        (Prim loc
          ((I_ADD | I_SUB | I_MUL | I_EDIV | I_AND | I_OR | I_XOR | I_LSL |
            I_LSR) as name) [] _, Item_t ta (Item_t tb _ _) _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (serialize_ty_for_error ctxt ta))
          (fun function_parameter =>
            match function_parameter with
            | (ta, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (serialize_ty_for_error ctxt tb))
                (fun function_parameter =>
                  match function_parameter with
                  | (tb, _ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                      (Undefined_binop loc name ta tb)
                  end)
            end)
      |
        (Prim loc
          ((I_NEG | I_ABS | I_NOT | I_CONCAT | I_SIZE | I_EQ | I_NEQ | I_LT |
            I_GT | I_LE | I_GE) as name) [] _, Item_t t _ _) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (serialize_ty_for_error ctxt t))
          (fun function_parameter =>
            match function_parameter with
            | (t, _ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Undefined_unop loc name t)
            end)
      | (Prim loc ((I_UPDATE | I_SLICE) as name) [] _, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            match function_parameter with
            | (stack, _ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Bad_stack loc name 3 stack)
            end)
      | (Prim loc I_CREATE_CONTRACT _ _, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            match function_parameter with
            | (stack, _ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Bad_stack loc I_CREATE_CONTRACT 7 stack)
            end)
      | (Prim loc I_CREATE_ACCOUNT [] _, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            match function_parameter with
            | (stack, _ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Bad_stack loc I_CREATE_ACCOUNT 4 stack)
            end)
      | (Prim loc I_TRANSFER_TOKENS [] _, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            match function_parameter with
            | (stack, _ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Bad_stack loc I_TRANSFER_TOKENS 4 stack)
            end)
      |
        (Prim loc
          ((I_DROP | I_DUP | I_CAR | I_CDR | I_SOME | I_BLAKE2B | I_SHA256 |
            I_SHA512 | I_DIP | I_IF_NONE | I_LEFT | I_RIGHT | I_IF_LEFT | I_IF |
            I_LOOP | I_IF_CONS | I_IMPLICIT_ACCOUNT | I_NEG | I_ABS | I_INT |
            I_NOT | I_HASH_KEY | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE) as
            name) _ _, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            match function_parameter with
            | (stack, _ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Bad_stack loc name 1 stack)
            end)
      |
        (Prim loc
          ((I_SWAP | I_PAIR | I_CONS | I_GET | I_MEM | I_EXEC |
            I_CHECK_SIGNATURE | I_ADD | I_SUB | I_MUL | I_EDIV | I_AND | I_OR |
            I_XOR | I_LSL | I_LSR) as name) _ _, stack) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            match function_parameter with
            | (stack, _ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.fail
                (Bad_stack loc name 2 stack)
            end)
      | (expr, _) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (unexpected expr (cons Seq_kind []) Instr_namespace
            (cons I_DROP
              (cons I_DUP
                (cons I_DIG
                  (cons I_DUG
                    (cons I_SWAP
                      (cons I_SOME
                        (cons I_UNIT
                          (cons I_PAIR
                            (cons I_CAR
                              (cons I_CDR
                                (cons I_CONS
                                  (cons I_MEM
                                    (cons I_UPDATE
                                      (cons I_MAP
                                        (cons I_ITER
                                          (cons I_GET
                                            (cons I_EXEC
                                              (cons I_FAILWITH
                                                (cons I_SIZE
                                                  (cons I_CONCAT
                                                    (cons I_ADD
                                                      (cons I_SUB
                                                        (cons I_MUL
                                                          (cons I_EDIV
                                                            (cons I_OR
                                                              (cons I_AND
                                                                (cons I_XOR
                                                                  (cons I_NOT
                                                                    (cons I_ABS
                                                                      (cons
                                                                        I_INT
                                                                        (cons
                                                                          I_NEG
                                                                          (cons
                                                                            I_LSL
                                                                            (cons
                                                                              I_LSR
                                                                              (cons
                                                                                I_COMPARE
                                                                                (cons
                                                                                  I_EQ
                                                                                  (cons
                                                                                    I_NEQ
                                                                                    (cons
                                                                                      I_LT
                                                                                      (cons
                                                                                        I_GT
                                                                                        (cons
                                                                                          I_LE
                                                                                          (cons
                                                                                            I_GE
                                                                                            (cons
                                                                                              I_TRANSFER_TOKENS
                                                                                              (cons
                                                                                                I_CREATE_ACCOUNT
                                                                                                (cons
                                                                                                  I_CREATE_CONTRACT
                                                                                                  (cons
                                                                                                    I_NOW
                                                                                                    (cons
                                                                                                      I_AMOUNT
                                                                                                      (cons
                                                                                                        I_BALANCE
                                                                                                        (cons
                                                                                                          I_IMPLICIT_ACCOUNT
                                                                                                          (cons
                                                                                                            I_CHECK_SIGNATURE
                                                                                                            (cons
                                                                                                              I_BLAKE2B
                                                                                                              (cons
                                                                                                                I_SHA256
                                                                                                                (cons
                                                                                                                  I_SHA512
                                                                                                                  (cons
                                                                                                                    I_HASH_KEY
                                                                                                                    (cons
                                                                                                                      I_STEPS_TO_QUOTA
                                                                                                                      (cons
                                                                                                                        I_PUSH
                                                                                                                        (cons
                                                                                                                          I_NONE
                                                                                                                          (cons
                                                                                                                            I_LEFT
                                                                                                                            (cons
                                                                                                                              I_RIGHT
                                                                                                                              (cons
                                                                                                                                I_NIL
                                                                                                                                (cons
                                                                                                                                  I_EMPTY_SET
                                                                                                                                  (cons
                                                                                                                                    I_DIP
                                                                                                                                    (cons
                                                                                                                                      I_LOOP
                                                                                                                                      (cons
                                                                                                                                        I_IF_NONE
                                                                                                                                        (cons
                                                                                                                                          I_IF_LEFT
                                                                                                                                          (cons
                                                                                                                                            I_IF_CONS
                                                                                                                                            (cons
                                                                                                                                              I_EMPTY_MAP
                                                                                                                                              (cons
                                                                                                                                                I_IF
                                                                                                                                                (cons
                                                                                                                                                  I_SOURCE
                                                                                                                                                  (cons
                                                                                                                                                    I_SENDER
                                                                                                                                                    (cons
                                                                                                                                                      I_SELF
                                                                                                                                                      (cons
                                                                                                                                                        I_LAMBDA
                                                                                                                                                        [])))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
      end)

with parse_contract {arg : Type}
  (legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (arg : Tezos_raw_protocol_alpha.Script_typed_ir.ty arg)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (entrypoint : string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract arg))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
        Typecheck_costs.contract_exists))
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Alpha_context.Contract._exists ctxt contract)
        (fun function_parameter =>
          match function_parameter with
          | false =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.fail
              (Invalid_contract loc contract)
          | true =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Typecheck_costs.get_script))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                      (Invalid_contract loc contract))
                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script_code
                      ctxt contract))
                  (fun function_parameter =>
                    match function_parameter with
                    | (ctxt, code) =>
                      match code with
                      | None =>
                        Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                            (ty_eq ctxt arg (Unit_t None))
                            (fun function_parameter =>
                              match function_parameter with
                              | (Eq, ctxt) =>
                                match entrypoint with
                                | "default" % string =>
                                  let contract := (arg, (contract, entrypoint))
                                    in
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                    (ctxt, contract)
                                | entrypoint =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.error
                                    (No_such_entrypoint entrypoint)
                                end
                              end))
                      | Some code =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                            ctxt code)
                          (fun function_parameter =>
                            match function_parameter with
                            | (code, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Lwt._return
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                  (parse_toplevel true code)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (arg_type, _, _, root_name) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                        (parse_parameter_ty ctxt true arg_type)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (Ex_ty targ, ctxt) =>
                                            let _return
                                              (ctxt :
                                              Tezos_raw_protocol_alpha.Alpha_context.context)
                                              (targ :
                                              Tezos_raw_protocol_alpha.Script_typed_ir.ty
                                                arg) (entrypoint : string)
                                              : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                                (Tezos_raw_protocol_alpha.Alpha_context.context
                                                  *
                                                  (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract
                                                    arg)) :=
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                                (merge_types legacy ctxt loc
                                                  targ arg)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (arg, ctxt) =>
                                                    let contract :=
                                                      (arg,
                                                        (contract, entrypoint))
                                                      in
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                                      (ctxt, contract)
                                                  end) in
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                              (find_entrypoint_for_type targ arg
                                                root_name entrypoint ctxt)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (ctxt, entrypoint, targ) =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                                    (merge_types legacy ctxt loc
                                                      targ arg)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | (targ, ctxt) =>
                                                        _return ctxt targ
                                                          entrypoint
                                                      end)
                                                end)
                                          end)
                                    end))
                            end)
                      end
                    end))
          end))

with parse_contract_for_script {arg : Type}
  (legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (arg : Tezos_raw_protocol_alpha.Script_typed_ir.ty arg)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (entrypoint : string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        (option (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract arg)))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
        Typecheck_costs.contract_exists))
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Alpha_context.Contract._exists ctxt contract)
        (fun function_parameter =>
          match function_parameter with
          | false =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (ctxt, None)
          | true =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  Typecheck_costs.get_script))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                      (Invalid_contract loc contract))
                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.get_script_code
                      ctxt contract))
                  (fun function_parameter =>
                    match function_parameter with
                    | (ctxt, code) =>
                      match code with
                      | None =>
                        match entrypoint with
                        | "default" % string =>
                          Tezos_protocol_environment_alpha__Environment.Lwt._return
                            match ty_eq ctxt arg (Unit_t None) with
                            | inl (Eq, ctxt) =>
                              let contract := (arg, (contract, entrypoint)) in
                              Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                (ctxt, (Some contract))
                            | inr _ =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                  ctxt Typecheck_costs.cycle)
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                    (ctxt, None))
                            end
                        | _ =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (ctxt, None)
                        end
                      | Some code =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode
                            ctxt code)
                          (fun function_parameter =>
                            match function_parameter with
                            | (code, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Lwt._return
                                match parse_toplevel true code with
                                | inr _ =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.error
                                    (Invalid_contract loc contract)
                                | inl (arg_type, _, _, root_name) =>
                                  match parse_parameter_ty ctxt true arg_type
                                    with
                                  | inr _ =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.error
                                      (Invalid_contract loc contract)
                                  | inl (Ex_ty targ, ctxt) =>
                                    match
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                        (find_entrypoint_for_type targ arg
                                          root_name entrypoint ctxt)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (ctxt, entrypoint, targ) =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                              (merge_types legacy ctxt loc targ
                                                arg)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (targ, ctxt) =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                                    (merge_types legacy ctxt loc
                                                      targ arg)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | (arg, ctxt) =>
                                                        let contract :=
                                                          (arg,
                                                            (contract,
                                                              entrypoint)) in
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                                          (ctxt, (Some contract))
                                                      end)
                                                end)
                                          end) with
                                    | inl res =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                        res
                                    | inr _ =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                        (ty_eq ctxt targ targ)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (Eq, ctxt) =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                              (merge_types legacy ctxt loc targ
                                                targ)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (_, ctxt) =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                                    (ctxt, None)
                                                end)
                                          end)
                                    end
                                  end
                                end
                            end)
                      end
                    end))
          end))

with parse_toplevel
  (legacy : bool)
  (toplevel : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      Tezos_raw_protocol_alpha.Alpha_context.Script.node * (option string)) :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
      (Ill_typed_contract toplevel []))
    match Tezos_protocol_environment_alpha__Environment.Micheline.root toplevel
      with
    | Int loc _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Invalid_kind loc (cons Seq_kind []) Int_kind)
    | String loc _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Invalid_kind loc (cons Seq_kind []) String_kind)
    | Bytes loc _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Invalid_kind loc (cons Seq_kind []) Bytes_kind)
    | Prim loc _ _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.error
        (Invalid_kind loc (cons Seq_kind []) Prim_kind)
    | Seq _ fields =>
      let fix find_fields
        (p :
        option
          ((Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
            Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_protocol_environment_alpha__Environment.Micheline.annot)) (s :
        option
          ((Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
            Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_protocol_environment_alpha__Environment.Micheline.annot)) (c :
        option
          ((Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
            Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_protocol_environment_alpha__Environment.Micheline.annot))
        (fields :
        list
          (Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim))
        : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((option
            ((Tezos_protocol_environment_alpha__Environment.Micheline.node
              Tezos_raw_protocol_alpha.Alpha_context.Script.location
              Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
              Tezos_raw_protocol_alpha.Alpha_context.Script.location *
              Tezos_protocol_environment_alpha__Environment.Micheline.annot)) *
            (option
              ((Tezos_protocol_environment_alpha__Environment.Micheline.node
                Tezos_raw_protocol_alpha.Alpha_context.Script.location
                Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
                Tezos_raw_protocol_alpha.Alpha_context.Script.location *
                Tezos_protocol_environment_alpha__Environment.Micheline.annot))
            *
            (option
              ((Tezos_protocol_environment_alpha__Environment.Micheline.node
                Tezos_raw_protocol_alpha.Alpha_context.Script.location
                Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
                Tezos_raw_protocol_alpha.Alpha_context.Script.location *
                Tezos_protocol_environment_alpha__Environment.Micheline.annot))) :=
        match fields with
        | [] =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.ok (p, s, c)
        | cons (Int loc _) _ =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            (Invalid_kind loc (cons Prim_kind []) Int_kind)
        | cons (String loc _) _ =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            (Invalid_kind loc (cons Prim_kind []) String_kind)
        | cons (Bytes loc _) _ =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            (Invalid_kind loc (cons Prim_kind []) Bytes_kind)
        | cons (Seq loc _) _ =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            (Invalid_kind loc (cons Prim_kind []) Seq_kind)
        | cons (Prim loc K_parameter (cons arg []) annot) rest =>
          match p with
          | None => find_fields (Some (arg, loc, annot)) s c rest
          | Some _ =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Duplicate_field loc K_parameter)
          end
        | cons (Prim loc K_storage (cons arg []) annot) rest =>
          match s with
          | None => find_fields p (Some (arg, loc, annot)) c rest
          | Some _ =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Duplicate_field loc K_storage)
          end
        | cons (Prim loc K_code (cons arg []) annot) rest =>
          match c with
          | None => find_fields p s (Some (arg, loc, annot)) rest
          | Some _ =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Duplicate_field loc K_code)
          end
        | cons (Prim loc ((K_parameter | K_storage | K_code) as name) args _) _
          =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            (Invalid_arity loc name 1
              (Tezos_protocol_environment_alpha__Environment.List.length args))
        | cons (Prim loc name _ _) _ =>
          let allowed := cons K_parameter (cons K_storage (cons K_code [])) in
          Tezos_protocol_environment_alpha__Environment.Error_monad.error
            (Invalid_primitive loc allowed name)
        end in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (find_fields None None None fields)
        (fun function_parameter =>
          match function_parameter with
          | (None, _, _) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Missing_field K_parameter)
          | (Some _, None, _) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Missing_field K_storage)
          | (Some _, Some _, None) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.error
              (Missing_field K_code)
          |
            (Some (p, ploc, pannot), Some (s, sloc, sannot),
              Some (c, cloc, carrot)) =>
            let maybe_root_name :=
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (Tezos_raw_protocol_alpha.Script_ir_annot.extract_field_annot p)
                (fun function_parameter =>
                  match function_parameter with
                  | (p, root_name) =>
                    match root_name with
                    | Some (Field_annot root_name) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                        (p, pannot, (Some root_name))
                    | None =>
                      match pannot with
                      | _ =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                          (p, pannot, None)
                      end
                    end
                  end) in
            if legacy then
              match
                match maybe_root_name with
                | inl (p, _, root_name) => (p, root_name)
                | inr _ => (p, None)
                end with
              | (p, root_name) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                  (p, s, c, root_name)
              end
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                maybe_root_name
                (fun function_parameter =>
                  match function_parameter with
                  | (p, pannot, root_name) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                      (Tezos_raw_protocol_alpha.Script_ir_annot.error_unexpected_annot
                        ploc pannot)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                            (Tezos_raw_protocol_alpha.Script_ir_annot.error_unexpected_annot
                              cloc carrot)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                  (Tezos_raw_protocol_alpha.Script_ir_annot.error_unexpected_annot
                                    sloc sannot)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                                        (p, s, c, root_name)
                                    end)
                              end)
                        end)
                  end)
          end)
    end.

Definition parse_script
  (type_logger : option type_logger)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (ex_script * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | {| code := code; storage := storage |} =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode ctxt code)
      (fun function_parameter =>
        match function_parameter with
        | (code, ctxt) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Alpha_context.Script.force_decode ctxt
              storage)
            (fun function_parameter =>
              match function_parameter with
              | (storage, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                    Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (parse_toplevel legacy code))
                  (fun function_parameter =>
                    match function_parameter with
                    | (arg_type, storage_type, code_field, root_name) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                          (Ill_formed_type (Some "parameter" % string) code
                            (location arg_type))
                          (Tezos_protocol_environment_alpha__Environment.Lwt._return
                            (parse_parameter_ty ctxt legacy arg_type)))
                        (fun function_parameter =>
                          match function_parameter with
                          | (Ex_ty arg_type, ctxt) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (if legacy then
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  tt
                              else
                                Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (well_formed_entrypoints arg_type root_name))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                      (Ill_formed_type (Some "storage" % string)
                                        code (location storage_type))
                                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                        (parse_storage_ty ctxt legacy
                                          storage_type)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (Ex_ty storage_type, ctxt) =>
                                        let arg_annot :=
                                          Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                                            Tezos_raw_protocol_alpha.Script_ir_annot.default_param_annot
                                            (Tezos_raw_protocol_alpha.Script_ir_annot.type_to_var_annot
                                              (name_of_ty arg_type)) in
                                        let storage_annot :=
                                          Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                                            Tezos_raw_protocol_alpha.Script_ir_annot.default_storage_annot
                                            (Tezos_raw_protocol_alpha.Script_ir_annot.type_to_var_annot
                                              (name_of_ty storage_type)) in
                                        let arg_type_full :=
                                          Pair_t (arg_type, None, arg_annot)
                                            (storage_type, None, storage_annot)
                                            None
                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                                              (has_big_map arg_type)
                                              (has_big_map storage_type)) in
                                        let ret_type_full :=
                                          Pair_t
                                            ((List_t (Operation_t None) None
                                              false), None, None)
                                            (storage_type, None, None) None
                                            (has_big_map storage_type) in
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                                                    Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                    (serialize_ty_for_error ctxt
                                                      storage_type))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | (storage_type, _ctxt) =>
                                                      Ill_typed_data None
                                                        storage storage_type
                                                    end)
                                              end)
                                            (parse_data type_logger ctxt legacy
                                              storage_type
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.root
                                                storage)))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (storage, ctxt) =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                                                  (Ill_typed_contract code [])
                                                  (parse_returning type_logger
                                                    (Toplevel
                                                      {|
                                                        storage_type :=
                                                          storage_type;
                                                        param_type := arg_type;
                                                        root_name := root_name;
                                                        legacy_create_contract_literal :=
                                                          false |}) ctxt legacy
                                                    (arg_type_full, None)
                                                    ret_type_full code_field))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (code, ctxt) =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                      ((Ex_script
                                                        {| code := code;
                                                          arg_type := arg_type;
                                                          storage := storage;
                                                          storage_type :=
                                                            storage_type;
                                                          root_name := root_name
                                                          |}), ctxt)
                                                  end)
                                            end)
                                      end)
                                end)
                          end)
                    end)
              end)
        end)
  end.

Definition typecheck_code
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Script_tc_errors.type_map *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let legacy := false in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
      Tezos_protocol_environment_alpha__Environment.Lwt._return
      (parse_toplevel legacy code))
    (fun function_parameter =>
      match function_parameter with
      | (arg_type, storage_type, code_field, root_name) =>
        let type_map :=
          Tezos_protocol_environment_alpha__Environment.Pervasives.ref [] in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
            (Ill_formed_type (Some "parameter" % string) code
              (location arg_type))
            (Tezos_protocol_environment_alpha__Environment.Lwt._return
              (parse_parameter_ty ctxt legacy arg_type)))
          (fun function_parameter =>
            match function_parameter with
            | (Ex_ty arg_type, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (if legacy then
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    tt
                else
                  Tezos_protocol_environment_alpha__Environment.Lwt._return
                    (well_formed_entrypoints arg_type root_name))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                        (Ill_formed_type (Some "storage" % string) code
                          (location storage_type))
                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                          (parse_storage_ty ctxt legacy storage_type)))
                      (fun function_parameter =>
                        match function_parameter with
                        | (Ex_ty storage_type, ctxt) =>
                          let arg_annot :=
                            Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                              Tezos_raw_protocol_alpha.Script_ir_annot.default_param_annot
                              (Tezos_raw_protocol_alpha.Script_ir_annot.type_to_var_annot
                                (name_of_ty arg_type)) in
                          let storage_annot :=
                            Tezos_raw_protocol_alpha.Script_ir_annot.default_annot
                              Tezos_raw_protocol_alpha.Script_ir_annot.default_storage_annot
                              (Tezos_raw_protocol_alpha.Script_ir_annot.type_to_var_annot
                                (name_of_ty storage_type)) in
                          let arg_type_full :=
                            Pair_t (arg_type, None, arg_annot)
                              (storage_type, None, storage_annot) None
                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_pipe
                                (has_big_map arg_type)
                                (has_big_map storage_type)) in
                          let ret_type_full :=
                            Pair_t
                              ((List_t (Operation_t None) None false), None,
                                None) (storage_type, None, None) None
                              (has_big_map storage_type) in
                          let result :=
                            parse_returning
                              (Some
                                (fun loc =>
                                  fun bef =>
                                    fun aft =>
                                      Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
                                        type_map
                                        (cons (loc, (bef, aft))
                                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
                                            type_map))))
                              (Toplevel
                                {| storage_type := storage_type;
                                  param_type := arg_type;
                                  root_name := root_name;
                                  legacy_create_contract_literal := false |})
                              ctxt legacy (arg_type_full, None) ret_type_full
                              code_field in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
                              (Ill_typed_contract code
                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
                                  type_map)) result)
                            (fun function_parameter =>
                              match function_parameter with
                              | (Lam _ _, ctxt) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
                                    type_map), ctxt)
                              end)
                        end)
                  end)
            end)
      end).

Definition typecheck_data
  (type_logger : option type_logger)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (function_parameter :
    Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  match function_parameter with
  | (data, exp_ty) =>
    let legacy := false in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Error_monad.trace
        (Ill_formed_type None exp_ty 0)
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Lwt._return
          (parse_packable_ty ctxt legacy
            (Tezos_protocol_environment_alpha__Environment.Micheline.root exp_ty))))
      (fun function_parameter =>
        match function_parameter with
        | (Ex_ty exp_ty, ctxt) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.trace_eval
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (serialize_ty_for_error ctxt exp_ty))
                    (fun function_parameter =>
                      match function_parameter with
                      | (exp_ty, _ctxt) => Ill_typed_data None data exp_ty
                      end)
                end)
              (parse_data type_logger ctxt legacy exp_ty
                (Tezos_protocol_environment_alpha__Environment.Micheline.root
                  data)))
            (fun function_parameter =>
              match function_parameter with
              | (_, ctxt) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ctxt
              end)
        end)
  end.

Definition list_entrypoints {A : Type}
  (full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (root_name :
    option
      Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.key))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
      (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        ((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
          Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
  let merge {B C : Type}
    (path : list B) (annot : option variant) (ty :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (reachable : bool)
    (function_parameter :
    (list (list B)) *
      (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        ((list B) * Tezos_raw_protocol_alpha.Alpha_context.Script.node)))
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list (list B)) *
        (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
          ((list B) * Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
    match function_parameter with
    | (unreachables, all) as acc =>
      match annot with
      | None | Some (Field_annot "" % string) =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
          Tezos_protocol_environment_alpha__Environment.Error_monad.ok
          (if reachable then
            acc
          else
            match ty with
            | Union_t _ _ _ _ => acc
            | _ =>
              ((cons
                (Tezos_protocol_environment_alpha__Environment.List.rev path)
                unreachables), all)
            end)
      | Some (Field_annot name) =>
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
            (Tezos_protocol_environment_alpha__Environment.String.length name)
            31 then
          Tezos_protocol_environment_alpha__Environment.Error_monad.ok
            ((cons (Tezos_protocol_environment_alpha__Environment.List.rev path)
              unreachables), all)
        else
          if
            Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
              name all then
            Tezos_protocol_environment_alpha__Environment.Error_monad.ok
              ((cons
                (Tezos_protocol_environment_alpha__Environment.List.rev path)
                unreachables), all)
          else
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
              (unparse_ty_no_lwt ctxt ty)
              (fun function_parameter =>
                match function_parameter with
                | (unparsed_ty, _) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                    (unreachables,
                      (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
                        name
                        ((Tezos_protocol_environment_alpha__Environment.List.rev
                          path), unparsed_ty) all))
                end)
      end
    end in
  let fix fold_tree {t : Type}
    (t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (path :
    list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (reachable : bool)
    (acc :
    (list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
      (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        ((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
          Tezos_raw_protocol_alpha.Alpha_context.Script.node)))
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
        (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
          ((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
            Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
    match t with
    | Union_t (tl, al) (tr, ar) _ _ =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (merge (cons D_Left path) al tl reachable acc)
        (fun acc =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
            (merge (cons D_Right path) ar tr reachable acc)
            (fun acc =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                (fold_tree tl (cons D_Left path)
                  match al with
                  | Some _ => true
                  | None => reachable
                  end acc)
                (fun acc =>
                  fold_tree tr (cons D_Right path)
                    match ar with
                    | Some _ => true
                    | None => reachable
                    end acc)))
    | _ => Tezos_protocol_environment_alpha__Environment.Error_monad.ok acc
    end in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
    (unparse_ty_no_lwt ctxt full)
    (fun function_parameter =>
      match function_parameter with
      | (unparsed_full, _) =>
        match
          match root_name with
          | None | Some "" % string =>
            (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.empty),
              false)
          | Some name =>
            ((Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.singleton)
              name ([], unparsed_full)), true)
          end with
        | (init, reachable) => fold_tree full [] reachable ([], init)
        end
      end).

Fixpoint unparse_data {a : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : unparsing_mode) (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  (a : a)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Lwt._return
      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
        Unparse_costs.cycle))
    (fun ctxt =>
      match (ty, a) with
      | (Unit_t _, tt) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.unit))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Prim (-1) D_Unit [] []), ctxt))
      | (Int_t _, v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Unparse_costs.int v)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Int (-1)
                (Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_zint v)),
                ctxt))
      | (Nat_t _, v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Unparse_costs.int v)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Int (-1)
                (Tezos_raw_protocol_alpha.Alpha_context.Script_int.to_zint v)),
                ctxt))
      | (String_t _, s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Unparse_costs.string s)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((String (-1) s), ctxt))
      | (Bytes_t _, s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Unparse_costs.bytes s)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Bytes (-1) s), ctxt))
      | (Bool_t _, true) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.bool))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Prim (-1) D_True [] []), ctxt))
      | (Bool_t _, false) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.bool))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Prim (-1) D_False [] []), ctxt))
      | (Timestamp_t _, t) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Unparse_costs.timestamp t)))
          (fun ctxt =>
            match mode with
            | Optimized =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Int (-1)
                  (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.to_zint
                    t)), ctxt)
            | Readable =>
              match
                Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.to_notation
                  t with
              | None =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ((Int (-1)
                    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.to_zint
                      t)), ctxt)
              | Some s =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ((String (-1) s), ctxt)
              end
            end)
      | (Address_t _, (c, entrypoint)) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.contract))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let entrypoint :=
                match entrypoint with
                | "default" % string => "" % string
                | name => name
                end in
              let bytes :=
                Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
                    Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding
                    Tezos_protocol_environment_alpha__Environment.Data_encoding.Variable.string)
                  (c, entrypoint) in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Bytes (-1) string), ctxt)
            | Readable =>
              let notation :=
                match entrypoint with
                | "default" % string =>
                  Tezos_raw_protocol_alpha.Alpha_context.Contract.to_b58check c
                | entrypoint =>
                  Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.to_b58check
                      c)
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
                      "%" % string entrypoint)
                end in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((String (-1) notation), ctxt)
            end)
      | (Contract_t _ _, (_, (c, entrypoint))) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.contract))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let entrypoint :=
                match entrypoint with
                | "default" % string => "" % string
                | name => name
                end in
              let bytes :=
                Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
                    Tezos_raw_protocol_alpha.Alpha_context.Contract.encoding
                    Tezos_protocol_environment_alpha__Environment.Data_encoding.Variable.string)
                  (c, entrypoint) in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Bytes (-1) string), ctxt)
            | Readable =>
              let notation :=
                match entrypoint with
                | "default" % string =>
                  Tezos_raw_protocol_alpha.Alpha_context.Contract.to_b58check c
                | entrypoint =>
                  Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.to_b58check
                      c)
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
                      "%" % string entrypoint)
                end in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((String (-1) notation), ctxt)
            end)
      | (Signature_t _, s) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.signature))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let bytes :=
                Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                  Tezos_protocol_environment_alpha__Environment.Signature.encoding
                  s in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Bytes (-1) string), ctxt)
            | Readable =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((String (-1)
                  (Tezos_protocol_environment_alpha__Environment.Signature.to_b58check
                    s)), ctxt)
            end)
      | (Mutez_t _, v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.tez))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Int (-1)
                (Tezos_protocol_environment_alpha__Environment.Z.of_int64
                  (Tezos_raw_protocol_alpha.Alpha_context.Tez.to_mutez v))),
                ctxt))
      | (Key_t _, k) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.key))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let bytes :=
                Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                  Tezos_protocol_environment_alpha__Environment.Signature.Public_key.encoding
                  k in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Bytes (-1) string), ctxt)
            | Readable =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((String (-1)
                  (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.to_b58check
                    k)), ctxt)
            end)
      | (Key_hash_t _, k) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.key_hash))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let bytes :=
                Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
                  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
                  k in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Bytes (-1) string), ctxt)
            | Readable =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((String (-1)
                  (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.to_b58check
                    k)), ctxt)
            end)
      | (Operation_t _, (op, _big_map_diff)) =>
        let bytes :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
            Tezos_raw_protocol_alpha.Alpha_context.Operation.internal_operation_encoding
            op in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Unparse_costs.operation string)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Bytes (-1) string), ctxt))
      | (Chain_id_t _, chain_id) =>
        let bytes :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
            Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)
            chain_id in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Unparse_costs.chain_id string)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Bytes (-1) string), ctxt))
      | (Pair_t (tl, _, _) (tr, _, _) _ _, (l, r)) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.pair))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (unparse_data ctxt mode tl l)
              (fun function_parameter =>
                match function_parameter with
                | (l, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (unparse_data ctxt mode tr r)
                    (fun function_parameter =>
                      match function_parameter with
                      | (r, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          ((Prim (-1) D_Pair (cons l (cons r [])) []), ctxt)
                      end)
                end))
      | (Union_t (tl, _) _ _ _, L l) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.union))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (unparse_data ctxt mode tl l)
              (fun function_parameter =>
                match function_parameter with
                | (l, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ((Prim (-1) D_Left (cons l []) []), ctxt)
                end))
      | (Union_t _ (tr, _) _ _, R r) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.union))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (unparse_data ctxt mode tr r)
              (fun function_parameter =>
                match function_parameter with
                | (r, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ((Prim (-1) D_Right (cons r []) []), ctxt)
                end))
      | (Option_t t _ _, Some v) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.some))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (unparse_data ctxt mode t v)
              (fun function_parameter =>
                match function_parameter with
                | (v, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    ((Prim (-1) D_Some (cons v []) []), ctxt)
                end))
      | (Option_t _ _ _, None) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              Unparse_costs.none))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Prim (-1) D_None [] []), ctxt))
      | (List_t t _ _, items) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
            (fun function_parameter =>
              match function_parameter with
              | (l, ctxt) =>
                fun element =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        Unparse_costs.list_element))
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (unparse_data ctxt mode t element)
                        (fun function_parameter =>
                          match function_parameter with
                          | (unparsed, ctxt) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              ((cons unparsed l), ctxt)
                          end))
              end) ([], ctxt) items)
          (fun function_parameter =>
            match function_parameter with
            | (items, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Micheline.Seq (-1)
                  (Tezos_protocol_environment_alpha__Environment.List.rev items)),
                  ctxt)
            end)
      | (Set_t t _, set) =>
        let t := ty_of_comparable_ty t in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
            (fun function_parameter =>
              match function_parameter with
              | (l, ctxt) =>
                fun item =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                        Unparse_costs.set_element))
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (unparse_data ctxt mode t item)
                        (fun function_parameter =>
                          match function_parameter with
                          | (item, ctxt) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              ((cons item l), ctxt)
                          end))
              end) ([], ctxt) (set_fold (fun e => fun acc => cons e acc) set []))
          (fun function_parameter =>
            match function_parameter with
            | (items, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Micheline.Seq (-1) items), ctxt)
            end)
      | (Map_t kt vt _ _, map) =>
        let kt := ty_of_comparable_ty kt in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
            (fun function_parameter =>
              match function_parameter with
              | (l, ctxt) =>
                fun function_parameter =>
                  match function_parameter with
                  | (k, v) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                          Unparse_costs.map_element))
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (unparse_data ctxt mode kt k)
                          (fun function_parameter =>
                            match function_parameter with
                            | (key, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (unparse_data ctxt mode vt v)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (value, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                      ((cons
                                        (Prim (-1) D_Elt
                                          (cons key (cons value [])) []) l),
                                        ctxt)
                                  end)
                            end))
                  end
              end) ([], ctxt)
            (map_fold (fun k => fun v => fun acc => cons (k, v) acc) map []))
          (fun function_parameter =>
            match function_parameter with
            | (items, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Micheline.Seq (-1) items), ctxt)
            end)
      | (Big_map_t kt vt _, {| id := None; diff := Diff |}) =>
        let Diff := projT2 Diff in
        let kt := ty_of_comparable_ty kt in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
            (fun function_parameter =>
              match function_parameter with
              | (l, ctxt) =>
                fun function_parameter =>
                  match function_parameter with
                  | (k, v) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                          Unparse_costs.map_element))
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (unparse_data ctxt mode kt k)
                          (fun function_parameter =>
                            match function_parameter with
                            | (key, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (unparse_data ctxt mode vt v)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (value, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                      ((cons
                                        (Prim (-1) D_Elt
                                          (cons key (cons value [])) []) l),
                                        ctxt)
                                  end)
                            end))
                  end
              end) ([], ctxt)
            (Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.fold)
              (fun k =>
                fun v =>
                  fun acc =>
                    match v with
                    | None => acc
                    | Some v => cons (k, v) acc
                    end)
              (Tezos_protocol_environment_alpha__Environment.Pervasives.fst
                Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))
              []))
          (fun function_parameter =>
            match function_parameter with
            | (items, ctxt) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ((Micheline.Seq (-1) items), ctxt)
            end)
      | (Big_map_t _kt _kv _, {| id := Some id; diff := Diff |}) =>
        let Diff := projT2 Diff in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.cardinal)
              (Tezos_protocol_environment_alpha__Environment.Pervasives.fst
                Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)))
            0 then
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            ((Micheline.Int (-1) id), ctxt)
        else
          false
      | (Lambda_t _ _ _, Lam _ original_code) =>
        unparse_code ctxt mode original_code
      end)

with unparse_code
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (mode : unparsing_mode)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((Tezos_protocol_environment_alpha__Environment.Micheline.node Z
          Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
          Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  let legacy := true in
  fun function_parameter =>
    match function_parameter with
    | Prim loc I_PUSH (cons ty (cons data [])) annot =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Lwt._return
          (parse_packable_ty ctxt legacy ty))
        (fun function_parameter =>
          match function_parameter with
          | (Ex_ty t, ctxt) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (parse_data None ctxt legacy t data)
              (fun function_parameter =>
                match function_parameter with
                | (data, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (unparse_data ctxt mode t data)
                    (fun function_parameter =>
                      match function_parameter with
                      | (data, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_protocol_environment_alpha__Environment.Lwt._return
                            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                              ctxt (Unparse_costs.prim_cost 2 annot)))
                          (fun ctxt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad._return
                              ((Prim loc I_PUSH (cons ty (cons data [])) annot),
                                ctxt))
                      end)
                end)
          end)
    | Seq loc items =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
          (fun function_parameter =>
            match function_parameter with
            | (l, ctxt) =>
              fun item =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (unparse_code ctxt mode item)
                  (fun function_parameter =>
                    match function_parameter with
                    | (item, ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        ((cons item l), ctxt)
                    end)
            end) ([], ctxt) items)
        (fun function_parameter =>
          match function_parameter with
          | (items, ctxt) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Unparse_costs.seq_cost
                    (Tezos_protocol_environment_alpha__Environment.List.length
                      items))))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ((Micheline.Seq loc
                    (Tezos_protocol_environment_alpha__Environment.List.rev
                      items)), ctxt))
          end)
    | Prim loc prim items annot =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
          (fun function_parameter =>
            match function_parameter with
            | (l, ctxt) =>
              fun item =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (unparse_code ctxt mode item)
                  (fun function_parameter =>
                    match function_parameter with
                    | (item, ctxt) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        ((cons item l), ctxt)
                    end)
            end) ([], ctxt) items)
        (fun function_parameter =>
          match function_parameter with
          | (items, ctxt) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Unparse_costs.prim_cost 3 annot)))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  ((Prim loc prim
                    (Tezos_protocol_environment_alpha__Environment.List.rev
                      items) annot), ctxt))
          end)
    | (Int _ _ | String _ _ | Bytes _ _) as atom =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (atom, ctxt)
    end.

Definition unparse_script {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (mode : unparsing_mode)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.script A B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.t *
        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  match function_parameter with
  | {|
    code := code;
      arg_type := arg_type;
      storage := storage;
      storage_type := storage_type;
      root_name := root_name
      |} =>
    match code with
    | Lam _ original_code =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (unparse_code ctxt mode original_code)
        (fun function_parameter =>
          match function_parameter with
          | (code, ctxt) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (unparse_data ctxt mode storage_type storage)
              (fun function_parameter =>
                match function_parameter with
                | (storage, ctxt) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (unparse_ty ctxt arg_type)
                    (fun function_parameter =>
                      match function_parameter with
                      | (arg_type, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (unparse_ty ctxt storage_type)
                          (fun function_parameter =>
                            match function_parameter with
                            | (storage_type, ctxt) =>
                              let arg_type :=
                                add_field_annot
                                  (Tezos_protocol_environment_alpha__Environment.Option.map
                                    (fun n => variant) root_name) None arg_type
                                in
                              let code :=
                                Seq (-1)
                                  (cons
                                    (Prim (-1) K_parameter (cons arg_type []) [])
                                    (cons
                                      (Prim (-1) K_storage
                                        (cons storage_type []) [])
                                      (cons (Prim (-1) K_code (cons code []) [])
                                        []))) in
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                    (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                      ctxt (Unparse_costs.seq_cost 3))
                                    (fun ctxt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                          ctxt (Unparse_costs.prim_cost 1 []))
                                        (fun ctxt =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                              ctxt
                                              (Unparse_costs.prim_cost 1 []))
                                            (fun ctxt =>
                                              Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                                ctxt
                                                (Unparse_costs.prim_cost 1 []))))))
                                (fun ctxt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                    ({|
                                      code :=
                                        Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                            code);
                                      storage :=
                                        Tezos_raw_protocol_alpha.Alpha_context.Script.lazy_expr
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                            storage) |}, ctxt))
                            end)
                      end)
                end)
          end)
    end
  end.

Definition pack_data {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (typ : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (data : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.MBytes.t *
        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (unparse_data ctxt Optimized typ data)
    (fun function_parameter =>
      match function_parameter with
      | (unparsed, ctxt) =>
        let bytes :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
            Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding
            (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
              unparsed) in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Tezos_raw_protocol_alpha.Alpha_context.Script.serialized_cost
                string)))
          (fun ctxt =>
            let bytes :=
              Tezos_protocol_environment_alpha__Environment.MBytes.concat
                "" % string
                (cons
                  (Tezos_protocol_environment_alpha__Environment.MBytes.of_string
                    "" % string) (cons string [])) in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                  (Tezos_raw_protocol_alpha.Alpha_context.Script.serialized_cost
                    string)))
              (fun ctxt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (string, ctxt)))
      end).

Definition hash_data {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (typ : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (data : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Script_expr_hash.t *
        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (pack_data ctxt typ data)
    (fun function_parameter =>
      match function_parameter with
      | (bytes, ctxt) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
            Tezos_protocol_environment_alpha__Environment.Lwt._return
            (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
              (Tezos_raw_protocol_alpha.Michelson_v1_gas.Cost_of.Legacy.hash
                string Tezos_raw_protocol_alpha.Script_expr_hash.size)))
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((Tezos_raw_protocol_alpha.Script_expr_hash.hash_bytes None
                (cons string [])), ctxt))
      end).

Definition empty_big_map {A B : Type}
  (tk : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty A)
  (tv : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
  : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B :=
  {| id := None; diff := empty_map tk; key_type := ty_of_comparable_ty tk;
    value_type := tv |}.

Definition big_map_mem {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (key : A)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (bool * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | {| id := id; diff := diff; key_type := key_type |} =>
    match ((map_get key diff), id) with
    | (None, None) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (false, ctxt)
    | (None, Some id) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (hash_data ctxt key_type key)
        (fun function_parameter =>
          match function_parameter with
          | (hash, ctxt) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Alpha_context.Big_map.mem ctxt id hash)
              (fun function_parameter =>
                match function_parameter with
                | (ctxt, res) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (res, ctxt)
                end)
          end)
    | (Some None, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (false, ctxt)
    | (Some (Some _), _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (true, ctxt)
    end
  end.

Definition big_map_get {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (key : A)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option B) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | {| id := id; diff := diff; key_type := key_type; value_type := value_type |}
    =>
    match ((map_get key diff), id) with
    | (Some x, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (x, ctxt)
    | (None, None) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (None, ctxt)
    | (None, Some id) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (hash_data ctxt key_type key)
        (fun function_parameter =>
          match function_parameter with
          | (hash, ctxt) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_raw_protocol_alpha.Alpha_context.Big_map.get_opt ctxt id
                hash)
              (fun function_parameter =>
                match function_parameter with
                | (ctxt, None) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (None, ctxt)
                | (ctxt, Some value) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (parse_data None ctxt true value_type
                      (Tezos_protocol_environment_alpha__Environment.Micheline.root
                        value))
                    (fun function_parameter =>
                      match function_parameter with
                      | (x, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          ((Some x), ctxt)
                      end)
                end)
          end)
    end
  end.

Definition big_map_update {A B : Type}
  (key : A) (value : option B)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
  : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B :=
  match function_parameter with
  | {| diff := diff |} as map => record
  end.

Definition big_map_ids :=
  Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t).

Definition no_big_map_id
  : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
  Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.empty).

Definition diff_of_big_map {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (fresh :
    Tezos_raw_protocol_alpha__Alpha_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha__Alpha_context.context *
            Tezos_raw_protocol_alpha__Alpha_context.Big_map.id)))
  (mode : unparsing_mode)
  (ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_item)
        * Tezos_raw_protocol_alpha__Alpha_context.Big_map.id *
        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  match function_parameter with
  | {| id := id; diff := diff; key_type := key_type; value_type := value_type |}
    =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
          (Tezos_raw_protocol_alpha.Michelson_v1_gas.Cost_of.Legacy.map_to_list
            diff)))
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          match id with
          | Some id =>
            if
              Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.mem) id
                ids then
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (fresh ctxt)
                (fun function_parameter =>
                  match function_parameter with
                  | (ctxt, duplicate) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (ctxt, (cons (Contract.Copy id duplicate) []), duplicate)
                  end)
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, [], id)
          | None =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (fresh ctxt)
              (fun function_parameter =>
                match function_parameter with
                | (ctxt, id) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (unparse_ty ctxt key_type)
                    (fun function_parameter =>
                      match function_parameter with
                      | (kt, ctxt) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (unparse_ty ctxt value_type)
                          (fun function_parameter =>
                            match function_parameter with
                            | (kv, ctxt) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (ctxt,
                                  (cons
                                    (Contract.Alloc
                                      {| big_map := id;
                                        key_type :=
                                          Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                            kt;
                                        value_type :=
                                          Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                            kv |}) []), id)
                            end)
                      end)
                end)
          end
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, init, big_map) =>
              let pairs :=
                map_fold
                  (fun key => fun value => fun acc => cons (key, value) acc)
                  diff [] in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                  (fun function_parameter =>
                    match function_parameter with
                    | (acc, ctxt) =>
                      fun function_parameter =>
                        match function_parameter with
                        | (key, value) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_protocol_environment_alpha__Environment.Lwt._return
                              (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume
                                ctxt Typecheck_costs.cycle))
                            (fun ctxt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (hash_data ctxt key_type key)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (diff_key_hash, ctxt) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (unparse_data ctxt mode key_type key)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (key_node, ctxt) =>
                                          let diff_key :=
                                            Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                              key_node in
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            match value with
                                            | None =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                (None, ctxt)
                                            | Some x =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (unparse_data ctxt mode
                                                  value_type x)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (node, ctxt) =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                      ((Some
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
                                                          node)), ctxt)
                                                  end)
                                            end
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | (diff_value, ctxt) =>
                                                let diff_item :=
                                                  Contract.Update
                                                    {| big_map := big_map;
                                                      diff_key := diff_key;
                                                      diff_key_hash :=
                                                        diff_key_hash;
                                                      diff_value := diff_value
                                                      |} in
                                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                  ((cons diff_item acc), ctxt)
                                              end)
                                        end)
                                  end))
                        end
                    end) ([], ctxt) pairs)
                (fun function_parameter =>
                  match function_parameter with
                  | (diff, ctxt) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                        init diff), big_map, ctxt)
                  end)
            end))
  end.

Fixpoint extract_big_map_updates {a : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (fresh :
    Tezos_raw_protocol_alpha.Alpha_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.context *
            Tezos_raw_protocol_alpha.Alpha_context.Big_map.id)))
  (mode : unparsing_mode)
  (ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  (acc : list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (x : a)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context * a *
        Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
        (list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
  match (ty, x) with
  | (Big_map_t _ _ _, map) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (diff_of_big_map ctxt fresh mode ids map)
      (fun function_parameter =>
        match function_parameter with
        | (diff, id, ctxt) =>
          let Map := diff map in
          let Map := projT2 Map in
          let map := record in
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (ctxt, map,
              (Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.add) id
                ids), (cons diff acc))
        end)
  | (Pair_t (tyl, _, _) (tyr, _, _) _ true, (xl, xr)) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
          Typecheck_costs.cycle))
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (extract_big_map_updates ctxt fresh mode ids acc tyl xl)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, xl, ids, acc) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (extract_big_map_updates ctxt fresh mode ids acc tyr xr)
                (fun function_parameter =>
                  match function_parameter with
                  | (ctxt, xr, ids, acc) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (ctxt, (xl, xr), ids, acc)
                  end)
            end))
  | (Union_t (ty, _) (_, _) _ true, L x) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
          Typecheck_costs.cycle))
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, x, ids, acc) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, (L x), ids, acc)
            end))
  | (Union_t (_, _) (ty, _) _ true, R x) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
          Typecheck_costs.cycle))
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, x, ids, acc) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, (R x), ids, acc)
            end))
  | (Option_t ty _ true, Some x) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
          Typecheck_costs.cycle))
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, x, ids, acc) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, (Some x), ids, acc)
            end))
  | (List_t ty _ true, l) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
        (fun function_parameter =>
          match function_parameter with
          | (ctxt, l, ids, acc) =>
            fun x =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                    Typecheck_costs.cycle))
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (extract_big_map_updates ctxt fresh mode ids acc ty x)
                    (fun function_parameter =>
                      match function_parameter with
                      | (ctxt, x, ids, acc) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (ctxt, (cons x l), ids, acc)
                      end))
          end) (ctxt, [], ids, acc) l)
      (fun function_parameter =>
        match function_parameter with
        | (ctxt, l, ids, acc) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (ctxt, (Tezos_protocol_environment_alpha__Environment.List.rev l),
              ids, acc)
        end)
  | (Map_t _ ty _ true, M as m) =>
    let M := projT2 M in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
          (Tezos_raw_protocol_alpha.Michelson_v1_gas.Cost_of.Legacy.map_to_list
            m)))
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
            (fun function_parameter =>
              match function_parameter with
              | (ctxt, m, ids, acc) =>
                fun function_parameter =>
                  match function_parameter with
                  | (k, x) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Lwt._return
                        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
                          Typecheck_costs.cycle))
                      (fun ctxt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (extract_big_map_updates ctxt fresh mode ids acc ty x)
                          (fun function_parameter =>
                            match function_parameter with
                            | (ctxt, x, ids, acc) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (ctxt,
                                  (M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
                                    k x m), ids, acc)
                            end))
                  end
              end)
            (ctxt,
              M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.empty),
              ids, acc)
            (M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
              (Tezos_protocol_environment_alpha__Environment.Pervasives.fst
                M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))))
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, m, ids, acc) =>
              let M :=
                existT _ _
                  {|
                    unknown_signature_name.OPS :=
                      M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
                    unknown_signature_name.key_ty :=
                      M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
                    unknown_signature_name.boxed :=
                      (m,
                        (Tezos_protocol_environment_alpha__Environment.Pervasives.snd
                          M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)))
                    |} in
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, M, ids, acc)
            end))
  | (Option_t _ _ true, None) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, None, ids, acc)
  | (List_t _ _ false, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Map_t _ _ _ false, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Option_t _ _ false, None) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, None, ids, acc)
  | (Pair_t _ _ _ false, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Union_t _ _ _ false, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Option_t _ _ false, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Chain_id_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Set_t _ _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Unit_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Int_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Nat_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Signature_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (String_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Bytes_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Mutez_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Key_hash_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Key_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Timestamp_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Address_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Bool_t _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Lambda_t _ _ _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Contract_t _ _, v) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
      (ctxt, v, ids, acc)
  | (Operation_t _, _) => false
  end.

Definition collect_big_maps {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (x : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let fix collect {a : Type}
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (ty :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (x : a) (acc :
    Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
        Tezos_raw_protocol_alpha.Alpha_context.context) :=
    match (ty, x) with
    | (Big_map_t _ _ _, {| id := Some id |}) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (Tezos_raw_protocol_alpha.Alpha_context.Gas.consume ctxt
          Typecheck_costs.cycle)
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.ok
            ((Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.add) id
              acc), ctxt))
    | (Pair_t (tyl, _, _) (tyr, _, _) _ true, (xl, xr)) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
        (collect ctxt tyl xl acc)
        (fun function_parameter =>
          match function_parameter with
          | (acc, ctxt) => collect ctxt tyr xr acc
          end)
    | (Union_t (ty, _) (_, _) _ true, L x) => collect ctxt ty x acc
    | (Union_t (_, _) (ty, _) _ true, R x) => collect ctxt ty x acc
    | (Option_t ty _ true, Some x) => collect ctxt ty x acc
    | (List_t ty _ true, l) =>
      Tezos_protocol_environment_alpha__Environment.List.fold_left
        (fun acc =>
          fun x =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
              acc
              (fun function_parameter =>
                match function_parameter with
                | (acc, ctxt) => collect ctxt ty x acc
                end))
        (Tezos_protocol_environment_alpha__Environment.Error_monad.ok
          (acc, ctxt)) l
    | (Map_t _ ty _ true, m) =>
      map_fold
        (fun function_parameter =>
          match function_parameter with
          | _ =>
            fun v =>
              fun acc =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  acc
                  (fun function_parameter =>
                    match function_parameter with
                    | (acc, ctxt) => collect ctxt ty v acc
                    end)
          end) m
        (Tezos_protocol_environment_alpha__Environment.Error_monad.ok
          (acc, ctxt))
    | (List_t _ _ false, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Map_t _ _ _ false, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Big_map_t _ _ _, {| id := None |}) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Option_t _ _ true, None) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Option_t _ _ false, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Union_t _ _ _ false, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Pair_t _ _ _ false, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Chain_id_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Set_t _ _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Unit_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Int_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Nat_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Signature_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (String_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Bytes_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Mutez_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Key_hash_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Key_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Timestamp_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Address_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Bool_t _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Lambda_t _ _ _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Contract_t _ _, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok (acc, ctxt)
    | (Operation_t _, _) => false
    end in
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (collect ctxt ty x no_big_map_id).

Definition extract_big_map_diff {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : unparsing_mode) (temporary : bool)
  (to_duplicate : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  (to_update : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (v : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A *
        (option
          (list
            Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_item))
        * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let to_duplicate :=
    Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.diff) to_duplicate
      to_update in
  let fresh :=
    if temporary then
      fun c =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (Tezos_raw_protocol_alpha.Alpha_context.Big_map.fresh_temporary c)
    else
      Tezos_raw_protocol_alpha.Alpha_context.Big_map.fresh in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (extract_big_map_updates ctxt fresh mode to_duplicate [] ty v)
    (fun function_parameter =>
      match function_parameter with
      | (ctxt, v, alive, diffs) =>
        let diffs :=
          if temporary then
            diffs
          else
            let dead :=
              Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.diff)
                to_update alive in
            cons
              (Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.fold)
                (fun id => fun acc => cons (Contract.Clear id) acc) dead [])
              diffs in
        match diffs with
        | [] =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (v, None, ctxt)
        | diffs =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (v,
              (Some
                (Tezos_protocol_environment_alpha__Environment.List.flatten
                  diffs)), ctxt)
        end
      end).

Definition list_of_big_map_ids
  (ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  : list Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.elt) :=
  Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.elements) ids.
src/proto_alpha/lib_protocol/script_ir_translator.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script_tc_errors

type ('ta, 'tb) eq = Eq : ('same, 'same) eq

type ex_comparable_ty =
  | Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty

type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty

type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty

type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script

type tc_context =
  | Lambda : tc_context
  | Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context
  | Toplevel : {
      storage_type : 'sto Script_typed_ir.ty;
      param_type : 'param Script_typed_ir.ty;
      root_name : string option;
      legacy_create_contract_literal : bool;
    }
      -> tc_context

type 'bef judgement =
  | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement
  | Failed : {
      descr :
        'aft. 'aft Script_typed_ir.stack_ty ->
        ('bef, 'aft) Script_typed_ir.descr;
    }
      -> 'bef judgement

type unparsing_mode = Optimized | Readable

type type_logger =
  int ->
  (Script.expr * Script.annot) list ->
  (Script.expr * Script.annot) list ->
  unit

(* ---- Sets and Maps -------------------------------------------------------*)

val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set

val set_fold :
  ('elt -> 'acc -> 'acc) -> 'elt Script_typed_ir.set -> 'acc -> 'acc

val set_update : 'a -> bool -> 'a Script_typed_ir.set -> 'a Script_typed_ir.set

val set_mem : 'elt -> 'elt Script_typed_ir.set -> bool

val set_size : 'elt Script_typed_ir.set -> Script_int.n Script_int.num

val empty_map :
  'a Script_typed_ir.comparable_ty -> ('a, 'b) Script_typed_ir.map

val map_fold :
  ('key -> 'value -> 'acc -> 'acc) ->
  ('key, 'value) Script_typed_ir.map ->
  'acc ->
  'acc

val map_update :
  'a ->
  'b option ->
  ('a, 'b) Script_typed_ir.map ->
  ('a, 'b) Script_typed_ir.map

val map_mem : 'key -> ('key, 'value) Script_typed_ir.map -> bool

val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option

val map_key_ty :
  ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty

val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num

val empty_big_map :
  'a Script_typed_ir.comparable_ty ->
  'b Script_typed_ir.ty ->
  ('a, 'b) Script_typed_ir.big_map

val big_map_mem :
  context ->
  'key ->
  ('key, 'value) Script_typed_ir.big_map ->
  (bool * context) tzresult Lwt.t

val big_map_get :
  context ->
  'key ->
  ('key, 'value) Script_typed_ir.big_map ->
  ('value option * context) tzresult Lwt.t

val big_map_update :
  'key ->
  'value option ->
  ('key, 'value) Script_typed_ir.big_map ->
  ('key, 'value) Script_typed_ir.big_map

val ty_eq :
  context ->
  'ta Script_typed_ir.ty ->
  'tb Script_typed_ir.ty ->
  (('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult

val compare_comparable : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> int

val parse_data :
  ?type_logger:type_logger ->
  context ->
  legacy:bool ->
  'a Script_typed_ir.ty ->
  Script.node ->
  ('a * context) tzresult Lwt.t

val unparse_data :
  context ->
  unparsing_mode ->
  'a Script_typed_ir.ty ->
  'a ->
  (Script.node * context) tzresult Lwt.t

val parse_instr :
  ?type_logger:type_logger ->
  tc_context ->
  context ->
  legacy:bool ->
  Script.node ->
  'bef Script_typed_ir.stack_ty ->
  ('bef judgement * context) tzresult Lwt.t

val parse_ty :
  context ->
  legacy:bool ->
  allow_big_map:bool ->
  allow_operation:bool ->
  allow_contract:bool ->
  Script.node ->
  (ex_ty * context) tzresult

val parse_packable_ty :
  context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult

val unparse_ty :
  context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t

val parse_toplevel :
  legacy:bool ->
  Script.expr ->
  (Script.node * Script.node * Script.node * string option) tzresult

val add_field_annot :
  [`Field_annot of string] option ->
  [`Var_annot of string] option ->
  Script.node ->
  Script.node

val typecheck_code :
  context -> Script.expr -> (type_map * context) tzresult Lwt.t

val typecheck_data :
  ?type_logger:type_logger ->
  context ->
  Script.expr * Script.expr ->
  context tzresult Lwt.t

val parse_script :
  ?type_logger:type_logger ->
  context ->
  legacy:bool ->
  Script.t ->
  (ex_script * context) tzresult Lwt.t

(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
val unparse_script :
  context ->
  unparsing_mode ->
  ('a, 'b) Script_typed_ir.script ->
  (Script.t * context) tzresult Lwt.t

val parse_contract :
  legacy:bool ->
  context ->
  Script.location ->
  'a Script_typed_ir.ty ->
  Contract.t ->
  entrypoint:string ->
  (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t

val parse_contract_for_script :
  legacy:bool ->
  context ->
  Script.location ->
  'a Script_typed_ir.ty ->
  Contract.t ->
  entrypoint:string ->
  (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t

val find_entrypoint :
  't Script_typed_ir.ty ->
  root_name:string option ->
  string ->
  ((Script.node -> Script.node) * ex_ty) tzresult

module Entrypoints_map : S.MAP with type key = string

val list_entrypoints :
  't Script_typed_ir.ty ->
  context ->
  root_name:string option ->
  ( Michelson_v1_primitives.prim list list
  * (Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t )
  tzresult

val pack_data :
  context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t

val hash_data :
  context ->
  'a Script_typed_ir.ty ->
  'a ->
  (Script_expr_hash.t * context) tzresult Lwt.t

type big_map_ids

val no_big_map_id : big_map_ids

val collect_big_maps :
  context ->
  'a Script_typed_ir.ty ->
  'a ->
  (big_map_ids * context) tzresult Lwt.t

val list_of_big_map_ids : big_map_ids -> Z.t list

val extract_big_map_diff :
  context ->
  unparsing_mode ->
  temporary:bool ->
  to_duplicate:big_map_ids ->
  to_update:big_map_ids ->
  'a Script_typed_ir.ty ->
  'a ->
  ('a * Contract.big_map_diff option * context) tzresult Lwt.t
src/proto_alpha/lib_protocol/script_ir_translator.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive eq : forall (ta tb : Type), Type :=
| Eq : forall {same : Type}, eq same same.

Inductive ex_comparable_ty : Type :=
| Ex_comparable_ty : forall {a : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) -> ex_comparable_ty.

Inductive ex_ty : Type :=
| Ex_ty : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
  ex_ty.

Inductive ex_stack_ty : Type :=
| Ex_stack_ty : forall {a : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) -> ex_stack_ty.

Inductive ex_script : Type :=
| Ex_script : forall {a b : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.script a b) -> ex_script.

Inductive tc_context : Type :=
| Lambda : tc_context
| Dip : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
  -> tc_context -> tc_context
| Toplevel : forall {param sto : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty sto) ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty param) -> (option string) -> bool
  -> tc_context.

Inductive judgement (bef : Type) : Type :=
| Typed : forall {aft : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) -> judgement bef
| Failed : forall {aft : Type},
  (((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft) ->
    Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) * (aft)) ->
  judgement bef.

Arguments Typed {_}.
Arguments Failed {_}.

Inductive unparsing_mode : Type :=
| Optimized : unparsing_mode
| Readable : unparsing_mode.

Definition type_logger :=
  Z ->
    (list
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) ->
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) -> unit.

Parameter empty_set : forall {a : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) ->
  Tezos_raw_protocol_alpha.Script_typed_ir.set a.

Parameter set_fold : forall {acc elt : Type},
(elt -> acc -> acc) ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.set elt) -> acc -> acc.

Parameter set_update : forall {a : Type},
a ->
  bool ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.set a) ->
      Tezos_raw_protocol_alpha.Script_typed_ir.set a.

Parameter set_mem : forall {elt : Type},
elt -> (Tezos_raw_protocol_alpha.Script_typed_ir.set elt) -> bool.

Parameter set_size : forall {elt : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.set elt) ->
  Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
    Tezos_raw_protocol_alpha.Alpha_context.Script_int.n.

Parameter empty_map : forall {a b : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) ->
  Tezos_raw_protocol_alpha.Script_typed_ir.map a b.

Parameter map_fold : forall {acc key value : Type},
(key -> value -> acc -> acc) ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.map key value) -> acc -> acc.

Parameter map_update : forall {a b : Type},
a ->
  (option b) ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.map a b) ->
      Tezos_raw_protocol_alpha.Script_typed_ir.map a b.

Parameter map_mem : forall {key value : Type},
key -> (Tezos_raw_protocol_alpha.Script_typed_ir.map key value) -> bool.

Parameter map_get : forall {key value : Type},
key -> (Tezos_raw_protocol_alpha.Script_typed_ir.map key value) -> option value.

Parameter map_key_ty : forall {a b : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.map a b) ->
  Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a.

Parameter map_size : forall {a b : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.map a b) ->
  Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
    Tezos_raw_protocol_alpha.Alpha_context.Script_int.n.

Parameter empty_big_map : forall {a b : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty b) ->
    Tezos_raw_protocol_alpha.Script_typed_ir.big_map a b.

Parameter big_map_mem : forall {key value : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  key ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.big_map key value) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (bool * Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter big_map_get : forall {key value : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  key ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.big_map key value) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((option value) * Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter big_map_update : forall {key value : Type},
key ->
  (option value) ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.big_map key value) ->
      Tezos_raw_protocol_alpha.Script_typed_ir.big_map key value.

Parameter ty_eq : forall {ta tb : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta) ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.ty tb) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
          (Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) *
          Tezos_raw_protocol_alpha.Alpha_context.context).

Parameter compare_comparable : forall {a : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) -> a -> a -> Z.

Parameter parse_data : forall {a : Type},
(option type_logger) ->
  Tezos_raw_protocol_alpha.Alpha_context.context ->
    bool ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
        Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (a * Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter unparse_data : forall {a : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  unparsing_mode ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
      a ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
              Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter parse_instr : forall {bef : Type},
(option type_logger) ->
  tc_context ->
    Tezos_raw_protocol_alpha.Alpha_context.context ->
      bool ->
        Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
          (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty bef) ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                ((judgement bef) *
                  Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter parse_ty :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  bool ->
    bool ->
      bool ->
        bool ->
          Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
            Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context).

Parameter parse_packable_ty :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  bool ->
    Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context).

Parameter unparse_ty : forall {a : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
          Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter parse_toplevel :
bool ->
  Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
        Tezos_raw_protocol_alpha.Alpha_context.Script.node *
        Tezos_raw_protocol_alpha.Alpha_context.Script.node * (option string)).

Parameter add_field_annot : forall {variant : Type},
(option variant) ->
  (option variant) ->
    Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.node.

Parameter typecheck_code :
Tezos_raw_protocol_alpha.Alpha_context.context ->
  Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Script_tc_errors.type_map *
          Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter typecheck_data :
(option type_logger) ->
  Tezos_raw_protocol_alpha.Alpha_context.context ->
    (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Alpha_context.context).

Parameter parse_script :
(option type_logger) ->
  Tezos_raw_protocol_alpha.Alpha_context.context ->
    bool ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (ex_script * Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter unparse_script : forall {a b : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  unparsing_mode ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.script a b) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.Script.t *
            Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter parse_contract : forall {a : Type},
bool ->
  Tezos_raw_protocol_alpha.Alpha_context.context ->
    Tezos_raw_protocol_alpha.Alpha_context.Script.location ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
        Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
          string ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Alpha_context.context *
                  (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract a))).

Parameter parse_contract_for_script : forall {a : Type},
bool ->
  Tezos_raw_protocol_alpha.Alpha_context.context ->
    Tezos_raw_protocol_alpha.Alpha_context.Script.location ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
        Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
          string ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Alpha_context.context *
                  (option
                    (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract a)))).

Parameter find_entrypoint : forall {t : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.ty t) ->
  (option string) ->
    string ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
          Tezos_raw_protocol_alpha.Alpha_context.Script.node) * ex_ty).

unhandled_module

Parameter list_entrypoints : forall {t : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.ty t) ->
  Tezos_raw_protocol_alpha.Alpha_context.context ->
    (option string) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
          (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
            ((list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) *
              Tezos_raw_protocol_alpha.Alpha_context.Script.node))).

Parameter pack_data : forall {a : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_protocol_environment_alpha__Environment.MBytes.t *
            Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter hash_data : forall {a : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Script_expr_hash.t *
            Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter big_map_ids : Type.

Parameter no_big_map_id : big_map_ids.

Parameter collect_big_maps : forall {a : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (big_map_ids * Tezos_raw_protocol_alpha.Alpha_context.context)).

Parameter list_of_big_map_ids :
big_map_ids -> list Tezos_protocol_environment_alpha__Environment.Z.t.

Parameter extract_big_map_diff : forall {a : Type},
Tezos_raw_protocol_alpha.Alpha_context.context ->
  unparsing_mode ->
    bool ->
      big_map_ids ->
        big_map_ids ->
          (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
            a ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  (a *
                    (option
                      Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)
                    * Tezos_raw_protocol_alpha.Alpha_context.context)).
src/proto_alpha/lib_protocol/script_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type location = Micheline.canonical_location

let location_encoding = Micheline.canonical_location_encoding

type annot = Micheline.annot

type expr = Michelson_v1_primitives.prim Micheline.canonical

type lazy_expr = expr Data_encoding.lazy_t

type node = (location, Michelson_v1_primitives.prim) Micheline.node

let expr_encoding =
  Micheline.canonical_encoding_v1
    ~variant:"michelson_v1"
    Michelson_v1_primitives.prim_encoding

type error += Lazy_script_decode (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"invalid_binary_format"
    ~title:"Invalid binary format"
    ~description:
      "Could not deserialize some piece of data from its binary representation"
    Data_encoding.empty
    (function Lazy_script_decode -> Some () | _ -> None)
    (fun () -> Lazy_script_decode)

let lazy_expr_encoding = Data_encoding.lazy_encoding expr_encoding

let lazy_expr expr = Data_encoding.make_lazy expr_encoding expr

type t = {code : lazy_expr; storage : lazy_expr}

let encoding =
  let open Data_encoding in
  def "scripted.contracts"
  @@ conv
       (fun {code; storage} -> (code, storage))
       (fun (code, storage) -> {code; storage})
       (obj2 (req "code" lazy_expr_encoding) (req "storage" lazy_expr_encoding))

let int_node_size_of_numbits n = (1, 1 + ((n + 63) / 64))

let int_node_size n = int_node_size_of_numbits (Z.numbits n)

let string_node_size_of_length s = (1, 1 + ((s + 7) / 8))

let string_node_size s = string_node_size_of_length (String.length s)

let bytes_node_size_of_length s =
  (* approx cost of indirection to the C heap *)
  (2, 1 + ((s + 7) / 8) + 12)

let bytes_node_size s = bytes_node_size_of_length (MBytes.length s)

let prim_node_size_nonrec_of_lengths n_args annots =
  let annots_length =
    List.fold_left (fun acc s -> acc + String.length s) 0 annots
  in
  if Compare.Int.(annots_length = 0) then (1 + n_args, 2 + (2 * n_args))
  else (2 + n_args, 4 + (2 * n_args) + ((annots_length + 7) / 8))

let prim_node_size_nonrec args annots =
  let n_args = List.length args in
  prim_node_size_nonrec_of_lengths n_args annots

let seq_node_size_nonrec_of_length n_args = (1 + n_args, 2 + (2 * n_args))

let seq_node_size_nonrec args =
  let n_args = List.length args in
  seq_node_size_nonrec_of_length n_args

let rec node_size node =
  let open Micheline in
  match node with
  | Int (_, n) ->
      int_node_size n
  | String (_, s) ->
      string_node_size s
  | Bytes (_, s) ->
      bytes_node_size s
  | Prim (_, _, args, annot) ->
      List.fold_left
        (fun (blocks, words) node ->
          let (nblocks, nwords) = node_size node in
          (blocks + nblocks, words + nwords))
        (prim_node_size_nonrec args annot)
        args
  | Seq (_, args) ->
      List.fold_left
        (fun (blocks, words) node ->
          let (nblocks, nwords) = node_size node in
          (blocks + nblocks, words + nwords))
        (seq_node_size_nonrec args)
        args

let expr_size expr = node_size (Micheline.root expr)

let traversal_cost node =
  let (blocks, _words) = node_size node in
  Gas_limit_repr.step_cost blocks

let cost_of_size (blocks, words) =
  let open Gas_limit_repr in
  (Compare.Int.max 0 (blocks - 1) *@ alloc_cost 0)
  +@ alloc_cost words +@ step_cost blocks

let node_cost node = cost_of_size (node_size node)

let int_node_cost n = cost_of_size (int_node_size n)

let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n)

let string_node_cost s = cost_of_size (string_node_size s)

let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s)

let bytes_node_cost s = cost_of_size (bytes_node_size s)

let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s)

let prim_node_cost_nonrec args annot =
  cost_of_size (prim_node_size_nonrec args annot)

let prim_node_cost_nonrec_of_length n_args annot =
  cost_of_size (prim_node_size_nonrec_of_lengths n_args annot)

let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args)

let seq_node_cost_nonrec_of_length n_args =
  cost_of_size (seq_node_size_nonrec_of_length n_args)

let deserialized_cost expr = cost_of_size (expr_size expr)

let serialized_cost bytes =
  let open Gas_limit_repr in
  alloc_mbytes_cost (MBytes.length bytes)

let force_decode lexpr =
  let account_deserialization_cost =
    Data_encoding.apply_lazy
      ~fun_value:(fun _ -> false)
      ~fun_bytes:(fun _ -> true)
      ~fun_combine:(fun _ _ -> false)
      lexpr
  in
  match Data_encoding.force_decode lexpr with
  | Some v ->
      if account_deserialization_cost then ok (v, deserialized_cost v)
      else ok (v, Gas_limit_repr.free)
  | None ->
      error Lazy_script_decode

let force_bytes expr =
  let open Gas_limit_repr in
  let account_serialization_cost =
    Data_encoding.apply_lazy
      ~fun_value:(fun v -> Some v)
      ~fun_bytes:(fun _ -> None)
      ~fun_combine:(fun _ _ -> None)
      expr
  in
  match Data_encoding.force_bytes expr with
  | bytes -> (
    match account_serialization_cost with
    | Some v ->
        ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes)
    | None ->
        ok (bytes, Gas_limit_repr.free) )
  | exception _ ->
      error Lazy_script_decode

let minimal_deserialize_cost lexpr =
  Data_encoding.apply_lazy
    ~fun_value:(fun _ -> Gas_limit_repr.free)
    ~fun_bytes:(fun b -> serialized_cost b)
    ~fun_combine:(fun c_free _ -> c_free)
    lexpr

let unit =
  Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))

let unit_parameter = lazy_expr unit

let is_unit_parameter =
  let unit_bytes = Data_encoding.force_bytes unit_parameter in
  Data_encoding.apply_lazy
    ~fun_value:(fun v ->
      match Micheline.root v with
      | Prim (_, Michelson_v1_primitives.D_Unit, [], []) ->
          true
      | _ ->
          false)
    ~fun_bytes:(fun b -> MBytes.( = ) b unit_bytes)
    ~fun_combine:(fun res _ -> res)

let rec strip_annotations node =
  let open Micheline in
  match node with
  | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf ->
      leaf
  | Prim (loc, name, args, _) ->
      Prim (loc, name, List.map strip_annotations args, [])
  | Seq (loc, args) ->
      Seq (loc, List.map strip_annotations args)
src/proto_alpha/lib_protocol/script_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition location :=
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location.

Definition location_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location :=
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location_encoding.

Definition annot :=
  Tezos_protocol_environment_alpha__Environment.Micheline.annot.

Definition expr :=
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim.

Definition lazy_expr :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t expr.

Definition node :=
  Tezos_protocol_environment_alpha__Environment.Micheline.node location
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim.

Definition expr_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical_encoding_v1
    "michelson_v1" % string
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim_encoding.

Definition lazy_expr_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
      (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
        Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_encoding
    expr_encoding.

Definition lazy_expr
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.make_lazy
    expr_encoding expr.

Record t := {
  code : lazy_expr;
  storage : lazy_expr }.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "scripted.contracts" % string in
    fun eta => arg None None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | {| code := code; storage := storage |} => (code, storage)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (code, storage) => {| code := code; storage := storage |}
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "code" % string lazy_expr_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "storage" % string lazy_expr_encoding))).

Definition int_node_size_of_numbits (n : Z) : Z * Z :=
  (1,
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus n 63)
        64))).

Definition int_node_size (n : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Z * Z :=
  int_node_size_of_numbits
    (Tezos_protocol_environment_alpha__Environment.Z.numbits n).

Definition string_node_size_of_length (s : Z) : Z * Z :=
  (1,
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus s 7) 8))).

Definition string_node_size (s : string) : Z * Z :=
  string_node_size_of_length
    (Tezos_protocol_environment_alpha__Environment.String.length s).

Definition bytes_node_size_of_length (s : Z) : Z * Z :=
  (2,
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus s 7)
          8)) 12)).

Definition bytes_node_size
  (s : Tezos_protocol_environment_alpha__Environment.MBytes.t) : Z * Z :=
  bytes_node_size_of_length
    (Tezos_protocol_environment_alpha__Environment.MBytes.length s).

Definition prim_node_size_nonrec_of_lengths (n_args : Z) (annots : list string)
  : Z * Z :=
  let annots_length :=
    Tezos_protocol_environment_alpha__Environment.List.fold_left
      (fun acc =>
        fun s =>
          Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus acc
            (Tezos_protocol_environment_alpha__Environment.String.length s)) 0
      annots in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
      annots_length 0 then
    ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1 n_args),
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 2
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star 2
          n_args)))
  else
    ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 2 n_args),
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 4
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star 2
            n_args))
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
            annots_length 7) 8))).

Definition prim_node_size_nonrec {A : Type}
  (args : list A) (annots : list string) : Z * Z :=
  let n_args := Tezos_protocol_environment_alpha__Environment.List.length args
    in
  prim_node_size_nonrec_of_lengths n_args annots.

Definition seq_node_size_nonrec_of_length (n_args : Z) : Z * Z :=
  ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 1 n_args),
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus 2
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star 2 n_args))).

Definition seq_node_size_nonrec {A : Type} (args : list A) : Z * Z :=
  let n_args := Tezos_protocol_environment_alpha__Environment.List.length args
    in
  seq_node_size_nonrec_of_length n_args.

Fixpoint node_size {A B : Type}
  (node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Z * Z :=
  match node with
  | Int _ n => int_node_size n
  | String _ s => string_node_size s
  | Bytes _ s => bytes_node_size s
  | Prim _ _ args annot =>
    Tezos_protocol_environment_alpha__Environment.List.fold_left
      (fun function_parameter =>
        match function_parameter with
        | (blocks, words) =>
          fun node =>
            match node_size node with
            | (nblocks, nwords) =>
              ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                blocks nblocks),
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                  words nwords))
            end
        end) (prim_node_size_nonrec args annot) args
  | Seq _ args =>
    Tezos_protocol_environment_alpha__Environment.List.fold_left
      (fun function_parameter =>
        match function_parameter with
        | (blocks, words) =>
          fun node =>
            match node_size node with
            | (nblocks, nwords) =>
              ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                blocks nblocks),
                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                  words nwords))
            end
        end) (seq_node_size_nonrec args) args
  end.

Definition expr_size {A : Type}
  (expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical A)
  : Z * Z :=
  node_size (Tezos_protocol_environment_alpha__Environment.Micheline.root expr).

Definition traversal_cost {A B : Type}
  (node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  match node_size node with
  | (blocks, _words) => Tezos_raw_protocol_alpha.Gas_limit_repr.step_cost blocks
  end.

Definition cost_of_size (function_parameter : Z * Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  match function_parameter with
  | (blocks, words) =>
    Tezos_raw_protocol_alpha.Gas_limit_repr.op_plus_at
      (Tezos_raw_protocol_alpha.Gas_limit_repr.op_plus_at
        (Tezos_raw_protocol_alpha.Gas_limit_repr.op_star_at
          (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
            0
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
              blocks 1)) (Tezos_raw_protocol_alpha.Gas_limit_repr.alloc_cost 0))
        (Tezos_raw_protocol_alpha.Gas_limit_repr.alloc_cost words))
      (Tezos_raw_protocol_alpha.Gas_limit_repr.step_cost blocks)
  end.

Definition node_cost {A B : Type}
  (node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (node_size node).

Definition int_node_cost (n : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (int_node_size n).

Definition int_node_cost_of_numbits (n : Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (int_node_size_of_numbits n).

Definition string_node_cost (s : string)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (string_node_size s).

Definition string_node_cost_of_length (s : Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (string_node_size_of_length s).

Definition bytes_node_cost
  (s : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (bytes_node_size s).

Definition bytes_node_cost_of_length (s : Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (bytes_node_size_of_length s).

Definition prim_node_cost_nonrec {A : Type}
  (args : list A) (annot : list string)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (prim_node_size_nonrec args annot).

Definition prim_node_cost_nonrec_of_length (n_args : Z) (annot : list string)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (prim_node_size_nonrec_of_lengths n_args annot).

Definition seq_node_cost_nonrec {A : Type} (args : list A)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (seq_node_size_nonrec args).

Definition seq_node_cost_nonrec_of_length (n_args : Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (seq_node_size_nonrec_of_length n_args).

Definition deserialized_cost {A : Type}
  (expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical A)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (expr_size expr).

Definition serialized_cost
  (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  Tezos_raw_protocol_alpha.Gas_limit_repr.alloc_mbytes_cost
    (Tezos_protocol_environment_alpha__Environment.MBytes.length string).

Definition force_decode {A : Type}
  (lexpr :
    Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
      (Tezos_protocol_environment_alpha__Environment.Micheline.canonical A))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical A) *
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost) :=
  let account_deserialization_cost :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.apply_lazy
      (fun function_parameter =>
        match function_parameter with
        | _ => false
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ => true
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => false
            end
        end) lexpr in
  match
    Tezos_protocol_environment_alpha__Environment.Data_encoding.force_decode
      lexpr with
  | Some v =>
    if account_deserialization_cost then
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
        (v, (deserialized_cost v))
    else
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
        (v, Tezos_raw_protocol_alpha.Gas_limit_repr.free)
  | None =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Lazy_script_decode
  end.

Definition force_bytes {A : Type}
  (expr :
    Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
      (Tezos_protocol_environment_alpha__Environment.Micheline.canonical A))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_protocol_environment_alpha__Environment.MBytes.t *
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost) :=
  let account_serialization_cost :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.apply_lazy
      (fun v => Some v)
      (fun function_parameter =>
        match function_parameter with
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | _ => None
            end
        end) expr in
  match
    Tezos_protocol_environment_alpha__Environment.Data_encoding.force_bytes expr
    with
  | bytes =>
    match account_serialization_cost with
    | Some v =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
        (string,
          (Tezos_raw_protocol_alpha.Gas_limit_repr.op_plus_at
            (traversal_cost
              (Tezos_protocol_environment_alpha__Environment.Micheline.root v))
            (serialized_cost string)))
    | None =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
        (string, Tezos_raw_protocol_alpha.Gas_limit_repr.free)
    end
  end.

Definition minimal_deserialize_cost {A : Type}
  (lexpr : Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t A)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.apply_lazy
    (fun function_parameter =>
      match function_parameter with
      | _ => Tezos_raw_protocol_alpha.Gas_limit_repr.free
      end) (fun b => serialized_cost b)
    (fun c_free =>
      fun function_parameter =>
        match function_parameter with
        | _ => c_free
        end) lexpr.

Definition unit
  : Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim :=
  Tezos_protocol_environment_alpha__Environment.Micheline.strip_locations
    (Prim 0 Michelson_v1_primitives.D_Unit [] []).

Definition unit_parameter
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) := lazy_expr unit.

Definition is_unit_parameter
  : (Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) -> bool :=
  let unit_bytes :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.force_bytes
      unit_parameter in
  Tezos_protocol_environment_alpha__Environment.Data_encoding.apply_lazy
    (fun v =>
      match Tezos_protocol_environment_alpha__Environment.Micheline.root v with
      | Prim _ Michelson_v1_primitives.D_Unit [] [] => true
      | _ => false
      end)
    (fun b =>
      Tezos_protocol_environment_alpha__Environment.MBytes.op_eq b unit_bytes)
    (fun res =>
      fun function_parameter =>
        match function_parameter with
        | _ => res
        end).

Fixpoint strip_annotations {A B : Type}
  (node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
  match node with
  | (Int _ _ | String _ _ | Bytes _ _) as leaf => leaf
  | Prim loc name args _ =>
    Prim loc name
      (Tezos_protocol_environment_alpha__Environment.List.map strip_annotations
        args) []
  | Seq loc args =>
    Seq loc
      (Tezos_protocol_environment_alpha__Environment.List.map strip_annotations
        args)
  end.
src/proto_alpha/lib_protocol/script_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type location = Micheline.canonical_location

type annot = Micheline.annot

type expr = Michelson_v1_primitives.prim Micheline.canonical

type error += Lazy_script_decode (* `Permanent *)

type lazy_expr = expr Data_encoding.lazy_t

type node = (location, Michelson_v1_primitives.prim) Micheline.node

val location_encoding : location Data_encoding.t

val expr_encoding : expr Data_encoding.t

val lazy_expr_encoding : lazy_expr Data_encoding.t

val lazy_expr : expr -> lazy_expr

type t = {code : lazy_expr; storage : lazy_expr}

val encoding : t Data_encoding.encoding

val deserialized_cost : expr -> Gas_limit_repr.cost

val serialized_cost : MBytes.t -> Gas_limit_repr.cost

val traversal_cost : node -> Gas_limit_repr.cost

val node_cost : node -> Gas_limit_repr.cost

val int_node_cost : Z.t -> Gas_limit_repr.cost

val int_node_cost_of_numbits : int -> Gas_limit_repr.cost

val string_node_cost : string -> Gas_limit_repr.cost

val string_node_cost_of_length : int -> Gas_limit_repr.cost

val bytes_node_cost : MBytes.t -> Gas_limit_repr.cost

val bytes_node_cost_of_length : int -> Gas_limit_repr.cost

val prim_node_cost_nonrec : expr list -> annot -> Gas_limit_repr.cost

val prim_node_cost_nonrec_of_length : int -> annot -> Gas_limit_repr.cost

val seq_node_cost_nonrec : expr list -> Gas_limit_repr.cost

val seq_node_cost_nonrec_of_length : int -> Gas_limit_repr.cost

val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult

val force_bytes : lazy_expr -> (MBytes.t * Gas_limit_repr.cost) tzresult

val minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost

val unit_parameter : lazy_expr

val is_unit_parameter : lazy_expr -> bool

val strip_annotations : node -> node
src/proto_alpha/lib_protocol/script_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition location :=
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location.

Definition annot :=
  Tezos_protocol_environment_alpha__Environment.Micheline.annot.

Definition expr :=
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim.

extensible_type

Definition lazy_expr :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t expr.

Definition node :=
  Tezos_protocol_environment_alpha__Environment.Micheline.node location
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim.

Parameter location_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t location.

Parameter expr_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t expr.

Parameter lazy_expr_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t lazy_expr.

Parameter lazy_expr : expr -> lazy_expr.

Record t := {
  code : lazy_expr;
  storage : lazy_expr }.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t.

Parameter deserialized_cost :
expr -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter serialized_cost :
Tezos_protocol_environment_alpha__Environment.MBytes.t ->
  Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter traversal_cost : node -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter node_cost : node -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter int_node_cost :
Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter int_node_cost_of_numbits :
Z -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter string_node_cost :
string -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter string_node_cost_of_length :
Z -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter bytes_node_cost :
Tezos_protocol_environment_alpha__Environment.MBytes.t ->
  Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter bytes_node_cost_of_length :
Z -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter prim_node_cost_nonrec :
(list expr) -> annot -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter prim_node_cost_nonrec_of_length :
Z -> annot -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter seq_node_cost_nonrec :
(list expr) -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter seq_node_cost_nonrec_of_length :
Z -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter force_decode :
lazy_expr ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (expr * Tezos_raw_protocol_alpha.Gas_limit_repr.cost).

Parameter force_bytes :
lazy_expr ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_protocol_environment_alpha__Environment.MBytes.t *
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost).

Parameter minimal_deserialize_cost :
lazy_expr -> Tezos_raw_protocol_alpha.Gas_limit_repr.cost.

Parameter unit_parameter : lazy_expr.

Parameter is_unit_parameter : lazy_expr -> bool.

Parameter strip_annotations : node -> node.
src/proto_alpha/lib_protocol/script_tc_errors.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script

(* ---- Error definitions ---------------------------------------------------*)

(* Auxiliary types for error documentation *)
type namespace =
  | Type_namespace
  | Constant_namespace
  | Instr_namespace
  | Keyword_namespace

type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind

type unparsed_stack_ty = (Script.expr * Script.annot) list

type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list

(* Structure errors *)
type error += Invalid_arity of Script.location * prim * int * int

type error +=
  | Invalid_namespace of Script.location * prim * namespace * namespace

type error += Invalid_primitive of Script.location * prim list * prim

type error += Invalid_kind of Script.location * kind list * kind

type error += Missing_field of prim

type error += Duplicate_field of Script.location * prim

type error += Unexpected_big_map of Script.location

type error += Unexpected_operation of Script.location

type error += Unexpected_contract of Script.location

type error += No_such_entrypoint of string

type error += Duplicate_entrypoint of string

type error += Unreachable_entrypoint of prim list

type error += Entrypoint_name_too_long of string

(* Instruction typing errors *)
type error += Fail_not_in_tail_position of Script.location

type error +=
  | Undefined_binop :
      Script.location * prim * Script.expr * Script.expr
      -> error

type error += Undefined_unop : Script.location * prim * Script.expr -> error

type error +=
  | Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error

type error +=
  | Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error

type error +=
  | Unmatched_branches :
      Script.location * unparsed_stack_ty * unparsed_stack_ty
      -> error

type error += Self_in_lambda of Script.location

type error += Bad_stack_length

type error += Bad_stack_item of int

type error += Inconsistent_annotations of string * string

type error +=
  | Inconsistent_type_annotations :
      Script.location * Script.expr * Script.expr
      -> error

type error += Inconsistent_field_annotations of string * string

type error += Unexpected_annotation of Script.location

type error += Ungrouped_annotations of Script.location

type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error

type error += Invalid_map_block_fail of Script.location

type error +=
  | Invalid_iter_body :
      Script.location * unparsed_stack_ty * unparsed_stack_ty
      -> error

type error += Type_too_large : Script.location * int * int -> error

(* Value typing errors *)
type error +=
  | Invalid_constant : Script.location * Script.expr * Script.expr -> error

type error +=
  | Invalid_syntactic_constant :
      Script.location * Script.expr * string
      -> error

type error += Invalid_contract of Script.location * Contract.t

type error += Invalid_big_map of Script.location * Big_map.id

type error +=
  | Comparable_type_expected : Script.location * Script.expr -> error

type error += Inconsistent_types : Script.expr * Script.expr -> error

type error += Unordered_map_keys of Script.location * Script.expr

type error += Unordered_set_values of Script.location * Script.expr

type error += Duplicate_map_keys of Script.location * Script.expr

type error += Duplicate_set_values of Script.location * Script.expr

(* Toplevel errors *)
type error +=
  | Ill_typed_data : string option * Script.expr * Script.expr -> error

type error +=
  | Ill_formed_type of string option * Script.expr * Script.location

type error += Ill_typed_contract : Script.expr * type_map -> error

(* Gas related errors *)
type error += Cannot_serialize_error

(* Deprecation errors *)
type error += Deprecated_instruction of prim
src/proto_alpha/lib_protocol/script_tc_errors.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_raw_protocol_alpha.Alpha_context.Script.

Inductive namespace : Type :=
| Type_namespace : namespace
| Constant_namespace : namespace
| Instr_namespace : namespace
| Keyword_namespace : namespace.

Inductive kind : Type :=
| Int_kind : kind
| String_kind : kind
| Bytes_kind : kind
| Prim_kind : kind
| Seq_kind : kind.

Definition unparsed_stack_ty :=
  list
    (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.annot).

Definition type_map := list (Z * (unparsed_stack_ty * unparsed_stack_ty)).
src/proto_alpha/lib_protocol/script_tc_errors_registration.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script
open Script_tc_errors

(* Helpers for encoding *)
let type_map_enc =
  let open Data_encoding in
  let stack_enc = list (tup2 Script.expr_encoding (list string)) in
  list
    (conv
       (fun (loc, (bef, aft)) -> (loc, bef, aft))
       (fun (loc, bef, aft) -> (loc, (bef, aft)))
       (obj3
          (req "location" Script.location_encoding)
          (req "stack_before" stack_enc)
          (req "stack_after" stack_enc)))

let stack_ty_enc =
  let open Data_encoding in
  list (obj2 (req "type" Script.expr_encoding) (dft "annots" (list string) []))

(* main registration *)
let () =
  let open Data_encoding in
  let located enc =
    merge_objs (obj1 (req "location" Script.location_encoding)) enc
  in
  let arity_enc = int8 in
  let namespace_enc =
    def
      "primitiveNamespace"
      ~title:"Primitive namespace"
      ~description:
        "One of the three possible namespaces of primitive (data constructor, \
         type name or instruction)."
    @@ string_enum
         [ ("type", Type_namespace);
           ("constant", Constant_namespace);
           ("instruction", Instr_namespace) ]
  in
  let kind_enc =
    def
      "expressionKind"
      ~title:"Expression kind"
      ~description:
        "One of the four possible kinds of expression (integer, string, \
         primitive application or sequence)."
    @@ string_enum
         [ ("integer", Int_kind);
           ("string", String_kind);
           ("bytes", Bytes_kind);
           ("primitiveApplication", Prim_kind);
           ("sequence", Seq_kind) ]
  in
  (* -- Structure errors ---------------------- *)
  (* Invalid arity *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_arity"
    ~title:"Invalid arity"
    ~description:
      "In a script or data expression, a primitive was applied to an \
       unsupported number of arguments."
    (located
       (obj3
          (req "primitive_name" Script.prim_encoding)
          (req "expected_arity" arity_enc)
          (req "wrong_arity" arity_enc)))
    (function
      | Invalid_arity (loc, name, exp, got) ->
          Some (loc, (name, exp, got))
      | _ ->
          None)
    (fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ;
  (* Missing field *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.missing_script_field"
    ~title:"Script is missing a field (parse error)"
    ~description:"When parsing script, a field was expected, but not provided"
    (obj1 (req "prim" prim_encoding))
    (function Missing_field prim -> Some prim | _ -> None)
    (fun prim -> Missing_field prim) ;
  (* Invalid primitive *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive"
    ~title:"Invalid primitive"
    ~description:"In a script or data expression, a primitive was unknown."
    (located
       (obj2
          (dft "expected_primitive_names" (list prim_encoding) [])
          (req "wrong_primitive_name" prim_encoding)))
    (function
      | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)
    (fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ;
  (* Invalid kind *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_expression_kind"
    ~title:"Invalid expression kind"
    ~description:
      "In a script or data expression, an expression was of the wrong kind \
       (for instance a string where only a primitive applications can appear)."
    (located
       (obj2 (req "expected_kinds" (list kind_enc)) (req "wrong_kind" kind_enc)))
    (function
      | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)
    (fun (loc, (exp, got)) -> Invalid_kind (loc, exp, got)) ;
  (* Invalid namespace *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_namespace"
    ~title:"Invalid primitive namespace"
    ~description:
      "In a script or data expression, a primitive was of the wrong namespace."
    (located
       (obj3
          (req "primitive_name" prim_encoding)
          (req "expected_namespace" namespace_enc)
          (req "wrong_namespace" namespace_enc)))
    (function
      | Invalid_namespace (loc, name, exp, got) ->
          Some (loc, (name, exp, got))
      | _ ->
          None)
    (fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ;
  (* Duplicate field *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_script_field"
    ~title:"Script has a duplicated field (parse error)"
    ~description:"When parsing script, a field was found more than once"
    (obj2 (req "loc" location_encoding) (req "prim" prim_encoding))
    (function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None)
    (fun (loc, prim) -> Duplicate_field (loc, prim)) ;
  (* Unexpected big_map *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_bigmap"
    ~title:"Big map in unauthorized position (type error)"
    ~description:
      "When parsing script, a big_map type was found in a position where it \
       could end up stored inside a big_map, which is forbidden for now."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_big_map loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_big_map loc) ;
  (* Unexpected operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_operation"
    ~title:"Operation in unauthorized position (type error)"
    ~description:
      "When parsing script, an operation type was found in the storage or \
       parameter field."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_operation loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_operation loc) ;
  (* No such entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.no_such_entrypoint"
    ~title:"No such entrypoint (type error)"
    ~description:"An entrypoint was not found when calling a contract."
    (obj1 (req "entrypoint" string))
    (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> No_such_entrypoint entrypoint) ;
  (* Unreachable entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unreachable_entrypoint"
    ~title:"Unreachable entrypoint (type error)"
    ~description:"An entrypoint in the contract is not reachable."
    (obj1 (req "path" (list prim_encoding)))
    (function Unreachable_entrypoint path -> Some path | _ -> None)
    (fun path -> Unreachable_entrypoint path) ;
  (* Duplicate entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_entrypoint"
    ~title:"Duplicate entrypoint (type error)"
    ~description:"Two entrypoints have the same name."
    (obj1 (req "path" string))
    (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> Duplicate_entrypoint entrypoint) ;
  (* Entrypoint name too long *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.entrypoint_name_too_long"
    ~title:"Entrypoint name too long (type error)"
    ~description:
      "An entrypoint name exceeds the maximum length of 31 characters."
    (obj1 (req "name" string))
    (function
      | Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> Entrypoint_name_too_long entrypoint) ;
  (* Unexpected contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_contract"
    ~title:"Contract in unauthorized position (type error)"
    ~description:
      "When parsing script, a contract type was found in the storage or \
       parameter field."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_contract loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_contract loc) ;
  (* -- Value typing errors ---------------------- *)
  (* Unordered map keys *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unordered_map_literal"
    ~title:"Invalid map key order"
    ~description:"Map keys must be in strictly increasing order"
    (obj2
       (req "location" Script.location_encoding)
       (req "item" Script.expr_encoding))
    (function Unordered_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Unordered_map_keys (loc, expr)) ;
  (* Duplicate map keys *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_map_keys"
    ~title:"Duplicate map keys"
    ~description:"Map literals cannot contain duplicated keys"
    (obj2
       (req "location" Script.location_encoding)
       (req "item" Script.expr_encoding))
    (function Duplicate_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Duplicate_map_keys (loc, expr)) ;
  (* Unordered set values *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unordered_set_literal"
    ~title:"Invalid set value order"
    ~description:"Set values must be in strictly increasing order"
    (obj2
       (req "location" Script.location_encoding)
       (req "value" Script.expr_encoding))
    (function
      | Unordered_set_values (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Unordered_set_values (loc, expr)) ;
  (* Duplicate set values *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_set_values_in_literal"
    ~title:"Sets literals cannot contain duplicate elements"
    ~description:
      "Set literals cannot contain duplicate elements, but a duplicae was \
       found while parsing."
    (obj2
       (req "location" Script.location_encoding)
       (req "value" Script.expr_encoding))
    (function
      | Duplicate_set_values (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Duplicate_set_values (loc, expr)) ;
  (* -- Instruction typing errors ------------- *)
  (* Fail not in tail position *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.fail_not_in_tail_position"
    ~title:"FAIL not in tail position"
    ~description:"There is non trivial garbage code after a FAIL instruction."
    (located empty)
    (function Fail_not_in_tail_position loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Fail_not_in_tail_position loc) ;
  (* Undefined binary operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.undefined_binop"
    ~title:"Undefined binop"
    ~description:
      "A binary operation is called on operands of types over which it is not \
       defined."
    (located
       (obj3
          (req "operator_name" prim_encoding)
          (req "wrong_left_operand_type" Script.expr_encoding)
          (req "wrong_right_operand_type" Script.expr_encoding)))
    (function
      | Undefined_binop (loc, n, tyl, tyr) ->
          Some (loc, (n, tyl, tyr))
      | _ ->
          None)
    (fun (loc, (n, tyl, tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ;
  (* Undefined unary operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.undefined_unop"
    ~title:"Undefined unop"
    ~description:
      "A unary operation is called on an operand of type over which it is not \
       defined."
    (located
       (obj2
          (req "operator_name" prim_encoding)
          (req "wrong_operand_type" Script.expr_encoding)))
    (function Undefined_unop (loc, n, ty) -> Some (loc, (n, ty)) | _ -> None)
    (fun (loc, (n, ty)) -> Undefined_unop (loc, n, ty)) ;
  (* Bad return *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_return"
    ~title:"Bad return"
    ~description:"Unexpected stack at the end of a lambda or script."
    (located
       (obj2
          (req "expected_return_type" Script.expr_encoding)
          (req "wrong_stack_type" stack_ty_enc)))
    (function Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) | _ -> None)
    (fun (loc, (ty, sty)) -> Bad_return (loc, sty, ty)) ;
  (* Bad stack *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_stack"
    ~title:"Bad stack"
    ~description:"The stack has an unexpected length or contents."
    (located
       (obj3
          (req "primitive_name" prim_encoding)
          (req "relevant_stack_portion" int16)
          (req "wrong_stack_type" stack_ty_enc)))
    (function
      | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) | _ -> None)
    (fun (loc, (name, s, sty)) -> Bad_stack (loc, name, s, sty)) ;
  (* Inconsistent annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_annotations"
    ~title:"Annotations inconsistent between branches"
    ~description:"The annotations on two types could not be merged"
    (obj2 (req "annot1" string) (req "annot2" string))
    (function
      | Inconsistent_annotations (annot1, annot2) ->
          Some (annot1, annot2)
      | _ ->
          None)
    (fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ;
  (* Inconsistent field annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_field_annotations"
    ~title:"Annotations for field accesses is inconsistent"
    ~description:
      "The specified field does not match the field annotation in the type"
    (obj2 (req "annot1" string) (req "annot2" string))
    (function
      | Inconsistent_field_annotations (annot1, annot2) ->
          Some (annot1, annot2)
      | _ ->
          None)
    (fun (annot1, annot2) -> Inconsistent_field_annotations (annot1, annot2)) ;
  (* Inconsistent type annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_type_annotations"
    ~title:"Types contain inconsistent annotations"
    ~description:"The two types contain annotations that do not match"
    (located
       (obj2
          (req "type1" Script.expr_encoding)
          (req "type2" Script.expr_encoding)))
    (function
      | Inconsistent_type_annotations (loc, ty1, ty2) ->
          Some (loc, (ty1, ty2))
      | _ ->
          None)
    (fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ;
  (* Unexpected annotation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_annotation"
    ~title:"An annotation was encountered where no annotation is expected"
    ~description:"A node in the syntax tree was impropperly annotated"
    (located empty)
    (function Unexpected_annotation loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Unexpected_annotation loc) ;
  (* Ungrouped annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ungrouped_annotations"
    ~title:"Annotations of the same kind were found spread apart"
    ~description:"Annotations of the same kind must be grouped"
    (located empty)
    (function Ungrouped_annotations loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Ungrouped_annotations loc) ;
  (* Unmatched branches *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unmatched_branches"
    ~title:"Unmatched branches"
    ~description:
      "At the join point at the end of two code branches the stacks have \
       inconsistent lengths or contents."
    (located
       (obj2
          (req "first_stack_type" stack_ty_enc)
          (req "other_stack_type" stack_ty_enc)))
    (function
      | Unmatched_branches (loc, stya, styb) ->
          Some (loc, (stya, styb))
      | _ ->
          None)
    (fun (loc, (stya, styb)) -> Unmatched_branches (loc, stya, styb)) ;
  (* Bad stack item *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_stack_item"
    ~title:"Bad stack item"
    ~description:
      "The type of a stack item is unexpected (this error is always \
       accompanied by a more precise one)."
    (obj1 (req "item_level" int16))
    (function Bad_stack_item n -> Some n | _ -> None)
    (fun n -> Bad_stack_item n) ;
  (* SELF in lambda *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.self_in_lambda"
    ~title:"SELF instruction in lambda"
    ~description:"A SELF instruction was encountered in a lambda expression."
    (located empty)
    (function Self_in_lambda loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Self_in_lambda loc) ;
  (* Bad stack length *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_stack_lengths"
    ~title:"Inconsistent stack lengths"
    ~description:
      "A stack was of an unexpected length (this error is always in the \
       context of a located error)."
    empty
    (function Bad_stack_length -> Some () | _ -> None)
    (fun () -> Bad_stack_length) ;
  (* -- Value typing errors ------------------- *)
  (* Invalid constant *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_constant"
    ~title:"Invalid constant"
    ~description:"A data expression was invalid for its expected type."
    (located
       (obj2
          (req "expected_type" Script.expr_encoding)
          (req "wrong_expression" Script.expr_encoding)))
    (function
      | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)
    (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;
  (* Invalid syntactic constant *)
  register_error_kind
    `Permanent
    ~id:"invalidSyntacticConstantError"
    ~title:"Invalid constant (parse error)"
    ~description:"A compile-time constant was invalid for its expected form."
    (located
       (obj2
          (req "expectedForm" Script.expr_encoding)
          (req "wrongExpression" Script.expr_encoding)))
    (function
      | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)
    (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;
  (* Invalid contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_contract"
    ~title:"Invalid contract"
    ~description:
      "A script or data expression references a contract that does not exist \
       or assumes a wrong type for an existing contract."
    (located (obj1 (req "contract" Contract.encoding)))
    (function Invalid_contract (loc, c) -> Some (loc, c) | _ -> None)
    (fun (loc, c) -> Invalid_contract (loc, c)) ;
  (* Invalid big_map *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_big_map"
    ~title:"Invalid big_map"
    ~description:
      "A script or data expression references a big_map that does not exist \
       or assumes a wrong type for an existing big_map."
    (located (obj1 (req "big_map" z)))
    (function Invalid_big_map (loc, c) -> Some (loc, c) | _ -> None)
    (fun (loc, c) -> Invalid_big_map (loc, c)) ;
  (* Comparable type expected *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.comparable_type_expected"
    ~title:"Comparable type expected"
    ~description:
      "A non comparable type was used in a place where only comparable types \
       are accepted."
    (located (obj1 (req "wrong_type" Script.expr_encoding)))
    (function
      | Comparable_type_expected (loc, ty) -> Some (loc, ty) | _ -> None)
    (fun (loc, ty) -> Comparable_type_expected (loc, ty)) ;
  (* Inconsistent types *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_types"
    ~title:"Inconsistent types"
    ~description:
      "This is the basic type clash error, that appears in several places \
       where the equality of two types have to be proven, it is always \
       accompanied with another error that provides more context."
    (obj2
       (req "first_type" Script.expr_encoding)
       (req "other_type" Script.expr_encoding))
    (function Inconsistent_types (tya, tyb) -> Some (tya, tyb) | _ -> None)
    (fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ;
  (* -- Instruction typing errors ------------------- *)
  (* Invalid map body *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_map_body"
    ~title:"Invalid map body"
    ~description:"The body of a map block did not match the expected type"
    (obj2 (req "loc" Script.location_encoding) (req "body_type" stack_ty_enc))
    (function Invalid_map_body (loc, stack) -> Some (loc, stack) | _ -> None)
    (fun (loc, stack) -> Invalid_map_body (loc, stack)) ;
  (* Invalid map block FAIL *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_map_block_fail"
    ~title:"FAIL instruction occurred as body of map block"
    ~description:
      "FAIL cannot be the only instruction in the body. The propper type of \
       the return list cannot be inferred."
    (obj1 (req "loc" Script.location_encoding))
    (function Invalid_map_block_fail loc -> Some loc | _ -> None)
    (fun loc -> Invalid_map_block_fail loc) ;
  (* Invalid ITER body *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_iter_body"
    ~title:"ITER body returned wrong stack type"
    ~description:
      "The body of an ITER instruction must result in the same stack type as \
       before the ITER."
    (obj3
       (req "loc" Script.location_encoding)
       (req "bef_stack" stack_ty_enc)
       (req "aft_stack" stack_ty_enc))
    (function
      | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) | _ -> None)
    (fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ;
  (* Type too large *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.type_too_large"
    ~title:"Stack item type too large"
    ~description:"An instruction generated a type larger than the limit."
    (obj3
       (req "loc" Script.location_encoding)
       (req "type_size" uint16)
       (req "maximum_type_size" uint16))
    (function
      | Type_too_large (loc, ts, maxts) -> Some (loc, ts, maxts) | _ -> None)
    (fun (loc, ts, maxts) -> Type_too_large (loc, ts, maxts)) ;
  (* -- Toplevel errors ------------------- *)
  (* Ill typed data *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_typed_data"
    ~title:"Ill typed data"
    ~description:
      "The toplevel error thrown when trying to typecheck a data expression \
       against a given type (always followed by more precise errors)."
    (obj3
       (opt "identifier" string)
       (req "expected_type" Script.expr_encoding)
       (req "ill_typed_expression" Script.expr_encoding))
    (function
      | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) | _ -> None)
    (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ;
  (* Ill formed type *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_formed_type"
    ~title:"Ill formed type"
    ~description:
      "The toplevel error thrown when trying to parse a type expression \
       (always followed by more precise errors)."
    (obj3
       (opt "identifier" string)
       (req "ill_formed_expression" Script.expr_encoding)
       (req "location" Script.location_encoding))
    (function
      | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) | _ -> None)
    (fun (name, expr, loc) -> Ill_formed_type (name, expr, loc)) ;
  (* Ill typed contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_typed_contract"
    ~title:"Ill typed contract"
    ~description:
      "The toplevel error thrown when trying to typecheck a contract code \
       against given input, output and storage types (always followed by more \
       precise errors)."
    (obj2
       (req "ill_typed_code" Script.expr_encoding)
       (req "type_map" type_map_enc))
    (function
      | Ill_typed_contract (expr, type_map) ->
          Some (expr, type_map)
      | _ ->
          None)
    (fun (expr, type_map) -> Ill_typed_contract (expr, type_map)) ;
  (* Cannot serialize error *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_error"
    ~title:"Not enough gas to serialize error"
    ~description:"The error was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_error -> Some () | _ -> None)
    (fun () -> Cannot_serialize_error) ;
  (* Deprecated instruction *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.deprecated_instruction"
    ~title:"Script is using a deprecated instruction"
    ~description:
      "A deprecated instruction usage is disallowed in newly created contracts"
    (obj1 (req "prim" prim_encoding))
    (function Deprecated_instruction prim -> Some prim | _ -> None)
    (fun prim -> Deprecated_instruction prim)
src/proto_alpha/lib_protocol/script_tc_errors_registration.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_raw_protocol_alpha.Alpha_context.Script.

Import Tezos_raw_protocol_alpha.Script_tc_errors.

Definition type_map_enc
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list
      (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
        ((list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string)))
          *
          (list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string)))))) :=
  let stack_enc :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
          Tezos_protocol_environment_alpha__Environment.Data_encoding.string))
    in
  Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
      (fun function_parameter =>
        match function_parameter with
        | (loc, (bef, aft)) => (loc, bef, aft)
        end)
      (fun function_parameter =>
        match function_parameter with
        | (loc, bef, aft) => (loc, (bef, aft))
        end) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "location" % string
          Tezos_raw_protocol_alpha.Alpha_context.Script.location_encoding)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "stack_before" % string stack_enc)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
          None "stack_after" % string stack_enc))).

Definition stack_ty_enc
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string))) :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "type" % string
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr_encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.dft None None
        "annots" % string
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
          Tezos_protocol_environment_alpha__Environment.Data_encoding.string) [])).
src/proto_alpha/lib_protocol/script_timestamp_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Z.t

let compare = Z.compare

let of_int64 = Z.of_int64

let of_string x =
  match Time_repr.of_notation x with
  | None -> (
    try Some (Z.of_string x) with _ -> None )
  | Some time ->
      Some (of_int64 (Time_repr.to_seconds time))

let to_notation x =
  try
    let notation = Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in
    if String.equal notation "out_of_range" then None else Some notation
  with _ -> None

let to_num_str = Z.to_string

let to_string x = match to_notation x with None -> to_num_str x | Some s -> s

let diff x y = Script_int_repr.of_zint @@ Z.sub x y

let sub_delta t delta = Z.sub t (Script_int_repr.to_zint delta)

let add_delta t delta = Z.add t (Script_int_repr.to_zint delta)

let to_zint x = x

let of_zint x = x
src/proto_alpha/lib_protocol/script_timestamp_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_protocol_environment_alpha__Environment.Z.t.

Definition compare
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t -> Z :=
  Tezos_protocol_environment_alpha__Environment.Z.compare.

Definition of_int64
  : int64 -> Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.of_int64.

Definition of_string (x : string)
  : option Tezos_protocol_environment_alpha__Environment.Z.t :=
  match Tezos_raw_protocol_alpha.Time_repr.of_notation x with
  | None => try
  | Some time =>
    Some (of_int64 (Tezos_raw_protocol_alpha.Time_repr.to_seconds time))
  end.

Definition to_notation (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option string := try.

Definition to_num_str
  : Tezos_protocol_environment_alpha__Environment.Z.t -> string :=
  Tezos_protocol_environment_alpha__Environment.Z.to_string.

Definition to_string (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : string :=
  match to_notation x with
  | None => to_num_str x
  | Some s => s
  end.

Definition diff
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_raw_protocol_alpha.Script_int_repr.num
    Tezos_raw_protocol_alpha.Script_int_repr.z :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    Tezos_raw_protocol_alpha.Script_int_repr.of_zint
    (Tezos_protocol_environment_alpha__Environment.Z.sub x y).

Definition sub_delta {A : Type}
  (t : Tezos_protocol_environment_alpha__Environment.Z.t)
  (delta : Tezos_raw_protocol_alpha.Script_int_repr.num A)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.sub t
    (Tezos_raw_protocol_alpha.Script_int_repr.to_zint delta).

Definition add_delta {A : Type}
  (t : Tezos_protocol_environment_alpha__Environment.Z.t)
  (delta : Tezos_raw_protocol_alpha.Script_int_repr.num A)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Tezos_protocol_environment_alpha__Environment.Z.add t
    (Tezos_raw_protocol_alpha.Script_int_repr.to_zint delta).

Definition to_zint {A : Type} (x : A) : A := x.

Definition of_zint {A : Type} (x : A) : A := x.
src/proto_alpha/lib_protocol/script_timestamp_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Script_int_repr

type t

val of_int64 : int64 -> t

val compare : t -> t -> int

(* Convert a timestamp to a notation if possible *)
val to_notation : t -> string option

(* Convert a timestamp to a string representation of the seconds *)
val to_num_str : t -> string

(* Convert to a notation if possible, or num if not *)
val to_string : t -> string

val of_string : string -> t option

val diff : t -> t -> z num

val add_delta : t -> z num -> t

val sub_delta : t -> z num -> t

val to_zint : t -> Z.t

val of_zint : Z.t -> t
src/proto_alpha/lib_protocol/script_timestamp_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter of_int64 : int64 -> t.

Parameter compare : t -> t -> Z.

Parameter to_notation : t -> option string.

Parameter to_num_str : t -> string.

Parameter to_string : t -> string.

Parameter of_string : string -> option t.

Parameter diff :
t ->
  t ->
    Tezos_raw_protocol_alpha.Script_int_repr.num
      Tezos_raw_protocol_alpha.Script_int_repr.z.

Parameter add_delta :
t ->
  (Tezos_raw_protocol_alpha.Script_int_repr.num
    Tezos_raw_protocol_alpha.Script_int_repr.z) -> t.

Parameter sub_delta :
t ->
  (Tezos_raw_protocol_alpha.Script_int_repr.num
    Tezos_raw_protocol_alpha.Script_int_repr.z) -> t.

Parameter to_zint : t -> Tezos_protocol_environment_alpha__Environment.Z.t.

Parameter of_zint : Tezos_protocol_environment_alpha__Environment.Z.t -> t.
src/proto_alpha/lib_protocol/script_typed_ir.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script_int

(* ---- Auxiliary types -----------------------------------------------------*)

type var_annot = [`Var_annot of string]

type type_annot = [`Type_annot of string]

type field_annot = [`Field_annot of string]

type annot = [var_annot | type_annot | field_annot]

type address = Contract.t * string

type ('a, 'b) pair = 'a * 'b

type ('a, 'b) union = L of 'a | R of 'b

type comb = Comb

type leaf = Leaf

type (_, _) comparable_struct =
  | Int_key : type_annot option -> (z num, _) comparable_struct
  | Nat_key : type_annot option -> (n num, _) comparable_struct
  | String_key : type_annot option -> (string, _) comparable_struct
  | Bytes_key : type_annot option -> (MBytes.t, _) comparable_struct
  | Mutez_key : type_annot option -> (Tez.t, _) comparable_struct
  | Bool_key : type_annot option -> (bool, _) comparable_struct
  | Key_hash_key : type_annot option -> (public_key_hash, _) comparable_struct
  | Timestamp_key :
      type_annot option
      -> (Script_timestamp.t, _) comparable_struct
  | Address_key : type_annot option -> (address, _) comparable_struct
  | Pair_key :
      (('a, leaf) comparable_struct * field_annot option)
      * (('b, _) comparable_struct * field_annot option)
      * type_annot option
      -> (('a, 'b) pair, comb) comparable_struct

type 'a comparable_ty = ('a, comb) comparable_struct

module type Boxed_set = sig
  type elt

  val elt_ty : elt comparable_ty

  module OPS : S.SET with type elt = elt

  val boxed : OPS.t

  val size : int
end

type 'elt set = (module Boxed_set with type elt = 'elt)

module type Boxed_map = sig
  type key

  type value

  val key_ty : key comparable_ty

  module OPS : S.MAP with type key = key

  val boxed : value OPS.t * int
end

type ('key, 'value) map =
  (module Boxed_map with type key = 'key and type value = 'value)

type operation = packed_internal_operation * Contract.big_map_diff option

type ('arg, 'storage) script = {
  code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda;
  arg_type : 'arg ty;
  storage : 'storage;
  storage_type : 'storage ty;
  root_name : string option;
}

and end_of_stack = unit

and ('arg, 'ret) lambda =
  | Lam :
      ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node
      -> ('arg, 'ret) lambda

and 'arg typed_contract = 'arg ty * address

and 'ty ty =
  | Unit_t : type_annot option -> unit ty
  | Int_t : type_annot option -> z num ty
  | Nat_t : type_annot option -> n num ty
  | Signature_t : type_annot option -> signature ty
  | String_t : type_annot option -> string ty
  | Bytes_t : type_annot option -> MBytes.t ty
  | Mutez_t : type_annot option -> Tez.t ty
  | Key_hash_t : type_annot option -> public_key_hash ty
  | Key_t : type_annot option -> public_key ty
  | Timestamp_t : type_annot option -> Script_timestamp.t ty
  | Address_t : type_annot option -> address ty
  | Bool_t : type_annot option -> bool ty
  | Pair_t :
      ('a ty * field_annot option * var_annot option)
      * ('b ty * field_annot option * var_annot option)
      * type_annot option
      * bool
      -> ('a, 'b) pair ty
  | Union_t :
      ('a ty * field_annot option)
      * ('b ty * field_annot option)
      * type_annot option
      * bool
      -> ('a, 'b) union ty
  | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty
  | Option_t : 'v ty * type_annot option * bool -> 'v option ty
  | List_t : 'v ty * type_annot option * bool -> 'v list ty
  | Set_t : 'v comparable_ty * type_annot option -> 'v set ty
  | Map_t :
      'k comparable_ty * 'v ty * type_annot option * bool
      -> ('k, 'v) map ty
  | Big_map_t :
      'k comparable_ty * 'v ty * type_annot option
      -> ('k, 'v) big_map ty
  | Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty
  | Operation_t : type_annot option -> operation ty
  | Chain_id_t : type_annot option -> Chain_id.t ty

and 'ty stack_ty =
  | Item_t :
      'ty ty * 'rest stack_ty * var_annot option
      -> ('ty * 'rest) stack_ty
  | Empty_t : end_of_stack stack_ty

and ('key, 'value) big_map = {
  id : Z.t option;
  diff : ('key, 'value option) map;
  key_type : 'key ty;
  value_type : 'value ty;
}

(* ---- Instructions --------------------------------------------------------*)

(* The low-level, typed instructions, as a GADT whose parameters
   encode the typing rules.

   The left parameter is the typed shape of the stack before the
   instruction, the right one the shape after. Any program whose
   construction is accepted by OCaml's type-checker is guaranteed to
   be type-safe. Overloadings of the concrete syntax are already
   resolved in this representation, either by using different
   constructors or type witness parameters. *)
and ('bef, 'aft) instr =
  (* stack ops *)
  | Drop : (_ * 'rest, 'rest) instr
  | Dup : ('top * 'rest, 'top * ('top * 'rest)) instr
  | Swap : ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr
  | Const : 'ty -> ('rest, 'ty * 'rest) instr
  (* pairs *)
  | Cons_pair : ('car * ('cdr * 'rest), ('car, 'cdr) pair * 'rest) instr
  | Car : (('car, _) pair * 'rest, 'car * 'rest) instr
  | Cdr : ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr
  (* options *)
  | Cons_some : ('v * 'rest, 'v option * 'rest) instr
  | Cons_none : 'a ty -> ('rest, 'a option * 'rest) instr
  | If_none :
      ('bef, 'aft) descr * ('a * 'bef, 'aft) descr
      -> ('a option * 'bef, 'aft) instr
  (* unions *)
  | Left : ('l * 'rest, ('l, 'r) union * 'rest) instr
  | Right : ('r * 'rest, ('l, 'r) union * 'rest) instr
  | If_left :
      ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr
      -> (('l, 'r) union * 'bef, 'aft) instr
  (* lists *)
  | Cons_list : ('a * ('a list * 'rest), 'a list * 'rest) instr
  | Nil : ('rest, 'a list * 'rest) instr
  | If_cons :
      ('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr
      -> ('a list * 'bef, 'aft) instr
  | List_map :
      ('a * 'rest, 'b * 'rest) descr
      -> ('a list * 'rest, 'b list * 'rest) instr
  | List_iter : ('a * 'rest, 'rest) descr -> ('a list * 'rest, 'rest) instr
  | List_size : ('a list * 'rest, n num * 'rest) instr
  (* sets *)
  | Empty_set : 'a comparable_ty -> ('rest, 'a set * 'rest) instr
  | Set_iter : ('a * 'rest, 'rest) descr -> ('a set * 'rest, 'rest) instr
  | Set_mem : ('elt * ('elt set * 'rest), bool * 'rest) instr
  | Set_update : ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr
  | Set_size : ('a set * 'rest, n num * 'rest) instr
  (* maps *)
  | Empty_map : 'a comparable_ty * 'v ty -> ('rest, ('a, 'v) map * 'rest) instr
  | Map_map :
      (('a * 'v) * 'rest, 'r * 'rest) descr
      -> (('a, 'v) map * 'rest, ('a, 'r) map * 'rest) instr
  | Map_iter :
      (('a * 'v) * 'rest, 'rest) descr
      -> (('a, 'v) map * 'rest, 'rest) instr
  | Map_mem : ('a * (('a, 'v) map * 'rest), bool * 'rest) instr
  | Map_get : ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr
  | Map_update
      : ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr
  | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr
  (* big maps *)
  | Empty_big_map :
      'a comparable_ty * 'v ty
      -> ('rest, ('a, 'v) big_map * 'rest) instr
  | Big_map_mem : ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr
  | Big_map_get : ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr
  | Big_map_update
      : ( 'key * ('value option * (('key, 'value) big_map * 'rest)),
          ('key, 'value) big_map * 'rest )
        instr
  (* string operations *)
  | Concat_string : (string list * 'rest, string * 'rest) instr
  | Concat_string_pair : (string * (string * 'rest), string * 'rest) instr
  | Slice_string
      : (n num * (n num * (string * 'rest)), string option * 'rest) instr
  | String_size : (string * 'rest, n num * 'rest) instr
  (* bytes operations *)
  | Concat_bytes : (MBytes.t list * 'rest, MBytes.t * 'rest) instr
  | Concat_bytes_pair : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) instr
  | Slice_bytes
      : (n num * (n num * (MBytes.t * 'rest)), MBytes.t option * 'rest) instr
  | Bytes_size : (MBytes.t * 'rest, n num * 'rest) instr
  (* timestamp operations *)
  | Add_seconds_to_timestamp
      : ( z num * (Script_timestamp.t * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Add_timestamp_to_seconds
      : ( Script_timestamp.t * (z num * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Sub_timestamp_seconds
      : ( Script_timestamp.t * (z num * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Diff_timestamps
      : ( Script_timestamp.t * (Script_timestamp.t * 'rest),
          z num * 'rest )
        instr
  (* tez operations *)
  | Add_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Sub_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Mul_teznat : (Tez.t * (n num * 'rest), Tez.t * 'rest) instr
  | Mul_nattez : (n num * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Ediv_teznat
      : (Tez.t * (n num * 'rest), (Tez.t, Tez.t) pair option * 'rest) instr
  | Ediv_tez
      : (Tez.t * (Tez.t * 'rest), (n num, Tez.t) pair option * 'rest) instr
  (* boolean operations *)
  | Or : (bool * (bool * 'rest), bool * 'rest) instr
  | And : (bool * (bool * 'rest), bool * 'rest) instr
  | Xor : (bool * (bool * 'rest), bool * 'rest) instr
  | Not : (bool * 'rest, bool * 'rest) instr
  (* integer operations *)
  | Is_nat : (z num * 'rest, n num option * 'rest) instr
  | Neg_nat : (n num * 'rest, z num * 'rest) instr
  | Neg_int : (z num * 'rest, z num * 'rest) instr
  | Abs_int : (z num * 'rest, n num * 'rest) instr
  | Int_nat : (n num * 'rest, z num * 'rest) instr
  | Add_intint : (z num * (z num * 'rest), z num * 'rest) instr
  | Add_intnat : (z num * (n num * 'rest), z num * 'rest) instr
  | Add_natint : (n num * (z num * 'rest), z num * 'rest) instr
  | Add_natnat : (n num * (n num * 'rest), n num * 'rest) instr
  | Sub_int : ('s num * ('t num * 'rest), z num * 'rest) instr
  | Mul_intint : (z num * (z num * 'rest), z num * 'rest) instr
  | Mul_intnat : (z num * (n num * 'rest), z num * 'rest) instr
  | Mul_natint : (n num * (z num * 'rest), z num * 'rest) instr
  | Mul_natnat : (n num * (n num * 'rest), n num * 'rest) instr
  | Ediv_intint
      : (z num * (z num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_intnat
      : (z num * (n num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_natint
      : (n num * (z num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_natnat
      : (n num * (n num * 'rest), (n num, n num) pair option * 'rest) instr
  | Lsl_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Lsr_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Or_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | And_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | And_int_nat : (z num * (n num * 'rest), n num * 'rest) instr
  | Xor_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Not_nat : (n num * 'rest, z num * 'rest) instr
  | Not_int : (z num * 'rest, z num * 'rest) instr
  (* control *)
  | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> ('bef, 'aft) instr
  | If : ('bef, 'aft) descr * ('bef, 'aft) descr -> (bool * 'bef, 'aft) instr
  | Loop : ('rest, bool * 'rest) descr -> (bool * 'rest, 'rest) instr
  | Loop_left :
      ('a * 'rest, ('a, 'b) union * 'rest) descr
      -> (('a, 'b) union * 'rest, 'b * 'rest) instr
  | Dip : ('bef, 'aft) descr -> ('top * 'bef, 'top * 'aft) instr
  | Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr
  | Apply :
      'arg ty
      -> ( 'arg * (('arg * 'remaining, 'ret) lambda * 'rest),
           ('remaining, 'ret) lambda * 'rest )
         instr
  | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr
  | Failwith : 'a ty -> ('a * 'rest, 'aft) instr
  | Nop : ('rest, 'rest) instr
  (* comparison *)
  | Compare : 'a comparable_ty -> ('a * ('a * 'rest), z num * 'rest) instr
  (* comparators *)
  | Eq : (z num * 'rest, bool * 'rest) instr
  | Neq : (z num * 'rest, bool * 'rest) instr
  | Lt : (z num * 'rest, bool * 'rest) instr
  | Gt : (z num * 'rest, bool * 'rest) instr
  | Le : (z num * 'rest, bool * 'rest) instr
  | Ge : (z num * 'rest, bool * 'rest) instr
  (* protocol *)
  | Address : (_ typed_contract * 'rest, address * 'rest) instr
  | Contract :
      'p ty * string
      -> (address * 'rest, 'p typed_contract option * 'rest) instr
  | Transfer_tokens
      : ( 'arg * (Tez.t * ('arg typed_contract * 'rest)),
          operation * 'rest )
        instr
  | Create_account
      : ( public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))),
          operation * (address * 'rest) )
        instr
  | Implicit_account
      : (public_key_hash * 'rest, unit typed_contract * 'rest) instr
  | Create_contract :
      'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option
      -> ( public_key_hash
           * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
           operation * (address * 'rest) )
         instr
  | Create_contract_2 :
      'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option
      -> ( public_key_hash option * (Tez.t * ('g * 'rest)),
           operation * (address * 'rest) )
         instr
  | Set_delegate : (public_key_hash option * 'rest, operation * 'rest) instr
  | Now : ('rest, Script_timestamp.t * 'rest) instr
  | Balance : ('rest, Tez.t * 'rest) instr
  | Check_signature
      : (public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr
  | Hash_key : (public_key * 'rest, public_key_hash * 'rest) instr
  | Pack : 'a ty -> ('a * 'rest, MBytes.t * 'rest) instr
  | Unpack : 'a ty -> (MBytes.t * 'rest, 'a option * 'rest) instr
  | Blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Sha512 : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Steps_to_quota
      : (* TODO: check that it always returns a nat *)
      ('rest, n num * 'rest) instr
  | Source : ('rest, address * 'rest) instr
  | Sender : ('rest, address * 'rest) instr
  | Self : 'p ty * string -> ('rest, 'p typed_contract * 'rest) instr
  | Amount : ('rest, Tez.t * 'rest) instr
  | Dig :
      int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('bef, 'x * 'aft) instr
  | Dug :
      int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('x * 'bef, 'aft) instr
  | Dipn :
      int
      * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      * ('fbef, 'faft) descr
      -> ('bef, 'aft) instr
  | Dropn :
      int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness
      -> ('bef, 'rest) instr
  | ChainId : ('rest, Chain_id.t * 'rest) instr

(* Type witness for operations that work deep in the stack ignoring
   (and preserving) a prefix.

   The two right parameters are the shape of the stack with the (same)
   prefix before and after the transformation. The two left
   parameters are the shape of the stack without the prefix before and
   after. The inductive definition makes it so by construction. *)
and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness =
  | Prefix :
      ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness
  | Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness

and ('bef, 'aft) descr = {
  loc : Script.location;
  bef : 'bef stack_ty;
  aft : 'aft stack_ty;
  instr : ('bef, 'aft) instr;
}

type ex_big_map = Ex_bm : ('key, 'value) big_map -> ex_big_map
src/proto_alpha/lib_protocol/script_typed_ir.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Import Tezos_raw_protocol_alpha.Alpha_context.Script_int.

Definition var_annot := variant.

Definition type_annot := variant.

Definition field_annot := variant.

Definition annot := variant.

Definition address :=
  Tezos_raw_protocol_alpha.Alpha_context.Contract.t * string.

Definition pair (a b : Type) := a * b.

Inductive union (a b : Type) : Type :=
| L : a -> union a b
| R : b -> union a b.

Arguments L {_ _}.
Arguments R {_ _}.

Inductive comb : Type :=
| Comb : comb.

Inductive leaf : Type :=
| Leaf : leaf.

Inductive comparable_struct : forall (_ _ : Type), Type :=
| Int_key : forall {A : Type}, (option type_annot) ->
  comparable_struct
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) A
| Nat_key : forall {A : Type}, (option type_annot) ->
  comparable_struct
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) A
| String_key : forall {A : Type}, (option type_annot) ->
  comparable_struct string A
| Bytes_key : forall {A : Type}, (option type_annot) ->
  comparable_struct Tezos_protocol_environment_alpha__Environment.MBytes.t A
| Mutez_key : forall {A : Type}, (option type_annot) ->
  comparable_struct Tezos_raw_protocol_alpha.Alpha_context.Tez.t A
| Bool_key : forall {A : Type}, (option type_annot) -> comparable_struct bool A
| Key_hash_key : forall {A : Type}, (option type_annot) ->
  comparable_struct Tezos_raw_protocol_alpha.Alpha_context.public_key_hash A
| Timestamp_key : forall {A : Type}, (option type_annot) ->
  comparable_struct Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t A
| Address_key : forall {A : Type}, (option type_annot) ->
  comparable_struct address A
| Pair_key : forall {C a b : Type},
  ((comparable_struct a leaf) * (option field_annot)) ->
  ((comparable_struct b C) * (option field_annot)) -> (option type_annot) ->
  comparable_struct (pair a b) comb.

Definition comparable_ty (a : Type) := comparable_struct a comb.

Module Boxed_set.
  Record signature {elt OPS_t : Type} := {
    elt := elt;
    elt_ty : comparable_ty elt;
    OPS : S.SET.signature elt OPS_t;
    boxed : OPS.(Tezos_protocol_environment_alpha__Environment.SET.S.t);
    size : Z;
  }.
  Arguments signature : clear implicits.
End Boxed_set.

Definition set (elt : Type) := {OPS_t : _ & Boxed_set.signature elt OPS_t}.

Module Boxed_map.
  Record signature {key value OPS_t : Type} := {
    key := key;
    value := value;
    key_ty : comparable_ty key;
    OPS : S.MAP.signature key OPS_t;
    boxed : (OPS.(Tezos_protocol_environment_alpha__Environment.MAP.S.t) value)
      * Z;
  }.
  Arguments signature : clear implicits.
End Boxed_map.

Definition map (key value : Type) :=
  {OPS_t : _ & Boxed_map.signature key value OPS_t}.

Definition operation :=
  Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation *
    (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff).

Reserved Notation "'end_of_stack".
Reserved Notation "'typed_contract".

Inductive lambda (arg ret : Type) : Type :=
| Lam : (descr (arg * 'end_of_stack) (ret * 'end_of_stack)) ->
  Tezos_raw_protocol_alpha.Alpha_context.Script.node -> lambda arg ret

with ty : forall (ty : Type), Type :=
| Unit_t : (option type_annot) -> ty unit
| Int_t : (option type_annot) ->
  ty
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
| Nat_t : (option type_annot) ->
  ty
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
| Signature_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.signature
| String_t : (option type_annot) -> ty string
| Bytes_t : (option type_annot) ->
  ty Tezos_protocol_environment_alpha__Environment.MBytes.t
| Mutez_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.Tez.t
| Key_hash_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.public_key_hash
| Key_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.public_key
| Timestamp_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t
| Address_t : (option type_annot) -> ty address
| Bool_t : (option type_annot) -> ty bool
| Pair_t : forall {a b : Type},
  ((ty a) * (option field_annot) * (option var_annot)) ->
  ((ty b) * (option field_annot) * (option var_annot)) -> (option type_annot) ->
  bool -> ty (pair a b)
| Union_t : forall {a b : Type}, ((ty a) * (option field_annot)) ->
  ((ty b) * (option field_annot)) -> (option type_annot) -> bool ->
  ty (union a b)
| Lambda_t : forall {arg ret : Type}, (ty arg) -> (ty ret) ->
  (option type_annot) -> ty (lambda arg ret)
| Option_t : forall {v : Type}, (ty v) -> (option type_annot) -> bool ->
  ty (option v)
| List_t : forall {v : Type}, (ty v) -> (option type_annot) -> bool ->
  ty (list v)
| Set_t : forall {v : Type}, (comparable_ty v) -> (option type_annot) ->
  ty (set v)
| Map_t : forall {k v : Type}, (comparable_ty k) -> (ty v) ->
  (option type_annot) -> bool -> ty (map k v)
| Big_map_t : forall {k v : Type}, (comparable_ty k) -> (ty v) ->
  (option type_annot) -> ty (big_map k v)
| Contract_t : forall {arg : Type}, (ty arg) -> (option type_annot) ->
  ty ('typed_contract arg)
| Operation_t : (option type_annot) -> ty operation
| Chain_id_t : (option type_annot) ->
  ty
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)

with stack_ty : forall (ty : Type), Type :=
| Item_t : forall {rest ty : Type}, (ty ty) -> (stack_ty rest) ->
  (option var_annot) -> stack_ty (ty * rest)
| Empty_t : stack_ty 'end_of_stack

with instr : forall (bef aft : Type), Type :=
| Drop : forall {A rest : Type}, instr (A * rest) rest
| Dup : forall {rest top : Type}, instr (top * rest) (top * (top * rest))
| Swap : forall {rest tip top : Type},
  instr (tip * (top * rest)) (top * (tip * rest))
| Const : forall {rest ty : Type}, ty -> instr rest (ty * rest)
| Cons_pair : forall {car cdr rest : Type},
  instr (car * (cdr * rest)) ((pair car cdr) * rest)
| Car : forall {B car rest : Type}, instr ((pair car B) * rest) (car * rest)
| Cdr : forall {A cdr rest : Type}, instr ((pair A cdr) * rest) (cdr * rest)
| Cons_some : forall {rest v : Type}, instr (v * rest) ((option v) * rest)
| Cons_none : forall {a rest : Type}, (ty a) -> instr rest ((option a) * rest)
| If_none : forall {a aft bef : Type}, (descr bef aft) -> (descr (a * bef) aft)
  -> instr ((option a) * bef) aft
| Left : forall {l r rest : Type}, instr (l * rest) ((union l r) * rest)
| Right : forall {l r rest : Type}, instr (r * rest) ((union l r) * rest)
| If_left : forall {aft bef l r : Type}, (descr (l * bef) aft) ->
  (descr (r * bef) aft) -> instr ((union l r) * bef) aft
| Cons_list : forall {a rest : Type},
  instr (a * ((list a) * rest)) ((list a) * rest)
| Nil : forall {a rest : Type}, instr rest ((list a) * rest)
| If_cons : forall {a aft bef : Type}, (descr (a * ((list a) * bef)) aft) ->
  (descr bef aft) -> instr ((list a) * bef) aft
| List_map : forall {a b rest : Type}, (descr (a * rest) (b * rest)) ->
  instr ((list a) * rest) ((list b) * rest)
| List_iter : forall {a rest : Type}, (descr (a * rest) rest) ->
  instr ((list a) * rest) rest
| List_size : forall {a rest : Type},
  instr ((list a) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_set : forall {a rest : Type}, (comparable_ty a) ->
  instr rest ((set a) * rest)
| Set_iter : forall {a rest : Type}, (descr (a * rest) rest) ->
  instr ((set a) * rest) rest
| Set_mem : forall {elt rest : Type},
  instr (elt * ((set elt) * rest)) (bool * rest)
| Set_update : forall {elt rest : Type},
  instr (elt * (bool * ((set elt) * rest))) ((set elt) * rest)
| Set_size : forall {a rest : Type},
  instr ((set a) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_map : forall {a rest v : Type}, (comparable_ty a) -> (ty v) ->
  instr rest ((map a v) * rest)
| Map_map : forall {a r rest v : Type}, (descr ((a * v) * rest) (r * rest)) ->
  instr ((map a v) * rest) ((map a r) * rest)
| Map_iter : forall {a rest v : Type}, (descr ((a * v) * rest) rest) ->
  instr ((map a v) * rest) rest
| Map_mem : forall {a rest v : Type},
  instr (a * ((map a v) * rest)) (bool * rest)
| Map_get : forall {a rest v : Type},
  instr (a * ((map a v) * rest)) ((option v) * rest)
| Map_update : forall {a rest v : Type},
  instr (a * ((option v) * ((map a v) * rest))) ((map a v) * rest)
| Map_size : forall {a b rest : Type},
  instr ((map a b) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_big_map : forall {a rest v : Type}, (comparable_ty a) -> (ty v) ->
  instr rest ((big_map a v) * rest)
| Big_map_mem : forall {a rest v : Type},
  instr (a * ((big_map a v) * rest)) (bool * rest)
| Big_map_get : forall {a rest v : Type},
  instr (a * ((big_map a v) * rest)) ((option v) * rest)
| Big_map_update : forall {key rest value : Type},
  instr (key * ((option value) * ((big_map key value) * rest)))
    ((big_map key value) * rest)
| Concat_string : forall {rest : Type},
  instr ((list string) * rest) (string * rest)
| Concat_string_pair : forall {rest : Type},
  instr (string * (string * rest)) (string * rest)
| Slice_string : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * (string * rest)))
    ((option string) * rest)
| String_size : forall {rest : Type},
  instr (string * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Concat_bytes : forall {rest : Type},
  instr ((list Tezos_protocol_environment_alpha__Environment.MBytes.t) * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Concat_bytes_pair : forall {rest : Type},
  instr
    (Tezos_protocol_environment_alpha__Environment.MBytes.t *
      (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest))
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Slice_bytes : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
        (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)))
    ((option Tezos_protocol_environment_alpha__Environment.MBytes.t) * rest)
| Bytes_size : forall {rest : Type},
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Add_seconds_to_timestamp : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Add_timestamp_to_seconds : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Sub_timestamp_seconds : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Diff_timestamps : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
      (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_tez : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Sub_tez : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Mul_teznat : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Mul_nattez : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Ediv_teznat : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((option
      (pair Tezos_raw_protocol_alpha.Alpha_context.Tez.t
        Tezos_raw_protocol_alpha.Alpha_context.Tez.t)) * rest)
| Ediv_tez : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
        Tezos_raw_protocol_alpha.Alpha_context.Tez.t)) * rest)
| Or : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| And : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| Xor : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| Not : forall {rest : Type}, instr (bool * rest) (bool * rest)
| Is_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
    ((option
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)) * rest)
| Neg_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Neg_int : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Abs_int : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Int_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_intint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_intnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_natint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_natnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Sub_int : forall {rest s t : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num s) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num t) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_intint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_intnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_natint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_natnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Ediv_intint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_intnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_natint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_natnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Lsl_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Lsr_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Or_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| And_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| And_int_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Xor_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Not_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Not_int : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Seq : forall {aft bef trans : Type}, (descr bef trans) -> (descr trans aft) ->
  instr bef aft
| If : forall {aft bef : Type}, (descr bef aft) -> (descr bef aft) ->
  instr (bool * bef) aft
| Loop : forall {rest : Type}, (descr rest (bool * rest)) ->
  instr (bool * rest) rest
| Loop_left : forall {a b rest : Type}, (descr (a * rest) ((union a b) * rest))
  -> instr ((union a b) * rest) (b * rest)
| Dip : forall {aft bef top : Type}, (descr bef aft) ->
  instr (top * bef) (top * aft)
| Exec : forall {arg rest ret : Type},
  instr (arg * ((lambda arg ret) * rest)) (ret * rest)
| Apply : forall {arg remaining rest ret : Type}, (ty arg) ->
  instr (arg * ((lambda (arg * remaining) ret) * rest))
    ((lambda remaining ret) * rest)
| Lambda : forall {arg rest ret : Type}, (lambda arg ret) ->
  instr rest ((lambda arg ret) * rest)
| Failwith : forall {a aft rest : Type}, (ty a) -> instr (a * rest) aft
| Nop : forall {rest : Type}, instr rest rest
| Compare : forall {a rest : Type}, (comparable_ty a) ->
  instr (a * (a * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Eq : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Neq : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Lt : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Gt : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Le : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Ge : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Address : forall {A rest : Type},
  instr (('typed_contract A) * rest) (address * rest)
| Contract : forall {p rest : Type}, (ty p) -> string ->
  instr (address * rest) ((option ('typed_contract p)) * rest)
| Transfer_tokens : forall {arg rest : Type},
  instr
    (arg *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
        (('typed_contract arg) * rest))) (operation * rest)
| Create_account : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash *
      ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
        (bool * (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))))
    (operation * (address * rest))
| Implicit_account : forall {rest : Type},
  instr (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * rest)
    (('typed_contract unit) * rest)
| Create_contract : forall {g p rest : Type}, (ty g) -> (ty p) ->
  (lambda (p * g) ((list operation) * g)) -> (option string) ->
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash *
      ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
        (bool *
          (bool * (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * (g * rest))))))
    (operation * (address * rest))
| Create_contract_2 : forall {g p rest : Type}, (ty g) -> (ty p) ->
  (lambda (p * g) ((list operation) * g)) -> (option string) ->
  instr
    ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * (g * rest)))
    (operation * (address * rest))
| Set_delegate : forall {rest : Type},
  instr ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) * rest)
    (operation * rest)
| Now : forall {rest : Type},
  instr rest (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Balance : forall {rest : Type},
  instr rest (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Check_signature : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.public_key *
      (Tezos_raw_protocol_alpha.Alpha_context.signature *
        (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)))
    (bool * rest)
| Hash_key : forall {rest : Type},
  instr (Tezos_raw_protocol_alpha.Alpha_context.public_key * rest)
    (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * rest)
| Pack : forall {a rest : Type}, (ty a) ->
  instr (a * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Unpack : forall {a rest : Type}, (ty a) ->
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    ((option a) * rest)
| Blake2b : forall {rest : Type},
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Sha256 : forall {rest : Type},
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Sha512 : forall {rest : Type},
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Steps_to_quota : forall {rest : Type},
  instr rest
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Source : forall {rest : Type}, instr rest (address * rest)
| Sender : forall {rest : Type}, instr rest (address * rest)
| Self : forall {p rest : Type}, (ty p) -> string ->
  instr rest (('typed_contract p) * rest)
| Amount : forall {rest : Type},
  instr rest (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Dig : forall {aft bef rest x : Type}, Z ->
  (stack_prefix_preservation_witness (x * rest) rest bef aft) ->
  instr bef (x * aft)
| Dug : forall {aft bef rest x : Type}, Z ->
  (stack_prefix_preservation_witness rest (x * rest) bef aft) ->
  instr (x * bef) aft
| Dipn : forall {aft bef faft fbef : Type}, Z ->
  (stack_prefix_preservation_witness fbef faft bef aft) -> (descr fbef faft) ->
  instr bef aft
| Dropn : forall {C bef rest : Type}, Z ->
  (stack_prefix_preservation_witness rest rest bef C) -> instr bef rest
| ChainId : forall {rest : Type},
  instr rest
    (Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      * rest)

with stack_prefix_preservation_witness : forall
  (bef aft bef_suffix aft_suffix : Type), Type :=
| Prefix : forall {aft bef faft fbef x : Type},
  (stack_prefix_preservation_witness fbef faft bef aft) ->
  stack_prefix_preservation_witness fbef faft (x * bef) (x * aft)
| Rest : forall {aft bef : Type},
  stack_prefix_preservation_witness bef aft bef aft

where "'end_of_stack" := ( unit)

and "'typed_contract" := (fun (arg : Type) => (ty arg) * address).

Definition end_of_stack := 'end_of_stack.
Definition typed_contract := 'typed_contract.

Arguments Lam {_ _}.

Inductive ex_big_map : Type :=
| Ex_bm : forall {key value : Type}, (big_map key value) -> ex_big_map.
src/proto_alpha/lib_protocol/seed_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Random number generation *)

type seed = B of State_hash.t

type t = T of State_hash.t

type sequence = S of State_hash.t

type nonce = MBytes.t

let nonce_encoding = Data_encoding.Fixed.bytes Constants_repr.nonce_length

let init = "Laissez-faire les proprietaires."

let zero_bytes = MBytes.of_string (String.make Nonce_hash.size '\000')

let state_hash_encoding =
  let open Data_encoding in
  conv
    State_hash.to_bytes
    State_hash.of_bytes_exn
    (Fixed.bytes Nonce_hash.size)

let seed_encoding =
  let open Data_encoding in
  conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding

let empty = B (State_hash.hash_bytes [MBytes.of_string init])

let nonce (B state) nonce =
  B (State_hash.hash_bytes [State_hash.to_bytes state; nonce])

let initialize_new (B state) append =
  T (State_hash.hash_bytes (State_hash.to_bytes state :: zero_bytes :: append))

let xor_higher_bits i b =
  let higher = MBytes.get_int32 b 0 in
  let r = Int32.logxor higher i in
  let res = MBytes.copy b in
  MBytes.set_int32 res 0 r ; res

let sequence (T state) n =
  State_hash.to_bytes state |> xor_higher_bits n
  |> fun b -> S (State_hash.hash_bytes [b])

let take (S state) =
  let b = State_hash.to_bytes state in
  let h = State_hash.hash_bytes [b] in
  (State_hash.to_bytes h, S h)

let take_int32 s bound =
  if Compare.Int32.(bound <= 0l) then invalid_arg "Seed_repr.take_int32"
    (* FIXME *)
  else
    let rec loop s =
      let (bytes, s) = take s in
      let r = Int32.abs (MBytes.get_int32 bytes 0) in
      let drop_if_over =
        Int32.sub Int32.max_int (Int32.rem Int32.max_int bound)
      in
      if Compare.Int32.(r >= drop_if_over) then loop s
      else
        let v = Int32.rem r bound in
        (v, s)
    in
    loop s

type error += Unexpected_nonce_length (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"unexpected_nonce_length"
    ~title:"Unexpected nonce length"
    ~description:"Nonce length is incorrect."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Nonce length is not %i bytes long as it should."
        Constants_repr.nonce_length)
    Data_encoding.empty
    (function Unexpected_nonce_length -> Some () | _ -> None)
    (fun () -> Unexpected_nonce_length)

let make_nonce nonce =
  if Compare.Int.(MBytes.length nonce <> Constants_repr.nonce_length) then
    error Unexpected_nonce_length
  else ok nonce

let hash nonce = Nonce_hash.hash_bytes [nonce]

let check_hash nonce hash =
  Compare.Int.(MBytes.length nonce = Constants_repr.nonce_length)
  && Nonce_hash.equal (Nonce_hash.hash_bytes [nonce]) hash

let nonce_hash_key_part = Nonce_hash.to_path

let initial_nonce_0 = zero_bytes

let initial_nonce_hash_0 = hash initial_nonce_0

let deterministic_seed seed = nonce seed zero_bytes

let initial_seeds n =
  let rec loop acc elt i =
    if Compare.Int.(i = 1) then List.rev (elt :: acc)
    else loop (elt :: acc) (deterministic_seed elt) (i - 1)
  in
  loop [] (B (State_hash.hash_bytes [])) n
src/proto_alpha/lib_protocol/seed_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive seed : Type :=
| B : Tezos_raw_protocol_alpha.State_hash.t -> seed.

Inductive t : Type :=
| T : Tezos_raw_protocol_alpha.State_hash.t -> t.

Inductive sequence : Type :=
| S : Tezos_raw_protocol_alpha.State_hash.t -> sequence.

Definition nonce := Tezos_protocol_environment_alpha__Environment.MBytes.t.

Definition nonce_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.Fixed.bytes
    Tezos_raw_protocol_alpha.Constants_repr.nonce_length.

Definition init : string := "Laissez-faire les proprietaires." % string.

Definition zero_bytes
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  Tezos_protocol_environment_alpha__Environment.MBytes.of_string
    (Tezos_protocol_environment_alpha__Environment.String.make
      Tezos_raw_protocol_alpha.Nonce_hash.size "000" % char).

Definition state_hash_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_raw_protocol_alpha.State_hash.t :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    Tezos_raw_protocol_alpha.State_hash.to_bytes
    Tezos_raw_protocol_alpha.State_hash.of_bytes_exn None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.Fixed.bytes
      Tezos_raw_protocol_alpha.Nonce_hash.size).

Definition seed_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding seed :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | B b => b
      end) (fun b => B b) None state_hash_encoding.

Definition empty : seed :=
  B
    (Tezos_raw_protocol_alpha.State_hash.hash_bytes None
      (cons
        (Tezos_protocol_environment_alpha__Environment.MBytes.of_string init) [])).

Definition nonce (function_parameter : seed)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t -> seed :=
  match function_parameter with
  | B state =>
    fun nonce =>
      B
        (Tezos_raw_protocol_alpha.State_hash.hash_bytes None
          (cons (Tezos_raw_protocol_alpha.State_hash.to_bytes state)
            (cons nonce [])))
  end.

Definition initialize_new (function_parameter : seed)
  : (list Tezos_protocol_environment_alpha__Environment.MBytes.t) -> t :=
  match function_parameter with
  | B state =>
    fun append =>
      T
        (Tezos_raw_protocol_alpha.State_hash.hash_bytes None
          (cons (Tezos_raw_protocol_alpha.State_hash.to_bytes state)
            (cons zero_bytes append)))
  end.

Definition xor_higher_bits
  (i : int32) (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  let higher :=
    Tezos_protocol_environment_alpha__Environment.MBytes.get_int32 b 0 in
  let r := Tezos_protocol_environment_alpha__Environment.Int32.logxor higher i
    in
  let res := Tezos_protocol_environment_alpha__Environment.MBytes.copy b in
  Tezos_protocol_environment_alpha__Environment.MBytes.set_int32 res 0 r;
  res.

Definition sequence (function_parameter : t) : int32 -> sequence :=
  match function_parameter with
  | T state =>
    fun n =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
          (Tezos_raw_protocol_alpha.State_hash.to_bytes state)
          (xor_higher_bits n))
        (fun b =>
          S (Tezos_raw_protocol_alpha.State_hash.hash_bytes None (cons b [])))
  end.

Definition take (function_parameter : sequence)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t * sequence :=
  match function_parameter with
  | S state =>
    let b := Tezos_raw_protocol_alpha.State_hash.to_bytes state in
    let h := Tezos_raw_protocol_alpha.State_hash.hash_bytes None (cons b []) in
    ((Tezos_raw_protocol_alpha.State_hash.to_bytes h), (S h))
  end.

Definition take_int32
  (s : sequence)
  (bound :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : int32 * sequence :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_eq)
      bound 0 then
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "Seed_repr.take_int32" % string
  else
    let fix loop (s : sequence) : int32 * sequence :=
      match take s with
      | (bytes, s) =>
        let r :=
          Tezos_protocol_environment_alpha__Environment.Int32.abs
            (Tezos_protocol_environment_alpha__Environment.MBytes.get_int32
              string 0) in
        let drop_if_over :=
          Tezos_protocol_environment_alpha__Environment.Int32.sub
            Tezos_protocol_environment_alpha__Environment.Int32.max_int
            (Tezos_protocol_environment_alpha__Environment.Int32.rem
              Tezos_protocol_environment_alpha__Environment.Int32.max_int bound)
          in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
            r drop_if_over then
          loop s
        else
          let v :=
            Tezos_protocol_environment_alpha__Environment.Int32.rem r bound in
          (v, s)
      end in
    loop s.

Definition make_nonce
  (nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt_gt)
      (Tezos_protocol_environment_alpha__Environment.MBytes.length nonce)
      Tezos_raw_protocol_alpha.Constants_repr.nonce_length then
    Tezos_protocol_environment_alpha__Environment.Error_monad.error
      Unexpected_nonce_length
  else
    Tezos_protocol_environment_alpha__Environment.Error_monad.ok nonce.

Definition hash (nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_raw_protocol_alpha.Nonce_hash.t :=
  Tezos_raw_protocol_alpha.Nonce_hash.hash_bytes None (cons nonce []).

Definition check_hash
  (nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  (hash : Tezos_raw_protocol_alpha.Nonce_hash.t) : bool :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
    (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
      (Tezos_protocol_environment_alpha__Environment.MBytes.length nonce)
      Tezos_raw_protocol_alpha.Constants_repr.nonce_length)
    (Tezos_raw_protocol_alpha.Nonce_hash.equal
      (Tezos_raw_protocol_alpha.Nonce_hash.hash_bytes None (cons nonce [])) hash).

Definition nonce_hash_key_part
  : Tezos_raw_protocol_alpha.Nonce_hash.t -> (list string) -> list string :=
  Tezos_raw_protocol_alpha.Nonce_hash.to_path.

Definition initial_nonce_0
  : Tezos_protocol_environment_alpha__Environment.MBytes.t := zero_bytes.

Definition initial_nonce_hash_0 : Tezos_raw_protocol_alpha.Nonce_hash.t :=
  hash initial_nonce_0.

Definition deterministic_seed (seed : seed) : seed := nonce seed zero_bytes.

Definition initial_seeds
  (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : list seed :=
  let fix loop
    (acc : list seed) (elt : seed) (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    : list seed :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        i 1 then
      Tezos_protocol_environment_alpha__Environment.List.rev (cons elt acc)
    else
      loop (cons elt acc) (deterministic_seed elt)
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus i 1)
    in
  loop [] (B (Tezos_raw_protocol_alpha.State_hash.hash_bytes None [])) n.
src/proto_alpha/lib_protocol/seed_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Random number generation

    This is not expected to be a good cryptographic random number
    generator. In particular this is supposed to be used in situations
    where the seed is a globaly known information.

    The only expected property is: It should be difficult to find a
    seed such that the generated sequence is a given one. *)

(** {2 Random Generation} *)

(** The state of the random number generator *)
type t

(** A random seed, to derive random sequences from *)
type seed

(** A random sequence, to derive random values from *)
type sequence

(** [initialize_new state ident] returns a new generator *)
val initialize_new : seed -> MBytes.t list -> t

(** [sequence state n] prepares the n-th sequence of a state  *)
val sequence : t -> int32 -> sequence

(** Generates the next random value in the sequence *)
val take : sequence -> MBytes.t * sequence

(** Generates the next random value as a bounded [int32] *)
val take_int32 : sequence -> int32 -> int32 * sequence

(** {2 Predefined seeds} *)

val empty : seed

(** Returns a new seed by hashing the one passed with a constant. *)
val deterministic_seed : seed -> seed

(** [intial_seeds n] generates the first [n] seeds for which there are no nonces.
    The first seed is a constant value. The kth seed is the hash of seed (k-1)
    concatenated with a constant. *)
val initial_seeds : int -> seed list

(** {2 Entropy} *)

(** A nonce for adding entropy to the generator *)
type nonce

(** Add entropy to the seed generator *)
val nonce : seed -> nonce -> seed

(** Use a byte sequence as a nonce *)
val make_nonce : MBytes.t -> nonce tzresult

(** Compute the has of a nonce *)
val hash : nonce -> Nonce_hash.t

(** [check_hash nonce hash] is true if the nonce correspond to the hash *)
val check_hash : nonce -> Nonce_hash.t -> bool

(** For using nonce hashes as keys in the hierarchical database *)
val nonce_hash_key_part : Nonce_hash.t -> string list -> string list

(** {2 Predefined nonce} *)

val initial_nonce_0 : nonce

val initial_nonce_hash_0 : Nonce_hash.t

(** {2 Serializers} *)

val nonce_encoding : nonce Data_encoding.t

val seed_encoding : seed Data_encoding.t
src/proto_alpha/lib_protocol/seed_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Parameter seed : Type.

Parameter sequence : Type.

Parameter initialize_new :
seed -> (list Tezos_protocol_environment_alpha__Environment.MBytes.t) -> t.

Parameter sequence : t -> int32 -> sequence.

Parameter take :
sequence -> Tezos_protocol_environment_alpha__Environment.MBytes.t * sequence.

Parameter take_int32 : sequence -> int32 -> int32 * sequence.

Parameter empty : seed.

Parameter deterministic_seed : seed -> seed.

Parameter initial_seeds : Z -> list seed.

Parameter nonce : Type.

Parameter nonce : seed -> nonce -> seed.

Parameter make_nonce :
Tezos_protocol_environment_alpha__Environment.MBytes.t ->
  Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult nonce.

Parameter hash : nonce -> Tezos_raw_protocol_alpha.Nonce_hash.t.

Parameter check_hash : nonce -> Tezos_raw_protocol_alpha.Nonce_hash.t -> bool.

Parameter nonce_hash_key_part :
Tezos_raw_protocol_alpha.Nonce_hash.t -> (list string) -> list string.

Parameter initial_nonce_0 : nonce.

Parameter initial_nonce_hash_0 : Tezos_raw_protocol_alpha.Nonce_hash.t.

Parameter nonce_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t nonce.

Parameter seed_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t seed.
src/proto_alpha/lib_protocol/seed_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

type error +=
  | Unknown of {
      oldest : Cycle_repr.t;
      cycle : Cycle_repr.t;
      latest : Cycle_repr.t;
    }

(* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"seed.unknown_seed"
    ~title:"Unknown seed"
    ~description:"The requested seed is not available"
    ~pp:(fun ppf (oldest, cycle, latest) ->
      if Cycle_repr.(cycle < oldest) then
        Format.fprintf
          ppf
          "The seed for cycle %a has been cleared from the context  (oldest \
           known seed is for cycle %a)"
          Cycle_repr.pp
          cycle
          Cycle_repr.pp
          oldest
      else
        Format.fprintf
          ppf
          "The seed for cycle %a has not been computed yet  (latest known \
           seed is for cycle %a)"
          Cycle_repr.pp
          cycle
          Cycle_repr.pp
          latest)
    Data_encoding.(
      obj3
        (req "oldest" Cycle_repr.encoding)
        (req "requested" Cycle_repr.encoding)
        (req "latest" Cycle_repr.encoding))
    (function
      | Unknown {oldest; cycle; latest} ->
          Some (oldest, cycle, latest)
      | _ ->
          None)
    (fun (oldest, cycle, latest) -> Unknown {oldest; cycle; latest})

let compute_for_cycle c ~revealed cycle =
  match Cycle_repr.pred cycle with
  | None ->
      assert false (* should not happen *)
  | Some previous_cycle ->
      let levels = Level_storage.levels_with_commitments_in_cycle c revealed in
      let combine (c, random_seed, unrevealed) level =
        Storage.Seed.Nonce.get c level
        >>=? function
        | Revealed nonce ->
            Storage.Seed.Nonce.delete c level
            >>=? fun c ->
            return (c, Seed_repr.nonce random_seed nonce, unrevealed)
        | Unrevealed u ->
            Storage.Seed.Nonce.delete c level
            >>=? fun c -> return (c, random_seed, u :: unrevealed)
      in
      Storage.Seed.For_cycle.get c previous_cycle
      >>=? fun prev_seed ->
      let seed = Seed_repr.deterministic_seed prev_seed in
      fold_left_s combine (c, seed, []) levels
      >>=? fun (c, seed, unrevealed) ->
      Storage.Seed.For_cycle.init c cycle seed
      >>=? fun c -> return (c, unrevealed)

let for_cycle ctxt cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  let current_level = Level_storage.current ctxt in
  let current_cycle = current_level.cycle in
  let latest =
    if Cycle_repr.(current_cycle = root) then
      Cycle_repr.add current_cycle (preserved + 1)
    else Cycle_repr.add current_cycle preserved
  in
  let oldest =
    match Cycle_repr.sub current_cycle preserved with
    | None ->
        Cycle_repr.root
    | Some oldest ->
        oldest
  in
  fail_unless
    Cycle_repr.(oldest <= cycle && cycle <= latest)
    (Unknown {oldest; cycle; latest})
  >>=? fun () -> Storage.Seed.For_cycle.get ctxt cycle

let clear_cycle c cycle = Storage.Seed.For_cycle.delete c cycle

let init ctxt =
  let preserved = Constants_storage.preserved_cycles ctxt in
  List.fold_left2
    (fun ctxt c seed ->
      ctxt
      >>=? fun ctxt ->
      let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
      Storage.Seed.For_cycle.init ctxt cycle seed)
    (return ctxt)
    (0 --> (preserved + 1))
    (Seed_repr.initial_seeds (preserved + 2))

let cycle_end ctxt last_cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.sub last_cycle preserved with
  | None ->
      return ctxt
  | Some cleared_cycle ->
      clear_cycle ctxt cleared_cycle )
  >>=? fun ctxt ->
  match Cycle_repr.pred last_cycle with
  | None ->
      return (ctxt, [])
  | Some revealed ->
      (* cycle with revelations *)
      let inited_seed_cycle = Cycle_repr.add last_cycle (preserved + 1) in
      compute_for_cycle ctxt ~revealed inited_seed_cycle
src/proto_alpha/lib_protocol/seed_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Misc.

Definition compute_for_cycle
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (revealed : Tezos_raw_protocol_alpha.Cycle_repr.t)
  (cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
  match Tezos_raw_protocol_alpha.Cycle_repr.pred cycle with
  | None => false
  | Some previous_cycle =>
    let levels :=
      Tezos_raw_protocol_alpha.Level_storage.levels_with_commitments_in_cycle c
        revealed in
    let combine
      (function_parameter :
      Tezos_raw_protocol_alpha.Storage.Seed.Nonce.context *
        Tezos_raw_protocol_alpha.Seed_repr.seed *
        (list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))
      : Tezos_raw_protocol_alpha.Level_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t *
              Tezos_raw_protocol_alpha.Seed_repr.seed *
              (list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
      match function_parameter with
      | (c, random_seed, unrevealed) =>
        fun level =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Seed.Nonce.get c level)
            (fun function_parameter =>
              match function_parameter with
              | Revealed nonce =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Seed.Nonce.delete c level)
                  (fun c =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (c,
                        (Tezos_raw_protocol_alpha.Seed_repr.nonce random_seed
                          nonce), unrevealed))
              | Unrevealed u =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Seed.Nonce.delete c level)
                  (fun c =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (c, random_seed, (cons u unrevealed)))
              end)
      end in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Storage.Seed.For_cycle.get c previous_cycle)
      (fun prev_seed =>
        let seed :=
          Tezos_raw_protocol_alpha.Seed_repr.deterministic_seed prev_seed in
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
            combine (c, seed, []) levels)
          (fun function_parameter =>
            match function_parameter with
            | (c, seed, unrevealed) =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_raw_protocol_alpha.Storage.Seed.For_cycle.init c cycle
                  seed)
                (fun c =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    (c, unrevealed))
            end))
  end.

Definition for_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (cycle : Tezos_raw_protocol_alpha.Cycle_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Seed_repr.seed) :=
  let preserved :=
    Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles ctxt in
  let current_level := Tezos_raw_protocol_alpha.Level_storage.current ctxt in
  let current_cycle := cycle current_level in
  let latest :=
    if
      Tezos_raw_protocol_alpha.Cycle_repr.op_eq current_cycle
        Tezos_raw_protocol_alpha.Cycle_repr.root then
      Tezos_raw_protocol_alpha.Cycle_repr.add current_cycle
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
          preserved 1)
    else
      Tezos_raw_protocol_alpha.Cycle_repr.add current_cycle preserved in
  let oldest :=
    match Tezos_raw_protocol_alpha.Cycle_repr.sub current_cycle preserved with
    | None => Tezos_raw_protocol_alpha.Cycle_repr.root
    | Some oldest => oldest
    end in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.fail_unless
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
        (Tezos_raw_protocol_alpha.Cycle_repr.op_lt_eq oldest cycle)
        (Tezos_raw_protocol_alpha.Cycle_repr.op_lt_eq cycle latest))
      (Unknown {| oldest := oldest; cycle := cycle; latest := latest |}))
    (fun function_parameter =>
      match function_parameter with
      | tt => Tezos_raw_protocol_alpha.Storage.Seed.For_cycle.get ctxt cycle
      end).

Definition clear_cycle
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (cycle : Tezos_raw_protocol_alpha.Cycle_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Seed.For_cycle.delete c cycle.

Definition init (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let preserved :=
    Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles ctxt in
  Tezos_protocol_environment_alpha__Environment.List.fold_left2
    (fun ctxt =>
      fun c =>
        fun seed =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            ctxt
            (fun ctxt =>
              let cycle :=
                Tezos_raw_protocol_alpha.Cycle_repr.of_int32_exn
                  (Tezos_protocol_environment_alpha__Environment.Int32.of_int c)
                in
              Tezos_raw_protocol_alpha.Storage.Seed.For_cycle.init ctxt cycle
                seed))
    (Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt)
    (Tezos_raw_protocol_alpha.Misc.op_minus_minus_gt 0
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
        preserved 1))
    (Tezos_raw_protocol_alpha.Seed_repr.initial_seeds
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
        preserved 2)).

Definition cycle_end
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.context *
        (list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
  let preserved :=
    Tezos_raw_protocol_alpha.Constants_storage.preserved_cycles ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    match Tezos_raw_protocol_alpha.Cycle_repr.sub last_cycle preserved with
    | None =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt
    | Some cleared_cycle => clear_cycle ctxt cleared_cycle
    end
    (fun ctxt =>
      match Tezos_raw_protocol_alpha.Cycle_repr.pred last_cycle with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          (ctxt, [])
      | Some revealed =>
        let inited_seed_cycle :=
          Tezos_raw_protocol_alpha.Cycle_repr.add last_cycle
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
              preserved 1) in
        compute_for_cycle ctxt revealed inited_seed_cycle
      end).
src/proto_alpha/lib_protocol/seed_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Unknown of {
      oldest : Cycle_repr.t;
      cycle : Cycle_repr.t;
      latest : Cycle_repr.t;
    }

(* `Permanent *)

(** Generates the first [preserved_cycles+2] seeds for which
    there are no nonces. *)
val init : Raw_context.t -> Raw_context.t tzresult Lwt.t

val for_cycle : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t

(** If it is the end of the cycle, computes and stores the seed of cycle at
    distance [preserved_cycle+2] in the future using the seed of the previous
    cycle and the revelations of the current one.  *)
val cycle_end :
  Raw_context.t ->
  Cycle_repr.t ->
  (Raw_context.t * Nonce_storage.unrevealed list) tzresult Lwt.t
src/proto_alpha/lib_protocol/seed_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

extensible_type

Parameter init :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).

Parameter for_cycle :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Seed_repr.seed).

Parameter cycle_end :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t *
          (list Tezos_raw_protocol_alpha.Nonce_storage.unrevealed))).
src/proto_alpha/lib_protocol/services_registration.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type rpc_context = {
  block_hash : Block_hash.t;
  block_header : Block_header.shell_header;
  context : Alpha_context.t;
}

let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) =
  let level = block_header.level in
  let timestamp = block_header.timestamp in
  let fitness = block_header.fitness in
  Alpha_context.prepare
    ~level
    ~predecessor_timestamp:timestamp
    ~timestamp
    ~fitness
    context
  >>=? fun context -> return {block_hash; block_header; context}

let rpc_services =
  ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t)

let register0_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun ctxt q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt q i)

let opt_register0_fullctxt s f =
  rpc_services :=
    RPC_directory.opt_register !rpc_services s (fun ctxt q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt q i)

let register0 s f = register0_fullctxt s (fun {context; _} -> f context)

let register0_noctxt s f =
  rpc_services := RPC_directory.register !rpc_services s (fun _ q i -> f q i)

let register1_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun (ctxt, arg) q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt arg q i)

let register1 s f = register1_fullctxt s (fun {context; _} x -> f context x)

let register1_noctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun (_, arg) q i -> f arg q i)

let register2_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun ((ctxt, arg1), arg2) q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt arg1 arg2 q i)

let register2 s f =
  register2_fullctxt s (fun {context; _} a1 a2 q i -> f context a1 a2 q i)

let get_rpc_services () =
  let p =
    RPC_directory.map
      (fun c ->
        rpc_init c
        >>= function Error _ -> assert false | Ok c -> Lwt.return c.context)
      (Storage_description.build_directory Alpha_context.description)
  in
  RPC_directory.register_dynamic_directory
    !rpc_services
    RPC_path.(open_root / "context" / "raw" / "json")
    (fun _ -> Lwt.return p)
src/proto_alpha/lib_protocol/services_registration.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Record rpc_context := {
  block_hash :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
  block_header :
    Tezos_raw_protocol_alpha.Alpha_context.Block_header.shell_header;
  context : Tezos_raw_protocol_alpha.Alpha_context.t }.

Definition rpc_init
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      rpc_context) :=
  match function_parameter with
  | {|
    block_hash := block_hash;
      block_header := block_header;
      context := context
      |} =>
    let level := level block_header in
    let timestamp := timestamp block_header in
    let fitness := fitness block_header in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (Tezos_raw_protocol_alpha.Alpha_context.prepare context level timestamp
        timestamp fitness)
      (fun context =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return
          {| block_hash := block_hash; block_header := block_header;
            context := context |})
  end.

Definition rpc_services
  : Tezos_protocol_environment_alpha__Environment.Pervasives.ref
    (Tezos_protocol_environment_alpha__Environment.RPC_directory.t
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context) :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.ref
    Tezos_protocol_environment_alpha__Environment.RPC_directory.empty.

Definition register0_fullctxt {A B C : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
  (f :
    rpc_context ->
      A ->
        B ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              C)) : unit :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
    rpc_services
    (Tezos_protocol_environment_alpha__Environment.RPC_directory.register
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        rpc_services) s
      (fun ctxt =>
        fun q =>
          fun i =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (rpc_init ctxt) (fun ctxt => f ctxt q i))).

Definition opt_register0_fullctxt {A B C : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
  (f :
    rpc_context ->
      A ->
        B ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (option C))) : unit :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
    rpc_services
    (Tezos_protocol_environment_alpha__Environment.RPC_directory.opt_register
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        rpc_services) s
      (fun ctxt =>
        fun q =>
          fun i =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (rpc_init ctxt) (fun ctxt => f ctxt q i))).

Definition register0 {A B C : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
  (f :
    Tezos_raw_protocol_alpha.Alpha_context.t ->
      A ->
        B ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              C)) : unit :=
  register0_fullctxt s
    (fun function_parameter =>
      match function_parameter with
      | {| context := context |} => f context
      end).

Definition register0_noctxt {A B C D : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C D)
  (f :
    B ->
      C ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D))
  : unit :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
    rpc_services
    (Tezos_protocol_environment_alpha__Environment.RPC_directory.register
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        rpc_services) s
      (fun function_parameter =>
        match function_parameter with
        | _ => fun q => fun i => f q i
        end)).

Definition register1_fullctxt {A B C D : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) B
      C D)
  (f :
    rpc_context ->
      A ->
        B ->
          C ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                D)) : unit :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
    rpc_services
    (Tezos_protocol_environment_alpha__Environment.RPC_directory.register
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        rpc_services) s
      (fun function_parameter =>
        match function_parameter with
        | (ctxt, arg) =>
          fun q =>
            fun i =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (rpc_init ctxt) (fun ctxt => f ctxt arg q i)
        end)).

Definition register1 {A B C D : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) B
      C D)
  (f :
    Tezos_raw_protocol_alpha.Alpha_context.t ->
      A ->
        B ->
          C ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                D)) : unit :=
  register1_fullctxt s
    (fun function_parameter =>
      match function_parameter with
      | {| context := context |} => fun x => f context x
      end).

Definition register1_noctxt {A B C D E : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context (A * B)
      C D E)
  (f :
    B ->
      C ->
        D ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              E)) : unit :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
    rpc_services
    (Tezos_protocol_environment_alpha__Environment.RPC_directory.register
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        rpc_services) s
      (fun function_parameter =>
        match function_parameter with
        | (_, arg) => fun q => fun i => f arg q i
        end)).

Definition register2_fullctxt {A B C D E : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      ((Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) *
        B) C D E)
  (f :
    rpc_context ->
      A ->
        B ->
          C ->
            D ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  E)) : unit :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
    rpc_services
    (Tezos_protocol_environment_alpha__Environment.RPC_directory.register
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        rpc_services) s
      (fun function_parameter =>
        match function_parameter with
        | ((ctxt, arg1), arg2) =>
          fun q =>
            fun i =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (rpc_init ctxt) (fun ctxt => f ctxt arg1 arg2 q i)
        end)).

Definition register2 {A B C D E : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      ((Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) *
        B) C D E)
  (f :
    Tezos_raw_protocol_alpha.Alpha_context.t ->
      A ->
        B ->
          C ->
            D ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  E)) : unit :=
  register2_fullctxt s
    (fun function_parameter =>
      match function_parameter with
      | {| context := context |} =>
        fun a1 => fun a2 => fun q => fun i => f context a1 a2 q i
      end).

Definition get_rpc_services (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.RPC_directory.directory
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
  match function_parameter with
  | tt =>
    let p :=
      Tezos_protocol_environment_alpha__Environment.RPC_directory.map
        (fun c =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (rpc_init c)
            (fun function_parameter =>
              match function_parameter with
              | inr _ => false
              | inl c =>
                Tezos_protocol_environment_alpha__Environment.Lwt._return
                  (context c)
              end))
        (Tezos_raw_protocol_alpha.Storage_description.build_directory
          Tezos_raw_protocol_alpha.Alpha_context.description) in
    Tezos_protocol_environment_alpha__Environment.RPC_directory.register_dynamic_directory
      None
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        rpc_services)
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
        (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
          (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
            Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
            "context" % string) "raw" % string) "json" % string)
      (fun function_parameter =>
        match function_parameter with
        | _ => Tezos_protocol_environment_alpha__Environment.Lwt._return p
        end)
  end.
src/proto_alpha/lib_protocol/state_hash.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let random_state_hash = "\076\064\204" (* rng(53): never used... *)

include Blake2B.Make
          (Base58)
          (struct
            let name = "random"

            let title = "A random generation state"

            let b58check_prefix = random_state_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "rng" 53
src/proto_alpha/lib_protocol/state_hash.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition random_state_hash : string := "L@Ì" % string.
src/proto_alpha/lib_protocol/storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Storage_functors

module Int = struct
  type t = int

  let encoding = Data_encoding.uint16
end

module Int32 = struct
  type t = Int32.t

  let encoding = Data_encoding.int32
end

module Z = struct
  include Z

  let encoding = Data_encoding.z
end

module Int_index = struct
  type t = int

  let path_length = 1

  let to_path c l = string_of_int c :: l

  let of_path = function
    | [] | _ :: _ :: _ ->
        None
    | [c] ->
        int_of_string_opt c

  type 'a ipath = 'a * t

  let args =
    Storage_description.One
      {
        rpc_arg = RPC_arg.int;
        encoding = Data_encoding.int31;
        compare = Compare.Int.compare;
      }
end

module Make_index (H : Storage_description.INDEX) :
  INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct
  include H

  type 'a ipath = 'a * t

  let args = Storage_description.One {rpc_arg; encoding; compare}
end

module Block_priority =
  Make_single_data_storage (Registered) (Raw_context)
    (struct
      let name = ["block_priority"]
    end)
    (Int)

(** Contracts handling *)

module Contract = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["contracts"]
      end)

  module Global_counter =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["global_counter"]
      end)
      (Z)

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Contract_repr.Index))

  let fold = Indexed_context.fold_keys

  let list = Indexed_context.keys

  module Balance =
    Indexed_context.Make_map
      (struct
        let name = ["balance"]
      end)
      (Tez_repr)

  module Frozen_balance_index =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["frozen_balance"]
         end))
         (Make_index (Cycle_repr.Index))

  module Frozen_deposits =
    Frozen_balance_index.Make_map
      (struct
        let name = ["deposits"]
      end)
      (Tez_repr)

  module Frozen_fees =
    Frozen_balance_index.Make_map
      (struct
        let name = ["fees"]
      end)
      (Tez_repr)

  module Frozen_rewards =
    Frozen_balance_index.Make_map
      (struct
        let name = ["rewards"]
      end)
      (Tez_repr)

  module Manager =
    Indexed_context.Make_map
      (struct
        let name = ["manager"]
      end)
      (Manager_repr)

  module Delegate =
    Indexed_context.Make_map
      (struct
        let name = ["delegate"]
      end)
      (Signature.Public_key_hash)

  module Inactive_delegate =
    Indexed_context.Make_set
      (Registered)
      (struct
        let name = ["inactive_delegate"]
      end)

  module Delegate_desactivation =
    Indexed_context.Make_map
      (struct
        let name = ["delegate_desactivation"]
      end)
      (Cycle_repr)

  module Delegated =
    Make_data_set_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["delegated"]
         end))
         (Make_index (Contract_repr.Index))

  module Counter =
    Indexed_context.Make_map
      (struct
        let name = ["counter"]
      end)
      (Z)

  (* Consume gas for serilization and deserialization of expr in this
     module *)
  module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct
    module I =
      Indexed_context.Make_carbonated_map
        (N)
        (struct
          type t = Script_repr.lazy_expr

          let encoding = Script_repr.lazy_expr_encoding
        end)

    type context = I.context

    type key = I.key

    type value = I.value

    let mem = I.mem

    let delete = I.delete

    let remove = I.remove

    let consume_deserialize_gas ctxt value =
      Lwt.return
      @@ ( Raw_context.check_enough_gas
             ctxt
             (Script_repr.minimal_deserialize_cost value)
         >>? fun () ->
         Script_repr.force_decode value
         >>? fun (_value, value_cost) ->
         Raw_context.consume_gas ctxt value_cost )

    let consume_serialize_gas ctxt value =
      Lwt.return
      @@ ( Script_repr.force_bytes value
         >>? fun (_value, value_cost) ->
         Raw_context.consume_gas ctxt value_cost )

    let get ctxt contract =
      I.get ctxt contract
      >>=? fun (ctxt, value) ->
      consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value)

    let get_option ctxt contract =
      I.get_option ctxt contract
      >>=? fun (ctxt, value_opt) ->
      match value_opt with
      | None ->
          return (ctxt, None)
      | Some value ->
          consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt)

    let set ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.set ctxt contract value

    let set_option ctxt contract value_opt =
      match value_opt with
      | None ->
          I.set_option ctxt contract None
      | Some value ->
          consume_serialize_gas ctxt value
          >>=? fun ctxt -> I.set_option ctxt contract value_opt

    let init ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.init ctxt contract value

    let init_set ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.init_set ctxt contract value
  end

  module Code = Make_carbonated_map_expr (struct
    let name = ["code"]
  end)

  module Storage = Make_carbonated_map_expr (struct
    let name = ["storage"]
  end)

  module Paid_storage_space =
    Indexed_context.Make_map
      (struct
        let name = ["paid_bytes"]
      end)
      (Z)

  module Used_storage_space =
    Indexed_context.Make_map
      (struct
        let name = ["used_bytes"]
      end)
      (Z)

  module Roll_list =
    Indexed_context.Make_map
      (struct
        let name = ["roll_list"]
      end)
      (Roll_repr)

  module Change =
    Indexed_context.Make_map
      (struct
        let name = ["change"]
      end)
      (Tez_repr)
end

(** Big maps handling *)

module Big_map = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["big_maps"]
      end)

  module Next = struct
    include Make_single_data_storage (Registered) (Raw_context)
              (struct
                let name = ["next"]
              end)
              (Z)

    let incr ctxt =
      get ctxt
      >>=? fun i -> set ctxt (Z.succ i) >>=? fun ctxt -> return (ctxt, i)

    let init ctxt = init ctxt Z.zero
  end

  module Index = struct
    type t = Z.t

    let rpc_arg =
      let construct = Z.to_string in
      let destruct hash =
        match Z.of_string hash with
        | exception _ ->
            Error "Cannot parse big map id"
        | id ->
            Ok id
      in
      RPC_arg.make
        ~descr:"A big map identifier"
        ~name:"big_map_id"
        ~construct
        ~destruct
        ()

    let encoding =
      Data_encoding.def
        "big_map_id"
        ~title:"Big map identifier"
        ~description:"A big map identifier"
        Z.encoding

    let compare = Compare.Z.compare

    let path_length = 7

    let to_path c l =
      let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
      let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
      String.sub index_key 0 2 :: String.sub index_key 2 2
      :: String.sub index_key 4 2 :: String.sub index_key 6 2
      :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: Z.to_string c
      :: l

    let of_path = function
      | []
      | [_]
      | [_; _]
      | [_; _; _]
      | [_; _; _; _]
      | [_; _; _; _; _]
      | [_; _; _; _; _; _]
      | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
          None
      | [index1; index2; index3; index4; index5; index6; key] ->
          let c = Z.of_string key in
          let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
          let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
          assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
          assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
          assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
          assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
          assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
          assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
          Some c
  end

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Index))

  let rpc_arg = Index.rpc_arg

  let fold = Indexed_context.fold_keys

  let list = Indexed_context.keys

  let remove_rec ctxt n = Indexed_context.remove_rec ctxt n

  let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_

  type key = Raw_context.t * Z.t

  module Total_bytes =
    Indexed_context.Make_map
      (struct
        let name = ["total_bytes"]
      end)
      (Z)

  module Key_type =
    Indexed_context.Make_map
      (struct
        let name = ["key_type"]
      end)
      (struct
        type t = Script_repr.expr

        let encoding = Script_repr.expr_encoding
      end)

  module Value_type =
    Indexed_context.Make_map
      (struct
        let name = ["value_type"]
      end)
      (struct
        type t = Script_repr.expr

        let encoding = Script_repr.expr_encoding
      end)

  module Contents = struct
    module I =
      Storage_functors.Make_indexed_carbonated_data_storage
        (Make_subcontext (Registered) (Indexed_context.Raw_context)
           (struct
             let name = ["contents"]
           end))
           (Make_index (Script_expr_hash))
           (struct
             type t = Script_repr.expr

             let encoding = Script_repr.expr_encoding
           end)

    type context = I.context

    type key = I.key

    type value = I.value

    let mem = I.mem

    let delete = I.delete

    let remove = I.remove

    let set = I.set

    let set_option = I.set_option

    let init = I.init

    let init_set = I.init_set

    let consume_deserialize_gas ctxt value =
      Lwt.return
      @@ Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value)

    let get ctxt contract =
      I.get ctxt contract
      >>=? fun (ctxt, value) ->
      consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value)

    let get_option ctxt contract =
      I.get_option ctxt contract
      >>=? fun (ctxt, value_opt) ->
      match value_opt with
      | None ->
          return (ctxt, None)
      | Some value ->
          consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt)
  end
end

module Delegates =
  Make_data_set_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["delegates"]
       end))
       (Make_index (Signature.Public_key_hash))

module Active_delegates_with_rolls =
  Make_data_set_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["active_delegates_with_rolls"]
       end))
       (Make_index (Signature.Public_key_hash))

module Delegates_with_frozen_balance_index =
  Make_indexed_subcontext
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["delegates_with_frozen_balance"]
       end))
       (Make_index (Cycle_repr.Index))

module Delegates_with_frozen_balance =
  Make_data_set_storage
    (Delegates_with_frozen_balance_index.Raw_context)
    (Make_index (Signature.Public_key_hash))

(** Rolls *)

module Cycle = struct
  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["cycle"]
         end))
         (Make_index (Cycle_repr.Index))

  module Last_roll =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["last_roll"]
         end))
         (Int_index)
      (Roll_repr)

  module Roll_snapshot =
    Indexed_context.Make_map
      (struct
        let name = ["roll_snapshot"]
      end)
      (Int)

  type unrevealed_nonce = {
    nonce_hash : Nonce_hash.t;
    delegate : Signature.Public_key_hash.t;
    rewards : Tez_repr.t;
    fees : Tez_repr.t;
  }

  type nonce_status =
    | Unrevealed of unrevealed_nonce
    | Revealed of Seed_repr.nonce

  let nonce_status_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Unrevealed"
          (tup4
             Nonce_hash.encoding
             Signature.Public_key_hash.encoding
             Tez_repr.encoding
             Tez_repr.encoding)
          (function
            | Unrevealed {nonce_hash; delegate; rewards; fees} ->
                Some (nonce_hash, delegate, rewards, fees)
            | _ ->
                None)
          (fun (nonce_hash, delegate, rewards, fees) ->
            Unrevealed {nonce_hash; delegate; rewards; fees});
        case
          (Tag 1)
          ~title:"Revealed"
          Seed_repr.nonce_encoding
          (function Revealed nonce -> Some nonce | _ -> None)
          (fun nonce -> Revealed nonce) ]

  module Nonce =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["nonces"]
         end))
         (Make_index (Raw_level_repr.Index))
         (struct
           type t = nonce_status

           let encoding = nonce_status_encoding
         end)

  module Seed =
    Indexed_context.Make_map
      (struct
        let name = ["random_seed"]
      end)
      (struct
        type t = Seed_repr.seed

        let encoding = Seed_repr.seed_encoding
      end)
end

module Roll = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["rolls"]
      end)

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Roll_repr.Index))

  module Next =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["next"]
      end)
      (Roll_repr)

  module Limbo =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["limbo"]
      end)
      (Roll_repr)

  module Delegate_roll_list =
    Wrap_indexed_data_storage
      (Contract.Roll_list)
      (struct
        type t = Signature.Public_key_hash.t

        let wrap = Contract_repr.implicit_contract

        let unwrap = Contract_repr.is_implicit
      end)

  module Successor =
    Indexed_context.Make_map
      (struct
        let name = ["successor"]
      end)
      (Roll_repr)

  module Delegate_change =
    Wrap_indexed_data_storage
      (Contract.Change)
      (struct
        type t = Signature.Public_key_hash.t

        let wrap = Contract_repr.implicit_contract

        let unwrap = Contract_repr.is_implicit
      end)

  module Snapshoted_owner_index = struct
    type t = Cycle_repr.t * int

    let path_length = Cycle_repr.Index.path_length + 1

    let to_path (c, n) s = Cycle_repr.Index.to_path c (string_of_int n :: s)

    let of_path l =
      match Misc.take Cycle_repr.Index.path_length l with
      | None | Some (_, ([] | _ :: _ :: _)) ->
          None
      | Some (l1, [l2]) -> (
        match (Cycle_repr.Index.of_path l1, int_of_string_opt l2) with
        | (None, _) | (_, None) ->
            None
        | (Some c, Some i) ->
            Some (c, i) )

    type 'a ipath = ('a * Cycle_repr.t) * int

    let left_args =
      Storage_description.One
        {
          rpc_arg = Cycle_repr.rpc_arg;
          encoding = Cycle_repr.encoding;
          compare = Cycle_repr.compare;
        }

    let right_args =
      Storage_description.One
        {
          rpc_arg = RPC_arg.int;
          encoding = Data_encoding.int31;
          compare = Compare.Int.compare;
        }

    let args = Storage_description.(Pair (left_args, right_args))
  end

  module Owner =
    Make_indexed_data_snapshotable_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["owner"]
         end))
         (Snapshoted_owner_index)
      (Make_index (Roll_repr.Index))
      (Signature.Public_key)

  module Snapshot_for_cycle = Cycle.Roll_snapshot
  module Last_for_snapshot = Cycle.Last_roll

  let clear = Indexed_context.clear
end

(** Votes *)

module Vote = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["votes"]
      end)

  module Current_period_kind =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["current_period_kind"]
      end)
      (struct
        type t = Voting_period_repr.kind

        let encoding = Voting_period_repr.kind_encoding
      end)

  module Participation_ema =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["participation_ema"]
      end)
      (Int32)

  module Current_proposal =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["current_proposal"]
      end)
      (Protocol_hash)

  module Listings_size =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["listings_size"]
      end)
      (Int32)

  module Listings =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["listings"]
         end))
         (Make_index (Signature.Public_key_hash))
         (Int32)

  module Proposals =
    Make_data_set_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["proposals"]
         end))
         (Pair
            (Make_index
               (Protocol_hash))
               (Make_index (Signature.Public_key_hash)))

  module Proposals_count =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["proposals_count"]
         end))
         (Make_index (Signature.Public_key_hash))
         (Int)

  module Ballots =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ballots"]
         end))
         (Make_index (Signature.Public_key_hash))
         (struct
           type t = Vote_repr.ballot

           let encoding = Vote_repr.ballot_encoding
         end)
end

(** Seed *)

module Seed = struct
  type unrevealed_nonce = Cycle.unrevealed_nonce = {
    nonce_hash : Nonce_hash.t;
    delegate : Signature.Public_key_hash.t;
    rewards : Tez_repr.t;
    fees : Tez_repr.t;
  }

  type nonce_status = Cycle.nonce_status =
    | Unrevealed of unrevealed_nonce
    | Revealed of Seed_repr.nonce

  module Nonce = struct
    open Level_repr

    type context = Raw_context.t

    let mem ctxt l = Cycle.Nonce.mem (ctxt, l.cycle) l.level

    let get ctxt l = Cycle.Nonce.get (ctxt, l.cycle) l.level

    let get_option ctxt l = Cycle.Nonce.get_option (ctxt, l.cycle) l.level

    let set ctxt l v = Cycle.Nonce.set (ctxt, l.cycle) l.level v

    let init ctxt l v = Cycle.Nonce.init (ctxt, l.cycle) l.level v

    let init_set ctxt l v = Cycle.Nonce.init_set (ctxt, l.cycle) l.level v

    let set_option ctxt l v = Cycle.Nonce.set_option (ctxt, l.cycle) l.level v

    let delete ctxt l = Cycle.Nonce.delete (ctxt, l.cycle) l.level

    let remove ctxt l = Cycle.Nonce.remove (ctxt, l.cycle) l.level
  end

  module For_cycle = Cycle.Seed
end

(** Commitments *)

module Commitments =
  Make_indexed_data_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["commitments"]
       end))
       (Make_index (Blinded_public_key_hash.Index))
       (Tez_repr)

(** Ramp up security deposits... *)

module Ramp_up = struct
  module Rewards =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ramp_up"; "rewards"]
         end))
         (Make_index (Cycle_repr.Index))
         (struct
           type t = Tez_repr.t * Tez_repr.t

           let encoding =
             Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
         end)

  module Security_deposits =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ramp_up"; "deposits"]
         end))
         (Make_index (Cycle_repr.Index))
         (struct
           type t = Tez_repr.t * Tez_repr.t

           let encoding =
             Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
         end)
end
src/proto_alpha/lib_protocol/storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Storage_functors.

Module Int.
  Definition t := Z.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding Z :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.uint16.
End Int.

Module Int32.
  Definition t := Tezos_protocol_environment_alpha__Environment.Int32.t.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.int32.
End Int32.

Module Z.
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.z.
End Z.

Module Int_index.
  Definition t := Z.
  
  Definition path_length : Z := 1.
  
  Definition to_path (c : Z) (l : list string) : list string :=
    cons
      (Tezos_protocol_environment_alpha__Environment.Pervasives.string_of_int c)
      l.
  
  Definition of_path (function_parameter : list string) : option Z :=
    match function_parameter with
    | [] | cons _ (cons _ _) => None
    | cons c [] =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.int_of_string_opt
        c
    end.
  
  Definition ipath (a : Type) := a * t.
  
  Definition args {A : Type}
    : Tezos_raw_protocol_alpha.Storage_description.args A
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
      (A *
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
    Storage_description.One
      {| rpc_arg := Tezos_protocol_environment_alpha__Environment.RPC_arg.int;
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.int31;
        compare :=
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
        |}.
End Int_index.

Module Contract.
  Definition fold {A : Type}
    : Indexed_context.context ->
      A ->
        (Indexed_context.key ->
          A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
    Indexed_context.fold_keys.
  
  Definition list
    : Indexed_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (list Indexed_context.key) := Indexed_context.keys.
End Contract.

Module Big_map.
  Module Next.
    Definition incr (ctxt : context)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * value)) :=
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (get ctxt)
        (fun i =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (set ctxt (Z.succ i))
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, i))).
    
    Definition init (ctxt : context)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) := init ctxt Z.zero.
  End Next.
  
  Module Index.
    Definition t := Z.t.
    
    Definition rpc_arg
      : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg Z.t :=
      let construct := Z.to_string in
      let destruct (hash : string)
        : Tezos_protocol_environment_alpha__Environment.Pervasives.result Z.t
          string :=
        match Z.of_string hash with
        | id => inl id
        end in
      Tezos_protocol_environment_alpha__Environment.RPC_arg.make
        (Some "A big map identifier" % string) "big_map_id" % string destruct
        construct tt.
    
    Definition encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        Tezos_protocol_environment_alpha__Environment.Z.t :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "big_map_id" % string (Some "Big map identifier" % string)
        (Some "A big map identifier" % string) Z.encoding.
    
    Definition compare
      : Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
        ->
        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
          -> Z :=
      Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare).
    
    Definition path_length : Z := 7.
    
    Definition to_path
      (c : Tezos_protocol_environment_alpha__Environment.Z.t) (l : list string)
      : list string :=
      let raw_key :=
        Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
          encoding c in
      match
        Tezos_protocol_environment_alpha__Environment.MBytes.to_hex
          (Tezos_protocol_environment_alpha__Environment.Raw_hashes.blake2b
            raw_key) with
      | Hex index_key =>
        cons
          (Tezos_protocol_environment_alpha__Environment.String.sub index_key 0
            2)
          (cons
            (Tezos_protocol_environment_alpha__Environment.String.sub index_key
              2 2)
            (cons
              (Tezos_protocol_environment_alpha__Environment.String.sub
                index_key 4 2)
              (cons
                (Tezos_protocol_environment_alpha__Environment.String.sub
                  index_key 6 2)
                (cons
                  (Tezos_protocol_environment_alpha__Environment.String.sub
                    index_key 8 2)
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.String.sub
                      index_key 10 2) (cons (Z.to_string c) l))))))
      end.
    
    Definition of_path
      (function_parameter :
        list
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : option Z.t :=
      match function_parameter with
      |
        [] | cons _ [] | cons _ (cons _ []) | cons _ (cons _ (cons _ [])) |
          cons _ (cons _ (cons _ (cons _ []))) |
          cons _ (cons _ (cons _ (cons _ (cons _ [])))) |
          cons _ (cons _ (cons _ (cons _ (cons _ (cons _ []))))) |
          cons _
            (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ _))))))) =>
        None
      |
        cons index1
          (cons index2
            (cons index3 (cons index4 (cons index5 (cons index6 (cons key []))))))
        =>
        let c := Z.of_string key in
        let raw_key :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
            encoding c in
        match
          Tezos_protocol_environment_alpha__Environment.MBytes.to_hex
            (Tezos_protocol_environment_alpha__Environment.Raw_hashes.blake2b
              raw_key) with
        | Hex index_key =>
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Tezos_protocol_environment_alpha__Environment.String.sub index_key
              0 2) index1;
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Tezos_protocol_environment_alpha__Environment.String.sub index_key
              2 2) index2;
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Tezos_protocol_environment_alpha__Environment.String.sub index_key
              4 2) index3;
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Tezos_protocol_environment_alpha__Environment.String.sub index_key
              6 2) index4;
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Tezos_protocol_environment_alpha__Environment.String.sub index_key
              8 2) index5;
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Tezos_protocol_environment_alpha__Environment.String.sub index_key
              10 2) index6;
          Some c
        end
      end.
  End Index.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg Z.t :=
    Index.rpc_arg.
  
  Definition fold {A : Type}
    : Indexed_context.context ->
      A ->
        (Indexed_context.key ->
          A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
    Indexed_context.fold_keys.
  
  Definition list
    : Indexed_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (list Indexed_context.key) := Indexed_context.keys.
  
  Definition remove_rec
    (ctxt : Indexed_context.context) (n : Indexed_context.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      Indexed_context.context := Indexed_context.remove_rec ctxt n.
  
  Definition copy
    (ctxt : Indexed_context.context) (from : Indexed_context.key)
    (to_ : Indexed_context.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Indexed_context.context) := Indexed_context.copy ctxt from to_.
  
  Definition key := Raw_context.t * Z.t.
  
  Module Contents.
    Definition context := I.context.
    
    Definition key := I.key.
    
    Definition value := I.value.
    
    Definition mem
      : I.context ->
        I.key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * bool)) := I.mem.
    
    Definition delete
      : I.context ->
        I.key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.delete.
    
    Definition remove
      : I.context ->
        I.key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) := I.remove.
    
    Definition set
      : I.context ->
        I.key ->
          I.value ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.set.
    
    Definition set_option
      : I.context ->
        I.key ->
          (option I.value) ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) :=
      I.set_option.
    
    Definition init
      : I.context ->
        I.key ->
          I.value ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.init.
    
    Definition init_set
      : I.context ->
        I.key ->
          I.value ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) :=
      I.init_set.
    
    Definition consume_deserialize_gas
      (ctxt : Raw_context.context)
      (value : Tezos_raw_protocol_alpha.Script_repr.expr)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Raw_context.context) :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Lwt._return
        (Raw_context.consume_gas ctxt
          (Tezos_raw_protocol_alpha.Script_repr.deserialized_cost value)).
    
    Definition get (ctxt : I.context) (contract : I.key)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Raw_context.context * I.value)) :=
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (I.get ctxt contract)
        (fun function_parameter =>
          match function_parameter with
          | (ctxt, value) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
              (consume_deserialize_gas ctxt value) (fun ctxt => (ctxt, value))
          end).
    
    Definition get_option (ctxt : I.context) (contract : I.key)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * (option I.value))) :=
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (I.get_option ctxt contract)
        (fun function_parameter =>
          match function_parameter with
          | (ctxt, value_opt) =>
            match value_opt with
            | None =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (ctxt, None)
            | Some value =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_pipe_question
                (consume_deserialize_gas ctxt value)
                (fun ctxt => (ctxt, value_opt))
            end
          end).
  End Contents.
End Big_map.

Module Cycle.
  Record unrevealed_nonce := {
    nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
    fees : Tezos_raw_protocol_alpha.Tez_repr.t }.
  
  Inductive nonce_status : Type :=
  | Unrevealed : unrevealed_nonce -> nonce_status
  | Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> nonce_status.
  
  Definition nonce_status_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      nonce_status :=
    Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Unrevealed" % string None (Tag 0)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup4
            Tezos_raw_protocol_alpha.Nonce_hash.encoding
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding
            Tezos_raw_protocol_alpha.Tez_repr.encoding
            Tezos_raw_protocol_alpha.Tez_repr.encoding)
          (fun function_parameter =>
            match function_parameter with
            |
              Unrevealed {|
                nonce_hash := nonce_hash;
                  delegate := delegate;
                  rewards := rewards;
                  fees := fees
                  |} => Some (nonce_hash, delegate, rewards, fees)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (nonce_hash, delegate, rewards, fees) =>
              Unrevealed
                {| nonce_hash := nonce_hash; delegate := delegate;
                  rewards := rewards; fees := fees |}
            end))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "Revealed" % string None (Tag 1)
            Tezos_raw_protocol_alpha.Seed_repr.nonce_encoding
            (fun function_parameter =>
              match function_parameter with
              | Revealed nonce => Some nonce
              | _ => None
              end) (fun nonce => Revealed nonce)) [])).
End Cycle.

Module Roll.
  Module Snapshoted_owner_index.
    Definition t := Tezos_raw_protocol_alpha.Cycle_repr.t * Z.
    
    Definition path_length : Z :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
        Tezos_raw_protocol_alpha.Cycle_repr.Index.path_length 1.
    
    Definition to_path
      (function_parameter : Tezos_raw_protocol_alpha.Cycle_repr.Index.t * Z)
      : (list string) -> list string :=
      match function_parameter with
      | (c, n) =>
        fun s =>
          Tezos_raw_protocol_alpha.Cycle_repr.Index.to_path c
            (cons
              (Tezos_protocol_environment_alpha__Environment.Pervasives.string_of_int
                n) s)
      end.
    
    Definition of_path (l : list string)
      : option (Tezos_raw_protocol_alpha.Cycle_repr.Index.t * Z) :=
      match
        Tezos_raw_protocol_alpha.Misc.take
          Tezos_raw_protocol_alpha.Cycle_repr.Index.path_length l with
      | None | Some (_, [] | cons _ (cons _ _)) => None
      | Some (l1, cons l2 []) =>
        match
          ((Tezos_raw_protocol_alpha.Cycle_repr.Index.of_path l1),
            (Tezos_protocol_environment_alpha__Environment.Pervasives.int_of_string_opt
              l2)) with
        | (None, _) | (_, None) => None
        | (Some c, Some i) => Some (c, i)
        end
      end.
    
    Definition ipath (a : Type) :=
      (a * Tezos_raw_protocol_alpha.Cycle_repr.t) * Z.
    
    Definition left_args {A : Type}
      : Tezos_raw_protocol_alpha.Storage_description.args A
        Tezos_raw_protocol_alpha.Cycle_repr.cycle
        (A * Tezos_raw_protocol_alpha.Cycle_repr.cycle) :=
      Storage_description.One
        {| rpc_arg := Tezos_raw_protocol_alpha.Cycle_repr.rpc_arg;
          encoding := Tezos_raw_protocol_alpha.Cycle_repr.encoding;
          compare := Tezos_raw_protocol_alpha.Cycle_repr.compare |}.
    
    Definition right_args {A : Type}
      : Tezos_raw_protocol_alpha.Storage_description.args A
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
        (A *
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
      Storage_description.One
        {| rpc_arg := Tezos_protocol_environment_alpha__Environment.RPC_arg.int;
          encoding :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.int31;
          compare :=
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
          |}.
    
    Definition args {A : Type}
      : Tezos_raw_protocol_alpha.Storage_description.args A
        (Tezos_raw_protocol_alpha.Cycle_repr.cycle *
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
        ((A * Tezos_raw_protocol_alpha.Cycle_repr.cycle) *
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
      Pair left_args right_args.
  End Snapshoted_owner_index.
  
  Definition clear
    : Indexed_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t := Indexed_context.clear.
End Roll.

Module Vote.

End Vote.

Module Seed.
  Record unrevealed_nonce := {
    nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
    fees : Tezos_raw_protocol_alpha.Tez_repr.t }.
  
  Inductive nonce_status : Type :=
  | Unrevealed : unrevealed_nonce -> nonce_status
  | Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> nonce_status.
  
  Module Nonce.
    Import Tezos_raw_protocol_alpha.Level_repr.
    
    Definition context := Tezos_raw_protocol_alpha.Raw_context.t.
    
    Definition mem
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
      Cycle.Nonce.mem (ctxt, (cycle l)) (level l).
    
    Definition get
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Cycle.Nonce.value) := Cycle.Nonce.get (ctxt, (cycle l)) (level l).
    
    Definition get_option
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option Cycle.Nonce.value)) :=
      Cycle.Nonce.get_option (ctxt, (cycle l)) (level l).
    
    Definition set
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
      Cycle.Nonce.set (ctxt, (cycle l)) (level l) v.
    
    Definition init
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
      Cycle.Nonce.init (ctxt, (cycle l)) (level l) v.
    
    Definition init_set
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t :=
      Cycle.Nonce.init_set (ctxt, (cycle l)) (level l) v.
    
    Definition set_option
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t) (v : option Cycle.Nonce.value)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t :=
      Cycle.Nonce.set_option (ctxt, (cycle l)) (level l) v.
    
    Definition delete
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
      Cycle.Nonce.delete (ctxt, (cycle l)) (level l).
    
    Definition remove
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t :=
      Cycle.Nonce.remove (ctxt, (cycle l)) (level l).
  End Nonce.
End Seed.

Module Ramp_up.

End Ramp_up.
src/proto_alpha/lib_protocol/storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Typed storage

    This module hides the hierarchical (key x value) database under
    pre-allocated typed accessors for all persistent entities of the
    tezos context.

    This interface enforces no invariant on the contents of the
    database. Its goal is to centralize all accessors in order to have
    a complete view over the database contents and avoid key
    collisions. *)

open Storage_sigs

module Block_priority : sig
  val get : Raw_context.t -> int tzresult Lwt.t

  val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t

  val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t
end

module Roll : sig
  (** Storage from this submodule must only be accessed through the
      module `Roll`. *)

  module Owner :
    Indexed_data_snapshotable_storage
      with type key = Roll_repr.t
       and type snapshot = Cycle_repr.t * int
       and type value = Signature.Public_key.t
       and type t := Raw_context.t

  val clear : Raw_context.t -> Raw_context.t Lwt.t

  (** The next roll to be allocated. *)
  module Next :
    Single_data_storage
      with type value = Roll_repr.t
       and type t := Raw_context.t

  (** Rolls linked lists represent both account owned and free rolls.
      All rolls belongs either to the limbo list or to an owned list. *)

  (** Head of the linked list of rolls in limbo *)
  module Limbo :
    Single_data_storage
      with type value = Roll_repr.t
       and type t := Raw_context.t

  (** Rolls associated to contracts, a linked list per contract *)
  module Delegate_roll_list :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = Roll_repr.t
       and type t := Raw_context.t

  (** Use this to iter on a linked list of rolls *)
  module Successor :
    Indexed_data_storage
      with type key = Roll_repr.t
       and type value = Roll_repr.t
       and type t := Raw_context.t

  (** The tez of a contract that are not assigned to rolls *)
  module Delegate_change :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = Tez_repr.t
       and type t := Raw_context.t

  (** Index of the randomly selected roll snapshot of a given cycle. *)
  module Snapshot_for_cycle :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = int
       and type t := Raw_context.t

  (** Last roll in the snapshoted roll allocation of a given cycle. *)
  module Last_for_snapshot :
    Indexed_data_storage
      with type key = int
       and type value = Roll_repr.t
       and type t = Raw_context.t * Cycle_repr.t
end

module Contract : sig
  (** Storage from this submodule must only be accessed through the
      module `Contract`. *)

  module Global_counter : sig
    val get : Raw_context.t -> Z.t tzresult Lwt.t

    val set : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t

    val init : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t
  end

  (** The domain of alive contracts *)
  val fold :
    Raw_context.t ->
    init:'a ->
    f:(Contract_repr.t -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val list : Raw_context.t -> Contract_repr.t list Lwt.t

  (** All the tez possesed by a contract, including rolls and change *)
  module Balance :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Tez_repr.t
       and type t := Raw_context.t

  (** Frozen balance, see 'delegate_storage.mli' for more explanation.
      Always update `Delegates_with_frozen_balance` accordingly. *)
  module Frozen_deposits :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t
       and type t = Raw_context.t * Contract_repr.t

  module Frozen_fees :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t
       and type t = Raw_context.t * Contract_repr.t

  module Frozen_rewards :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t
       and type t = Raw_context.t * Contract_repr.t

  (** The manager of a contract *)
  module Manager :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Manager_repr.t
       and type t := Raw_context.t

  (** The delegate of a contract, if any. *)
  module Delegate :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Signature.Public_key_hash.t
       and type t := Raw_context.t

  (** All contracts (implicit and originated) that are delegated, if any  *)
  module Delegated :
    Data_set_storage
      with type elt = Contract_repr.t
       and type t = Raw_context.t * Contract_repr.t

  module Inactive_delegate :
    Data_set_storage with type elt = Contract_repr.t and type t = Raw_context.t

  (** The cycle where the delegate should be desactivated. *)
  module Delegate_desactivation :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Cycle_repr.t
       and type t := Raw_context.t

  module Counter :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Z.t
       and type t := Raw_context.t

  module Code :
    Non_iterable_indexed_carbonated_data_storage
      with type key = Contract_repr.t
       and type value = Script_repr.lazy_expr
       and type t := Raw_context.t

  module Storage :
    Non_iterable_indexed_carbonated_data_storage
      with type key = Contract_repr.t
       and type value = Script_repr.lazy_expr
       and type t := Raw_context.t

  (** Current storage space in bytes.
      Includes code, global storage and big map elements. *)
  module Used_storage_space :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Z.t
       and type t := Raw_context.t

  (** Maximal space available without needing to burn new fees. *)
  module Paid_storage_space :
    Indexed_data_storage
      with type key = Contract_repr.t
       and type value = Z.t
       and type t := Raw_context.t
end

module Big_map : sig
  module Next : sig
    val incr : Raw_context.t -> (Raw_context.t * Z.t) tzresult Lwt.t

    val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
  end

  (** The domain of alive big maps *)
  val fold : Raw_context.t -> init:'a -> f:(Z.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val list : Raw_context.t -> Z.t list Lwt.t

  val remove_rec : Raw_context.t -> Z.t -> Raw_context.t Lwt.t

  val copy :
    Raw_context.t -> from:Z.t -> to_:Z.t -> Raw_context.t tzresult Lwt.t

  type key = Raw_context.t * Z.t

  val rpc_arg : Z.t RPC_arg.t

  module Contents :
    Non_iterable_indexed_carbonated_data_storage
      with type key = Script_expr_hash.t
       and type value = Script_repr.expr
       and type t := key

  module Total_bytes :
    Indexed_data_storage
      with type key = Z.t
       and type value = Z.t
       and type t := Raw_context.t

  module Key_type :
    Indexed_data_storage
      with type key = Z.t
       and type value = Script_repr.expr
       and type t := Raw_context.t

  module Value_type :
    Indexed_data_storage
      with type key = Z.t
       and type value = Script_repr.expr
       and type t := Raw_context.t
end

(** Set of all registered delegates. *)
module Delegates :
  Data_set_storage
    with type t := Raw_context.t
     and type elt = Signature.Public_key_hash.t

(** Set of all active delegates with rolls. *)
module Active_delegates_with_rolls :
  Data_set_storage
    with type t := Raw_context.t
     and type elt = Signature.Public_key_hash.t

(** Set of all the delegates with frozen rewards/bonds/fees for a given cycle. *)
module Delegates_with_frozen_balance :
  Data_set_storage
    with type t = Raw_context.t * Cycle_repr.t
     and type elt = Signature.Public_key_hash.t

(** Votes *)

module Vote : sig
  module Current_period_kind :
    Single_data_storage
      with type value = Voting_period_repr.kind
       and type t := Raw_context.t

  (** Participation exponential moving average, in centile of percentage *)
  module Participation_ema :
    Single_data_storage with type value = int32 and type t := Raw_context.t

  module Current_proposal :
    Single_data_storage
      with type value = Protocol_hash.t
       and type t := Raw_context.t

  (** Sum of all rolls of all delegates. *)
  module Listings_size :
    Single_data_storage with type value = int32 and type t := Raw_context.t

  (** Contains all delegates with their assigned number of rolls. *)
  module Listings :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = int32
       and type t := Raw_context.t

  (** Set of protocol proposal with corresponding proposer delegate *)
  module Proposals :
    Data_set_storage
      with type elt = Protocol_hash.t * Signature.Public_key_hash.t
       and type t := Raw_context.t

  (** Keeps for each delegate the number of proposed protocols *)
  module Proposals_count :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = int
       and type t := Raw_context.t

  (** Contains for each delegate its ballot *)
  module Ballots :
    Indexed_data_storage
      with type key = Signature.Public_key_hash.t
       and type value = Vote_repr.ballot
       and type t := Raw_context.t
end

(** Seed *)

module Seed : sig
  (** Storage from this submodule must only be accessed through the
      module `Seed`. *)

  type unrevealed_nonce = {
    nonce_hash : Nonce_hash.t;
    delegate : Signature.Public_key_hash.t;
    rewards : Tez_repr.t;
    fees : Tez_repr.t;
  }

  type nonce_status =
    | Unrevealed of unrevealed_nonce
    | Revealed of Seed_repr.nonce

  module Nonce :
    Non_iterable_indexed_data_storage
      with type key := Level_repr.t
       and type value := nonce_status
       and type t := Raw_context.t

  module For_cycle : sig
    val init :
      Raw_context.t ->
      Cycle_repr.t ->
      Seed_repr.seed ->
      Raw_context.t tzresult Lwt.t

    val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t

    val delete : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
  end
end

(** Commitments *)

module Commitments :
  Indexed_data_storage
    with type key = Blinded_public_key_hash.t
     and type value = Tez_repr.t
     and type t := Raw_context.t

(** Ramp up security deposits... *)

module Ramp_up : sig
  module Rewards :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t * Tez_repr.t
      (* baking * endorsement *)
       and type t := Raw_context.t

  module Security_deposits :
    Indexed_data_storage
      with type key = Cycle_repr.t
       and type value = Tez_repr.t * Tez_repr.t
      (* baking * endorsement *)
       and type t := Raw_context.t
end
src/proto_alpha/lib_protocol/storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Block_priority.
  Parameter get : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z).
  
  Parameter set : Tezos_raw_protocol_alpha.Raw_context.t ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).
  
  Parameter init : Tezos_raw_protocol_alpha.Raw_context.t ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).
End Block_priority.

Module Roll.
  unhandled_module
  
  Parameter clear : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      Tezos_raw_protocol_alpha.Raw_context.t.
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
End Roll.

Module Contract.
  Module Global_counter.
    Parameter get : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Z.t).
    
    Parameter set : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).
    
    Parameter init : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).
  End Global_counter.
  
  Parameter fold : forall {a : Type}, Tezos_raw_protocol_alpha.Raw_context.t ->
    a ->
      (Tezos_raw_protocol_alpha.Contract_repr.t ->
        a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t a.
  
  Parameter list : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list Tezos_raw_protocol_alpha.Contract_repr.t).
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
End Contract.

Module Big_map.
  Module Next.
    Parameter incr : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t *
            Tezos_protocol_environment_alpha__Environment.Z.t)).
    
    Parameter init : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).
  End Next.
  
  Parameter fold : forall {a : Type}, Tezos_raw_protocol_alpha.Raw_context.t ->
    a ->
      (Tezos_protocol_environment_alpha__Environment.Z.t ->
        a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t a.
  
  Parameter list : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list Tezos_protocol_environment_alpha__Environment.Z.t).
  
  Parameter remove_rec : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t.
  
  Parameter copy : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).
  
  Definition key :=
    Tezos_raw_protocol_alpha.Raw_context.t *
      Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Parameter rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.t
    Tezos_protocol_environment_alpha__Environment.Z.t.
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
End Big_map.

unhandled_module

unhandled_module

unhandled_module

Module Vote.
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
  
  unhandled_module
End Vote.

Module Seed.
  Record unrevealed_nonce := {
    nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
    fees : Tezos_raw_protocol_alpha.Tez_repr.t }.
  
  Inductive nonce_status : Type :=
  | Unrevealed : unrevealed_nonce -> nonce_status
  | Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> nonce_status.
  
  unhandled_module
  
  Module For_cycle.
    Parameter init : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Cycle_repr.t ->
        Tezos_raw_protocol_alpha.Seed_repr.seed ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              Tezos_raw_protocol_alpha.Raw_context.t).
    
    Parameter get : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Cycle_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Seed_repr.seed).
    
    Parameter delete : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Cycle_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t).
  End For_cycle.
End Seed.

unhandled_module

Module Ramp_up.
  unhandled_module
  
  unhandled_module
End Ramp_up.
src/proto_alpha/lib_protocol/storage_description.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module StringMap = Map.Make (String)

type 'key t = 'key description ref

and 'key description =
  | Empty : 'key description
  | Value : {
      get : 'key -> 'a option tzresult Lwt.t;
      encoding : 'a Data_encoding.t;
    }
      -> 'key description
  | NamedDir : 'key t StringMap.t -> 'key description
  | IndexedDir : {
      arg : 'a RPC_arg.t;
      arg_encoding : 'a Data_encoding.t;
      list : 'key -> 'a list tzresult Lwt.t;
      subdir : ('key * 'a) t;
    }
      -> 'key description

let rec register_named_subcontext : type r. r t -> string list -> r t =
 fun dir names ->
  match (!dir, names) with
  | (_, []) ->
      dir
  | (Value _, _) ->
      invalid_arg ""
  | (IndexedDir _, _) ->
      invalid_arg ""
  | (Empty, name :: names) ->
      let subdir = ref Empty in
      dir := NamedDir (StringMap.singleton name subdir) ;
      register_named_subcontext subdir names
  | (NamedDir map, name :: names) ->
      let subdir =
        match StringMap.find_opt name map with
        | Some subdir ->
            subdir
        | None ->
            let subdir = ref Empty in
            dir := NamedDir (StringMap.add name subdir map) ;
            subdir
      in
      register_named_subcontext subdir names

type (_, _, _) args =
  | One : {
      rpc_arg : 'a RPC_arg.t;
      encoding : 'a Data_encoding.t;
      compare : 'a -> 'a -> int;
    }
      -> ('key, 'a, 'key * 'a) args
  | Pair :
      ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args
      -> ('key, 'a * 'b, 'sub_key) args

let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function
  | One _ ->
      fun x -> x
  | Pair (l, r) ->
      let unpack_l = unpack l in
      let unpack_r = unpack r in
      fun x ->
        let (c, d) = unpack_r x in
        let (b, a) = unpack_l c in
        (b, (a, d))

let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function
  | One _ ->
      fun b a -> (b, a)
  | Pair (l, r) ->
      let pack_l = pack l in
      let pack_r = pack r in
      fun b (a, d) ->
        let c = pack_l b a in
        pack_r c d

let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function
  | One {compare; _} ->
      compare
  | Pair (l, r) -> (
      let compare_l = compare l in
      let compare_r = compare r in
      fun (a1, b1) (a2, b2) ->
        match compare_l a1 a2 with 0 -> compare_r b1 b2 | x -> x )

let destutter equal l =
  match l with
  | [] ->
      []
  | (i, _) :: l ->
      let rec loop acc i = function
        | [] ->
            acc
        | (j, _) :: l ->
            if equal i j then loop acc i l else loop (j :: acc) j l
      in
      loop [i] i l

let rec register_indexed_subcontext :
    type r a b.
    r t -> list:(r -> a list tzresult Lwt.t) -> (r, a, b) args -> b t =
 fun dir ~list path ->
  match path with
  | Pair (left, right) ->
      let compare_left = compare left in
      let equal_left x y = Compare.Int.(compare_left x y = 0) in
      let list_left r = list r >>=? fun l -> return (destutter equal_left l) in
      let list_right r =
        let (a, k) = unpack left r in
        list a
        >>=? fun l ->
        return (List.map snd (List.filter (fun (x, _) -> equal_left x k) l))
      in
      register_indexed_subcontext
        (register_indexed_subcontext dir ~list:list_left left)
        ~list:list_right
        right
  | One {rpc_arg = arg; encoding = arg_encoding; _} -> (
    match !dir with
    | Value _ ->
        invalid_arg ""
    | NamedDir _ ->
        invalid_arg ""
    | Empty ->
        let subdir = ref Empty in
        dir := IndexedDir {arg; arg_encoding; list; subdir} ;
        subdir
    | IndexedDir {arg = inner_arg; subdir; _} -> (
      match RPC_arg.eq arg inner_arg with
      | None ->
          invalid_arg ""
      | Some RPC_arg.Eq ->
          subdir ) )

let register_value :
    type a b.
    a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit =
 fun dir ~get encoding ->
  match !dir with Empty -> dir := Value {get; encoding} | _ -> invalid_arg ""

let create () = ref Empty

let rec pp : type a. Format.formatter -> a t -> unit =
 fun ppf dir ->
  match !dir with
  | Empty ->
      Format.fprintf ppf "EMPTY"
  | Value _e ->
      Format.fprintf ppf "Value"
  | NamedDir map ->
      Format.fprintf
        ppf
        "@[<v>%a@]"
        (Format.pp_print_list pp_item)
        (StringMap.bindings map)
  | IndexedDir {arg; subdir; _} ->
      let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in
      pp_item ppf (name, subdir)

and pp_item : type a. Format.formatter -> string * a t -> unit =
 fun ppf (name, dir) -> Format.fprintf ppf "@[<v 2>%s@ %a@]" name pp dir

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  val rpc_arg : t RPC_arg.t

  val encoding : t Data_encoding.t

  val compare : t -> t -> int
end

type _ handler =
  | Handler : {
      encoding : 'a Data_encoding.t;
      get : 'key -> int -> 'a tzresult Lwt.t;
    }
      -> 'key handler

type _ opt_handler =
  | Opt_handler : {
      encoding : 'a Data_encoding.t;
      get : 'key -> int -> 'a option tzresult Lwt.t;
    }
      -> 'key opt_handler

let rec combine_object = function
  | [] ->
      Handler {encoding = Data_encoding.unit; get = (fun _ _ -> return_unit)}
  | (name, Opt_handler handler) :: fields ->
      let (Handler handlers) = combine_object fields in
      Handler
        {
          encoding =
            Data_encoding.merge_objs
              Data_encoding.(obj1 (opt name (dynamic_size handler.encoding)))
              handlers.encoding;
          get =
            (fun k i ->
              handler.get k i
              >>=? fun v1 -> handlers.get k i >>=? fun v2 -> return (v1, v2));
        }

type query = {depth : int}

let depth_query =
  let open RPC_query in
  query (fun depth -> {depth})
  |+ field "depth" RPC_arg.int 0 (fun t -> t.depth)
  |> seal

let build_directory : type key. key t -> key RPC_directory.t =
 fun dir ->
  let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in
  let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit
      =
   fun path (Opt_handler {encoding; get}) ->
    let service =
      RPC_service.get_service ~query:depth_query ~output:encoding path
    in
    rpc_dir :=
      RPC_directory.register !rpc_dir service (fun k q () ->
          get k (q.depth + 1)
          >>=? function None -> raise Not_found | Some x -> return x)
  in
  let rec build_handler :
      type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler =
   fun dir path ->
    match !dir with
    | Empty ->
        Opt_handler
          {encoding = Data_encoding.unit; get = (fun _ _ -> return_none)}
    | Value {get; encoding} ->
        let handler =
          Opt_handler
            {
              encoding;
              get =
                (fun k i -> if Compare.Int.(i < 0) then return_none else get k);
            }
        in
        register path handler ; handler
    | NamedDir map ->
        let fields = StringMap.bindings map in
        let fields =
          List.map
            (fun (name, dir) ->
              (name, build_handler dir RPC_path.(path / name)))
            fields
        in
        let (Handler handler) = combine_object fields in
        let handler =
          Opt_handler
            {
              encoding = handler.encoding;
              get =
                (fun k i ->
                  if Compare.Int.(i < 0) then return_none
                  else handler.get k (i - 1) >>=? fun v -> return_some v);
            }
        in
        register path handler ; handler
    | IndexedDir {arg; arg_encoding; list; subdir} ->
        let (Opt_handler handler) =
          build_handler subdir RPC_path.(path /: arg)
        in
        let encoding =
          let open Data_encoding in
          union
            [ case
                (Tag 0)
                ~title:"Leaf"
                (dynamic_size arg_encoding)
                (function (key, None) -> Some key | _ -> None)
                (fun key -> (key, None));
              case
                (Tag 1)
                ~title:"Dir"
                (tup2
                   (dynamic_size arg_encoding)
                   (dynamic_size handler.encoding))
                (function (key, Some value) -> Some (key, value) | _ -> None)
                (fun (key, value) -> (key, Some value)) ]
        in
        let get k i =
          if Compare.Int.(i < 0) then return_none
          else if Compare.Int.(i = 0) then return_some []
          else
            list k
            >>=? fun keys ->
            map_s
              (fun key ->
                if Compare.Int.(i = 1) then return (key, None)
                else
                  handler.get (k, key) (i - 1)
                  >>=? fun value -> return (key, value))
              keys
            >>=? fun values -> return_some values
        in
        let handler =
          Opt_handler
            {encoding = Data_encoding.(list (dynamic_size encoding)); get}
        in
        register path handler ; handler
  in
  ignore (build_handler dir RPC_path.open_root : key opt_handler) ;
  !rpc_dir
src/proto_alpha/lib_protocol/storage_description.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Reserved Notation "'t".

Inductive description (key : Type) : Type :=
| Empty : description key
| Value : forall {a : Type},
  (key ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option a))) ->
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  description key
| NamedDir :
  (StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.t) ('t key))
  -> description key
| IndexedDir : forall {a : Type},
  (Tezos_protocol_environment_alpha__Environment.RPC_arg.t a) ->
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (key ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list a))) -> ('t (key * a)) -> description key

where "'t" := (fun (key : Type) =>
  Tezos_protocol_environment_alpha__Environment.Pervasives.ref (description key)).

Definition t := 't.

Arguments Empty {_}.
Arguments Value {_}.
Arguments NamedDir {_}.
Arguments IndexedDir {_}.

Fixpoint register_named_subcontext {r : Type} (dir : t r) (names : list string)
  : t r :=
  match
    ((Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
      dir), names) with
  | (_, []) => dir
  | (Value _, _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "" % string
  | (IndexedDir _, _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "" % string
  | (Empty, cons name names) =>
    let subdir :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.ref Empty in
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq dir
      (NamedDir
        (StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.singleton)
          name subdir));
    register_named_subcontext subdir names
  | (NamedDir map, cons name names) =>
    let subdir :=
      match
        StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.find_opt)
          name map with
      | Some subdir => subdir
      | None =>
        let subdir :=
          Tezos_protocol_environment_alpha__Environment.Pervasives.ref Empty in
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq dir
          (NamedDir
            (StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
              name subdir map));
        subdir
      end in
    register_named_subcontext subdir names
  end.

Inductive args : forall (_ _ _ : Type), Type :=
| One : forall {a key : Type},
  (Tezos_protocol_environment_alpha__Environment.RPC_arg.t a) ->
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (a -> a -> Z) -> args key a (key * a)
| Pair : forall {a b inter_key key sub_key : Type}, (args key a inter_key) ->
  (args inter_key b sub_key) -> args key (a * b) sub_key.

Fixpoint unpack {a b c : Type} (function_parameter : args a b c) : c -> a * b :=
  match function_parameter with
  | One _ => fun x => x
  | Pair l r =>
    let unpack_l := unpack l in
    let unpack_r := unpack r in
    fun x =>
      match unpack_r x with
      | (c, d) =>
        match unpack_l c with
        | (b, a) => (b, (a, d))
        end
      end
  end.

Fixpoint pack {a b c : Type} (function_parameter : args a b c) : a -> b -> c :=
  match function_parameter with
  | One _ => fun b => fun a => (b, a)
  | Pair l r =>
    let pack_l := pack l in
    let pack_r := pack r in
    fun b =>
      fun function_parameter =>
        match function_parameter with
        | (a, d) =>
          let c := pack_l b a in
          pack_r c d
        end
  end.

Fixpoint compare {a b c : Type} (function_parameter : args a b c)
  : b -> b -> Z :=
  match function_parameter with
  | One {| compare := compare |} => compare
  | Pair l r =>
    let compare_l := compare l in
    let compare_r := compare r in
    fun function_parameter =>
      match function_parameter with
      | (a1, b1) =>
        fun function_parameter =>
          match function_parameter with
          | (a2, b2) =>
            match compare_l a1 a2 with
            | 0 => compare_r b1 b2
            | x => x
            end
          end
      end
  end.

Definition destutter {A B : Type} (equal : A -> A -> bool) (l : list (A * B))
  : list A :=
  match l with
  | [] => []
  | cons (i, _) l =>
    let fix loop {C : Type}
      (acc : list A) (i : A) (function_parameter : list (A * C)) : list A :=
      match function_parameter with
      | [] => acc
      | cons (j, _) l =>
        if equal i j then
          loop acc i l
        else
          loop (cons j acc) j l
      end in
    loop (cons i []) i l
  end.

Fixpoint register_indexed_subcontext {a b r : Type}
  (dir : t r)
  (list :
    r ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list a))) (path : args r a b) : t b :=
  match path with
  | Pair left right =>
    let compare_left := compare left in
    let equal_left (x : op_dollar_0) (y : op_dollar_0) : bool :=
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        (compare_left x y) 0 in
    let list_left (r : r)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list op_dollar_0)) :=
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (list r)
        (fun l =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (destutter equal_left l)) in
    let list_right (r : op_dollar_P_a_i_r___'_i_n_t_e_r___k_e_y)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list op_dollar_1)) :=
      match unpack left r with
      | (a, k) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (list a)
          (fun l =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              (Tezos_protocol_environment_alpha__Environment.List.map
                Tezos_protocol_environment_alpha__Environment.Pervasives.snd
                (Tezos_protocol_environment_alpha__Environment.List.filter
                  (fun function_parameter =>
                    match function_parameter with
                    | (x, _) => equal_left x k
                    end) l)))
      end in
    register_indexed_subcontext (register_indexed_subcontext dir list_left left)
      list_right right
  | One {| rpc_arg := arg; encoding := arg_encoding |} =>
    match
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        dir with
    | Value _ =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
        "" % string
    | NamedDir _ =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
        "" % string
    | Empty =>
      let subdir :=
        Tezos_protocol_environment_alpha__Environment.Pervasives.ref Empty in
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq dir
        (IndexedDir
          {| arg := arg; arg_encoding := arg_encoding; list := list;
            subdir := subdir |});
      subdir
    | IndexedDir {| arg := inner_arg; subdir := subdir |} =>
      match
        Tezos_protocol_environment_alpha__Environment.RPC_arg.eq arg inner_arg
        with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
          "" % string
      | Some RPC_arg.Eq => subdir
      end
    end
  end.

Definition register_value {a b : Type}
  (dir : t a)
  (get :
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option b)))
  (encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t b)
  : unit :=
  match
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation dir
    with
  | Empty =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq dir
      (Value {| get := get; encoding := encoding |})
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "" % string
  end.

Definition create {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Pervasives.ref (description A) :=
  match function_parameter with
  | tt => Tezos_protocol_environment_alpha__Environment.Pervasives.ref Empty
  end.

Fixpoint pp {a : Type}
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (dir : t a) : unit :=
  match
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation dir
    with
  | Empty =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "EMPTY" % string
          CamlinternalFormatBasics.End_of_format) "EMPTY" % string)
  | Value _e =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Value" % string
          CamlinternalFormatBasics.End_of_format) "Value" % string)
  | NamedDir map =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v>" % string
                CamlinternalFormatBasics.End_of_format) "<v>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format))) "@[<v>%a@]" % string)
      (Tezos_protocol_environment_alpha__Environment.Format.pp_print_list None
        pp_item)
      (StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
        map)
  | IndexedDir {| arg := arg; subdir := subdir |} =>
    let name :=
      Tezos_protocol_environment_alpha__Environment.Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "<" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ">" % char
                CamlinternalFormatBasics.End_of_format))) "<%s>" % string)
        (name (Tezos_protocol_environment_alpha__Environment.RPC_arg.descr arg))
      in
    pp_item ppf (name, subdir)
  end

with pp_item {a : Type}
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : string * (t a)) : unit :=
  match function_parameter with
  | (name, dir) =>
    Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>%s@ %a@]" % string) name pp dir
  end.

Module INDEX.
  Record signature {t : Type} := {
    t := t;
    path_length : Z;
    to_path : t -> (list string) -> list string;
    of_path : (list string) -> option t;
    rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.t t;
    encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
    compare : t -> t -> Z;
  }.
  Arguments signature : clear implicits.
End INDEX.

Inductive handler : forall (_ : Type), Type :=
| Handler : forall {a key : Type},
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (key ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult a))
  -> handler key.

Inductive opt_handler : forall (_ : Type), Type :=
| Opt_handler : forall {a key : Type},
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (key ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option a))) -> opt_handler key.

Fixpoint combine_object {A : Type}
  (function_parameter : list (string * (opt_handler A))) : handler A :=
  match function_parameter with
  | [] =>
    Handler
      {|
        encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.unit;
        get :=
          fun function_parameter =>
            match function_parameter with
            | _ =>
              fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                end
            end |}
  | cons (name, Opt_handler handler) fields =>
    match combine_object fields with
    | Handler handlers =>
      Handler
        {|
          encoding :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.merge_objs
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj1
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.opt
                  None None name
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                    None (encoding handler)))) (encoding handlers);
          get :=
            fun k =>
              fun i =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  ((get handler) k i)
                  (fun v1 =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      ((get handlers) k i)
                      (fun v2 =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (v1, v2))) |}
    end
  end.

Record query := {
  depth : Z }.

Definition depth_query
  : Tezos_protocol_environment_alpha__Environment.RPC_query.t query :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
    (Tezos_protocol_environment_alpha__Environment.RPC_query.op_pipe_plus
      (Tezos_protocol_environment_alpha__Environment.RPC_query.query
        (fun depth => {| depth := depth |}))
      (Tezos_protocol_environment_alpha__Environment.RPC_query.field None
        "depth" % string
        Tezos_protocol_environment_alpha__Environment.RPC_arg.int 0
        (fun t => depth t)))
    Tezos_protocol_environment_alpha__Environment.RPC_query.seal.

Definition build_directory {key : Type} (dir : t key)
  : Tezos_protocol_environment_alpha__Environment.RPC_directory.t key :=
  let rpc_dir :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.ref
      Tezos_protocol_environment_alpha__Environment.RPC_directory.empty in
  let register {ikey : Type}
    (path : Tezos_protocol_environment_alpha__Environment.RPC_path.t key ikey)
    (function_parameter : opt_handler ikey) : unit :=
    match function_parameter with
    | Opt_handler {| encoding := encoding; get := get |} =>
      let service :=
        Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
          None depth_query encoding path in
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_colon_eq
        rpc_dir
        (Tezos_protocol_environment_alpha__Environment.RPC_directory.register
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
            rpc_dir) service
          (fun k =>
            fun q =>
              fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (get k
                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                        (depth q) 1))
                    (fun function_parameter =>
                      match function_parameter with
                      | None =>
                        Tezos_protocol_environment_alpha__Environment.Pervasives.raise
                          OCaml.Not_found
                      | Some x =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          x
                      end)
                end))
    end in
  let fix build_handler {ikey : Type}
    (dir : t ikey) (path :
    Tezos_protocol_environment_alpha__Environment.RPC_path.t key ikey)
    : opt_handler ikey :=
    match
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
        dir with
    | Empty =>
      Opt_handler
        {|
          encoding :=
            Tezos_protocol_environment_alpha__Environment.Data_encoding.unit;
          get :=
            fun function_parameter =>
              match function_parameter with
              | _ =>
                fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                  end
              end |}
    | Value {| get := get; encoding := encoding |} =>
      let handler :=
        Opt_handler
          {| encoding := encoding;
            get :=
              fun k =>
                fun i =>
                  if
                    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                      i 0 then
                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                  else
                    get k |} in
      register path handler;
      handler
    | NamedDir map =>
      let fields :=
        StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
          map in
      let fields :=
        Tezos_protocol_environment_alpha__Environment.List.map
          (fun function_parameter =>
            match function_parameter with
            | (name, dir) =>
              (name,
                (build_handler dir
                  (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
                    path name)))
            end) fields in
      match combine_object fields with
      | Handler handler =>
        let handler :=
          Opt_handler
            {| encoding := encoding handler;
              get :=
                fun k =>
                  fun i =>
                    if
                      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                        i 0 then
                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                    else
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        ((get handler) k
                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                            i 1))
                        (fun v =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                            v) |} in
        register path handler;
        handler
      end
    |
      IndexedDir {|
        arg := arg;
          arg_encoding := arg_encoding;
          list := list;
          subdir := subdir
          |} =>
      match
        build_handler subdir
          (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div_colon
            path arg) with
      | Opt_handler handler =>
        let encoding :=
          Tezos_protocol_environment_alpha__Environment.Data_encoding.union None
            (cons
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
                "Leaf" % string None (Tag 0)
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                  None arg_encoding)
                (fun function_parameter =>
                  match function_parameter with
                  | (key, None) => Some key
                  | _ => None
                  end) (fun key => (key, None)))
              (cons
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
                  "Dir" % string None (Tag 1)
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.tup2
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                      None arg_encoding)
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                      None (encoding handler)))
                  (fun function_parameter =>
                    match function_parameter with
                    | (key, Some value) => Some (key, value)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    match function_parameter with
                    | (key, value) => (key, (Some value))
                    end)) [])) in
        let get
          (k : ikey) (i :
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
          : Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (option
                (list
                  (op_dollar_I_n_d_e_x_e_d_D_i_r___'_a *
                    (option op_dollar_O_p_t___h_a_n_d_l_e_r___'_a_1))))) :=
          if
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
              i 0 then
            Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
          else
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                i 0 then
              Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                []
            else
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (list k)
                (fun keys =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                      (fun key =>
                        if
                          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                            i 1 then
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (key, None)
                        else
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            ((get handler) (k, key)
                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                i 1))
                            (fun value =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                (key, value))) keys)
                    (fun values =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                        values)) in
        let handler :=
          Opt_handler
            {|
              encoding :=
                Tezos_protocol_environment_alpha__Environment.Data_encoding.list
                  None
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.dynamic_size
                    None encoding); get := get |} in
        register path handler;
        handler
      end
    end in
  Tezos_protocol_environment_alpha__Environment.Pervasives.ignore
    (build_handler dir
      Tezos_protocol_environment_alpha__Environment.RPC_path.open_root);
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_exclamation
    rpc_dir.
src/proto_alpha/lib_protocol/storage_description.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Typed description of the key-value context. *)
type 'key t

(** Trivial display of the key-value context layout. *)
val pp : Format.formatter -> 'key t -> unit

(** Export an RPC hierarchy for querying the context. There is one service
    by possible path in the context. Services for "directory" are able to
    aggregate in one JSON object the whole subtree. *)
val build_directory : 'key t -> 'key RPC_directory.t

(** Create a empty context description,
    keys will be registred by side effects. *)
val create : unit -> 'key t

(** Register a single key accessor at a given path. *)
val register_value :
  'key t ->
  get:('key -> 'a option tzresult Lwt.t) ->
  'a Data_encoding.t ->
  unit

(** Return a description for a prefixed fragment of the given context.
    All keys registred in the subcontext will be shared by the external
    context *)
val register_named_subcontext : 'key t -> string list -> 'key t

(** Description of an index as a sequence of `RPC_arg.t`. *)
type (_, _, _) args =
  | One : {
      rpc_arg : 'a RPC_arg.t;
      encoding : 'a Data_encoding.t;
      compare : 'a -> 'a -> int;
    }
      -> ('key, 'a, 'key * 'a) args
  | Pair :
      ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args
      -> ('key, 'a * 'b, 'sub_key) args

(** Return a description for a indexed sub-context.
    All keys registred in the subcontext will be shared by the external
    context. One should provide a function to list all the registred
    index in the context. *)
val register_indexed_subcontext :
  'key t ->
  list:('key -> 'arg list tzresult Lwt.t) ->
  ('key, 'arg, 'sub_key) args ->
  'sub_key t

(** Helpers for manipulating and defining indexes. *)

val pack : ('key, 'a, 'sub_key) args -> 'key -> 'a -> 'sub_key

val unpack : ('key, 'a, 'sub_key) args -> 'sub_key -> 'key * 'a

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  val rpc_arg : t RPC_arg.t

  val encoding : t Data_encoding.t

  val compare : t -> t -> int
end
src/proto_alpha/lib_protocol/storage_description.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : forall (key : Type), Type.

Parameter pp : forall {key : Type},
Tezos_protocol_environment_alpha__Environment.Format.formatter ->
  (t key) -> unit.

Parameter build_directory : forall {key : Type},
(t key) -> Tezos_protocol_environment_alpha__Environment.RPC_directory.t key.

Parameter create : forall {key : Type}, unit -> t key.

Parameter register_value : forall {a key : Type},
(t key) ->
  (key ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option a))) ->
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) -> unit.

Parameter register_named_subcontext : forall {key : Type},
(t key) -> (list string) -> t key.

Inductive args : forall (_ _ _ : Type), Type :=
| One : forall {a key : Type},
  (Tezos_protocol_environment_alpha__Environment.RPC_arg.t a) ->
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (a -> a -> Z) -> args key a (key * a)
| Pair : forall {a b inter_key key sub_key : Type}, (args key a inter_key) ->
  (args inter_key b sub_key) -> args key (a * b) sub_key.

Parameter register_indexed_subcontext : forall {arg key sub_key : Type},
(t key) ->
  (key ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list arg))) -> (args key arg sub_key) -> t sub_key.

Parameter pack : forall {a key sub_key : Type},
(args key a sub_key) -> key -> a -> sub_key.

Parameter unpack : forall {a key sub_key : Type},
(args key a sub_key) -> sub_key -> key * a.

module_type
src/proto_alpha/lib_protocol/storage_functors.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Storage_sigs

module Registered = struct
  let ghost = false
end

module Ghost = struct
  let ghost = true
end

module Make_encoder (V : VALUE) = struct
  let of_bytes ~key b =
    match Data_encoding.Binary.of_bytes V.encoding b with
    | None ->
        error (Raw_context.Storage_error (Corrupted_data key))
    | Some v ->
        Ok v

  let to_bytes v =
    match Data_encoding.Binary.to_bytes V.encoding v with
    | Some b ->
        b
    | None ->
        MBytes.create 0
end

let len_name = "len"

let data_name = "data"

let encode_len_value bytes =
  let length = MBytes.length bytes in
  Data_encoding.(Binary.to_bytes_exn int31) length

let decode_len_value key len =
  match Data_encoding.(Binary.of_bytes int31) len with
  | None ->
      fail (Raw_context.Storage_error (Corrupted_data key))
  | Some len ->
      return len

let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k)

module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) :
  Raw_context.T with type t = C.t = struct
  type t = C.t

  type context = t

  let name_length = List.length N.name

  let to_key k = N.name @ k

  let of_key k = Misc.remove_elem_from_list name_length k

  let mem t k = C.mem t (to_key k)

  let dir_mem t k = C.dir_mem t (to_key k)

  let get t k = C.get t (to_key k)

  let get_option t k = C.get_option t (to_key k)

  let init t k v = C.init t (to_key k) v

  let set t k v = C.set t (to_key k) v

  let init_set t k v = C.init_set t (to_key k) v

  let set_option t k v = C.set_option t (to_key k) v

  let delete t k = C.delete t (to_key k)

  let remove t k = C.remove t (to_key k)

  let remove_rec t k = C.remove_rec t (to_key k)

  let copy t ~from ~to_ = C.copy t ~from:(to_key from) ~to_:(to_key to_)

  let fold t k ~init ~f =
    C.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

  let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys

  let fold_keys t k ~init ~f =
    C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc)

  let project = C.project

  let absolute_key c k = C.absolute_key c (to_key k)

  let consume_gas = C.consume_gas

  let check_enough_gas = C.check_enough_gas

  let description =
    let description =
      if R.ghost then Storage_description.create () else C.description
    in
    Storage_description.register_named_subcontext description N.name
end

module Make_single_data_storage
    (R : REGISTER)
    (C : Raw_context.T)
    (N : NAME)
    (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t =
struct
  type t = C.t

  type context = t

  type value = V.t

  let mem t = C.mem t N.name

  include Make_encoder (V)

  let get t =
    C.get t N.name
    >>=? fun b ->
    let key = C.absolute_key t N.name in
    Lwt.return (of_bytes ~key b)

  let get_option t =
    C.get_option t N.name
    >>= function
    | None ->
        return_none
    | Some b -> (
        let key = C.absolute_key t N.name in
        match of_bytes ~key b with
        | Ok v ->
            return_some v
        | Error _ as err ->
            Lwt.return err )

  let init t v =
    C.init t N.name (to_bytes v) >>=? fun t -> return (C.project t)

  let set t v = C.set t N.name (to_bytes v) >>=? fun t -> return (C.project t)

  let init_set t v =
    C.init_set t N.name (to_bytes v) >>= fun t -> Lwt.return (C.project t)

  let set_option t v =
    C.set_option t N.name (Option.map ~f:to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let remove t = C.remove t N.name >>= fun t -> Lwt.return (C.project t)

  let delete t = C.delete t N.name >>=? fun t -> return (C.project t)

  let () =
    let open Storage_description in
    let description =
      if R.ghost then Storage_description.create () else C.description
    in
    register_value
      ~get:get_option
      (register_named_subcontext description N.name)
      V.encoding
end

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  type 'a ipath

  val args : ('a, t, 'a ipath) Storage_description.args
end

module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t =
struct
  type t = I1.t * I2.t

  let path_length = I1.path_length + I2.path_length

  let to_path (x, y) l = I1.to_path x (I2.to_path y l)

  let of_path l =
    match Misc.take I1.path_length l with
    | None ->
        None
    | Some (l1, l2) -> (
      match (I1.of_path l1, I2.of_path l2) with
      | (Some x, Some y) ->
          Some (x, y)
      | _ ->
          None )

  type 'a ipath = 'a I1.ipath I2.ipath

  let args = Storage_description.Pair (I1.args, I2.args)
end

module Make_data_set_storage (C : Raw_context.T) (I : INDEX) :
  Data_set_storage with type t = C.t and type elt = I.t = struct
  type t = C.t

  type context = t

  type elt = I.t

  let inited = MBytes.of_string "inited"

  let mem s i = C.mem s (I.to_path i [])

  let add s i =
    C.init_set s (I.to_path i []) inited >>= fun t -> Lwt.return (C.project t)

  let del s i =
    C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t)

  let set s i = function true -> add s i | false -> del s i

  let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t)

  let fold s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 1) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match I.of_path file with
              | None ->
                  assert false
              | Some p ->
                  f p acc ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value (* TODO fixme 'elements...' *)
      ~get:(fun c ->
        let (c, k) = unpack c in
        mem c k >>= function true -> return_some true | false -> return_none)
      (register_indexed_subcontext
         ~list:(fun c -> elements c >>= return)
         C.description
         I.args)
      Data_encoding.bool
end

module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) :
  Indexed_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t = struct
  type t = C.t

  type context = t

  type key = I.t

  type value = V.t

  include Make_encoder (V)

  let mem s i = C.mem s (I.to_path i [])

  let get s i =
    C.get s (I.to_path i [])
    >>=? fun b ->
    let key = C.absolute_key s (I.to_path i []) in
    Lwt.return (of_bytes ~key b)

  let get_option s i =
    C.get_option s (I.to_path i [])
    >>= function
    | None ->
        return_none
    | Some b -> (
        let key = C.absolute_key s (I.to_path i []) in
        match of_bytes ~key b with
        | Ok v ->
            return_some v
        | Error _ as err ->
            Lwt.return err )

  let set s i v =
    C.set s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t)

  let init s i v =
    C.init s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t)

  let init_set s i v =
    C.init_set s (I.to_path i []) (to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let set_option s i v =
    C.set_option s (I.to_path i []) (Option.map ~f:to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let remove s i =
    C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t)

  let delete s i =
    C.delete s (I.to_path i []) >>=? fun t -> return (C.project t)

  let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t)

  let fold_keys s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 1) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match I.of_path file with
              | None ->
                  assert false
              | Some path ->
                  f path acc ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let fold s ~init ~f =
    let f path acc =
      get s path
      >>= function
      | Error _ ->
          (* FIXME: silently ignore unparsable data *)
          Lwt.return acc
      | Ok v ->
          f path v acc
    in
    fold_keys s ~init ~f

  let bindings s =
    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

  let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value
      ~get:(fun c ->
        let (c, k) = unpack c in
        get_option c k)
      (register_indexed_subcontext
         ~list:(fun c -> keys c >>= return)
         C.description
         I.args)
      V.encoding
end

module Make_indexed_carbonated_data_storage
    (C : Raw_context.T)
    (I : INDEX)
    (V : VALUE) :
  Non_iterable_indexed_carbonated_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t = struct
  type t = C.t

  type context = t

  type key = I.t

  type value = V.t

  include Make_encoder (V)

  let data_key i = I.to_path i [data_name]

  let len_key i = I.to_path i [len_name]

  let consume_mem_gas c =
    Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))

  let existing_size c i =
    C.get_option c (len_key i)
    >>= function
    | None ->
        return (0, false)
    | Some len ->
        decode_len_value (len_key i) len >>=? fun len -> return (len, true)

  let consume_read_gas get c i =
    get c (len_key i)
    >>=? fun len ->
    decode_len_value (len_key i) len
    >>=? fun len ->
    Lwt.return
      (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len)))

  let consume_serialize_write_gas set c i v =
    let bytes = to_bytes v in
    let len = MBytes.length bytes in
    Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len))
    >>=? fun c ->
    Lwt.return
      (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len)))
    >>=? fun c ->
    set c (len_key i) (encode_len_value bytes) >>=? fun c -> return (c, bytes)

  let consume_remove_gas del c i =
    Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero))
    >>=? fun c -> del c (len_key i)

  let mem s i =
    consume_mem_gas s
    >>=? fun s ->
    C.mem s (data_key i) >>= fun exists -> return (C.project s, exists)

  let get s i =
    consume_read_gas C.get s i
    >>=? fun s ->
    C.get s (data_key i)
    >>=? fun b ->
    let key = C.absolute_key s (data_key i) in
    Lwt.return (of_bytes ~key b) >>=? fun v -> return (C.project s, v)

  let get_option s i =
    consume_mem_gas s
    >>=? fun s ->
    C.mem s (data_key i)
    >>= fun exists ->
    if exists then get s i >>=? fun (s, v) -> return (s, Some v)
    else return (C.project s, None)

  let set s i v =
    existing_size s i
    >>=? fun (prev_size, _) ->
    consume_serialize_write_gas C.set s i v
    >>=? fun (s, bytes) ->
    C.set s (data_key i) bytes
    >>=? fun t ->
    let size_diff = MBytes.length bytes - prev_size in
    return (C.project t, size_diff)

  let init s i v =
    consume_serialize_write_gas C.init s i v
    >>=? fun (s, bytes) ->
    C.init s (data_key i) bytes
    >>=? fun t ->
    let size = MBytes.length bytes in
    return (C.project t, size)

  let init_set s i v =
    let init_set s i v = C.init_set s i v >>= return in
    existing_size s i
    >>=? fun (prev_size, existed) ->
    consume_serialize_write_gas init_set s i v
    >>=? fun (s, bytes) ->
    init_set s (data_key i) bytes
    >>=? fun t ->
    let size_diff = MBytes.length bytes - prev_size in
    return (C.project t, size_diff, existed)

  let remove s i =
    let remove s i = C.remove s i >>= return in
    existing_size s i
    >>=? fun (prev_size, existed) ->
    consume_remove_gas remove s i
    >>=? fun s ->
    remove s (data_key i) >>=? fun t -> return (C.project t, prev_size, existed)

  let delete s i =
    existing_size s i
    >>=? fun (prev_size, _) ->
    consume_remove_gas C.delete s i
    >>=? fun s ->
    C.delete s (data_key i) >>=? fun t -> return (C.project t, prev_size)

  let set_option s i v =
    match v with None -> remove s i | Some v -> init_set s i v

  let fold_keys_unaccounted s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 0) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match List.rev file with
              | last :: _ when Compare.String.(last = len_name) ->
                  Lwt.return acc
              | last :: rest when Compare.String.(last = data_name) -> (
                  let file = List.rev rest in
                  match I.of_path file with
                  | None ->
                      assert false
                  | Some path ->
                      f path acc )
              | _ ->
                  assert false ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let keys_unaccounted s =
    fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value (* TODO export consumed gas ?? *)
      ~get:(fun c ->
        let (c, k) = unpack c in
        get_option c k >>=? fun (_, v) -> return v)
      (register_indexed_subcontext
         ~list:(fun c -> keys_unaccounted c >>= return)
         C.description
         I.args)
      V.encoding
end

module Make_indexed_data_snapshotable_storage
    (C : Raw_context.T)
    (Snapshot_index : INDEX)
    (I : INDEX)
    (V : VALUE) :
  Indexed_data_snapshotable_storage
    with type t = C.t
     and type snapshot = Snapshot_index.t
     and type key = I.t
     and type value = V.t = struct
  type snapshot = Snapshot_index.t

  let data_name = ["current"]

  let snapshot_name = ["snapshot"]

  module C_data =
    Make_subcontext (Registered) (C)
      (struct
        let name = data_name
      end)

  module C_snapshot =
    Make_subcontext (Registered) (C)
      (struct
        let name = snapshot_name
      end)

  include Make_indexed_data_storage (C_data) (I) (V)
  module Snapshot =
    Make_indexed_data_storage (C_snapshot) (Pair (Snapshot_index) (I)) (V)

  let snapshot_path id = snapshot_name @ Snapshot_index.to_path id []

  let snapshot_exists s id = C.dir_mem s (snapshot_path id)

  let snapshot s id =
    C.copy s ~from:data_name ~to_:(snapshot_path id)
    >>=? fun t -> return (C.project t)

  let delete_snapshot s id =
    C.remove_rec s (snapshot_path id) >>= fun t -> Lwt.return (C.project t)
end

module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :
  Indexed_raw_context
    with type t = C.t
     and type key = I.t
     and type 'a ipath = 'a I.ipath = struct
  type t = C.t

  type context = t

  type key = I.t

  type 'a ipath = 'a I.ipath

  let clear t = C.remove_rec t [] >>= fun t -> Lwt.return (C.project t)

  let fold_keys t ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 0) then
        match I.of_path path with
        | None ->
            assert false
        | Some path ->
            f path acc
      else
        C.fold t path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let keys t = fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))

  let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

  let remove_rec t k = C.remove_rec t (I.to_path k [])

  let copy t ~from ~to_ =
    C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ [])

  let description =
    Storage_description.register_indexed_subcontext
      ~list:(fun c -> keys c >>= return)
      C.description
      I.args

  let unpack = Storage_description.unpack I.args

  let pack = Storage_description.pack I.args

  module Raw_context = struct
    type t = C.t I.ipath

    type context = t

    let to_key i k = I.to_path i k

    let of_key k = Misc.remove_elem_from_list I.path_length k

    let mem c k =
      let (t, i) = unpack c in
      C.mem t (to_key i k)

    let dir_mem c k =
      let (t, i) = unpack c in
      C.dir_mem t (to_key i k)

    let get c k =
      let (t, i) = unpack c in
      C.get t (to_key i k)

    let get_option c k =
      let (t, i) = unpack c in
      C.get_option t (to_key i k)

    let init c k v =
      let (t, i) = unpack c in
      C.init t (to_key i k) v >>=? fun t -> return (pack t i)

    let set c k v =
      let (t, i) = unpack c in
      C.set t (to_key i k) v >>=? fun t -> return (pack t i)

    let init_set c k v =
      let (t, i) = unpack c in
      C.init_set t (to_key i k) v >>= fun t -> Lwt.return (pack t i)

    let set_option c k v =
      let (t, i) = unpack c in
      C.set_option t (to_key i k) v >>= fun t -> Lwt.return (pack t i)

    let delete c k =
      let (t, i) = unpack c in
      C.delete t (to_key i k) >>=? fun t -> return (pack t i)

    let remove c k =
      let (t, i) = unpack c in
      C.remove t (to_key i k) >>= fun t -> Lwt.return (pack t i)

    let remove_rec c k =
      let (t, i) = unpack c in
      C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (pack t i)

    let copy c ~from ~to_ =
      let (t, i) = unpack c in
      C.copy t ~from:(to_key i from) ~to_:(to_key i to_)
      >>=? fun t -> return (pack t i)

    let fold c k ~init ~f =
      let (t, i) = unpack c in
      C.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

    let keys c k =
      let (t, i) = unpack c in
      C.keys t (to_key i k) >|= fun keys -> List.map of_key keys

    let fold_keys c k ~init ~f =
      let (t, i) = unpack c in
      C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)

    let project c =
      let (t, _) = unpack c in
      C.project t

    let absolute_key c k =
      let (t, i) = unpack c in
      C.absolute_key t (to_key i k)

    let consume_gas c g =
      let (t, i) = unpack c in
      C.consume_gas t g >>? fun t -> ok (pack t i)

    let check_enough_gas c g =
      let (t, _i) = unpack c in
      C.check_enough_gas t g

    let description = description
  end

  let resolve t prefix =
    let rec loop i prefix = function
      | [] when Compare.Int.(i = I.path_length) -> (
        match I.of_path prefix with
        | None ->
            assert false
        | Some path ->
            Lwt.return [path] )
      | [] ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix [])
            prefixes
          >|= List.flatten
      | [d] when Compare.Int.(i = I.path_length - 1) ->
          if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function
              | `Key prefix | `Dir prefix -> (
                match
                  Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix))
                with
                | None ->
                    Lwt.return_nil
                | Some _ ->
                    loop (i + 1) prefix [] ))
            prefixes
          >|= List.flatten
      | "" :: ds ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds)
            prefixes
          >|= List.flatten
      | d :: ds -> (
          if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
          C.dir_mem t (prefix @ [d])
          >>= function
          | true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil )
    in
    loop 0 [] prefix

  module Make_set (R : REGISTER) (N : NAME) = struct
    type t = C.t

    type context = t

    type elt = I.t

    let inited = MBytes.of_string "inited"

    let mem s i = Raw_context.mem (pack s i) N.name

    let add s i =
      Raw_context.init_set (pack s i) N.name inited
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let del s i =
      Raw_context.remove (pack s i) N.name
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let set s i = function true -> add s i | false -> del s i

    let clear s =
      fold_keys s ~init:s ~f:(fun i s ->
          Raw_context.remove (pack s i) N.name
          >>= fun c ->
          let (s, _) = unpack c in
          Lwt.return s)
      >>= fun t -> Lwt.return (C.project t)

    let fold s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          mem s i >>= function true -> f i acc | false -> Lwt.return acc)

    let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      let description =
        if R.ghost then Storage_description.create ()
        else Raw_context.description
      in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          mem c k
          >>= function true -> return_some true | false -> return_none)
        (register_named_subcontext description N.name)
        Data_encoding.bool
  end

  module Make_map (N : NAME) (V : VALUE) = struct
    type t = C.t

    type context = t

    type key = I.t

    type value = V.t

    include Make_encoder (V)

    let mem s i = Raw_context.mem (pack s i) N.name

    let get s i =
      Raw_context.get (pack s i) N.name
      >>=? fun b ->
      let key = Raw_context.absolute_key (pack s i) N.name in
      Lwt.return (of_bytes ~key b)

    let get_option s i =
      Raw_context.get_option (pack s i) N.name
      >>= function
      | None ->
          return_none
      | Some b -> (
          let key = Raw_context.absolute_key (pack s i) N.name in
          match of_bytes ~key b with
          | Ok v ->
              return_some v
          | Error _ as err ->
              Lwt.return err )

    let set s i v =
      Raw_context.set (pack s i) N.name (to_bytes v)
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let init s i v =
      Raw_context.init (pack s i) N.name (to_bytes v)
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let init_set s i v =
      Raw_context.init_set (pack s i) N.name (to_bytes v)
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let set_option s i v =
      Raw_context.set_option (pack s i) N.name (Option.map ~f:to_bytes v)
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let remove s i =
      Raw_context.remove (pack s i) N.name
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let delete s i =
      Raw_context.delete (pack s i) N.name
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let clear s =
      fold_keys s ~init:s ~f:(fun i s ->
          Raw_context.remove (pack s i) N.name
          >>= fun c ->
          let (s, _) = unpack c in
          Lwt.return s)
      >>= fun t -> Lwt.return (C.project t)

    let fold s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          get s i >>= function Error _ -> Lwt.return acc | Ok v -> f i v acc)

    let bindings s =
      fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

    let fold_keys s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          mem s i >>= function false -> Lwt.return acc | true -> f i acc)

    let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          get_option c k)
        (register_named_subcontext Raw_context.description N.name)
        V.encoding
  end

  module Make_carbonated_map (N : NAME) (V : VALUE) = struct
    type t = C.t

    type context = t

    type key = I.t

    type value = V.t

    include Make_encoder (V)

    let len_name = len_name :: N.name

    let data_name = data_name :: N.name

    let consume_mem_gas c =
      Lwt.return
        (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))

    let existing_size c =
      Raw_context.get_option c len_name
      >>= function
      | None ->
          return (0, false)
      | Some len ->
          decode_len_value len_name len >>=? fun len -> return (len, true)

    let consume_read_gas get c =
      get c len_name
      >>=? fun len ->
      decode_len_value len_name len
      >>=? fun len ->
      Lwt.return
        (Raw_context.consume_gas
           c
           (Gas_limit_repr.read_bytes_cost (Z.of_int len)))

    let consume_write_gas set c v =
      let bytes = to_bytes v in
      let len = MBytes.length bytes in
      Lwt.return
        (Raw_context.consume_gas
           c
           (Gas_limit_repr.write_bytes_cost (Z.of_int len)))
      >>=? fun c ->
      set c len_name (encode_len_value bytes) >>=? fun c -> return (c, bytes)

    let consume_remove_gas del c =
      Lwt.return
        (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero))
      >>=? fun c -> del c len_name

    let mem s i =
      consume_mem_gas (pack s i)
      >>=? fun c ->
      Raw_context.mem c data_name
      >>= fun res -> return (Raw_context.project c, res)

    let get s i =
      consume_read_gas Raw_context.get (pack s i)
      >>=? fun c ->
      Raw_context.get c data_name
      >>=? fun b ->
      let key = Raw_context.absolute_key c data_name in
      Lwt.return (of_bytes ~key b)
      >>=? fun v -> return (Raw_context.project c, v)

    let get_option s i =
      consume_mem_gas (pack s i)
      >>=? fun c ->
      let (s, _) = unpack c in
      Raw_context.mem (pack s i) data_name
      >>= fun exists ->
      if exists then get s i >>=? fun (s, v) -> return (s, Some v)
      else return (C.project s, None)

    let set s i v =
      existing_size (pack s i)
      >>=? fun (prev_size, _) ->
      consume_write_gas Raw_context.set (pack s i) v
      >>=? fun (c, bytes) ->
      Raw_context.set c data_name bytes
      >>=? fun c ->
      let size_diff = MBytes.length bytes - prev_size in
      return (Raw_context.project c, size_diff)

    let init s i v =
      consume_write_gas Raw_context.init (pack s i) v
      >>=? fun (c, bytes) ->
      Raw_context.init c data_name bytes
      >>=? fun c ->
      let size = MBytes.length bytes in
      return (Raw_context.project c, size)

    let init_set s i v =
      let init_set c k v = Raw_context.init_set c k v >>= return in
      existing_size (pack s i)
      >>=? fun (prev_size, existed) ->
      consume_write_gas init_set (pack s i) v
      >>=? fun (c, bytes) ->
      init_set c data_name bytes
      >>=? fun c ->
      let size_diff = MBytes.length bytes - prev_size in
      return (Raw_context.project c, size_diff, existed)

    let remove s i =
      let remove c k = Raw_context.remove c k >>= return in
      existing_size (pack s i)
      >>=? fun (prev_size, existed) ->
      consume_remove_gas remove (pack s i)
      >>=? fun c ->
      remove c data_name
      >>=? fun c -> return (Raw_context.project c, prev_size, existed)

    let delete s i =
      existing_size (pack s i)
      >>=? fun (prev_size, _) ->
      consume_remove_gas Raw_context.delete (pack s i)
      >>=? fun c ->
      Raw_context.delete c data_name
      >>=? fun c -> return (Raw_context.project c, prev_size)

    let set_option s i v =
      match v with None -> remove s i | Some v -> init_set s i v

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          get_option c k >>=? fun (_, v) -> return v)
        (register_named_subcontext Raw_context.description N.name)
        V.encoding
  end
end

module Wrap_indexed_data_storage
    (C : Indexed_data_storage) (K : sig
      type t

      val wrap : t -> C.key

      val unwrap : C.key -> t option
    end) =
struct
  type t = C.t

  type context = C.t

  type key = K.t

  type value = C.value

  let mem ctxt k = C.mem ctxt (K.wrap k)

  let get ctxt k = C.get ctxt (K.wrap k)

  let get_option ctxt k = C.get_option ctxt (K.wrap k)

  let set ctxt k v = C.set ctxt (K.wrap k) v

  let init ctxt k v = C.init ctxt (K.wrap k) v

  let init_set ctxt k v = C.init_set ctxt (K.wrap k) v

  let set_option ctxt k v = C.set_option ctxt (K.wrap k) v

  let delete ctxt k = C.delete ctxt (K.wrap k)

  let remove ctxt k = C.remove ctxt (K.wrap k)

  let clear ctxt = C.clear ctxt

  let fold ctxt ~init ~f =
    C.fold ctxt ~init ~f:(fun k v acc ->
        match K.unwrap k with None -> Lwt.return acc | Some k -> f k v acc)

  let bindings s =
    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

  let fold_keys s ~init ~f =
    C.fold_keys s ~init ~f:(fun k acc ->
        match K.unwrap k with None -> Lwt.return acc | Some k -> f k acc)

  let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
end
src/proto_alpha/lib_protocol/storage_functors.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Storage_sigs.

Module Registered.
  Definition ghost : bool := false.
End Registered.

Module Ghost.
  Definition ghost : bool := true.
End Ghost.

Definition len_name : string := "len" % string.

Definition data_name : string := "data" % string.

Definition encode_len_value
  (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  let length :=
    Tezos_protocol_environment_alpha__Environment.MBytes.length string in
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.to_bytes_exn
    Tezos_protocol_environment_alpha__Environment.Data_encoding.int31) length.

Definition decode_len_value
  (key : list string)
  (len : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  match
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.Binary.of_bytes
      Tezos_protocol_environment_alpha__Environment.Data_encoding.int31) len
    with
  | None =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.fail
      (Raw_context.Storage_error (Corrupted_data key))
  | Some len =>
    Tezos_protocol_environment_alpha__Environment.Error_monad._return len
  end.

Definition map_key {A B : Type} (f : A -> B) (function_parameter : variant)
  : variant :=
  match function_parameter with
  | Key k => variant
  | Dir k => variant
  end.

Module INDEX.
  Record signature {t ipath : Type} := {
    t := t;
    path_length : Z;
    to_path : t -> (list string) -> list string;
    of_path : (list string) -> option t;
    polymorphic_abstract_type;
    args : forall {a : Type}, Tezos_raw_protocol_alpha.Storage_description.args
      a t (ipath a);
  }.
  Arguments signature : clear implicits.
End INDEX.
src/proto_alpha/lib_protocol/storage_functors.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Typed storage builders. *)

open Storage_sigs

module Registered : REGISTER

module Ghost : REGISTER

module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) :
  Raw_context.T with type t = C.t

module Make_single_data_storage
    (R : REGISTER)
    (C : Raw_context.T)
    (N : NAME)
    (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  type 'a ipath

  val args : ('a, t, 'a ipath) Storage_description.args
end

module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t

module Make_data_set_storage (C : Raw_context.T) (I : INDEX) :
  Data_set_storage with type t = C.t and type elt = I.t

module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) :
  Indexed_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t

module Make_indexed_carbonated_data_storage
    (C : Raw_context.T)
    (I : INDEX)
    (V : VALUE) :
  Non_iterable_indexed_carbonated_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t

module Make_indexed_data_snapshotable_storage
    (C : Raw_context.T)
    (Snapshot : INDEX)
    (I : INDEX)
    (V : VALUE) :
  Indexed_data_snapshotable_storage
    with type t = C.t
     and type snapshot = Snapshot.t
     and type key = I.t
     and type value = V.t

module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :
  Indexed_raw_context
    with type t = C.t
     and type key = I.t
     and type 'a ipath = 'a I.ipath

module Wrap_indexed_data_storage
    (C : Indexed_data_storage) (K : sig
      type t

      val wrap : t -> C.key

      val unwrap : C.key -> t option
    end) :
  Indexed_data_storage
    with type t = C.t
     and type key = K.t
     and type value = C.value
src/proto_alpha/lib_protocol/storage_functors.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

unhandled_module

unhandled_module

unhandled_module

unhandled_module

module_type

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module

unhandled_module
src/proto_alpha/lib_protocol/storage_sigs.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {1 Entity Accessor Signatures} *)

(** The generic signature of a single data accessor (a single value
    bound to a specific key in the hierarchical (key x value)
    database). *)
module type Single_data_storage = sig
  type t

  type context = t

  (** The type of the value *)
  type value

  (** Tells if the data is already defined *)
  val mem : context -> bool Lwt.t

  (** Retrieve the value from the storage bucket ; returns a
      {!Storage_error} if the key is not set or if the deserialisation
      fails *)
  val get : context -> value tzresult Lwt.t

  (** Retrieves the value from the storage bucket ; returns [None] if
      the data is not initialized, or {!Storage_helpers.Storage_error}
      if the deserialisation fails *)
  val get_option : context -> value option tzresult Lwt.t

  (** Allocates the storage bucket and initializes it ; returns a
      {!Storage_error Existing_key} if the bucket exists *)
  val init : context -> value -> Raw_context.t tzresult Lwt.t

  (** Updates the content of the bucket ; returns a {!Storage_Error
      Missing_key} if the value does not exists *)
  val set : context -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates the data and initializes it with a value ; just
      updates it if the bucket exists *)
  val init_set : context -> value -> Raw_context.t Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists. *)
  val set_option : context -> value option -> Raw_context.t Lwt.t

  (** Delete the storage bucket ; returns a {!Storage_error
      Missing_key} if the bucket does not exists *)
  val delete : context -> Raw_context.t tzresult Lwt.t

  (** Removes the storage bucket and its contents ; does nothing if
      the bucket does not exists *)
  val remove : context -> Raw_context.t Lwt.t
end

(** Variant of {!Single_data_storage} with gas accounting. *)
module type Single_carbonated_data_storage = sig
  type t

  type context = t

  (** The type of the value *)
  type value

  (** Tells if the data is already defined.
      Consumes [Gas_repr.read_bytes_cost Z.zero]. *)
  val mem : context -> (Raw_context.t * bool) tzresult Lwt.t

  (** Retrieve the value from the storage bucket ; returns a
      {!Storage_error} if the key is not set or if the deserialisation
      fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)
  val get : context -> (Raw_context.t * value) tzresult Lwt.t

  (** Retrieves the value from the storage bucket ; returns [None] if
      the data is not initialized, or {!Storage_helpers.Storage_error}
      if the deserialisation fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>] if present
      or [Gas_repr.read_bytes_cost Z.zero]. *)
  val get_option : context -> (Raw_context.t * value option) tzresult Lwt.t

  (** Allocates the storage bucket and initializes it ; returns a
      {!Storage_error Missing_key} if the bucket exists.
      Consumes [Gas_repr.write_bytes_cost <size of the value>].
      Returns the size. *)
  val init : context -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Updates the content of the bucket ; returns a {!Storage_Error
      Existing_key} if the value does not exists.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old to the new size. *)
  val set : context -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates the data and initializes it with a value ; just
      updates it if the bucket exists.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val init_set :
    context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists.
      Consumes the same gas cost as either {!remove} or {!init_set}.
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val set_option :
    context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** Delete the storage bucket ; returns a {!Storage_error
      Missing_key} if the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size. *)
  val delete : context -> (Raw_context.t * int) tzresult Lwt.t

  (** Removes the storage bucket and its contents ; does nothing if
      the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size, and a boolean
      indicating if a value was already associated to this key. *)
  val remove : context -> (Raw_context.t * int * bool) tzresult Lwt.t
end

(** Restricted version of {!Indexed_data_storage} w/o iterators. *)
module type Non_iterable_indexed_data_storage = sig
  type t

  type context = t

  (** An abstract type for keys *)
  type key

  (** The type of values *)
  type value

  (** Tells if a given key is already bound to a storage bucket *)
  val mem : context -> key -> bool Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns {!Storage_error Missing_key} if the key is not set ;
      returns {!Storage_error Corrupted_data} if the deserialisation
      fails. *)
  val get : context -> key -> value tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns [None] if the value is not set ; returns {!Storage_error
      Corrupted_data} if the deserialisation fails. *)
  val get_option : context -> key -> value option tzresult Lwt.t

  (** Updates the content of a bucket ; returns A {!Storage_Error
      Missing_key} if the value does not exists. *)
  val set : context -> key -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it ;
      returns a {!Storage_error Existing_key} if the bucket exists. *)
  val init : context -> key -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it
      with a value ; just updates it if the bucket exists. *)
  val init_set : context -> key -> value -> Raw_context.t Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists. *)
  val set_option : context -> key -> value option -> Raw_context.t Lwt.t

  (** Delete a storage bucket and its contents ; returns a
      {!Storage_error Missing_key} if the bucket does not exists. *)
  val delete : context -> key -> Raw_context.t tzresult Lwt.t

  (** Removes a storage bucket and its contents ; does nothing if the
      bucket does not exists. *)
  val remove : context -> key -> Raw_context.t Lwt.t
end

(** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *)
module type Non_iterable_indexed_carbonated_data_storage = sig
  type t

  type context = t

  (** An abstract type for keys *)
  type key

  (** The type of values *)
  type value

  (** Tells if a given key is already bound to a storage bucket.
      Consumes [Gas_repr.read_bytes_cost Z.zero]. *)
  val mem : context -> key -> (Raw_context.t * bool) tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns {!Storage_error Missing_key} if the key is not set ;
      returns {!Storage_error Corrupted_data} if the deserialisation
      fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)
  val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns [None] if the value is not set ; returns {!Storage_error
      Corrupted_data} if the deserialisation fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>] if present
      or [Gas_repr.read_bytes_cost Z.zero]. *)
  val get_option :
    context -> key -> (Raw_context.t * value option) tzresult Lwt.t

  (** Updates the content of a bucket ; returns A {!Storage_Error
      Missing_key} if the value does not exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old to the new size. *)
  val set : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it ;
      returns a {!Storage_error Existing_key} if the bucket exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the value>].
      Returns the size. *)
  val init : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it
      with a value ; just updates it if the bucket exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val init_set :
    context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists.
      Consumes serialization cost.
      Consumes the same gas cost as either {!remove} or {!init_set}.
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val set_option :
    context ->
    key ->
    value option ->
    (Raw_context.t * int * bool) tzresult Lwt.t

  (** Delete a storage bucket and its contents ; returns a
      {!Storage_error Missing_key} if the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size. *)
  val delete : context -> key -> (Raw_context.t * int) tzresult Lwt.t

  (** Removes a storage bucket and its contents ; does nothing if the
      bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size, and a boolean
      indicating if a value was already associated to this key. *)
  val remove : context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t
end

(** The generic signature of indexed data accessors (a set of values
    of the same type indexed by keys of the same form in the
    hierarchical (key x value) database). *)
module type Indexed_data_storage = sig
  include Non_iterable_indexed_data_storage

  (** Empties all the keys and associated data. *)
  val clear : context -> Raw_context.t Lwt.t

  (** Lists all the keys. *)
  val keys : context -> key list Lwt.t

  (** Lists all the keys and associated data. *)
  val bindings : context -> (key * value) list Lwt.t

  (** Iterates over all the keys and associated data. *)
  val fold :
    context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  (** Iterate over all the keys. *)
  val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type Indexed_data_snapshotable_storage = sig
  type snapshot

  type key

  include Indexed_data_storage with type key := key

  module Snapshot :
    Indexed_data_storage
      with type key = snapshot * key
       and type value = value
       and type t = t

  val snapshot_exists : context -> snapshot -> bool Lwt.t

  val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t

  val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t
end

(** The generic signature of a data set accessor (a set of values
    bound to a specific key prefix in the hierarchical (key x value)
    database). *)
module type Data_set_storage = sig
  type t

  type context = t

  (** The type of elements. *)
  type elt

  (** Tells if a elt is a member of the set *)
  val mem : context -> elt -> bool Lwt.t

  (** Adds a elt is a member of the set *)
  val add : context -> elt -> Raw_context.t Lwt.t

  (** Removes a elt of the set ; does nothing if not a member *)
  val del : context -> elt -> Raw_context.t Lwt.t

  (** Adds/Removes a elt of the set *)
  val set : context -> elt -> bool -> Raw_context.t Lwt.t

  (** Returns the elements of the set, deserialized in a list in no
      particular order. *)
  val elements : context -> elt list Lwt.t

  (** Iterates over the elements of the set. *)
  val fold : context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  (** Removes all elements in the set *)
  val clear : context -> Raw_context.t Lwt.t
end

module type NAME = sig
  val name : Raw_context.key
end

module type VALUE = sig
  type t

  val encoding : t Data_encoding.t
end

module type REGISTER = sig
  val ghost : bool
end

module type Indexed_raw_context = sig
  type t

  type context = t

  type key

  type 'a ipath

  val clear : context -> Raw_context.t Lwt.t

  val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val keys : context -> key list Lwt.t

  val resolve : context -> string list -> key list Lwt.t

  val remove_rec : context -> key -> context Lwt.t

  val copy : context -> from:key -> to_:key -> context tzresult Lwt.t

  module Make_set (R : REGISTER) (N : NAME) :
    Data_set_storage with type t = t and type elt = key

  module Make_map (N : NAME) (V : VALUE) :
    Indexed_data_storage
      with type t = t
       and type key = key
       and type value = V.t

  module Make_carbonated_map (N : NAME) (V : VALUE) :
    Non_iterable_indexed_carbonated_data_storage
      with type t = t
       and type key = key
       and type value = V.t

  module Raw_context : Raw_context.T with type t = t ipath
end
src/proto_alpha/lib_protocol/storage_sigs.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Single_data_storage.
  Record signature {t value : Type} := {
    t := t;
    context := t;
    value := value;
    mem : context -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    get : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          value);
    get_option : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option value));
    init : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t);
    set : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t);
    init_set : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
    set_option : context ->
      (option value) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
    delete : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t);
    remove : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Single_data_storage.

Module Single_carbonated_data_storage.
  Record signature {t value : Type} := {
    t := t;
    context := t;
    value := value;
    mem : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * bool));
    get : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * value));
    get_option : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * (option value)));
    init : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    set : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    init_set : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
    set_option : context ->
      (option value) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
    delete : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    remove : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
  }.
  Arguments signature : clear implicits.
End Single_carbonated_data_storage.

Module Non_iterable_indexed_data_storage.
  Record signature {t key value : Type} := {
    t := t;
    context := t;
    key := key;
    value := value;
    mem : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    get : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            value);
    get_option : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (option value));
    set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              Tezos_raw_protocol_alpha.Raw_context.t);
    init : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              Tezos_raw_protocol_alpha.Raw_context.t);
    init_set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            Tezos_raw_protocol_alpha.Raw_context.t;
    set_option : context ->
      key ->
        (option value) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            Tezos_raw_protocol_alpha.Raw_context.t;
    delete : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t);
    remove : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Non_iterable_indexed_data_storage.

Module Non_iterable_indexed_carbonated_data_storage.
  Record signature {t key value : Type} := {
    t := t;
    context := t;
    key := key;
    value := value;
    mem : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * bool));
    get : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * value));
    get_option : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * (option value)));
    set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    init : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    init_set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
    set_option : context ->
      key ->
        (option value) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
    delete : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    remove : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
  }.
  Arguments signature : clear implicits.
End Non_iterable_indexed_carbonated_data_storage.

Module Indexed_data_storage.
  Record signature {t key value : Type} := {
    include;
    clear : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t;
    keys : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
    bindings : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t (list (key * value));
    fold : forall {a : Type}, context ->
      a ->
        (key ->
          value -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a)
          -> Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    fold_keys : forall {a : Type}, context ->
      a ->
        (key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t a;
  }.
  Arguments signature : clear implicits.
End Indexed_data_storage.

Module Indexed_data_snapshotable_storage.
  Record signature {snapshot key t value : Type} := {
    snapshot := snapshot;
    key := key;
    include;
    Snapshot : Indexed_data_storage.signature t (snapshot * key) value;
    snapshot_exists : context ->
      snapshot -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    snapshot : context ->
      snapshot ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t);
    delete_snapshot : context ->
      snapshot ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Indexed_data_snapshotable_storage.

Module Data_set_storage.
  Record signature {t elt : Type} := {
    t := t;
    context := t;
    elt := elt;
    mem : context ->
      elt -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    add : context ->
      elt ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
    del : context ->
      elt ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
    set : context ->
      elt ->
        bool ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            Tezos_raw_protocol_alpha.Raw_context.t;
    elements : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t (list elt);
    fold : forall {a : Type}, context ->
      a ->
        (elt -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    clear : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Data_set_storage.

Module NAME.
  Record signature := {
    name : Tezos_raw_protocol_alpha.Raw_context.key;
  }.
End NAME.

Module VALUE.
  Record signature {t : Type} := {
    t := t;
    encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End VALUE.

Module REGISTER.
  Record signature := {
    ghost : bool;
  }.
End REGISTER.

Module Indexed_raw_context.
  Record signature {t key ipath : Type} := {
    t := t;
    context := t;
    key := key;
    polymorphic_abstract_type;
    clear : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t;
    fold_keys : forall {a : Type}, context ->
      a ->
        (key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    keys : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
    resolve : context ->
      (list string) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
    remove_rec : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    copy : context ->
      key ->
        key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context);
    Make_set : functor;
    Make_map : functor;
    Make_carbonated_map : functor;
    Raw_context : Raw_context.T.signature (ipath t);
  }.
  Arguments signature : clear implicits.
End Indexed_raw_context.
src/proto_alpha/lib_protocol/test/activation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The activation operation creates an implicit contract from a
    registered commitment present in the context. It is parametrized by
    a public key hash (pkh) and a secret.

    The commitments are composed of :
    - a blinded pkh that can be revealed by the secret ;
    - an amount.

    The commitments and the secrets are generated from
    /scripts/create_genesis/create_genenis.py and should be coherent.
*)

open Protocol
open Alpha_context
open Test_utils
open Test_tez

(* Generated commitments and secrets  *)

(* Commitments are hard-coded in {Tezos_proto_alpha_parameters.Default_parameters} *)

(* let commitments =
 *   List.map (fun (bpkh, a) ->
 *       Commitment_repr.{
 *         blinded_public_key_hash=Blinded_public_key_hash.of_b58check_exn bpkh ;
 *         amount = Tez_repr.of_mutez_exn (Int64.of_string a)}
 *     )
 *     [ ( "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ) ;
 *       ( "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ) ;
 *       ( "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428349" ) ;
 *       ( "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ) ;
 *       ( "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ) ;
 *       ( "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ) ;
 *       ( "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ) ;
 *       ( "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ) ;
 *       ( "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ) ;
 *       ( "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ) ;
 *     ] *)

type secret_account = {
  account : public_key_hash;
  activation_code : Blinded_public_key_hash.activation_code;
  amount : Tez.t;
}

let secrets () =
  (* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *)
  let read_key mnemonic email password =
    match Bip39.of_words mnemonic with
    | None ->
        assert false
    | Some t ->
        (* TODO: unicode normalization (NFKD)... *)
        let passphrase =
          Bigstring.(concat "" [of_string email; of_string password])
        in
        let sk = Bip39.to_seed ~passphrase t in
        let sk = Bigstring.sub_bytes sk 0 32 in
        let sk : Signature.Secret_key.t =
          Ed25519
            (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
        in
        let pk = Signature.Secret_key.to_public_key sk in
        let pkh = Signature.Public_key.hash pk in
        (pkh, pk, sk)
  in
  List.map
    (fun (mnemonic, secret, amount, pkh, password, email) ->
      let (pkh', pk, sk) = read_key mnemonic email password in
      let pkh = Signature.Public_key_hash.of_b58check_exn pkh in
      assert (Signature.Public_key_hash.equal pkh pkh') ;
      let account = Account.{pkh; pk; sk} in
      Account.add_account account ;
      {
        account = account.pkh;
        activation_code = Blinded_public_key_hash.activation_code_of_hex secret;
        amount =
          Option.unopt_exn
            (Invalid_argument "tez conversion")
            (Tez.of_mutez (Int64.of_string amount));
      })
    [ ( [ "envelope";
          "hospital";
          "mind";
          "sunset";
          "cancel";
          "muscle";
          "leisure";
          "thumb";
          "wine";
          "market";
          "exit";
          "lucky";
          "style";
          "picnic";
          "success" ],
        "0f39ed0b656509c2ecec4771712d9cddefe2afac",
        "23932454669343",
        "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF",
        "z0eZHQQGKt",
        "cjgfoqmk.wpxnvnup@tezos.example.org" );
      ( [ "flag";
          "quote";
          "will";
          "valley";
          "mouse";
          "chat";
          "hold";
          "prosper";
          "silk";
          "tent";
          "cruel";
          "cause";
          "demise";
          "bottom";
          "practice" ],
        "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4",
        "72954577464032",
        "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX",
        "MHErskWPE6",
        "oklmcktr.ztljnpzc@tezos.example.org" );
      ( [ "library";
          "away";
          "inside";
          "paper";
          "wise";
          "focus";
          "sweet";
          "expose";
          "require";
          "change";
          "stove";
          "planet";
          "zone";
          "reflect";
          "finger" ],
        "411dfef031eeecc506de71c9df9f8e44297cf5ba",
        "217487035428348",
        "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc",
        "0AO6BzQNfN",
        "ctgnkvqm.kvtiybky@tezos.example.org" );
      ( [ "cruel";
          "fluid";
          "damage";
          "demand";
          "mimic";
          "above";
          "village";
          "alpha";
          "vendor";
          "staff";
          "absent";
          "uniform";
          "fire";
          "asthma";
          "milk" ],
        "08d7d355bc3391d12d140780b39717d9f46fcf87",
        "4092742372031",
        "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS",
        "9kbZ7fR6im",
        "bnyxxzqr.tdszcvqb@tezos.example.org" );
      ( [ "opera";
          "divorce";
          "easy";
          "myself";
          "idea";
          "aim";
          "dash";
          "scout";
          "case";
          "resource";
          "vote";
          "humor";
          "ticket";
          "client";
          "edge" ],
        "9b7cad042fba557618bdc4b62837c5f125b50e56",
        "17590039016550",
        "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM",
        "suxT5H09yY",
        "iilkhohu.otnyuvna@tezos.example.org" );
      ( [ "token";
          "similar";
          "ginger";
          "tongue";
          "gun";
          "sort";
          "piano";
          "month";
          "hotel";
          "vote";
          "undo";
          "success";
          "hobby";
          "shell";
          "cart" ],
        "124c0ca217f11ffc6c7b76a743d867c8932e5afd",
        "26322312350555",
        "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU",
        "4odVdLykaa",
        "kwhlglvr.slriitzy@tezos.example.org" );
      ( [ "shield";
          "warrior";
          "gorilla";
          "birth";
          "steak";
          "neither";
          "feel";
          "only";
          "liberty";
          "float";
          "oven";
          "extend";
          "pulse";
          "suffer";
          "vapor" ],
        "ac7a2125beea68caf5266a647f24dce9fea018a7",
        "244951387881443",
        "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur",
        "A6yeMqBFG8",
        "lvrmlbyj.yczltcxn@tezos.example.org" );
      ( [ "waste";
          "open";
          "scan";
          "tip";
          "subway";
          "dance";
          "rent";
          "copper";
          "garlic";
          "laundry";
          "defense";
          "clerk";
          "another";
          "staff";
          "liar" ],
        "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2",
        "80065050465525",
        "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs",
        "oVZqpq60sk",
        "rfodmrha.zzdndvyk@tezos.example.org" );
      ( [ "fiber";
          "next";
          "property";
          "cradle";
          "silk";
          "obey";
          "gossip";
          "push";
          "key";
          "second";
          "across";
          "minimum";
          "nice";
          "boil";
          "age" ],
        "dac31640199f2babc157aadc0021cd71128ca9ea",
        "3569618927693",
        "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX",
        "FfytQTTVbu",
        "owecikdy.gxnyttya@tezos.example.org" );
      ( [ "print";
          "labor";
          "budget";
          "speak";
          "poem";
          "diet";
          "chunk";
          "eternal";
          "book";
          "saddle";
          "pioneer";
          "ankle";
          "happy";
          "only";
          "exclude" ],
        "bb841227f250a066eb8429e56937ad504d7b34dd",
        "9034781424478",
        "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u",
        "zknAl3lrX2",
        "ettilrvh.zsrqrbud@tezos.example.org" ) ]

let activation_init () =
  Context.init ~with_commitments:true 1
  >>=? fun (b, cs) -> secrets () |> fun ss -> return (b, cs, ss)

let simple_init_with_commitments () =
  activation_init ()
  >>=? fun (blk, _contracts, _secrets) ->
  Block.bake blk >>=? fun _ -> return_unit

(** A single activation *)
let single_activation () =
  activation_init ()
  >>=? fun (blk, _contracts, secrets) ->
  let ({account; activation_code; amount = expected_amount; _} as _first_one) =
    List.hd secrets
  in
  (* Contract does not exist *)
  Assert.balance_is
    ~loc:__LOC__
    (B blk)
    (Contract.implicit_contract account)
    Tez.zero
  >>=? fun () ->
  Op.activation (B blk) account activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>=? fun blk ->
  (* Contract does exist *)
  Assert.balance_is
    ~loc:__LOC__
    (B blk)
    (Contract.implicit_contract account)
    expected_amount

(** 10 activations, one per bake *)
let multi_activation_1 () =
  activation_init ()
  >>=? fun (blk, _contracts, secrets) ->
  Error_monad.fold_left_s
    (fun blk {account; activation_code; amount = expected_amount; _} ->
      Op.activation (B blk) account activation_code
      >>=? fun operation ->
      Block.bake ~operation blk
      >>=? fun blk ->
      Assert.balance_is
        ~loc:__LOC__
        (B blk)
        (Contract.implicit_contract account)
        expected_amount
      >>=? fun () -> return blk)
    blk
    secrets
  >>=? fun _ -> return_unit

(** All in one bake *)
let multi_activation_2 () =
  activation_init ()
  >>=? fun (blk, _contracts, secrets) ->
  Error_monad.fold_left_s
    (fun ops {account; activation_code; _} ->
      Op.activation (B blk) account activation_code
      >>=? fun op -> return (op :: ops))
    []
    secrets
  >>=? fun ops ->
  Block.bake ~operations:ops blk
  >>=? fun blk ->
  Error_monad.iter_s
    (fun {account; amount = expected_amount; _} ->
      (* Contract does exist *)
      Assert.balance_is
        ~loc:__LOC__
        (B blk)
        (Contract.implicit_contract account)
        expected_amount)
    secrets

(** Transfer with activated account *)
let activation_and_transfer () =
  activation_init ()
  >>=? fun (blk, contracts, secrets) ->
  let ({account; activation_code; _} as _first_one) = List.hd secrets in
  let bootstrap_contract = List.hd contracts in
  let first_contract = Contract.implicit_contract account in
  Op.activation (B blk) account activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>=? fun blk ->
  Context.Contract.balance (B blk) bootstrap_contract
  >>=? fun amount ->
  Tez.( /? ) amount 2L
  >>?= fun half_amount ->
  Context.Contract.balance (B blk) first_contract
  >>=? fun activated_amount_before ->
  Op.transaction (B blk) bootstrap_contract first_contract half_amount
  >>=? fun operation ->
  Block.bake ~operation blk
  >>=? fun blk ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B blk)
    (Contract.implicit_contract account)
    activated_amount_before
    half_amount

(** Transfer to an unactivated account and then activating it *)
let transfer_to_unactivated_then_activate () =
  activation_init ()
  >>=? fun (blk, contracts, secrets) ->
  let ({account; activation_code; amount} as _first_one) = List.hd secrets in
  let bootstrap_contract = List.hd contracts in
  let unactivated_commitment_contract = Contract.implicit_contract account in
  Context.Contract.balance (B blk) bootstrap_contract
  >>=? fun b_amount ->
  Tez.( /? ) b_amount 2L
  >>?= fun b_half_amount ->
  Incremental.begin_construction blk
  >>=? fun inc ->
  Op.transaction
    (I inc)
    bootstrap_contract
    unactivated_commitment_contract
    b_half_amount
  >>=? fun op ->
  Incremental.add_operation inc op
  >>=? fun inc ->
  Op.activation (I inc) account activation_code
  >>=? fun op' ->
  Incremental.add_operation inc op'
  >>=? fun inc ->
  Incremental.finalize_block inc
  >>=? fun blk2 ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B blk2)
    (Contract.implicit_contract account)
    amount
    b_half_amount

(****************************************************************)
(*  The following test scenarios are supposed to raise errors.  *)
(****************************************************************)

(** Invalid pkh activation : expected to fail as the context does not
    contain any commitment *)
let invalid_activation_with_no_commitments () =
  Context.init 1
  >>=? fun (blk, _) ->
  let secrets = secrets () in
  let ({account; activation_code; _} as _first_one) = List.hd secrets in
  Op.activation (B blk) account activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_activation _ ->
          true
      | _ ->
          false)

(** Wrong activation : wrong secret given in the operation *)
let invalid_activation_wrong_secret () =
  activation_init ()
  >>=? fun (blk, _, secrets) ->
  let ({account; _} as _first_one) = List.nth secrets 0 in
  let ({activation_code; _} as _second_one) = List.nth secrets 1 in
  Op.activation (B blk) account activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_activation _ ->
          true
      | _ ->
          false)

(** Invalid pkh activation : expected to fail as the context does not
    contain an associated commitment *)
let invalid_activation_inexistent_pkh () =
  activation_init ()
  >>=? fun (blk, _, secrets) ->
  let ({activation_code; _} as _first_one) = List.hd secrets in
  let inexistent_pkh =
    Signature.Public_key_hash.of_b58check_exn
      "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o"
  in
  Op.activation (B blk) inexistent_pkh activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_activation _ ->
          true
      | _ ->
          false)

(** Invalid pkh activation : expected to fail as the commitment has
    already been claimed *)
let invalid_double_activation () =
  activation_init ()
  >>=? fun (blk, _, secrets) ->
  let ({account; activation_code; _} as _first_one) = List.hd secrets in
  Incremental.begin_construction blk
  >>=? fun inc ->
  Op.activation (I inc) account activation_code
  >>=? fun op ->
  Incremental.add_operation inc op
  >>=? fun inc ->
  Op.activation (I inc) account activation_code
  >>=? fun op' ->
  Incremental.add_operation inc op'
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_activation _ ->
          true
      | _ ->
          false)

(** Transfer from an unactivated commitment account *)
let invalid_transfer_from_unactived_account () =
  activation_init ()
  >>=? fun (blk, contracts, secrets) ->
  let ({account; _} as _first_one) = List.hd secrets in
  let bootstrap_contract = List.hd contracts in
  let unactivated_commitment_contract = Contract.implicit_contract account in
  (* No activation *)
  Op.transaction
    (B blk)
    unactivated_commitment_contract
    bootstrap_contract
    Tez.one
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Contract_storage.Empty_implicit_contract pkh ->
          if pkh = account then true else false
      | _ ->
          false)

let tests =
  [ Test.tztest "init with commitments" `Quick simple_init_with_commitments;
    Test.tztest "single activation" `Quick single_activation;
    Test.tztest "multi-activation one-by-one" `Quick multi_activation_1;
    Test.tztest "multi-activation all at a time" `Quick multi_activation_2;
    Test.tztest "activation and transfer" `Quick activation_and_transfer;
    Test.tztest
      "transfer to unactivated account then activate"
      `Quick
      transfer_to_unactivated_then_activate;
    Test.tztest
      "invalid activation with no commitments"
      `Quick
      invalid_activation_with_no_commitments;
    Test.tztest
      "invalid activation with commitments"
      `Quick
      invalid_activation_inexistent_pkh;
    Test.tztest "invalid double activation" `Quick invalid_double_activation;
    Test.tztest "wrong activation code" `Quick invalid_activation_wrong_secret;
    Test.tztest
      "invalid transfer from unactivated account"
      `Quick
      invalid_transfer_from_unactived_account ]
src/proto_alpha/lib_protocol/test/activation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Record secret_account := {
  account : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
  activation_code :
    Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code;
  amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t }.

Definition secrets (function_parameter : unit) : list secret_account :=
  match function_parameter with
  | tt =>
    let read_key {A : Type}
      (mnemonic : list string) (email : string) (password : string)
      : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * A * Stdlib.Bytes.t :=
      match op_star_t_y_p_e_minus_e_r_r_o_r_star mnemonic with
      | None => false
      | Some t =>
        let passphrase :=
          Bigstring.concat "" % string
            (cons (Bigstring.of_string email)
              (cons (Bigstring.of_string password) [])) in
        let sk := op_star_t_y_p_e_minus_e_r_r_o_r_star passphrase t in
        let sk := Bigstring.sub_bytes sk 0 32 in
        match op_star_t_y_p_e_minus_e_r_r_o_r_star with
        | _ =>
          let pk := op_star_t_y_p_e_minus_e_r_r_o_r_star sk in
          let pkh :=
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
              pk in
          (pkh, pk, sk)
        end
      end in
    Tezos_protocol_environment_alpha__Environment.List.map
      (fun function_parameter =>
        match function_parameter with
        | (mnemonic, secret, amount, pkh, password, email) =>
          match read_key mnemonic email password with
          | (pkh', pk, sk) =>
            let pkh :=
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.of_b58check_exn
                pkh in
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
              pkh pkh';
            let account := op_star_t_y_p_e_minus_e_r_r_o_r_star in
            op_star_t_y_p_e_minus_e_r_r_o_r_star account;
            {| account := pkh account;
              activation_code :=
                Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code_of_hex
                  secret;
              amount :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (OCaml.Invalid_argument "tez conversion" % string)
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez
                    (Tezos_protocol_environment_alpha__Environment.Int64.of_string
                      amount)) |}
          end
        end)
      (cons
        ((cons "envelope" % string
          (cons "hospital" % string
            (cons "mind" % string
              (cons "sunset" % string
                (cons "cancel" % string
                  (cons "muscle" % string
                    (cons "leisure" % string
                      (cons "thumb" % string
                        (cons "wine" % string
                          (cons "market" % string
                            (cons "exit" % string
                              (cons "lucky" % string
                                (cons "style" % string
                                  (cons "picnic" % string
                                    (cons "success" % string []))))))))))))))),
          "0f39ed0b656509c2ecec4771712d9cddefe2afac" % string,
          "23932454669343" % string,
          "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF" % string,
          "z0eZHQQGKt" % string, "cjgfoqmk.wpxnvnup@tezos.example.org" % string)
        (cons
          ((cons "flag" % string
            (cons "quote" % string
              (cons "will" % string
                (cons "valley" % string
                  (cons "mouse" % string
                    (cons "chat" % string
                      (cons "hold" % string
                        (cons "prosper" % string
                          (cons "silk" % string
                            (cons "tent" % string
                              (cons "cruel" % string
                                (cons "cause" % string
                                  (cons "demise" % string
                                    (cons "bottom" % string
                                      (cons "practice" % string []))))))))))))))),
            "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4" % string,
            "72954577464032" % string,
            "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX" % string,
            "MHErskWPE6" % string,
            "oklmcktr.ztljnpzc@tezos.example.org" % string)
          (cons
            ((cons "library" % string
              (cons "away" % string
                (cons "inside" % string
                  (cons "paper" % string
                    (cons "wise" % string
                      (cons "focus" % string
                        (cons "sweet" % string
                          (cons "expose" % string
                            (cons "require" % string
                              (cons "change" % string
                                (cons "stove" % string
                                  (cons "planet" % string
                                    (cons "zone" % string
                                      (cons "reflect" % string
                                        (cons "finger" % string []))))))))))))))),
              "411dfef031eeecc506de71c9df9f8e44297cf5ba" % string,
              "217487035428348" % string,
              "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc" % string,
              "0AO6BzQNfN" % string,
              "ctgnkvqm.kvtiybky@tezos.example.org" % string)
            (cons
              ((cons "cruel" % string
                (cons "fluid" % string
                  (cons "damage" % string
                    (cons "demand" % string
                      (cons "mimic" % string
                        (cons "above" % string
                          (cons "village" % string
                            (cons "alpha" % string
                              (cons "vendor" % string
                                (cons "staff" % string
                                  (cons "absent" % string
                                    (cons "uniform" % string
                                      (cons "fire" % string
                                        (cons "asthma" % string
                                          (cons "milk" % string []))))))))))))))),
                "08d7d355bc3391d12d140780b39717d9f46fcf87" % string,
                "4092742372031" % string,
                "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS" % string,
                "9kbZ7fR6im" % string,
                "bnyxxzqr.tdszcvqb@tezos.example.org" % string)
              (cons
                ((cons "opera" % string
                  (cons "divorce" % string
                    (cons "easy" % string
                      (cons "myself" % string
                        (cons "idea" % string
                          (cons "aim" % string
                            (cons "dash" % string
                              (cons "scout" % string
                                (cons "case" % string
                                  (cons "resource" % string
                                    (cons "vote" % string
                                      (cons "humor" % string
                                        (cons "ticket" % string
                                          (cons "client" % string
                                            (cons "edge" % string []))))))))))))))),
                  "9b7cad042fba557618bdc4b62837c5f125b50e56" % string,
                  "17590039016550" % string,
                  "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM" % string,
                  "suxT5H09yY" % string,
                  "iilkhohu.otnyuvna@tezos.example.org" % string)
                (cons
                  ((cons "token" % string
                    (cons "similar" % string
                      (cons "ginger" % string
                        (cons "tongue" % string
                          (cons "gun" % string
                            (cons "sort" % string
                              (cons "piano" % string
                                (cons "month" % string
                                  (cons "hotel" % string
                                    (cons "vote" % string
                                      (cons "undo" % string
                                        (cons "success" % string
                                          (cons "hobby" % string
                                            (cons "shell" % string
                                              (cons "cart" % string []))))))))))))))),
                    "124c0ca217f11ffc6c7b76a743d867c8932e5afd" % string,
                    "26322312350555" % string,
                    "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU" % string,
                    "4odVdLykaa" % string,
                    "kwhlglvr.slriitzy@tezos.example.org" % string)
                  (cons
                    ((cons "shield" % string
                      (cons "warrior" % string
                        (cons "gorilla" % string
                          (cons "birth" % string
                            (cons "steak" % string
                              (cons "neither" % string
                                (cons "feel" % string
                                  (cons "only" % string
                                    (cons "liberty" % string
                                      (cons "float" % string
                                        (cons "oven" % string
                                          (cons "extend" % string
                                            (cons "pulse" % string
                                              (cons "suffer" % string
                                                (cons "vapor" % string []))))))))))))))),
                      "ac7a2125beea68caf5266a647f24dce9fea018a7" % string,
                      "244951387881443" % string,
                      "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur" % string,
                      "A6yeMqBFG8" % string,
                      "lvrmlbyj.yczltcxn@tezos.example.org" % string)
                    (cons
                      ((cons "waste" % string
                        (cons "open" % string
                          (cons "scan" % string
                            (cons "tip" % string
                              (cons "subway" % string
                                (cons "dance" % string
                                  (cons "rent" % string
                                    (cons "copper" % string
                                      (cons "garlic" % string
                                        (cons "laundry" % string
                                          (cons "defense" % string
                                            (cons "clerk" % string
                                              (cons "another" % string
                                                (cons "staff" % string
                                                  (cons "liar" % string []))))))))))))))),
                        "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2" % string,
                        "80065050465525" % string,
                        "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs" % string,
                        "oVZqpq60sk" % string,
                        "rfodmrha.zzdndvyk@tezos.example.org" % string)
                      (cons
                        ((cons "fiber" % string
                          (cons "next" % string
                            (cons "property" % string
                              (cons "cradle" % string
                                (cons "silk" % string
                                  (cons "obey" % string
                                    (cons "gossip" % string
                                      (cons "push" % string
                                        (cons "key" % string
                                          (cons "second" % string
                                            (cons "across" % string
                                              (cons "minimum" % string
                                                (cons "nice" % string
                                                  (cons "boil" % string
                                                    (cons "age" % string []))))))))))))))),
                          "dac31640199f2babc157aadc0021cd71128ca9ea" % string,
                          "3569618927693" % string,
                          "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX" % string,
                          "FfytQTTVbu" % string,
                          "owecikdy.gxnyttya@tezos.example.org" % string)
                        (cons
                          ((cons "print" % string
                            (cons "labor" % string
                              (cons "budget" % string
                                (cons "speak" % string
                                  (cons "poem" % string
                                    (cons "diet" % string
                                      (cons "chunk" % string
                                        (cons "eternal" % string
                                          (cons "book" % string
                                            (cons "saddle" % string
                                              (cons "pioneer" % string
                                                (cons "ankle" % string
                                                  (cons "happy" % string
                                                    (cons "only" % string
                                                      (cons "exclude" % string
                                                        []))))))))))))))),
                            "bb841227f250a066eb8429e56937ad504d7b34dd" % string,
                            "9034781424478" % string,
                            "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u" % string,
                            "zknAl3lrX2" % string,
                            "ettilrvh.zsrqrbud@tezos.example.org" % string) []))))))))))
  end.

Definition activation_init {A B : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A * B * (list secret_account))) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star true 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, cs) =>
          Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
            (secrets tt)
            (fun ss =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (b, cs, ss))
        end)
  end.

Definition simple_init_with_commitments (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, _contracts, _secrets) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star blk)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
              end)
        end)
  end.

Definition single_activation {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, _contracts, secrets) =>
          match Tezos_protocol_environment_alpha__Environment.List.hd secrets
            with
          |
            {|
              account := account;
                activation_code := activation_code;
                amount := expected_amount
                |} as _first_one =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  account) Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star account
                      activation_code)
                    (fun operation =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk)
                        (fun blk =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                              account) expected_amount))
                end)
          end
        end)
  end.

Definition multi_activation_1 (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, _contracts, secrets) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
              (fun blk =>
                fun function_parameter =>
                  match function_parameter with
                  | {|
                    account := account;
                      activation_code := activation_code;
                      amount := expected_amount
                      |} =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star account
                        activation_code)
                      (fun operation =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk)
                          (fun blk =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                  account) expected_amount)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                    blk
                                end)))
                  end) blk secrets)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
              end)
        end)
  end.

Definition multi_activation_2 (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, _contracts, secrets) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
              (fun ops =>
                fun function_parameter =>
                  match function_parameter with
                  | {| account := account; activation_code := activation_code |}
                    =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star account
                        activation_code)
                      (fun op =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (cons op ops))
                  end) [] secrets)
            (fun ops =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star ops blk)
                (fun blk =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.iter_s
                    (fun function_parameter =>
                      match function_parameter with
                      | {| account := account; amount := expected_amount |} =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                            account) expected_amount
                      end) secrets))
        end)
  end.

Definition activation_and_transfer {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, contracts, secrets) =>
          match Tezos_protocol_environment_alpha__Environment.List.hd secrets
            with
          |
            {| account := account; activation_code := activation_code |} as
              _first_one =>
            let bootstrap_contract :=
              Tezos_protocol_environment_alpha__Environment.List.hd contracts in
            let first_contract :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                account in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star account activation_code)
              (fun operation =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk)
                  (fun blk =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap_contract)
                      (fun amount =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_div_question
                            amount 2)
                          (fun half_amount =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                first_contract)
                              (fun activated_amount_before =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    bootstrap_contract first_contract
                                    half_amount)
                                  (fun operation =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        operation blk)
                                      (fun blk =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                            account) activated_amount_before
                                          half_amount)))))))
          end
        end)
  end.

Definition transfer_to_unactivated_then_activate {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, contracts, secrets) =>
          match Tezos_protocol_environment_alpha__Environment.List.hd secrets
            with
          |
            {|
              account := account;
                activation_code := activation_code;
                amount := amount
                |} as _first_one =>
            let bootstrap_contract :=
              Tezos_protocol_environment_alpha__Environment.List.hd contracts in
            let unactivated_commitment_contract :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                account in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap_contract)
              (fun b_amount =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_div_question
                    b_amount 2)
                  (fun b_half_amount =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star blk)
                      (fun inc =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            bootstrap_contract unactivated_commitment_contract
                            b_half_amount)
                          (fun op =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star inc op)
                              (fun inc =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star account
                                    activation_code)
                                  (fun op' =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star inc
                                        op')
                                      (fun inc =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            inc)
                                          (fun blk2 =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                account) amount b_half_amount))))))))
          end
        end)
  end.

Definition invalid_activation_with_no_commitments {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (blk, _) =>
          let secrets := secrets tt in
          match Tezos_protocol_environment_alpha__Environment.List.hd secrets
            with
          |
            {| account := account; activation_code := activation_code |} as
              _first_one =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star account activation_code)
              (fun operation =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk)
                  (fun res =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      res
                      (fun function_parameter =>
                        match function_parameter with
                        | Apply.Invalid_activation _ => true
                        | _ => false
                        end)))
          end
        end)
  end.

Definition invalid_activation_wrong_secret {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, _, secrets) =>
          match op_star_t_y_p_e_minus_e_r_r_o_r_star secrets 0 with
          | {| account := account |} as _first_one =>
            match op_star_t_y_p_e_minus_e_r_r_o_r_star secrets 1 with
            | {| activation_code := activation_code |} as _second_one =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star account activation_code)
                (fun operation =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk)
                    (fun res =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                        res
                        (fun function_parameter =>
                          match function_parameter with
                          | Apply.Invalid_activation _ => true
                          | _ => false
                          end)))
            end
          end
        end)
  end.

Definition invalid_activation_inexistent_pkh {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, _, secrets) =>
          match Tezos_protocol_environment_alpha__Environment.List.hd secrets
            with
          | {| activation_code := activation_code |} as _first_one =>
            let inexistent_pkh :=
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.of_b58check_exn
                "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" % string in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star inexistent_pkh
                activation_code)
              (fun operation =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk)
                  (fun res =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      res
                      (fun function_parameter =>
                        match function_parameter with
                        | Apply.Invalid_activation _ => true
                        | _ => false
                        end)))
          end
        end)
  end.

Definition invalid_double_activation {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, _, secrets) =>
          match Tezos_protocol_environment_alpha__Environment.List.hd secrets
            with
          |
            {| account := account; activation_code := activation_code |} as
              _first_one =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star blk)
              (fun inc =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star account activation_code)
                  (fun op =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star inc op)
                      (fun inc =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star account
                            activation_code)
                          (fun op' =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star inc op')
                              (fun res =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  res
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Apply.Invalid_activation _ => true
                                    | _ => false
                                    end))))))
          end
        end)
  end.

Definition invalid_transfer_from_unactived_account {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (activation_init tt)
      (fun function_parameter =>
        match function_parameter with
        | (blk, contracts, secrets) =>
          match Tezos_protocol_environment_alpha__Environment.List.hd secrets
            with
          | {| account := account |} as _first_one =>
            let bootstrap_contract :=
              Tezos_protocol_environment_alpha__Environment.List.hd contracts in
            let unactivated_commitment_contract :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                account in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                unactivated_commitment_contract bootstrap_contract
                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
              (fun operation =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk)
                  (fun res =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      res
                      (fun function_parameter =>
                        match function_parameter with
                        | Contract_storage.Empty_implicit_contract pkh =>
                          if op_star_t_y_p_e_minus_e_r_r_o_r_star pkh account
                            then
                            true
                          else
                            false
                        | _ => false
                        end)))
          end
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "init with commitments" % string
      variant simple_init_with_commitments)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star "single activation" % string variant
        single_activation)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "multi-activation one-by-one" % string variant multi_activation_1)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "multi-activation all at a time" % string variant multi_activation_2)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              "activation and transfer" % string variant activation_and_transfer)
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "transfer to unactivated account then activate" % string variant
                transfer_to_unactivated_then_activate)
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "invalid activation with no commitments" % string variant
                  invalid_activation_with_no_commitments)
                (cons
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "invalid activation with commitments" % string variant
                    invalid_activation_inexistent_pkh)
                  (cons
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      "invalid double activation" % string variant
                      invalid_double_activation)
                    (cons
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "wrong activation code" % string variant
                        invalid_activation_wrong_secret)
                      (cons
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          "invalid transfer from unactivated account" % string
                          variant invalid_transfer_from_unactived_account) [])))))))))).
src/proto_alpha/lib_protocol/test/baking.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Test_utils

(** Tests for [bake_n] and [bake_until_end_cycle]. *)
let test_cycle () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun csts ->
  let blocks_per_cycle = csts.parametric.blocks_per_cycle in
  let pp fmt x = Format.fprintf fmt "%ld" x in
  (* Tests that [bake_until_cycle_end] returns a block at
     level [blocks_per_cycle]. *)
  Block.bake b
  >>=? fun b ->
  Block.bake_until_cycle_end b
  >>=? fun b ->
  Context.get_level (B b)
  >>=? fun curr_level ->
  Assert.equal
    ~loc:__LOC__
    Int32.equal
    "not the right level"
    pp
    (Alpha_context.Raw_level.to_int32 curr_level)
    blocks_per_cycle
  >>=? fun () ->
  (* Tests that [bake_n n] bakes [n] blocks. *)
  Context.get_level (B b)
  >>=? fun l ->
  Block.bake_n 10 b
  >>=? fun b ->
  Context.get_level (B b)
  >>=? fun curr_level ->
  Assert.equal
    ~loc:__LOC__
    Int32.equal
    "not the right level"
    pp
    (Alpha_context.Raw_level.to_int32 curr_level)
    (Int32.add (Alpha_context.Raw_level.to_int32 l) 10l)

(** Tests the formula introduced in Emmy+ for block reward:
    (16/(p+1)) * (0.8 + 0.2 * e / 32)
    where p is the block priority and
    e is the number of included endorsements *)
let test_block_reward priority () =
  ( match priority with
  | 0 ->
      Test_tez.Tez.(of_int 128 /? Int64.of_int 10)
      >>?= fun min -> return (Test_tez.Tez.of_int 16, min)
  | 1 ->
      Test_tez.Tez.(of_int 64 /? Int64.of_int 10)
      >>?= fun min -> return (Test_tez.Tez.of_int 8, min)
  | 3 ->
      Test_tez.Tez.(of_int 32 /? Int64.of_int 10)
      >>?= fun min -> return (Test_tez.Tez.of_int 4, min)
  | _ ->
      fail (invalid_arg "prio should be 0, 1, or 3") )
  >>=? fun (expected_reward_max_endo, expected_reward_min_endo) ->
  let endorsers_per_block = 32 in
  Context.init ~endorsers_per_block 32
  >>=? fun (b, _) ->
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  fold_left_s
    (fun ops (endorser : Alpha_services.Delegate.Endorsing_rights.t) ->
      let delegate = endorser.delegate in
      Op.endorsement ~delegate (B b) ()
      >>=? fun op -> return (Operation.pack op :: ops))
    []
    endorsers
  >>=? fun ops ->
  Block.bake ~policy:(By_priority 0) ~operations:ops b
  >>=? fun b ->
  (* bake a block at priority 0 and 32 endorsements;
     the reward is 16 tez *)
  Context.get_baking_reward (B b) ~priority ~endorsing_power:32
  >>=? fun baking_reward ->
  Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_max_endo
  >>=? fun () ->
  (* bake a block at priority 0 and 0 endorsements;
     the reward is 12.8 tez *)
  Context.get_baking_reward (B b) ~priority ~endorsing_power:0
  >>=? fun baking_reward ->
  Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_min_endo

let tests =
  [ Test.tztest "cycle" `Quick test_cycle;
    Test.tztest "block_reward for priority 0" `Quick (test_block_reward 0);
    Test.tztest "block_reward for priority 1" `Quick (test_block_reward 1);
    Test.tztest "block_reward for priority 3" `Quick (test_block_reward 3) ]
src/proto_alpha/lib_protocol/test/baking.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition test_cycle {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun csts =>
              let blocks_per_cycle := blocks_per_cycle (parametric csts) in
              let pp
                (fmt :
                Tezos_protocol_environment_alpha__Environment.Format.formatter)
                (x : int32) : unit :=
                Tezos_protocol_environment_alpha__Environment.Format.fprintf fmt
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Int32
                      CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format) "%ld" % string) x
                in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                    (fun b =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (fun curr_level =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                              Tezos_protocol_environment_alpha__Environment.Int32.equal
                              "not the right level" % string pp
                              (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
                                curr_level) blocks_per_cycle)
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                  (fun l =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star 10 b)
                                      (fun b =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                          (fun curr_level =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              Tezos_protocol_environment_alpha__Environment.Int32.equal
                                              "not the right level" % string pp
                                              (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
                                                curr_level)
                                              (Tezos_protocol_environment_alpha__Environment.Int32.add
                                                (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.to_int32
                                                  l) 10))))
                              end)))))
        end)
  end.

Definition test_block_reward {A : Type}
  (priority : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      match priority with
      | 0 =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star
          (fun min =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((op_star_t_y_p_e_minus_e_r_r_o_r_star 16), min))
      | 1 =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star
          (fun min =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((op_star_t_y_p_e_minus_e_r_r_o_r_star 8), min))
      | 3 =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star
          (fun min =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ((op_star_t_y_p_e_minus_e_r_r_o_r_star 4), min))
      | _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.fail
          (Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
            "prio should be 0, 1, or 3" % string)
      end
      (fun function_parameter =>
        match function_parameter with
        | (expected_reward_max_endo, expected_reward_min_endo) =>
          let endorsers_per_block := 32 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star endorsers_per_block 32)
            (fun function_parameter =>
              match function_parameter with
              | (b, _) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun endorsers =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                        (fun ops =>
                          fun endorser =>
                            let delegate := delegate endorser in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                                op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                              (fun op =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  (cons
                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                      op) ops))) [] endorsers)
                      (fun ops =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star ops b)
                          (fun b =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star priority 32)
                              (fun baking_reward =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    baking_reward expected_reward_max_endo)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          priority 0)
                                        (fun baking_reward =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            baking_reward
                                            expected_reward_min_endo)
                                    end)))))
              end)
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "cycle" % string variant test_cycle)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        "block_reward for priority 0" % string variant (test_block_reward 0))
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "block_reward for priority 1" % string variant (test_block_reward 1))
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "block_reward for priority 3" % string variant (test_block_reward 3))
          []))).
src/proto_alpha/lib_protocol/test/combined_operations.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Multiple operations can be grouped in one ensuring their
    derministic application.

    If an invalid operation is present in this group of operation, the
    previous applied operations are backtracked leaving the context
    unchanged and the following operations are skipped. Fees attributed
    to the operations are collected by the baker nonetheless.

    Only manager operations are allowed in multiple transactions.
    They must all belong to the same manager as there is only one signature. *)

open Protocol
open Test_tez
open Test_utils

let ten_tez = Tez.of_int 10

(** Groups ten transactions between the same parties. *)
let multiple_transfers () =
  Context.init 3
  >>=? fun (blk, contracts) ->
  let c1 = List.nth contracts 0 in
  let c2 = List.nth contracts 1 in
  let c3 = List.nth contracts 2 in
  map_s (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10)
  >>=? fun ops ->
  Op.combine_operations ~source:c1 (B blk) ops
  >>=? fun operation ->
  Context.Contract.balance (B blk) c1
  >>=? fun c1_old_balance ->
  Context.Contract.balance (B blk) c2
  >>=? fun c2_old_balance ->
  Context.Contract.pkh c3
  >>=? fun baker_pkh ->
  Block.bake ~policy:(By_account baker_pkh) ~operation blk
  >>=? fun blk ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B blk)
    c1
    c1_old_balance
    (Tez.of_int 10)
  >>=? fun () ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B blk)
    c2
    c2_old_balance
    (Tez.of_int 10)
  >>=? fun () -> return_unit

(** Groups ten delegated originations. *)
let multiple_origination_and_delegation () =
  Context.init 2
  >>=? fun (blk, contracts) ->
  let c1 = List.nth contracts 0 in
  let c2 = List.nth contracts 1 in
  let n = 10 in
  Context.get_constants (B blk)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Context.Contract.pkh c2
  >>=? fun delegate_pkh ->
  (* Deploy n smart contracts with dummy scripts from c1 *)
  map_s
    (fun i ->
      Op.origination
        ~delegate:delegate_pkh
        ~counter:(Z.of_int i)
        ~fee:Tez.zero
        ~script:Op.dummy_script
        ~credit:(Tez.of_int 10)
        (B blk)
        c1)
    (1 -- n)
  >>=? fun originations ->
  (* These computed originated contracts are not the ones really created *)
  (* We will extract them from the tickets *)
  let (originations_operations, _) = List.split originations in
  Op.combine_operations ~source:c1 (B blk) originations_operations
  >>=? fun operation ->
  Context.Contract.balance (B blk) c1
  >>=? fun c1_old_balance ->
  Incremental.begin_construction blk
  >>=? fun inc ->
  Incremental.add_operation inc operation
  >>=? fun inc ->
  (* To retrieve the originated contracts, it is easier to extract them
     from the tickets. Else, we could (could we ?) hash each combined
     operation individually. *)
  let tickets = Incremental.rev_tickets inc in
  let open Apply_results in
  let tickets =
    List.fold_left
      (fun acc -> function No_operation_metadata -> assert false
        | Operation_metadata {contents} ->
            to_list (Contents_result_list contents) @ acc)
      []
      tickets
    |> List.rev
  in
  let new_contracts =
    List.map
      (function
        | Contents_result
            (Manager_operation_result
              { operation_result =
                  Applied (Origination_result {originated_contracts = [h]; _});
                _ }) ->
            h
        | _ ->
            assert false)
      tickets
  in
  (* Previous balance - (Credit (n * 10tz) + Origination cost (n tz)) *)
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Tez.(origination_burn *? Int64.of_int n)
  >>?= fun origination_total_cost ->
  Lwt.return
    ( Tez.( *? ) Op.dummy_script_cost 10L
    >>? Tez.( +? ) (Tez.of_int (10 * n))
    >>? Tez.( +? ) origination_total_cost )
  >>=? fun total_cost ->
  Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost
  >>=? fun () ->
  iter_s
    (fun c -> Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10))
    new_contracts
  >>=? fun () -> return_unit

let expect_balance_too_low = function
  | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
      return_unit
  | _ ->
      failwith
        "Contract should not have a sufficient balance : operation expected \
         to fail."

(** Groups three operations, the midlle one failing.
    Checks that the receipt is consistent.
    Variant without fees. *)
let failing_operation_in_the_middle () =
  Context.init 2
  >>=? fun (blk, contracts) ->
  let c1 = List.nth contracts 0 in
  let c2 = List.nth contracts 1 in
  Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one
  >>=? fun op1 ->
  Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez
  >>=? fun op2 ->
  Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one
  >>=? fun op3 ->
  let operations = [op1; op2; op3] in
  Op.combine_operations ~source:c1 (B blk) operations
  >>=? fun operation ->
  Context.Contract.balance (B blk) c1
  >>=? fun c1_old_balance ->
  Context.Contract.balance (B blk) c2
  >>=? fun c2_old_balance ->
  Incremental.begin_construction blk
  >>=? fun inc ->
  Incremental.add_operation
    ~expect_failure:expect_balance_too_low
    inc
    operation
  >>=? fun inc ->
  let tickets = Incremental.rev_tickets inc in
  let open Apply_results in
  let tickets =
    List.fold_left
      (fun acc -> function No_operation_metadata -> assert false
        | Operation_metadata {contents} ->
            to_list (Contents_result_list contents) @ acc)
      []
      tickets
  in
  ( match tickets with
  | Contents_result
      (Manager_operation_result {operation_result = Backtracked _; _})
    :: Contents_result
         (Manager_operation_result
           { operation_result = Failed (_, [Contract_storage.Balance_too_low _]);
             _ })
       :: Contents_result
            (Manager_operation_result {operation_result = Skipped _; _})
          :: _ ->
      ()
  | _ ->
      assert false ) ;
  Assert.balance_is ~loc:__LOC__ (I inc) c1 c1_old_balance
  >>=? fun () ->
  Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance
  >>=? fun () -> return_unit

(** Groups three operations, the midlle one failing.
    Checks that the receipt is consistent.
    Variant with fees, that should be spent even in case of failure. *)
let failing_operation_in_the_middle_with_fees () =
  Context.init 2
  >>=? fun (blk, contracts) ->
  let c1 = List.nth contracts 0 in
  let c2 = List.nth contracts 1 in
  Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one
  >>=? fun op1 ->
  Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez
  >>=? fun op2 ->
  Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one
  >>=? fun op3 ->
  let operations = [op1; op2; op3] in
  Op.combine_operations ~source:c1 (B blk) operations
  >>=? fun operation ->
  Context.Contract.balance (B blk) c1
  >>=? fun c1_old_balance ->
  Context.Contract.balance (B blk) c2
  >>=? fun c2_old_balance ->
  Incremental.begin_construction blk
  >>=? fun inc ->
  Incremental.add_operation
    ~expect_failure:expect_balance_too_low
    inc
    operation
  >>=? fun inc ->
  let tickets = Incremental.rev_tickets inc in
  let open Apply_results in
  let tickets =
    List.fold_left
      (fun acc -> function No_operation_metadata -> assert false
        | Operation_metadata {contents} ->
            to_list (Contents_result_list contents) @ acc)
      []
      tickets
  in
  ( match tickets with
  | Contents_result
      (Manager_operation_result {operation_result = Backtracked _; _})
    :: Contents_result
         (Manager_operation_result
           { operation_result = Failed (_, [Contract_storage.Balance_too_low _]);
             _ })
       :: Contents_result
            (Manager_operation_result {operation_result = Skipped _; _})
          :: _ ->
      ()
  | _ ->
      assert false ) ;
  (* In the presence of a failure, all the fees are collected. Even for skipped operations. *)
  Assert.balance_was_debited
    ~loc:__LOC__
    (I inc)
    c1
    c1_old_balance
    (Tez.of_int 3)
  >>=? fun () ->
  Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance
  >>=? fun () -> return_unit

let tests =
  [ Test.tztest "multiple transfers" `Quick multiple_transfers;
    Test.tztest
      "multiple originations and delegations"
      `Quick
      multiple_origination_and_delegation;
    Test.tztest
      "Failing operation in the middle"
      `Quick
      failing_operation_in_the_middle;
    Test.tztest
      "Failing operation in the middle (with fees)"
      `Quick
      failing_operation_in_the_middle_with_fees ]
src/proto_alpha/lib_protocol/test/combined_operations.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition ten_tez {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star 10.

Definition multiple_transfers (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 3)
      (fun function_parameter =>
        match function_parameter with
        | (blk, contracts) =>
          let c1 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let c2 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1 in
          let c3 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 2 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star c1 c2
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                end) (op_star_t_y_p_e_minus_e_r_r_o_r_star 1 10))
            (fun ops =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star c1
                  op_star_t_y_p_e_minus_e_r_r_o_r_star ops)
                (fun operation =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star c1)
                    (fun c1_old_balance =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star c2)
                        (fun c2_old_balance =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star c3)
                            (fun baker_pkh =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star operation
                                  blk)
                                (fun blk =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star c1
                                      c1_old_balance
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star 10))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            c2 c2_old_balance
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              10))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                            end)
                                      end)))))))
        end)
  end.

Definition multiple_origination_and_delegation {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (blk, contracts) =>
          let c1 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let c2 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1 in
          let n := 10 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star c2)
                  (fun delegate_pkh =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                        (fun i =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star delegate_pkh
                            (Tezos_protocol_environment_alpha__Environment.Z.of_int
                              i) op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star 10)
                            op_star_t_y_p_e_minus_e_r_r_o_r_star c1)
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star 1 n))
                      (fun originations =>
                        match
                          Tezos_protocol_environment_alpha__Environment.List.split
                            originations with
                        | (originations_operations, _) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star c1
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                              originations_operations)
                            (fun operation =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star c1)
                                (fun c1_old_balance =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star blk)
                                    (fun inc =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          inc operation)
                                        (fun inc =>
                                          let tickets :=
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              inc in
                                          let tickets :=
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                                              (Tezos_protocol_environment_alpha__Environment.List.fold_left
                                                (fun acc =>
                                                  fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | No_operation_metadata =>
                                                      false
                                                    |
                                                      Operation_metadata {|
                                                        contents := contents
                                                          |} =>
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                                        (Tezos_protocol_alpha.Protocol.Apply_results.to_list
                                                          (Contents_result_list
                                                            contents)) acc
                                                    end) [] tickets)
                                              Tezos_protocol_environment_alpha__Environment.List.rev
                                            in
                                          let new_contracts :=
                                            Tezos_protocol_environment_alpha__Environment.List.map
                                              (fun function_parameter =>
                                                match function_parameter with
                                                |
                                                  Contents_result
                                                    (Manager_operation_result {|
                                                      operation_result :=
                                                        Applied
                                                          (Origination_result
                                                            {|
                                                            originated_contracts :=
                                                              cons
                                                                h
                                                                []
                                                              |})
                                                        |}) => h
                                                | _ => false
                                                end) tickets in
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (fun origination_burn =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (fun origination_total_cost =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            10)
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
                                                                10 n))))
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          origination_total_cost)))
                                                    (fun total_cost =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          c1 c1_old_balance
                                                          total_cost)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.iter_s
                                                                (fun c =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    c
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      10))
                                                                new_contracts)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                end)
                                                          end))))))))
                        end))
              end)
        end)
  end.

Definition expect_balance_too_low
  (function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | cons (Environment.Ecoproto_error (Contract_storage.Balance_too_low _ _ _)) _
    => Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
      "Contract should not have a sufficient balance : operation expected to fail."
        % string
  end.

Definition failing_operation_in_the_middle (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (blk, contracts) =>
          let c1 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let c2 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star c1 c2
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun op1 =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star c1 c2
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun op2 =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star c1 c2
                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                    (fun op3 =>
                      let operations := cons op1 (cons op2 (cons op3 [])) in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star c1
                          op_star_t_y_p_e_minus_e_r_r_o_r_star operations)
                        (fun operation =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star c1)
                            (fun c1_old_balance =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star c2)
                                (fun c2_old_balance =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star blk)
                                    (fun inc =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          expect_balance_too_low inc operation)
                                        (fun inc =>
                                          let tickets :=
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              inc in
                                          let tickets :=
                                            Tezos_protocol_environment_alpha__Environment.List.fold_left
                                              (fun acc =>
                                                fun function_parameter =>
                                                  match function_parameter with
                                                  | No_operation_metadata =>
                                                    false
                                                  |
                                                    Operation_metadata {|
                                                      contents := contents
                                                        |} =>
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                                      (Tezos_protocol_alpha.Protocol.Apply_results.to_list
                                                        (Contents_result_list
                                                          contents)) acc
                                                  end) [] tickets in
                                          match tickets with
                                          |
                                            cons
                                              (Contents_result
                                                (Manager_operation_result {|
                                                  operation_result := Backtracked _ _
                                                    |}))
                                              (cons
                                                (Contents_result
                                                  (Manager_operation_result {|
                                                    operation_result :=
                                                      Failed _
                                                        (cons
                                                          (Contract_storage.Balance_too_low
                                                            _
                                                            _
                                                            _)
                                                          [])
                                                      |}))
                                                (cons
                                                  (Contents_result
                                                    (Manager_operation_result {|
                                                      operation_result := Skipped _
                                                        |})) _)) => tt
                                          | _ => false
                                          end;
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              c1 c1_old_balance)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    c2 c2_old_balance)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                    end)
                                              end)))))))))
        end)
  end.

Definition failing_operation_in_the_middle_with_fees (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (blk, contracts) =>
          let c1 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let c2 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star c1 c2
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun op1 =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star c1 c2
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun op2 =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star c1 c2
                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                    (fun op3 =>
                      let operations := cons op1 (cons op2 (cons op3 [])) in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star c1
                          op_star_t_y_p_e_minus_e_r_r_o_r_star operations)
                        (fun operation =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star c1)
                            (fun c1_old_balance =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star c2)
                                (fun c2_old_balance =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star blk)
                                    (fun inc =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          expect_balance_too_low inc operation)
                                        (fun inc =>
                                          let tickets :=
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              inc in
                                          let tickets :=
                                            Tezos_protocol_environment_alpha__Environment.List.fold_left
                                              (fun acc =>
                                                fun function_parameter =>
                                                  match function_parameter with
                                                  | No_operation_metadata =>
                                                    false
                                                  |
                                                    Operation_metadata {|
                                                      contents := contents
                                                        |} =>
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                                      (Tezos_protocol_alpha.Protocol.Apply_results.to_list
                                                        (Contents_result_list
                                                          contents)) acc
                                                  end) [] tickets in
                                          match tickets with
                                          |
                                            cons
                                              (Contents_result
                                                (Manager_operation_result {|
                                                  operation_result := Backtracked _ _
                                                    |}))
                                              (cons
                                                (Contents_result
                                                  (Manager_operation_result {|
                                                    operation_result :=
                                                      Failed _
                                                        (cons
                                                          (Contract_storage.Balance_too_low
                                                            _
                                                            _
                                                            _)
                                                          [])
                                                      |}))
                                                (cons
                                                  (Contents_result
                                                    (Manager_operation_result {|
                                                      operation_result := Skipped _
                                                        |})) _)) => tt
                                          | _ => false
                                          end;
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              c1 c1_old_balance
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                3))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    c2 c2_old_balance)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                    end)
                                              end)))))))))
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "multiple transfers" % string variant
      multiple_transfers)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        "multiple originations and delegations" % string variant
        multiple_origination_and_delegation)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "Failing operation in the middle" % string variant
          failing_operation_in_the_middle)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "Failing operation in the middle (with fees)" % string variant
            failing_operation_in_the_middle_with_fees) []))).
src/proto_alpha/lib_protocol/test/delegation.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Test_tez
open Test_utils

(**************************************************************************)
(* bootstrap contracts *)
(**************************************************************************)
(* Bootstrap contracts are heavily used in other tests. It is helpful
   to test some properties of these contracts, so we can correctly
   interpret the other tests that use them. *)

let expect_error err = function
  | err0 :: _ when err = err0 ->
      return_unit
  | _ ->
      failwith "Unexpected successful result"

let expect_alpha_error err = expect_error (Environment.Ecoproto_error err)

let expect_no_change_registered_delegate_pkh pkh = function
  | Environment.Ecoproto_error (Delegate_storage.No_deletion pkh0) :: _
    when pkh0 = pkh ->
      return_unit
  | _ ->
      failwith "Delegate can not be deleted and operation should fail."

(** bootstrap contracts delegate to themselves *)
let bootstrap_manager_is_bootstrap_delegate () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap0 = List.hd bootstrap_contracts in
  Context.Contract.delegate (B b) bootstrap0
  >>=? fun delegate0 ->
  Context.Contract.manager (B b) bootstrap0
  >>=? fun manager0 -> Assert.equal_pkh ~loc:__LOC__ delegate0 manager0.pkh

(** bootstrap contracts cannot change their delegate *)
let bootstrap_delegate_cannot_change ~fee () =
  Context.init 2
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap0 = List.nth bootstrap_contracts 0 in
  let bootstrap1 = List.nth bootstrap_contracts 1 in
  Context.Contract.pkh bootstrap0
  >>=? fun pkh1 ->
  Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap1
  >>=? fun manager1 ->
  Context.Contract.balance (I i) bootstrap0
  >>=? fun balance0 ->
  Context.Contract.delegate (I i) bootstrap0
  >>=? fun delegate0 ->
  (* change delegation to bootstrap1 *)
  Op.delegation ~fee (I i) bootstrap0 (Some manager1.pkh)
  >>=? fun set_delegate ->
  if fee > balance0 then
    Incremental.add_operation i set_delegate
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation
      ~expect_failure:(expect_no_change_registered_delegate_pkh delegate0)
      i
      set_delegate
    >>=? fun i ->
    Incremental.finalize_block i
    >>=? fun b ->
    (* bootstrap0 still has same delegate *)
    Context.Contract.delegate (B b) bootstrap0
    >>=? fun delegate0_after ->
    Assert.equal_pkh ~loc:__LOC__ delegate0_after delegate0
    >>=? fun () ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (B b) bootstrap0 balance0 fee

(** bootstrap contracts cannot delete their delegation *)
let bootstrap_delegate_cannot_be_removed ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap = List.hd bootstrap_contracts in
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  Context.Contract.delegate (I i) bootstrap
  >>=? fun delegate ->
  Context.Contract.manager (I i) bootstrap
  >>=? fun manager ->
  (* remove delegation *)
  Op.delegation ~fee (I i) bootstrap None
  >>=? fun set_delegate ->
  if fee > balance then
    Incremental.add_operation i set_delegate
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation
      ~expect_failure:(expect_no_change_registered_delegate_pkh manager.pkh)
      i
      set_delegate
    >>=? fun i ->
    (* delegate has not changed *)
    Context.Contract.delegate (I i) bootstrap
    >>=? fun delegate_after ->
    Assert.equal_pkh ~loc:__LOC__ delegate delegate_after
    >>=? fun () ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee

(** contracts not registered as delegate can change their delegation *)
let delegate_can_be_changed_from_unregistered_contract ~fee () =
  Context.init 2
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap0 = List.hd bootstrap_contracts in
  let bootstrap1 = List.nth bootstrap_contracts 1 in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let unregistered = Contract.implicit_contract unregistered_pkh in
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap0
  >>=? fun manager0 ->
  Context.Contract.manager (I i) bootstrap1
  >>=? fun manager1 ->
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap0 unregistered credit
  >>=? fun credit_contract ->
  Context.Contract.balance (I i) bootstrap0
  >>=? fun balance ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  (* delegate to bootstrap0 *)
  Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager0.pkh)
  >>=? fun set_delegate ->
  Incremental.add_operation i set_delegate
  >>=? fun i ->
  Context.Contract.delegate (I i) unregistered
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate manager0.pkh
  >>=? fun () ->
  (* change delegation to bootstrap1 *)
  Op.delegation ~fee (I i) unregistered (Some manager1.pkh)
  >>=? fun change_delegate ->
  if fee > balance then
    Incremental.add_operation i change_delegate
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation i change_delegate
    >>=? fun i ->
    (* delegate has changed *)
    Context.Contract.delegate (I i) unregistered
    >>=? fun delegate_after ->
    Assert.equal_pkh ~loc:__LOC__ delegate_after manager1.pkh
    >>=? fun () ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee

(** contracts not registered as delegate can delete their delegation *)
let delegate_can_be_removed_from_unregistered_contract ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let unregistered = Contract.implicit_contract unregistered_pkh in
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap
  >>=? fun manager ->
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap unregistered credit
  >>=? fun credit_contract ->
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  (* delegate to bootstrap *)
  Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager.pkh)
  >>=? fun set_delegate ->
  Incremental.add_operation i set_delegate
  >>=? fun i ->
  Context.Contract.delegate (I i) unregistered
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh
  >>=? fun () ->
  (* remove delegation *)
  Op.delegation ~fee (I i) unregistered None
  >>=? fun delete_delegate ->
  if fee > balance then
    Incremental.add_operation i delete_delegate
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation i delete_delegate
    >>=? fun i ->
    (* the delegate has been removed *)
    Context.Contract.delegate_opt (I i) unregistered
    >>=? (function
           | None ->
               return_unit
           | Some _ ->
               failwith "Expected delegate to be removed")
    >>=? fun () ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee

(** bootstrap keys are already registered as delegate keys *)
let bootstrap_manager_already_registered_delegate ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  Context.Contract.manager (I i) bootstrap
  >>=? fun manager ->
  let pkh = manager.pkh in
  let impl_contract = Contract.implicit_contract pkh in
  Context.Contract.balance (I i) impl_contract
  >>=? fun balance ->
  Op.delegation ~fee (I i) impl_contract (Some pkh)
  >>=? fun sec_reg ->
  if fee > balance then
    Incremental.add_operation i sec_reg
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation
      ~expect_failure:(function
        | Environment.Ecoproto_error Delegate_storage.Active_delegate :: _ ->
            return_unit
        | _ ->
            failwith "Delegate is already active and operation should fail.")
      i
      sec_reg
    >>=? fun i ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee

(** bootstrap manager can be set as delegate of an originated contract
    (through origination operation) *)
let delegate_to_bootstrap_by_origination ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  Context.Contract.manager (I i) bootstrap
  >>=? fun manager ->
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  (* originate a contract with bootstrap's manager as delegate *)
  Op.origination
    ~fee
    ~credit:Tez.zero
    ~delegate:manager.pkh
    (I i)
    bootstrap
    ~script:Op.dummy_script
  >>=? fun (op, orig_contract) ->
  Context.get_constants (I i)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  (* 0.257tz *)
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Lwt.return
    (Tez.( +? ) fee origination_burn >>? Tez.( +? ) Op.dummy_script_cost)
  >>=? fun total_fee ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else if total_fee > balance && balance >= fee then
    (* origination did not proceed; fee has been debited *)
    Incremental.add_operation
      i
      ~expect_failure:(function
        | Environment.Ecoproto_error (Contract.Balance_too_low _) :: _ ->
            return_unit
        | _ ->
            failwith
              "Not enough balance for origination burn: operation should fail.")
      op
    >>=? fun i ->
    (* fee was taken *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
    >>=? fun () ->
    (* originated contract has not been created *)
    Context.Contract.balance (I i) orig_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)
  else
    (* bootstrap is delegate, fee + origination burn have been debited *)
    Incremental.add_operation i op
    >>=? fun i ->
    Context.Contract.delegate (I i) orig_contract
    >>=? fun delegate ->
    Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh
    >>=? fun () ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance total_fee

let tests_bootstrap_contracts =
  [ Test.tztest
      "bootstrap contracts delegate to themselves"
      `Quick
      bootstrap_manager_is_bootstrap_delegate;
    Test.tztest
      "bootstrap contracts can change their delegate (small fee)"
      `Quick
      (bootstrap_delegate_cannot_change ~fee:Tez.one_mutez);
    Test.tztest
      "bootstrap contracts can change their delegate (max fee)"
      `Quick
      (bootstrap_delegate_cannot_change ~fee:Tez.max_tez);
    Test.tztest
      "bootstrap contracts cannot remove their delegation (small fee)"
      `Quick
      (bootstrap_delegate_cannot_be_removed ~fee:Tez.one_mutez);
    Test.tztest
      "bootstrap contracts cannot remove their delegation (max fee)"
      `Quick
      (bootstrap_delegate_cannot_be_removed ~fee:Tez.max_tez);
    Test.tztest
      "contracts not registered as delegate can remove their delegation \
       (small fee)"
      `Quick
      (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.one_mutez);
    Test.tztest
      "contracts not registered as delegate can remove their delegation (max \
       fee)"
      `Quick
      (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.max_tez);
    Test.tztest
      "contracts not registered as delegate can remove their delegation \
       (small fee)"
      `Quick
      (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.one_mutez);
    Test.tztest
      "contracts not registered as delegate can remove their delegation (max \
       fee)"
      `Quick
      (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.max_tez);
    Test.tztest
      "bootstrap keys are already registered as delegate keys (small fee)"
      `Quick
      (bootstrap_manager_already_registered_delegate ~fee:Tez.one_mutez);
    Test.tztest
      "bootstrap keys are already registered as delegate keys (max fee)"
      `Quick
      (bootstrap_manager_already_registered_delegate ~fee:Tez.max_tez);
    Test.tztest
      "bootstrap manager can be delegate (init origination, small fee)"
      `Quick
      (delegate_to_bootstrap_by_origination ~fee:Tez.one_mutez);
    (* balance enough for fee but not for fee + origination burn + dummy script storage cost *)
    Test.tztest
      "bootstrap manager can be delegate (init origination, edge case)"
      `Quick
      (delegate_to_bootstrap_by_origination
         ~fee:(Tez.of_mutez_exn 3_999_999_705_000L));
    (* fee bigger than bootstrap's initial balance*)
    Test.tztest
      "bootstrap manager can be delegate (init origination, large fee)"
      `Quick
      (delegate_to_bootstrap_by_origination ~fee:(Tez.of_int 10_000_000)) ]

(**************************************************************************)
(* delegate registration *)
(**************************************************************************)
(* A delegate is a pkh. Delegates must be registered. Registration is
   done via the self-delegation of the implicit contract corresponding
   to the pkh. The implicit contract must be credited when the
   self-delegation is done. Furthermore, trying to register an already
   registered key raises an error.

   In this series of tests, we verify that
   1- unregistered delegate keys cannot be delegated to,
   2- registered keys can be delegated to,
   3- registering an already registered key raises an error.


   We consider three scenarios for setting a delegate:
   - through origination,
   - through delegation when the implicit contract has no delegate yet,
   - through delegation when the implicit contract already has a delegate.

   We also test that emptying the implicit contract linked to a
   registered delegate key does not unregister the delegate key.
*)

(*
   Valid registration

   Unregistered key:
   - contract not credited and no self-delegation
   - contract credited but no self-delegation
   - contract not credited and self-delegation

Not credited:
- no credit operation
- credit operation of 1μꜩ and then debit operation of 1μꜩ

*)

(** A- unregistered delegate keys cannot be used for delegation *)

(* Two main series of tests: without self-delegation, and with a failed attempt at self-delegation
   1- no self-delegation
     a- no credit
   - no token transfer
   - credit of 1μꜩ and then debit of 1μꜩ
     b- with credit of 1μꜩ.
     For every scenario, we try three different ways of delegating:
   - through origination (init origination)
   - through delegation when no delegate was assigned (init delegation)
   - through delegation when a delegate was assigned (switch delegation).

   2- Self-delegation fails if the contract has no credit. We try the
   two possibilities of 1a for non-credited contracts.
*)

let expect_unregistered_key pkh = function
  | Environment.Ecoproto_error (Roll_storage.Unregistered_delegate pkh0) :: _
    when pkh = pkh0 ->
      return_unit
  | _ ->
      failwith "Delegate key is not registered: operation should fail."

(* A1: no self-delegation *)
(* no token transfer, no self-delegation *)
let unregistered_delegate_key_init_origination ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  (* origination with delegate argument *)
  Op.origination
    ~fee
    ~delegate:unregistered_pkh
    (I i)
    bootstrap
    ~script:Op.dummy_script
  >>=? fun (op, orig_contract) ->
  Context.get_constants (I i)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Lwt.return (Tez.( +? ) fee origination_burn)
  >>=? fun _total_fee ->
  (* FIXME unused variable *)
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* origination did not proceed; fee has been debited *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
    >>=? fun () ->
    (* originated contract has not been created *)
    Context.Contract.balance (I i) orig_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_init_delegation ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
  >>=? fun _ ->
  (* try to delegate *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been debited; no delegate *)
    Incremental.add_operation
      i
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
    >>=? fun () ->
    (* implicit contract has no delegate *)
    Context.Contract.delegate (I i) impl_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_switch_delegation ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let bootstrap_pkh =
    Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
  in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun init_credit ->
  Incremental.add_operation i init_credit
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
  >>=? fun _ ->
  (* set and check the initial delegate *)
  Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
  >>=? fun delegate_op ->
  Incremental.add_operation i delegate_op
  >>=? fun i ->
  Context.Contract.delegate (I i) bootstrap
  >>=? fun delegate_pkh ->
  Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
  >>=? fun () ->
  (* try to delegate *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been debited; no delegate *)
    Incremental.add_operation
      i
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
    >>=? fun () ->
    (* implicit contract delegate has not changed *)
    Context.Contract.delegate (I i) bootstrap
    >>=? fun delegate_pkh_after ->
    Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate_pkh_after

(* credit of some amount, no self-delegation *)
let unregistered_delegate_key_init_origination_credit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* origination with delegate argument *)
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  Op.origination
    ~fee
    ~delegate:unregistered_pkh
    (I i)
    bootstrap
    ~script:Op.dummy_script
  >>=? fun (op, orig_contract) ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* origination not done, fee taken *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
    >>=? fun () ->
    Context.Contract.balance (I i) orig_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_init_delegation_credit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Lwt.return Tez.(credit +? amount)
  >>=? fun balance ->
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun init_credit ->
  Incremental.add_operation i init_credit
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance
  >>=? fun _ ->
  (* try to delegate *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been taken, no delegate for contract *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      i
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee
    >>=? fun () ->
    Context.Contract.delegate (I i) impl_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let bootstrap_pkh =
    Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
  in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Lwt.return Tez.(credit +? amount)
  >>=? fun balance ->
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun init_credit ->
  Incremental.add_operation i init_credit
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance
  >>=? fun _ ->
  (* set and check the initial delegate *)
  Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
  >>=? fun delegate_op ->
  Incremental.add_operation i delegate_op
  >>=? fun i ->
  Context.Contract.delegate (I i) bootstrap
  >>=? fun delegate_pkh ->
  Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
  >>=? fun () ->
  (* switch delegate through delegation *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been taken, delegate for contract has not changed *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      i
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee
    >>=? fun () ->
    Context.Contract.delegate (I i) impl_contract
    >>=? fun delegate ->
    Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh
    >>=? fun () -> Assert.equal_pkh ~loc:__LOC__ delegate bootstrap_pkh

(* a credit of some amount followed by a debit of the same amount, no self-delegation *)
let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  (* credit + check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* debit + check balance *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun debit_contract ->
  Incremental.add_operation i debit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* origination with delegate argument *)
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  Op.origination
    ~fee
    ~delegate:unregistered_pkh
    (I i)
    bootstrap
    ~script:Op.dummy_script
  >>=? fun (op, orig_contract) ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee taken, origination not processed *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
    >>=? fun () ->
    Context.Contract.balance (I i) orig_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* debit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) impl_contract bootstrap amount
  >>=? fun debit_contract ->
  Incremental.add_operation i debit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
  >>=? fun _ ->
  (* try to delegate *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been taken, no delegate for contract *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      i
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
    >>=? fun () ->
    Context.Contract.delegate (I i) impl_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let bootstrap_pkh =
    Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
  in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* debit + check balance *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun debit_contract ->
  Incremental.add_operation i debit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* delegation - initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
  >>=? fun _ ->
  (* set and check the initial delegate *)
  Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
  >>=? fun delegate_op ->
  Incremental.add_operation i delegate_op
  >>=? fun i ->
  Context.Contract.delegate (I i) bootstrap
  >>=? fun delegate_pkh ->
  Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
  >>=? fun () ->
  (* switch delegate through delegation *)
  Op.delegation (I i) ~fee impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been taken, delegate for contract has not changed *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      i
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
    >>=? fun () ->
    Context.Contract.delegate (I i) impl_contract
    >>=? fun delegate ->
    Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh

(* A2- self-delegation to an empty contract fails *)
let failed_self_delegation_no_transaction () =
  Context.init 1
  >>=? fun (b, _) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let account = Account.new_account () in
  let unregistered_pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  (* check balance *)
  Context.Contract.balance (I i) impl_contract
  >>=? fun balance ->
  Assert.equal_tez ~loc:__LOC__ Tez.zero balance
  >>=? fun _ ->
  (* self delegation fails *)
  Op.delegation (I i) impl_contract (Some unregistered_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Contract_storage.Empty_implicit_contract pkh ->
          if pkh = unregistered_pkh then true else false
      | _ ->
          false)

let failed_self_delegation_emptied_implicit_contract amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let account = Account.new_account () in
  let unregistered_pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  (*  credit implicit contract and check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* empty implicit contract and check balance *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* self delegation fails *)
  Op.delegation (I i) impl_contract (Some unregistered_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Contract_storage.Empty_implicit_contract pkh ->
          if pkh = unregistered_pkh then true else false
      | _ ->
          false)

(** B- valid registration:
    - credit implicit contract with some ꜩ + verification of balance
    - self delegation + verification
    - empty contract + verification of balance + verification of not being erased / self-delegation
    - create delegator implicit contract w first implicit contract as delegate + verification of delegation *)
let valid_delegate_registration_init_delegation_credit amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let delegate_account = Account.new_account () in
  let delegate_pkh = Account.(delegate_account.pkh) in
  let impl_contract = Contract.implicit_contract delegate_pkh in
  (* credit > 0ꜩ + check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* self delegation + verification *)
  Op.delegation (I i) impl_contract (Some delegate_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
  >>=? fun _ ->
  (* create an implicit contract with no delegate *)
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let delegator = Contract.implicit_contract unregistered_pkh in
  Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  (* check no delegate for delegator contract *)
  Context.Contract.delegate (I i) delegator
  >>= fun err ->
  Assert.error ~loc:__LOC__ err (function
      | RPC_context.Not_found _ ->
          true
      | _ ->
          false)
  >>=? fun _ ->
  (* delegation to the newly registered key *)
  Op.delegation (I i) delegator (Some delegate_account.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  (* check delegation *)
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh

let valid_delegate_registration_switch_delegation_credit amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let delegate_account = Account.new_account () in
  let delegate_pkh = Account.(delegate_account.pkh) in
  let impl_contract = Contract.implicit_contract delegate_pkh in
  (* credit > 0ꜩ + check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* self delegation + verification *)
  Op.delegation (I i) impl_contract (Some delegate_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
  >>=? fun _ ->
  (* create an implicit contract with bootstrap's account as delegate *)
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let delegator = Contract.implicit_contract unregistered_pkh in
  Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap
  >>=? fun bootstrap_manager ->
  Op.delegation (I i) delegator (Some bootstrap_manager.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  (* test delegate of new contract is bootstrap *)
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh
  >>=? fun _ ->
  (* delegation with newly registered key *)
  Op.delegation (I i) delegator (Some delegate_account.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh

let valid_delegate_registration_init_delegation_credit_debit amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let delegate_account = Account.new_account () in
  let delegate_pkh = Account.(delegate_account.pkh) in
  let impl_contract = Contract.implicit_contract delegate_pkh in
  (* credit > 0ꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* self delegation + verification *)
  Op.delegation (I i) impl_contract (Some delegate_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
  >>=? fun _ ->
  (* empty implicit contracts are usually deleted but they are kept if
     they were registered as delegates. we empty the contract in
     order to verify this. *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun empty_contract ->
  Incremental.add_operation i empty_contract
  >>=? fun i ->
  (* impl_contract is empty *)
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* verify self-delegation after contract is emptied *)
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
  >>=? fun _ ->
  (* create an implicit contract with no delegate *)
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let delegator = Contract.implicit_contract unregistered_pkh in
  Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  (* check no delegate for delegator contract *)
  Context.Contract.delegate (I i) delegator
  >>= fun err ->
  Assert.error ~loc:__LOC__ err (function
      | RPC_context.Not_found _ ->
          true
      | _ ->
          false)
  >>=? fun _ ->
  (* delegation to the newly registered key *)
  Op.delegation (I i) delegator (Some delegate_account.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  (* check delegation *)
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh

let valid_delegate_registration_switch_delegation_credit_debit amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let delegate_account = Account.new_account () in
  let delegate_pkh = Account.(delegate_account.pkh) in
  let impl_contract = Contract.implicit_contract delegate_pkh in
  (* credit > 0ꜩ + check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* self delegation + verification *)
  Op.delegation (I i) impl_contract (Some delegate_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
  >>=? fun _ ->
  (* empty implicit contracts are usually deleted but they are kept if
     they were registered as delegates. we empty the contract in
     order to verify this. *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun empty_contract ->
  Incremental.add_operation i empty_contract
  >>=? fun i ->
  (* impl_contract is empty *)
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* create an implicit contract with bootstrap's account as delegate *)
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let delegator = Contract.implicit_contract unregistered_pkh in
  Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap
  >>=? fun bootstrap_manager ->
  Op.delegation (I i) delegator (Some bootstrap_manager.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  (* test delegate of new contract is bootstrap *)
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh
  >>=? fun _ ->
  (* delegation with newly registered key *)
  Op.delegation (I i) delegator (Some delegate_account.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh

(* with implicit contract with some credit *)

(** C- a second self-delegation should raise an `Active_delegate` error *)
let double_registration () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let account = Account.new_account () in
  let pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract pkh in
  (* credit 1μꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
  >>=? fun _ ->
  (* self-delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  (* second self-delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun second_registration ->
  Incremental.add_operation i second_registration
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Delegate_storage.Active_delegate ->
          true
      | _ ->
          false)

(* with implicit contract emptied after first self-delegation  *)
let double_registration_when_empty () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let account = Account.new_account () in
  let pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract pkh in
  (* credit 1μꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
  >>=? fun _ ->
  (* self delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  (* empty the delegate account *)
  Op.transaction (I i) impl_contract bootstrap Tez.one_mutez
  >>=? fun empty_contract ->
  Incremental.add_operation i empty_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* second self-delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun second_registration ->
  Incremental.add_operation i second_registration
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Delegate_storage.Active_delegate ->
          true
      | _ ->
          false)

(* with implicit contract emptied then recredited after first self-delegation  *)
let double_registration_when_recredited () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let account = Account.new_account () in
  let pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract pkh in
  (* credit 1μꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
  >>=? fun _ ->
  (* self delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  (* empty the delegate account *)
  Op.transaction (I i) impl_contract bootstrap Tez.one_mutez
  >>=? fun empty_contract ->
  Incremental.add_operation i empty_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* credit 1μꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
  >>=? fun _ ->
  (* second self-delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun second_registration ->
  Incremental.add_operation i second_registration
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Delegate_storage.Active_delegate ->
          true
      | _ ->
          false)

(* self-delegation on unrevealed contract *)
let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let {Account.pkh; _} = Account.new_account () in
  let {Account.pkh = delegate_pkh; _} = Account.new_account () in
  let contract = Alpha_context.Contract.implicit_contract pkh in
  Op.transaction (I i) bootstrap contract (Tez.of_int 10)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.delegation ~fee (I i) contract (Some delegate_pkh)
  >>=? fun op ->
  Context.Contract.balance (I i) contract
  >>=? fun balance ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* origination did not proceed; fee has been debited *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key delegate_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee

(* self-delegation on revelead but not registered contract *)
let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let {Account.pkh; pk; _} = Account.new_account () in
  let {Account.pkh = delegate_pkh; _} = Account.new_account () in
  let contract = Alpha_context.Contract.implicit_contract pkh in
  Op.transaction (I i) bootstrap contract (Tez.of_int 10)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.revelation (I i) pk
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.delegation ~fee (I i) contract (Some delegate_pkh)
  >>=? fun op ->
  Context.Contract.balance (I i) contract
  >>=? fun balance ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* origination did not proceed; fee has been debited *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key delegate_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee

(* self-delegation on revealed and registered contract *)
let registered_self_delegate_key_init_delegation () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let {Account.pkh; _} = Account.new_account () in
  let {Account.pkh = delegate_pkh; pk = delegate_pk; _} =
    Account.new_account ()
  in
  let contract = Alpha_context.Contract.implicit_contract pkh in
  let delegate_contract =
    Alpha_context.Contract.implicit_contract delegate_pkh
  in
  Op.transaction (I i) bootstrap contract (Tez.of_int 10)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.transaction (I i) bootstrap delegate_contract (Tez.of_int 1)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.revelation (I i) delegate_pk
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.delegation (I i) delegate_contract (Some delegate_pkh)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.delegation (I i) contract (Some delegate_pkh)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Context.Contract.delegate (I i) contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
  >>=? fun () -> return_unit

let tests_delegate_registration =
  [ (*** unregistered delegate key: no self-delegation ***)
    (* no token transfer, no self-delegation *)
    Test.tztest
      "unregistered delegate key (origination, small fee)"
      `Quick
      (unregistered_delegate_key_init_origination ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key (origination, edge case fee)"
      `Quick
      (unregistered_delegate_key_init_origination ~fee:(Tez.of_int 3_999_488));
    Test.tztest
      "unregistered delegate key (origination, large fee)"
      `Quick
      (unregistered_delegate_key_init_origination ~fee:(Tez.of_int 10_000_000));
    Test.tztest
      "unregistered delegate key (init with delegation, small fee)"
      `Quick
      (unregistered_delegate_key_init_delegation ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key (init with delegation, max fee)"
      `Quick
      (unregistered_delegate_key_init_delegation ~fee:Tez.max_tez);
    Test.tztest
      "unregistered delegate key (switch with delegation, small fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key (switch with delegation, max fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation ~fee:Tez.max_tez);
    (* credit/debit 1μꜩ, no self-delegation *)
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (origination, small fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit_debit
         ~fee:Tez.one_mutez
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (origination, large fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit_debit
         ~fee:Tez.max_tez
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (init with delegation, \
       small fee)"
      `Quick
      (unregistered_delegate_key_init_delegation_credit_debit
         ~amount:Tez.one_mutez
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (init with delegation, \
       large fee)"
      `Quick
      (unregistered_delegate_key_init_delegation_credit_debit
         ~amount:Tez.one_mutez
         ~fee:Tez.max_tez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (switch with \
       delegation, small fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation_credit_debit
         ~amount:Tez.one_mutez
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (switch with \
       delegation, large fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation_credit_debit
         ~amount:Tez.one_mutez
         ~fee:Tez.max_tez);
    (* credit 1μꜩ, no self-delegation *)
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (origination, small fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit
         ~fee:Tez.one_mutez
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (origination, edge case fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit
         ~fee:(Tez.of_int 3_999_488)
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (origination, large fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit
         ~fee:(Tez.of_int 10_000_000)
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (init with delegation, small \
       fee)"
      `Quick
      (unregistered_delegate_key_init_delegation_credit
         ~amount:Tez.one_mutez
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (init with delegation, large \
       fee)"
      `Quick
      (unregistered_delegate_key_init_delegation_credit
         ~amount:Tez.one_mutez
         ~fee:Tez.max_tez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (switch with delegation, \
       small fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation_credit
         ~amount:Tez.one_mutez
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (switch with delegation, \
       large fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation_credit
         ~amount:Tez.one_mutez
         ~fee:Tez.max_tez);
    (* self delegation on unrevealed and unregistered contract *)
    Test.tztest
      "unregistered and unrevealed self-delegation (small fee)"
      `Quick
      (unregistered_and_unrevealed_self_delegate_key_init_delegation
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered and unrevealed self-delegation (large fee)"
      `Quick
      (unregistered_and_unrevealed_self_delegate_key_init_delegation
         ~fee:Tez.max_tez);
    (* self delegation on unregistered contract *)
    Test.tztest
      "unregistered and revealed self-delegation (small fee)"
      `Quick
      (unregistered_and_revealed_self_delegate_key_init_delegation
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered and revealed self-delegation  large fee)"
      `Quick
      (unregistered_and_revealed_self_delegate_key_init_delegation
         ~fee:Tez.max_tez);
    (* self delegation on registered contract *)
    Test.tztest
      "registered and revelead self-delegation"
      `Quick
      registered_self_delegate_key_init_delegation;
    (*** unregistered delegate key: failed self-delegation ***)
    (* no token transfer, self-delegation *)
    Test.tztest
      "failed self-delegation: no transaction"
      `Quick
      failed_self_delegation_no_transaction;
    (* credit 1μtz, debit 1μtz, self-delegation *)
    Test.tztest
      "failed self-delegation: credit & debit 1μꜩ"
      `Quick
      (failed_self_delegation_emptied_implicit_contract Tez.one_mutez);
    (*** valid registration ***)
    (* valid registration: credit 1 μꜩ, self delegation *)
    Test.tztest
      "valid delegate registration: credit 1μꜩ, self delegation (init with \
       delegation)"
      `Quick
      (valid_delegate_registration_init_delegation_credit Tez.one_mutez);
    Test.tztest
      "valid delegate registration: credit 1μꜩ, self delegation (switch \
       with delegation)"
      `Quick
      (valid_delegate_registration_switch_delegation_credit Tez.one_mutez);
    (* valid registration: credit 1 μꜩ, self delegation, debit 1μꜩ *)
    Test.tztest
      "valid delegate registration: credit 1μꜩ, self delegation, debit \
       1μꜩ (init with delegation)"
      `Quick
      (valid_delegate_registration_init_delegation_credit_debit Tez.one_mutez);
    Test.tztest
      "valid delegate registration: credit 1μꜩ, self delegation, debit \
       1μꜩ (switch with delegation)"
      `Quick
      (valid_delegate_registration_switch_delegation_credit_debit Tez.one_mutez);
    (*** double registration ***)
    Test.tztest "double registration" `Quick double_registration;
    Test.tztest
      "double registration when delegate account is emptied"
      `Quick
      double_registration_when_empty;
    Test.tztest
      "double registration when delegate account is emptied and then recredited"
      `Quick
      double_registration_when_recredited ]

(******************************************************************************)
(* Main                                                                       *)
(******************************************************************************)

let tests = tests_bootstrap_contracts @ tests_delegate_registration
src/proto_alpha/lib_protocol/test/delegation.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition expect_error {A B : Type} (err : A) (function_parameter : list B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | cons err0 _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
      "Unexpected successful result" % string
  end.

Definition expect_alpha_error {A : Type}
  (err : Tezos_protocol_alpha.Protocol.Environment.Error_monad.error)
  : (list A) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  expect_error (Environment.Ecoproto_error err).

Definition expect_no_change_registered_delegate_pkh {A : Type}
  (pkh : A)
  (function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | cons (Environment.Ecoproto_error (Delegate_storage.No_deletion pkh0)) _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
      "Delegate can not be deleted and operation should fail." % string
  end.

Definition bootstrap_manager_is_bootstrap_delegate {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          let bootstrap0 :=
            Tezos_protocol_environment_alpha__Environment.List.hd
              bootstrap_contracts in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap0)
            (fun delegate0 =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap0)
                (fun manager0 =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                    delegate0 (pkh manager0)))
        end)
  end.

Definition bootstrap_delegate_cannot_change {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          let bootstrap0 :=
            op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap_contracts 0 in
          let bootstrap1 :=
            op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap_contracts 1 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap0)
            (fun pkh1 =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star b
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun i =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap1)
                    (fun manager1 =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap0)
                        (fun balance0 =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap0)
                            (fun delegate0 =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  bootstrap0 (Some (pkh manager1)))
                                (fun set_delegate =>
                                  if
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                      balance0 then
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                        set_delegate)
                                      (fun err =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                          err
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              Contract_storage.Balance_too_low _
                                                _ _ => true
                                            | _ => false
                                            end))
                                  else
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (expect_no_change_registered_delegate_pkh
                                          delegate0) i set_delegate)
                                      (fun i =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            i)
                                          (fun b =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                bootstrap0)
                                              (fun delegate0_after =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                    delegate0_after delegate0)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        bootstrap0 balance0 fee
                                                    end))))))))))
        end)
  end.

Definition bootstrap_delegate_cannot_be_removed {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          let bootstrap :=
            Tezos_protocol_environment_alpha__Environment.List.hd
              bootstrap_contracts in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                (fun balance =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                    (fun delegate =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                        (fun manager =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                              op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap
                              None)
                            (fun set_delegate =>
                              if
                                op_star_t_y_p_e_minus_e_r_r_o_r_star fee balance
                                then
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    set_delegate)
                                  (fun err =>
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                      err
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | Contract_storage.Balance_too_low _ _ _
                                          => true
                                        | _ => false
                                        end))
                              else
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (expect_no_change_registered_delegate_pkh
                                      (pkh manager)) i set_delegate)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        bootstrap)
                                      (fun delegate_after =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            delegate delegate_after)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                bootstrap balance fee
                                            end))))))))
        end)
  end.

Definition delegate_can_be_changed_from_unregistered_contract {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          let bootstrap0 :=
            Tezos_protocol_environment_alpha__Environment.List.hd
              bootstrap_contracts in
          let bootstrap1 :=
            op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap_contracts 1 in
          let unregistered_account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
          let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
          let unregistered :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
              unregistered_pkh in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap0)
                (fun manager0 =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap1)
                    (fun manager1 =>
                      let credit := op_star_t_y_p_e_minus_e_r_r_o_r_star 10 in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                          op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap0
                          unregistered credit)
                        (fun credit_contract =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap0)
                            (fun balance =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                  credit_contract)
                                (fun i =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      unregistered (Some (pkh manager0)))
                                    (fun set_delegate =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                          set_delegate)
                                        (fun i =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              unregistered)
                                            (fun delegate =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  delegate (pkh manager0))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        fee
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        unregistered
                                                        (Some (pkh manager1)))
                                                      (fun change_delegate =>
                                                        if
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            fee balance then
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              i change_delegate)
                                                            (fun err =>
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                err
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  |
                                                                    Contract_storage.Balance_too_low
                                                                      _ _ _ =>
                                                                    true
                                                                  | _ => false
                                                                  end))
                                                        else
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              i change_delegate)
                                                            (fun i =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  unregistered)
                                                                (fun
                                                                  delegate_after
                                                                  =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                      delegate_after
                                                                      (pkh
                                                                        manager1))
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | tt =>
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          unregistered
                                                                          credit
                                                                          fee
                                                                      end))))
                                                  end))))))))))
        end)
  end.

Definition delegate_can_be_removed_from_unregistered_contract {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          let bootstrap :=
            Tezos_protocol_environment_alpha__Environment.List.hd
              bootstrap_contracts in
          let unregistered_account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
          let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
          let unregistered :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
              unregistered_pkh in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                (fun manager =>
                  let credit := op_star_t_y_p_e_minus_e_r_r_o_r_star 10 in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                      op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap
                      unregistered credit)
                    (fun credit_contract =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                        (fun balance =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                              credit_contract)
                            (fun i =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  unregistered (Some (pkh manager)))
                                (fun set_delegate =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                      set_delegate)
                                    (fun i =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          unregistered)
                                        (fun delegate =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              delegate (pkh manager))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    fee
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    unregistered None)
                                                  (fun delete_delegate =>
                                                    if
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        fee balance then
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          i delete_delegate)
                                                        (fun err =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                            err
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              |
                                                                Contract_storage.Balance_too_low
                                                                  _ _ _ => true
                                                              | _ => false
                                                              end))
                                                    else
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          i delete_delegate)
                                                        (fun i =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                unregistered)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | None =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                | Some _ =>
                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                    "Expected delegate to be removed"
                                                                      % string
                                                                end))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  unregistered
                                                                  credit fee
                                                              end)))
                                              end)))))))))
        end)
  end.

Definition bootstrap_manager_already_registered_delegate {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                (fun manager =>
                  let pkh := pkh manager in
                  let impl_contract :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                      pkh in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract)
                    (fun balance =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          (Some pkh))
                        (fun sec_reg =>
                          if op_star_t_y_p_e_minus_e_r_r_o_r_star fee balance
                            then
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star i sec_reg)
                              (fun err =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  err
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Contract_storage.Balance_too_low _ _ _ =>
                                      true
                                    | _ => false
                                    end))
                          else
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    cons
                                      (Environment.Ecoproto_error
                                        Delegate_storage.Active_delegate) _ =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                  | _ =>
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                      "Delegate is already active and operation should fail."
                                        % string
                                  end) i sec_reg)
                              (fun i =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  impl_contract balance fee)))))
        end)
  end.

Definition delegate_to_bootstrap_by_origination {A : Type}
  (fee : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                (fun manager =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                    (fun balance =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                          (pkh manager) op_star_t_y_p_e_minus_e_r_r_o_r_star
                          bootstrap op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (fun function_parameter =>
                          match function_parameter with
                          | (op, orig_contract) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                    (fun origination_burn =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                                              fee origination_burn)
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)))
                                        (fun total_fee =>
                                          if
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              fee balance then
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                i op)
                                              (fun err =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  err
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Contract_storage.Balance_too_low
                                                        _ _ _ => true
                                                    | _ => false
                                                    end))
                                          else
                                            if
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  total_fee balance)
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  balance fee) then
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  i
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      cons
                                                        (Environment.Ecoproto_error
                                                          (Contract.Balance_too_low
                                                            _ _ _)) _ =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                    | _ =>
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                        "Not enough balance for origination burn: operation should fail."
                                                          % string
                                                    end) op)
                                                (fun i =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      bootstrap balance fee)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            orig_contract)
                                                          (fun err =>
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                              err
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | _ => true
                                                                | _ => false
                                                                end))
                                                      end))
                                            else
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  i op)
                                                (fun i =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      orig_contract)
                                                    (fun delegate =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          delegate (pkh manager))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              bootstrap balance
                                                              total_fee
                                                          end)))))
                                end)
                          end))))
        end)
  end.

Definition tests_bootstrap_contracts {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      "bootstrap contracts delegate to themselves" % string variant
      bootstrap_manager_is_bootstrap_delegate)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        "bootstrap contracts can change their delegate (small fee)" % string
        variant
        (bootstrap_delegate_cannot_change
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "bootstrap contracts can change their delegate (max fee)" % string
          variant
          (bootstrap_delegate_cannot_change op_star_t_y_p_e_minus_e_r_r_o_r_star))
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "bootstrap contracts cannot remove their delegation (small fee)" %
              string variant
            (bootstrap_delegate_cannot_be_removed
              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              "bootstrap contracts cannot remove their delegation (max fee)" %
                string variant
              (bootstrap_delegate_cannot_be_removed
                op_star_t_y_p_e_minus_e_r_r_o_r_star))
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "contracts not registered as delegate can remove their delegation (small fee)"
                  % string variant
                (delegate_can_be_changed_from_unregistered_contract
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "contracts not registered as delegate can remove their delegation (max fee)"
                    % string variant
                  (delegate_can_be_changed_from_unregistered_contract
                    op_star_t_y_p_e_minus_e_r_r_o_r_star))
                (cons
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "contracts not registered as delegate can remove their delegation (small fee)"
                      % string variant
                    (delegate_can_be_removed_from_unregistered_contract
                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                  (cons
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      "contracts not registered as delegate can remove their delegation (max fee)"
                        % string variant
                      (delegate_can_be_removed_from_unregistered_contract
                        op_star_t_y_p_e_minus_e_r_r_o_r_star))
                    (cons
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "bootstrap keys are already registered as delegate keys (small fee)"
                          % string variant
                        (bootstrap_manager_already_registered_delegate
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                      (cons
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          "bootstrap keys are already registered as delegate keys (max fee)"
                            % string variant
                          (bootstrap_manager_already_registered_delegate
                            op_star_t_y_p_e_minus_e_r_r_o_r_star))
                        (cons
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            "bootstrap manager can be delegate (init origination, small fee)"
                              % string variant
                            (delegate_to_bootstrap_by_origination
                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                          (cons
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              "bootstrap manager can be delegate (init origination, edge case)"
                                % string variant
                              (delegate_to_bootstrap_by_origination
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  3999999705000)))
                            (cons
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                "bootstrap manager can be delegate (init origination, large fee)"
                                  % string variant
                                (delegate_to_bootstrap_by_origination
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star 10000000)))
                              []))))))))))))).

Definition expect_unregistered_key {A : Type}
  (pkh : A)
  (function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  |
    cons (Environment.Ecoproto_error (Roll_storage.Unregistered_delegate pkh0))
      _ => Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
      "Delegate key is not registered: operation should fail." % string
  end.

Definition unregistered_delegate_key_init_origination {A : Type}
  (fee : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star fee unregistered_pkh
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | (op, orig_contract) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                op_star_t_y_p_e_minus_e_r_r_o_r_star))
                            (fun origination_burn =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                                    fee origination_burn))
                                (fun _total_fee =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      bootstrap)
                                    (fun balance =>
                                      if
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                          balance then
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            i op)
                                          (fun err =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              err
                                              (fun function_parameter =>
                                                match function_parameter with
                                                |
                                                  Contract_storage.Balance_too_low
                                                    _ _ _ => true
                                                | _ => false
                                                end))
                                      else
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (expect_unregistered_key
                                              unregistered_pkh) i op)
                                          (fun i =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                bootstrap balance fee)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      orig_contract)
                                                    (fun err =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                        err
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | _ => true
                                                          | _ => false
                                                          end))
                                                end)))))
                        end)
                  end))
        end)
  end.

Definition unregistered_delegate_key_init_delegation {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              let unregistered_delegate_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_delegate_pkh :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let credit := op_star_t_y_p_e_minus_e_r_r_o_r_star 10 in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  credit)
                (fun credit_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i credit_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          credit)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some unregistered_delegate_pkh))
                              (fun delegate_op =>
                                if
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                    credit then
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                      delegate_op)
                                    (fun err =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        err
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            Contract_storage.Balance_too_low _ _
                                              _ => true
                                          | _ => false
                                          end))
                                else
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                      (expect_unregistered_key
                                        unregistered_delegate_pkh) delegate_op)
                                    (fun i =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          impl_contract credit fee)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                impl_contract)
                                              (fun err =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  err
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | _ => true
                                                    | _ => false
                                                    end))
                                          end)))
                          end))))
        end)
  end.

Definition unregistered_delegate_key_switch_delegation {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let bootstrap_pkh :=
                Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                    bootstrap)
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    Tezos_protocol_environment_alpha__Environment.Pervasives.__POS__)
                in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              let unregistered_delegate_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_delegate_pkh :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let credit := op_star_t_y_p_e_minus_e_r_r_o_r_star 10 in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  credit)
                (fun init_credit =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i init_credit)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          credit)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some bootstrap_pkh))
                              (fun delegate_op =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    delegate_op)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        bootstrap)
                                      (fun delegate_pkh =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            bootstrap_pkh delegate_pkh)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  fee
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  impl_contract
                                                  (Some
                                                    unregistered_delegate_pkh))
                                                (fun delegate_op =>
                                                  if
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      fee credit then
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        i delegate_op)
                                                      (fun err =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          err
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            |
                                                              Contract_storage.Balance_too_low
                                                                _ _ _ => true
                                                            | _ => false
                                                            end))
                                                  else
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        i
                                                        (expect_unregistered_key
                                                          unregistered_delegate_pkh)
                                                        delegate_op)
                                                      (fun i =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            impl_contract credit
                                                            fee)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  bootstrap)
                                                                (fun
                                                                  delegate_pkh_after
                                                                  =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                    delegate_pkh
                                                                    delegate_pkh_after)
                                                            end)))
                                            end))))
                          end))))
        end)
  end.

Definition unregistered_delegate_key_init_origination_credit {A B C : Type}
  (fee : A) (amount : B) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap)
                              (fun balance =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                    unregistered_pkh
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    bootstrap
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (op, orig_contract) =>
                                      if
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                          balance then
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            i op)
                                          (fun err =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              err
                                              (fun function_parameter =>
                                                match function_parameter with
                                                |
                                                  Contract_storage.Balance_too_low
                                                    _ _ _ => true
                                                | _ => false
                                                end))
                                      else
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (expect_unregistered_key
                                              unregistered_pkh) i op)
                                          (fun i =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                bootstrap balance fee)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      orig_contract)
                                                    (fun err =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                        err
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | _ => true
                                                          | _ => false
                                                          end))
                                                end))
                                    end))
                          end))))
        end)
  end.

Definition unregistered_delegate_key_init_delegation_credit {A B : Type}
  (fee : A) (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              let unregistered_delegate_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_delegate_pkh :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            let credit :=
                              op_star_t_y_p_e_minus_e_r_r_o_r_star 10 in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                                  credit amount))
                              (fun balance =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    bootstrap impl_contract credit)
                                  (fun init_credit =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                        init_credit)
                                      (fun i =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            impl_contract balance)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  fee
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  impl_contract
                                                  (Some
                                                    unregistered_delegate_pkh))
                                                (fun delegate_op =>
                                                  if
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      fee credit then
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        i delegate_op)
                                                      (fun err =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          err
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            |
                                                              Contract_storage.Balance_too_low
                                                                _ _ _ => true
                                                            | _ => false
                                                            end))
                                                  else
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (expect_unregistered_key
                                                          unregistered_delegate_pkh)
                                                        i delegate_op)
                                                      (fun i =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            impl_contract
                                                            balance fee)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | tt =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  impl_contract)
                                                                (fun err =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                    err
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | _ =>
                                                                        true
                                                                      | _ =>
                                                                        false
                                                                      end))
                                                            end)))
                                            end))))
                          end))))
        end)
  end.

Definition unregistered_delegate_key_switch_delegation_credit {A B : Type}
  (fee : A) (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let bootstrap_pkh :=
                Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                    bootstrap)
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    Tezos_protocol_environment_alpha__Environment.Pervasives.__POS__)
                in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              let unregistered_delegate_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_delegate_pkh :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            let credit :=
                              op_star_t_y_p_e_minus_e_r_r_o_r_star 10 in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                                  credit amount))
                              (fun balance =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    bootstrap impl_contract credit)
                                  (fun init_credit =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                        init_credit)
                                      (fun i =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            impl_contract balance)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  impl_contract
                                                  (Some bootstrap_pkh))
                                                (fun delegate_op =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      i delegate_op)
                                                    (fun i =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          bootstrap)
                                                        (fun delegate_pkh =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                              bootstrap_pkh
                                                              delegate_pkh)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    fee
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    impl_contract
                                                                    (Some
                                                                      unregistered_delegate_pkh))
                                                                  (fun
                                                                    delegate_op
                                                                    =>
                                                                    if
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        fee
                                                                        credit
                                                                      then
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          i
                                                                          delegate_op)
                                                                        (fun err
                                                                          =>
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                            err
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                Contract_storage.Balance_too_low
                                                                                  _
                                                                                  _
                                                                                  _
                                                                                =>
                                                                                true
                                                                              |
                                                                                _
                                                                                =>
                                                                                false
                                                                              end))
                                                                    else
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          (expect_unregistered_key
                                                                            unregistered_delegate_pkh)
                                                                          i
                                                                          delegate_op)
                                                                        (fun i
                                                                          =>
                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              impl_contract
                                                                              balance
                                                                              fee)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    impl_contract)
                                                                                  (fun
                                                                                    delegate
                                                                                    =>
                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                        delegate
                                                                                        unregistered_delegate_pkh)
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          tt
                                                                                          =>
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                            delegate
                                                                                            bootstrap_pkh
                                                                                        end))
                                                                              end)))
                                                              end))))
                                            end))))
                          end))))
        end)
  end.

Definition unregistered_delegate_key_init_origination_credit_debit
  {A B C : Type} (fee : A) (amount : B) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract bootstrap amount)
                              (fun debit_contract =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    debit_contract)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              bootstrap)
                                            (fun balance =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  fee unregistered_pkh
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  bootstrap
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | (op, orig_contract) =>
                                                    if
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        fee balance then
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          i op)
                                                        (fun err =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                            err
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              |
                                                                Contract_storage.Balance_too_low
                                                                  _ _ _ => true
                                                              | _ => false
                                                              end))
                                                    else
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (expect_unregistered_key
                                                            unregistered_pkh) i
                                                          op)
                                                        (fun i =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              bootstrap balance
                                                              fee)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    orig_contract)
                                                                  (fun err =>
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                      err
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | _ =>
                                                                          true
                                                                        | _ =>
                                                                          false
                                                                        end))
                                                              end))
                                                  end))
                                        end)))
                          end))))
        end)
  end.

Definition unregistered_delegate_key_init_delegation_credit_debit {A B C : Type}
  (amount : A) (fee : B) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              let unregistered_delegate_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_delegate_pkh :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract bootstrap amount)
                              (fun debit_contract =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    debit_contract)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          let credit :=
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              10 in
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              bootstrap impl_contract credit)
                                            (fun credit_contract =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  i credit_contract)
                                                (fun i =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      impl_contract credit)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | _ =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            fee
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            impl_contract
                                                            (Some
                                                              unregistered_delegate_pkh))
                                                          (fun delegate_op =>
                                                            if
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                fee credit then
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  i delegate_op)
                                                                (fun err =>
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                    err
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      |
                                                                        Contract_storage.Balance_too_low
                                                                          _ _ _
                                                                        => true
                                                                      | _ =>
                                                                        false
                                                                      end))
                                                            else
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  (expect_unregistered_key
                                                                    unregistered_delegate_pkh)
                                                                  i delegate_op)
                                                                (fun i =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      impl_contract
                                                                      credit fee)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | tt =>
                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            impl_contract)
                                                                          (fun
                                                                            err
                                                                            =>
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                              err
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  _
                                                                                  =>
                                                                                  true
                                                                                |
                                                                                  _
                                                                                  =>
                                                                                  false
                                                                                end))
                                                                      end)))
                                                      end)))
                                        end)))
                          end))))
        end)
  end.

Definition unregistered_delegate_key_switch_delegation_credit_debit
  {A B C : Type} (fee : A) (amount : B) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let bootstrap_pkh :=
                Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
                    bootstrap)
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    Tezos_protocol_environment_alpha__Environment.Pervasives.__POS__)
                in
              let unregistered_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              let unregistered_delegate_account :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_delegate_pkh :=
                op_star_t_y_p_e_minus_e_r_r_o_r_star in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract bootstrap amount)
                              (fun debit_contract =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    debit_contract)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          let credit :=
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              10 in
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              bootstrap impl_contract credit)
                                            (fun credit_contract =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  i credit_contract)
                                                (fun i =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      impl_contract credit)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | _ =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            impl_contract
                                                            (Some bootstrap_pkh))
                                                          (fun delegate_op =>
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                i delegate_op)
                                                              (fun i =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    bootstrap)
                                                                  (fun
                                                                    delegate_pkh
                                                                    =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                        bootstrap_pkh
                                                                        delegate_pkh)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | tt =>
                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              fee
                                                                              impl_contract
                                                                              (Some
                                                                                unregistered_delegate_pkh))
                                                                            (fun
                                                                              delegate_op
                                                                              =>
                                                                              if
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  fee
                                                                                  credit
                                                                                then
                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    i
                                                                                    delegate_op)
                                                                                  (fun
                                                                                    err
                                                                                    =>
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                      err
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          Contract_storage.Balance_too_low
                                                                                            _
                                                                                            _
                                                                                            _
                                                                                          =>
                                                                                          true
                                                                                        |
                                                                                          _
                                                                                          =>
                                                                                          false
                                                                                        end))
                                                                              else
                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    (expect_unregistered_key
                                                                                      unregistered_delegate_pkh)
                                                                                    i
                                                                                    delegate_op)
                                                                                  (fun
                                                                                    i
                                                                                    =>
                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        impl_contract
                                                                                        credit
                                                                                        fee)
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          tt
                                                                                          =>
                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              impl_contract)
                                                                                            (fun
                                                                                              delegate
                                                                                              =>
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                delegate
                                                                                                unregistered_delegate_pkh)
                                                                                        end)))
                                                                        end))))
                                                      end)))
                                        end)))
                          end))))
        end)
  end.

Definition failed_self_delegation_no_transaction {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract)
                (fun balance =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                      balance)
                    (fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                            (Some unregistered_pkh))
                          (fun self_delegation =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                self_delegation)
                              (fun err =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  err
                                  (fun function_parameter =>
                                    match function_parameter with
                                    |
                                      Contract_storage.Empty_implicit_contract
                                        pkh =>
                                      if
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star pkh
                                          unregistered_pkh then
                                        true
                                      else
                                        false
                                    | _ => false
                                    end)))
                      end)))
        end)
  end.

Definition failed_self_delegation_emptied_implicit_contract {A B : Type}
  (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let unregistered_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  unregistered_pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract bootstrap amount)
                              (fun create_contract =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    create_contract)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              impl_contract
                                              (Some unregistered_pkh))
                                            (fun self_delegation =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  i self_delegation)
                                                (fun err =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                    err
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      |
                                                        Contract_storage.Empty_implicit_contract
                                                          pkh =>
                                                        if
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            pkh unregistered_pkh
                                                          then
                                                          true
                                                        else
                                                          false
                                                      | _ => false
                                                      end)))
                                        end)))
                          end))))
        end)
  end.

Definition valid_delegate_registration_init_delegation_credit {A B : Type}
  (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let delegate_account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let delegate_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  delegate_pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some delegate_pkh))
                              (fun self_delegation =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    self_delegation)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract)
                                      (fun delegate =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            delegate delegate_pkh)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              let unregistered_account :=
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  tt in
                                              let unregistered_pkh :=
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                in
                                              let delegator :=
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                  unregistered_pkh in
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  bootstrap delegator
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
                                                (fun credit_contract =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      i credit_contract)
                                                    (fun i =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          delegator)
                                                        (fun err =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                              err
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | _ => true
                                                                | _ => false
                                                                end))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | _ =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    delegator
                                                                    (Some
                                                                      (pkh
                                                                        delegate_account)))
                                                                  (fun
                                                                    delegation
                                                                    =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        i
                                                                        delegation)
                                                                      (fun i =>
                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            delegator)
                                                                          (fun
                                                                            delegator_delegate
                                                                            =>
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                              delegator_delegate
                                                                              delegate_pkh)))
                                                              end))))
                                            end))))
                          end))))
        end)
  end.

Definition valid_delegate_registration_switch_delegation_credit {A B : Type}
  (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let delegate_account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let delegate_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  delegate_pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some delegate_pkh))
                              (fun self_delegation =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    self_delegation)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract)
                                      (fun delegate =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            delegate delegate_pkh)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              let unregistered_account :=
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  tt in
                                              let unregistered_pkh :=
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                in
                                              let delegator :=
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                  unregistered_pkh in
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  bootstrap delegator
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
                                                (fun credit_contract =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      i credit_contract)
                                                    (fun i =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          bootstrap)
                                                        (fun bootstrap_manager
                                                          =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              delegator
                                                              (Some
                                                                (pkh
                                                                  bootstrap_manager)))
                                                            (fun delegation =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  i delegation)
                                                                (fun i =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      delegator)
                                                                    (fun
                                                                      delegator_delegate
                                                                      =>
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                          delegator_delegate
                                                                          (pkh
                                                                            bootstrap_manager))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | _ =>
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                delegator
                                                                                (Some
                                                                                  (pkh
                                                                                    delegate_account)))
                                                                              (fun
                                                                                delegation
                                                                                =>
                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    i
                                                                                    delegation)
                                                                                  (fun
                                                                                    i
                                                                                    =>
                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        delegator)
                                                                                      (fun
                                                                                        delegator_delegate
                                                                                        =>
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                          delegator_delegate
                                                                                          delegate_pkh)))
                                                                          end)))))))
                                            end))))
                          end))))
        end)
  end.

Definition valid_delegate_registration_init_delegation_credit_debit {A B : Type}
  (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let delegate_account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let delegate_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  delegate_pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some delegate_pkh))
                              (fun self_delegation =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    self_delegation)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract)
                                      (fun delegate =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            delegate_pkh delegate)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  impl_contract bootstrap amount)
                                                (fun empty_contract =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      i empty_contract)
                                                    (fun i =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          impl_contract
                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | _ =>
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                impl_contract)
                                                              (fun delegate =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                    delegate_pkh
                                                                    delegate)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | _ =>
                                                                      let
                                                                        unregistered_account :=
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          tt in
                                                                      let
                                                                        unregistered_pkh :=
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        in
                                                                      let
                                                                        delegator :=
                                                                        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                          unregistered_pkh
                                                                        in
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          bootstrap
                                                                          delegator
                                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
                                                                        (fun
                                                                          credit_contract
                                                                          =>
                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              i
                                                                              credit_contract)
                                                                            (fun
                                                                              i
                                                                              =>
                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  delegator)
                                                                                (fun
                                                                                  err
                                                                                  =>
                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                      err
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          _
                                                                                          =>
                                                                                          true
                                                                                        |
                                                                                          _
                                                                                          =>
                                                                                          false
                                                                                        end))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        _
                                                                                        =>
                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            delegator
                                                                                            (Some
                                                                                              (pkh
                                                                                                delegate_account)))
                                                                                          (fun
                                                                                            delegation
                                                                                            =>
                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                i
                                                                                                delegation)
                                                                                              (fun
                                                                                                i
                                                                                                =>
                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    delegator)
                                                                                                  (fun
                                                                                                    delegator_delegate
                                                                                                    =>
                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                      delegator_delegate
                                                                                                      delegate_pkh)))
                                                                                      end))))
                                                                    end))
                                                          end)))
                                            end))))
                          end))))
        end)
  end.

Definition valid_delegate_registration_switch_delegation_credit_debit
  {A B : Type} (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let delegate_account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let delegate_pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  delegate_pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  amount)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some delegate_pkh))
                              (fun self_delegation =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    self_delegation)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract)
                                      (fun delegate =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            delegate_pkh delegate)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  impl_contract bootstrap amount)
                                                (fun empty_contract =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      i empty_contract)
                                                    (fun i =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          impl_contract
                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | _ =>
                                                            let
                                                              unregistered_account :=
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                tt in
                                                            let
                                                              unregistered_pkh :=
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              in
                                                            let delegator :=
                                                              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                unregistered_pkh
                                                              in
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                bootstrap
                                                                delegator
                                                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
                                                              (fun
                                                                credit_contract
                                                                =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    i
                                                                    credit_contract)
                                                                  (fun i =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        bootstrap)
                                                                      (fun
                                                                        bootstrap_manager
                                                                        =>
                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            delegator
                                                                            (Some
                                                                              (pkh
                                                                                bootstrap_manager)))
                                                                          (fun
                                                                            delegation
                                                                            =>
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                i
                                                                                delegation)
                                                                              (fun
                                                                                i
                                                                                =>
                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    delegator)
                                                                                  (fun
                                                                                    delegator_delegate
                                                                                    =>
                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                        delegator_delegate
                                                                                        (pkh
                                                                                          bootstrap_manager))
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          _
                                                                                          =>
                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              delegator
                                                                                              (Some
                                                                                                (pkh
                                                                                                  delegate_account)))
                                                                                            (fun
                                                                                              delegation
                                                                                              =>
                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  i
                                                                                                  delegation)
                                                                                                (fun
                                                                                                  i
                                                                                                  =>
                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      delegator)
                                                                                                    (fun
                                                                                                      delegator_delegate
                                                                                                      =>
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                        delegator_delegate
                                                                                                        delegate_pkh)))
                                                                                        end)))))))
                                                          end)))
                                            end))))
                          end))))
        end)
  end.

Definition double_registration {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some pkh))
                              (fun self_delegation =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    self_delegation)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract (Some pkh))
                                      (fun second_registration =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            i second_registration)
                                          (fun err =>
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              err
                                              (fun function_parameter =>
                                                match function_parameter with
                                                |
                                                  Delegate_storage.Active_delegate
                                                  => true
                                                | _ => false
                                                end)))))
                          end))))
        end)
  end.

Definition double_registration_when_empty {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some pkh))
                              (fun self_delegation =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    self_delegation)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract bootstrap
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                                      (fun empty_contract =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            i empty_contract)
                                          (fun i =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                impl_contract
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | _ =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      impl_contract (Some pkh))
                                                    (fun second_registration =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          i second_registration)
                                                        (fun err =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                            err
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              |
                                                                Delegate_storage.Active_delegate
                                                                => true
                                                              | _ => false
                                                              end)))
                                                end)))))
                          end))))
        end)
  end.

Definition double_registration_when_recredited {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              let account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let pkh := op_star_t_y_p_e_minus_e_r_r_o_r_star in
              let impl_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  pkh in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap impl_contract
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                (fun create_contract =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i create_contract)
                    (fun i =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          op_star_t_y_p_e_minus_e_r_r_o_r_star impl_contract
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                impl_contract (Some pkh))
                              (fun self_delegation =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                    self_delegation)
                                  (fun i =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        impl_contract bootstrap
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                                      (fun empty_contract =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            i empty_contract)
                                          (fun i =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                impl_contract
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | _ =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      bootstrap impl_contract
                                                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                                                    (fun create_contract =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          i create_contract)
                                                        (fun i =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              impl_contract
                                                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | _ =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    impl_contract
                                                                    (Some pkh))
                                                                  (fun
                                                                    second_registration
                                                                    =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        i
                                                                        second_registration)
                                                                      (fun err
                                                                        =>
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                          err
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            |
                                                                              Delegate_storage.Active_delegate
                                                                              =>
                                                                              true
                                                                            | _
                                                                              =>
                                                                              false
                                                                            end)))
                                                              end)))
                                                end)))))
                          end))))
        end)
  end.

Definition unregistered_and_unrevealed_self_delegate_key_init_delegation
  {A B : Type} (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              match op_star_t_y_p_e_minus_e_r_r_o_r_star tt with
              | _ =>
                match op_star_t_y_p_e_minus_e_r_r_o_r_star tt with
                | _ =>
                  let contract :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                      op_star_t_y_p_e_minus_e_r_r_o_r_star in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap contract
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star 10))
                    (fun op =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star i op)
                        (fun i =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                              op_star_t_y_p_e_minus_e_r_r_o_r_star contract
                              (Some op_star_t_y_p_e_minus_e_r_r_o_r_star))
                            (fun op =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star contract)
                                (fun balance =>
                                  if
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                      balance then
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star i op)
                                      (fun err =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                          err
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              Contract_storage.Balance_too_low _
                                                _ _ => true
                                            | _ => false
                                            end))
                                  else
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        (expect_unregistered_key
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                        i op)
                                      (fun i =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          contract balance fee)))))
                end
              end)
        end)
  end.

Definition unregistered_and_revealed_self_delegate_key_init_delegation
  {A B : Type} (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              match op_star_t_y_p_e_minus_e_r_r_o_r_star tt with
              | _ =>
                match op_star_t_y_p_e_minus_e_r_r_o_r_star tt with
                | _ =>
                  let contract :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                      op_star_t_y_p_e_minus_e_r_r_o_r_star in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap contract
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star 10))
                    (fun op =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star i op)
                        (fun i =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                            (fun op =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star i op)
                                (fun i =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      contract
                                      (Some op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                    (fun op =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          contract)
                                        (fun balance =>
                                          if
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              fee balance then
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                i op)
                                              (fun err =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  err
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Contract_storage.Balance_too_low
                                                        _ _ _ => true
                                                    | _ => false
                                                    end))
                                          else
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (expect_unregistered_key
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                i op)
                                              (fun i =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  contract balance fee)))))))
                end
              end)
        end)
  end.

Definition registered_self_delegate_key_init_delegation
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, bootstrap_contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let bootstrap :=
                Tezos_protocol_environment_alpha__Environment.List.hd
                  bootstrap_contracts in
              match op_star_t_y_p_e_minus_e_r_r_o_r_star tt with
              | _ =>
                match op_star_t_y_p_e_minus_e_r_r_o_r_star tt with
                | _ =>
                  let contract :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                      op_star_t_y_p_e_minus_e_r_r_o_r_star in
                  let delegate_contract :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                      op_star_t_y_p_e_minus_e_r_r_o_r_star in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap contract
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star 10))
                    (fun op =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star i op)
                        (fun i =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star bootstrap
                              delegate_contract
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star 1))
                            (fun op =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star i op)
                                (fun i =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                    (fun op =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star i
                                          op)
                                        (fun i =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              delegate_contract
                                              (Some
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                            (fun op =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  i op)
                                                (fun i =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      contract
                                                      (Some
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                                    (fun op =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          i op)
                                                        (fun i =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              contract)
                                                            (fun delegate =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                  delegate
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                  end))))))))))))
                end
              end)
        end)
  end.

Definition tests_delegate_registration {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      "unregistered delegate key (origination, small fee)" % string variant
      (unregistered_delegate_key_init_origination
        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        "unregistered delegate key (origination, edge case fee)" % string
        variant
        (unregistered_delegate_key_init_origination
          (op_star_t_y_p_e_minus_e_r_r_o_r_star 3999488)))
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "unregistered delegate key (origination, large fee)" % string variant
          (unregistered_delegate_key_init_origination
            (op_star_t_y_p_e_minus_e_r_r_o_r_star 10000000)))
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "unregistered delegate key (init with delegation, small fee)" %
              string variant
            (unregistered_delegate_key_init_delegation
              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              "unregistered delegate key (init with delegation, max fee)" %
                string variant
              (unregistered_delegate_key_init_delegation
                op_star_t_y_p_e_minus_e_r_r_o_r_star))
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "unregistered delegate key (switch with delegation, small fee)"
                  % string variant
                (unregistered_delegate_key_switch_delegation
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "unregistered delegate key (switch with delegation, max fee)"
                    % string variant
                  (unregistered_delegate_key_switch_delegation
                    op_star_t_y_p_e_minus_e_r_r_o_r_star))
                (cons
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "unregistered delegate key - credit/debit 1μꜩ (origination, small fee)"
                      % string variant
                    (unregistered_delegate_key_init_origination_credit_debit
                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez
                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                  (cons
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      "unregistered delegate key - credit/debit 1μꜩ (origination, large fee)"
                        % string variant
                      (unregistered_delegate_key_init_origination_credit_debit
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                    (cons
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "unregistered delegate key - credit/debit 1μꜩ (init with delegation, small fee)"
                          % string variant
                        (unregistered_delegate_key_init_delegation_credit_debit
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez
                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                      (cons
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          "unregistered delegate key - credit/debit 1μꜩ (init with delegation, large fee)"
                            % string variant
                          (unregistered_delegate_key_init_delegation_credit_debit
                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez
                            op_star_t_y_p_e_minus_e_r_r_o_r_star))
                        (cons
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, small fee)"
                              % string variant
                            (unregistered_delegate_key_switch_delegation_credit_debit
                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez
                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                          (cons
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, large fee)"
                                % string variant
                              (unregistered_delegate_key_switch_delegation_credit_debit
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                            (cons
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                "unregistered delegate key - credit 1μꜩ (origination, small fee)"
                                  % string variant
                                (unregistered_delegate_key_init_origination_credit
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                              (cons
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  "unregistered delegate key - credit 1μꜩ (origination, edge case fee)"
                                    % string variant
                                  (unregistered_delegate_key_init_origination_credit
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      3999488)
                                    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                (cons
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    "unregistered delegate key - credit 1μꜩ (origination, large fee)"
                                      % string variant
                                    (unregistered_delegate_key_init_origination_credit
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        10000000)
                                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                  (cons
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      "unregistered delegate key - credit 1μꜩ (init with delegation, small fee)"
                                        % string variant
                                      (unregistered_delegate_key_init_delegation_credit
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                    (cons
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        "unregistered delegate key - credit 1μꜩ (init with delegation, large fee)"
                                          % string variant
                                        (unregistered_delegate_key_init_delegation_credit
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                      (cons
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          "unregistered delegate key - credit 1μꜩ (switch with delegation, small fee)"
                                            % string variant
                                          (unregistered_delegate_key_switch_delegation_credit
                                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez
                                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                        (cons
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            "unregistered delegate key - credit 1μꜩ (switch with delegation, large fee)"
                                              % string variant
                                            (unregistered_delegate_key_switch_delegation_credit
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                          (cons
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              "unregistered and unrevealed self-delegation (small fee)"
                                                % string variant
                                              (unregistered_and_unrevealed_self_delegate_key_init_delegation
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                            (cons
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                "unregistered and unrevealed self-delegation (large fee)"
                                                  % string variant
                                                (unregistered_and_unrevealed_self_delegate_key_init_delegation
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                              (cons
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  "unregistered and revealed self-delegation (small fee)"
                                                    % string variant
                                                  (unregistered_and_revealed_self_delegate_key_init_delegation
                                                    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                                (cons
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    "unregistered and revealed self-delegation  large fee)"
                                                      % string variant
                                                    (unregistered_and_revealed_self_delegate_key_init_delegation
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                                  (cons
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      "registered and revelead self-delegation"
                                                        % string variant
                                                      registered_self_delegate_key_init_delegation)
                                                    (cons
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        "failed self-delegation: no transaction"
                                                          % string variant
                                                        failed_self_delegation_no_transaction)
                                                      (cons
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          "failed self-delegation: credit & debit 1μꜩ"
                                                            % string variant
                                                          (failed_self_delegation_emptied_implicit_contract
                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                                        (cons
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            "valid delegate registration: credit 1μꜩ, self delegation (init with delegation)"
                                                              % string variant
                                                            (valid_delegate_registration_init_delegation_credit
                                                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                                          (cons
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              "valid delegate registration: credit 1μꜩ, self delegation (switch with delegation)"
                                                                % string variant
                                                              (valid_delegate_registration_switch_delegation_credit
                                                                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                                            (cons
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ (init with delegation)"
                                                                  % string
                                                                variant
                                                                (valid_delegate_registration_init_delegation_credit_debit
                                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                                              (cons
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ (switch with delegation)"
                                                                    % string
                                                                  variant
                                                                  (valid_delegate_registration_switch_delegation_credit_debit
                                                                    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_mutez))
                                                                (cons
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    "double registration"
                                                                      % string
                                                                    variant
                                                                    double_registration)
                                                                  (cons
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      "double registration when delegate account is emptied"
                                                                        % string
                                                                      variant
                                                                      double_registration_when_empty)
                                                                    (cons
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        "double registration when delegate account is emptied and then recredited"
                                                                          %
                                                                          string
                                                                        variant
                                                                        double_registration_when_recredited)
                                                                      []))))))))))))))))))))))))))))))))).

Definition tests {A : Type} : list A :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
    tests_bootstrap_contracts tests_delegate_registration.
src/proto_alpha/lib_protocol/test/double_baking.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Double baking evidence operation may happen when a baker
    baked two different blocks on the same level. *)

open Protocol
open Alpha_context

(****************************************************************)
(*                  Utility functions                           *)
(****************************************************************)

let get_first_different_baker baker bakers =
  return
  @@ List.find
       (fun baker' -> Signature.Public_key_hash.( <> ) baker baker')
       bakers

let get_first_different_bakers ctxt =
  Context.get_bakers ctxt
  >>=? fun bakers ->
  let baker_1 = List.hd bakers in
  get_first_different_baker baker_1 (List.tl bakers)
  >>=? fun baker_2 -> return (baker_1, baker_2)

let get_first_different_endorsers ctxt =
  Context.get_endorsers ctxt
  >>=? fun endorsers ->
  let endorser_1 = (List.hd endorsers).delegate in
  let endorser_2 = (List.hd (List.tl endorsers)).delegate in
  return (endorser_1, endorser_2)

(** Bake two block at the same level using the same policy (i.e. same
    baker) *)
let block_fork ?policy contracts b =
  let (contract_a, contract_b) =
    (List.hd contracts, List.hd (List.tl contracts))
  in
  Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent
  >>=? fun operation ->
  Block.bake ?policy ~operation b
  >>=? fun blk_a -> Block.bake ?policy b >>=? fun blk_b -> return (blk_a, blk_b)

(****************************************************************)
(*                        Tests                                 *)
(****************************************************************)

(** Simple scenario where two blocks are baked by a same baker and
    exposed by a double baking evidence operation *)
let valid_double_baking_evidence () =
  Context.init 2
  >>=? fun (b, contracts) ->
  Context.get_bakers (B b)
  >>=? fun bakers ->
  let priority_0_baker = List.hd bakers in
  block_fork ~policy:(By_priority 0) contracts b
  >>=? fun (blk_a, blk_b) ->
  Op.double_baking (B blk_a) blk_a.header blk_b.header
  >>=? fun operation ->
  Block.bake ~policy:(Excluding [priority_0_baker]) ~operation blk_a
  >>=? fun blk ->
  (* Check that the frozen deposit, the fees and rewards are removed *)
  iter_s
    (fun kind ->
      let contract =
        Alpha_context.Contract.implicit_contract priority_0_baker
      in
      Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero)
    [Deposit; Fees; Rewards]

(****************************************************************)
(*  The following test scenarios are supposed to raise errors.  *)
(****************************************************************)

(** Check that a double baking operation fails if it exposes the same two blocks *)
let same_blocks () =
  Context.init 2
  >>=? fun (b, _contracts) ->
  Block.bake b
  >>=? fun ba ->
  Op.double_baking (B ba) ba.header ba.header
  >>=? fun operation ->
  Block.bake ~operation ba
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_double_baking_evidence _ ->
          true
      | _ ->
          false)
  >>=? fun () -> return_unit

(** Check that a double baking operation exposing two blocks with
    different levels fails *)
let different_levels () =
  Context.init 2
  >>=? fun (b, contracts) ->
  block_fork ~policy:(By_priority 0) contracts b
  >>=? fun (blk_a, blk_b) ->
  Block.bake blk_b
  >>=? fun blk_b_2 ->
  Op.double_baking (B blk_a) blk_a.header blk_b_2.header
  >>=? fun operation ->
  Block.bake ~operation blk_a
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_double_baking_evidence _ ->
          true
      | _ ->
          false)

(** Check that a double baking operation exposing two yet to be baked
    blocks fails *)
let too_early_double_baking_evidence () =
  Context.init 2
  >>=? fun (b, contracts) ->
  block_fork ~policy:(By_priority 0) contracts b
  >>=? fun (blk_a, blk_b) ->
  Op.double_baking (B b) blk_a.header blk_b.header
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Too_early_double_baking_evidence _ ->
          true
      | _ ->
          false)

(** Check that after [preserved_cycles + 1], it is not possible to
    create a double baking operation anymore *)
let too_late_double_baking_evidence () =
  Context.init 2
  >>=? fun (b, contracts) ->
  Context.get_constants (B b)
  >>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
  block_fork ~policy:(By_priority 0) contracts b
  >>=? fun (blk_a, blk_b) ->
  fold_left_s
    (fun blk _ -> Block.bake_until_cycle_end blk)
    blk_a
    (1 -- (preserved_cycles + 1))
  >>=? fun blk ->
  Op.double_baking (B blk) blk_a.header blk_b.header
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Outdated_double_baking_evidence _ ->
          true
      | _ ->
          false)

(** Check that an invalid double baking evidence that exposes two block
    baking with same level made by different bakers fails *)
let different_delegates () =
  Context.init 2
  >>=? fun (b, _) ->
  get_first_different_bakers (B b)
  >>=? fun (baker_1, baker_2) ->
  Block.bake ~policy:(By_account baker_1) b
  >>=? fun blk_a ->
  Block.bake ~policy:(By_account baker_2) b
  >>=? fun blk_b ->
  Op.double_baking (B blk_a) blk_a.header blk_b.header
  >>=? fun operation ->
  Block.bake ~operation blk_a
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Apply.Inconsistent_double_baking_evidence _ ->
          true
      | _ ->
          false)

let wrong_signer () =
  (* Baker_2 bakes a block but baker signs it. *)
  let header_custom_signer baker baker_2 b =
    Block.Forge.forge_header ~policy:(By_account baker_2) b
    >>=? fun header ->
    Block.Forge.set_baker baker header |> Block.Forge.sign_header
  in
  Context.init 2
  >>=? fun (b, _) ->
  get_first_different_bakers (B b)
  >>=? fun (baker_1, baker_2) ->
  Block.bake ~policy:(By_account baker_1) b
  >>=? fun blk_a ->
  header_custom_signer baker_1 baker_2 b
  >>=? fun header_b ->
  Op.double_baking (B blk_a) blk_a.header header_b
  >>=? fun operation ->
  Block.bake ~operation blk_a
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Baking.Invalid_block_signature _ ->
          true
      | _ ->
          false)

let tests =
  [ Test.tztest
      "valid double baking evidence"
      `Quick
      valid_double_baking_evidence;
    (* Should fail*)
    Test.tztest "same blocks" `Quick same_blocks;
    Test.tztest "different levels" `Quick different_levels;
    Test.tztest
      "too early double baking evidence"
      `Quick
      too_early_double_baking_evidence;
    Test.tztest
      "too late double baking evidence"
      `Quick
      too_late_double_baking_evidence;
    Test.tztest "different delegates" `Quick different_delegates;
    Test.tztest "wrong delegate" `Quick wrong_signer ]
src/proto_alpha/lib_protocol/test/double_baking.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition get_first_different_baker {A B : Type}
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (bakers : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun baker' =>
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.op_lt_gt
          baker baker') bakers).

Definition get_first_different_bakers {A B : Type} (ctxt : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * B)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt)
    (fun bakers =>
      let baker_1 :=
        Tezos_protocol_environment_alpha__Environment.List.hd bakers in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (get_first_different_baker baker_1
          (Tezos_protocol_environment_alpha__Environment.List.tl bakers))
        (fun baker_2 =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (baker_1, baker_2))).

Definition get_first_different_endorsers {A B C : Type} (ctxt : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * C)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt)
    (fun endorsers =>
      let endorser_1 :=
        delegate
          (Tezos_protocol_environment_alpha__Environment.List.hd endorsers) in
      let endorser_2 :=
        delegate
          (Tezos_protocol_environment_alpha__Environment.List.hd
            (Tezos_protocol_environment_alpha__Environment.List.tl endorsers))
        in
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (endorser_1, endorser_2)).

Definition block_fork {A B C D E : Type}
  (policy : option A) (contracts : list B) (b : C)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (D * E)) :=
  match
    ((Tezos_protocol_environment_alpha__Environment.List.hd contracts),
      (Tezos_protocol_environment_alpha__Environment.List.hd
        (Tezos_protocol_environment_alpha__Environment.List.tl contracts))) with
  | (contract_a, contract_b) =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
        contract_a contract_b
        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one_cent)
      (fun operation =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star policy operation b)
          (fun blk_a =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star policy b)
              (fun blk_b =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (blk_a, blk_b))))
  end.

Definition valid_double_baking_evidence (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun bakers =>
              let priority_0_baker :=
                Tezos_protocol_environment_alpha__Environment.List.hd bakers in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (block_fork (Some op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  contracts b)
                (fun function_parameter =>
                  match function_parameter with
                  | (blk_a, blk_b) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star (header blk_a)
                        (header blk_b))
                      (fun operation =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk_a)
                          (fun blk =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.iter_s
                              (fun kind =>
                                let contract :=
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                    priority_0_baker in
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star contract
                                  kind
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                              (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (cons op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (cons op_star_t_y_p_e_minus_e_r_r_o_r_star [])))))
                  end))
        end)
  end.

Definition same_blocks (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, _contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun ba =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star (header ba) (header ba))
                (fun operation =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star operation ba)
                    (fun res =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          res
                          (fun function_parameter =>
                            match function_parameter with
                            | Apply.Invalid_double_baking_evidence _ => true
                            | _ => false
                            end))
                        (fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                          end))))
        end)
  end.

Definition different_levels {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (block_fork (Some op_star_t_y_p_e_minus_e_r_r_o_r_star) contracts b)
            (fun function_parameter =>
              match function_parameter with
              | (blk_a, blk_b) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star blk_b)
                  (fun blk_b_2 =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star (header blk_a)
                        (header blk_b_2))
                      (fun operation =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star operation blk_a)
                          (fun res =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                              res
                              (fun function_parameter =>
                                match function_parameter with
                                | Apply.Invalid_double_baking_evidence _ => true
                                | _ => false
                                end))))
              end)
        end)
  end.

Definition too_early_double_baking_evidence {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (block_fork (Some op_star_t_y_p_e_minus_e_r_r_o_r_star) contracts b)
            (fun function_parameter =>
              match function_parameter with
              | (blk_a, blk_b) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star (header blk_a)
                    (header blk_b))
                  (fun operation =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star operation b)
                      (fun res =>
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          res
                          (fun function_parameter =>
                            match function_parameter with
                            | Apply.Too_early_double_baking_evidence _ => true
                            | _ => false
                            end)))
              end)
        end)
  end.

Definition too_late_double_baking_evidence {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | {| parametric := {| preserved_cycles := preserved_cycles |} |}
                =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (block_fork (Some op_star_t_y_p_e_minus_e_r_r_o_r_star)
                    contracts b)
                  (fun function_parameter =>
                    match function_parameter with
                    | (blk_a, blk_b) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                          (fun blk =>
                            fun function_parameter =>
                              match function_parameter with
                              | _ => op_star_t_y_p_e_minus_e_r_r_o_r_star blk
                              end) blk_a
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star 1
                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                              preserved_cycles 1)))
                        (fun blk =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (header blk_a) (header blk_b))
                            (fun operation =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star operation
                                  blk)
                                (fun res =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    res
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | Apply.Outdated_double_baking_evidence _
                                        => true
                                      | _ => false
                                      end))))
                    end)
              end)
        end)
  end.

Definition different_delegates {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (get_first_different_bakers op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | (baker_1, baker_2) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                  (fun blk_a =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                      (fun blk_b =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star (header blk_a)
                            (header blk_b))
                          (fun operation =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star operation
                                blk_a)
                              (fun e =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  e
                                  (fun function_parameter =>
                                    match function_parameter with
                                    |
                                      Apply.Inconsistent_double_baking_evidence
                                        _ => true
                                    | _ => false
                                    end)))))
              end)
        end)
  end.

Definition wrong_signer {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    let header_custom_signer {B C D E : Type} (baker : B) (baker_2 : C) (b : D)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult E) :=
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star b)
        (fun header =>
          Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
            (op_star_t_y_p_e_minus_e_r_r_o_r_star baker header)
            op_star_t_y_p_e_minus_e_r_r_o_r_star) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (get_first_different_bakers op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | (baker_1, baker_2) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                  (fun blk_a =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (header_custom_signer baker_1 baker_2 b)
                      (fun header_b =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star (header blk_a)
                            header_b)
                          (fun operation =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star operation
                                blk_a)
                              (fun e =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  e
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Baking.Invalid_block_signature _ _ => true
                                    | _ => false
                                    end)))))
              end)
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      "valid double baking evidence" % string variant
      valid_double_baking_evidence)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star "same blocks" % string variant
        same_blocks)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star "different levels" % string
          variant different_levels)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "too early double baking evidence" % string variant
            too_early_double_baking_evidence)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              "too late double baking evidence" % string variant
              too_late_double_baking_evidence)
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "different delegates" % string variant different_delegates)
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star "wrong delegate" % string
                  variant wrong_signer) [])))))).
src/proto_alpha/lib_protocol/test/double_endorsement.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Double endorsement evidence operation may happen when an endorser
    endorsed two different blocks on the same level. *)

open Protocol
open Alpha_context

(****************************************************************)
(*                  Utility functions                           *)
(****************************************************************)

let get_first_different_baker baker bakers =
  return
  @@ List.find
       (fun baker' -> Signature.Public_key_hash.( <> ) baker baker')
       bakers

let get_first_different_bakers ctxt =
  Context.get_bakers ctxt
  >>=? fun bakers ->
  let baker_1 = List.hd bakers in
  get_first_different_baker baker_1 (List.tl bakers)
  >>=? fun baker_2 -> return (baker_1, baker_2)

let get_first_different_endorsers ctxt =
  Context.get_endorsers ctxt
  >>=? fun endorsers ->
  let endorser_1 = List.hd endorsers in
  let endorser_2 = List.hd (List.tl endorsers) in
  return (endorser_1, endorser_2)

let block_fork b =
  get_first_different_bakers (B b)
  >>=? fun (baker_1, baker_2) ->
  Block.bake ~policy:(By_account baker_1) b
  >>=? fun blk_a ->
  Block.bake ~policy:(By_account baker_2) b
  >>=? fun blk_b -> return (blk_a, blk_b)

(****************************************************************)
(*                        Tests                                 *)
(****************************************************************)

(** Simple scenario where two endorsements are made from the same
    delegate and exposed by a double_endorsement operation. Also verify
    that punishment is operated. *)
let valid_double_endorsement_evidence () =
  Context.init 2
  >>=? fun (b, _) ->
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (delegate, _slots) ->
  Op.endorsement ~delegate (B blk_a) ()
  >>=? fun endorsement_a ->
  Op.endorsement ~delegate (B blk_b) ()
  >>=? fun endorsement_b ->
  Block.bake ~operations:[Operation.pack endorsement_a] blk_a
  >>=? fun blk_a ->
  (* Block.bake ~operations:[endorsement_b] blk_b >>=? fun _ -> *)
  Op.double_endorsement (B blk_a) endorsement_a endorsement_b
  >>=? fun operation ->
  (* Bake with someone different than the bad endorser *)
  Context.get_bakers (B blk_a)
  >>=? fun bakers ->
  get_first_different_baker delegate bakers
  >>=? fun baker ->
  Block.bake ~policy:(By_account baker) ~operation blk_a
  >>=? fun blk ->
  (* Check that the frozen deposit, the fees and rewards are removed *)
  iter_s
    (fun kind ->
      let contract = Alpha_context.Contract.implicit_contract delegate in
      Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero)
    [Deposit; Fees; Rewards]

(****************************************************************)
(*  The following test scenarios are supposed to raise errors.  *)
(****************************************************************)

(** Check that an invalid double endorsement operation that exposes a valid
    endorsement fails. *)
let invalid_double_endorsement () =
  Context.init 10
  >>=? fun (b, _) ->
  Block.bake b
  >>=? fun b ->
  Op.endorsement (B b) ()
  >>=? fun endorsement ->
  Block.bake ~operation:(Operation.pack endorsement) b
  >>=? fun b ->
  Op.double_endorsement (B b) endorsement endorsement
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_double_endorsement_evidence ->
          true
      | _ ->
          false)

(** Check that a double endorsement added at the same time as a double
    endorsement operation fails. *)
let too_early_double_endorsement_evidence () =
  Context.init 2
  >>=? fun (b, _) ->
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (delegate, _slots) ->
  Op.endorsement ~delegate (B blk_a) ()
  >>=? fun endorsement_a ->
  Op.endorsement ~delegate (B blk_b) ()
  >>=? fun endorsement_b ->
  Op.double_endorsement (B b) endorsement_a endorsement_b
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Too_early_double_endorsement_evidence _ ->
          true
      | _ ->
          false)

(** Check that after [preserved_cycles + 1], it is not possible
    to create a double_endorsement anymore. *)
let too_late_double_endorsement_evidence () =
  Context.init 2
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (delegate, _slots) ->
  Op.endorsement ~delegate (B blk_a) ()
  >>=? fun endorsement_a ->
  Op.endorsement ~delegate (B blk_b) ()
  >>=? fun endorsement_b ->
  fold_left_s
    (fun blk _ -> Block.bake_until_cycle_end blk)
    blk_a
    (1 -- (preserved_cycles + 1))
  >>=? fun blk ->
  Op.double_endorsement (B blk) endorsement_a endorsement_b
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Outdated_double_endorsement_evidence _ ->
          true
      | _ ->
          false)

(** Check that an invalid double endorsement evidence that expose two
    endorsements made by two different endorsers fails. *)
let different_delegates () =
  Context.init 2
  >>=? fun (b, _) ->
  Block.bake b
  >>=? fun b ->
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (endorser_a, _a_slots) ->
  get_first_different_endorsers (B blk_b)
  >>=? fun (endorser_b1c, endorser_b2c) ->
  let endorser_b =
    if Signature.Public_key_hash.( = ) endorser_a endorser_b1c.delegate then
      endorser_b2c.delegate
    else endorser_b1c.delegate
  in
  Op.endorsement ~delegate:endorser_a (B blk_a) ()
  >>=? fun e_a ->
  Op.endorsement ~delegate:endorser_b (B blk_b) ()
  >>=? fun e_b ->
  Block.bake ~operation:(Operation.pack e_b) blk_b
  >>=? fun _ ->
  Op.double_endorsement (B blk_b) e_a e_b
  >>=? fun operation ->
  Block.bake ~operation blk_b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Inconsistent_double_endorsement_evidence _ ->
          true
      | _ ->
          false)

(** Check that a double endorsement evidence that exposes a ill-formed
    endorsement fails. *)
let wrong_delegate () =
  Context.init ~endorsers_per_block:1 2
  >>=? fun (b, contracts) ->
  Error_monad.map_s (Context.Contract.manager (B b)) contracts
  >>=? fun accounts ->
  let pkh1 = (List.nth accounts 0).Account.pkh in
  let pkh2 = (List.nth accounts 1).Account.pkh in
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (endorser_a, _a_slots) ->
  Op.endorsement ~delegate:endorser_a (B blk_a) ()
  >>=? fun endorsement_a ->
  Context.get_endorser (B blk_b)
  >>=? fun (endorser_b, _b_slots) ->
  let delegate =
    if Signature.Public_key_hash.equal pkh1 endorser_b then pkh2 else pkh1
  in
  Op.endorsement ~delegate (B blk_b) ()
  >>=? fun endorsement_b ->
  Op.double_endorsement (B blk_b) endorsement_a endorsement_b
  >>=? fun operation ->
  Block.bake ~operation blk_b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Baking.Unexpected_endorsement ->
          true
      | _ ->
          false)

let tests =
  [ Test.tztest
      "valid double endorsement evidence"
      `Quick
      valid_double_endorsement_evidence;
    Test.tztest
      "invalid double endorsement evidence"
      `Quick
      invalid_double_endorsement;
    Test.tztest
      "too early double endorsement evidence"
      `Quick
      too_early_double_endorsement_evidence;
    Test.tztest
      "too late double endorsement evidence"
      `Quick
      too_late_double_endorsement_evidence;
    Test.tztest "different delegates" `Quick different_delegates;
    Test.tztest "wrong delegate" `Quick wrong_delegate ]
src/proto_alpha/lib_protocol/test/double_endorsement.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition get_first_different_baker {A B : Type}
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (bakers : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    Tezos_protocol_environment_alpha__Environment.Error_monad._return
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun baker' =>
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.op_lt_gt
          baker baker') bakers).

Definition get_first_different_bakers {A B : Type} (ctxt : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * B)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt)
    (fun bakers =>
      let baker_1 :=
        Tezos_protocol_environment_alpha__Environment.List.hd bakers in
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (get_first_different_baker baker_1
          (Tezos_protocol_environment_alpha__Environment.List.tl bakers))
        (fun baker_2 =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (baker_1, baker_2))).

Definition get_first_different_endorsers {A B : Type} (ctxt : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * B)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt)
    (fun endorsers =>
      let endorser_1 :=
        Tezos_protocol_environment_alpha__Environment.List.hd endorsers in
      let endorser_2 :=
        Tezos_protocol_environment_alpha__Environment.List.hd
          (Tezos_protocol_environment_alpha__Environment.List.tl endorsers) in
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (endorser_1, endorser_2)).

Definition block_fork {A B C : Type} (b : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * C)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (get_first_different_bakers op_star_t_y_p_e_minus_e_r_r_o_r_star)
    (fun function_parameter =>
      match function_parameter with
      | (baker_1, baker_2) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star b)
          (fun blk_a =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star b)
              (fun blk_b =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  (blk_a, blk_b)))
      end).

Definition valid_double_endorsement_evidence (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (block_fork b)
            (fun function_parameter =>
              match function_parameter with
              | (blk_a, blk_b) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun function_parameter =>
                    match function_parameter with
                    | (delegate, _slots) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                          op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                        (fun endorsement_a =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                              op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                            (fun endorsement_b =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (cons
                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                      endorsement_a) []) blk_a)
                                (fun blk_a =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      endorsement_a endorsement_b)
                                    (fun operation =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                        (fun bakers =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (get_first_different_baker delegate
                                              bakers)
                                            (fun baker =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  operation blk_a)
                                                (fun blk =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.iter_s
                                                    (fun kind =>
                                                      let contract :=
                                                        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                          delegate in
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        contract kind
                                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                                                    (cons
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (cons
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (cons
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          []))))))))))
                    end)
              end)
        end)
  end.

Definition invalid_double_endorsement {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 10)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                (fun endorsement =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                        endorsement) b)
                    (fun b =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star endorsement
                          endorsement)
                        (fun operation =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star operation b)
                            (fun res =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                res
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Apply.Invalid_double_endorsement_evidence =>
                                    true
                                  | _ => false
                                  end))))))
        end)
  end.

Definition too_early_double_endorsement_evidence {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (block_fork b)
            (fun function_parameter =>
              match function_parameter with
              | (blk_a, blk_b) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun function_parameter =>
                    match function_parameter with
                    | (delegate, _slots) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                          op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                        (fun endorsement_a =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                              op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                            (fun endorsement_b =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  endorsement_a endorsement_b)
                                (fun operation =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      operation b)
                                    (fun res =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        res
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            Apply.Too_early_double_endorsement_evidence
                                              _ => true
                                          | _ => false
                                          end)))))
                    end)
              end)
        end)
  end.

Definition too_late_double_endorsement_evidence {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | {| parametric := {| preserved_cycles := preserved_cycles |} |}
                =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (block_fork b)
                  (fun function_parameter =>
                    match function_parameter with
                    | (blk_a, blk_b) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (fun function_parameter =>
                          match function_parameter with
                          | (delegate, _slots) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                                op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                              (fun endorsement_a =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                                  (fun endorsement_b =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                        (fun blk =>
                                          fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                blk
                                            end) blk_a
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star 1
                                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                                            preserved_cycles 1)))
                                      (fun blk =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            endorsement_a endorsement_b)
                                          (fun operation =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                operation blk)
                                              (fun res =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  res
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Apply.Outdated_double_endorsement_evidence
                                                        _ => true
                                                    | _ => false
                                                    end))))))
                          end)
                    end)
              end)
        end)
  end.

Definition different_delegates {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (block_fork b)
                (fun function_parameter =>
                  match function_parameter with
                  | (blk_a, blk_b) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (fun function_parameter =>
                        match function_parameter with
                        | (endorser_a, _a_slots) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (get_first_different_endorsers
                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                            (fun function_parameter =>
                              match function_parameter with
                              | (endorser_b1c, endorser_b2c) =>
                                let endorser_b :=
                                  if
                                    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.op_eq
                                      endorser_a (delegate endorser_b1c) then
                                    delegate endorser_b2c
                                  else
                                    delegate endorser_b1c in
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    endorser_a
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                                  (fun e_a =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        endorser_b
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                                      (fun e_b =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                              e_b) blk_b)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  e_a e_b)
                                                (fun operation =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      operation blk_b)
                                                    (fun res =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                        res
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          |
                                                            Apply.Inconsistent_double_endorsement_evidence
                                                              _ => true
                                                          | _ => false
                                                          end)))
                                            end)))
                              end)
                        end)
                  end))
        end)
  end.

Definition wrong_delegate {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star) contracts)
            (fun accounts =>
              let pkh1 :=
                Account.pkh (op_star_t_y_p_e_minus_e_r_r_o_r_star accounts 0) in
              let pkh2 :=
                Account.pkh (op_star_t_y_p_e_minus_e_r_r_o_r_star accounts 1) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (block_fork b)
                (fun function_parameter =>
                  match function_parameter with
                  | (blk_a, blk_b) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (fun function_parameter =>
                        match function_parameter with
                        | (endorser_a, _a_slots) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star endorser_a
                              op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                            (fun endorsement_a =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (endorser_b, _b_slots) =>
                                    let delegate :=
                                      if
                                        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                                          pkh1 endorser_b then
                                        pkh2
                                      else
                                        pkh1 in
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        delegate
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                                      (fun endorsement_b =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            endorsement_a endorsement_b)
                                          (fun operation =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                operation blk_b)
                                              (fun e =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  e
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Baking.Unexpected_endorsement
                                                      => true
                                                    | _ => false
                                                    end))))
                                  end))
                        end)
                  end))
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star
      "valid double endorsement evidence" % string variant
      valid_double_endorsement_evidence)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        "invalid double endorsement evidence" % string variant
        invalid_double_endorsement)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "too early double endorsement evidence" % string variant
          too_early_double_endorsement_evidence)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "too late double endorsement evidence" % string variant
            too_late_double_endorsement_evidence)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star "different delegates" % string
              variant different_delegates)
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star "wrong delegate" % string
                variant wrong_delegate) []))))).
src/proto_alpha/lib_protocol/test/endorsement.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Endorsing a block adds an extra layer of confidence to the Tezos's
    PoS algorithm. The block endorsing operation must be included in
    the following block. Each endorser possess a number of slots
    corresponding to their priority. After [preserved_cycles], a reward
    is given to the endorser. This reward depends on the priority of
    the block that contains the endorsements. *)

open Protocol
open Alpha_context
open Test_utils
open Test_tez

(****************************************************************)
(*                    Utility functions                         *)
(****************************************************************)

let get_expected_reward ctxt ~priority ~baker ~endorsing_power =
  ( if baker then Context.get_baking_reward ctxt ~priority ~endorsing_power
  else return (Test_tez.Tez.of_int 0) )
  >>=? fun baking_reward ->
  Context.get_endorsing_reward ctxt ~priority ~endorsing_power
  >>=? fun endorsing_reward ->
  Test_tez.Tez.(endorsing_reward +? baking_reward)
  >>?= fun reward -> return reward

let get_expected_deposit ctxt ~baker ~endorsing_power =
  Context.get_constants ctxt
  >>=? fun Constants.
             { parametric =
                 {endorsement_security_deposit; block_security_deposit; _};
               _ } ->
  let open Environment in
  let open Tez in
  let baking_deposit = if baker then block_security_deposit else of_int 0 in
  endorsement_security_deposit *? Int64.of_int endorsing_power
  >>?= fun endorsement_deposit ->
  endorsement_deposit +? baking_deposit >>?= fun deposit -> return deposit

(* [baker] is true if the [pkh] has also baked the current block, in
   which case correspoding deposit and reward should be ajusted *)
let assert_endorser_balance_consistency ~loc ?(priority = 0) ?(baker = false)
    ~endorsing_power ctxt pkh initial_balance =
  let contract = Contract.implicit_contract pkh in
  get_expected_reward ctxt ~priority ~baker ~endorsing_power
  >>=? fun reward ->
  get_expected_deposit ctxt ~baker ~endorsing_power
  >>=? fun deposit ->
  Assert.balance_was_debited ~loc ctxt contract initial_balance deposit
  >>=? fun () ->
  Context.Contract.balance ~kind:Rewards ctxt contract
  >>=? fun reward_balance ->
  Assert.equal_tez ~loc reward_balance reward
  >>=? fun () ->
  Context.Contract.balance ~kind:Deposit ctxt contract
  >>=? fun deposit_balance -> Assert.equal_tez ~loc deposit_balance deposit

let delegates_with_slots endorsers =
  List.map
    (fun (endorser : Delegate_services.Endorsing_rights.t) ->
      endorser.delegate)
    endorsers

let endorsing_power endorsers =
  List.fold_left
    (fun sum (endorser : Delegate_services.Endorsing_rights.t) ->
      sum + List.length endorser.slots)
    0
    endorsers

(****************************************************************)
(*                      Tests                                   *)
(****************************************************************)

(** Apply a single endorsement from the slot 0 endorser *)
let simple_endorsement () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_endorser (B b)
  >>=? fun (delegate, slots) ->
  Op.endorsement ~delegate (B b) ()
  >>=? fun op ->
  Context.Contract.balance (B b) (Contract.implicit_contract delegate)
  >>=? fun initial_balance ->
  let policy = Block.Excluding [delegate] in
  Block.get_next_baker ~policy b
  >>=? fun (_, priority, _) ->
  Block.bake ~policy ~operations:[Operation.pack op] b
  >>=? fun b2 ->
  assert_endorser_balance_consistency
    ~loc:__LOC__
    (B b2)
    ~priority
    ~endorsing_power:(List.length slots)
    delegate
    initial_balance

(** Apply a maximum number of endorsements. An endorser can be
    selected twice. *)
let max_endorsement () =
  let endorsers_per_block = 16 in
  Context.init ~endorsers_per_block 32
  >>=? fun (b, _) ->
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  Assert.equal_int
    ~loc:__LOC__
    (List.length
       (List.concat
          (List.map
             (fun {Alpha_services.Delegate.Endorsing_rights.slots; _} -> slots)
             endorsers)))
    endorsers_per_block
  >>=? fun () ->
  fold_left_s
    (fun (delegates, ops, balances)
         (endorser : Alpha_services.Delegate.Endorsing_rights.t) ->
      let delegate = endorser.delegate in
      Context.Contract.balance (B b) (Contract.implicit_contract delegate)
      >>=? fun balance ->
      Op.endorsement ~delegate (B b) ()
      >>=? fun op ->
      return
        ( delegate :: delegates,
          Operation.pack op :: ops,
          (List.length endorser.slots, balance) :: balances ))
    ([], [], [])
    endorsers
  >>=? fun (delegates, ops, previous_balances) ->
  Block.bake ~policy:(Excluding delegates) ~operations:(List.rev ops) b
  >>=? fun b ->
  (* One account can endorse more than one time per level, we must
     check that the bonds are summed up *)
  iter_s
    (fun (endorser_account, (endorsing_power, previous_balance)) ->
      assert_endorser_balance_consistency
        ~loc:__LOC__
        (B b)
        ~endorsing_power
        endorser_account
        previous_balance)
    (List.combine delegates previous_balances)

(** Check every that endorsers' balances are consistent with different priorities *)
let consistent_priorities () =
  let priorities = 0 -- 64 in
  Context.init 64
  >>=? fun (b, _) ->
  fold_left_s
    (fun (b, used_pkhes) priority ->
      (* Choose an endorser that has not baked nor endorsed before *)
      Context.get_endorsers (B b)
      >>=? fun endorsers ->
      let endorser =
        List.find_opt
          (fun (e : Delegate_services.Endorsing_rights.t) ->
            not (Signature.Public_key_hash.Set.mem e.delegate used_pkhes))
          endorsers
      in
      match endorser with
      | None ->
          return (b, used_pkhes) (* not enough fresh endorsers; we "stop" *)
      | Some endorser ->
          Context.Contract.balance
            (B b)
            (Contract.implicit_contract endorser.delegate)
          >>=? fun balance ->
          Op.endorsement ~delegate:endorser.delegate (B b) ()
          >>=? fun operation ->
          let operation = Operation.pack operation in
          Block.get_next_baker ~policy:(By_priority priority) b
          >>=? fun (baker, _, _) ->
          let used_pkhes =
            Signature.Public_key_hash.Set.add baker used_pkhes
          in
          let used_pkhes =
            Signature.Public_key_hash.Set.add endorser.delegate used_pkhes
          in
          (* Bake with a specific priority *)
          Block.bake ~policy:(By_priority priority) ~operation b
          >>=? fun b ->
          let is_baker =
            Signature.Public_key_hash.(baker = endorser.delegate)
          in
          assert_endorser_balance_consistency
            ~loc:__LOC__
            ~priority
            ~baker:is_baker
            (B b)
            ~endorsing_power:(List.length endorser.slots)
            endorser.delegate
            balance
          >>=? fun () -> return (b, used_pkhes))
    (b, Signature.Public_key_hash.Set.empty)
    priorities
  >>=? fun _b -> return_unit

(** Check that after [preserved_cycles] cycles the endorser gets his reward *)
let reward_retrieval () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
  Context.get_endorser (B b)
  >>=? fun (endorser, slots) ->
  Context.Contract.balance (B b) (Contract.implicit_contract endorser)
  >>=? fun balance ->
  Op.endorsement ~delegate:endorser (B b) ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  let policy = Block.Excluding [endorser] in
  Block.get_next_baker ~policy b
  >>=? fun (_, priority, _) ->
  Block.bake ~policy ~operation b
  >>=? fun b ->
  (* Bake (preserved_cycles + 1) cycles *)
  fold_left_s
    (fun b _ -> Block.bake_until_cycle_end ~policy:(Excluding [endorser]) b)
    b
    (0 -- preserved_cycles)
  >>=? fun b ->
  get_expected_reward
    (B b)
    ~priority
    ~baker:false
    ~endorsing_power:(List.length slots)
  >>=? fun reward ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser)
    balance
    reward

(** Check that after [preserved_cycles] cycles endorsers get their
    reward. Two endorsers are used and they endorse in different
    cycles. *)
let reward_retrieval_two_endorsers () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun Constants.
             { parametric =
                 { preserved_cycles;
                   endorsement_reward;
                   endorsement_security_deposit;
                   _ };
               _ } ->
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  let endorser1 = List.hd endorsers in
  let endorser2 = List.hd (List.tl endorsers) in
  Context.Contract.balance
    (B b)
    (Contract.implicit_contract endorser1.delegate)
  >>=? fun balance1 ->
  Context.Contract.balance
    (B b)
    (Contract.implicit_contract endorser2.delegate)
  >>=? fun balance2 ->
  Lwt.return
    Tez.(
      endorsement_security_deposit
      *? Int64.of_int (List.length endorser1.slots))
  >>=? fun security_deposit1 ->
  (* endorser1 endorses the genesis block in cycle 0 *)
  Op.endorsement ~delegate:endorser1.delegate (B b) ()
  >>=? fun operation1 ->
  let policy = Block.Excluding [endorser1.delegate; endorser2.delegate] in
  Block.get_next_baker ~policy b
  >>=? fun (_, priority, _) ->
  Tez.(endorsement_reward /? Int64.(succ (of_int priority)))
  >>?= fun reward_per_slot ->
  Lwt.return
    Tez.(reward_per_slot *? Int64.of_int (List.length endorser1.slots))
  >>=? fun reward1 ->
  (* bake next block, include endorsement of endorser1 *)
  Block.bake ~policy ~operation:(Operation.pack operation1) b
  >>=? fun b ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    security_deposit1
  >>=? fun () ->
  Assert.balance_is
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
  >>=? fun () ->
  (* complete cycle 0 *)
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    security_deposit1
  >>=? fun () ->
  Assert.balance_is
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
  >>=? fun () ->
  (* get the slots of endorser2 for the current block *)
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  let same_endorser2 endorser =
    Signature.Public_key_hash.(
      endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate)
  in
  let endorser2 = List.find same_endorser2 endorsers in
  (* No exception raised: in sandboxed mode endorsers do not change between blocks *)
  Lwt.return
    Tez.(
      endorsement_security_deposit
      *? Int64.of_int (List.length endorser2.slots))
  >>=? fun security_deposit2 ->
  (* endorser2 endorses the last block in cycle 0 *)
  Op.endorsement ~delegate:endorser2.delegate (B b) ()
  >>=? fun operation2 ->
  (* bake first block in cycle 1, include endorsement of endorser2 *)
  Block.bake ~policy ~operation:(Operation.pack operation2) b
  >>=? fun b ->
  let priority = b.header.protocol_data.contents.priority in
  Tez.(endorsement_reward /? Int64.(succ (of_int priority)))
  >>?= fun reward_per_slot ->
  Lwt.return
    Tez.(reward_per_slot *? Int64.of_int (List.length endorser2.slots))
  >>=? fun reward2 ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    security_deposit1
  >>=? fun () ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
    security_deposit2
  >>=? fun () ->
  (* bake [preserved_cycles] cycles *)
  fold_left_s
    (fun b _ ->
      Assert.balance_was_debited
        ~loc:__LOC__
        (B b)
        (Contract.implicit_contract endorser1.delegate)
        balance1
        security_deposit1
      >>=? fun () ->
      Assert.balance_was_debited
        ~loc:__LOC__
        (B b)
        (Contract.implicit_contract endorser2.delegate)
        balance2
        security_deposit2
      >>=? fun () -> Block.bake_until_cycle_end ~policy b)
    b
    (1 -- preserved_cycles)
  >>=? fun b ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    reward1
  >>=? fun () ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
    security_deposit2
  >>=? fun () ->
  (* bake cycle [preserved_cycle + 1] *)
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    reward1
  >>=? fun () ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
    reward2

(****************************************************************)
(*  The following test scenarios are supposed to raise errors.  *)
(****************************************************************)

(** Wrong endorsement predecessor : apply an endorsement with an
    incorrect block predecessor *)
let wrong_endorsement_predecessor () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_endorser (B b)
  >>=? fun (genesis_endorser, _slots) ->
  Block.bake b
  >>=? fun b' ->
  Op.endorsement ~delegate:genesis_endorser ~signing_context:(B b) (B b') ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  Block.bake ~operation b'
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Wrong_endorsement_predecessor _ ->
          true
      | _ ->
          false)

(** Invalid_endorsement_level : apply an endorsement with an incorrect
    level (i.e. the predecessor level) *)
let invalid_endorsement_level () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_level (B b)
  >>=? fun genesis_level ->
  Block.bake b
  >>=? fun b ->
  Op.endorsement ~level:genesis_level (B b) ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  Block.bake ~operation b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_endorsement_level ->
          true
      | _ ->
          false)

(** Duplicate endorsement : apply an endorsement that has already been done *)
let duplicate_endorsement () =
  Context.init 5
  >>=? fun (b, _) ->
  Incremental.begin_construction b
  >>=? fun inc ->
  Op.endorsement (B b) ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  Incremental.add_operation inc operation
  >>=? fun inc ->
  Op.endorsement (B b) ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  Incremental.add_operation inc operation
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Duplicate_endorsement _ ->
          true
      | _ ->
          false)

(** Apply a single endorsement from the slot 0 endorser *)
let not_enough_for_deposit () =
  Context.init 5 ~endorsers_per_block:1
  >>=? fun (b_init, contracts) ->
  Error_monad.map_s
    (fun c ->
      Context.Contract.manager (B b_init) c >>=? fun m -> return (m, c))
    contracts
  >>=? fun managers ->
  Block.bake b_init
  >>=? fun b ->
  (* retrieve the level 2's endorser *)
  Context.get_endorser (B b)
  >>=? fun (endorser, _slots) ->
  let (_, contract_other_than_endorser) =
    List.find
      (fun (c, _) ->
        not (Signature.Public_key_hash.equal c.Account.pkh endorser))
      managers
  in
  let (_, contract_of_endorser) =
    List.find
      (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser)
      managers
  in
  Context.Contract.balance (B b) (Contract.implicit_contract endorser)
  >>=? fun initial_balance ->
  (* Empty the future endorser account *)
  Op.transaction
    (B b_init)
    contract_of_endorser
    contract_other_than_endorser
    initial_balance
  >>=? fun op_trans ->
  Block.bake ~operation:op_trans b_init
  >>=? fun b ->
  (* Endorse with a zero balance *)
  Op.endorsement ~delegate:endorser (B b) ()
  >>=? fun op_endo ->
  Block.bake
    ~policy:(Excluding [endorser])
    ~operation:(Operation.pack op_endo)
    b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Delegate_storage.Balance_too_low_for_deposit _ ->
          true
      | _ ->
          false)

(* check that a block with not enough endorsement cannot be baked *)
let endorsement_threshold () =
  let initial_endorsers = 28 in
  let num_accounts = 100 in
  Context.init ~initial_endorsers num_accounts
  >>=? fun (b, _) ->
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  let num_endorsers = List.length endorsers in
  (* we try to bake with more and more endorsers, but at each
     iteration with a timestamp smaller than required *)
  iter_s
    (fun i ->
      (* the priority is chosen rather arbitrarily *)
      let priority = num_endorsers - i in
      let crt_endorsers = List.take_n i endorsers in
      let endorsing_power = endorsing_power crt_endorsers in
      let delegates = delegates_with_slots crt_endorsers in
      map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates
      >>=? fun ops ->
      Context.get_minimal_valid_time (B b) ~priority ~endorsing_power
      >>=? fun timestamp ->
      (* decrease the timestamp by one second *)
      let seconds =
        Int64.(sub (of_string (Timestamp.to_seconds_string timestamp)) 1L)
      in
      match Timestamp.of_seconds (Int64.to_string seconds) with
      | None ->
          failwith "timestamp to/from string manipulation failed"
      | Some timestamp ->
          Block.bake
            ~timestamp
            ~policy:(By_priority priority)
            ~operations:(List.map Operation.pack ops)
            b
          >>= fun b2 ->
          Assert.proto_error ~loc:__LOC__ b2 (function
              | Baking.Timestamp_too_early _
              | Apply.Not_enough_endorsements_for_priority _ ->
                  true
              | _ ->
                  false))
    (0 -- (num_endorsers - 1))
  >>=? fun () ->
  (* we bake with all endorsers endorsing, at the right time *)
  let priority = 0 in
  let endorsing_power = endorsing_power endorsers in
  let delegates = delegates_with_slots endorsers in
  map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates
  >>=? fun ops ->
  Context.get_minimal_valid_time (B b) ~priority ~endorsing_power
  >>=? fun timestamp ->
  Block.bake
    ~policy:(By_priority priority)
    ~timestamp
    ~operations:(List.map Operation.pack ops)
    b
  >>= fun _ -> return_unit

let test_fitness_gap () =
  let num_accounts = 5 in
  Context.init num_accounts
  >>=? fun (b, _) ->
  ( match Fitness_repr.to_int64 b.header.shell.fitness with
  | Ok fitness ->
      return (Int64.to_int fitness)
  | Error _ ->
      assert false )
  >>=? fun fitness ->
  Context.get_endorser (B b)
  >>=? fun (delegate, _slots) ->
  Op.endorsement ~delegate (B b) ()
  >>=? fun op ->
  (* bake at priority 0 succeed thanks to enough endorsements *)
  Block.bake ~policy:(By_priority 0) ~operations:[Operation.pack op] b
  >>=? fun b ->
  ( match Fitness_repr.to_int64 b.header.shell.fitness with
  | Ok new_fitness ->
      return (Int64.to_int new_fitness - fitness)
  | Error _ ->
      assert false )
  >>=? fun res ->
  (* in Emmy+, the fitness increases by 1, so the difference between
     the fitness at level 1 and at level 0 is 1, independently if the
     number fo endorements (here 1) *)
  Assert.equal_int ~loc:__LOC__ res 1 >>=? fun () -> return_unit

let tests =
  [ Test.tztest "Simple endorsement" `Quick simple_endorsement;
    Test.tztest "Maximum endorsement" `Quick max_endorsement;
    Test.tztest "Consistent priorities" `Quick consistent_priorities;
    Test.tztest "Reward retrieval" `Quick reward_retrieval;
    Test.tztest
      "Reward retrieval two endorsers"
      `Quick
      reward_retrieval_two_endorsers;
    Test.tztest "Endorsement threshold" `Quick endorsement_threshold;
    Test.tztest "Fitness gap" `Quick test_fitness_gap;
    (* Fail scenarios *)
    Test.tztest
      "Wrong endorsement predecessor"
      `Quick
      wrong_endorsement_predecessor;
    Test.tztest "Invalid endorsement level" `Quick invalid_endorsement_level;
    Test.tztest "Duplicate endorsement" `Quick duplicate_endorsement;
    Test.tztest "Not enough for deposit" `Quick not_enough_for_deposit ]
src/proto_alpha/lib_protocol/test/endorsement.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition get_expected_reward {A B C D : Type}
  (ctxt : A) (priority : B) (baker : bool) (endorsing_power : C)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (if baker then
      op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt priority endorsing_power
    else
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (op_star_t_y_p_e_minus_e_r_r_o_r_star 0))
    (fun baking_reward =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt priority endorsing_power)
        (fun endorsing_reward =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
            (fun reward =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                reward))).

Definition get_expected_deposit {A B : Type}
  (ctxt : A) (baker : bool) (endorsing_power : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt)
    (fun function_parameter =>
      match function_parameter with
      | {|
        parametric := {|
          block_security_deposit := block_security_deposit;
            endorsement_security_deposit := endorsement_security_deposit
            |}
          |} =>
        let baking_deposit :=
          if baker then
            block_security_deposit
          else
            op_star_t_y_p_e_minus_e_r_r_o_r_star 0 in
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
            endorsement_security_deposit
            (Tezos_protocol_alpha.Protocol.Environment.Int64.of_int
              endorsing_power))
          (fun endorsement_deposit =>
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                endorsement_deposit baking_deposit)
              (fun deposit =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  deposit))
      end).

Definition assert_endorser_balance_consistency {A B C D : Type}
  (loc : A) (op_star_o_p_t_star : option Z)
  : (option bool) ->
    Z ->
      B ->
        Tezos_raw_protocol_alpha__Alpha_context.public_key_hash ->
          C ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                D) :=
  let priority :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun op_star_o_p_t_star =>
    let baker :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => false
      end in
    fun endorsing_power =>
      fun ctxt =>
        fun pkh =>
          fun initial_balance =>
            let contract :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                pkh in
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (get_expected_reward ctxt priority baker endorsing_power)
              (fun reward =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (get_expected_deposit ctxt baker endorsing_power)
                  (fun deposit =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star loc ctxt contract
                        initial_balance deposit)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt contract)
                            (fun reward_balance =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star loc
                                  reward_balance reward)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | tt =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        ctxt contract)
                                      (fun deposit_balance =>
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star loc
                                          deposit_balance deposit)
                                  end))
                        end))).

Definition delegates_with_slots
  (endorsers :
    list Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
  : list
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
  Tezos_protocol_environment_alpha__Environment.List.map
    (fun endorser => delegate endorser) endorsers.

Definition endorsing_power
  (endorsers :
    list Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
  : Z :=
  Tezos_protocol_environment_alpha__Environment.List.fold_left
    (fun sum =>
      fun endorser =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus sum
          (Tezos_protocol_environment_alpha__Environment.List.length
            (slots endorser))) 0 endorsers.

Definition simple_endorsement {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | (delegate, slots) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                    op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                  (fun op =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                          delegate))
                      (fun initial_balance =>
                        let policy := op_star_t_y_p_e_minus_e_r_r_o_r_star in
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star policy b)
                          (fun function_parameter =>
                            match function_parameter with
                            | (_, priority, _) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star policy
                                  (cons
                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                      op) []) b)
                                (fun b2 =>
                                  assert_endorser_balance_consistency
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    (Some priority) None
                                    (Tezos_protocol_environment_alpha__Environment.List.length
                                      slots)
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    delegate initial_balance)
                            end)))
              end)
        end)
  end.

Definition max_endorsement (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let endorsers_per_block := 16 in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star endorsers_per_block 32)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun endorsers =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                  (Tezos_protocol_environment_alpha__Environment.List.length
                    (Tezos_protocol_environment_alpha__Environment.List.concat
                      (Tezos_protocol_environment_alpha__Environment.List.map
                        (fun function_parameter =>
                          match function_parameter with
                          | {|
                            Alpha_services.Delegate.Endorsing_rights.slots := slots
                              |} => slots
                          end) endorsers))) endorsers_per_block)
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                        (fun function_parameter =>
                          match function_parameter with
                          | (delegates, ops, balances) =>
                            fun endorser =>
                              let delegate := delegate endorser in
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                    delegate))
                                (fun balance =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      delegate
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                                    (fun op =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                        ((cons delegate delegates),
                                          (cons
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                              op) ops),
                                          (cons
                                            ((Tezos_protocol_environment_alpha__Environment.List.length
                                              (slots endorser)), balance)
                                            balances))))
                          end) ([], [], []) endorsers)
                      (fun function_parameter =>
                        match function_parameter with
                        | (delegates, ops, previous_balances) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (Tezos_protocol_environment_alpha__Environment.List.rev
                                ops) b)
                            (fun b =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.iter_s
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    (endorser_account,
                                      (endorsing_power, previous_balance)) =>
                                    assert_endorser_balance_consistency
                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                      None None endorsing_power
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      endorser_account previous_balance
                                  end)
                                (Tezos_protocol_environment_alpha__Environment.List.combine
                                  delegates previous_balances))
                        end)
                  end))
        end)
  end.

Definition consistent_priorities (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let priorities := op_star_t_y_p_e_minus_e_r_r_o_r_star 0 64 in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 64)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
              (fun function_parameter =>
                match function_parameter with
                | (b, used_pkhes) =>
                  fun priority =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (fun endorsers =>
                        let endorser :=
                          Tezos_protocol_environment_alpha__Environment.List.find_opt
                            (fun e =>
                              Tezos_protocol_environment_alpha__Environment.Pervasives.not
                                (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Set.mem
                                  (delegate e) used_pkhes)) endorsers in
                        match endorser with
                        | None =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                            (b, used_pkhes)
                        | Some endorser =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                (delegate endorser)))
                            (fun balance =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (delegate endorser)
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                                (fun operation =>
                                  let operation :=
                                    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                      operation in
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | (baker, _, _) =>
                                        let used_pkhes :=
                                          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Set.add
                                            baker used_pkhes in
                                        let used_pkhes :=
                                          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Set.add
                                            (delegate endorser) used_pkhes in
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            operation b)
                                          (fun b =>
                                            let is_baker :=
                                              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.op_eq
                                                baker (delegate endorser) in
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (assert_endorser_balance_consistency
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                (Some priority) (Some is_baker)
                                                (Tezos_protocol_environment_alpha__Environment.List.length
                                                  (slots endorser))
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (delegate endorser) balance)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                    (b, used_pkhes)
                                                end))
                                      end)))
                        end)
                end)
              (b,
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Set.empty)
              priorities)
            (fun _b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit)
        end)
  end.

Definition reward_retrieval {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | {| parametric := {| preserved_cycles := preserved_cycles |} |}
                =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun function_parameter =>
                    match function_parameter with
                    | (endorser, slots) =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                            endorser))
                        (fun balance =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star endorser
                              op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                            (fun operation =>
                              let operation :=
                                Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                  operation in
                              let policy := op_star_t_y_p_e_minus_e_r_r_o_r_star
                                in
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star policy b)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | (_, priority, _) =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        policy operation b)
                                      (fun b =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                            (fun b =>
                                              fun function_parameter =>
                                                match function_parameter with
                                                | _ =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    b
                                                end) b
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              0 preserved_cycles))
                                          (fun b =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (get_expected_reward
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                priority false
                                                (Tezos_protocol_environment_alpha__Environment.List.length
                                                  slots))
                                              (fun reward =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                    endorser) balance reward)))
                                  end)))
                    end)
              end)
        end)
  end.

Definition reward_retrieval_two_endorsers {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | {|
                parametric := {|
                  preserved_cycles := preserved_cycles;
                    endorsement_security_deposit :=
                      endorsement_security_deposit;
                    endorsement_reward := endorsement_reward
                    |}
                  |} =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun endorsers =>
                    let endorser1 :=
                      Tezos_protocol_environment_alpha__Environment.List.hd
                        endorsers in
                    let endorser2 :=
                      Tezos_protocol_environment_alpha__Environment.List.hd
                        (Tezos_protocol_environment_alpha__Environment.List.tl
                          endorsers) in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                          (delegate endorser1)))
                      (fun balance1 =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                              (delegate endorser2)))
                          (fun balance2 =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                                  endorsement_security_deposit
                                  (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                    (Tezos_protocol_environment_alpha__Environment.List.length
                                      (slots endorser1)))))
                              (fun security_deposit1 =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (delegate endorser1)
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                                  (fun operation1 =>
                                    let policy :=
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star in
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        policy b)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (_, priority, _) =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_div_question
                                              endorsement_reward
                                              (Tezos_protocol_environment_alpha__Environment.Int64.succ
                                                (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                                  priority)))
                                            (fun reward_per_slot =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                                                    reward_per_slot
                                                    (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                                      (Tezos_protocol_environment_alpha__Environment.List.length
                                                        (slots endorser1)))))
                                                (fun reward1 =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      policy
                                                      (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                                        operation1) b)
                                                    (fun b =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                            (delegate endorser1))
                                                          balance1
                                                          security_deposit1)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                  (delegate
                                                                    endorser2))
                                                                balance2)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      policy b)
                                                                    (fun b =>
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                            (delegate
                                                                              endorser1))
                                                                          balance1
                                                                          security_deposit1)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | tt
                                                                            =>
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                  (delegate
                                                                                    endorser2))
                                                                                balance2)
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                match
                                                                                  function_parameter
                                                                                  with
                                                                                |
                                                                                  tt
                                                                                  =>
                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                    (fun
                                                                                      endorsers
                                                                                      =>
                                                                                      let
                                                                                        same_endorser2
                                                                                        (endorser
                                                                                        :
                                                                                        Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
                                                                                        : bool :=
                                                                                        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.op_eq
                                                                                          (Delegate_services.Endorsing_rights.delegate
                                                                                            endorser)
                                                                                          (delegate
                                                                                            endorser2)
                                                                                        in
                                                                                      let
                                                                                        endorser2 :=
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          same_endorser2
                                                                                          endorsers
                                                                                        in
                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                                                                                            endorsement_security_deposit
                                                                                            (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                                                                              (Tezos_protocol_environment_alpha__Environment.List.length
                                                                                                (slots
                                                                                                  endorser2)))))
                                                                                        (fun
                                                                                          security_deposit2
                                                                                          =>
                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              (delegate
                                                                                                endorser2)
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              tt)
                                                                                            (fun
                                                                                              operation2
                                                                                              =>
                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  policy
                                                                                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                                                                                    operation2)
                                                                                                  b)
                                                                                                (fun
                                                                                                  b
                                                                                                  =>
                                                                                                  let
                                                                                                    priority :=
                                                                                                    priority
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    in
                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_div_question
                                                                                                      endorsement_reward
                                                                                                      (Tezos_protocol_environment_alpha__Environment.Int64.succ
                                                                                                        (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                                                                                          priority)))
                                                                                                    (fun
                                                                                                      reward_per_slot
                                                                                                      =>
                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                                                                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                                                                                                            reward_per_slot
                                                                                                            (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                                                                                              (Tezos_protocol_environment_alpha__Environment.List.length
                                                                                                                (slots
                                                                                                                  endorser2)))))
                                                                                                        (fun
                                                                                                          reward2
                                                                                                          =>
                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                                                (delegate
                                                                                                                  endorser1))
                                                                                                              balance1
                                                                                                              security_deposit1)
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              match
                                                                                                                function_parameter
                                                                                                                with
                                                                                                              |
                                                                                                                tt
                                                                                                                =>
                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                                                      (delegate
                                                                                                                        endorser2))
                                                                                                                    balance2
                                                                                                                    security_deposit2)
                                                                                                                  (fun
                                                                                                                    function_parameter
                                                                                                                    =>
                                                                                                                    match
                                                                                                                      function_parameter
                                                                                                                      with
                                                                                                                    |
                                                                                                                      tt
                                                                                                                      =>
                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                                                                                                          (fun
                                                                                                                            b
                                                                                                                            =>
                                                                                                                            fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              match
                                                                                                                                function_parameter
                                                                                                                                with
                                                                                                                              |
                                                                                                                                _
                                                                                                                                =>
                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                                                                      (delegate
                                                                                                                                        endorser1))
                                                                                                                                    balance1
                                                                                                                                    security_deposit1)
                                                                                                                                  (fun
                                                                                                                                    function_parameter
                                                                                                                                    =>
                                                                                                                                    match
                                                                                                                                      function_parameter
                                                                                                                                      with
                                                                                                                                    |
                                                                                                                                      tt
                                                                                                                                      =>
                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                                                                            (delegate
                                                                                                                                              endorser2))
                                                                                                                                          balance2
                                                                                                                                          security_deposit2)
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          match
                                                                                                                                            function_parameter
                                                                                                                                            with
                                                                                                                                          |
                                                                                                                                            tt
                                                                                                                                            =>
                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              policy
                                                                                                                                              b
                                                                                                                                          end)
                                                                                                                                    end)
                                                                                                                              end)
                                                                                                                          b
                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                            1
                                                                                                                            preserved_cycles))
                                                                                                                        (fun
                                                                                                                          b
                                                                                                                          =>
                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                                                                (delegate
                                                                                                                                  endorser1))
                                                                                                                              balance1
                                                                                                                              reward1)
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              match
                                                                                                                                function_parameter
                                                                                                                                with
                                                                                                                              |
                                                                                                                                tt
                                                                                                                                =>
                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                                                                      (delegate
                                                                                                                                        endorser2))
                                                                                                                                    balance2
                                                                                                                                    security_deposit2)
                                                                                                                                  (fun
                                                                                                                                    function_parameter
                                                                                                                                    =>
                                                                                                                                    match
                                                                                                                                      function_parameter
                                                                                                                                      with
                                                                                                                                    |
                                                                                                                                      tt
                                                                                                                                      =>
                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                          policy
                                                                                                                                          b)
                                                                                                                                        (fun
                                                                                                                                          b
                                                                                                                                          =>
                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                              (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                                                                                (delegate
                                                                                                                                                  endorser1))
                                                                                                                                              balance1
                                                                                                                                              reward1)
                                                                                                                                            (fun
                                                                                                                                              function_parameter
                                                                                                                                              =>
                                                                                                                                              match
                                                                                                                                                function_parameter
                                                                                                                                                with
                                                                                                                                              |
                                                                                                                                                tt
                                                                                                                                                =>
                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                                                                                                                                    (delegate
                                                                                                                                                      endorser2))
                                                                                                                                                  balance2
                                                                                                                                                  reward2
                                                                                                                                              end))
                                                                                                                                    end)
                                                                                                                              end))
                                                                                                                    end)
                                                                                                              end)))))))
                                                                                end)
                                                                          end))
                                                                end)
                                                          end))))
                                        end))))))
              end)
        end)
  end.

Definition wrong_endorsement_predecessor {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | (genesis_endorser, _slots) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                  (fun b' =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star genesis_endorser
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                      (fun operation =>
                        let operation :=
                          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                            operation in
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star operation b')
                          (fun res =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                              res
                              (fun function_parameter =>
                                match function_parameter with
                                | Apply.Wrong_endorsement_predecessor _ _ =>
                                  true
                                | _ => false
                                end))))
              end)
        end)
  end.

Definition invalid_endorsement_level {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun genesis_level =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star genesis_level
                      op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                    (fun operation =>
                      let operation :=
                        Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                          operation in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star operation b)
                        (fun res =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                            res
                            (fun function_parameter =>
                              match function_parameter with
                              | Apply.Invalid_endorsement_level => true
                              | _ => false
                              end)))))
        end)
  end.

Definition duplicate_endorsement {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun inc =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                (fun operation =>
                  let operation :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                      operation in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star inc operation)
                    (fun inc =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                        (fun operation =>
                          let operation :=
                            Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                              operation in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star inc operation)
                            (fun res =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                res
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Apply.Duplicate_endorsement _ => true
                                  | _ => false
                                  end))))))
        end)
  end.

Definition not_enough_for_deposit {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5 1)
      (fun function_parameter =>
        match function_parameter with
        | (b_init, contracts) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
              (fun c =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star c)
                  (fun m =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (m, c))) contracts)
            (fun managers =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star b_init)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                    (fun function_parameter =>
                      match function_parameter with
                      | (endorser, _slots) =>
                        match
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (fun function_parameter =>
                              match function_parameter with
                              | (c, _) =>
                                Tezos_protocol_environment_alpha__Environment.Pervasives.not
                                  (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                                    (Account.pkh c) endorser)
                              end) managers with
                        | (_, contract_other_than_endorser) =>
                          match
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (fun function_parameter =>
                                match function_parameter with
                                | (c, _) =>
                                  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                                    (Account.pkh c) endorser
                                end) managers with
                          | (_, contract_of_endorser) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                  endorser))
                              (fun initial_balance =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    contract_of_endorser
                                    contract_other_than_endorser initial_balance)
                                  (fun op_trans =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_trans b_init)
                                      (fun b =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            endorser
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            tt)
                                          (fun op_endo =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                                  op_endo) b)
                                              (fun res =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  res
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Delegate_storage.Balance_too_low_for_deposit
                                                        _ => true
                                                    | _ => false
                                                    end))))))
                          end
                        end
                      end)))
        end)
  end.

Definition endorsement_threshold (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let initial_endorsers := 28 in
    let num_accounts := 100 in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star initial_endorsers num_accounts)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun endorsers =>
              let num_endorsers :=
                Tezos_protocol_environment_alpha__Environment.List.length
                  endorsers in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.iter_s
                  (fun i =>
                    let priority :=
                      Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                        num_endorsers i in
                    let crt_endorsers :=
                      op_star_t_y_p_e_minus_e_r_r_o_r_star i endorsers in
                    let endorsing_power := endorsing_power crt_endorsers in
                    let delegates := delegates_with_slots crt_endorsers in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                        (fun x =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star x
                            op_star_t_y_p_e_minus_e_r_r_o_r_star tt) delegates)
                      (fun ops =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star priority
                            endorsing_power)
                          (fun timestamp =>
                            let seconds :=
                              Tezos_protocol_environment_alpha__Environment.Int64.sub
                                (Tezos_protocol_environment_alpha__Environment.Int64.of_string
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Timestamp.to_seconds_string
                                    timestamp)) 1 in
                            match
                              Tezos_protocol_alpha.Protocol.Alpha_context.Timestamp.of_seconds
                                (Tezos_protocol_environment_alpha__Environment.Int64.to_string
                                  seconds) with
                            | None =>
                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                "timestamp to/from string manipulation failed" %
                                  string
                            | Some timestamp =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star timestamp
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (Tezos_protocol_environment_alpha__Environment.List.map
                                    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                    ops) b)
                                (fun b2 =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    b2
                                    (fun function_parameter =>
                                      match function_parameter with
                                      |
                                        Baking.Timestamp_too_early _ _ |
                                          Apply.Not_enough_endorsements_for_priority
                                            _ => true
                                      | _ => false
                                      end))
                            end)))
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star 0
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                      num_endorsers 1)))
                (fun function_parameter =>
                  match function_parameter with
                  | tt =>
                    let priority := 0 in
                    let endorsing_power := endorsing_power endorsers in
                    let delegates := delegates_with_slots endorsers in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                        (fun delegate =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                            op_star_t_y_p_e_minus_e_r_r_o_r_star tt) delegates)
                      (fun ops =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star priority
                            endorsing_power)
                          (fun timestamp =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star timestamp
                                (Tezos_protocol_environment_alpha__Environment.List.map
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                  ops) b)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                end)))
                  end))
        end)
  end.

Definition test_fitness_gap (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let num_accounts := 5 in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star num_accounts)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            match
              Tezos_protocol_alpha.Protocol.Fitness_repr.to_int64
                (fitness (shell (header b))) with
            | inl fitness =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (Tezos_protocol_environment_alpha__Environment.Int64.to_int
                  fitness)
            | inr _ => false
            end
            (fun fitness =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | (delegate, _slots) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate
                        op_star_t_y_p_e_minus_e_r_r_o_r_star tt)
                      (fun op =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (cons
                              (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
                                op) []) b)
                          (fun b =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              match
                                Tezos_protocol_alpha.Protocol.Fitness_repr.to_int64
                                  (fitness (shell (header b))) with
                              | inl new_fitness =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                    (Tezos_protocol_environment_alpha__Environment.Int64.to_int
                                      new_fitness) fitness)
                              | inr _ => false
                              end
                              (fun res =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    res 1)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                    end))))
                  end))
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "Simple endorsement" % string variant
      simple_endorsement)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star "Maximum endorsement" % string
        variant max_endorsement)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star "Consistent priorities" % string
          variant consistent_priorities)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star "Reward retrieval" % string
            variant reward_retrieval)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              "Reward retrieval two endorsers" % string variant
              reward_retrieval_two_endorsers)
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "Endorsement threshold" % string variant endorsement_threshold)
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star "Fitness gap" % string
                  variant test_fitness_gap)
                (cons
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "Wrong endorsement predecessor" % string variant
                    wrong_endorsement_predecessor)
                  (cons
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      "Invalid endorsement level" % string variant
                      invalid_endorsement_level)
                    (cons
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "Duplicate endorsement" % string variant
                        duplicate_endorsement)
                      (cons
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          "Not enough for deposit" % string variant
                          not_enough_for_deposit) [])))))))))).
src/proto_alpha/lib_protocol/test/helpers/account.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

type t = {
  pkh : Signature.Public_key_hash.t;
  pk : Signature.Public_key.t;
  sk : Signature.Secret_key.t;
}

type account = t

let known_accounts = Signature.Public_key_hash.Table.create 17

let new_account ?seed () =
  let seed = Option.map ~f:Bigstring.of_bytes seed in
  let (pkh, pk, sk) = Signature.generate_key ?seed () in
  let account = {pkh; pk; sk} in
  Signature.Public_key_hash.Table.add known_accounts pkh account ;
  account

let add_account ({pkh; _} as account) =
  Signature.Public_key_hash.Table.add known_accounts pkh account

let activator_account = new_account ()

let find pkh =
  try return (Signature.Public_key_hash.Table.find known_accounts pkh)
  with Not_found ->
    failwith "Missing account: %a" Signature.Public_key_hash.pp pkh

let find_alternate pkh =
  let exception Found of t in
  try
    Signature.Public_key_hash.Table.iter
      (fun pkh' account ->
        if not (Signature.Public_key_hash.equal pkh pkh') then
          raise (Found account))
      known_accounts ;
    raise Not_found
  with Found account -> account

let dummy_account = new_account ()

let generate_accounts ?(initial_balances = []) n : (t * Tez_repr.t) list =
  Signature.Public_key_hash.Table.clear known_accounts ;
  let default_amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
  let amount i =
    match List.nth_opt initial_balances i with
    | None ->
        default_amount
    | Some a ->
        Tez_repr.of_mutez_exn a
  in
  List.map
    (fun i ->
      let (pkh, pk, sk) = Signature.generate_key () in
      let account = {pkh; pk; sk} in
      Signature.Public_key_hash.Table.add known_accounts pkh account ;
      (account, amount i))
    (0 -- (n - 1))

let commitment_secret =
  Blinded_public_key_hash.activation_code_of_hex
    "aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb"

let new_commitment ?seed () =
  let seed = Option.map ~f:Bigstring.of_bytes seed in
  let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in
  let unactivated_account = {pkh; pk; sk} in
  let open Commitment_repr in
  let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in
  let bpkh = Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in
  (Lwt.return @@ Environment.wrap_error @@ Tez_repr.(one *? 4_000L))
  >>=? fun amount ->
  return @@ (unactivated_account, {blinded_public_key_hash = bpkh; amount})
src/proto_alpha/lib_protocol/test/helpers/account.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Record t := {
  pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t;
  pk : Tezos_base__TzPervasives.Signature.Public_key.t;
  sk : Tezos_base__TzPervasives.Signature.Secret_key.t }.

Definition account := t.

Definition known_accounts
  : Tezos_base__TzPervasives.Signature.Public_key_hash.Table.t t :=
  Tezos_base__TzPervasives.Signature.Public_key_hash.Table.create 17.

Definition new_account
  (seed : option Stdlib.Bytes.t) (function_parameter : unit) : t :=
  match function_parameter with
  | tt =>
    let seed := Tezos_base__TzPervasives.Option.map Bigstring.of_bytes seed in
    match Tezos_base__TzPervasives.Signature.generate_key None seed tt with
    | (pkh, pk, sk) =>
      let account := {| pkh := pkh; pk := pk; sk := sk |} in
      Tezos_base__TzPervasives.Signature.Public_key_hash.Table.add
        known_accounts pkh account;
      account
    end
  end.

Definition add_account (function_parameter : t) : unit :=
  match function_parameter with
  | {| pkh := pkh |} as account =>
    Tezos_base__TzPervasives.Signature.Public_key_hash.Table.add known_accounts
      pkh account
  end.

Definition activator_account : t := new_account None tt.

Definition find
  (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.Table.key)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) := try.

Definition find_alternate
  (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t) : t :=
  let_exception.

Definition dummy_account : t := new_account None tt.

Definition generate_accounts (op_star_o_p_t_star : option (list int64))
  : Z -> list (t * Tezos_protocol_alpha.Protocol.Tez_repr.t) :=
  let initial_balances :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun n =>
    Tezos_base__TzPervasives.Signature.Public_key_hash.Table.clear
      known_accounts;
    let default_amount :=
      Tezos_protocol_alpha.Protocol.Tez_repr.of_mutez_exn 4000000000000 in
    let amount (i : Z) : Tezos_protocol_alpha.Protocol.Tez_repr.t :=
      match Tezos_base__TzPervasives.List.nth_opt initial_balances i with
      | None => default_amount
      | Some a => Tezos_protocol_alpha.Protocol.Tez_repr.of_mutez_exn a
      end in
    Tezos_base__TzPervasives.List.map
      (fun i =>
        match Tezos_base__TzPervasives.Signature.generate_key None None tt with
        | (pkh, pk, sk) =>
          let account := {| pkh := pkh; pk := pk; sk := sk |} in
          Tezos_base__TzPervasives.Signature.Public_key_hash.Table.add
            known_accounts pkh account;
          (account, (amount i))
        end) (Tezos_base__TzPervasives.op_minus_minus 0 (Z.sub n 1)).

Definition commitment_secret
  : Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code :=
  Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code_of_hex
    "aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb" % string.

Definition new_commitment
  (seed : option Stdlib.Bytes.t) (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (t * Tezos_protocol_alpha.Protocol.Commitment_repr.t)) :=
  match function_parameter with
  | tt =>
    let seed := Tezos_base__TzPervasives.Option.map Bigstring.of_bytes seed in
    match Tezos_base__TzPervasives.Signature.generate_key (Some Ed25519) seed tt
      with
    | (pkh, pk, sk) =>
      let unactivated_account := {| pkh := pkh; pk := pk; sk := sk |} in
      let pkh :=
        match pkh with
        | Ed25519 pkh => pkh
        | _ => false
        end in
      let bpkh :=
        Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.of_ed25519_pkh
          commitment_secret pkh in
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (apply Lwt._return
          (apply Tezos_protocol_alpha.Protocol.Environment.wrap_error
            (Tezos_protocol_alpha.Protocol.Tez_repr.op_star_question
              Tezos_protocol_alpha.Protocol.Tez_repr.one 4000)))
        (fun amount =>
          apply Tezos_base__TzPervasives._return
            (unactivated_account,
              {| blinded_public_key_hash := bpkh; amount := amount |}))
    end
  end.
src/proto_alpha/lib_protocol/test/helpers/account.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

type t = {
  pkh : Signature.Public_key_hash.t;
  pk : Signature.Public_key.t;
  sk : Signature.Secret_key.t;
}

type account = t

val known_accounts : t Signature.Public_key_hash.Table.t

val activator_account : account

val dummy_account : account

val new_account : ?seed:MBytes.t -> unit -> account

val add_account : t -> unit

val find : Signature.Public_key_hash.t -> t tzresult Lwt.t

val find_alternate : Signature.Public_key_hash.t -> t

(** [generate_accounts ?initial_balances n] : generates [n] random
    accounts with the initial balance of the [i]th account given by the
    [i]th value in the list [initial_balances] or otherwise
    4.000.000.000 tz (if the list is too short); and add them to the
    global account state *)
val generate_accounts :
  ?initial_balances:int64 list -> int -> (t * Tez_repr.t) list

val commitment_secret : Blinded_public_key_hash.activation_code

val new_commitment :
  ?seed:MBytes.t -> unit -> (account * Commitment_repr.t) tzresult Lwt.t
src/proto_alpha/lib_protocol/test/helpers/account.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t;
  pk : Tezos_base__TzPervasives.Signature.Public_key.t;
  sk : Tezos_base__TzPervasives.Signature.Secret_key.t }.

Definition account := t.

Parameter known_accounts :
Tezos_base__TzPervasives.Signature.Public_key_hash.Table.t t.

Parameter activator_account : account.

Parameter dummy_account : account.

Parameter new_account :
(option Tezos_base__TzPervasives.MBytes.t) -> unit -> account.

Parameter add_account : t -> unit.

Parameter find :
Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
  Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter find_alternate :
Tezos_base__TzPervasives.Signature.Public_key_hash.t -> t.

Parameter generate_accounts :
(option (list int64)) ->
  Z -> list (t * Tezos_protocol_alpha.Protocol.Tez_repr.t).

Parameter commitment_secret :
Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code.

Parameter new_commitment :
(option Tezos_base__TzPervasives.MBytes.t) ->
  unit ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (account * Tezos_protocol_alpha.Protocol.Commitment_repr.t)).
src/proto_alpha/lib_protocol/test/helpers/assert.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let error ~loc v f =
  match v with
  | Error err when List.exists f err ->
      return_unit
  | Ok _ ->
      failwith "Unexpected successful result (%s)" loc
  | Error err ->
      failwith "@[Unexpected error (%s): %a@]" loc pp_print_error err

let proto_error ~loc v f =
  error ~loc v (function
      | Environment.Ecoproto_error err ->
          f err
      | _ ->
          false)

let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
  if not (cmp a b) then
    failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b
  else return_unit

let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
  if cmp a b then
    failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b
  else return_unit

(* tez *)
let equal_tez ~loc (a : Alpha_context.Tez.t) (b : Alpha_context.Tez.t) =
  let open Alpha_context in
  equal ~loc Tez.( = ) "Tez aren't equal" Tez.pp a b

let not_equal_tez ~loc (a : Alpha_context.Tez.t) (b : Alpha_context.Tez.t) =
  let open Alpha_context in
  not_equal ~loc Tez.( = ) "Tez are equal" Tez.pp a b

(* int *)
let equal_int ~loc (a : int) (b : int) =
  equal ~loc ( = ) "Integers aren't equal" Format.pp_print_int a b

let not_equal_int ~loc (a : int) (b : int) =
  not_equal ~loc ( = ) "Integers are equal" Format.pp_print_int a b

(* bool *)
let equal_bool ~loc (a : bool) (b : bool) =
  equal ~loc ( = ) "Booleans aren't equal" Format.pp_print_bool a b

let not_equal_bool ~loc (a : bool) (b : bool) =
  not_equal ~loc ( = ) "Booleans are equal" Format.pp_print_bool a b

(* pkh *)
let equal_pkh ~loc (a : Signature.Public_key_hash.t)
    (b : Signature.Public_key_hash.t) =
  let module PKH = Signature.Public_key_hash in
  equal ~loc PKH.equal "Public key hashes  aren't equal" PKH.pp a b

let not_equal_pkh ~loc (a : Signature.Public_key_hash.t)
    (b : Signature.Public_key_hash.t) =
  let module PKH = Signature.Public_key_hash in
  not_equal ~loc PKH.equal "Public key hashes are equal" PKH.pp a b

open Context

(* Some asserts for account operations *)

(** [balance_is b c amount] checks that the current balance of contract [c] is
    [amount].
    Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or
    [Rewards] for the others. *)
let balance_is ~loc b contract ?(kind = Contract.Main) expected =
  Contract.balance b contract ~kind
  >>=? fun balance -> equal_tez ~loc balance expected

(** [balance_was_operated ~operand b c old_balance amount] checks that the
    current balance of contract [c] is [operand old_balance amount] and
    returns the current balance.
    Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or
    [Rewards] for the others. *)
let balance_was_operated ~operand ~loc b contract ?(kind = Contract.Main)
    old_balance amount =
  operand old_balance amount |> Environment.wrap_error |> Lwt.return
  >>=? fun expected -> balance_is ~loc b contract ~kind expected

let balance_was_credited =
  balance_was_operated ~operand:Alpha_context.Tez.( +? )

let balance_was_debited =
  balance_was_operated ~operand:Alpha_context.Tez.( -? )

(* debug *)

let print_balances ctxt id =
  Contract.balance ~kind:Main ctxt id
  >>=? fun main ->
  Contract.balance ~kind:Deposit ctxt id
  >>=? fun deposit ->
  Contract.balance ~kind:Fees ctxt id
  >>=? fun fees ->
  Contract.balance ~kind:Rewards ctxt id
  >>|? fun rewards ->
  Format.printf
    "\nMain: %s\nDeposit: %s\nFees: %s\nRewards: %s\n"
    (Alpha_context.Tez.to_string main)
    (Alpha_context.Tez.to_string deposit)
    (Alpha_context.Tez.to_string fees)
    (Alpha_context.Tez.to_string rewards)
src/proto_alpha/lib_protocol/test/helpers/assert.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition error {A : Type}
  (loc : string) (v : sum A (list Tezos_base__TzPervasives.error))
  (f : Tezos_base__TzPervasives.error -> bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match v with
  | inl _ =>
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Unexpected successful result (" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Unexpected successful result (%s)" % string) loc
  | inr err =>
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.String_literal "Unexpected error (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "): " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format))))))
        "@[Unexpected error (%s): %a@]" % string) loc
      Tezos_base__TzPervasives.pp_print_error err
  end.

Definition proto_error {A : Type}
  (loc : string) (v : sum A (list Tezos_base__TzPervasives.error))
  (f : Tezos_protocol_alpha.Protocol.Environment.Error_monad.error -> bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  error loc v
    (fun function_parameter =>
      match function_parameter with
      | Environment.Ecoproto_error err => f err
      | _ => false
      end).

Definition equal {a : Type}
  (loc : string) (cmp : a -> a -> bool) (msg : string)
  (pp : Stdlib.Format.formatter -> a -> unit) (a : a) (b : a)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if negb (cmp a b) then
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                CamlinternalFormatBasics.End_of_format "" % string))
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal "]" % char
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    (CamlinternalFormatBasics.String_literal " - " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal
                            " : " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " is not equal to " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" % string) loc msg pp a
      pp b
  else
    Tezos_base__TzPervasives.return_unit.

Definition not_equal {a : Type}
  (loc : string) (cmp : a -> a -> bool) (msg : string)
  (pp : Stdlib.Format.formatter -> a -> unit) (a : a) (b : a)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if cmp a b then
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                CamlinternalFormatBasics.End_of_format "" % string))
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal "]" % char
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    (CamlinternalFormatBasics.String_literal " - " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal
                            " : " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " is equal to " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" % string) loc msg pp a pp b
  else
    Tezos_base__TzPervasives.return_unit.

Definition equal_tez
  (loc : string) (a : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (b : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  equal loc Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_eq
    "Tez aren't equal" % string
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp a b.

Definition not_equal_tez
  (loc : string) (a : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (b : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  not_equal loc Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_eq
    "Tez are equal" % string Tezos_protocol_alpha.Protocol.Alpha_context.Tez.pp
    a b.

Definition equal_int (loc : string) (a : Z) (b : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  equal loc equiv_decb "Integers aren't equal" % string
    Stdlib.Format.pp_print_int a b.

Definition not_equal_int (loc : string) (a : Z) (b : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  not_equal loc equiv_decb "Integers are equal" % string
    Stdlib.Format.pp_print_int a b.

Definition equal_bool (loc : string) (a : bool) (b : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  equal loc equiv_decb "Booleans aren't equal" % string
    Stdlib.Format.pp_print_bool a b.

Definition not_equal_bool (loc : string) (a : bool) (b : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  not_equal loc equiv_decb "Booleans are equal" % string
    Stdlib.Format.pp_print_bool a b.

Definition equal_pkh
  (loc : string) (a : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (b : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let PKH := Tezos_base__TzPervasives.Signature.Public_key_hash in
  equal loc PKH.equal "Public key hashes  aren't equal" % string PKH.pp a b.

Definition not_equal_pkh
  (loc : string) (a : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (b : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let PKH := Tezos_base__TzPervasives.Signature.Public_key_hash in
  not_equal loc PKH.equal "Public key hashes are equal" % string PKH.pp a b.

Import Tezos_alpha_test_helpers.Context.

Definition balance_is
  (loc : string) (b : Tezos_alpha_test_helpers__Context.t)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (op_star_o_p_t_star :
    option Tezos_alpha_test_helpers.Context.Contract.balance_kind)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let kind :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Contract.Main
    end in
  fun expected =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_alpha_test_helpers.Context.Contract.balance (Some kind) b contract)
      (fun balance => equal_tez loc balance expected).

Definition balance_was_operated {A B : Type}
  (operand :
    A ->
      B ->
        Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) (loc : string)
  (b : Tezos_alpha_test_helpers__Context.t)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (op_star_o_p_t_star :
    option Tezos_alpha_test_helpers.Context.Contract.balance_kind)
  : A -> B -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let kind :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Contract.Main
    end in
  fun old_balance =>
    fun amount =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply (operand old_balance amount)
            Tezos_protocol_alpha.Protocol.Environment.wrap_error) Lwt._return)
        (fun expected => balance_is loc b contract (Some kind) expected).

Definition balance_was_credited
  : string ->
    Tezos_alpha_test_helpers__Context.t ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        (option Tezos_alpha_test_helpers.Context.Contract.balance_kind) ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  balance_was_operated
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question.

Definition balance_was_debited
  : string ->
    Tezos_alpha_test_helpers__Context.t ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        (option Tezos_alpha_test_helpers.Context.Contract.balance_kind) ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  balance_was_operated
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_minus_question.

Definition print_balances
  (ctxt : Tezos_alpha_test_helpers__Context.t)
  (id : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_alpha_test_helpers.Context.Contract.balance (Some Main) ctxt id)
    (fun main =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_alpha_test_helpers.Context.Contract.balance (Some Deposit) ctxt
          id)
        (fun deposit =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_alpha_test_helpers.Context.Contract.balance (Some Fees) ctxt
              id)
            (fun fees =>
              Tezos_base__TzPervasives.op_gt_gt_pipe_question
                (Tezos_alpha_test_helpers.Context.Contract.balance
                  (Some Rewards) ctxt id)
                (fun rewards =>
                  Stdlib.Format.printf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "
Main: " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal
                            "
Deposit: " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                "
Fees: " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    "
Rewards: " % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Char_literal
                                        "010" % char
                                        CamlinternalFormatBasics.End_of_format)))))))))
                      "
Main: %s
Deposit: %s
Fees: %s
Rewards: %s
" % string)
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_string
                      main)
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_string
                      deposit)
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_string
                      fees)
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_string
                      rewards))))).
src/proto_alpha/lib_protocol/test/helpers/block.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *)

open Alpha_context

(* This type collects a block and the context that results from its application *)
type t = {
  hash : Block_hash.t;
  header : Block_header.t;
  operations : Operation.packed list;
  context : Tezos_protocol_environment.Context.t;
}

type block = t

let rpc_context block =
  {
    Environment.Updater.block_hash = block.hash;
    block_header = block.header.shell;
    context = block.context;
  }

let rpc_ctxt =
  new Environment.proto_rpc_context_of_directory rpc_context rpc_services

(******** Policies ***********)

(* Policies are functions that take a block and return a tuple
   [(account, level, timestamp)] for the [forge_header] function. *)

(* This type is used only to provide a simpler interface to the exterior. *)
type baker_policy =
  | By_priority of int
  | By_account of public_key_hash
  | Excluding of public_key_hash list

let get_next_baker_by_priority priority block =
  Alpha_services.Delegate.Baking_rights.get
    rpc_ctxt
    ~all:true
    ~max_priority:(priority + 1)
    block
  >>=? fun bakers ->
  let {Alpha_services.Delegate.Baking_rights.delegate = pkh; timestamp; _} =
    List.find
      (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} ->
        p = priority)
      bakers
  in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let get_next_baker_by_account pkh block =
  Alpha_services.Delegate.Baking_rights.get
    rpc_ctxt
    ~delegates:[pkh]
    ~max_priority:256
    block
  >>=? fun bakers ->
  let { Alpha_services.Delegate.Baking_rights.delegate = pkh;
        timestamp;
        priority;
        _ } =
    List.hd bakers
  in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let get_next_baker_excluding excludes block =
  Alpha_services.Delegate.Baking_rights.get rpc_ctxt ~max_priority:256 block
  >>=? fun bakers ->
  let { Alpha_services.Delegate.Baking_rights.delegate = pkh;
        timestamp;
        priority;
        _ } =
    List.find
      (fun {Alpha_services.Delegate.Baking_rights.delegate; _} ->
        not (List.mem delegate excludes))
      bakers
  in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let dispatch_policy = function
  | By_priority p ->
      get_next_baker_by_priority p
  | By_account a ->
      get_next_baker_by_account a
  | Excluding al ->
      get_next_baker_excluding al

let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy

let get_endorsing_power b =
  fold_left_s
    (fun acc (op : Operation.packed) ->
      let (Operation_data data) = op.protocol_data in
      match data.contents with
      | Single (Endorsement _) ->
          Alpha_services.Delegate.Endorsing_power.get
            rpc_ctxt
            b
            op
            Chain_id.zero
          >>=? fun endorsement_power -> return (acc + endorsement_power)
      | _ ->
          return acc)
    0
    b.operations

module Forge = struct
  type header = {
    baker : public_key_hash;
    (* the signer of the block *)
    shell : Block_header.shell_header;
    contents : Block_header.contents;
  }

  let default_proof_of_work_nonce =
    MBytes.create Constants.proof_of_work_nonce_size

  let make_contents ?(proof_of_work_nonce = default_proof_of_work_nonce)
      ~priority ~seed_nonce_hash () =
    Block_header.{priority; proof_of_work_nonce; seed_nonce_hash}

  let make_shell ~level ~predecessor ~timestamp ~fitness ~operations_hash =
    Tezos_base.Block_header.
      {
        level;
        predecessor;
        timestamp;
        fitness;
        operations_hash;
        (* We don't care of the following values, only the shell validates them. *)
        proto_level = 0;
        validation_passes = 0;
        context = Context_hash.zero;
      }

  let set_seed_nonce_hash seed_nonce_hash {baker; shell; contents} =
    {baker; shell; contents = {contents with seed_nonce_hash}}

  let set_baker baker header = {header with baker}

  let sign_header {baker; shell; contents} =
    Account.find baker
    >>=? fun delegate ->
    let unsigned_bytes =
      Data_encoding.Binary.to_bytes_exn
        Block_header.unsigned_encoding
        (shell, contents)
    in
    let signature =
      Signature.sign
        ~watermark:Signature.(Block_header Chain_id.zero)
        delegate.sk
        unsigned_bytes
    in
    Block_header.{shell; protocol_data = {contents; signature}} |> return

  let forge_header ?(policy = By_priority 0) ?timestamp ?(operations = []) pred
      =
    dispatch_policy policy pred
    >>=? fun (pkh, priority, _timestamp) ->
    Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt pred priority 0
    >>=? fun expected_timestamp ->
    let timestamp = Option.unopt ~default:expected_timestamp timestamp in
    let level = Int32.succ pred.header.shell.level in
    ( match Fitness_repr.to_int64 pred.header.shell.fitness with
    | Ok old_fitness ->
        return
          (Fitness_repr.from_int64 (Int64.add (Int64.of_int 1) old_fitness))
    | Error _ ->
        assert false )
    >>=? fun fitness ->
    Alpha_services.Helpers.current_level ~offset:1l rpc_ctxt pred
    >>|? (function
           | {expected_commitment = true; _} ->
               Some (fst (Proto_Nonce.generate ()))
           | {expected_commitment = false; _} ->
               None)
    >>=? fun seed_nonce_hash ->
    let hashes = List.map Operation.hash_packed operations in
    let operations_hash =
      Operation_list_list_hash.compute [Operation_list_hash.compute hashes]
    in
    let shell =
      make_shell
        ~level
        ~predecessor:pred.hash
        ~timestamp
        ~fitness
        ~operations_hash
    in
    let contents = make_contents ~priority ~seed_nonce_hash () in
    return {baker = pkh; shell; contents}

  (* compatibility only, needed by incremental *)
  let contents ?(proof_of_work_nonce = default_proof_of_work_nonce)
      ?(priority = 0) ?seed_nonce_hash () =
    {Block_header.priority; proof_of_work_nonce; seed_nonce_hash}
end

(********* Genesis creation *************)

(* Hard-coded context key *)
let protocol_param_key = ["protocol_parameters"]

let check_constants_consistency constants =
  let open Constants_repr in
  let {blocks_per_cycle; blocks_per_commitment; blocks_per_roll_snapshot; _} =
    constants
  in
  Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) (fun () ->
      failwith
        "Inconsistent constants : blocks per commitment must be less than \
         blocks per cycle")
  >>=? fun () ->
  Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) (fun () ->
      failwith
        "Inconsistent constants : blocks per cycle must be superior than \
         blocks per roll snapshot")
  >>=? return

let initial_context ?(with_commitments = false) constants header
    initial_accounts =
  let open Tezos_protocol_alpha_parameters in
  let bootstrap_accounts =
    List.map
      (fun (Account.{pk; pkh; _}, amount) ->
        Default_parameters.make_bootstrap_account (pkh, pk, amount))
      initial_accounts
  in
  let parameters =
    Default_parameters.parameters_of_constants
      ~bootstrap_accounts
      ~with_commitments
      constants
  in
  let json = Default_parameters.json_of_parameters parameters in
  let proto_params =
    Data_encoding.Binary.to_bytes_exn Data_encoding.json json
  in
  Tezos_protocol_environment.Context.(
    let empty = Memory_context.empty in
    set empty ["version"] (MBytes.of_string "genesis")
    >>= fun ctxt -> set ctxt protocol_param_key proto_params)
  >>= fun ctxt ->
  Main.init ctxt header >|= Environment.wrap_error
  >>=? fun {context; _} -> return context

let genesis_with_parameters parameters =
  let hash =
    Block_hash.of_b58check_exn
      "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
  in
  let shell =
    Forge.make_shell
      ~level:0l
      ~predecessor:hash
      ~timestamp:Time.Protocol.epoch
      ~fitness:(Fitness_repr.from_int64 0L)
      ~operations_hash:Operation_list_list_hash.zero
  in
  let contents = Forge.make_contents ~priority:0 ~seed_nonce_hash:None () in
  let open Tezos_protocol_alpha_parameters in
  let json = Default_parameters.json_of_parameters parameters in
  let proto_params =
    Data_encoding.Binary.to_bytes_exn Data_encoding.json json
  in
  Tezos_protocol_environment.Context.(
    let empty = Memory_context.empty in
    set empty ["version"] (MBytes.of_string "genesis")
    >>= fun ctxt -> set ctxt protocol_param_key proto_params)
  >>= fun ctxt ->
  Main.init ctxt shell >|= Environment.wrap_error
  >>=? fun {context; _} ->
  let block =
    {
      hash;
      header = {shell; protocol_data = {contents; signature = Signature.zero}};
      operations = [];
      context;
    }
  in
  return block

(* if no parameter file is passed we check in the current directory
   where the test is run *)
let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers
    ?min_proposal_quorum (initial_accounts : (Account.t * Tez_repr.t) list) =
  if initial_accounts = [] then
    Pervasives.failwith "Must have one account with a roll to bake" ;
  let open Tezos_protocol_alpha_parameters in
  let constants = Default_parameters.constants_test in
  let endorsers_per_block =
    Option.unopt ~default:constants.endorsers_per_block endorsers_per_block
  in
  let initial_endorsers =
    Option.unopt ~default:constants.initial_endorsers initial_endorsers
  in
  let min_proposal_quorum =
    Option.unopt ~default:constants.min_proposal_quorum min_proposal_quorum
  in
  let constants =
    {
      constants with
      endorsers_per_block;
      initial_endorsers;
      min_proposal_quorum;
    }
  in
  (* Check there is at least one roll *)
  ( try
      let open Test_utils in
      fold_left_s
        (fun acc (_, amount) ->
          Environment.wrap_error @@ Tez_repr.( +? ) acc amount
          >>?= fun acc ->
          if acc >= constants.tokens_per_roll then raise Exit else return acc)
        Tez_repr.zero
        initial_accounts
      >>=? fun _ ->
      failwith "Insufficient tokens in initial accounts to create one roll"
    with Exit -> return_unit )
  >>=? fun () ->
  check_constants_consistency constants
  >>=? fun () ->
  let hash =
    Block_hash.of_b58check_exn
      "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
  in
  let shell =
    Forge.make_shell
      ~level:0l
      ~predecessor:hash
      ~timestamp:Time.Protocol.epoch
      ~fitness:(Fitness_repr.from_int64 0L)
      ~operations_hash:Operation_list_list_hash.zero
  in
  let contents = Forge.make_contents ~priority:0 ~seed_nonce_hash:None () in
  initial_context ?with_commitments constants shell initial_accounts
  >>=? fun context ->
  let block =
    {
      hash;
      header = {shell; protocol_data = {contents; signature = Signature.zero}};
      operations = [];
      context;
    }
  in
  return block

(********* Baking *************)

let apply header ?(operations = []) pred =
  (let open Environment.Error_monad in
  Main.begin_application
    ~chain_id:Chain_id.zero
    ~predecessor_context:pred.context
    ~predecessor_fitness:pred.header.shell.fitness
    ~predecessor_timestamp:pred.header.shell.timestamp
    header
  >>=? fun vstate ->
  fold_left_s
    (fun vstate op ->
      apply_operation vstate op >>=? fun (state, _result) -> return state)
    vstate
    operations
  >>=? fun vstate ->
  Main.finalize_block vstate
  >>=? fun (validation, _result) -> return validation.context)
  >|= Environment.wrap_error
  >>|? fun context ->
  let hash = Block_header.hash header in
  {hash; header; operations; context}

let bake ?policy ?timestamp ?operation ?operations pred =
  let operations =
    match (operation, operations) with
    | (Some op, Some ops) ->
        Some (op :: ops)
    | (Some op, None) ->
        Some [op]
    | (None, Some ops) ->
        Some ops
    | (None, None) ->
        None
  in
  Forge.forge_header ?timestamp ?policy ?operations pred
  >>=? fun header ->
  Forge.sign_header header >>=? fun header -> apply header ?operations pred

(********** Cycles ****************)

(* This function is duplicated from Context to avoid a cyclic dependency *)
let get_constants b = Alpha_services.Constants.all rpc_ctxt b

let bake_n ?policy n b =
  Error_monad.fold_left_s (fun b _ -> bake ?policy b) b (1 -- n)

let bake_until_cycle_end ?policy b =
  get_constants b
  >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} ->
  let current_level = b.header.shell.level in
  let current_level = Int32.rem current_level blocks_per_cycle in
  let delta = Int32.sub blocks_per_cycle current_level in
  bake_n ?policy (Int32.to_int delta) b

let bake_until_n_cycle_end ?policy n b =
  Error_monad.fold_left_s (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n)

let bake_until_cycle ?policy cycle (b : t) =
  get_constants b
  >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} ->
  let rec loop (b : t) =
    let current_cycle =
      let current_level = b.header.shell.level in
      let current_cycle = Int32.div current_level blocks_per_cycle in
      current_cycle
    in
    if Int32.equal (Cycle.to_int32 cycle) current_cycle then return b
    else bake_until_cycle_end ?policy b >>=? fun b -> loop b
  in
  loop b
src/proto_alpha/lib_protocol/test/helpers/block.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Record t := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  header : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t;
  operations : list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
  context : Tezos_protocol_environment.Context.t }.

Definition block := t.

Definition rpc_context (block : t)
  : Tezos_protocol_alpha.Protocol.Environment.Updater.rpc_context :=
  {| Environment.Updater.block_hash := hash block;
    Environment.Updater.block_header := shell (header block);
    Environment.Updater.context := context block |}.

Definition rpc_ctxt
  : Tezos_protocol_alpha.Protocol.Environment.proto_rpc_context_of_directory t :=
  new rpc_context Tezos_protocol_alpha.Protocol.rpc_services.

Inductive baker_policy : Type :=
| By_priority : Z -> baker_policy
| By_account : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
  baker_policy
| Excluding : (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  -> baker_policy.

Definition get_next_baker_by_priority (priority : Z) (block : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Baking_rights.get
      rpc_ctxt None None None (Some true) (Some (Z.add priority 1)) block)
    (fun bakers =>
      match
        Tezos_base__TzPervasives.List.find
          (fun function_parameter =>
            match function_parameter with
            | {| Alpha_services.Delegate.Baking_rights.priority := p |} =>
              equiv_decb p priority
            end) bakers with
      | {|
        Alpha_services.Delegate.Baking_rights.delegate := pkh;
          Alpha_services.Delegate.Baking_rights.timestamp := timestamp
          |} =>
        Tezos_base__TzPervasives._return
          (pkh, priority,
            (Tezos_base__TzPervasives.Option.unopt_exn
              (OCaml.Failure "" % string) timestamp))
      end).

Definition get_next_baker_by_account
  (pkh : Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
  (block : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Baking_rights.get
      rpc_ctxt None None (Some (cons pkh [])) None (Some 256) block)
    (fun bakers =>
      match Tezos_base__TzPervasives.List.hd bakers with
      | {|
        Alpha_services.Delegate.Baking_rights.delegate := pkh;
          Alpha_services.Delegate.Baking_rights.priority := priority;
          Alpha_services.Delegate.Baking_rights.timestamp := timestamp
          |} =>
        Tezos_base__TzPervasives._return
          (pkh, priority,
            (Tezos_base__TzPervasives.Option.unopt_exn
              (OCaml.Failure "" % string) timestamp))
      end).

Definition get_next_baker_excluding
  (excludes :
    list
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (block : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Baking_rights.get
      rpc_ctxt None None None None (Some 256) block)
    (fun bakers =>
      match
        Tezos_base__TzPervasives.List.find
          (fun function_parameter =>
            match function_parameter with
            | {| Alpha_services.Delegate.Baking_rights.delegate := delegate |}
              => negb (Tezos_base__TzPervasives.List.mem delegate excludes)
            end) bakers with
      | {|
        Alpha_services.Delegate.Baking_rights.delegate := pkh;
          Alpha_services.Delegate.Baking_rights.priority := priority;
          Alpha_services.Delegate.Baking_rights.timestamp := timestamp
          |} =>
        Tezos_base__TzPervasives._return
          (pkh, priority,
            (Tezos_base__TzPervasives.Option.unopt_exn
              (OCaml.Failure "" % string) timestamp))
      end).

Definition dispatch_policy (function_parameter : baker_policy)
  : t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  match function_parameter with
  | By_priority p => get_next_baker_by_priority p
  | By_account a => get_next_baker_by_account a
  | Excluding al => get_next_baker_excluding al
  end.

Definition get_next_baker (op_star_o_p_t_star : option baker_policy)
  : t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  let policy :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => By_priority 0
    end in
  dispatch_policy policy.

Definition get_endorsing_power (b : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
  Tezos_base__TzPervasives.fold_left_s
    (fun acc =>
      fun op =>
        match protocol_data op with
        | Operation_data data =>
          match contents data with
          | Single (Endorsement _) =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Endorsing_power.get
                rpc_ctxt b op Tezos_base__TzPervasives.Chain_id.zero)
              (fun endorsement_power =>
                Tezos_base__TzPervasives._return (Z.add acc endorsement_power))
          | _ => Tezos_base__TzPervasives._return acc
          end
        end) 0 (operations b).

Module Forge.
  Record header := {
    baker : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
    shell :
      Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.shell_header;
    contents : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents
    }.
  
  Definition default_proof_of_work_nonce : Tezos_base__TzPervasives.MBytes.t :=
    Tezos_base__TzPervasives.MBytes.create
      Tezos_protocol_alpha.Protocol.Alpha_context.Constants.proof_of_work_nonce_size.
  
  Definition make_contents
    (op_star_o_p_t_star : option Tezos_base__TzPervasives.MBytes.t)
    : Z ->
      (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
        unit ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents :=
    let proof_of_work_nonce :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_proof_of_work_nonce
      end in
    fun priority =>
      fun seed_nonce_hash =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            {| priority := priority; seed_nonce_hash := seed_nonce_hash;
              proof_of_work_nonce := proof_of_work_nonce |}
          end.
  
  Definition make_shell
    (level : Stdlib.Int32.t) (predecessor : Tezos_crypto.Block_hash.t)
    (timestamp : Tezos_base.Time.Protocol.t) (fitness : Tezos_base.Fitness.t)
    (operations_hash : Tezos_crypto.Operation_list_list_hash.t)
    : Tezos_base.Block_header.shell_header :=
    {| level := level; proto_level := 0; predecessor := predecessor;
      timestamp := timestamp; validation_passes := 0;
      operations_hash := operations_hash; fitness := fitness;
      context := Tezos_base__TzPervasives.Context_hash.zero |}.
  
  Definition set_seed_nonce_hash
    (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
    (function_parameter : header) : header :=
    match function_parameter with
    | {| baker := baker; shell := shell; contents := contents |} =>
      {| baker := baker; shell := shell; contents := record |}
    end.
  
  Definition set_baker
    (baker : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
    (header : header) : header := record.
  
  Definition sign_header (function_parameter : header)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t) :=
    match function_parameter with
    | {| baker := baker; shell := shell; contents := contents |} =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_alpha_test_helpers.Account.find baker)
        (fun delegate =>
          let unsigned_bytes :=
            Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
              Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.unsigned_encoding
              (shell, contents) in
          let signature :=
            Tezos_base__TzPervasives.Signature.sign
              (Some (Block_header Tezos_base__TzPervasives.Chain_id.zero))
              (sk delegate) unsigned_bytes in
          OCaml.Stdlib.reverse_apply
            {| shell := shell;
              protocol_data :=
                {| contents := contents; signature := signature |} |}
            Tezos_base__TzPervasives._return)
    end.
  
  Definition forge_header (op_star_o_p_t_star : option baker_policy)
    : (option Tezos_protocol_environment_alpha__Environment.Time.t) ->
      (option (list Tezos_raw_protocol_alpha__Alpha_context.packed_operation))
        -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult header) :=
    let policy :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => By_priority 0
      end in
    fun timestamp =>
      fun op_star_o_p_t_star =>
        let operations :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => []
          end in
        fun pred =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (dispatch_policy policy pred)
            (fun function_parameter =>
              match function_parameter with
              | (pkh, priority, _timestamp) =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Minimal_valid_time.get
                    rpc_ctxt pred priority 0)
                  (fun expected_timestamp =>
                    let timestamp :=
                      Tezos_base__TzPervasives.Option.unopt expected_timestamp
                        timestamp in
                    let level := Stdlib.Int32.succ (level (shell (header pred)))
                      in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      match
                        Tezos_protocol_alpha.Protocol.Fitness_repr.to_int64
                          (fitness (shell (header pred))) with
                      | inl old_fitness =>
                        Tezos_base__TzPervasives._return
                          (Tezos_protocol_alpha.Protocol.Fitness_repr.from_int64
                            (Stdlib.Int64.add (Stdlib.Int64.of_int 1)
                              old_fitness))
                      | inr _ => false
                      end
                      (fun fitness =>
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_base__TzPervasives.op_gt_gt_pipe_question
                            (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level
                              rpc_ctxt (Some 1) pred)
                            (fun function_parameter =>
                              match function_parameter with
                              | {| expected_commitment := true |} =>
                                Some (fst (Proto_Nonce.generate tt))
                              | {| expected_commitment := false |} => None
                              end))
                          (fun seed_nonce_hash =>
                            let hashes :=
                              Tezos_base__TzPervasives.List.map
                                Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash_packed
                                operations in
                            let operations_hash :=
                              Tezos_base__TzPervasives.Operation_list_list_hash.compute
                                (cons
                                  (Tezos_base__TzPervasives.Operation_list_hash.compute
                                    hashes) []) in
                            let shell :=
                              make_shell level (hash pred) timestamp fitness
                                operations_hash in
                            let contents :=
                              make_contents None priority seed_nonce_hash tt in
                            Tezos_base__TzPervasives._return
                              {| baker := pkh; shell := shell;
                                contents := contents |})))
              end).
  
  Definition contents
    (op_star_o_p_t_star : option Tezos_base__TzPervasives.MBytes.t)
    : (option Z) ->
      (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
        unit ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents :=
    let proof_of_work_nonce :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_proof_of_work_nonce
      end in
    fun op_star_o_p_t_star =>
      let priority :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => 0
        end in
      fun seed_nonce_hash =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            {| Block_header.priority := priority;
              Block_header.seed_nonce_hash := seed_nonce_hash;
              Block_header.proof_of_work_nonce := proof_of_work_nonce |}
          end.
End Forge.

Definition protocol_param_key : list string :=
  cons "protocol_parameters" % string [].

Definition check_constants_consistency
  (constants : Tezos_protocol_alpha.Protocol.Constants_repr.parametric)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match constants with
  | {|
    blocks_per_cycle := blocks_per_cycle;
      blocks_per_commitment := blocks_per_commitment;
      blocks_per_roll_snapshot := blocks_per_roll_snapshot
      |} =>
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_base__TzPervasives.Error_monad.unless
        (OCaml.Stdlib.le blocks_per_commitment blocks_per_cycle)
        (fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_base__TzPervasives.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Inconsistent constants : blocks per commitment must be less than blocks per cycle"
                    % string CamlinternalFormatBasics.End_of_format)
                "Inconsistent constants : blocks per commitment must be less than blocks per cycle"
                  % string)
          end))
      (fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_base__TzPervasives.Error_monad.unless
              (OCaml.Stdlib.ge blocks_per_cycle blocks_per_roll_snapshot)
              (fun function_parameter =>
                match function_parameter with
                | tt =>
                  Tezos_base__TzPervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Inconsistent constants : blocks per cycle must be superior than blocks per roll snapshot"
                          % string CamlinternalFormatBasics.End_of_format)
                      "Inconsistent constants : blocks per cycle must be superior than blocks per roll snapshot"
                        % string)
                end)) Tezos_base__TzPervasives._return
        end)
  end.

Definition initial_context (op_star_o_p_t_star : option bool)
  : Tezos_protocol_alpha.Protocol.Constants_repr.parametric ->
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header ->
      (list
        (Tezos_alpha_test_helpers.Account.t *
          Tezos_protocol_alpha.Protocol.Tez_repr.t)) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_environment_alpha__Environment.Context.t) :=
  let with_commitments :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun constants =>
    fun header =>
      fun initial_accounts =>
        let bootstrap_accounts :=
          Tezos_base__TzPervasives.List.map
            (fun function_parameter =>
              match function_parameter with
              | ({| pkh := pkh; pk := pk |}, amount) =>
                Tezos_protocol_alpha_parameters.Default_parameters.make_bootstrap_account
                  (pkh, pk, amount)
              end) initial_accounts in
        let parameters :=
          Tezos_protocol_alpha_parameters.Default_parameters.parameters_of_constants
            (Some bootstrap_accounts) None (Some with_commitments) constants in
        let json :=
          Tezos_protocol_alpha_parameters.Default_parameters.json_of_parameters
            parameters in
        let proto_params :=
          Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
            Tezos_base__TzPervasives.Data_encoding.json json in
        Tezos_base__TzPervasives.op_gt_gt_eq
          (let empty := Memory_context.empty in
          Tezos_base__TzPervasives.op_gt_gt_eq
            (Tezos_protocol_environment.Context.set empty
              (cons "version" % string [])
              (Tezos_base__TzPervasives.MBytes.of_string "genesis" % string))
            (fun ctxt =>
              Tezos_protocol_environment.Context.set ctxt protocol_param_key
                proto_params))
          (fun ctxt =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.op_gt_pipe_eq
                (Tezos_protocol_alpha.Protocol.Main.init ctxt header)
                Tezos_protocol_alpha.Protocol.Environment.wrap_error)
              (fun function_parameter =>
                match function_parameter with
                | {| context := context |} =>
                  Tezos_base__TzPervasives._return context
                end)).

Definition genesis_with_parameters
  (parameters : Tezos_protocol_alpha.Protocol.Parameters_repr.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let hash :=
    Tezos_base__TzPervasives.Block_hash.of_b58check_exn
      "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" % string in
  let shell :=
    Forge.make_shell 0 hash Tezos_base__TzPervasives.Time.Protocol.epoch
      (Tezos_protocol_alpha.Protocol.Fitness_repr.from_int64 0)
      Tezos_base__TzPervasives.Operation_list_list_hash.zero in
  let contents := Forge.make_contents None 0 None tt in
  let json :=
    Tezos_protocol_alpha_parameters.Default_parameters.json_of_parameters
      parameters in
  let proto_params :=
    Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
      Tezos_base__TzPervasives.Data_encoding.json json in
  Tezos_base__TzPervasives.op_gt_gt_eq
    (let empty := Memory_context.empty in
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_protocol_environment.Context.set empty (cons "version" % string [])
        (Tezos_base__TzPervasives.MBytes.of_string "genesis" % string))
      (fun ctxt =>
        Tezos_protocol_environment.Context.set ctxt protocol_param_key
          proto_params))
    (fun ctxt =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_base__TzPervasives.op_gt_pipe_eq
          (Tezos_protocol_alpha.Protocol.Main.init ctxt shell)
          Tezos_protocol_alpha.Protocol.Environment.wrap_error)
        (fun function_parameter =>
          match function_parameter with
          | {| context := context |} =>
            let block :=
              {| hash := hash;
                header :=
                  {| shell := shell;
                    protocol_data :=
                      {| contents := contents;
                        signature := Tezos_base__TzPervasives.Signature.zero |}
                    |}; operations := []; context := context |} in
            Tezos_base__TzPervasives._return block
          end)).

Definition genesis
  (with_commitments : option bool) (endorsers_per_block : option Z)
  (initial_endorsers : option Z) (min_proposal_quorum : option int32)
  (initial_accounts :
    list
      (Tezos_alpha_test_helpers.Account.t *
        Tezos_protocol_alpha.Protocol.Tez_repr.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  if equiv_decb initial_accounts [] then
    Stdlib.Pervasives.failwith
      "Must have one account with a roll to bake" % string
  else
    tt;
  let constants :=
    Tezos_protocol_alpha_parameters.Default_parameters.constants_test in
  let endorsers_per_block :=
    Tezos_base__TzPervasives.Option.unopt (endorsers_per_block constants)
      endorsers_per_block in
  let initial_endorsers :=
    Tezos_base__TzPervasives.Option.unopt (initial_endorsers constants)
      initial_endorsers in
  let min_proposal_quorum :=
    Tezos_base__TzPervasives.Option.unopt (min_proposal_quorum constants)
      min_proposal_quorum in
  let constants := record in
  Tezos_base__TzPervasives.op_gt_gt_eq_question try
    (fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (check_constants_consistency constants)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              let hash :=
                Tezos_base__TzPervasives.Block_hash.of_b58check_exn
                  "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" % string
                in
              let shell :=
                Forge.make_shell 0 hash
                  Tezos_base__TzPervasives.Time.Protocol.epoch
                  (Tezos_protocol_alpha.Protocol.Fitness_repr.from_int64 0)
                  Tezos_base__TzPervasives.Operation_list_list_hash.zero in
              let contents := Forge.make_contents None 0 None tt in
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                (initial_context with_commitments constants shell
                  initial_accounts)
                (fun context =>
                  let block :=
                    {| hash := hash;
                      header :=
                        {| shell := shell;
                          protocol_data :=
                            {| contents := contents;
                              signature :=
                                Tezos_base__TzPervasives.Signature.zero |} |};
                      operations := []; context := context |} in
                  Tezos_base__TzPervasives._return block)
            end)
      end).

Definition apply
  (header : Tezos_protocol_alpha.Protocol.Main.block_header)
  (op_star_o_p_t_star :
    option (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed))
  : t -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let operations :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun pred =>
    Tezos_base__TzPervasives.op_gt_gt_pipe_question
      (Tezos_base__TzPervasives.op_gt_pipe_eq
        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_protocol_alpha.Protocol.Main.begin_application
            Tezos_base__TzPervasives.Chain_id.zero (context pred)
            (timestamp (shell (header pred))) (fitness (shell (header pred)))
            header)
          (fun vstate =>
            Tezos_protocol_alpha.Protocol.Environment.Error_monad.op_gt_gt_eq_question
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.fold_left_s
                (fun vstate =>
                  fun op =>
                    Tezos_protocol_alpha.Protocol.Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_alpha.Protocol.apply_operation vstate op)
                      (fun function_parameter =>
                        match function_parameter with
                        | (state, _result) =>
                          Tezos_protocol_alpha.Protocol.Environment.Error_monad._return
                            state
                        end)) vstate operations)
              (fun vstate =>
                Tezos_protocol_alpha.Protocol.Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_alpha.Protocol.Main.finalize_block vstate)
                  (fun function_parameter =>
                    match function_parameter with
                    | (validation, _result) =>
                      Tezos_protocol_alpha.Protocol.Environment.Error_monad._return
                        (context validation)
                    end)))) Tezos_protocol_alpha.Protocol.Environment.wrap_error)
      (fun context =>
        let hash :=
          Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.hash header
          in
        {| hash := hash; header := header; operations := operations;
          context := context |}).

Definition bake
  (policy : option baker_policy)
  (timestamp : option Tezos_protocol_environment_alpha__Environment.Time.t)
  (operation :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  (operations :
    option (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed))
  (pred : t) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let operations :=
    match (operation, operations) with
    | (Some op, Some ops) => Some (cons op ops)
    | (Some op, None) => Some (cons op [])
    | (None, Some ops) => Some ops
    | (None, None) => None
    end in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Forge.forge_header policy timestamp operations pred)
    (fun header =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question (Forge.sign_header header)
        (fun header => apply header operations pred)).

Definition get_constants (b : t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all rpc_ctxt b.

Definition bake_n (policy : option baker_policy) (n : Z) (b : t)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult t) :=
  Tezos_base__TzPervasives.Error_monad.fold_left_s
    (fun b =>
      fun function_parameter =>
        match function_parameter with
        | _ => bake policy None None None b
        end) b (Tezos_base__TzPervasives.op_minus_minus 1 n).

Definition bake_until_cycle_end (policy : option baker_policy) (b : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (get_constants b)
    (fun function_parameter =>
      match function_parameter with
      | {| parametric := {| blocks_per_cycle := blocks_per_cycle |} |} =>
        let current_level := level (shell (header b)) in
        let current_level := Stdlib.Int32.rem current_level blocks_per_cycle in
        let delta := Stdlib.Int32.sub blocks_per_cycle current_level in
        bake_n policy (Stdlib.Int32.to_int delta) b
      end).

Definition bake_until_n_cycle_end (policy : option baker_policy) (n : Z) (b : t)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult t) :=
  Tezos_base__TzPervasives.Error_monad.fold_left_s
    (fun b =>
      fun function_parameter =>
        match function_parameter with
        | _ => bake_until_cycle_end policy b
        end) b (Tezos_base__TzPervasives.op_minus_minus 1 n).

Definition bake_until_cycle
  (policy : option baker_policy)
  (cycle : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle) (b : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (get_constants b)
    (fun function_parameter =>
      match function_parameter with
      | {| parametric := {| blocks_per_cycle := blocks_per_cycle |} |} =>
        let fix loop (b : t) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
          let current_cycle :=
            let current_level := level (shell (header b)) in
            let current_cycle := Stdlib.Int32.div current_level blocks_per_cycle
              in
            current_cycle in
          if
            Stdlib.Int32.equal
              (Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.to_int32 cycle)
              current_cycle then
            Tezos_base__TzPervasives._return b
          else
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (bake_until_cycle_end policy b) (fun b => loop b) in
        loop b
      end).
src/proto_alpha/lib_protocol/test/helpers/block.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type t = {
  hash : Block_hash.t;
  header : Block_header.t;
  operations : Operation.packed list;
  context : Tezos_protocol_environment.Context.t;  (** Resulting context *)
}

type block = t

val rpc_ctxt : t Environment.RPC_context.simple

(** Policies to select the next baker:
    - [By_priority p] selects the baker at priority [p]
    - [By_account pkh] selects the first slot for baker [pkh]
    - [Excluding pkhs] selects the first baker that doesn't belong to [pkhs]
*)
type baker_policy =
  | By_priority of int
  | By_account of public_key_hash
  | Excluding of public_key_hash list

(** Returns (account, priority, timestamp) of the next baker given
    a policy, defaults to By_priority 0. *)
val get_next_baker :
  ?policy:baker_policy ->
  t ->
  (public_key_hash * int * Time.Protocol.t) tzresult Lwt.t

val get_endorsing_power : block -> int tzresult Lwt.t

module Forge : sig
  val contents :
    ?proof_of_work_nonce:MBytes.t ->
    ?priority:int ->
    ?seed_nonce_hash:Nonce_hash.t ->
    unit ->
    Block_header.contents

  type header

  (** Forges a correct header following the policy.
      The header can then be modified and applied with [apply]. *)
  val forge_header :
    ?policy:baker_policy ->
    ?timestamp:Timestamp.time ->
    ?operations:Operation.packed list ->
    t ->
    header tzresult Lwt.t

  (** Sets uniquely seed_nonce_hash of a header *)
  val set_seed_nonce_hash : Nonce_hash.t option -> header -> header

  (** Sets the baker that will sign the header to an arbitrary pkh *)
  val set_baker : public_key_hash -> header -> header

  (** Signs the header with the key of the baker configured in the header.
      The header can no longer be modified, only applied. *)
  val sign_header : header -> Block_header.block_header tzresult Lwt.t
end

(** [genesis <opts> accounts] : generates an initial block with the
    given constants [<opts>] and initializes [accounts] with their
    associated amounts.
*)
val genesis :
  ?with_commitments:bool ->
  ?endorsers_per_block:int ->
  ?initial_endorsers:int ->
  ?min_proposal_quorum:int32 ->
  (Account.t * Tez_repr.tez) list ->
  block tzresult Lwt.t

val genesis_with_parameters : Parameters_repr.t -> block tzresult Lwt.t

(** Applies a signed header and its operations to a block and
    obtains a new block *)
val apply :
  Block_header.block_header ->
  ?operations:Operation.packed list ->
  t ->
  t tzresult Lwt.t

(**
   [bake b] returns a block [b'] which has as predecessor block [b].
   Optional parameter [policy] allows to pick the next baker in several ways.
   This function bundles together [forge_header], [sign_header] and [apply].
   These functions should be used instead of bake to craft unusual blocks for
   testing together with setters for properties of the headers.
   For examples see seed.ml or double_baking.ml
*)
val bake :
  ?policy:baker_policy ->
  ?timestamp:Timestamp.time ->
  ?operation:Operation.packed ->
  ?operations:Operation.packed list ->
  t ->
  t tzresult Lwt.t

(** Bakes [n] blocks. *)
val bake_n : ?policy:baker_policy -> int -> t -> block tzresult Lwt.t

(** Given a block [b] at level [l] bakes enough blocks to complete a cycle,
    that is [blocks_per_cycle - (l % blocks_per_cycle)]. *)
val bake_until_cycle_end : ?policy:baker_policy -> t -> t tzresult Lwt.t

(** Bakes enough blocks to end [n] cycles. *)
val bake_until_n_cycle_end :
  ?policy:baker_policy -> int -> t -> t tzresult Lwt.t

(** Bakes enough blocks to reach the cycle. *)
val bake_until_cycle : ?policy:baker_policy -> Cycle.t -> t -> t tzresult Lwt.t
src/proto_alpha/lib_protocol/test/helpers/block.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  header : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t;
  operations : list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
  context : Tezos_protocol_environment.Context.t }.

Definition block := t.

Parameter rpc_ctxt :
Tezos_protocol_alpha.Protocol.Environment.RPC_context.simple t.

Inductive baker_policy : Type :=
| By_priority : Z -> baker_policy
| By_account : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
  baker_policy
| Excluding : (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  -> baker_policy.

Parameter get_next_baker :
(option baker_policy) ->
  t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash * Z *
          Tezos_base__TzPervasives.Time.Protocol.t)).

Parameter get_endorsing_power :
block -> Lwt.t (Tezos_base__TzPervasives.tzresult Z).

Module Forge.
  Parameter contents : (option Tezos_base__TzPervasives.MBytes.t) ->
    (option Z) ->
      (option Tezos_protocol_alpha.Protocol.Nonce_hash.t) ->
        unit ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents.
  
  Parameter header : Type.
  
  Parameter forge_header : (option baker_policy) ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Timestamp.time) ->
      (option
        (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)) ->
        t -> Lwt.t (Tezos_base__TzPervasives.tzresult header).
  
  Parameter set_seed_nonce_hash : (option
    Tezos_protocol_alpha.Protocol.Nonce_hash.t) -> header -> header.
  
  Parameter set_baker : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash
    -> header -> header.
  
  Parameter sign_header : header ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.block_header).
End Forge.

Parameter genesis :
(option bool) ->
  (option Z) ->
    (option Z) ->
      (option int32) ->
        (list
          (Tezos_alpha_test_helpers.Account.t *
            Tezos_protocol_alpha.Protocol.Tez_repr.tez)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult block).

Parameter genesis_with_parameters :
Tezos_protocol_alpha.Protocol.Parameters_repr.t ->
  Lwt.t (Tezos_base__TzPervasives.tzresult block).

Parameter apply :
Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.block_header ->
  (option (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed))
    -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter bake :
(option baker_policy) ->
  (option Tezos_protocol_alpha.Protocol.Alpha_context.Timestamp.time) ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed) ->
      (option
        (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)) ->
        t -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter bake_n :
(option baker_policy) ->
  Z -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult block).

Parameter bake_until_cycle_end :
(option baker_policy) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter bake_until_n_cycle_end :
(option baker_policy) -> Z -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult t).

Parameter bake_until_cycle :
(option baker_policy) ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.t ->
    t -> Lwt.t (Tezos_base__TzPervasives.tzresult t).
src/proto_alpha/lib_protocol/test/helpers/context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type t = B of Block.t | I of Incremental.t

let branch = function B b -> b.hash | I i -> (Incremental.predecessor i).hash

let level = function B b -> b.header.shell.level | I i -> Incremental.level i

let get_level ctxt =
  level ctxt |> Raw_level.of_int32 |> Environment.wrap_error |> Lwt.return

let rpc_ctxt =
  object
    method call_proto_service0
        : 'm 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            Environment.RPC_context.t,
            Environment.RPC_context.t,
            'q,
            'i,
            'o )
          RPC_service.t -> t -> 'q -> 'i -> 'o tzresult Lwt.t =
      fun s pr q i ->
        match pr with
        | B b ->
            Block.rpc_ctxt#call_proto_service0 s b q i
        | I b ->
            Incremental.rpc_ctxt#call_proto_service0 s b q i

    method call_proto_service1
        : 'm 'a 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            Environment.RPC_context.t,
            Environment.RPC_context.t * 'a,
            'q,
            'i,
            'o )
          RPC_service.t -> t -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t =
      fun s pr a q i ->
        match pr with
        | B bl ->
            Block.rpc_ctxt#call_proto_service1 s bl a q i
        | I bl ->
            Incremental.rpc_ctxt#call_proto_service1 s bl a q i

    method call_proto_service2
        : 'm 'a 'b 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            Environment.RPC_context.t,
            (Environment.RPC_context.t * 'a) * 'b,
            'q,
            'i,
            'o )
          RPC_service.t -> t -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t =
      fun s pr a b q i ->
        match pr with
        | B bl ->
            Block.rpc_ctxt#call_proto_service2 s bl a b q i
        | I bl ->
            Incremental.rpc_ctxt#call_proto_service2 s bl a b q i

    method call_proto_service3
        : 'm 'a 'b 'c 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            Environment.RPC_context.t,
            ((Environment.RPC_context.t * 'a) * 'b) * 'c,
            'q,
            'i,
            'o )
          RPC_service.t -> t -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t
        =
      fun s pr a b c q i ->
        match pr with
        | B bl ->
            Block.rpc_ctxt#call_proto_service3 s bl a b c q i
        | I bl ->
            Incremental.rpc_ctxt#call_proto_service3 s bl a b c q i
  end

let get_endorsers ctxt =
  Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt

let get_endorser ctxt =
  Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt
  >>=? fun endorsers ->
  let endorser = List.hd endorsers in
  return (endorser.delegate, endorser.slots)

let get_bakers ctxt =
  Alpha_services.Delegate.Baking_rights.get ~max_priority:256 rpc_ctxt ctxt
  >>=? fun bakers ->
  return
    (List.map
       (fun p -> p.Alpha_services.Delegate.Baking_rights.delegate)
       bakers)

let get_seed_nonce_hash ctxt =
  let header =
    match ctxt with B {header; _} -> header | I i -> Incremental.header i
  in
  match header.protocol_data.contents.seed_nonce_hash with
  | None ->
      failwith "No committed nonce"
  | Some hash ->
      return hash

let get_seed ctxt = Alpha_services.Seed.get rpc_ctxt ctxt

let get_constants ctxt = Alpha_services.Constants.all rpc_ctxt ctxt

let get_minimal_valid_time ctxt ~priority ~endorsing_power =
  Alpha_services.Delegate.Minimal_valid_time.get
    rpc_ctxt
    ctxt
    priority
    endorsing_power

let get_baking_reward ctxt ~priority ~endorsing_power =
  get_constants ctxt
  >>=? fun Constants.{parametric = {block_reward; endorsers_per_block; _}; _} ->
  let prio_factor_denominator = Int64.(succ (of_int priority)) in
  let endo_factor_numerator =
    Int64.of_int (8 + (2 * endorsing_power / endorsers_per_block))
  in
  let endo_factor_denominator = 10L in
  Lwt.return
    Test_tez.Tez.(
      block_reward *? endo_factor_numerator
      >>? fun val1 ->
      val1 /? endo_factor_denominator
      >>? fun val2 -> val2 /? prio_factor_denominator)

let get_endorsing_reward ctxt ~priority ~endorsing_power =
  get_constants ctxt
  >>=? fun Constants.{parametric = {endorsement_reward; _}; _} ->
  let open Test_utils in
  Test_tez.Tez.(
    (endorsement_reward /? Int64.(succ (of_int priority)))
    >>?= fun reward_per_slot ->
    reward_per_slot *? Int64.of_int endorsing_power
    >>?= fun reward -> return reward)

(* Voting *)

module Vote = struct
  let get_ballots ctxt = Alpha_services.Voting.ballots rpc_ctxt ctxt

  let get_ballot_list ctxt = Alpha_services.Voting.ballot_list rpc_ctxt ctxt

  let get_voting_period ctxt =
    Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt
    >>=? fun l -> return l.voting_period

  let get_voting_period_position ctxt =
    Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt
    >>=? fun l -> return l.voting_period_position

  let get_current_period_kind ctxt =
    Alpha_services.Voting.current_period_kind rpc_ctxt ctxt

  let get_current_quorum ctxt =
    Alpha_services.Voting.current_quorum rpc_ctxt ctxt

  let get_listings ctxt = Alpha_services.Voting.listings rpc_ctxt ctxt

  let get_proposals ctxt = Alpha_services.Voting.proposals rpc_ctxt ctxt

  let get_current_proposal ctxt =
    Alpha_services.Voting.current_proposal rpc_ctxt ctxt

  let get_protocol (b : Block.t) =
    Tezos_protocol_environment.Context.get b.context ["protocol"]
    >>= function
    | None ->
        assert false
    | Some p ->
        Lwt.return (Protocol_hash.of_bytes_exn p)

  let get_participation_ema (b : Block.t) =
    Environment.Context.get b.context ["votes"; "participation_ema"]
    >>= function
    | None -> assert false | Some bytes -> return (MBytes.get_int32 bytes 0)

  let set_participation_ema (b : Block.t) ema =
    let bytes = Bytes.make 4 '\000' in
    MBytes.set_int32 bytes 0 ema ;
    Environment.Context.set b.context ["votes"; "participation_ema"] bytes
    >>= fun context -> Lwt.return {b with context}
end

module Contract = struct
  let pp = Alpha_context.Contract.pp

  let pkh c =
    Alpha_context.Contract.is_implicit c
    |> function
    | Some p -> return p | None -> failwith "pkh: only for implicit contracts"

  type balance_kind = Main | Deposit | Fees | Rewards

  let balance ?(kind = Main) ctxt contract =
    match kind with
    | Main ->
        Alpha_services.Contract.balance rpc_ctxt ctxt contract
    | _ -> (
      match Alpha_context.Contract.is_implicit contract with
      | None ->
          invalid_arg
            "get_balance: no frozen accounts for an originated contract."
      | Some pkh ->
          Alpha_services.Delegate.frozen_balance_by_cycle rpc_ctxt ctxt pkh
          >>=? fun map ->
          Lwt.return
          @@ Cycle.Map.fold
               (fun _cycle {Delegate.deposit; fees; rewards} acc ->
                 acc
                 >>? fun acc ->
                 match kind with
                 | Deposit ->
                     Test_tez.Tez.(acc +? deposit)
                 | Fees ->
                     Test_tez.Tez.(acc +? fees)
                 | Rewards ->
                     Test_tez.Tez.(acc +? rewards)
                 | _ ->
                     assert false)
               map
               (Ok Tez.zero) )

  let counter ctxt contract =
    match Contract.is_implicit contract with
    | None ->
        invalid_arg "Helpers.Context.counter"
    | Some mgr ->
        Alpha_services.Contract.counter rpc_ctxt ctxt mgr

  let manager _ contract =
    match Contract.is_implicit contract with
    | None ->
        invalid_arg "Helpers.Context.manager"
    | Some pkh ->
        Account.find pkh

  let is_manager_key_revealed ctxt contract =
    match Contract.is_implicit contract with
    | None ->
        invalid_arg "Helpers.Context.is_manager_key_revealed"
    | Some mgr ->
        Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr
        >>=? fun res -> return (res <> None)

  let delegate ctxt contract =
    Alpha_services.Contract.delegate rpc_ctxt ctxt contract

  let delegate_opt ctxt contract =
    Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract
end

module Delegate = struct
  type info = Delegate_services.info = {
    balance : Tez.t;
    frozen_balance : Tez.t;
    frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
    staking_balance : Tez.t;
    delegated_contracts : Contract_repr.t list;
    delegated_balance : Tez.t;
    deactivated : bool;
    grace_period : Cycle.t;
  }

  let info ctxt pkh = Alpha_services.Delegate.info rpc_ctxt ctxt pkh
end

let init ?endorsers_per_block ?with_commitments ?(initial_balances = [])
    ?initial_endorsers ?min_proposal_quorum n =
  let accounts = Account.generate_accounts ~initial_balances n in
  let contracts =
    List.map
      (fun (a, _) -> Alpha_context.Contract.implicit_contract Account.(a.pkh))
      accounts
  in
  Block.genesis
    ?endorsers_per_block
    ?with_commitments
    ?initial_endorsers
    ?min_proposal_quorum
    accounts
  >>=? fun blk -> return (blk, contracts)
src/proto_alpha/lib_protocol/test/helpers/context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Inductive t : Type :=
| B : Tezos_alpha_test_helpers.Block.t -> t
| I : Tezos_alpha_test_helpers.Incremental.t -> t.

Definition branch (function_parameter : t)
  : Tezos_base__TzPervasives.Block_hash.t :=
  match function_parameter with
  | B b => hash b
  | I i => hash (Tezos_alpha_test_helpers.Incremental.predecessor i)
  end.

Definition level (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Int32.t :=
  match function_parameter with
  | B b => level (shell (header b))
  | I i => Tezos_alpha_test_helpers.Incremental.level i
  end.

Definition get_level (ctxt : t)
  : Lwt.t
    (Tezos_base__TzPervasives.Error_monad.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.raw_level) :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply (level ctxt)
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.of_int32)
      Tezos_protocol_alpha.Protocol.Environment.wrap_error) Lwt._return.

Definition rpc_ctxt {D F H J a b c i o q : Type}
  : ((((Tezos_base__TzPervasives.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    t -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
    (D * q * i * o)) *
    ((((Tezos_base__TzPervasives.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      t -> a -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
      (F * a * q * i * o)) *
      ((((Tezos_base__TzPervasives.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        t -> a -> b -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
        (H * a * b * q * i * o)) *
        ((((Tezos_base__TzPervasives.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          t ->
            a -> b -> c -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o))
          * (J * a * b * c * q * i * o)) * nil)))) := object.

Definition get_endorsers (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list
        Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Endorsing_rights.t)) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Endorsing_rights.get
    rpc_ctxt None None None ctxt.

Definition get_endorser (ctxt : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * (list Z))) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Endorsing_rights.get
      rpc_ctxt None None None ctxt)
    (fun endorsers =>
      let endorser := Tezos_base__TzPervasives.List.hd endorsers in
      Tezos_base__TzPervasives._return ((delegate endorser), (slots endorser))).

Definition get_bakers (ctxt : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Baking_rights.get
      rpc_ctxt None None None None (Some 256) ctxt)
    (fun bakers =>
      Tezos_base__TzPervasives._return
        (Tezos_base__TzPervasives.List.map
          (fun p => Alpha_services.Delegate.Baking_rights.delegate p) bakers)).

Definition get_seed_nonce_hash (ctxt : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_raw_protocol_alpha.Nonce_hash.t) :=
  let header :=
    match ctxt with
    | B {| header := header |} => header
    | I i => Tezos_alpha_test_helpers.Incremental.header i
    end in
  match seed_nonce_hash (contents (protocol_data header)) with
  | None =>
    Tezos_base__TzPervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "No committed nonce" % string
          CamlinternalFormatBasics.End_of_format) "No committed nonce" % string)
  | Some hash => Tezos_base__TzPervasives._return hash
  end.

Definition get_seed (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Seed.seed) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Seed.get rpc_ctxt ctxt.

Definition get_constants (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Constants.all rpc_ctxt ctxt.

Definition get_minimal_valid_time
  (ctxt : t) (priority : Z) (endorsing_power : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_protocol_environment_alpha__Environment.Time.t) :=
  Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Minimal_valid_time.get
    rpc_ctxt ctxt priority endorsing_power.

Definition get_baking_reward (ctxt : t) (priority : Z) (endorsing_power : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Test_tez.Tez.tez) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (get_constants ctxt)
    (fun function_parameter =>
      match function_parameter with
      | {|
        parametric := {|
          endorsers_per_block := endorsers_per_block;
            block_reward := block_reward
            |}
          |} =>
        let prio_factor_denominator :=
          Stdlib.Int64.succ (Stdlib.Int64.of_int priority) in
        let endo_factor_numerator :=
          Stdlib.Int64.of_int
            (Z.add 8 (Z.div (Z.mul 2 endorsing_power) endorsers_per_block)) in
        let endo_factor_denominator := 10 in
        Lwt._return
          (Tezos_base__TzPervasives.op_gt_gt_question
            (Tezos_alpha_test_helpers.Test_tez.Tez.op_star_question block_reward
              endo_factor_numerator)
            (fun val1 =>
              Tezos_base__TzPervasives.op_gt_gt_question
                (Tezos_alpha_test_helpers.Test_tez.Tez.op_div_question val1
                  endo_factor_denominator)
                (fun val2 =>
                  Tezos_alpha_test_helpers.Test_tez.Tez.op_div_question val2
                    prio_factor_denominator)))
      end).

Definition get_endorsing_reward (ctxt : t) (priority : Z) (endorsing_power : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Test_tez.Tez.tez) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question (get_constants ctxt)
    (fun function_parameter =>
      match function_parameter with
      | {| parametric := {| endorsement_reward := endorsement_reward |} |} =>
        Tezos_alpha_test_helpers.Test_utils.op_gt_gt_question_eq
          (Tezos_alpha_test_helpers.Test_tez.Tez.op_div_question
            endorsement_reward
            (Stdlib.Int64.succ (Stdlib.Int64.of_int priority)))
          (fun reward_per_slot =>
            Tezos_alpha_test_helpers.Test_utils.op_gt_gt_question_eq
              (Tezos_alpha_test_helpers.Test_tez.Tez.op_star_question
                reward_per_slot (Stdlib.Int64.of_int endorsing_power))
              (fun reward => Tezos_base__TzPervasives._return reward))
      end).

Module Vote.
  Definition get_ballots (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Voting.ballots rpc_ctxt ctxt.
  
  Definition get_ballot_list (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
            * Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot))) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Voting.ballot_list rpc_ctxt
      ctxt.
  
  Definition get_voting_period (ctxt : t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_raw_protocol_alpha__Alpha_context.Voting_period.t) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level
        rpc_ctxt (Some 1) ctxt)
      (fun l => Tezos_base__TzPervasives._return (voting_period l)).
  
  Definition get_voting_period_position (ctxt : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult int32) :=
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      (Tezos_protocol_alpha.Protocol.Alpha_services.Helpers.current_level
        rpc_ctxt (Some 1) ctxt)
      (fun l => Tezos_base__TzPervasives._return (voting_period_position l)).
  
  Definition get_current_period_kind (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Voting.current_period_kind
      rpc_ctxt ctxt.
  
  Definition get_current_quorum (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.Int32.t) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Voting.current_quorum rpc_ctxt
      ctxt.
  
  Definition get_listings (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
            * int32))) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Voting.listings rpc_ctxt ctxt.
  
  Definition get_proposals (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t
          Tezos_protocol_environment_alpha__Environment.Int32.t)) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Voting.proposals rpc_ctxt ctxt.
  
  Definition get_current_proposal (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (option
          Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Voting.current_proposal
      rpc_ctxt ctxt.
  
  Definition get_protocol (b : Tezos_alpha_test_helpers.Block.t)
    : Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_protocol_environment.Context.get (context b)
        (cons "protocol" % string []))
      (fun function_parameter =>
        match function_parameter with
        | None => false
        | Some p =>
          Lwt._return (Tezos_base__TzPervasives.Protocol_hash.of_bytes_exn p)
        end).
  
  Definition get_participation_ema (b : Tezos_alpha_test_helpers.Block.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult int32) :=
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_protocol_alpha.Protocol.Environment.Context.get (context b)
        (cons "votes" % string (cons "participation_ema" % string [])))
      (fun function_parameter =>
        match function_parameter with
        | None => false
        | Some bytes =>
          Tezos_base__TzPervasives._return
            (Tezos_base__TzPervasives.MBytes.get_int32 string 0)
        end).
  
  Definition set_participation_ema
    (b : Tezos_alpha_test_helpers.Block.t) (ema : int32)
    : Lwt.t Tezos_alpha_test_helpers.Block.t :=
    let bytes := Stdlib.Bytes.make 4 "000" % char in
    Tezos_base__TzPervasives.MBytes.set_int32 string 0 ema;
    Tezos_base__TzPervasives.op_gt_gt_eq
      (Tezos_protocol_alpha.Protocol.Environment.Context.set (context b)
        (cons "votes" % string (cons "participation_ema" % string [])) string)
      (fun context => Lwt._return record).
End Vote.

Module Contract.
  Definition pp
    : Tezos_protocol_environment_alpha__Environment.Format.formatter ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t -> unit :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.pp.
  
  Definition pkh
    (c : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_raw_protocol_alpha__Alpha_context.public_key_hash) :=
    OCaml.Stdlib.reverse_apply
      (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit c)
      (fun function_parameter =>
        match function_parameter with
        | Some p => Tezos_base__TzPervasives._return p
        | None =>
          Tezos_base__TzPervasives.failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "pkh: only for implicit contracts" % string
                CamlinternalFormatBasics.End_of_format)
              "pkh: only for implicit contracts" % string)
        end).
  
  Inductive balance_kind : Type :=
  | Main : balance_kind
  | Deposit : balance_kind
  | Fees : balance_kind
  | Rewards : balance_kind.
  
  Definition balance (op_star_o_p_t_star : option balance_kind)
    : t ->
      Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
    let kind :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => Main
      end in
    fun ctxt =>
      fun contract =>
        match kind with
        | Main =>
          Tezos_protocol_alpha.Protocol.Alpha_services.Contract.balance rpc_ctxt
            ctxt contract
        | _ =>
          match
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
              contract with
          | None =>
            OCaml.Stdlib.invalid_arg
              "get_balance: no frozen accounts for an originated contract." %
                string
          | Some pkh =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.frozen_balance_by_cycle
                rpc_ctxt ctxt pkh)
              (fun map =>
                apply Lwt._return
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.Map.fold
                    (fun _cycle =>
                      fun function_parameter =>
                        match function_parameter with
                        | {|
                          Delegate.deposit := deposit;
                            Delegate.fees := fees;
                            Delegate.rewards := rewards
                            |} =>
                          fun acc =>
                            Tezos_base__TzPervasives.op_gt_gt_question acc
                              (fun acc =>
                                match kind with
                                | Deposit =>
                                  Tezos_alpha_test_helpers.Test_tez.Tez.op_plus_question
                                    acc deposit
                                | Fees =>
                                  Tezos_alpha_test_helpers.Test_tez.Tez.op_plus_question
                                    acc fees
                                | Rewards =>
                                  Tezos_alpha_test_helpers.Test_tez.Tez.op_plus_question
                                    acc rewards
                                | _ => false
                                end)
                        end) map
                    (inl Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)))
          end
        end.
  
  Definition counter
    (ctxt : t)
    (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.counter) :=
    match
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit contract
      with
    | None => OCaml.Stdlib.invalid_arg "Helpers.Context.counter" % string
    | Some mgr =>
      Tezos_protocol_alpha.Protocol.Alpha_services.Contract.counter rpc_ctxt
        ctxt mgr
    end.
  
  Definition manager {A : Type} (function_parameter : A)
    : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Account.t) :=
    match function_parameter with
    | _ =>
      fun contract =>
        match
          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit
            contract with
        | None => OCaml.Stdlib.invalid_arg "Helpers.Context.manager" % string
        | Some pkh => Tezos_alpha_test_helpers.Account.find pkh
        end
    end.
  
  Definition is_manager_key_revealed
    (ctxt : t)
    (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
    match
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.is_implicit contract
      with
    | None =>
      OCaml.Stdlib.invalid_arg
        "Helpers.Context.is_manager_key_revealed" % string
    | Some mgr =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_protocol_alpha.Protocol.Alpha_services.Contract.manager_key
          rpc_ctxt ctxt mgr)
        (fun res => Tezos_base__TzPervasives._return (nequiv_decb res None))
    end.
  
  Definition delegate
    (ctxt : t) (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Contract.delegate rpc_ctxt ctxt
      contract.
  
  Definition delegate_opt
    (ctxt : t) (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Contract.delegate_opt rpc_ctxt
      ctxt contract.
End Contract.

Module Delegate.
  Record info := {
    balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    frozen_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    frozen_balance_by_cycle :
      Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.Map.t
        Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.frozen_balance;
    staking_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    delegated_contracts : list Tezos_protocol_alpha.Protocol.Contract_repr.t;
    delegated_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    deactivated : bool;
    grace_period : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.t }.
  
  Definition info
    (ctxt : t)
    (pkh :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.info) :=
    Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.info rpc_ctxt ctxt pkh.
End Delegate.

Definition init
  (endorsers_per_block : option Z) (with_commitments : option bool)
  (op_star_o_p_t_star : option (list int64))
  : (option Z) ->
    (option int32) ->
      Z ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_alpha_test_helpers.Block.block *
              (list
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract))) :=
  let initial_balances :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => []
    end in
  fun initial_endorsers =>
    fun min_proposal_quorum =>
      fun n =>
        let accounts :=
          Tezos_alpha_test_helpers.Account.generate_accounts
            (Some initial_balances) n in
        let contracts :=
          Tezos_base__TzPervasives.List.map
            (fun function_parameter =>
              match function_parameter with
              | (a, _) =>
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  (pkh a)
              end) accounts in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_alpha_test_helpers.Block.genesis with_commitments
            endorsers_per_block initial_endorsers min_proposal_quorum accounts)
          (fun blk => Tezos_base__TzPervasives._return (blk, contracts)).
src/proto_alpha/lib_protocol/test/helpers/context.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Environment

type t = B of Block.t | I of Incremental.t

val branch : t -> Block_hash.t

val get_level : t -> Raw_level.t tzresult Lwt.t

val get_endorsers :
  t -> Alpha_services.Delegate.Endorsing_rights.t list tzresult Lwt.t

val get_endorser : t -> (public_key_hash * int list) tzresult Lwt.t

val get_bakers : t -> public_key_hash list tzresult Lwt.t

val get_seed_nonce_hash : t -> Nonce_hash.t tzresult Lwt.t

(** Returns the seed of the cycle to which the block belongs to. *)
val get_seed : t -> Seed.seed tzresult Lwt.t

(** Returns all the constants of the protocol *)
val get_constants : t -> Constants.t tzresult Lwt.t

val get_minimal_valid_time :
  t -> priority:int -> endorsing_power:int -> Time.t tzresult Lwt.t

val get_baking_reward :
  t -> priority:int -> endorsing_power:int -> Tez.t tzresult Lwt.t

val get_endorsing_reward :
  t -> priority:int -> endorsing_power:int -> Tez.t tzresult Lwt.t

module Vote : sig
  val get_ballots : t -> Vote.ballots tzresult Lwt.t

  val get_ballot_list :
    t -> (Signature.Public_key_hash.t * Vote.ballot) list tzresult Lwt.t

  val get_voting_period : t -> Voting_period.t tzresult Lwt.t

  val get_voting_period_position : t -> Int32.t tzresult Lwt.t

  val get_current_period_kind : t -> Voting_period.kind tzresult Lwt.t

  val get_current_quorum : t -> Int32.t tzresult Lwt.t

  val get_participation_ema : Block.t -> Int32.t tzresult Lwt.t

  val get_listings :
    t -> (Signature.Public_key_hash.t * int32) list tzresult Lwt.t

  val get_proposals : t -> Int32.t Protocol_hash.Map.t tzresult Lwt.t

  val get_current_proposal : t -> Protocol_hash.t option tzresult Lwt.t

  val get_protocol : Block.t -> Protocol_hash.t Lwt.t

  val set_participation_ema : Block.t -> int32 -> Block.t Lwt.t
end

module Contract : sig
  val pp : Format.formatter -> Contract.t -> unit

  val pkh : Contract.t -> public_key_hash tzresult Lwt.t

  type balance_kind = Main | Deposit | Fees | Rewards

  (** Returns the balance of a contract, by default the main balance.
      If the contract is implicit the frozen balances are available too:
      deposit, fees or rewards. *)
  val balance : ?kind:balance_kind -> t -> Contract.t -> Tez.t tzresult Lwt.t

  val counter : t -> Contract.t -> Z.t tzresult Lwt.t

  val manager : t -> Contract.t -> Account.t tzresult Lwt.t

  val is_manager_key_revealed : t -> Contract.t -> bool tzresult Lwt.t

  val delegate : t -> Contract.t -> public_key_hash tzresult Lwt.t

  val delegate_opt : t -> Contract.t -> public_key_hash option tzresult Lwt.t
end

module Delegate : sig
  type info = Delegate_services.info = {
    balance : Tez.t;
    frozen_balance : Tez.t;
    frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
    staking_balance : Tez.t;
    delegated_contracts : Contract_repr.t list;
    delegated_balance : Tez.t;
    deactivated : bool;
    grace_period : Cycle.t;
  }

  val info : t -> public_key_hash -> Delegate_services.info tzresult Lwt.t
end

(** [init n] : returns an initial block with [n] initialized accounts
    and the associated implicit contracts *)
val init :
  ?endorsers_per_block:int ->
  ?with_commitments:bool ->
  ?initial_balances:int64 list ->
  ?initial_endorsers:int ->
  ?min_proposal_quorum:int32 ->
  int ->
  (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t
src/proto_alpha/lib_protocol/test/helpers/context.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| B : Tezos_alpha_test_helpers.Block.t -> t
| I : Tezos_alpha_test_helpers.Incremental.t -> t.

Parameter branch : t -> Tezos_protocol_alpha.Protocol.Environment.Block_hash.t.

Parameter get_level :
t ->
  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t).

Parameter get_endorsers :
t ->
  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Endorsing_rights.t)).

Parameter get_endorser :
t ->
  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash * (list Z))).

Parameter get_bakers :
t ->
  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)).

Parameter get_seed_nonce_hash :
t ->
  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Nonce_hash.t).

Parameter get_seed :
t ->
  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Seed.seed).

Parameter get_constants :
t ->
  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t).

Parameter get_minimal_valid_time :
t ->
  Z ->
    Z ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Environment.Time.t).

Parameter get_baking_reward :
t ->
  Z ->
    Z ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t).

Parameter get_endorsing_reward :
t ->
  Z ->
    Z ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t).

Module Vote.
  Parameter get_ballots : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots).
  
  Parameter get_ballot_list : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_protocol_alpha.Protocol.Environment.Signature.Public_key_hash.t
            * Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot))).
  
  Parameter get_voting_period : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.t).
  
  Parameter get_voting_period_position : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Environment.Int32.t).
  
  Parameter get_current_period_kind : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.kind).
  
  Parameter get_current_quorum : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Environment.Int32.t).
  
  Parameter get_participation_ema : Tezos_alpha_test_helpers.Block.t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Environment.Int32.t).
  
  Parameter get_listings : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_protocol_alpha.Protocol.Environment.Signature.Public_key_hash.t
            * int32))).
  
  Parameter get_proposals : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.t
          Tezos_protocol_alpha.Protocol.Environment.Int32.t)).
  
  Parameter get_current_proposal : t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.t)).
  
  Parameter get_protocol : Tezos_alpha_test_helpers.Block.t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.t.
  
  Parameter set_participation_ema : Tezos_alpha_test_helpers.Block.t ->
    int32 ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        Tezos_alpha_test_helpers.Block.t.
End Vote.

Module Contract.
  Parameter pp : Tezos_protocol_alpha.Protocol.Environment.Format.formatter ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t -> unit.
  
  Parameter pkh : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash).
  
  Inductive balance_kind : Type :=
  | Main : balance_kind
  | Deposit : balance_kind
  | Fees : balance_kind
  | Rewards : balance_kind.
  
  Parameter balance : (option balance_kind) ->
    t ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t).
  
  Parameter counter : t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Environment.Z.t).
  
  Parameter manager : t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Account.t).
  
  Parameter is_manager_key_revealed : t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult bool).
  
  Parameter delegate : t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash).
  
  Parameter delegate_opt : t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)).
End Contract.

Module Delegate.
  Record info := {
    balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    frozen_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    frozen_balance_by_cycle :
      Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.Map.t
        Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.frozen_balance;
    staking_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    delegated_contracts : list Tezos_protocol_alpha.Protocol.Contract_repr.t;
    delegated_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    deactivated : bool;
    grace_period : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.t }.
  
  Parameter info : t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Delegate_services.info).
End Delegate.

Parameter init :
(option Z) ->
  (option bool) ->
    (option (list int64)) ->
      (option Z) ->
        (option int32) ->
          Z ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_base__TzPervasives.tzresult
                (Tezos_alpha_test_helpers.Block.t *
                  (list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))).
src/proto_alpha/lib_protocol/test/helpers/incremental.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type t = {
  predecessor : Block.t;
  state : validation_state;
  rev_operations : Operation.packed list;
  rev_tickets : operation_receipt list;
  header : Block_header.t;
  delegate : Account.t;
}

type incremental = t

let predecessor {predecessor; _} = predecessor

let header {header; _} = header

let rev_tickets {rev_tickets; _} = rev_tickets

let level st = st.header.shell.level

let rpc_context st =
  let result = Alpha_context.finalize st.state.ctxt in
  {
    Environment.Updater.block_hash = Block_hash.zero;
    block_header = {st.header.shell with fitness = result.fitness};
    context = result.context;
  }

let rpc_ctxt =
  new Environment.proto_rpc_context_of_directory rpc_context rpc_services

let begin_construction ?(priority = 0) ?timestamp ?seed_nonce_hash
    ?(policy = Block.By_priority priority) (predecessor : Block.t) =
  Block.get_next_baker ~policy predecessor
  >>=? fun (delegate, priority, _timestamp) ->
  Alpha_services.Delegate.Minimal_valid_time.get
    Block.rpc_ctxt
    predecessor
    priority
    0
  >>=? fun real_timestamp ->
  Account.find delegate
  >>=? fun delegate ->
  let timestamp = Option.unopt ~default:real_timestamp timestamp in
  let contents = Block.Forge.contents ~priority ?seed_nonce_hash () in
  let protocol_data = {Block_header.contents; signature = Signature.zero} in
  let header =
    {
      Block_header.shell =
        {
          predecessor = predecessor.hash;
          proto_level = predecessor.header.shell.proto_level;
          validation_passes = predecessor.header.shell.validation_passes;
          fitness = predecessor.header.shell.fitness;
          timestamp;
          level = predecessor.header.shell.level;
          context = Context_hash.zero;
          operations_hash = Operation_list_list_hash.zero;
        };
      protocol_data = {contents; signature = Signature.zero};
    }
  in
  begin_construction
    ~chain_id:Chain_id.zero
    ~predecessor_context:predecessor.context
    ~predecessor_timestamp:predecessor.header.shell.timestamp
    ~predecessor_fitness:predecessor.header.shell.fitness
    ~predecessor_level:predecessor.header.shell.level
    ~predecessor:predecessor.hash
    ~timestamp
    ~protocol_data
    ()
  >>= fun state ->
  Lwt.return (Environment.wrap_error state)
  >>=? fun state ->
  return
    {
      predecessor;
      state;
      rev_operations = [];
      rev_tickets = [];
      header;
      delegate;
    }

let detect_script_failure :
    type kind. kind Apply_results.operation_metadata -> _ =
  let rec detect_script_failure :
      type kind. kind Apply_results.contents_result_list -> _ =
    let open Apply_results in
    let detect_script_failure_single (type kind)
        (Manager_operation_result
           {operation_result; internal_operation_results; _} :
          kind Kind.manager Apply_results.contents_result) =
      let detect_script_failure (type kind)
          (result : kind manager_operation_result) =
        match result with
        | Applied _ ->
            Ok ()
        | Skipped _ ->
            assert false
        | Backtracked (_, None) ->
            (* there must be another error for this to happen *)
            Ok ()
        | Backtracked (_, Some errs) ->
            Environment.wrap_error (Error errs)
        | Failed (_, errs) ->
            Environment.wrap_error (Error errs)
      in
      List.fold_left
        (fun acc (Internal_operation_result (_, r)) ->
          acc >>? fun () -> detect_script_failure r)
        (detect_script_failure operation_result)
        internal_operation_results
    in
    function
    | Single_result (Manager_operation_result _ as res) ->
        detect_script_failure_single res
    | Single_result _ ->
        Ok ()
    | Cons_result (res, rest) ->
        detect_script_failure_single res
        >>? fun () -> detect_script_failure rest
  in
  fun {contents} -> detect_script_failure contents

let add_operation ?expect_failure st op =
  let open Apply_results in
  apply_operation st.state op
  >>= fun x ->
  Lwt.return (Environment.wrap_error x)
  >>=? function
  | (state, (Operation_metadata result as metadata)) ->
      Lwt.return @@ detect_script_failure result
      >>= fun result ->
      ( match expect_failure with
      | None ->
          Lwt.return result
      | Some f -> (
        match result with
        | Ok _ ->
            failwith "Error expected while adding operation"
        | Error e ->
            f e ) )
      >>=? fun () ->
      return
        {
          st with
          state;
          rev_operations = op :: st.rev_operations;
          rev_tickets = metadata :: st.rev_tickets;
        }
  | (state, (No_operation_metadata as metadata)) ->
      return
        {
          st with
          state;
          rev_operations = op :: st.rev_operations;
          rev_tickets = metadata :: st.rev_tickets;
        }

let finalize_block st =
  finalize_block st.state
  >>= fun x ->
  Lwt.return (Environment.wrap_error x)
  >>=? fun (result, _) ->
  let operations = List.rev st.rev_operations in
  let operations_hash =
    Operation_list_list_hash.compute
      [Operation_list_hash.compute (List.map Operation.hash_packed operations)]
  in
  let header =
    {
      st.header with
      shell =
        {
          st.header.shell with
          level = Int32.succ st.header.shell.level;
          operations_hash;
          fitness = result.fitness;
        };
    }
  in
  let hash = Block_header.hash header in
  return {Block.hash; header; operations; context = result.context}
src/proto_alpha/lib_protocol/test/helpers/incremental.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Record t := {
  predecessor : Tezos_alpha_test_helpers.Block.t;
  state : Tezos_protocol_alpha.Protocol.validation_state;
  rev_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
  rev_tickets : list Tezos_protocol_alpha.Protocol.operation_receipt;
  header : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t;
  delegate : Tezos_alpha_test_helpers.Account.t }.

Definition incremental := t.

Definition predecessor (function_parameter : t)
  : Tezos_alpha_test_helpers.Block.t :=
  match function_parameter with
  | {| predecessor := predecessor |} => predecessor
  end.

Definition header (function_parameter : t)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t :=
  match function_parameter with
  | {| header := header |} => header
  end.

Definition rev_tickets (function_parameter : t)
  : list Tezos_protocol_alpha.Protocol.operation_receipt :=
  match function_parameter with
  | {| rev_tickets := rev_tickets |} => rev_tickets
  end.

Definition level (st : t)
  : Tezos_protocol_environment_alpha__Environment.Int32.t :=
  level (shell (header st)).

Definition rpc_context (st : t)
  : Tezos_protocol_alpha.Protocol.Environment.Updater.rpc_context :=
  let result :=
    Tezos_protocol_alpha.Protocol.Alpha_context.finalize None (ctxt (state st))
    in
  {| Environment.Updater.block_hash := Tezos_base__TzPervasives.Block_hash.zero;
    Environment.Updater.block_header := record;
    Environment.Updater.context := context result |}.

Definition rpc_ctxt
  : Tezos_protocol_alpha.Protocol.Environment.proto_rpc_context_of_directory t :=
  new rpc_context Tezos_protocol_alpha.Protocol.rpc_services.

Definition begin_construction (op_star_o_p_t_star : option Z)
  : (option Tezos_protocol_environment_alpha__Environment.Time.t) ->
    (option Tezos_protocol_alpha.Protocol.Nonce_hash.t) ->
      (option Tezos_alpha_test_helpers.Block.baker_policy) ->
        Tezos_alpha_test_helpers.Block.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let priority :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => 0
    end in
  fun timestamp =>
    fun seed_nonce_hash =>
      fun op_star_o_p_t_star =>
        let policy :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => Block.By_priority priority
          end in
        fun predecessor =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_alpha_test_helpers.Block.get_next_baker (Some policy)
              predecessor)
            (fun function_parameter =>
              match function_parameter with
              | (delegate, priority, _timestamp) =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Minimal_valid_time.get
                    Tezos_alpha_test_helpers.Block.rpc_ctxt predecessor priority
                    0)
                  (fun real_timestamp =>
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_alpha_test_helpers.Account.find delegate)
                      (fun delegate =>
                        let timestamp :=
                          Tezos_base__TzPervasives.Option.unopt real_timestamp
                            timestamp in
                        let contents :=
                          Tezos_alpha_test_helpers.Block.Forge.contents None
                            (Some priority) seed_nonce_hash tt in
                        let protocol_data :=
                          {| Block_header.contents := contents;
                            Block_header.signature :=
                              Tezos_base__TzPervasives.Signature.zero |} in
                        let header :=
                          {|
                            Block_header.shell :=
                              {| level := level (shell (header predecessor));
                                proto_level :=
                                  proto_level (shell (header predecessor));
                                predecessor := hash predecessor;
                                timestamp := timestamp;
                                validation_passes :=
                                  validation_passes (shell (header predecessor));
                                operations_hash :=
                                  Tezos_base__TzPervasives.Operation_list_list_hash.zero;
                                fitness := fitness (shell (header predecessor));
                                context :=
                                  Tezos_base__TzPervasives.Context_hash.zero |};
                            Block_header.protocol_data :=
                              {| contents := contents;
                                signature :=
                                  Tezos_base__TzPervasives.Signature.zero |} |}
                          in
                        Tezos_base__TzPervasives.op_gt_gt_eq
                          (Tezos_protocol_alpha.Protocol.begin_construction
                            Tezos_base__TzPervasives.Chain_id.zero
                            (context predecessor)
                            (timestamp (shell (header predecessor)))
                            (level (shell (header predecessor)))
                            (fitness (shell (header predecessor)))
                            (hash predecessor) timestamp (Some protocol_data) tt)
                          (fun state =>
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (Lwt._return
                                (Tezos_protocol_alpha.Protocol.Environment.wrap_error
                                  state))
                              (fun state =>
                                Tezos_base__TzPervasives._return
                                  {| predecessor := predecessor; state := state;
                                    rev_operations := []; rev_tickets := [];
                                    header := header; delegate := delegate |}))))
              end).

Definition detect_script_failure {kind : Type}
  : (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind) ->
    Tezos_base__TzPervasives.tzresult unit :=
  let detect_script_failure :=
    let detect_script_failure_single {B : Type}
      (function_parameter :
      Tezos_protocol_alpha.Protocol.Apply_results.contents_result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager B))
      : Tezos_base__TzPervasives.tzresult unit :=
      match function_parameter with
      |
        Manager_operation_result {|
          operation_result := operation_result;
            internal_operation_results := internal_operation_results
            |} =>
        let detect_script_failure {C : Type}
          (result :
          Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
          : sum unit (list Tezos_base__TzPervasives.Error_monad.error) :=
          match result with
          | Applied _ => inl tt
          | Skipped _ => false
          | Backtracked _ None => inl tt
          | Backtracked _ (Some errs) =>
            Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs)
          | Failed _ errs =>
            Tezos_protocol_alpha.Protocol.Environment.wrap_error (inr errs)
          end in
        Tezos_base__TzPervasives.List.fold_left
          (fun acc =>
            fun function_parameter =>
              match function_parameter with
              | Internal_operation_result _ r =>
                Tezos_base__TzPervasives.op_gt_gt_question acc
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => detect_script_failure r
                    end)
              end) (detect_script_failure operation_result)
          internal_operation_results
      end in
    fun function_parameter =>
      match function_parameter with
      | Single_result ((Manager_operation_result _) as res) =>
        detect_script_failure_single res
      | Single_result _ => inl tt
      | Cons_result res rest =>
        Tezos_base__TzPervasives.op_gt_gt_question
          (detect_script_failure_single res)
          (fun function_parameter =>
            match function_parameter with
            | tt => detect_script_failure rest
            end)
      end in
  fun function_parameter =>
    match function_parameter with
    | {| contents := contents |} => detect_script_failure contents
    end.

Definition add_operation
  (expect_failure :
    option
      ((list Tezos_base__TzPervasives.error) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit))) (st : t)
  (op : Tezos_protocol_alpha.Protocol.operation)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_protocol_alpha.Protocol.apply_operation (state st) op)
    (fun x =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Lwt._return (Tezos_protocol_alpha.Protocol.Environment.wrap_error x))
        (fun function_parameter =>
          match function_parameter with
          | (state, (Operation_metadata result) as metadata) =>
            Tezos_base__TzPervasives.op_gt_gt_eq
              (apply Lwt._return (detect_script_failure result))
              (fun result =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  match expect_failure with
                  | None => Lwt._return result
                  | Some f =>
                    match result with
                    | inl _ =>
                      Tezos_base__TzPervasives.failwith
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Error expected while adding operation" % string
                            CamlinternalFormatBasics.End_of_format)
                          "Error expected while adding operation" % string)
                    | inr e => f e
                    end
                  end
                  (fun function_parameter =>
                    match function_parameter with
                    | tt => Tezos_base__TzPervasives._return record
                    end))
          | (state, No_operation_metadata as metadata) =>
            Tezos_base__TzPervasives._return record
          end)).

Definition finalize_block (st : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Block.t) :=
  Tezos_base__TzPervasives.op_gt_gt_eq
    (Tezos_protocol_alpha.Protocol.finalize_block (state st))
    (fun x =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Lwt._return (Tezos_protocol_alpha.Protocol.Environment.wrap_error x))
        (fun function_parameter =>
          match function_parameter with
          | (result, _) =>
            let operations :=
              Tezos_base__TzPervasives.List.rev (rev_operations st) in
            let operations_hash :=
              Tezos_base__TzPervasives.Operation_list_list_hash.compute
                (cons
                  (Tezos_base__TzPervasives.Operation_list_hash.compute
                    (Tezos_base__TzPervasives.List.map
                      Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash_packed
                      operations)) []) in
            let header := record in
            let hash :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.hash
                header in
            Tezos_base__TzPervasives._return
              {| Block.hash := hash; Block.header := header;
                Block.operations := operations; Block.context := context result
                |}
          end)).
src/proto_alpha/lib_protocol/test/helpers/incremental.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type t

type incremental = t

val predecessor : incremental -> Block.t

val header : incremental -> Block_header.t

val rev_tickets : incremental -> operation_receipt list

val level : incremental -> int32

val begin_construction :
  ?priority:int ->
  ?timestamp:Time.Protocol.t ->
  ?seed_nonce_hash:Nonce_hash.t ->
  ?policy:Block.baker_policy ->
  Block.t ->
  incremental tzresult Lwt.t

val add_operation :
  ?expect_failure:(error list -> unit tzresult Lwt.t) ->
  incremental ->
  Operation.packed ->
  incremental tzresult Lwt.t

val finalize_block : incremental -> Block.t tzresult Lwt.t

val rpc_ctxt : incremental Environment.RPC_context.simple
src/proto_alpha/lib_protocol/test/helpers/incremental.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition incremental := t.

Parameter predecessor : incremental -> Tezos_alpha_test_helpers.Block.t.

Parameter header :
incremental -> Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t.

Parameter rev_tickets :
incremental -> list Tezos_protocol_alpha.Protocol.operation_receipt.

Parameter level : incremental -> int32.

Parameter begin_construction :
(option Z) ->
  (option Tezos_base__TzPervasives.Time.Protocol.t) ->
    (option Tezos_protocol_alpha.Protocol.Nonce_hash.t) ->
      (option Tezos_alpha_test_helpers.Block.baker_policy) ->
        Tezos_alpha_test_helpers.Block.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult incremental).

Parameter add_operation :
(option
  ((list Tezos_base__TzPervasives.error) ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit))) ->
  incremental ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed ->
      Lwt.t (Tezos_base__TzPervasives.tzresult incremental).

Parameter finalize_block :
incremental ->
  Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Block.t).

Parameter rpc_ctxt :
Tezos_protocol_alpha.Protocol.Environment.RPC_context.simple incremental.
src/proto_alpha/lib_protocol/test/helpers/nonce.ml 
(**************************************************************************)
(*                                                                        *)
(*    Copyright (c) 2014 - 2018.                                          *)
(*    Dynamic Ledger Solutions, Inc.< contact@tezos.com >                 *)
(*                                                                        *)
(*    All rights reserved.No warranty, explicit or implicit, provided.    *)
(*                                                                        *)
(**************************************************************************)

open Protocol

module Table = Hashtbl.Make (struct
  type t = Nonce_hash.t

  let hash h = Int32.to_int (MBytes.get_int32 (Nonce_hash.to_bytes h) 0)

  let equal = Nonce_hash.equal
end)

let known_nonces = Table.create 17

let generate () =
  match
    Alpha_context.Nonce.of_bytes
    @@ Rand.generate Alpha_context.Constants.nonce_length
  with
  | Ok nonce ->
      let hash = Alpha_context.Nonce.hash nonce in
      Table.add known_nonces hash nonce ;
      (hash, nonce)
  | Error _ ->
      assert false

let forget_all () = Table.clear known_nonces

let get hash = Table.find known_nonces hash
src/proto_alpha/lib_protocol/test/helpers/nonce.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition known_nonces
  : Table.t Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  Table.create 17.

Definition generate (function_parameter : unit)
  : Tezos_raw_protocol_alpha.Nonce_hash.t *
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  match function_parameter with
  | tt =>
    match
      apply Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.of_bytes
        (Tezos_base__TzPervasives.Rand.generate
          Tezos_protocol_alpha.Protocol.Alpha_context.Constants.nonce_length)
      with
    | inl nonce =>
      let hash := Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.hash nonce
        in
      Table.add known_nonces hash nonce;
      (hash, nonce)
    | inr _ => false
    end
  end.

Definition forget_all (function_parameter : unit) : unit :=
  match function_parameter with
  | tt => Table.clear known_nonces
  end.

Definition get (hash : Table.key)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  Table.find known_nonces hash.
src/proto_alpha/lib_protocol/test/helpers/nonce.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

(** Returns a fresh nonce and its corresponding hash (and stores them). *)
val generate : unit -> Nonce_hash.t * Alpha_context.Nonce.t

val get : Nonce_hash.t -> Alpha_context.Nonce.t

val forget_all : unit -> unit
src/proto_alpha/lib_protocol/test/helpers/nonce.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter generate :
unit ->
  Tezos_protocol_alpha.Protocol.Nonce_hash.t *
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.

Parameter get :
Tezos_protocol_alpha.Protocol.Nonce_hash.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.

Parameter forget_all : unit -> unit.
src/proto_alpha/lib_protocol/test/helpers/op.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

let sign ?(watermark = Signature.Generic_operation) sk ctxt contents =
  let branch = Context.branch ctxt in
  let unsigned =
    Data_encoding.Binary.to_bytes_exn
      Operation.unsigned_encoding
      ({branch}, Contents_list contents)
  in
  let signature = Some (Signature.sign ~watermark sk unsigned) in
  ({shell = {branch}; protocol_data = {contents; signature}} : _ Operation.t)

let endorsement ?delegate ?level ctxt ?(signing_context = ctxt) () =
  ( match delegate with
  | None ->
      Context.get_endorser ctxt >>=? fun (delegate, _slots) -> return delegate
  | Some delegate ->
      return delegate )
  >>=? fun delegate_pkh ->
  Account.find delegate_pkh
  >>=? fun delegate ->
  ( match level with
  | None ->
      Context.get_level ctxt
  | Some level ->
      return level )
  >>=? fun level ->
  let op = Single (Endorsement {level}) in
  return
    (sign
       ~watermark:Signature.(Endorsement Chain_id.zero)
       delegate.sk
       signing_context
       op)

let sign ?watermark sk ctxt (Contents_list contents) =
  Operation.pack (sign ?watermark sk ctxt contents)

let combine_operations ?public_key ?counter ~source ctxt
    (packed_operations : packed_operation list) =
  assert (List.length packed_operations > 0) ;
  (* Hypothesis : each operation must have the same branch (is this really true?) *)
  let {Tezos_base.Operation.branch} = (List.hd packed_operations).shell in
  assert (
    List.for_all
      (fun {shell = {Tezos_base.Operation.branch = b; _}; _} ->
        Block_hash.(branch = b))
      packed_operations ) ;
  (* TODO? : check signatures consistency *)
  let unpacked_operations =
    List.map
      (function
        | {Alpha_context.protocol_data = Operation_data {contents; _}; _} -> (
          match Contents_list contents with
          | Contents_list (Single o) ->
              Contents o
          | Contents_list
              (Cons (Manager_operation {operation = Reveal _; _}, Single o)) ->
              Contents o
          | _ ->
              (* TODO : decent error *) assert false ))
      packed_operations
  in
  ( match counter with
  | Some counter ->
      return counter
  | None ->
      Context.Contract.counter ctxt source )
  >>=? fun counter ->
  (* We increment the counter *)
  let counter = Z.succ counter in
  Context.Contract.manager ctxt source
  >>=? fun account ->
  let public_key = Option.unopt ~default:account.pk public_key in
  Context.Contract.is_manager_key_revealed ctxt source
  >>=? (function
         | false ->
             let reveal_op =
               Manager_operation
                 {
                   source = Signature.Public_key.hash public_key;
                   fee = Tez.zero;
                   counter;
                   operation = Reveal public_key;
                   gas_limit = Z.of_int 10000;
                   storage_limit = Z.zero;
                 }
             in
             return (Some (Contents reveal_op), Z.succ counter)
         | true ->
             return (None, counter))
  >>=? fun (manager_op, counter) ->
  (* Update counters and transform into a contents_list *)
  let operations =
    List.fold_left
      (fun (counter, acc) -> function Contents (Manager_operation m) ->
            ( Z.succ counter,
              Contents (Manager_operation {m with counter}) :: acc ) | x ->
            (counter, x :: acc))
      (counter, match manager_op with None -> [] | Some op -> [op])
      unpacked_operations
    |> snd |> List.rev
  in
  let operations = Operation.of_list operations in
  return @@ sign account.sk ctxt operations

let manager_operation ?counter ?(fee = Tez.zero) ?gas_limit ?storage_limit
    ?public_key ~source ctxt operation =
  ( match counter with
  | Some counter ->
      return counter
  | None ->
      Context.Contract.counter ctxt source )
  >>=? fun counter ->
  Context.get_constants ctxt
  >>=? fun c ->
  let gas_limit =
    Option.unopt
      ~default:c.parametric.hard_storage_limit_per_operation
      gas_limit
  in
  let storage_limit =
    Option.unopt
      ~default:c.parametric.hard_storage_limit_per_operation
      storage_limit
  in
  Context.Contract.manager ctxt source
  >>=? fun account ->
  let public_key = Option.unopt ~default:account.pk public_key in
  let counter = Z.succ counter in
  Context.Contract.is_manager_key_revealed ctxt source
  >>=? function
  | true ->
      let op =
        Manager_operation
          {
            source = Signature.Public_key.hash public_key;
            fee;
            counter;
            operation;
            gas_limit;
            storage_limit;
          }
      in
      return (Contents_list (Single op))
  | false ->
      let op_reveal =
        Manager_operation
          {
            source = Signature.Public_key.hash public_key;
            fee = Tez.zero;
            counter;
            operation = Reveal public_key;
            gas_limit = Z.of_int 10000;
            storage_limit = Z.zero;
          }
      in
      let op =
        Manager_operation
          {
            source = Signature.Public_key.hash public_key;
            fee;
            counter = Z.succ counter;
            operation;
            gas_limit;
            storage_limit;
          }
      in
      return (Contents_list (Cons (op_reveal, Single op)))

let revelation ctxt public_key =
  let pkh = Signature.Public_key.hash public_key in
  let source = Contract.implicit_contract pkh in
  Context.Contract.counter ctxt source
  >>=? fun counter ->
  Context.Contract.manager ctxt source
  >>=? fun account ->
  let counter = Z.succ counter in
  let sop =
    Contents_list
      (Single
         (Manager_operation
            {
              source = Signature.Public_key.hash public_key;
              fee = Tez.zero;
              counter;
              operation = Reveal public_key;
              gas_limit = Z.of_int 10000;
              storage_limit = Z.zero;
            }))
  in
  return @@ sign account.sk ctxt sop

let originated_contract op =
  let nonce = Contract.initial_origination_nonce (Operation.hash_packed op) in
  Contract.originated_contract nonce

exception Impossible

let origination ?counter ?delegate ~script ?(preorigination = None) ?public_key
    ?credit ?fee ?gas_limit ?storage_limit ctxt source =
  Context.Contract.manager ctxt source
  >>=? fun account ->
  let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in
  let default_credit = Option.unopt_exn Impossible default_credit in
  let credit = Option.unopt ~default:default_credit credit in
  let operation = Origination {delegate; script; credit; preorigination} in
  manager_operation
    ?counter
    ?public_key
    ?fee
    ?gas_limit
    ?storage_limit
    ~source
    ctxt
    operation
  >>=? fun sop ->
  let op = sign account.sk ctxt sop in
  return (op, originated_contract op)

let miss_signed_endorsement ?level ctxt =
  ( match level with
  | None ->
      Context.get_level ctxt
  | Some level ->
      return level )
  >>=? fun level ->
  Context.get_endorser ctxt
  >>=? fun (real_delegate_pkh, _slots) ->
  let delegate = Account.find_alternate real_delegate_pkh in
  endorsement ~delegate:delegate.pkh ~level ctxt ()

let transaction ?fee ?gas_limit ?storage_limit
    ?(parameters = Script.unit_parameter) ?(entrypoint = "default") ctxt
    (src : Contract.t) (dst : Contract.t) (amount : Tez.t) =
  let top = Transaction {amount; parameters; destination = dst; entrypoint} in
  manager_operation ?fee ?gas_limit ?storage_limit ~source:src ctxt top
  >>=? fun sop ->
  Context.Contract.manager ctxt src
  >>=? fun account -> return @@ sign account.sk ctxt sop

let delegation ?fee ctxt source dst =
  let top = Delegation dst in
  manager_operation ?fee ~source ctxt top
  >>=? fun sop ->
  Context.Contract.manager ctxt source
  >>=? fun account -> return @@ sign account.sk ctxt sop

let activation ctxt (pkh : Signature.Public_key_hash.t) activation_code =
  ( match pkh with
  | Ed25519 edpkh ->
      return edpkh
  | _ ->
      failwith
        "Wrong public key hash : %a - Commitments must be activated with an \
         Ed25519 encrypted public key hash"
        Signature.Public_key_hash.pp
        pkh )
  >>=? fun id ->
  let contents = Single (Activate_account {id; activation_code}) in
  let branch = Context.branch ctxt in
  return
    {
      shell = {branch};
      protocol_data = Operation_data {contents; signature = None};
    }

let double_endorsement ctxt op1 op2 =
  let contents = Single (Double_endorsement_evidence {op1; op2}) in
  let branch = Context.branch ctxt in
  return
    {
      shell = {branch};
      protocol_data = Operation_data {contents; signature = None};
    }

let double_baking ctxt bh1 bh2 =
  let contents = Single (Double_baking_evidence {bh1; bh2}) in
  let branch = Context.branch ctxt in
  return
    {
      shell = {branch};
      protocol_data = Operation_data {contents; signature = None};
    }

let seed_nonce_revelation ctxt level nonce =
  return
    {
      shell = {branch = Context.branch ctxt};
      protocol_data =
        Operation_data
          {
            contents = Single (Seed_nonce_revelation {level; nonce});
            signature = None;
          };
    }

let proposals ctxt (pkh : Contract.t) proposals =
  Context.Contract.pkh pkh
  >>=? fun source ->
  Context.Vote.get_voting_period ctxt
  >>=? fun period ->
  let op = Proposals {source; period; proposals} in
  Account.find source
  >>=? fun account -> return (sign account.sk ctxt (Contents_list (Single op)))

let ballot ctxt (pkh : Contract.t) proposal ballot =
  Context.Contract.pkh pkh
  >>=? fun source ->
  Context.Vote.get_voting_period ctxt
  >>=? fun period ->
  let op = Ballot {source; period; proposal; ballot} in
  Account.find source
  >>=? fun account -> return (sign account.sk ctxt (Contents_list (Single op)))

let dummy_script =
  let open Micheline in
  Script.
    {
      code =
        lazy_expr
          (strip_locations
             (Seq
                ( 0,
                  [ Prim (0, K_parameter, [Prim (0, T_unit, [], [])], []);
                    Prim (0, K_storage, [Prim (0, T_unit, [], [])], []);
                    Prim
                      ( 0,
                        K_code,
                        [ Seq
                            ( 0,
                              [ Prim (0, I_CDR, [], []);
                                Prim
                                  ( 0,
                                    I_NIL,
                                    [Prim (0, T_operation, [], [])],
                                    [] );
                                Prim (0, I_PAIR, [], []) ] ) ],
                        [] ) ] )));
      storage = lazy_expr (strip_locations (Prim (0, D_Unit, [], [])));
    }

let dummy_script_cost = Test_tez.Tez.of_mutez_exn 38_000L
src/proto_alpha/lib_protocol/test/helpers/op.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition sign {A : Type}
  (op_star_o_p_t_star : option Tezos_base__TzPervasives.Signature.watermark)
  : Tezos_base__TzPervasives.Signature.Secret_key.t ->
    Tezos_alpha_test_helpers.Context.t ->
      (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A) ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t A :=
  let watermark :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Signature.Generic_operation
    end in
  fun sk =>
    fun ctxt =>
      fun contents =>
        let branch := Tezos_alpha_test_helpers.Context.branch ctxt in
        let unsigned :=
          Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
            Tezos_protocol_alpha.Protocol.Alpha_context.Operation.unsigned_encoding
            ({| branch := branch |}, (Contents_list contents)) in
        let signature :=
          Some
            (Tezos_base__TzPervasives.Signature.sign (Some watermark) sk
              unsigned) in
        {| shell := {| branch := branch |};
          protocol_data := {| contents := contents; signature := signature |} |}.

Definition endorsement
  (delegate : option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (level : option Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (op_star_o_p_t_star : option Tezos_alpha_test_helpers.Context.t)
  : unit ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)) :=
  let signing_context :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => ctxt
    end in
  fun function_parameter =>
    match function_parameter with
    | tt =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        match delegate with
        | None =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_alpha_test_helpers.Context.get_endorser ctxt)
            (fun function_parameter =>
              match function_parameter with
              | (delegate, _slots) => Tezos_base__TzPervasives._return delegate
              end)
        | Some delegate => Tezos_base__TzPervasives._return delegate
        end
        (fun delegate_pkh =>
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_alpha_test_helpers.Account.find delegate_pkh)
            (fun delegate =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                match level with
                | None => Tezos_alpha_test_helpers.Context.get_level ctxt
                | Some level => Tezos_base__TzPervasives._return level
                end
                (fun level =>
                  let op := Single (Endorsement {| level := level |}) in
                  Tezos_base__TzPervasives._return
                    (sign
                      (Some (Endorsement Tezos_base__TzPervasives.Chain_id.zero))
                      (sk delegate) signing_context op))))
    end.

Definition sign
  (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Alpha_context.packed_contents_list)
  : Tezos_raw_protocol_alpha__Alpha_context.packed_operation :=
  match function_parameter with
  | Contents_list contents =>
    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.pack
      (sign watermark sk ctxt contents)
  end.

Definition combine_operations
  (public_key : option Tezos_base__TzPervasives.Signature.Public_key.t)
  (counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (packed_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  OCaml.Stdlib.gt (Tezos_base__TzPervasives.List.length packed_operations) 0;
  match shell (Tezos_base__TzPervasives.List.hd packed_operations) with
  | {| Tezos_base.Operation.branch := branch |} =>
    Tezos_base__TzPervasives.List.for_all
      (fun function_parameter =>
        match function_parameter with
        | {| shell := {| Tezos_base.Operation.branch := b |} |} =>
          Tezos_base__TzPervasives.Block_hash.op_eq branch b
        end) packed_operations;
    let unpacked_operations :=
      Tezos_base__TzPervasives.List.map
        (fun function_parameter =>
          match function_parameter with
          | {|
            Alpha_context.protocol_data := Operation_data {| contents := contents |}
              |} =>
            match Contents_list contents with
            | Contents_list (Single o) => Contents o
            |
              Contents_list
                (Cons (Manager_operation {| operation := Reveal _ |}) (Single o))
              => Contents o
            | _ => false
            end
          end) packed_operations in
    Tezos_base__TzPervasives.op_gt_gt_eq_question
      match counter with
      | Some counter => Tezos_base__TzPervasives._return counter
      | None => Tezos_alpha_test_helpers.Context.Contract.counter ctxt source
      end
      (fun counter =>
        let counter := Z.succ counter in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_alpha_test_helpers.Context.Contract.manager ctxt source)
          (fun account =>
            let public_key :=
              Tezos_base__TzPervasives.Option.unopt (pk account) public_key in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_base__TzPervasives.op_gt_gt_eq_question
                (Tezos_alpha_test_helpers.Context.Contract.is_manager_key_revealed
                  ctxt source)
                (fun function_parameter =>
                  match function_parameter with
                  | false =>
                    let reveal_op :=
                      Manager_operation
                        {|
                          source :=
                            Tezos_base__TzPervasives.Signature.Public_key.hash
                              public_key;
                          fee :=
                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero;
                          counter := counter; operation := Reveal public_key;
                          gas_limit := Z.of_int 10000; storage_limit := Z.zero
                          |} in
                    Tezos_base__TzPervasives._return
                      ((Some (Contents reveal_op)), (Z.succ counter))
                  | true => Tezos_base__TzPervasives._return (None, counter)
                  end))
              (fun function_parameter =>
                match function_parameter with
                | (manager_op, counter) =>
                  let operations :=
                    OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply
                        (Tezos_base__TzPervasives.List.fold_left
                          (fun function_parameter =>
                            match function_parameter with
                            | (counter, acc) =>
                              fun function_parameter =>
                                match function_parameter with
                                | Contents (Manager_operation m) =>
                                  ((Z.succ counter),
                                    (cons (Contents (Manager_operation record))
                                      acc))
                                | x => (counter, (cons x acc))
                                end
                            end)
                          (counter,
                            match manager_op with
                            | None => []
                            | Some op => cons op []
                            end) unpacked_operations) snd)
                      Tezos_base__TzPervasives.List.rev in
                  let operations :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Operation.of_list
                      operations in
                  apply Tezos_base__TzPervasives._return
                    (sign None (sk account) ctxt operations)
                end)))
  end.

Definition manager_operation {A : Type}
  (counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (op_star_o_p_t_star :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
    (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
      (option Tezos_base__TzPervasives.Signature.Public_key.t) ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
          Tezos_alpha_test_helpers.Context.t ->
            (Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation A) ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  Tezos_protocol_alpha.Protocol.Alpha_context.packed_contents_list) :=
  let fee :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
    end in
  fun gas_limit =>
    fun storage_limit =>
      fun public_key =>
        fun source =>
          fun ctxt =>
            fun operation =>
              Tezos_base__TzPervasives.op_gt_gt_eq_question
                match counter with
                | Some counter => Tezos_base__TzPervasives._return counter
                | None =>
                  Tezos_alpha_test_helpers.Context.Contract.counter ctxt source
                end
                (fun counter =>
                  Tezos_base__TzPervasives.op_gt_gt_eq_question
                    (Tezos_alpha_test_helpers.Context.get_constants ctxt)
                    (fun c =>
                      let gas_limit :=
                        Tezos_base__TzPervasives.Option.unopt
                          (hard_storage_limit_per_operation (parametric c))
                          gas_limit in
                      let storage_limit :=
                        Tezos_base__TzPervasives.Option.unopt
                          (hard_storage_limit_per_operation (parametric c))
                          storage_limit in
                      Tezos_base__TzPervasives.op_gt_gt_eq_question
                        (Tezos_alpha_test_helpers.Context.Contract.manager ctxt
                          source)
                        (fun account =>
                          let public_key :=
                            Tezos_base__TzPervasives.Option.unopt (pk account)
                              public_key in
                          let counter := Z.succ counter in
                          Tezos_base__TzPervasives.op_gt_gt_eq_question
                            (Tezos_alpha_test_helpers.Context.Contract.is_manager_key_revealed
                              ctxt source)
                            (fun function_parameter =>
                              match function_parameter with
                              | true =>
                                let op :=
                                  Manager_operation
                                    {|
                                      source :=
                                        Tezos_base__TzPervasives.Signature.Public_key.hash
                                          public_key; fee := fee;
                                      counter := counter;
                                      operation := operation;
                                      gas_limit := gas_limit;
                                      storage_limit := storage_limit |} in
                                Tezos_base__TzPervasives._return
                                  (Contents_list (Single op))
                              | false =>
                                let op_reveal :=
                                  Manager_operation
                                    {|
                                      source :=
                                        Tezos_base__TzPervasives.Signature.Public_key.hash
                                          public_key;
                                      fee :=
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero;
                                      counter := counter;
                                      operation := Reveal public_key;
                                      gas_limit := Z.of_int 10000;
                                      storage_limit := Z.zero |} in
                                let op :=
                                  Manager_operation
                                    {|
                                      source :=
                                        Tezos_base__TzPervasives.Signature.Public_key.hash
                                          public_key; fee := fee;
                                      counter := Z.succ counter;
                                      operation := operation;
                                      gas_limit := gas_limit;
                                      storage_limit := storage_limit |} in
                                Tezos_base__TzPervasives._return
                                  (Contents_list (Cons op_reveal (Single op)))
                              end)))).

Definition revelation
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (public_key : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  let pkh := Tezos_base__TzPervasives.Signature.Public_key.hash public_key in
  let source :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract pkh
    in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_alpha_test_helpers.Context.Contract.counter ctxt source)
    (fun counter =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_alpha_test_helpers.Context.Contract.manager ctxt source)
        (fun account =>
          let counter := Z.succ counter in
          let sop :=
            Contents_list
              (Single
                (Manager_operation
                  {|
                    source :=
                      Tezos_base__TzPervasives.Signature.Public_key.hash
                        public_key;
                    fee := Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero;
                    counter := counter; operation := Reveal public_key;
                    gas_limit := Z.of_int 10000; storage_limit := Z.zero |})) in
          apply Tezos_base__TzPervasives._return
            (sign None (sk account) ctxt sop))).

Definition originated_contract
  (op : Tezos_raw_protocol_alpha__Alpha_context.packed_operation)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract :=
  let nonce :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.initial_origination_nonce
      (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.hash_packed op) in
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.originated_contract nonce.

Definition origination
  (counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (script : Tezos_protocol_alpha.Protocol.Alpha_context.Script.t)
  (op_star_o_p_t_star :
    option (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))
  : (option Tezos_base__TzPervasives.Signature.Public_key.t) ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
        (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
          (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
            Tezos_alpha_test_helpers.Context.t ->
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
                Lwt.t
                  (Tezos_base__TzPervasives.tzresult
                    (Tezos_raw_protocol_alpha__Alpha_context.packed_operation *
                      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
  let preorigination :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => None
    end in
  fun public_key =>
    fun credit =>
      fun fee =>
        fun gas_limit =>
          fun storage_limit =>
            fun ctxt =>
              fun source =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_alpha_test_helpers.Context.Contract.manager ctxt source)
                  (fun account =>
                    let default_credit :=
                      apply
                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez
                        (Stdlib.Int64.of_int 1000001) in
                    let default_credit :=
                      Tezos_base__TzPervasives.Option.unopt_exn Impossible
                        default_credit in
                    let credit :=
                      Tezos_base__TzPervasives.Option.unopt default_credit
                        credit in
                    let operation :=
                      Origination
                        {| delegate := delegate; script := script;
                          credit := credit; preorigination := preorigination |}
                      in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (manager_operation counter fee gas_limit storage_limit
                        public_key source ctxt operation)
                      (fun sop =>
                        let op := sign None (sk account) ctxt sop in
                        Tezos_base__TzPervasives._return
                          (op, (originated_contract op)))).

Definition miss_signed_endorsement
  (level : option Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
        Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match level with
    | None => Tezos_alpha_test_helpers.Context.get_level ctxt
    | Some level => Tezos_base__TzPervasives._return level
    end
    (fun level =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_alpha_test_helpers.Context.get_endorser ctxt)
        (fun function_parameter =>
          match function_parameter with
          | (real_delegate_pkh, _slots) =>
            let delegate :=
              Tezos_alpha_test_helpers.Account.find_alternate real_delegate_pkh
              in
            endorsement (Some (pkh delegate)) (Some level) ctxt None tt
          end)).

Definition transaction
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (gas_limit : option Tezos_protocol_environment_alpha__Environment.Z.t)
  (storage_limit : option Tezos_protocol_environment_alpha__Environment.Z.t)
  (op_star_o_p_t_star :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr)
  : (option string) ->
    Tezos_alpha_test_helpers.Context.t ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  let parameters :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_protocol_alpha.Protocol.Alpha_context.Script.unit_parameter
    end in
  fun op_star_o_p_t_star =>
    let entrypoint :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => "default" % string
      end in
    fun ctxt =>
      fun src =>
        fun dst =>
          fun amount =>
            let top :=
              Transaction
                {| amount := amount; parameters := parameters;
                  entrypoint := entrypoint; destination := dst |} in
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (manager_operation None fee gas_limit storage_limit None src ctxt
                top)
              (fun sop =>
                Tezos_base__TzPervasives.op_gt_gt_eq_question
                  (Tezos_alpha_test_helpers.Context.Contract.manager ctxt src)
                  (fun account =>
                    apply Tezos_base__TzPervasives._return
                      (sign None (sk account) ctxt sop))).

Definition delegation
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (dst :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  let top := Delegation dst in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (manager_operation None fee None None None source ctxt top)
    (fun sop =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_alpha_test_helpers.Context.Contract.manager ctxt source)
        (fun account =>
          apply Tezos_base__TzPervasives._return
            (sign None (sk account) ctxt sop))).

Definition activation
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (activation_code :
    Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    match pkh with
    | Ed25519 edpkh => Tezos_base__TzPervasives._return edpkh
    | _ =>
      Tezos_base__TzPervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Wrong public key hash : " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                " - Commitments must be activated with an Ed25519 encrypted public key hash"
                  % string CamlinternalFormatBasics.End_of_format)))
          "Wrong public key hash : %a - Commitments must be activated with an Ed25519 encrypted public key hash"
            % string) Tezos_base__TzPervasives.Signature.Public_key_hash.pp pkh
    end
    (fun id =>
      let contents :=
        Single
          (Activate_account {| id := id; activation_code := activation_code |})
        in
      let branch := Tezos_alpha_test_helpers.Context.branch ctxt in
      Tezos_base__TzPervasives._return
        {| shell := {| branch := branch |};
          protocol_data :=
            Operation_data {| contents := contents; signature := None |} |}).

Definition double_endorsement
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (op1 :
    Tezos_protocol_alpha.Protocol.Alpha_context.operation
      Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)
  (op2 :
    Tezos_protocol_alpha.Protocol.Alpha_context.operation
      Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
  let contents :=
    Single (Double_endorsement_evidence {| op1 := op1; op2 := op2 |}) in
  let branch := Tezos_alpha_test_helpers.Context.branch ctxt in
  Tezos_base__TzPervasives._return
    {| shell := {| branch := branch |};
      protocol_data :=
        Operation_data {| contents := contents; signature := None |} |}.

Definition double_baking
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (bh1 : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t)
  (bh2 : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
  let contents := Single (Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |})
    in
  let branch := Tezos_alpha_test_helpers.Context.branch ctxt in
  Tezos_base__TzPervasives._return
    {| shell := {| branch := branch |};
      protocol_data :=
        Operation_data {| contents := contents; signature := None |} |}.

Definition seed_nonce_revelation
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  (nonce : Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
  Tezos_base__TzPervasives._return
    {| shell := {| branch := Tezos_alpha_test_helpers.Context.branch ctxt |};
      protocol_data :=
        Operation_data
          {|
            contents :=
              Single
                (Seed_nonce_revelation {| level := level; nonce := nonce |});
            signature := None |} |}.

Definition proposals
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (pkh : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (proposals :
    list
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_alpha_test_helpers.Context.Contract.pkh pkh)
    (fun source =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_alpha_test_helpers.Context.Vote.get_voting_period ctxt)
        (fun period =>
          let op :=
            Proposals
              {| source := source; period := period; proposals := proposals |}
            in
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_alpha_test_helpers.Account.find source)
            (fun account =>
              Tezos_base__TzPervasives._return
                (sign None (sk account) ctxt (Contents_list (Single op)))))).

Definition ballot
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (pkh : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (proposal :
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ballot : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_alpha_test_helpers.Context.Contract.pkh pkh)
    (fun source =>
      Tezos_base__TzPervasives.op_gt_gt_eq_question
        (Tezos_alpha_test_helpers.Context.Vote.get_voting_period ctxt)
        (fun period =>
          let op :=
            Ballot
              {| source := source; period := period; proposal := proposal;
                ballot := ballot |} in
          Tezos_base__TzPervasives.op_gt_gt_eq_question
            (Tezos_alpha_test_helpers.Account.find source)
            (fun account =>
              Tezos_base__TzPervasives._return
                (sign None (sk account) ctxt (Contents_list (Single op)))))).

Definition dummy_script
  : Tezos_protocol_alpha.Protocol.Alpha_context.Script.t :=
  {|
    code :=
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr
        (Tezos_micheline.Micheline.strip_locations
          (Seq 0
            (cons (Prim 0 K_parameter (cons (Prim 0 T_unit [] []) []) [])
              (cons (Prim 0 K_storage (cons (Prim 0 T_unit [] []) []) [])
                (cons
                  (Prim 0 K_code
                    (cons
                      (Seq 0
                        (cons (Prim 0 I_CDR [] [])
                          (cons
                            (Prim 0 I_NIL (cons (Prim 0 T_operation [] []) [])
                              []) (cons (Prim 0 I_PAIR [] []) [])))) []) []) [])))));
    storage :=
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr
        (Tezos_micheline.Micheline.strip_locations (Prim 0 D_Unit [] [])) |}.

Definition dummy_script_cost
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
  Tezos_alpha_test_helpers.Test_tez.Tez.of_mutez_exn 38000.
src/proto_alpha/lib_protocol/test/helpers/op.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

val endorsement :
  ?delegate:public_key_hash ->
  ?level:Raw_level.t ->
  Context.t ->
  ?signing_context:Context.t ->
  unit ->
  Kind.endorsement Operation.t tzresult Lwt.t

val miss_signed_endorsement :
  ?level:Raw_level.t ->
  Context.t ->
  Kind.endorsement Operation.t tzresult Lwt.t

val transaction :
  ?fee:Tez.tez ->
  ?gas_limit:Z.t ->
  ?storage_limit:Z.t ->
  ?parameters:Script.lazy_expr ->
  ?entrypoint:string ->
  Context.t ->
  Contract.t ->
  Contract.t ->
  Tez.t ->
  Operation.packed tzresult Lwt.t

val delegation :
  ?fee:Tez.tez ->
  Context.t ->
  Contract.t ->
  public_key_hash option ->
  Operation.packed tzresult Lwt.t

val revelation : Context.t -> public_key -> Operation.packed tzresult Lwt.t

val origination :
  ?counter:Z.t ->
  ?delegate:public_key_hash ->
  script:Script.t ->
  ?preorigination:Contract.contract option ->
  ?public_key:public_key ->
  ?credit:Tez.tez ->
  ?fee:Tez.tez ->
  ?gas_limit:Z.t ->
  ?storage_limit:Z.t ->
  Context.t ->
  Contract.contract ->
  (Operation.packed * Contract.contract) tzresult Lwt.t

val originated_contract : Operation.packed -> Contract.contract

val double_endorsement :
  Context.t ->
  Kind.endorsement Operation.t ->
  Kind.endorsement Operation.t ->
  Operation.packed tzresult Lwt.t

val double_baking :
  Context.t ->
  Block_header.block_header ->
  Block_header.block_header ->
  Operation.packed tzresult Lwt.t

val activation :
  Context.t ->
  Signature.Public_key_hash.t ->
  Blinded_public_key_hash.activation_code ->
  Operation.packed tzresult Lwt.t

val combine_operations :
  ?public_key:public_key ->
  ?counter:counter ->
  source:Contract.t ->
  Context.t ->
  packed_operation list ->
  packed_operation tzresult Lwt.t

(** Reveals a seed_nonce that was previously committed at a certain level *)
val seed_nonce_revelation :
  Context.t -> Raw_level.t -> Nonce.t -> Operation.packed tzresult Lwt.t

(** Propose a list of protocol hashes during the approval voting *)
val proposals :
  Context.t ->
  Contract.t ->
  Protocol_hash.t list ->
  Operation.packed tzresult Lwt.t

(** Cast a vote yay, nay or pass *)
val ballot :
  Context.t ->
  Contract.t ->
  Protocol_hash.t ->
  Vote.ballot ->
  Operation.packed tzresult Lwt.t

val dummy_script : Script.t

val dummy_script_cost : Test_tez.Tez.t
src/proto_alpha/lib_protocol/test/helpers/op.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter endorsement :
(option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
  (option Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t) ->
    Tezos_alpha_test_helpers.Context.t ->
      (option Tezos_alpha_test_helpers.Context.t) ->
        unit ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
                Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)).

Parameter miss_signed_endorsement :
(option Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t) ->
  Tezos_alpha_test_helpers.Context.t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)).

Parameter transaction :
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
  (option Z.t) ->
    (option Z.t) ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr) ->
        (option string) ->
          Tezos_alpha_test_helpers.Context.t ->
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
                Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter delegation :
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
  Tezos_alpha_test_helpers.Context.t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter revelation :
Tezos_alpha_test_helpers.Context.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.public_key ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter origination :
(option Z.t) ->
  (option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.t ->
      (option
        (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract))
        ->
        (option Tezos_protocol_alpha.Protocol.Alpha_context.public_key) ->
          (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
            (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
              (option Z.t) ->
                (option Z.t) ->
                  Tezos_alpha_test_helpers.Context.t ->
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract
                      ->
                      Lwt.t
                        (Tezos_base__TzPervasives.tzresult
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed
                            *
                            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)).

Parameter originated_contract :
Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract.

Parameter double_endorsement :
Tezos_alpha_test_helpers.Context.t ->
  (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
    Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement) ->
    (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement) ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter double_baking :
Tezos_alpha_test_helpers.Context.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.block_header ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.block_header ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter activation :
Tezos_alpha_test_helpers.Context.t ->
  Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
    Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter combine_operations :
(option Tezos_protocol_alpha.Protocol.Alpha_context.public_key) ->
  (option Tezos_protocol_alpha.Protocol.Alpha_context.counter) ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
      Tezos_alpha_test_helpers.Context.t ->
        (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation).

Parameter seed_nonce_revelation :
Tezos_alpha_test_helpers.Context.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter proposals :
Tezos_alpha_test_helpers.Context.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
    (list Tezos_base__TzPervasives.Protocol_hash.t) ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter ballot :
Tezos_alpha_test_helpers.Context.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
    Tezos_base__TzPervasives.Protocol_hash.t ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed).

Parameter dummy_script : Tezos_protocol_alpha.Protocol.Alpha_context.Script.t.

Parameter dummy_script_cost : Tezos_alpha_test_helpers.Test_tez.Tez.t.
src/proto_alpha/lib_protocol/test/helpers/test_tez.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Environment

(* This module is mostly to wrap the errors from the protocol *)
module Tez = struct
  include Tez

  let ( +? ) t1 t2 = t1 +? t2 |> wrap_error

  let ( -? ) t1 t2 = t1 -? t2 |> wrap_error

  let ( *? ) t1 t2 = t1 *? t2 |> wrap_error

  let ( /? ) t1 t2 = t1 /? t2 |> wrap_error

  let ( + ) t1 t2 =
    match t1 +? t2 with
    | Ok r ->
        r
    | Error _ ->
        Pervasives.failwith "adding tez"

  let of_int x =
    match Tez.of_mutez (Int64.mul (Int64.of_int x) 1_000_000L) with
    | None ->
        invalid_arg "tez_of_int"
    | Some x ->
        x

  let of_mutez_exn x =
    match Tez.of_mutez x with
    | None ->
        invalid_arg "tez_of_mutez"
    | Some x ->
        x

  let max_tez =
    match Tez.of_mutez Int64.max_int with None -> assert false | Some p -> p
end
src/proto_alpha/lib_protocol/test/helpers/test_tez.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Import Tezos_protocol_alpha.Protocol.Environment.

Module Tez.
  Definition op_plus_question (t1 : tez) (t2 : tez)
    : Tezos_base__TzPervasives.Error_monad.tzresult tez :=
    OCaml.Stdlib.reverse_apply (op_plus_question t1 t2)
      Tezos_protocol_alpha.Protocol.Environment.wrap_error.
  
  Definition op_minus_question (t1 : tez) (t2 : tez)
    : Tezos_base__TzPervasives.Error_monad.tzresult tez :=
    OCaml.Stdlib.reverse_apply (op_minus_question t1 t2)
      Tezos_protocol_alpha.Protocol.Environment.wrap_error.
  
  Definition op_star_question (t1 : tez) (t2 : int64)
    : Tezos_base__TzPervasives.Error_monad.tzresult tez :=
    OCaml.Stdlib.reverse_apply (op_star_question t1 t2)
      Tezos_protocol_alpha.Protocol.Environment.wrap_error.
  
  Definition op_div_question (t1 : tez) (t2 : int64)
    : Tezos_base__TzPervasives.Error_monad.tzresult tez :=
    OCaml.Stdlib.reverse_apply (op_div_question t1 t2)
      Tezos_protocol_alpha.Protocol.Environment.wrap_error.
  
  Definition op_plus (t1 : tez) (t2 : tez) : tez :=
    match op_plus_question t1 t2 with
    | inl r => r
    | inr _ =>
      Tezos_protocol_alpha.Protocol.Environment.Pervasives.failwith
        "adding tez" % string
    end.
  
  Definition of_int (x : Z)
    : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
    match
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez
        (Tezos_protocol_alpha.Protocol.Environment.Int64.mul
          (Tezos_protocol_alpha.Protocol.Environment.Int64.of_int x) 1000000)
      with
    | None => OCaml.Stdlib.invalid_arg "tez_of_int" % string
    | Some x => x
    end.
  
  Definition of_mutez_exn (x : int64)
    : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
    match Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez x with
    | None => OCaml.Stdlib.invalid_arg "tez_of_mutez" % string
    | Some x => x
    end.
  
  Definition max_tez : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
    match
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.of_mutez
        Tezos_protocol_alpha.Protocol.Environment.Int64.max_int with
    | None => false
    | Some p => p
    end.
End Tez.
src/proto_alpha/lib_protocol/test/helpers/test_utils.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* This file should not depend on any other file from tests. *)

let ( >>?= ) x y = match x with Ok a -> y a | Error b -> fail @@ List.hd b

(** Like List.find but returns the index of the found element *)
let findi p =
  let rec aux p i = function
    | [] ->
        raise Not_found
    | x :: l ->
        if p x then (x, i) else aux p (i + 1) l
  in
  aux p 0

exception Pair_of_list

let pair_of_list = function [a; b] -> (a, b) | _ -> raise Pair_of_list
src/proto_alpha/lib_protocol/test/helpers/test_utils.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_gt_gt_question_eq {A B : Type}
  (x : sum A (list Tezos_base__TzPervasives.error))
  (y : A -> Lwt.t (Tezos_base__TzPervasives.tzresult B))
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  match x with
  | inl a => y a
  | inr b =>
    apply Tezos_base__TzPervasives.fail (Tezos_base__TzPervasives.List.hd b)
  end.

Definition findi {A : Type} (p : A -> bool) : (list A) -> A * Z :=
  let fix aux {B : Type} (p : B -> bool) (i : Z) (function_parameter : list B)
    : B * Z :=
    match function_parameter with
    | [] => Stdlib.raise OCaml.Not_found
    | cons x l =>
      if p x then
        (x, i)
      else
        aux p (Z.add i 1) l
    end in
  aux p 0.

Definition pair_of_list {A : Type} (function_parameter : list A) : A * A :=
  match function_parameter with
  | cons a (cons b []) => (a, b)
  | _ => Stdlib.raise Pair_of_list
  end.
src/proto_alpha/lib_protocol/test/main.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Alcotest.run
    "protocol_alpha"
    [ ("transfer", Transfer.tests);
      ("origination", Origination.tests);
      ("activation", Activation.tests);
      ("endorsement", Endorsement.tests);
      ("double endorsement", Double_endorsement.tests);
      ("double baking", Double_baking.tests);
      ("seed", Seed.tests);
      ("baking", Baking.tests);
      ("delegation", Delegation.tests);
      ("rolls", Rolls.tests);
      ("combined", Combined_operations.tests);
      ("qty", Qty.tests);
      ("voting", Voting.tests) ]
src/proto_alpha/lib_protocol/test/main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/proto_alpha/lib_protocol/test/origination.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Test_utils
open Test_tez

let ten_tez = Tez.of_int 10

(** [register_origination fee credit spendable delegatable] takes four
    optional parameter: fee for the fee need to be paid if set to
    create an originated contract; credit is the amount of tez that
    send to this originated contract; spendable default is set to true
    meaning that this contract is spendable; delegatable default is
    set to true meaning that this contract is able to delegate. *)
let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let source = List.hd contracts in
  Context.Contract.balance (B b) source
  >>=? fun source_balance ->
  Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script
  >>=? fun (operation, originated) ->
  Block.bake ~operation b
  >>=? fun b ->
  (* fee + credit + block security deposit were debited from source *)
  Context.get_constants (B b)
  >>=? fun { parametric =
               {origination_size; cost_per_byte; block_security_deposit; _};
             _ } ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Lwt.return
    ( Tez.( +? ) credit block_security_deposit
    >>? Tez.( +? ) fee
    >>? Tez.( +? ) origination_burn
    >>? Tez.( +? ) Op.dummy_script_cost )
  >>=? fun total_fee ->
  Assert.balance_was_debited ~loc:__LOC__ (B b) source source_balance total_fee
  >>=? fun () ->
  (* originated contract has been credited *)
  Assert.balance_was_credited ~loc:__LOC__ (B b) originated Tez.zero credit
  >>=? fun () ->
  (* TODO spendable or not and delegatable or not if relevant for some
     test. Not the case at the moment, cf. uses of
     register_origination *)
  return (b, source, originated)

(* [test_origination_balances fee credit spendable delegatable]
   takes four optional parameter: fee is the fee that pay if require to create
   an originated contract; credit is the amount of tez that will send to this
   contract; delegatable default is set to true meaning that this contract is
   able to delegate.
   This function will create a contract, get the balance of this contract, call
   the origination operation to create a new originated contract from this
   contract with all the possible fees; and check the balance before/after
   originated operation valid.
   - the source contract has payed all the fees
   - the originated has been credited correctly *)
let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) ()
    =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.hd contracts in
  Context.Contract.balance (B b) contract
  >>=? fun balance ->
  Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script
  >>=? fun (operation, new_contract) ->
  (* The possible fees are: a given credit, an origination burn fee
     (constants_repr.default.origination_burn = 257 mtez),
     a fee that is paid when creating an originate contract.

     We also take into account a block security deposit. Note that it
     is not related to origination but to the baking done in the
     tests.*)
  Context.get_constants (B b)
  >>=? fun { parametric =
               {origination_size; cost_per_byte; block_security_deposit; _};
             _ } ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Lwt.return
    ( Tez.( +? ) credit block_security_deposit
    >>? Tez.( +? ) fee
    >>? Tez.( +? ) origination_burn
    >>? Tez.( +? ) Op.dummy_script_cost )
  >>=? fun total_fee ->
  Block.bake ~operation b
  >>=? fun b ->
  (* check that after the block has been baked the source contract
     was debited all the fees *)
  Assert.balance_was_debited ~loc:__LOC__ (B b) contract balance total_fee
  >>=? fun _ ->
  (* check the balance of the originate contract is equal to credit *)
  Assert.balance_is ~loc:__LOC__ (B b) new_contract credit

(******************************************************)
(** Tests *)

(******************************************************)

(** compute half of the balance and divided it by nth times *)

let two_nth_of_balance incr contract nth =
  Context.Contract.balance (I incr) contract
  >>=? fun balance ->
  Tez.( /? ) balance nth
  >>?= fun res -> Tez.( *? ) res 2L >>?= fun balance -> return balance

(*******************)
(** Basic test *)

(*******************)

let balances_simple () = test_origination_balances ~loc:__LOC__ ()

let balances_credit () =
  test_origination_balances ~loc:__LOC__ ~credit:ten_tez ()

let balances_credit_fee () =
  test_origination_balances ~loc:__LOC__ ~credit:(Tez.of_int 2) ~fee:ten_tez ()

let balances_undelegatable () = test_origination_balances ~loc:__LOC__ ()

(*******************)
(** ask source contract to pay a fee when originating a contract *)

(*******************)

let pay_fee () =
  register_origination ~credit:(Tez.of_int 2) ~fee:ten_tez ()
  >>=? fun (_b, _contract, _new_contract) -> return_unit

(******************************************************)
(** Errors *)

(******************************************************)

(*******************)
(** create an originate contract where the contract
    does not have enough tez to pay for the fee *)

(*******************)

let not_tez_in_contract_to_pay_fee () =
  Context.init 2
  >>=? fun (b, contracts) ->
  let contract_1 = List.nth contracts 0 in
  let contract_2 = List.nth contracts 1 in
  Incremental.begin_construction b
  >>=? fun inc ->
  (* transfer everything but one tez from 1 to 2 and check balance of 1 *)
  Context.Contract.balance (I inc) contract_1
  >>=? fun balance ->
  Lwt.return @@ Tez.( -? ) balance Tez.one
  >>=? fun amount ->
  Op.transaction (I inc) contract_1 contract_2 amount
  >>=? fun operation ->
  Incremental.add_operation inc operation
  >>=? fun inc ->
  Assert.balance_was_debited ~loc:__LOC__ (I inc) contract_1 balance amount
  >>=? fun _ ->
  (* use this source contract to create an originate contract where it requires
     to pay a fee and add an amount of credit into this new contract *)
  Op.origination
    (I inc)
    ~fee:ten_tez
    ~credit:Tez.one
    contract_1
    ~script:Op.dummy_script
  >>=? fun (op, _) ->
  Incremental.add_operation inc op
  >>= fun inc ->
  Assert.proto_error ~loc:__LOC__ inc (function
      | Contract_storage.Balance_too_low _ ->
          true
      | _ ->
          false)

(***************************************************)
(* set the endorser of the block as manager/delegate of the originated
   account *)
(***************************************************)

let register_contract_get_endorser () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.hd contracts in
  Incremental.begin_construction b
  >>=? fun inc ->
  Context.get_endorser (I inc)
  >>=? fun (account_endorser, _slots) ->
  return (inc, contract, account_endorser)

(*******************)
(** create multiple originated contracts and
    ask contract to pay the fee *)

(*******************)

let n_originations n ?credit ?fee () =
  fold_left_s
    (fun new_contracts _ ->
      register_origination ?fee ?credit ()
      >>=? fun (_b, _source, new_contract) ->
      let contracts = new_contract :: new_contracts in
      return contracts)
    []
    (1 -- n)

let multiple_originations () =
  n_originations 100 ~credit:(Tez.of_int 2) ~fee:ten_tez ()
  >>=? fun contracts ->
  Assert.equal_int ~loc:__LOC__ (List.length contracts) 100

(*******************)
(** cannot originate two contracts with the same context's counter *)

(*******************)

let counter () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.hd contracts in
  Incremental.begin_construction b
  >>=? fun inc ->
  Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script
  >>=? fun (op1, _) ->
  Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script
  >>=? fun (op2, _) ->
  Incremental.add_operation inc op1
  >>=? fun inc ->
  Incremental.add_operation inc op2
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Contract_storage.Counter_in_the_past _ ->
          true
      | _ ->
          false)

(******************************************************)

let tests =
  [ Test.tztest "balances_simple" `Quick balances_simple;
    Test.tztest "balances_credit" `Quick balances_credit;
    Test.tztest "balances_credit_fee" `Quick balances_credit_fee;
    Test.tztest "balances_undelegatable" `Quick balances_undelegatable;
    Test.tztest "pay_fee" `Quick pay_fee;
    Test.tztest
      "not enough tez in contract to pay fee"
      `Quick
      not_tez_in_contract_to_pay_fee;
    Test.tztest "multiple originations" `Quick multiple_originations;
    Test.tztest "counter" `Quick counter ]
src/proto_alpha/lib_protocol/test/origination.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition ten_tez {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star 10.

Definition register_origination {A B C : Type} (op_star_o_p_t_star : option A)
  : (option B) ->
    unit ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  let fee :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => op_star_t_y_p_e_minus_e_r_r_o_r_star
    end in
  fun op_star_o_p_t_star =>
    let credit :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => op_star_t_y_p_e_minus_e_r_r_o_r_star
      end in
    fun function_parameter =>
      match function_parameter with
      | tt =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
          (fun function_parameter =>
            match function_parameter with
            | (b, contracts) =>
              let source :=
                Tezos_protocol_environment_alpha__Environment.List.hd contracts
                in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star source)
                (fun source_balance =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star source fee credit
                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                    (fun function_parameter =>
                      match function_parameter with
                      | (operation, originated) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star operation b)
                          (fun b =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (fun origination_burn =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  credit
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  fee))
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                origination_burn))
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)))
                                        (fun total_fee =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              source source_balance total_fee)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    originated
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    credit)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                        (b, source, originated)
                                                    end)
                                              end)))
                                end))
                      end))
            end)
      end.

Definition test_origination_balances {A B C D : Type} (function_parameter : A)
  : (option B) ->
    (option C) ->
      unit ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
  match function_parameter with
  | _ =>
    fun op_star_o_p_t_star =>
      let fee :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => op_star_t_y_p_e_minus_e_r_r_o_r_star
        end in
      fun op_star_o_p_t_star =>
        let credit :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => op_star_t_y_p_e_minus_e_r_r_o_r_star
          end in
        fun function_parameter =>
          match function_parameter with
          | tt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
              (fun function_parameter =>
                match function_parameter with
                | (b, contracts) =>
                  let contract :=
                    Tezos_protocol_environment_alpha__Environment.List.hd
                      contracts in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star contract)
                    (fun balance =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star contract fee
                          credit op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (fun function_parameter =>
                          match function_parameter with
                          | (operation, new_contract) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (fun origination_burn =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Lwt._return
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  credit
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  fee))
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                origination_burn))
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)))
                                        (fun total_fee =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              operation b)
                                            (fun b =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  contract balance total_fee)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | _ =>
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      new_contract credit
                                                  end))))
                                end)
                          end))
                end)
          end
  end.

Definition two_nth_of_balance {A B C D : Type}
  (incr : A) (contract : B) (nth : C)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
      contract)
    (fun balance =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (op_star_t_y_p_e_minus_e_r_r_o_r_star balance nth)
        (fun res =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (op_star_t_y_p_e_minus_e_r_r_o_r_star res 2)
            (fun balance =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                balance))).

Definition balances_simple {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    test_origination_balances
      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__ None None
      tt
  end.

Definition balances_credit {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    test_origination_balances
      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__ None
      (Some ten_tez) tt
  end.

Definition balances_credit_fee {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    test_origination_balances
      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
      (Some ten_tez) (Some (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)) tt
  end.

Definition balances_undelegatable {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    test_origination_balances
      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__ None None
      tt
  end.

Definition pay_fee (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (register_origination (Some ten_tez)
        (Some (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)) tt)
      (fun function_parameter =>
        match function_parameter with
        | (_b, _contract, _new_contract) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
        end)
  end.

Definition not_tez_in_contract_to_pay_fee {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contract_1 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let contract_2 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun inc =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1)
                (fun balance =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star balance
                        op_star_t_y_p_e_minus_e_r_r_o_r_star))
                    (fun amount =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1
                          contract_2 amount)
                        (fun operation =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star inc operation)
                            (fun inc =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  contract_1 balance amount)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | _ =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        ten_tez
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        contract_1
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (op, _) =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              inc op)
                                            (fun inc =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                inc
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  |
                                                    Contract_storage.Balance_too_low
                                                      _ _ _ => true
                                                  | _ => false
                                                  end))
                                        end)
                                  end))))))
        end)
  end.

Definition register_contract_get_endorser {A B C : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A * B * C)) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contract :=
            Tezos_protocol_environment_alpha__Environment.List.hd contracts in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun inc =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | (account_endorser, _slots) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad._return
                      (inc, contract, account_endorser)
                  end))
        end)
  end.

Definition n_originations {A B C D : Type}
  (n : A) (credit : option B) (fee : option C) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list D)) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
      (fun new_contracts =>
        fun function_parameter =>
          match function_parameter with
          | _ =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (register_origination fee credit tt)
              (fun function_parameter =>
                match function_parameter with
                | (_b, _source, new_contract) =>
                  let contracts := cons new_contract new_contracts in
                  Tezos_protocol_environment_alpha__Environment.Error_monad._return
                    contracts
                end)
          end) [] (op_star_t_y_p_e_minus_e_r_r_o_r_star 1 n)
  end.

Definition multiple_originations {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (n_originations 100 (Some (op_star_t_y_p_e_minus_e_r_r_o_r_star 2))
        (Some ten_tez) tt)
      (fun contracts =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star
          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
          (Tezos_protocol_environment_alpha__Environment.List.length contracts)
          100)
  end.

Definition counter {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contract :=
            Tezos_protocol_environment_alpha__Environment.List.hd contracts in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun inc =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star contract
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | (op1, _) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star contract
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (fun function_parameter =>
                        match function_parameter with
                        | (op2, _) =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star inc op1)
                            (fun inc =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star inc op2)
                                (fun res =>
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    res
                                    (fun function_parameter =>
                                      match function_parameter with
                                      |
                                        Contract_storage.Counter_in_the_past _ _
                                          _ => true
                                      | _ => false
                                      end)))
                        end)
                  end))
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "balances_simple" % string variant
      balances_simple)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star "balances_credit" % string variant
        balances_credit)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star "balances_credit_fee" % string
          variant balances_credit_fee)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "balances_undelegatable" % string variant balances_undelegatable)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star "pay_fee" % string variant
              pay_fee)
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "not enough tez in contract to pay fee" % string variant
                not_tez_in_contract_to_pay_fee)
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "multiple originations" % string variant multiple_originations)
                (cons
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star "counter" % string
                    variant counter) []))))))).
src/proto_alpha/lib_protocol/test/qty.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let known_ok_tez_literals =
  [ (0L, "0");
    (10L, "0.00001");
    (100L, "0.0001");
    (1_000L, "0.001");
    (10_000L, "0.01");
    (100_000L, "0.1");
    (1_000_000L, "1");
    (10_000_000L, "10");
    (100_000_000L, "100");
    (1_000_000_000L, "1000");
    (10_000_000_000L, "10000");
    (100_000_000_000L, "100000");
    (1_000_000_000_000L, "1000000");
    (1_000_000_000_001L, "1000000.000001");
    (1_000_000_000_010L, "1000000.00001");
    (1_000_000_000_100L, "1000000.0001");
    (1_000_000_001_000L, "1000000.001");
    (1_000_000_010_000L, "1000000.01");
    (1_000_000_100_000L, "1000000.1");
    (123_123_123_123_123_123L, "123123123123.123123");
    (999_999_999_999_999_999L, "999999999999.999999") ]

let known_bad_tez_literals =
  [ "10000.";
    "100,.";
    "100,";
    "1,0000";
    "0.0000,1";
    "0.00,1";
    "0,1";
    "HAHA";
    "0.000,000,1";
    "0.0000000";
    "9,999,999,999,999.999,999" ]

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg

let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg

let is_some ?(msg = "") x = if x = None then fail "Some _" "None" msg

let test_known_tez_literals () =
  List.iter
    (fun (v, s) ->
      let vv = Tez_repr.of_mutez v in
      let vs = Tez_repr.of_string s in
      let vs' =
        Tez_repr.of_string (String.concat "" (String.split_on_char ',' s))
      in
      let vv =
        match vv with
        | None ->
            fail_msg "could not unopt %Ld" v
        | Some vv ->
            vv
      in
      let vs =
        match vs with None -> fail_msg "could not unopt %s" s | Some vs -> vs
      in
      let vs' =
        match vs' with
        | None ->
            fail_msg "could not unopt %s" s
        | Some vs' ->
            vs'
      in
      equal ~prn:Tez_repr.to_string vv vs ;
      equal ~prn:Tez_repr.to_string vv vs' ;
      equal ~prn:(fun s -> s) (Tez_repr.to_string vv) s)
    known_ok_tez_literals ;
  List.iter
    (fun s ->
      let vs = Tez_repr.of_string s in
      is_none ~msg:("Unexpected successful parsing of " ^ s) vs)
    known_bad_tez_literals ;
  return_unit

let test_random_tez_literals () =
  for _ = 0 to 100_000 do
    let v = Random.int64 12L in
    let vv = Tez_repr.of_mutez v in
    let vv =
      match vv with None -> fail_msg "could not unopt %Ld" v | Some vv -> vv
    in
    let s = Tez_repr.to_string vv in
    let vs = Tez_repr.of_string s in
    let s' = String.concat "" (String.split_on_char ',' s) in
    let vs' = Tez_repr.of_string s' in
    is_some ~msg:("Could not parse " ^ s ^ " back") vs ;
    is_some ~msg:("Could not parse " ^ s ^ " back") vs' ;
    ( match vs with
    | None ->
        assert false
    | Some vs ->
        let rev = Tez_repr.to_int64 vs in
        equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev ) ;
    match vs' with
    | None ->
        assert false
    | Some vs' ->
        let rev = Tez_repr.to_int64 vs' in
        equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev
  done ;
  return_unit

let tests =
  [ ("tez-literals", fun _ -> test_known_tez_literals ());
    ("rnd-tez-literals", fun _ -> test_random_tez_literals ()) ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let tests = List.map wrap tests
src/proto_alpha/lib_protocol/test/qty.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition known_ok_tez_literals : list (int64 * string) :=
  cons (0, "0" % string)
    (cons (10, "0.00001" % string)
      (cons (100, "0.0001" % string)
        (cons (1000, "0.001" % string)
          (cons (10000, "0.01" % string)
            (cons (100000, "0.1" % string)
              (cons (1000000, "1" % string)
                (cons (10000000, "10" % string)
                  (cons (100000000, "100" % string)
                    (cons (1000000000, "1000" % string)
                      (cons (10000000000, "10000" % string)
                        (cons (100000000000, "100000" % string)
                          (cons (1000000000000, "1000000" % string)
                            (cons (1000000000001, "1000000.000001" % string)
                              (cons (1000000000010, "1000000.00001" % string)
                                (cons (1000000000100, "1000000.0001" % string)
                                  (cons (1000000001000, "1000000.001" % string)
                                    (cons (1000000010000, "1000000.01" % string)
                                      (cons
                                        (1000000100000, "1000000.1" % string)
                                        (cons
                                          (123123123123123123,
                                            "123123123123.123123" % string)
                                          (cons
                                            (999999999999999999,
                                              "999999999999.999999" % string) [])))))))))))))))))))).

Definition known_bad_tez_literals : list string :=
  cons "10000." % string
    (cons "100,." % string
      (cons "100," % string
        (cons "1,0000" % string
          (cons "0.0000,1" % string
            (cons "0.00,1" % string
              (cons "0,1" % string
                (cons "HAHA" % string
                  (cons "0.000,000,1" % string
                    (cons "0.0000000" % string
                      (cons "9,999,999,999,999.999,999" % string [])))))))))).

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Tezos_protocol_environment_alpha__Environment.Format.kasprintf
    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt :
    Tezos_protocol_environment_alpha__Environment.Pervasives.format4 A
      Tezos_protocol_environment_alpha__Environment.Format.formatter unit B)
  : A :=
  Tezos_protocol_environment_alpha__Environment.Format.kasprintf
    (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  match function_parameter with
  | _ => "" % string
  end.

Definition equal {A : Type} (op_star_o_p_t_star : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => op_star_t_y_p_e_minus_e_r_r_o_r_star
    end in
  fun op_star_o_p_t_star =>
    let prn :=
      match op_star_o_p_t_star with
      | Some op_star_s_t_h_star => op_star_s_t_h_star
      | None => default_printer
      end in
    fun op_star_o_p_t_star =>
      let msg :=
        match op_star_o_p_t_star with
        | Some op_star_s_t_h_star => op_star_s_t_h_star
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if
            Tezos_protocol_environment_alpha__Environment.Pervasives.not
              (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

Definition is_none {A : Type} (op_star_o_p_t_star : option string)
  : A -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    if op_star_t_y_p_e_minus_e_r_r_o_r_star x None then
      fail "None" % string "Some _" % string msg
    else
      tt.

Definition is_some {A : Type} (op_star_o_p_t_star : option string)
  : A -> unit :=
  let msg :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => "" % string
    end in
  fun x =>
    if op_star_t_y_p_e_minus_e_r_r_o_r_star x None then
      fail "Some _" % string "None" % string msg
    else
      tt.

Definition test_known_tez_literals (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.List.iter
      (fun function_parameter =>
        match function_parameter with
        | (v, s) =>
          let vv := Tezos_protocol_alpha.Protocol.Tez_repr.of_mutez v in
          let vs := Tezos_protocol_alpha.Protocol.Tez_repr.of_string s in
          let vs' :=
            Tezos_protocol_alpha.Protocol.Tez_repr.of_string
              (Tezos_protocol_environment_alpha__Environment.String.concat
                "" % string
                (Tezos_protocol_environment_alpha__Environment.String.split_on_char
                  "," % char s)) in
          let vv :=
            match vv with
            | None =>
              fail_msg
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "could not unopt " % string
                    (CamlinternalFormatBasics.Int64
                      CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format))
                  "could not unopt %Ld" % string) v
            | Some vv => vv
            end in
          let vs :=
            match vs with
            | None =>
              fail_msg
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "could not unopt " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "could not unopt %s" % string) s
            | Some vs => vs
            end in
          let vs' :=
            match vs' with
            | None =>
              fail_msg
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "could not unopt " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "could not unopt %s" % string) s
            | Some vs' => vs'
            end in
          equal None (Some Tezos_protocol_alpha.Protocol.Tez_repr.to_string)
            None vv vs;
          equal None (Some Tezos_protocol_alpha.Protocol.Tez_repr.to_string)
            None vv vs';
          equal None (Some (fun s => s)) None
            (Tezos_protocol_alpha.Protocol.Tez_repr.to_string vv) s
        end) known_ok_tez_literals;
    Tezos_protocol_environment_alpha__Environment.List.iter
      (fun s =>
        let vs := Tezos_protocol_alpha.Protocol.Tez_repr.of_string s in
        is_none
          (Some
            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_caret
              "Unexpected successful parsing of " % string s)) vs)
      known_bad_tez_literals;
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  end.

Definition test_random_tez_literals (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    for;
    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
  end.

Definition tests {A : Type}
  : list
    (string *
      (A ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            unit))) :=
  cons
    ("tez-literals" % string,
      (fun function_parameter =>
        match function_parameter with
        | _ => test_known_tez_literals tt
        end))
    (cons
      ("rnd-tez-literals" % string,
        (fun function_parameter =>
          match function_parameter with
          | _ => test_random_tez_literals tt
          end)) []).

Definition wrap {A B C : Type}
  (function_parameter :
    A *
      (unit ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Pervasives.result unit
            B))) : C :=
  match function_parameter with
  | (n, f) =>
    op_star_t_y_p_e_minus_e_r_r_o_r_star n variant
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                (f tt)
                (fun function_parameter =>
                  match function_parameter with
                  | inl tt =>
                    Tezos_protocol_environment_alpha__Environment.Lwt.return_unit
                  | inr error =>
                    Tezos_protocol_environment_alpha__Environment.Format.kasprintf
                      Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format) "%a" % string)
                      op_star_t_y_p_e_minus_e_r_r_o_r_star error
                  end)
            end
        end)
  end.

Definition tests {A : Type} : list A :=
  Tezos_protocol_environment_alpha__Environment.List.map wrap tests.
src/proto_alpha/lib_protocol/test/rolls.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Test_tez
open Test_utils

let account_pair = function [a1; a2] -> (a1, a2) | _ -> assert false

let wrap e = Lwt.return (Environment.wrap_error e)

let traverse_rolls ctxt head =
  let rec loop acc roll =
    Storage.Roll.Successor.get_option ctxt roll
    >>= wrap
    >>=? function
    | None -> return (List.rev acc) | Some next -> loop (next :: acc) next
  in
  loop [head] head

let get_rolls ctxt delegate =
  Storage.Roll.Delegate_roll_list.get_option ctxt delegate
  >>= wrap
  >>=? function
  | None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll

let check_rolls b (account : Account.t) =
  Context.get_constants (B b)
  >>=? fun constants ->
  Context.Delegate.info (B b) account.pkh
  >>=? fun {staking_balance; _} ->
  let token_per_roll = constants.parametric.tokens_per_roll in
  let expected_rolls =
    Int64.div (Tez.to_mutez staking_balance) (Tez.to_mutez token_per_roll)
  in
  Raw_context.prepare
    b.context
    ~level:b.header.shell.level
    ~predecessor_timestamp:b.header.shell.timestamp
    ~timestamp:b.header.shell.timestamp
    ~fitness:b.header.shell.fitness
  >>= wrap
  >>=? fun ctxt ->
  get_rolls ctxt account.pkh
  >>=? fun rolls ->
  Assert.equal_int
    ~loc:__LOC__
    (List.length rolls)
    (Int64.to_int expected_rolls)

let check_no_rolls (b : Block.t) (account : Account.t) =
  Raw_context.prepare
    b.context
    ~level:b.header.shell.level
    ~predecessor_timestamp:b.header.shell.timestamp
    ~timestamp:b.header.shell.timestamp
    ~fitness:b.header.shell.fitness
  >>= wrap
  >>=? fun ctxt ->
  get_rolls ctxt account.pkh
  >>=? fun rolls -> Assert.equal_int ~loc:__LOC__ (List.length rolls) 0

let simple_staking_rights () =
  Context.init 2
  >>=? fun (b, accounts) ->
  let (a1, _a2) = account_pair accounts in
  Context.Contract.balance (B b) a1
  >>=? fun balance ->
  Context.Contract.manager (B b) a1
  >>=? fun m1 ->
  Context.Delegate.info (B b) m1.pkh
  >>=? fun info ->
  Assert.equal_tez ~loc:__LOC__ balance info.staking_balance
  >>=? fun () -> check_rolls b m1

let simple_staking_rights_after_baking () =
  Context.init 2
  >>=? fun (b, accounts) ->
  let (a1, a2) = account_pair accounts in
  Context.Contract.balance (B b) a1
  >>=? fun balance ->
  Context.Contract.manager (B b) a1
  >>=? fun m1 ->
  Context.Contract.manager (B b) a2
  >>=? fun m2 ->
  Block.bake_n ~policy:(By_account m2.pkh) 5 b
  >>=? fun b ->
  Context.Delegate.info (B b) m1.pkh
  >>=? fun info ->
  Assert.equal_tez ~loc:__LOC__ balance info.staking_balance
  >>=? fun () -> check_rolls b m1 >>=? fun () -> check_rolls b m2

let frozen_deposit (info : Context.Delegate.info) =
  Cycle.Map.fold
    (fun _ {Delegate.deposit; _} acc -> Test_tez.Tez.(deposit + acc))
    info.frozen_balance_by_cycle
    Tez.zero

let check_activate_staking_balance ~loc ~deactivated b (a, (m : Account.t)) =
  Context.Delegate.info (B b) m.pkh
  >>=? fun info ->
  Assert.equal_bool ~loc info.deactivated deactivated
  >>=? fun () ->
  Context.Contract.balance (B b) a
  >>=? fun balance ->
  let deposit = frozen_deposit info in
  Assert.equal_tez ~loc Test_tez.Tez.(balance + deposit) info.staking_balance

let run_until_deactivation () =
  Context.init 2
  >>=? fun (b, accounts) ->
  let (a1, a2) = account_pair accounts in
  Context.Contract.balance (B b) a1
  >>=? fun balance_start ->
  Context.Contract.manager (B b) a1
  >>=? fun m1 ->
  Context.Contract.manager (B b) a2
  >>=? fun m2 ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a1, m1)
  >>=? fun () ->
  Context.Delegate.info (B b) m1.pkh
  >>=? fun info ->
  Block.bake_until_cycle ~policy:(By_account m2.pkh) info.grace_period b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a1, m1)
  >>=? fun () ->
  Block.bake_until_cycle_end ~policy:(By_account m2.pkh) b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:true b (a1, m1)
  >>=? fun () -> return (b, ((a1, m1), balance_start), (a2, m2))

let deactivation_then_bake () =
  run_until_deactivation ()
  >>=? fun ( b,
             ( ((_deactivated_contract, deactivated_account) as deactivated),
               _start_balance ),
             (_a2, _m2) ) ->
  Block.bake ~policy:(By_account deactivated_account.pkh) b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
  >>=? fun () -> check_rolls b deactivated_account

let deactivation_then_self_delegation () =
  run_until_deactivation ()
  >>=? fun ( b,
             ( ((deactivated_contract, deactivated_account) as deactivated),
               start_balance ),
             (_a2, m2) ) ->
  Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
  >>=? fun self_delegation ->
  Block.bake ~policy:(By_account m2.pkh) b ~operation:self_delegation
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
  >>=? fun () ->
  Context.Contract.balance (B b) deactivated_contract
  >>=? fun balance ->
  Assert.equal_tez ~loc:__LOC__ start_balance balance
  >>=? fun () -> check_rolls b deactivated_account

let deactivation_then_empty_then_self_delegation () =
  run_until_deactivation ()
  >>=? fun ( b,
             ( ((deactivated_contract, deactivated_account) as deactivated),
               _start_balance ),
             (_a2, m2) ) ->
  (* empty the contract *)
  Context.Contract.balance (B b) deactivated_contract
  >>=? fun balance ->
  let sink_account = Account.new_account () in
  let sink_contract = Contract.implicit_contract sink_account.pkh in
  Context.get_constants (B b)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  let amount =
    match Tez.(balance -? origination_burn) with
    | Ok r ->
        r
    | Error _ ->
        assert false
  in
  Op.transaction (B b) deactivated_contract sink_contract amount
  >>=? fun empty_contract ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b
  >>=? fun b ->
  (* self delegation *)
  Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
  >>=? fun self_delegation ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
  >>=? fun () ->
  Context.Contract.balance (B b) deactivated_contract
  >>=? fun balance ->
  Assert.equal_tez ~loc:__LOC__ Tez.zero balance
  >>=? fun () -> check_rolls b deactivated_account

let deactivation_then_empty_then_self_delegation_then_recredit () =
  run_until_deactivation ()
  >>=? fun ( b,
             ( ((deactivated_contract, deactivated_account) as deactivated),
               balance ),
             (_a2, m2) ) ->
  (* empty the contract *)
  let sink_account = Account.new_account () in
  let sink_contract = Contract.implicit_contract sink_account.pkh in
  Context.get_constants (B b)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  let amount =
    match Tez.(balance -? origination_burn) with
    | Ok r ->
        r
    | Error _ ->
        assert false
  in
  Op.transaction (B b) deactivated_contract sink_contract amount
  >>=? fun empty_contract ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b
  >>=? fun b ->
  (* self delegation *)
  Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
  >>=? fun self_delegation ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b
  >>=? fun b ->
  (* recredit *)
  Op.transaction (B b) sink_contract deactivated_contract amount
  >>=? fun recredit_contract ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:recredit_contract b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
  >>=? fun () ->
  Context.Contract.balance (B b) deactivated_contract
  >>=? fun balance ->
  Assert.equal_tez ~loc:__LOC__ amount balance
  >>=? fun () -> check_rolls b deactivated_account

let delegation () =
  Context.init 2
  >>=? fun (b, accounts) ->
  let (a1, a2) = account_pair accounts in
  let m3 = Account.new_account () in
  Account.add_account m3 ;
  Context.Contract.manager (B b) a1
  >>=? fun m1 ->
  Context.Contract.manager (B b) a2
  >>=? fun m2 ->
  let a3 = Contract.implicit_contract m3.pkh in
  Context.Contract.delegate_opt (B b) a1
  >>=? fun delegate ->
  ( match delegate with
  | None ->
      assert false
  | Some pkh ->
      assert (Signature.Public_key_hash.equal pkh m1.pkh) ) ;
  Op.transaction (B b) a1 a3 Tez.fifty_cents
  >>=? fun transact ->
  Block.bake ~policy:(By_account m2.pkh) b ~operation:transact
  >>=? fun b ->
  Context.Contract.delegate_opt (B b) a3
  >>=? fun delegate ->
  (match delegate with None -> () | Some _ -> assert false) ;
  check_no_rolls b m3
  >>=? fun () ->
  Op.delegation (B b) a3 (Some m3.pkh)
  >>=? fun delegation ->
  Block.bake ~policy:(By_account m2.pkh) b ~operation:delegation
  >>=? fun b ->
  Context.Contract.delegate_opt (B b) a3
  >>=? fun delegate ->
  ( match delegate with
  | None ->
      assert false
  | Some pkh ->
      assert (Signature.Public_key_hash.equal pkh m3.pkh) ) ;
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a3, m3)
  >>=? fun () -> check_rolls b m3 >>=? fun () -> check_rolls b m1

let tests =
  [ Test.tztest "simple staking rights" `Quick simple_staking_rights;
    Test.tztest
      "simple staking rights after baking"
      `Quick
      simple_staking_rights_after_baking;
    Test.tztest "deactivation then bake" `Quick deactivation_then_bake;
    Test.tztest
      "deactivation then self delegation"
      `Quick
      deactivation_then_self_delegation;
    Test.tztest
      "deactivation then empty then self delegation"
      `Quick
      deactivation_then_empty_then_self_delegation;
    Test.tztest
      "deactivation then empty then self delegation then recredit"
      `Quick
      deactivation_then_empty_then_self_delegation_then_recredit;
    Test.tztest "delegation" `Quick delegation ]
src/proto_alpha/lib_protocol/test/rolls.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition account_pair {A : Type} (function_parameter : list A) : A * A :=
  match function_parameter with
  | cons a1 (cons a2 []) => (a1, a2)
  | _ => false
  end.

Definition wrap {A : Type}
  (e : Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_base__TzPervasives.Error_monad.tzresult A) :=
  Tezos_protocol_environment_alpha__Environment.Lwt._return
    (Tezos_protocol_alpha.Protocol.Environment.wrap_error e).

Definition traverse_rolls
  (ctxt : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.context)
  (head : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
  let fix loop
    (acc : list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)
    (roll : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      op_star_t_y_p_e_minus_e_r_r_o_r_star
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (Tezos_protocol_environment_alpha__Environment.List.rev acc)
        | Some next => loop (cons next acc) next
        end) in
  loop (cons head []) head.

Definition get_rolls
  (ctxt : Tezos_protocol_alpha.Protocol.Storage.Roll.Delegate_roll_list.context)
  (delegate : Tezos_protocol_alpha.Protocol.Storage.Roll.Delegate_roll_list.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    op_star_t_y_p_e_minus_e_r_r_o_r_star
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.return_nil
      | Some head_roll => traverse_rolls ctxt head_roll
      end).

Definition check_rolls {A B : Type} (b : A) (function_parameter : B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star)
      (fun constants =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            op_star_t_y_p_e_minus_e_r_r_o_r_star
            (pkh op_star_t_y_p_e_minus_e_r_r_o_r_star))
          (fun function_parameter =>
            match function_parameter with
            | _ =>
              let token_per_roll := tokens_per_roll (parametric constants) in
              let expected_rolls :=
                Tezos_protocol_environment_alpha__Environment.Int64.div
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.to_mutez
                    token_per_roll) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                (fun ctxt =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (get_rolls ctxt (pkh op_star_t_y_p_e_minus_e_r_r_o_r_star))
                    (fun rolls =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                        (Tezos_protocol_environment_alpha__Environment.List.length
                          rolls)
                        (Tezos_protocol_environment_alpha__Environment.Int64.to_int
                          expected_rolls)))
            end))
  end.

Definition check_no_rolls {A B : Type} (function_parameter : A)
  : B ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          op_star_t_y_p_e_minus_e_r_r_o_r_star
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (get_rolls ctxt (pkh op_star_t_y_p_e_minus_e_r_r_o_r_star))
              (fun rolls =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                  (Tezos_protocol_environment_alpha__Environment.List.length
                    rolls) 0))
      end
  end.

Definition simple_staking_rights (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, accounts) =>
          match account_pair accounts with
          | (a1, _a2) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star a1)
              (fun balance =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star a1)
                  (fun m1 =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star (pkh m1))
                      (fun info =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                            balance (staking_balance info))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt => check_rolls b m1
                            end))))
          end
        end)
  end.

Definition simple_staking_rights_after_baking (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, accounts) =>
          match account_pair accounts with
          | (a1, a2) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star a1)
              (fun balance =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star a1)
                  (fun m1 =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star a2)
                      (fun m2 =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star 5 b)
                          (fun b =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star (pkh m1))
                              (fun info =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    balance (staking_balance info))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (check_rolls b m1)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt => check_rolls b m2
                                          end)
                                    end))))))
          end
        end)
  end.

Definition frozen_deposit {A : Type} (function_parameter : A)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
  match function_parameter with
  | _ =>
    Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.Map.fold
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun function_parameter =>
            match function_parameter with
            | {| Delegate.deposit := deposit |} =>
              fun acc => op_star_t_y_p_e_minus_e_r_r_o_r_star
            end
        end) (frozen_balance_by_cycle op_star_t_y_p_e_minus_e_r_r_o_r_star)
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
  end.

Definition check_activate_staking_balance {A B : Type}
  (loc : string) (deactivated : bool) (b : A)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
        (pkh op_star_t_y_p_e_minus_e_r_r_o_r_star))
      (fun info =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star loc (deactivated info)
            deactivated)
          (fun function_parameter =>
            match function_parameter with
            | tt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star a)
                (fun balance =>
                  let deposit := frozen_deposit info in
                  op_star_t_y_p_e_minus_e_r_r_o_r_star loc
                    op_star_t_y_p_e_minus_e_r_r_o_r_star (staking_balance info))
            end))
  end.

Definition run_until_deactivation {A B C D : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A *
        ((Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * B) * C)
        * (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * D))) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, accounts) =>
          match account_pair accounts with
          | (a1, a2) =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star a1)
              (fun balance_start =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star a1)
                  (fun m1 =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star a2)
                      (fun m2 =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (check_activate_staking_balance
                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                            false b (a1, m1))
                          (fun function_parameter =>
                            match function_parameter with
                            | tt =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star (pkh m1))
                                (fun info =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (grace_period info) b)
                                    (fun b =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (check_activate_staking_balance
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                          false b (a1, m1))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                b)
                                              (fun b =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (check_activate_staking_balance
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                    true b (a1, m1))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                        (b,
                                                          ((a1, m1),
                                                            balance_start),
                                                          (a2, m2))
                                                    end))
                                          end)))
                            end))))
          end
        end)
  end.

Definition deactivation_then_bake (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (run_until_deactivation tt)
      (fun function_parameter =>
        match function_parameter with
        |
          (b,
            ((_deactivated_contract, deactivated_account) as deactivated,
              _start_balance), (_a2, _m2)) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (check_activate_staking_balance
                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                  false b deactivated)
                (fun function_parameter =>
                  match function_parameter with
                  | tt => check_rolls b deactivated_account
                  end))
        end)
  end.

Definition deactivation_then_self_delegation (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (run_until_deactivation tt)
      (fun function_parameter =>
        match function_parameter with
        |
          (b,
            ((deactivated_contract, deactivated_account) as deactivated,
              start_balance), (_a2, m2)) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star deactivated_contract
              (Some (pkh deactivated_account)))
            (fun self_delegation =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star b self_delegation)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (check_activate_staking_balance
                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      false b deactivated)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            deactivated_contract)
                          (fun balance =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                start_balance balance)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => check_rolls b deactivated_account
                                end))
                      end)))
        end)
  end.

Definition deactivation_then_empty_then_self_delegation {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (run_until_deactivation tt)
      (fun function_parameter =>
        match function_parameter with
        |
          (b,
            ((deactivated_contract, deactivated_account) as deactivated,
              _start_balance), (_a2, m2)) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star deactivated_contract)
            (fun balance =>
              let sink_account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
              let sink_contract :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  (pkh sink_account) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                      (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                          op_star_t_y_p_e_minus_e_r_r_o_r_star))
                      (fun origination_burn =>
                        let amount :=
                          match
                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_minus_question
                              balance origination_burn with
                          | inl r => r
                          | inr _ => false
                          end in
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            deactivated_contract sink_contract amount)
                          (fun empty_contract =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                empty_contract b)
                              (fun b =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    deactivated_contract
                                    (Some (pkh deactivated_account)))
                                  (fun self_delegation =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        self_delegation b)
                                      (fun b =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (check_activate_staking_balance
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            false b deactivated)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | tt =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  deactivated_contract)
                                                (fun balance =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                      balance)
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | tt =>
                                                        check_rolls b
                                                          deactivated_account
                                                      end))
                                            end))))))
                  end))
        end)
  end.

Definition deactivation_then_empty_then_self_delegation_then_recredit {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (run_until_deactivation tt)
      (fun function_parameter =>
        match function_parameter with
        |
          (b,
            ((deactivated_contract, deactivated_account) as deactivated, balance),
            (_a2, m2)) =>
          let sink_account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
          let sink_contract :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
              (pkh sink_account) in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                      op_star_t_y_p_e_minus_e_r_r_o_r_star))
                  (fun origination_burn =>
                    let amount :=
                      match
                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_minus_question
                          balance origination_burn with
                      | inl r => r
                      | inr _ => false
                      end in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        deactivated_contract sink_contract amount)
                      (fun empty_contract =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star empty_contract
                            b)
                          (fun b =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                deactivated_contract
                                (Some (pkh deactivated_account)))
                              (fun self_delegation =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    self_delegation b)
                                  (fun b =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        sink_contract deactivated_contract
                                        amount)
                                      (fun recredit_contract =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            recredit_contract b)
                                          (fun b =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (check_activate_staking_balance
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                false b deactivated)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      deactivated_contract)
                                                    (fun balance =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          amount balance)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            check_rolls b
                                                              deactivated_account
                                                          end))
                                                end))))))))
              end)
        end)
  end.

Definition delegation (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, accounts) =>
          match account_pair accounts with
          | (a1, a2) =>
            let m3 := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
            op_star_t_y_p_e_minus_e_r_r_o_r_star m3;
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star a1)
              (fun m1 =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star a2)
                  (fun m2 =>
                    let a3 :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                        (pkh m3) in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star a1)
                      (fun delegate =>
                        match delegate with
                        | None => false
                        | Some pkh =>
                          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                            pkh (pkh m1)
                        end;
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star a1 a3
                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.fifty_cents)
                          (fun transact =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star b transact)
                              (fun b =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star a3)
                                  (fun delegate =>
                                    match delegate with
                                    | None => tt
                                    | Some _ => false
                                    end;
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (check_no_rolls b m3)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              a3 (Some (pkh m3)))
                                            (fun delegation =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  b delegation)
                                                (fun b =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      a3)
                                                    (fun delegate =>
                                                      match delegate with
                                                      | None => false
                                                      | Some pkh =>
                                                        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.equal
                                                          pkh (pkh m3)
                                                      end;
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (check_activate_staking_balance
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                          false b (a3, m3))
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | tt =>
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (check_rolls b m3)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | tt =>
                                                                  check_rolls b
                                                                    m1
                                                                end)
                                                          end))))
                                        end)))))))
          end
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "simple staking rights" % string
      variant simple_staking_rights)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        "simple staking rights after baking" % string variant
        simple_staking_rights_after_baking)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star "deactivation then bake" % string
          variant deactivation_then_bake)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "deactivation then self delegation" % string variant
            deactivation_then_self_delegation)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              "deactivation then empty then self delegation" % string variant
              deactivation_then_empty_then_self_delegation)
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "deactivation then empty then self delegation then recredit" %
                  string variant
                deactivation_then_empty_then_self_delegation_then_recredit)
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star "delegation" % string
                  variant delegation) [])))))).
src/proto_alpha/lib_protocol/test/seed.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tests about
    - seed_nonce_hash included in some blocks
    - revelation operation of seed_nonce that should correspond to each
      seed_nonce_hash
*)

open Protocol
open Test_tez

(** Tests that baking [blocks_per_commitment] blocks without a
    [seed_nonce_hash] commitment fails with [Invalid_commitment] *)
let no_commitment () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_commitment; _}; _} ->
  let blocks_per_commitment = Int32.to_int blocks_per_commitment in
  (* Bake normally until before the commitment *)
  Block.bake_n (blocks_per_commitment - 2) b
  >>=? fun b ->
  (* Forge a block with empty commitment and apply it *)
  Block.Forge.forge_header b
  >>=? fun header ->
  Block.Forge.set_seed_nonce_hash None header
  |> Block.Forge.sign_header
  >>=? fun header ->
  Block.apply header b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Apply.Invalid_commitment _ ->
          true
      | _ ->
          false)

let baking_reward ctxt (b : Block.t) =
  let priority = b.header.protocol_data.contents.priority in
  Block.get_endorsing_power b
  >>=? fun endorsing_power ->
  Context.get_baking_reward ctxt ~priority ~endorsing_power

(** Choose a baker, denote it by id. In the first cycle, make id bake only once.
    Test that:
    - after id bakes with a commitment the bond is frozen and the reward allocated
    - when id reveals the nonce too early, there's an error
    - when id reveals at the right time but the wrong value, there's an error
    - when another baker reveals correctly, it receives the tip
    - revealing twice produces an error
    - after [preserved cycles] a committer that correctly revealed
      receives back the bond and the reward
*)
let revelation_early_wrong_right_twice () =
  let open Assert in
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun csts ->
  let bond = csts.parametric.block_security_deposit in
  let tip = csts.parametric.seed_nonce_revelation_tip in
  let blocks_per_commitment =
    Int32.to_int csts.parametric.blocks_per_commitment
  in
  let preserved_cycles = csts.parametric.preserved_cycles in
  (* get the pkh of a baker *)
  Block.get_next_baker b
  >>=? fun (pkh, _, _) ->
  let id = Alpha_context.Contract.implicit_contract pkh in
  let policy = Block.Excluding [pkh] in
  (* bake until commitment, excluding id *)
  Block.bake_n ~policy (blocks_per_commitment - 2) b
  >>=? fun b ->
  Context.Contract.balance ~kind:Main (B b) id
  >>=? fun bal_main ->
  Context.Contract.balance ~kind:Deposit (B b) id
  >>=? fun bal_deposit ->
  Context.Contract.balance ~kind:Rewards (B b) id
  >>=? fun bal_rewards ->
  (* the baker [id] will include a seed_nonce commitment *)
  Block.bake ~policy:(Block.By_account pkh) b
  >>=? fun b ->
  Context.get_level (B b)
  >>=? fun level_commitment ->
  Context.get_seed_nonce_hash (B b)
  >>=? fun committed_hash ->
  baking_reward (B b) b
  >>=? fun reward ->
  (* test that the bond was frozen and the reward allocated *)
  balance_was_debited ~loc:__LOC__ (B b) id bal_main bond
  >>=? fun () ->
  balance_was_credited ~loc:__LOC__ (B b) id ~kind:Deposit bal_deposit bond
  >>=? fun () ->
  balance_was_credited ~loc:__LOC__ (B b) id ~kind:Rewards bal_rewards reward
  >>=? fun () ->
  (* test that revealing too early produces an error *)
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
  >>=? fun operation ->
  Block.bake ~policy ~operation b
  >>= fun e ->
  let expected = function
    | Nonce_storage.Too_early_revelation ->
        true
    | _ ->
        false
  in
  Assert.proto_error ~loc:__LOC__ e expected
  >>=? fun () ->
  (* finish the cycle excluding the committing baker, id *)
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  (* test that revealing at the right time but the wrong value produces an error *)
  let (wrong_hash, _) = Nonce.generate () in
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get wrong_hash)
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Nonce_storage.Unexpected_nonce ->
          true
      | _ ->
          false)
  >>=? fun () ->
  (* reveals correctly *)
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
  >>=? fun operation ->
  Block.get_next_baker ~policy b
  >>=? fun (baker_pkh, _, _) ->
  let baker = Alpha_context.Contract.implicit_contract baker_pkh in
  Context.Contract.balance ~kind:Main (B b) baker
  >>=? fun baker_bal_main ->
  Context.Contract.balance ~kind:Deposit (B b) baker
  >>=? fun baker_bal_deposit ->
  Context.Contract.balance ~kind:Rewards (B b) baker
  >>=? fun baker_bal_rewards ->
  (* bake the operation in a block *)
  Block.bake ~policy ~operation b
  >>=? fun b ->
  baking_reward (B b) b
  >>=? fun baker_reward ->
  (* test that the baker gets the tip reward *)
  balance_was_debited ~loc:__LOC__ (B b) baker ~kind:Main baker_bal_main bond
  >>=? fun () ->
  balance_was_credited
    ~loc:__LOC__
    (B b)
    baker
    ~kind:Deposit
    baker_bal_deposit
    bond
  >>=? fun () ->
  Lwt.return @@ Tez.( +? ) baker_reward tip
  >>=? fun expected_rewards ->
  balance_was_credited
    ~loc:__LOC__
    (B b)
    baker
    ~kind:Rewards
    baker_bal_rewards
    expected_rewards
  >>=? fun () ->
  (* test that revealing twice produces an error *)
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get wrong_hash)
  >>=? fun operation ->
  Block.bake ~operation ~policy b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Nonce_storage.Previously_revealed_nonce ->
          true
      | _ ->
          false)
  >>=? fun () ->
  (* bake [preserved_cycles] cycles excluding [id] *)
  Error_monad.fold_left_s
    (fun b _ -> Block.bake_until_cycle_end ~policy b)
    b
    (1 -- preserved_cycles)
  >>=? fun b ->
  (* test that [id] receives back the bond and the reward *)
  (* note that in order to have that new_bal = bal_main + reward,
     id can only bake once; this is why we exclude id from all other bake ops. *)
  balance_was_credited ~loc:__LOC__ (B b) id ~kind:Main bal_main reward
  >>=? fun () ->
  balance_is ~loc:__LOC__ (B b) id ~kind:Deposit Tez.zero
  >>=? fun () -> balance_is ~loc:__LOC__ (B b) id ~kind:Rewards Tez.zero

(** Tests that:
    - a committer at cycle 0, which doesn't reveal at cycle 1,
      at the end of the cycle 1 looses the bond and the reward
    - revealing too late produces an error
*)
let revelation_missing_and_late () =
  let open Context in
  let open Assert in
  Context.init 5
  >>=? fun (b, _) ->
  get_constants (B b)
  >>=? fun csts ->
  baking_reward (B b) b
  >>=? fun reward ->
  let blocks_per_commitment =
    Int32.to_int csts.parametric.blocks_per_commitment
  in
  (* bake until commitment *)
  Block.bake_n (blocks_per_commitment - 2) b
  >>=? fun b ->
  (* the next baker [id] will include a seed_nonce commitment *)
  Block.get_next_baker b
  >>=? fun (pkh, _, _) ->
  let id = Alpha_context.Contract.implicit_contract pkh in
  Block.bake b
  >>=? fun b ->
  Context.get_level (B b)
  >>=? fun level_commitment ->
  Context.get_seed_nonce_hash (B b)
  >>=? fun committed_hash ->
  Context.Contract.balance ~kind:Main (B b) id
  >>=? fun bal_main ->
  Context.Contract.balance ~kind:Deposit (B b) id
  >>=? fun bal_deposit ->
  Context.Contract.balance ~kind:Rewards (B b) id
  >>=? fun bal_rewards ->
  (* finish cycle 0 excluding the committing baker [id] *)
  let policy = Block.Excluding [pkh] in
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  (* finish cycle 1 excluding the committing baker [id] *)
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  (* test that baker [id], which didn't reveal at cycle 1 like it was supposed to,
     at the end of the cycle 1 looses the reward but not the bond *)
  balance_is ~loc:__LOC__ (B b) id ~kind:Main bal_main
  >>=? fun () ->
  balance_is ~loc:__LOC__ (B b) id ~kind:Deposit bal_deposit
  >>=? fun () ->
  balance_was_debited ~loc:__LOC__ (B b) id ~kind:Rewards bal_rewards reward
  >>=? fun () ->
  (* test that revealing too late (after cycle 1) produces an error *)
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Nonce_storage.Too_late_revelation ->
          true
      | _ ->
          false)

let tests =
  [ Test.tztest "no commitment" `Quick no_commitment;
    Test.tztest
      "revelation_early_wrong_right_twice"
      `Quick
      revelation_early_wrong_right_twice;
    Test.tztest
      "revelation_missing_and_late"
      `Quick
      revelation_missing_and_late ]
src/proto_alpha/lib_protocol/test/seed.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition no_commitment {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 5)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                let blocks_per_commitment :=
                  Tezos_protocol_environment_alpha__Environment.Int32.to_int
                    op_star_t_y_p_e_minus_e_r_r_o_r_star in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                      blocks_per_commitment 2) b)
                  (fun b =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                      (fun header =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star None header)
                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                          (fun header =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star header b)
                              (fun e =>
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  e
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Apply.Invalid_commitment _ => true
                                    | _ => false
                                    end)))))
              end)
        end)
  end.

Definition baking_reward {A B C : Type} (ctxt : A) (function_parameter : B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  match function_parameter with
  | _ =>
    let priority :=
      priority
        (contents (protocol_data (header op_star_t_y_p_e_minus_e_r_r_o_r_star)))
      in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star)
      (fun endorsing_power =>
        op_star_t_y_p_e_minus_e_r_r_o_r_star ctxt priority endorsing_power)
  end.

Definition revelation_early_wrong_right_twice {A : Type}
  (function_parameter : unit) : A :=
  match function_parameter with
  | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition revelation_missing_and_late {A : Type} (function_parameter : unit)
  : A :=
  match function_parameter with
  | tt => op_star_t_y_p_e_minus_e_r_r_o_r_star
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "no commitment" % string variant
      no_commitment)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        "revelation_early_wrong_right_twice" % string variant
        revelation_early_wrong_right_twice)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "revelation_missing_and_late" % string variant
          revelation_missing_and_late) [])).
src/proto_alpha/lib_protocol/test/test.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Wraps an alcotest so that it prints correcly errors from the Error_monad. *)
let tztest name speed f =
  Alcotest_lwt.test_case name speed (fun _sw () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error err ->
          Tezos_stdlib_unix.Internal_event_unix.close ()
          >>= fun () ->
          Format.printf "@.%a@." pp_print_error err ;
          Lwt.fail Alcotest.Test_error)
src/proto_alpha/lib_protocol/test/test.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition tztest {A B C D : Type}
  (name : A) (speed : B)
  (f :
    unit ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result unit C))
  : D :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star name speed
    (fun _sw =>
      fun function_parameter =>
        match function_parameter with
        | tt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (f tt)
            (fun function_parameter =>
              match function_parameter with
              | inl tt =>
                Tezos_protocol_environment_alpha__Environment.Lwt.return_unit
              | inr err =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_stdlib_unix.Internal_event_unix.close tt)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star "@.%a@." % string
                        op_star_t_y_p_e_minus_e_r_r_o_r_star err;
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                    end)
              end)
        end).
src/proto_alpha/lib_protocol/test/transfer.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Test_utils
open Test_tez

(*********************************************************************)
(* Utility functions                                                 *)
(*********************************************************************)

(**
   [transfer_and_check_balances b fee src dst amount]
   this function takes a block, an optional parameter fee if fee does not
   given it will be set to zero tez, a source contract, a destination contract
   and the amount that one wants to transfer.

   1- Transfer the amount of tez (w/wo fee) from a source contract to a
       destination contract.

    2- Check the equivalent of the balance of the source/destination
       contract before and after transfer is valided.

   This function returns a pair:
   - A block that added a valid operation
   - a valid operation
*)
let transfer_and_check_balances ?(with_burn = false) ~loc b ?(fee = Tez.zero)
    ?expect_failure src dst amount =
  Tez.( +? ) fee amount
  >>?= fun amount_fee ->
  Context.Contract.balance (I b) src
  >>=? fun bal_src ->
  Context.Contract.balance (I b) dst
  >>=? fun bal_dst ->
  Op.transaction (I b) ~fee src dst amount
  >>=? fun op ->
  Incremental.add_operation ?expect_failure b op
  >>=? fun b ->
  Context.get_constants (I b)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  let amount_fee_maybe_burn =
    if with_burn then
      match Tez.(amount_fee +? origination_burn) with
      | Ok r ->
          r
      | Error _ ->
          assert false
    else amount_fee
  in
  Assert.balance_was_debited ~loc (I b) src bal_src amount_fee_maybe_burn
  >>=? fun () ->
  Assert.balance_was_credited ~loc (I b) dst bal_dst amount
  >>=? fun () -> return (b, op)

(**
   [transfer_to_itself_and_check_balances b fee contract amount]
   this function takes a block, an optional parameter fee,
   a contract that is a source and a destination contract,
   and an amount of tez that one wants to transfer.

   1- Transfer the amount of tez (w/wo transfer fee) from/to a contract itself.

   2- Check the equivalent of the balance of the contract before
       and after transfer.

   This function returns a pair:
   - a block that added the valid transaction
   - an valid transaction
*)
let transfer_to_itself_and_check_balances ~loc b ?(fee = Tez.zero) contract
    amount =
  Context.Contract.balance (I b) contract
  >>=? fun bal ->
  Op.transaction (I b) ~fee contract contract amount
  >>=? fun op ->
  Incremental.add_operation b op
  >>=? fun b ->
  Assert.balance_was_debited ~loc (I b) contract bal fee
  >>=? fun () -> return (b, op)

(**
   [n_transactions n b fee source dest amount]
   this function takes a number of "n" that one wish to transfer,
   a block, an optional parameter fee, a source contract,
   a destination contract and an amount one wants to transfer.

   This function will do a transaction from a source contract to
   a destination contract with the amount "n" times.
*)
let n_transactions n b ?fee source dest amount =
  fold_left_s
    (fun b _ ->
      transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount
      >>=? fun (b, _) -> return b)
    b
    (1 -- n)

let ten_tez = Tez.of_int 10

(*********************************************************************)
(* Tests                                                             *)
(*********************************************************************)

let register_two_contracts () =
  Context.init 2
  >>=? fun (b, contracts) ->
  let contract_1 = List.nth contracts 0 in
  let contract_2 = List.nth contracts 1 in
  return (b, contract_1, contract_2)

(** compute half of the balance and divided by nth
    times *)

let two_nth_of_balance incr contract nth =
  Context.Contract.balance (I incr) contract
  >>=? fun balance ->
  Tez.( /? ) balance nth
  >>?= fun res -> Tez.( *? ) res 2L >>?= fun balance -> return balance

(********************)
(** Single transfer *)

(********************)

let single_transfer ?fee ?expect_failure amount =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  transfer_and_check_balances
    ~loc:__LOC__
    ?fee
    ?expect_failure
    b
    contract_1
    contract_2
    amount
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(** single transfer without fee *)
let block_with_a_single_transfer () = single_transfer Tez.one

(** single transfer with fee *)
let block_with_a_single_transfer_with_fee () =
  single_transfer ~fee:Tez.one Tez.one

(** single transfer without fee *)

let transfer_zero_tez () =
  single_transfer
    ~expect_failure:(function
      | Environment.Ecoproto_error (Contract_storage.Empty_transaction _) :: _
        ->
          return_unit
      | _ ->
          failwith "Empty transaction should fail")
    Tez.zero

(********************)
(** Transfer zero tez from an implicit contract *)

(********************)

let transfer_zero_implicit () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let dest = List.nth contracts 0 in
  let account = Account.new_account () in
  Incremental.begin_construction b
  >>=? fun i ->
  let src = Contract.implicit_contract account.Account.pkh in
  Op.transaction (I i) src dest Tez.zero
  >>=? fun op ->
  Incremental.add_operation i op
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Contract_storage.Empty_implicit_contract _ ->
          true
      | _ ->
          false)

(********************)
(** Transfer to originted contract *)

(********************)

let transfer_to_originate_with_fee () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.nth contracts 0 in
  Incremental.begin_construction b
  >>=? fun b ->
  two_nth_of_balance b contract 10L
  >>=? fun fee ->
  (* originated contract, paying a fee to originated this contract *)
  Op.origination (I b) ~fee:ten_tez contract ~script:Op.dummy_script
  >>=? fun (operation, new_contract) ->
  Incremental.add_operation b operation
  >>=? fun b ->
  two_nth_of_balance b contract 3L
  >>=? fun amount ->
  transfer_and_check_balances ~loc:__LOC__ b ~fee contract new_contract amount
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Transfer from balance *)

(********************)

let transfer_amount_of_contract_balance () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Context.Contract.pkh contract_1
  >>=? fun pkh1 ->
  (* given that contract_1 no longer has a sufficient balance to bake,
     make sure it cannot be chosen as baker *)
  Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
  >>=? fun b ->
  (* get the balance of the source contract *)
  Context.Contract.balance (I b) contract_1
  >>=? fun balance ->
  (* transfer all the tez inside contract 1 *)
  transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 balance
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Transfer to itself *)

(********************)

let transfers_to_self () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.nth contracts 0 in
  Incremental.begin_construction b
  >>=? fun b ->
  two_nth_of_balance b contract 3L
  >>=? fun amount ->
  transfer_to_itself_and_check_balances ~loc:__LOC__ b contract amount
  >>=? fun (b, _) ->
  two_nth_of_balance b contract 5L
  >>=? fun fee ->
  transfer_to_itself_and_check_balances ~loc:__LOC__ b ~fee contract ten_tez
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Forgot to add the valid transaction into the block *)

(********************)

let missing_transaction () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  (* given that contract_1 no longer has a sufficient balance to bake,
     make sure it cannot be chosen as baker *)
  Context.Contract.pkh contract_1
  >>=? fun pkh1 ->
  Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
  >>=? fun b ->
  two_nth_of_balance b contract_1 6L
  >>=? fun amount ->
  (* do the transfer 3 times from source contract to destination contract *)
  n_transactions 3 b contract_1 contract_2 amount
  >>=? fun b ->
  (* do the fourth transfer from source contract to destination contract *)
  Op.transaction (I b) contract_1 contract_2 amount
  >>=? fun _ -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** These following tests are for different kind of contracts:
    - implicit to implicit
    - implicit to originated
    - originated to implicit
    - originted to originted *)

(********************)

(** Implicit to Implicit *)

let transfer_from_implicit_to_implicit_contract () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let bootstrap_contract = List.nth contracts 0 in
  let account_a = Account.new_account () in
  let account_b = Account.new_account () in
  Incremental.begin_construction b
  >>=? fun b ->
  let src = Contract.implicit_contract account_a.Account.pkh in
  two_nth_of_balance b bootstrap_contract 3L
  >>=? fun amount1 ->
  two_nth_of_balance b bootstrap_contract 10L
  >>=? fun fee1 ->
  transfer_and_check_balances
    ~with_burn:true
    ~loc:__LOC__
    ~fee:fee1
    b
    bootstrap_contract
    src
    amount1
  >>=? fun (b, _) ->
  (* create an implicit contract as a destination contract *)
  let dest = Contract.implicit_contract account_b.pkh in
  two_nth_of_balance b bootstrap_contract 4L
  >>=? fun amount2 ->
  two_nth_of_balance b bootstrap_contract 10L
  >>=? fun fee2 ->
  (* transfer from implicit contract to another implicit contract *)
  transfer_and_check_balances
    ~with_burn:true
    ~loc:__LOC__
    ~fee:fee2
    b
    src
    dest
    amount2
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(** Implicit to originated *)

let transfer_from_implicit_to_originated_contract () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let bootstrap_contract = List.nth contracts 0 in
  let contract = List.nth contracts 0 in
  let account = Account.new_account () in
  let src = Contract.implicit_contract account.Account.pkh in
  Incremental.begin_construction b
  >>=? fun b ->
  two_nth_of_balance b bootstrap_contract 3L
  >>=? fun amount1 ->
  (* transfer the money to implicit contract *)
  transfer_and_check_balances
    ~with_burn:true
    ~loc:__LOC__
    b
    bootstrap_contract
    src
    amount1
  >>=? fun (b, _) ->
  (* originated contract *)
  Op.origination (I b) contract ~script:Op.dummy_script
  >>=? fun (operation, new_contract) ->
  Incremental.add_operation b operation
  >>=? fun b ->
  two_nth_of_balance b bootstrap_contract 4L
  >>=? fun amount2 ->
  (* transfer from implicit contract to originated contract *)
  transfer_and_check_balances ~loc:__LOC__ b src new_contract amount2
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Slow tests case *)

(********************)

let multiple_transfer n ?fee amount =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  n_transactions n b ?fee contract_1 contract_2 amount
  >>=? fun b -> Incremental.finalize_block b >>=? fun _ -> return_unit

(** 1- Create a block with two contracts;
    2- Apply 100 transfers. *)
let block_with_multiple_transfers () = multiple_transfer 99 (Tez.of_int 1000)

(** 1- Create a block with two contracts;
    2- Apply 100 transfers with 10tz fee. *)
let block_with_multiple_transfers_pay_fee () =
  multiple_transfer 10 ~fee:ten_tez (Tez.of_int 1000)

(* TODO : increase the number of operations and add a `Slow tag to it in `tests` *)

(** 1- Create a block with 8 contracts;
    2- Apply multiple transfers without fees;
    3- Apply multiple transfers with fees. *)
let block_with_multiple_transfers_with_without_fee () =
  Context.init 8
  >>=? fun (b, contracts) ->
  let contracts = Array.of_list contracts in
  Incremental.begin_construction b
  >>=? fun b ->
  let hundred = Tez.of_int 100 in
  let ten = Tez.of_int 10 in
  let twenty = Tez.of_int 20 in
  n_transactions 10 b contracts.(0) contracts.(1) Tez.one
  >>=? fun b ->
  n_transactions 30 b contracts.(1) contracts.(2) hundred
  >>=? fun b ->
  n_transactions 30 b contracts.(1) contracts.(3) hundred
  >>=? fun b ->
  n_transactions 30 b contracts.(4) contracts.(3) hundred
  >>=? fun b ->
  n_transactions 20 b contracts.(0) contracts.(1) hundred
  >>=? fun b ->
  n_transactions 10 b contracts.(1) contracts.(3) hundred
  >>=? fun b ->
  n_transactions 10 b contracts.(1) contracts.(3) hundred
  >>=? fun b ->
  n_transactions 20 ~fee:ten b contracts.(3) contracts.(4) ten
  >>=? fun b ->
  n_transactions 10 ~fee:twenty b contracts.(4) contracts.(5) ten
  >>=? fun b ->
  n_transactions 70 ~fee:twenty b contracts.(6) contracts.(0) twenty
  >>=? fun b ->
  n_transactions 550 ~fee:twenty b contracts.(6) contracts.(4) twenty
  >>=? fun b ->
  n_transactions 50 ~fee:ten b contracts.(7) contracts.(5) twenty
  >>=? fun b ->
  n_transactions 30 ~fee:ten b contracts.(0) contracts.(7) hundred
  >>=? fun b ->
  n_transactions 20 ~fee:ten b contracts.(1) contracts.(0) twenty
  >>=? fun b -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Build a chain that has 10 blocks. *)

(********************)

let build_a_chain () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  let ten = Tez.of_int 10 in
  fold_left_s
    (fun b _ ->
      Incremental.begin_construction b
      >>=? fun b ->
      transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten
      >>=? fun (b, _) -> Incremental.finalize_block b)
    b
    (1 -- 10)
  >>=? fun _ -> return_unit

(*********************************************************************)
(* Expected error test cases                                         *)
(*********************************************************************)

(********************)
(** transfer zero tez is forbidden in implicit contract *)

(********************)

let empty_implicit () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let dest = List.nth contracts 0 in
  let account = Account.new_account () in
  Incremental.begin_construction b
  >>=? fun incr ->
  let src = Contract.implicit_contract account.Account.pkh in
  two_nth_of_balance incr dest 3L
  >>=? fun amount ->
  (* transfer zero tez from an implicit contract *)
  Op.transaction (I incr) src dest amount
  >>=? fun op ->
  Incremental.add_operation incr op
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Contract_storage.Empty_implicit_contract _ ->
          true
      | _ ->
          false)

(********************)
(** Balance is too low to transfer *)

(********************)

let balance_too_low fee () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.balance (I i) contract_1
  >>=? fun balance1 ->
  Context.Contract.balance (I i) contract_2
  >>=? fun balance2 ->
  (* transfer the amount of tez that is bigger than the balance in the source contract *)
  Op.transaction ~fee (I i) contract_1 contract_2 Tez.max_tez
  >>=? fun op ->
  let expect_failure = function
    | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
        return_unit
    | _ ->
        failwith "balance too low should fail"
  in
  (* the fee is higher than the balance then raise an error "Balance_too_low" *)
  if fee > balance1 then
    Incremental.add_operation ~expect_failure i op >>= fun _res -> return_unit
    (* the fee is smaller than the balance, then the transfer is accepted
     but it is not processed, and fees are taken *)
  else
    Incremental.add_operation ~expect_failure i op
    >>=? fun i ->
    (* contract_1 loses the fees *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee
    >>=? fun () ->
    (* contract_2 is not credited *)
    Assert.balance_was_credited ~loc:__LOC__ (I i) contract_2 balance2 Tez.zero

(** 1- Create a block, and three contracts;
    2- Add a transfer that at the end the balance of a contract is
       zero into this block;
    3- Add another transfer that send tez from a zero balance contract;
    4- Catch the expected error: Balance_too_low. *)
let balance_too_low_two_transfers fee () =
  Context.init 3
  >>=? fun (b, contracts) ->
  let contract_1 = List.nth contracts 0 in
  let contract_2 = List.nth contracts 1 in
  let contract_3 = List.nth contracts 2 in
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.balance (I i) contract_1
  >>=? fun balance ->
  Tez.( /? ) balance 3L
  >>?= fun res ->
  Tez.( *? ) res 2L
  >>?= fun two_third_of_balance ->
  transfer_and_check_balances
    ~loc:__LOC__
    i
    contract_1
    contract_2
    two_third_of_balance
  >>=? fun (i, _) ->
  Context.Contract.balance (I i) contract_1
  >>=? fun balance1 ->
  Context.Contract.balance (I i) contract_3
  >>=? fun balance3 ->
  Op.transaction ~fee (I i) contract_1 contract_3 two_third_of_balance
  >>=? fun operation ->
  let expect_failure = function
    | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
        return_unit
    | _ ->
        failwith "balance too low should fail"
  in
  Incremental.add_operation ~expect_failure i operation
  >>=? fun i ->
  (* contract_1 loses the fees *)
  Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee
  >>=? fun () ->
  (* contract_3 is not credited *)
  Assert.balance_was_credited ~loc:__LOC__ (I i) contract_3 balance3 Tez.zero

(********************)
(** The counter is already used for the previous operation *)

(********************)

let invalid_counter () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  Op.transaction (I b) contract_1 contract_2 Tez.one
  >>=? fun op1 ->
  Op.transaction (I b) contract_1 contract_2 Tez.one
  >>=? fun op2 ->
  Incremental.add_operation b op1
  >>=? fun b ->
  Incremental.add_operation b op2
  >>= fun b ->
  Assert.proto_error ~loc:__LOC__ b (function
      | Contract_storage.Counter_in_the_past _ ->
          true
      | _ ->
          false)

(* same as before but different way to perform this error *)

let add_the_same_operation_twice () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten_tez
  >>=? fun (b, op_transfer) ->
  Op.transaction (I b) contract_1 contract_2 ten_tez
  >>=? fun _ ->
  Incremental.add_operation b op_transfer
  >>= fun b ->
  Assert.proto_error ~loc:__LOC__ b (function
      | Contract_storage.Counter_in_the_past _ ->
          true
      | _ ->
          false)

(********************)
(** check ownership *)

(********************)

let ownership_sender () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  (* get the manager of the contract_1 as a sender *)
  Context.Contract.manager (I b) contract_1
  >>=? fun manager ->
  (* create an implicit_contract *)
  let imcontract_1 = Alpha_context.Contract.implicit_contract manager.pkh in
  transfer_and_check_balances ~loc:__LOC__ b imcontract_1 contract_2 Tez.one
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(*********************************************************************)
(** Random transfer *)

(** Return a pair of minimum and maximum random number *)
let random_range (min, max) =
  let interv = max - min + 1 in
  let init =
    Random.self_init () ;
    Random.int interv + min
  in
  init

(** Return a random contract *)
let random_contract contract_array =
  let i = Random.int (Array.length contract_array) in
  contract_array.(i)

(** Transfer by randomly choose amount 10 contracts, and randomly
    choose the amount in the source contract *)
let random_transfer () =
  Context.init 10
  >>=? fun (b, contracts) ->
  let contracts = Array.of_list contracts in
  let source = random_contract contracts in
  let dest = random_contract contracts in
  Context.Contract.pkh source
  >>=? fun source_pkh ->
  (* given that source may not have a sufficient balance for the transfer + to bake,
     make sure it cannot be chosen as baker *)
  Incremental.begin_construction b ~policy:(Block.Excluding [source_pkh])
  >>=? fun b ->
  Context.Contract.balance (I b) source
  >>=? fun amount ->
  ( if source = dest then
    transfer_to_itself_and_check_balances ~loc:__LOC__ b source amount
  else transfer_and_check_balances ~loc:__LOC__ b source dest amount )
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(** Transfer random transactions *)
let random_multi_transactions () =
  let n = random_range (1, 100) in
  multiple_transfer n (Tez.of_int 100)

(*********************************************************************)

let tests =
  [ (* single transfer *)
    Test.tztest "single transfer" `Quick block_with_a_single_transfer;
    Test.tztest
      "single transfer with fee"
      `Quick
      block_with_a_single_transfer_with_fee;
    (* transfer zero tez *)
    Test.tztest "single transfer zero tez" `Quick transfer_zero_tez;
    Test.tztest
      "transfer zero tez from implicit contract"
      `Quick
      transfer_zero_implicit;
    (* transfer to originated contract *)
    Test.tztest
      "transfer to originated contract paying transaction fee"
      `Quick
      transfer_to_originate_with_fee;
    (* transfer by the balance of contract *)
    Test.tztest
      "transfer the amount from source contract balance"
      `Quick
      transfer_amount_of_contract_balance;
    (* transfer to itself *)
    Test.tztest "transfers to itself" `Quick transfers_to_self;
    (* missing operation *)
    Test.tztest "missing transaction" `Quick missing_transaction;
    (* transfer from/to implicit/originted contracts*)
    Test.tztest
      "transfer from an implicit to implicit contract "
      `Quick
      transfer_from_implicit_to_implicit_contract;
    Test.tztest
      "transfer from an implicit to an originated contract"
      `Quick
      transfer_from_implicit_to_originated_contract;
    (* Slow tests *)
    Test.tztest
      "block with multiple transfers"
      `Slow
      block_with_multiple_transfers;
    (* TODO increase the number of transaction times *)
    Test.tztest
      "block with multiple transfer paying fee"
      `Slow
      block_with_multiple_transfers_pay_fee;
    Test.tztest
      "block with multiple transfer without paying fee"
      `Slow
      block_with_multiple_transfers_with_without_fee;
    (* build the chain *)
    Test.tztest "build a chain" `Quick build_a_chain;
    (* Erroneous *)
    Test.tztest "empty implicit" `Quick empty_implicit;
    Test.tztest
      "balance too low - transfer zero"
      `Quick
      (balance_too_low Tez.zero);
    Test.tztest "balance too low" `Quick (balance_too_low Tez.one);
    Test.tztest
      "balance too low (max fee)"
      `Quick
      (balance_too_low Tez.max_tez);
    Test.tztest
      "balance too low with two transfers - transfer zero"
      `Quick
      (balance_too_low_two_transfers Tez.zero);
    Test.tztest
      "balance too low with two transfers"
      `Quick
      (balance_too_low_two_transfers Tez.one);
    Test.tztest "invalid_counter" `Quick invalid_counter;
    Test.tztest
      "add the same operation twice"
      `Quick
      add_the_same_operation_twice;
    Test.tztest "ownership sender" `Quick ownership_sender;
    (* Random tests *)
    Test.tztest "random transfer" `Quick random_transfer;
    Test.tztest "random multi transfer" `Quick random_multi_transactions ]
src/proto_alpha/lib_protocol/test/transfer.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Import Tezos_protocol_alpha.Protocol.Alpha_context.

Definition transfer_and_check_balances {A B C D E F : Type}
  (op_star_o_p_t_star : option bool)
  : A ->
    B ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
        (option C) ->
          D -> E -> Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez -> F :=
  let with_burn :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => false
    end in
  fun loc =>
    fun b =>
      fun op_star_o_p_t_star =>
        let fee :=
          match op_star_o_p_t_star with
          | Some op_star_s_t_h_star => op_star_s_t_h_star
          | None => Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
          end in
        fun expect_failure =>
          fun src =>
            fun dst =>
              fun amount =>
                op_star_t_y_p_e_minus_e_r_r_o_r_star
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                    fee amount)
                  (fun amount_fee =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star src)
                      (fun bal_src =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star dst)
                          (fun bal_dst =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star fee src dst
                                amount)
                              (fun op =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    expect_failure b op)
                                  (fun b =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              (Tezos_protocol_environment_alpha__Environment.Int64.of_int
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                            (fun origination_burn =>
                                              let amount_fee_maybe_burn :=
                                                if with_burn then
                                                  match
                                                    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_plus_question
                                                      amount_fee
                                                      origination_burn with
                                                  | inl r => r
                                                  | inr _ => false
                                                  end
                                                else
                                                  amount_fee in
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  loc
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  src bal_src
                                                  amount_fee_maybe_burn)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | tt =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        loc
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        dst bal_dst amount)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                            (b, op)
                                                        end)
                                                  end))
                                        end)))))).

Definition transfer_to_itself_and_check_balances {A B C D E F : Type}
  (loc : A) (b : B)
  (op_star_o_p_t_star :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : C ->
    D ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (E * F)) :=
  let fee :=
    match op_star_o_p_t_star with
    | Some op_star_s_t_h_star => op_star_s_t_h_star
    | None => Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
    end in
  fun contract =>
    fun amount =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          op_star_t_y_p_e_minus_e_r_r_o_r_star contract)
        (fun bal =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star fee contract contract amount)
            (fun op =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star b op)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star loc
                      op_star_t_y_p_e_minus_e_r_r_o_r_star contract bal fee)
                    (fun function_parameter =>
                      match function_parameter with
                      | tt =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                          (b, op)
                      end)))).

Definition n_transactions {A B C D : Type}
  (n : A) (b : B)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (source : C) (dest : D)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
    (fun b =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (transfer_and_check_balances None
              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__ b
              fee None source dest amount)
            (fun function_parameter =>
              match function_parameter with
              | (b, _) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  b
              end)
        end) b (op_star_t_y_p_e_minus_e_r_r_o_r_star 1 n).

Definition ten_tez {A : Type} : A := op_star_t_y_p_e_minus_e_r_r_o_r_star 10.

Definition register_two_contracts {A B C : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A * B * C)) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contract_1 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let contract_2 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1 in
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (b, contract_1, contract_2)
        end)
  end.

Definition two_nth_of_balance {A B C : Type}
  (incr : A) (contract : B) (nth : int64)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star
      contract)
    (fun balance =>
      op_star_t_y_p_e_minus_e_r_r_o_r_star
        (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_div_question balance
          nth)
        (fun res =>
          op_star_t_y_p_e_minus_e_r_r_o_r_star
            (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
              res 2)
            (fun balance =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                balance))).

Definition single_transfer {A : Type}
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (expect_failure : option A)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (register_two_contracts tt)
    (fun function_parameter =>
      match function_parameter with
      | (b, contract_1, contract_2) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
          (fun b =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (transfer_and_check_balances None
                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                b fee expect_failure contract_1 contract_2 amount)
              (fun function_parameter =>
                match function_parameter with
                | (b, _) =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                    (fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                      end)
                end))
      end).

Definition block_with_a_single_transfer (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    single_transfer None None
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one
  end.

Definition block_with_a_single_transfer_with_fee (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    single_transfer (Some Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
      None Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one
  end.

Definition transfer_zero_tez (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    single_transfer None
      (Some
        (fun function_parameter =>
          match function_parameter with
          |
            cons
              (Environment.Ecoproto_error (Contract_storage.Empty_transaction _))
              _ =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
          | _ =>
            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
              "Empty transaction should fail" % string
          end)) Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
  end.

Definition transfer_zero_implicit {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let dest := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              let src :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  (Account.pkh account) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star src dest
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero)
                (fun op =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star i op)
                    (fun res =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                        res
                        (fun function_parameter =>
                          match function_parameter with
                          | Contract_storage.Empty_implicit_contract _ => true
                          | _ => false
                          end))))
        end)
  end.

Definition transfer_to_originate_with_fee (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contract := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (two_nth_of_balance b contract 10)
                (fun fee =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star ten_tez contract
                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                    (fun function_parameter =>
                      match function_parameter with
                      | (operation, new_contract) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star b operation)
                          (fun b =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (two_nth_of_balance b contract 3)
                              (fun amount =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (transfer_and_check_balances None
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    b (Some fee) None contract new_contract
                                    amount)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | (b, _) =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | _ =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                          end)
                                    end)))
                      end)))
        end)
  end.

Definition transfer_amount_of_contract_balance (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (register_two_contracts tt)
      (fun function_parameter =>
        match function_parameter with
        | (b, contract_1, contract_2) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1)
            (fun pkh1 =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star b
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1)
                    (fun balance =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (transfer_and_check_balances None
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          b None None contract_1 contract_2 balance)
                        (fun function_parameter =>
                          match function_parameter with
                          | (b, _) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                end)
                          end))))
        end)
  end.

Definition transfers_to_self (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contract := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (two_nth_of_balance b contract 3)
                (fun amount =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (transfer_to_itself_and_check_balances
                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      b None contract amount)
                    (fun function_parameter =>
                      match function_parameter with
                      | (b, _) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (two_nth_of_balance b contract 5)
                          (fun fee =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (transfer_to_itself_and_check_balances
                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                b (Some fee) contract ten_tez)
                              (fun function_parameter =>
                                match function_parameter with
                                | (b, _) =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | _ =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                      end)
                                end))
                      end)))
        end)
  end.

Definition missing_transaction (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (register_two_contracts tt)
      (fun function_parameter =>
        match function_parameter with
        | (b, contract_1, contract_2) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1)
            (fun pkh1 =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star b
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (two_nth_of_balance b contract_1 6)
                    (fun amount =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (n_transactions 3 b None contract_1 contract_2 amount)
                        (fun b =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1
                              contract_2 amount)
                            (fun function_parameter =>
                              match function_parameter with
                              | _ =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                    end)
                              end)))))
        end)
  end.

Definition transfer_from_implicit_to_implicit_contract
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let bootstrap_contract :=
            op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let account_a := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
          let account_b := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              let src :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  (Account.pkh account_a) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (two_nth_of_balance b bootstrap_contract 3)
                (fun amount1 =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (two_nth_of_balance b bootstrap_contract 10)
                    (fun fee1 =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (transfer_and_check_balances (Some true)
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          b (Some fee1) None bootstrap_contract src amount1)
                        (fun function_parameter =>
                          match function_parameter with
                          | (b, _) =>
                            let dest :=
                              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                                (pkh account_b) in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (two_nth_of_balance b bootstrap_contract 4)
                              (fun amount2 =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (two_nth_of_balance b bootstrap_contract 10)
                                  (fun fee2 =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (transfer_and_check_balances (Some true)
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        b (Some fee2) None src dest amount2)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | (b, _) =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              b)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | _ =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                              end)
                                        end)))
                          end))))
        end)
  end.

Definition transfer_from_implicit_to_originated_contract
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let bootstrap_contract :=
            op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let contract := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
          let src :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
              (Account.pkh account) in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (two_nth_of_balance b bootstrap_contract 3)
                (fun amount1 =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (transfer_and_check_balances (Some true)
                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      b None None bootstrap_contract src amount1)
                    (fun function_parameter =>
                      match function_parameter with
                      | (b, _) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star contract
                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                          (fun function_parameter =>
                            match function_parameter with
                            | (operation, new_contract) =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star b
                                  operation)
                                (fun b =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (two_nth_of_balance b bootstrap_contract 4)
                                    (fun amount2 =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (transfer_and_check_balances None
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                          b None None src new_contract amount2)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | (b, _) =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                b)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | _ =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                end)
                                          end)))
                            end)
                      end)))
        end)
  end.

Definition multiple_transfer {A : Type}
  (n : A) (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (register_two_contracts tt)
    (fun function_parameter =>
      match function_parameter with
      | (b, contract_1, contract_2) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
          (fun b =>
            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (n_transactions n b fee contract_1 contract_2 amount)
              (fun b =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                  (fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                    end)))
      end).

Definition block_with_multiple_transfers (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt => multiple_transfer 99 None (op_star_t_y_p_e_minus_e_r_r_o_r_star 1000)
  end.

Definition block_with_multiple_transfers_pay_fee (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    multiple_transfer 10 (Some ten_tez)
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1000)
  end.

Definition block_with_multiple_transfers_with_without_fee
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 8)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contracts := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              let hundred := op_star_t_y_p_e_minus_e_r_r_o_r_star 100 in
              let ten := op_star_t_y_p_e_minus_e_r_r_o_r_star 10 in
              let twenty := op_star_t_y_p_e_minus_e_r_r_o_r_star 20 in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (n_transactions 10 b None
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0)
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1)
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (n_transactions 30 b None
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1)
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 2) hundred)
                    (fun b =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (n_transactions 30 b None
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1)
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 3)
                          hundred)
                        (fun b =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (n_transactions 30 b None
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 4)
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 3)
                              hundred)
                            (fun b =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (n_transactions 20 b None
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    contracts 0)
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    contracts 1) hundred)
                                (fun b =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (n_transactions 10 b None
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        contracts 1)
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        contracts 3) hundred)
                                    (fun b =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (n_transactions 10 b None
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            contracts 1)
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            contracts 3) hundred)
                                        (fun b =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (n_transactions 20 b (Some ten)
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                contracts 3)
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                contracts 4) ten)
                                            (fun b =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (n_transactions 10 b
                                                  (Some twenty)
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    contracts 4)
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    contracts 5) ten)
                                                (fun b =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (n_transactions 70 b
                                                      (Some twenty)
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        contracts 6)
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        contracts 0) twenty)
                                                    (fun b =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (n_transactions 550 b
                                                          (Some twenty)
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            contracts 6)
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            contracts 4) twenty)
                                                        (fun b =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (n_transactions 50 b
                                                              (Some ten)
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                contracts 7)
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                contracts 5)
                                                              twenty)
                                                            (fun b =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (n_transactions
                                                                  30 b
                                                                  (Some ten)
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    contracts 0)
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    contracts 7)
                                                                  hundred)
                                                                (fun b =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                    (n_transactions
                                                                      20 b
                                                                      (Some ten)
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        contracts
                                                                        1)
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        contracts
                                                                        0)
                                                                      twenty)
                                                                    (fun b =>
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          b)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | _ =>
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                          end))))))))))))))))
        end)
  end.

Definition build_a_chain (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (register_two_contracts tt)
      (fun function_parameter =>
        match function_parameter with
        | (b, contract_1, contract_2) =>
          let ten := op_star_t_y_p_e_minus_e_r_r_o_r_star 10 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
              (fun b =>
                fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                      (fun b =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (transfer_and_check_balances None
                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                            b None None contract_1 contract_2 ten)
                          (fun function_parameter =>
                            match function_parameter with
                            | (b, _) => op_star_t_y_p_e_minus_e_r_r_o_r_star b
                            end))
                  end) b (op_star_t_y_p_e_minus_e_r_r_o_r_star 1 10))
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
              end)
        end)
  end.

Definition empty_implicit {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let dest := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let account := op_star_t_y_p_e_minus_e_r_r_o_r_star tt in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun incr =>
              let src :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                  (Account.pkh account) in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (two_nth_of_balance incr dest 3)
                (fun amount =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star src dest amount)
                    (fun op =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star incr op)
                        (fun res =>
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                            res
                            (fun function_parameter =>
                              match function_parameter with
                              | Contract_storage.Empty_implicit_contract _ =>
                                true
                              | _ => false
                              end)))))
        end)
  end.

Definition balance_too_low {A : Type} (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (register_two_contracts tt)
      (fun function_parameter =>
        match function_parameter with
        | (b, contract_1, contract_2) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1)
                (fun balance1 =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star contract_2)
                    (fun balance2 =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star fee
                          op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1
                          contract_2 op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (fun op =>
                          let expect_failure
                            (function_parameter :
                            list Tezos_base__TzPervasives.Error_monad.error)
                            : Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                unit) :=
                            match function_parameter with
                            |
                              cons
                                (Environment.Ecoproto_error
                                  (Contract_storage.Balance_too_low _ _ _)) _ =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                            | _ =>
                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                "balance too low should fail" % string
                            end in
                          if op_star_t_y_p_e_minus_e_r_r_o_r_star fee balance1
                            then
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                expect_failure i op)
                              (fun _res =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit)
                          else
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                expect_failure i op)
                              (fun i =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    contract_1 balance1 fee)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt =>
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        contract_2 balance2
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                    end))))))
        end)
  end.

Definition balance_too_low_two_transfers {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 3)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contract_1 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 0 in
          let contract_2 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 1 in
          let contract_3 := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts 2 in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun i =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1)
                (fun balance =>
                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_div_question
                      balance 3)
                    (fun res =>
                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.op_star_question
                          res 2)
                        (fun two_third_of_balance =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (transfer_and_check_balances None
                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                              i None None contract_1 contract_2
                              two_third_of_balance)
                            (fun function_parameter =>
                              match function_parameter with
                              | (i, _) =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    contract_1)
                                  (fun balance1 =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        contract_3)
                                      (fun balance3 =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            fee
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            contract_1 contract_3
                                            two_third_of_balance)
                                          (fun operation =>
                                            let expect_failure
                                              (function_parameter :
                                              list
                                                Tezos_base__TzPervasives.Error_monad.error)
                                              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                                  unit) :=
                                              match function_parameter with
                                              |
                                                cons
                                                  (Environment.Ecoproto_error
                                                    (Contract_storage.Balance_too_low
                                                      _ _ _)) _ =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                              | _ =>
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                  "balance too low should fail"
                                                    % string
                                              end in
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                expect_failure i operation)
                                              (fun i =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    contract_1 balance1 fee)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | tt =>
                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        contract_3 balance3
                                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero
                                                    end)))))
                              end)))))
        end)
  end.

Definition invalid_counter {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (register_two_contracts tt)
      (fun function_parameter =>
        match function_parameter with
        | (b, contract_1, contract_2) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1 contract_2
                  Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
                (fun op1 =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1 contract_2
                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
                    (fun op2 =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star b op1)
                        (fun b =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star b op2)
                            (fun b =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                b
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Contract_storage.Counter_in_the_past _ _ _
                                    => true
                                  | _ => false
                                  end))))))
        end)
  end.

Definition add_the_same_operation_twice {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (register_two_contracts tt)
      (fun function_parameter =>
        match function_parameter with
        | (b, contract_1, contract_2) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (transfer_and_check_balances None
                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                  b None None contract_1 contract_2 ten_tez)
                (fun function_parameter =>
                  match function_parameter with
                  | (b, op_transfer) =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1
                        contract_2 ten_tez)
                      (fun function_parameter =>
                        match function_parameter with
                        | _ =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star b op_transfer)
                            (fun b =>
                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                b
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Contract_storage.Counter_in_the_past _ _ _
                                    => true
                                  | _ => false
                                  end))
                        end)
                  end))
        end)
  end.

Definition ownership_sender (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (register_two_contracts tt)
      (fun function_parameter =>
        match function_parameter with
        | (b, contract_1, contract_2) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star contract_1)
                (fun manager =>
                  let imcontract_1 :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
                      (pkh manager) in
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (transfer_and_check_balances None
                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      b None None imcontract_1 contract_2
                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one)
                    (fun function_parameter =>
                      match function_parameter with
                      | (b, _) =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                          (fun function_parameter =>
                            match function_parameter with
                            | _ =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                            end)
                      end)))
        end)
  end.

Definition random_range (function_parameter : Z * Z) : Z :=
  match function_parameter with
  | (min, max) =>
    let interv :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus max
          min) 1 in
    let init :=
      op_star_t_y_p_e_minus_e_r_r_o_r_star tt;
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
        (op_star_t_y_p_e_minus_e_r_r_o_r_star interv) min in
    init
  end.

Definition random_contract {A B : Type} (contract_array : A) : B :=
  let i :=
    op_star_t_y_p_e_minus_e_r_r_o_r_star
      (op_star_t_y_p_e_minus_e_r_r_o_r_star contract_array) in
  op_star_t_y_p_e_minus_e_r_r_o_r_star contract_array i.

Definition random_transfer (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 10)
      (fun function_parameter =>
        match function_parameter with
        | (b, contracts) =>
          let contracts := op_star_t_y_p_e_minus_e_r_r_o_r_star contracts in
          let source := random_contract contracts in
          let dest := random_contract contracts in
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star source)
            (fun source_pkh =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star b
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun b =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star source)
                    (fun amount =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (if op_star_t_y_p_e_minus_e_r_r_o_r_star source dest
                          then
                          transfer_to_itself_and_check_balances
                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                            b None source amount
                        else
                          transfer_and_check_balances None
                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                            b None None source dest amount)
                        (fun function_parameter =>
                          match function_parameter with
                          | (b, _) =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star b)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                end)
                          end))))
        end)
  end.

Definition random_multi_transactions (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let n := random_range (1, 100) in
    multiple_transfer n None (op_star_t_y_p_e_minus_e_r_r_o_r_star 100)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "single transfer" % string variant
      block_with_a_single_transfer)
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star "single transfer with fee" % string
        variant block_with_a_single_transfer_with_fee)
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "single transfer zero tez" % string variant transfer_zero_tez)
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "transfer zero tez from implicit contract" % string variant
            transfer_zero_implicit)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              "transfer to originated contract paying transaction fee" % string
              variant transfer_to_originate_with_fee)
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "transfer the amount from source contract balance" % string
                variant transfer_amount_of_contract_balance)
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "transfers to itself" % string variant transfers_to_self)
                (cons
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "missing transaction" % string variant missing_transaction)
                  (cons
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      "transfer from an implicit to implicit contract " % string
                      variant transfer_from_implicit_to_implicit_contract)
                    (cons
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "transfer from an implicit to an originated contract" %
                          string variant
                        transfer_from_implicit_to_originated_contract)
                      (cons
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          "block with multiple transfers" % string variant
                          block_with_multiple_transfers)
                        (cons
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            "block with multiple transfer paying fee" % string
                            variant block_with_multiple_transfers_pay_fee)
                          (cons
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              "block with multiple transfer without paying fee"
                                % string variant
                              block_with_multiple_transfers_with_without_fee)
                            (cons
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                "build a chain" % string variant build_a_chain)
                              (cons
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  "empty implicit" % string variant
                                  empty_implicit)
                                (cons
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    "balance too low - transfer zero" % string
                                    variant
                                    (balance_too_low
                                      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero))
                                  (cons
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      "balance too low" % string variant
                                      (balance_too_low
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one))
                                    (cons
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        "balance too low (max fee)" % string
                                        variant
                                        (balance_too_low
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                      (cons
                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                          "balance too low with two transfers - transfer zero"
                                            % string variant
                                          (balance_too_low_two_transfers
                                            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.zero))
                                        (cons
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            "balance too low with two transfers"
                                              % string variant
                                            (balance_too_low_two_transfers
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Tez.one))
                                          (cons
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              "invalid_counter" % string variant
                                              invalid_counter)
                                            (cons
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                "add the same operation twice" %
                                                  string variant
                                                add_the_same_operation_twice)
                                              (cons
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  "ownership sender" % string
                                                  variant ownership_sender)
                                                (cons
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    "random transfer" % string
                                                    variant random_transfer)
                                                  (cons
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      "random multi transfer" %
                                                        string variant
                                                      random_multi_transactions)
                                                    [])))))))))))))))))))))))).
src/proto_alpha/lib_protocol/test/voting.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Test_utils

(* missing stuff in Alpha_context.Vote *)
let ballots_zero = Alpha_context.Vote.{yay = 0l; nay = 0l; pass = 0l}

let ballots_equal b1 b2 =
  Alpha_context.Vote.(b1.yay = b2.yay && b1.nay = b2.nay && b1.pass = b2.pass)

let ballots_pp ppf v =
  Alpha_context.Vote.(
    Format.fprintf
      ppf
      "{ yay = %ld ; nay = %ld ; pass = %ld"
      v.yay
      v.nay
      v.pass)

(* constants and ratios used in voting:
   percent_mul denotes the percent multiplier
   initial_participation is 7000 that is, 7/10 * percent_mul
   the participation EMA ratio pr_ema_weight / den = 7 / 10
   the participation ratio pr_num / den = 2 / 10
   note: we use the same denominator for both participation EMA and participation rate.
   supermajority rate is s_num / s_den = 8 / 10 *)
let percent_mul = 100_00

let initial_participation_num = 7

let initial_participation = initial_participation_num * percent_mul / 10

let pr_ema_weight = 8

let den = 10

let pr_num = den - pr_ema_weight

let s_num = 8

let s_den = 10

let qr_min_num = 2

let qr_max_num = 7

let expected_qr_num =
  Float.(
    of_int qr_min_num
    +. of_int initial_participation_num
       *. (of_int qr_max_num -. of_int qr_min_num)
       /. of_int den)

(* Protocol_hash.zero is "PrihK96nBAFSxVL1GLJTVhu9YnzkMFiBeuJRPA8NwuZVZCE1L6i" *)
let protos =
  Array.map
    (fun s -> Protocol_hash.of_b58check_exn s)
    [| "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH";
       "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB";
       "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm";
       "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS";
       "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN";
       "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr";
       "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC";
       "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC";
       "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ";
       "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk";
       "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD";
       "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi";
       "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj";
       "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7";
       "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG";
       "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR";
       "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW";
       "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ";
       "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh";
       "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx";
       "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX" |]

(** helper functions *)
let mk_contracts_from_pkh pkh_list =
  List.map Alpha_context.Contract.implicit_contract pkh_list

(* get the list of delegates and the list of their rolls from listings *)
let get_delegates_and_rolls_from_listings b =
  Context.Vote.get_listings (B b)
  >>=? fun l -> return (mk_contracts_from_pkh (List.map fst l), List.map snd l)

(* compute the rolls of each delegate *)
let get_rolls b delegates loc =
  Context.Vote.get_listings (B b)
  >>=? fun l ->
  map_s
    (fun delegate ->
      Context.Contract.pkh delegate
      >>=? fun pkh ->
      match List.find_opt (fun (del, _) -> del = pkh) l with
      | None ->
          failwith "%s - Missing delegate" loc
      | Some (_, rolls) ->
          return rolls)
    delegates

let test_successful_vote num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  (* no ballots in proposal period *)
  Context.Vote.get_ballots (B b)
  >>=? fun v ->
  Assert.equal
    ~loc:__LOC__
    ballots_equal
    "Unexpected ballots"
    ballots_pp
    v
    ballots_zero
  >>=? fun () ->
  (* no ballots in proposal period *)
  Context.Vote.get_ballot_list (B b)
  >>=? (function
         | [] ->
             return_unit
         | _ ->
             failwith "%s - Unexpected ballot list" __LOC__)
  >>=? fun () ->
  (* period 0 *)
  Context.Vote.get_voting_period (B b)
  >>=? fun v ->
  let open Alpha_context in
  Assert.equal
    ~loc:__LOC__
    Voting_period.equal
    "Unexpected period"
    Voting_period.pp
    v
    Voting_period.(root)
  >>=? fun () ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* participation EMA starts at initial_participation *)
  Context.Vote.get_participation_ema b
  >>=? fun v ->
  Assert.equal_int ~loc:__LOC__ initial_participation (Int32.to_int v)
  >>=? fun () ->
  (* listings must be populated in proposal period *)
  Context.Vote.get_listings (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty listings" __LOC__
         | _ ->
             return_unit)
  >>=? fun () ->
  (* beginning of proposal, denoted by _p1;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p1, rolls_p1) ->
  (* no proposals at the beginning of proposal period *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  ( if Environment.Protocol_hash.Map.is_empty ps then return_unit
  else failwith "%s - Unexpected proposals" __LOC__ )
  >>=? fun () ->
  (* no current proposal during proposal period *)
  Context.Vote.get_current_proposal (B b)
  >>=? (function
         | None ->
             return_unit
         | Some _ ->
             failwith "%s - Unexpected proposal" __LOC__)
  >>=? fun () ->
  let del1 = List.nth delegates_p1 0 in
  let del2 = List.nth delegates_p1 1 in
  let props =
    List.map (fun i -> protos.(i)) (2 -- Constants.max_proposals_per_delegate)
  in
  Op.proposals (B b) del1 (Protocol_hash.zero :: props)
  >>=? fun ops1 ->
  Op.proposals (B b) del2 [Protocol_hash.zero]
  >>=? fun ops2 ->
  Block.bake ~operations:[ops1; ops2] b
  >>=? fun b ->
  (* proposals are now populated *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  (* correctly count the double proposal for zero *)
  (let weight = Int32.add (List.nth rolls_p1 0) (List.nth rolls_p1 1) in
   match Environment.Protocol_hash.(Map.find_opt zero ps) with
   | Some v ->
       if v = weight then return_unit
       else failwith "%s - Wrong count %ld is not %ld" __LOC__ v weight
   | None ->
       failwith "%s - Missing proposal" __LOC__)
  >>=? fun () ->
  (* proposing more than maximum_proposals fails *)
  Op.proposals (B b) del1 (Protocol_hash.zero :: props)
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Amendment.Too_many_proposals ->
          true
      | _ ->
          false)
  >>=? fun () ->
  (* proposing less than one proposal fails *)
  Op.proposals (B b) del1 []
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Amendment.Empty_proposal ->
          true
      | _ ->
          false)
  >>=? fun () ->
  (* skip to testing_vote period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* period 1 *)
  Context.Vote.get_voting_period (B b)
  >>=? fun v ->
  let open Alpha_context in
  Assert.equal
    ~loc:__LOC__
    Voting_period.equal
    "Unexpected period"
    Voting_period.pp
    v
    Voting_period.(succ root)
  >>=? fun () ->
  (* listings must be populated in testing_vote period *)
  Context.Vote.get_listings (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty listings" __LOC__
         | _ ->
             return_unit)
  >>=? fun () ->
  (* beginning of testing_vote period, denoted by _p2;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p2, rolls_p2) ->
  (* no proposals during testing_vote period *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  ( if Environment.Protocol_hash.Map.is_empty ps then return_unit
  else failwith "%s - Unexpected proposals" __LOC__ )
  >>=? fun () ->
  (* current proposal must be set during testing_vote period *)
  Context.Vote.get_current_proposal (B b)
  >>=? (function
         | Some v ->
             if Protocol_hash.(equal zero v) then return_unit
             else failwith "%s - Wrong proposal" __LOC__
         | None ->
             failwith "%s - Missing proposal" __LOC__)
  >>=? fun () ->
  (* unanimous vote: all delegates --active when p2 started-- vote *)
  map_s
    (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
    delegates_p2
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  Op.ballot (B b) del1 Protocol_hash.zero Vote.Nay
  >>=? fun op ->
  Block.bake ~operations:[op] b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Amendment.Unauthorized_ballot ->
          true
      | _ ->
          false)
  >>=? fun () ->
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls_p2
  >>=? fun rolls_sum ->
  (* # of Yays in ballots matches rolls of the delegate *)
  Context.Vote.get_ballots (B b)
  >>=? fun v ->
  Assert.equal
    ~loc:__LOC__
    ballots_equal
    "Unexpected ballots"
    ballots_pp
    v
    Vote.{yay = rolls_sum; nay = 0l; pass = 0l}
  >>=? fun () ->
  (* One Yay ballot per delegate *)
  Context.Vote.get_ballot_list (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty ballot list" __LOC__
         | l ->
             iter_s
               (fun delegate ->
                 Context.Contract.pkh delegate
                 >>=? fun pkh ->
                 match List.find_opt (fun (del, _) -> del = pkh) l with
                 | None ->
                     failwith "%s - Missing delegate" __LOC__
                 | Some (_, Vote.Yay) ->
                     return_unit
                 | Some _ ->
                     failwith "%s - Wrong ballot" __LOC__)
               delegates_p2)
  >>=? fun () ->
  (* skip to testing period
     -1 because we already baked one block with the ballot *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* period 2 *)
  Context.Vote.get_voting_period (B b)
  >>=? fun v ->
  let open Alpha_context in
  Assert.equal
    ~loc:__LOC__
    Voting_period.equal
    "Unexpected period"
    Voting_period.pp
    v
    Voting_period.(succ (succ root))
  >>=? fun () ->
  (* no ballots in testing period *)
  Context.Vote.get_ballots (B b)
  >>=? fun v ->
  Assert.equal
    ~loc:__LOC__
    ballots_equal
    "Unexpected ballots"
    ballots_pp
    v
    ballots_zero
  >>=? fun () ->
  (* listings must be empty in testing period *)
  Context.Vote.get_listings (B b)
  >>=? (function
         | [] -> return_unit | _ -> failwith "%s - Unexpected listings" __LOC__)
  >>=? fun () ->
  (* skip to promotion_vote period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period) b
  >>=? fun b ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Promotion_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* period 3 *)
  Context.Vote.get_voting_period (B b)
  >>=? fun v ->
  let open Alpha_context in
  Assert.equal
    ~loc:__LOC__
    Voting_period.equal
    "Unexpected period"
    Voting_period.pp
    v
    Voting_period.(succ (succ (succ root)))
  >>=? fun () ->
  (* listings must be populated in promotion_vote period *)
  Context.Vote.get_listings (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty listings" __LOC__
         | _ ->
             return_unit)
  >>=? fun () ->
  (* beginning of promotion_vote period, denoted by _p4;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p4, rolls_p4) ->
  (* no proposals during promotion_vote period *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  ( if Environment.Protocol_hash.Map.is_empty ps then return_unit
  else failwith "%s - Unexpected proposals" __LOC__ )
  >>=? fun () ->
  (* current proposal must be set during promotion_vote period *)
  Context.Vote.get_current_proposal (B b)
  >>=? (function
         | Some v ->
             if Protocol_hash.(equal zero v) then return_unit
             else failwith "%s - Wrong proposal" __LOC__
         | None ->
             failwith "%s - Missing proposal" __LOC__)
  >>=? fun () ->
  (* unanimous vote: all delegates --active when p4 started-- vote *)
  map_s
    (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
    delegates_p4
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls_p4
  >>=? fun rolls_sum ->
  (* # of Yays in ballots matches rolls of the delegate *)
  Context.Vote.get_ballots (B b)
  >>=? fun v ->
  Assert.equal
    ~loc:__LOC__
    ballots_equal
    "Unexpected ballots"
    ballots_pp
    v
    Vote.{yay = rolls_sum; nay = 0l; pass = 0l}
  >>=? fun () ->
  (* One Yay ballot per delegate *)
  Context.Vote.get_ballot_list (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty ballot list" __LOC__
         | l ->
             iter_s
               (fun delegate ->
                 Context.Contract.pkh delegate
                 >>=? fun pkh ->
                 match List.find_opt (fun (del, _) -> del = pkh) l with
                 | None ->
                     failwith "%s - Missing delegate" __LOC__
                 | Some (_, Vote.Yay) ->
                     return_unit
                 | Some _ ->
                     failwith "%s - Wrong ballot" __LOC__)
               delegates_p4)
  >>=? fun () ->
  (* skip to end of promotion_vote period and activation*)
  Block.bake_n Int32.(to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* zero is the new protocol (before the vote this value is unset) *)
  Context.Vote.get_protocol b
  >>= fun p ->
  Assert.equal
    ~loc:__LOC__
    Protocol_hash.equal
    "Unexpected proposal"
    Protocol_hash.pp
    p
    Protocol_hash.zero
  >>=? fun () -> return_unit

(* given a list of active delegates,
   return the first k active delegates with which one can have quorum, that is:
   their roll sum divided by the total roll sum is bigger than pr_ema_weight/den *)
let get_smallest_prefix_voters_for_quorum active_delegates active_rolls =
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l active_rolls
  >>=? fun active_rolls_sum ->
  let rec loop delegates rolls sum selected =
    match (delegates, rolls) with
    | ([], []) ->
        selected
    | (del :: delegates, del_rolls :: rolls) ->
        if
          den * sum
          < Float.to_int (expected_qr_num *. Int32.to_float active_rolls_sum)
        then
          loop delegates rolls (sum + Int32.to_int del_rolls) (del :: selected)
        else selected
    | (_, _) ->
        []
  in
  return (loop active_delegates active_rolls 0 [])

let get_expected_participation_ema rolls voter_rolls old_participation_ema =
  (* formula to compute the updated participation_ema *)
  let get_updated_participation_ema old_participation_ema participation =
    ( (pr_ema_weight * Int32.to_int old_participation_ema)
    + (pr_num * participation) )
    / den
  in
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls
  >>=? fun rolls_sum ->
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l voter_rolls
  >>=? fun voter_rolls_sum ->
  let participation =
    Int32.to_int voter_rolls_sum * percent_mul / Int32.to_int rolls_sum
  in
  return (get_updated_participation_ema old_participation_ema participation)

(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in testing vote,
   go back to proposal period *)
let test_not_enough_quorum_in_testing_vote num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  (* proposal period *)
  let open Alpha_context in
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  let proposer = List.nth delegates 0 in
  Op.proposals (B b) proposer [Protocol_hash.zero]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* skip to vote_testing period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  Context.Vote.get_participation_ema b
  >>=? fun initial_participation_ema ->
  (* beginning of testing_vote period, denoted by _p2;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p2, rolls_p2) ->
  get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2
  >>=? fun voters ->
  (* take the first two voters out so there cannot be quorum *)
  let voters_without_quorum = List.tl voters in
  get_rolls b voters_without_quorum __LOC__
  >>=? fun voters_rolls_in_testing_vote ->
  (* all voters_without_quorum vote, for yays;
     no nays, so supermajority is satisfied *)
  map_s
    (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
    voters_without_quorum
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to testing period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we move back to the proposal period because not enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* check participation_ema update *)
  get_expected_participation_ema
    rolls_p2
    voters_rolls_in_testing_vote
    initial_participation_ema
  >>=? fun expected_participation_ema ->
  Context.Vote.get_participation_ema b
  >>=? fun new_participation_ema ->
  (* assert the formula to calculate participation_ema is correct *)
  Assert.equal_int
    ~loc:__LOC__
    expected_participation_ema
    (Int32.to_int new_participation_ema)
  >>=? fun () -> return_unit

(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in promotion vote,
   go back to proposal period *)
let test_not_enough_quorum_in_promotion_vote num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  let proposer = List.nth delegates 0 in
  Op.proposals (B b) proposer [Protocol_hash.zero]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* skip to vote_testing period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* beginning of testing_vote period, denoted by _p2;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p2, rolls_p2) ->
  get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2
  >>=? fun voters ->
  let open Alpha_context in
  (* all voters vote, for yays;
       no nays, so supermajority is satisfied *)
  map_s (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to testing period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we move to testing because we have supermajority and enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* skip to promotion_vote period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period) b
  >>=? fun b ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Promotion_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  Context.Vote.get_participation_ema b
  >>=? fun initial_participation_ema ->
  (* beginning of promotion period, denoted by _p4;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p4, rolls_p4) ->
  get_smallest_prefix_voters_for_quorum delegates_p4 rolls_p4
  >>=? fun voters ->
  (* take the first voter out so there cannot be quorum *)
  let voters_without_quorum = List.tl voters in
  get_rolls b voters_without_quorum __LOC__
  >>=? fun voter_rolls ->
  (* all voters_without_quorum vote, for yays;
     no nays, so supermajority is satisfied *)
  map_s
    (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
    voters_without_quorum
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to end of promotion_vote period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  get_expected_participation_ema rolls_p4 voter_rolls initial_participation_ema
  >>=? fun expected_participation_ema ->
  Context.Vote.get_participation_ema b
  >>=? fun new_participation_ema ->
  (* assert the formula to calculate participation_ema is correct *)
  Assert.equal_int
    ~loc:__LOC__
    expected_participation_ema
    (Int32.to_int new_participation_ema)
  >>=? fun () ->
  (* we move back to the proposal period because not enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

let test_multiple_identical_proposals_count_as_one () =
  Context.init 1
  >>=? fun (b, delegates) ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  let proposer = List.hd delegates in
  Op.proposals (B b) proposer [Protocol_hash.zero; Protocol_hash.zero]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* compute the weight of proposals *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  (* compute the rolls of proposer *)
  Context.Contract.pkh proposer
  >>=? fun pkh ->
  Context.Vote.get_listings (B b)
  >>=? fun l ->
  ( match List.find_opt (fun (del, _) -> del = pkh) l with
  | None ->
      failwith "%s - Missing delegate" __LOC__
  | Some (_, proposer_rolls) ->
      return proposer_rolls )
  >>=? fun proposer_rolls ->
  (* correctly count the double proposal for zero as one proposal *)
  let expected_weight_proposer = proposer_rolls in
  match Environment.Protocol_hash.(Map.find_opt zero ps) with
  | Some v ->
      if v = expected_weight_proposer then return_unit
      else
        failwith
          "%s - Wrong count %ld is not %ld; identical proposals count as one"
          __LOC__
          v
          expected_weight_proposer
  | None ->
      failwith "%s - Missing proposal" __LOC__

(* assumes the initial balance of allocated by Context.init is at
   least 4 time the value of the tokens_per_roll constant *)
let test_supermajority_in_proposal there_is_a_winner () =
  let min_proposal_quorum = 0l in
  Context.init ~min_proposal_quorum ~initial_balances:[1L; 1L; 1L] 10
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun { parametric =
               {blocks_per_cycle; blocks_per_voting_period; tokens_per_roll; _};
             _ } ->
  let del1 = List.nth delegates 0 in
  let del2 = List.nth delegates 1 in
  let del3 = List.nth delegates 2 in
  map_s (fun del -> Context.Contract.pkh del) [del1; del2; del3]
  >>=? fun pkhs ->
  let policy = Block.Excluding pkhs in
  Op.transaction (B b) (List.nth delegates 3) del1 tokens_per_roll
  >>=? fun op1 ->
  Op.transaction (B b) (List.nth delegates 4) del2 tokens_per_roll
  >>=? fun op2 ->
  ( if there_is_a_winner then Test_tez.Tez.( *? ) tokens_per_roll 3L
  else Test_tez.Tez.( *? ) tokens_per_roll 2L )
  >>?= fun bal3 ->
  Op.transaction (B b) (List.nth delegates 5) del3 bal3
  >>=? fun op3 ->
  Block.bake ~policy ~operations:[op1; op2; op3] b
  >>=? fun b ->
  (* we let one voting period pass; we make sure that:
     - the three selected delegates remain active by re-registering as delegates
     - their number of rolls do not change *)
  fold_left_s
    (fun b _ ->
      Error_monad.map_s
        (fun del ->
          Context.Contract.pkh del
          >>=? fun pkh -> Op.delegation (B b) del (Some pkh))
        delegates
      >>=? fun ops ->
      Block.bake ~policy ~operations:ops b
      >>=? fun b -> Block.bake_until_cycle_end ~policy b)
    b
    (1 -- Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle))
  >>=? fun b ->
  (* make the proposals *)
  Op.proposals (B b) del1 [protos.(0)]
  >>=? fun ops1 ->
  Op.proposals (B b) del2 [protos.(0)]
  >>=? fun ops2 ->
  Op.proposals (B b) del3 [protos.(1)]
  >>=? fun ops3 ->
  Block.bake ~policy ~operations:[ops1; ops2; ops3] b
  >>=? fun b ->
  Block.bake_n ~policy (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we remain in the proposal period when there is no winner,
     otherwise we move to the testing vote period *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             if there_is_a_winner then return_unit
             else
               failwith
                 "%s - Expected period kind Proposal, obtained Testing_vote"
                 __LOC__
         | Proposal ->
             if not there_is_a_winner then return_unit
             else
               failwith
                 "%s - Expected period kind Testing_vote, obtained Proposal"
                 __LOC__
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

let test_quorum_in_proposal has_quorum () =
  let total_tokens = 32_000_000_000_000L in
  let half_tokens = Int64.div total_tokens 2L in
  Context.init ~initial_balances:[1L; half_tokens; half_tokens] 3
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun { parametric =
               { blocks_per_cycle;
                 blocks_per_voting_period;
                 min_proposal_quorum;
                 _ };
             _ } ->
  let del1 = List.nth delegates 0 in
  let del2 = List.nth delegates 1 in
  map_s (fun del -> Context.Contract.pkh del) [del1; del2]
  >>=? fun pkhs ->
  let policy = Block.Excluding pkhs in
  let quorum =
    if has_quorum then Int64.of_int32 min_proposal_quorum
    else Int64.(sub (of_int32 min_proposal_quorum) 10L)
  in
  let bal =
    Int64.(div (mul total_tokens quorum) 100_00L) |> Test_tez.Tez.of_mutez_exn
  in
  Op.transaction (B b) del2 del1 bal
  >>=? fun op2 ->
  Block.bake ~policy ~operations:[op2] b
  >>=? fun b ->
  (* we let one voting period pass; we make sure that:
     - the two selected delegates remain active by re-registering as delegates
     - their number of rolls do not change *)
  fold_left_s
    (fun b _ ->
      Error_monad.map_s
        (fun del ->
          Context.Contract.pkh del
          >>=? fun pkh -> Op.delegation (B b) del (Some pkh))
        [del1; del2]
      >>=? fun ops ->
      Block.bake ~policy ~operations:ops b
      >>=? fun b -> Block.bake_until_cycle_end ~policy b)
    b
    (1 -- Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle))
  >>=? fun b ->
  (* make the proposal *)
  Op.proposals (B b) del1 [protos.(0)]
  >>=? fun ops ->
  Block.bake ~policy ~operations:[ops] b
  >>=? fun b ->
  Block.bake_n ~policy (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we remain in the proposal period when there is no quorum,
     otherwise we move to the testing vote period *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             if has_quorum then return_unit
             else
               failwith
                 "%s - Expected period kind Proposal, obtained Testing_vote"
                 __LOC__
         | Proposal ->
             if not has_quorum then return_unit
             else
               failwith
                 "%s - Expected period kind Testing_vote, obtained Proposal"
                 __LOC__
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

let test_supermajority_in_testing_vote supermajority () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / 100)) in
  Context.init ~min_proposal_quorum 100
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  let del1 = List.nth delegates 0 in
  let proposal = protos.(0) in
  Op.proposals (B b) del1 [proposal]
  >>=? fun ops1 ->
  Block.bake ~operations:[ops1] b
  >>=? fun b ->
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* move to testing_vote *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* assert our proposal won *)
  Context.Vote.get_current_proposal (B b)
  >>=? (function
         | Some v ->
             if Protocol_hash.(equal proposal v) then return_unit
             else failwith "%s - Wrong proposal" __LOC__
         | None ->
             failwith "%s - Missing proposal" __LOC__)
  >>=? fun () ->
  (* beginning of testing_vote period, denoted by _p2;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p2, _olls_p2) ->
  (* supermajority means [num_yays / (num_yays + num_nays) >= s_num / s_den],
     which is equivalent with [num_yays >= num_nays * s_num / (s_den - s_num)] *)
  let num_delegates = List.length delegates_p2 in
  let num_nays = num_delegates / 5 in
  (* any smaller number will do as well *)
  let num_yays = num_nays * s_num / (s_den - s_num) in
  (* majority/minority vote depending on the [supermajority] parameter *)
  let num_yays = if supermajority then num_yays else num_yays - 1 in
  let open Alpha_context in
  let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in
  let (yays_delegates, _) = List.split_n num_yays rest in
  map_s (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates
  >>=? fun operations_yays ->
  map_s (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates
  >>=? fun operations_nays ->
  let operations = operations_yays @ operations_nays in
  Block.bake ~operations b
  >>=? fun b ->
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing ->
             if supermajority then return_unit
             else
               failwith
                 "%s - Expected period kind Proposal, obtained Testing"
                 __LOC__
         | Proposal ->
             if not supermajority then return_unit
             else
               failwith
                 "%s - Expected period kind Testing_vote, obtained Proposal"
                 __LOC__
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

(* test also how the selection scales: all delegates propose max proposals *)
let test_no_winning_proposal num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  (* beginning of proposal, denoted by _p1;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p1, _rolls_p1) ->
  let open Alpha_context in
  let props =
    List.map (fun i -> protos.(i)) (1 -- Constants.max_proposals_per_delegate)
  in
  (* all delegates active in p1 propose the same proposals *)
  map_s (fun del -> Op.proposals (B b) del props) delegates_p1
  >>=? fun ops_list ->
  Block.bake ~operations:ops_list b
  >>=? fun b ->
  (* skip to testing_vote period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
  >>=? fun b ->
  (* we stay in the same proposal period because no winning proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

(** Test that for the vote to pass with maximum possible participation_ema
    (100%), it is sufficient for the vote quorum to be equal or greater than
    the maximum quorum cap. *)
let test_quorum_capped_maximum num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, delegates) ->
  (* set the participation EMA to 100% *)
  Context.Vote.set_participation_ema b 100_00l
  >>= fun b ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; quorum_max; _}; _} ->
  (* proposal period *)
  let open Alpha_context in
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* propose a new protocol *)
  let protocol = Protocol_hash.zero in
  let proposer = List.nth delegates 0 in
  Op.proposals (B b) proposer [protocol]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* skip to vote_testing period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* take percentage of the delegates equal or greater than quorum_max *)
  let minimum_to_pass =
    Float.of_int (List.length delegates)
    *. Int32.(to_float quorum_max)
    /. 100_00.
    |> Float.ceil |> Float.to_int
  in
  let voters = List.take_n minimum_to_pass delegates in
  (* all voters vote for yays; no nays, so supermajority is satisfied *)
  map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to next period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* expect to move to testing because we have supermajority and enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? function
  | Testing ->
      return_unit
  | _ ->
      failwith "%s - Unexpected period kind" __LOC__

(** Test that for the vote to pass with minimum possible participation_ema
    (0%), it is sufficient for the vote quorum to be equal or greater than
    the minimum quorum cap. *)
let test_quorum_capped_minimum num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, delegates) ->
  (* set the participation EMA to 0% *)
  Context.Vote.set_participation_ema b 0l
  >>= fun b ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; quorum_min; _}; _} ->
  (* proposal period *)
  let open Alpha_context in
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* propose a new protocol *)
  let protocol = Protocol_hash.zero in
  let proposer = List.nth delegates 0 in
  Op.proposals (B b) proposer [protocol]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* skip to vote_testing period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* take percentage of the delegates equal or greater than quorum_min *)
  let minimum_to_pass =
    Float.of_int (List.length delegates)
    *. Int32.(to_float quorum_min)
    /. 100_00.
    |> Float.ceil |> Float.to_int
  in
  let voters = List.take_n minimum_to_pass delegates in
  (* all voters vote for yays; no nays, so supermajority is satisfied *)
  map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to next period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* expect to move to testing because we have supermajority and enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? function
  | Testing ->
      return_unit
  | _ ->
      failwith "%s - Unexpected period kind" __LOC__

let tests =
  [ Test.tztest "voting successful_vote" `Quick (test_successful_vote 137);
    Test.tztest
      "voting testing vote, not enough quorum"
      `Quick
      (test_not_enough_quorum_in_testing_vote 245);
    Test.tztest
      "voting promotion vote, not enough quorum"
      `Quick
      (test_not_enough_quorum_in_promotion_vote 432);
    Test.tztest
      "voting counting double proposal"
      `Quick
      test_multiple_identical_proposals_count_as_one;
    Test.tztest
      "voting proposal, with supermajority"
      `Quick
      (test_supermajority_in_proposal true);
    Test.tztest
      "voting proposal, without supermajority"
      `Quick
      (test_supermajority_in_proposal false);
    Test.tztest
      "voting proposal, with quorum"
      `Quick
      (test_quorum_in_proposal true);
    Test.tztest
      "voting proposal, without quorum"
      `Quick
      (test_quorum_in_proposal false);
    Test.tztest
      "voting testing vote, with supermajority"
      `Quick
      (test_supermajority_in_testing_vote true);
    Test.tztest
      "voting testing vote, without supermajority"
      `Quick
      (test_supermajority_in_testing_vote false);
    Test.tztest
      "voting proposal, no winning proposal"
      `Quick
      (test_no_winning_proposal 400);
    Test.tztest
      "voting quorum, quorum capped maximum"
      `Quick
      (test_quorum_capped_maximum 400);
    Test.tztest
      "voting quorum, quorum capped minimum"
      `Quick
      (test_quorum_capped_minimum 401) ]
src/proto_alpha/lib_protocol/test/voting.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_alpha.Protocol.

Definition ballots_zero
  : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots :=
  {| yay := 0; nay := 0; pass := 0 |}.

Definition ballots_equal
  (b1 : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots)
  (b2 : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots) : bool :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
    (op_star_t_y_p_e_minus_e_r_r_o_r_star (yay b1) (yay b2))
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_and_and
      (op_star_t_y_p_e_minus_e_r_r_o_r_star (nay b1) (nay b2))
      (op_star_t_y_p_e_minus_e_r_r_o_r_star (pass b1) (pass b2))).

Definition ballots_pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (v : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots) : unit :=
  Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "{ yay = " % string
        (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal " ; nay = " % string
            (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " ; pass = " % string
                (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))))))
      "{ yay = %ld ; nay = %ld ; pass = %ld" % string) (yay v) (nay v) (pass v).

Definition percent_mul : Z := 10000.

Definition initial_participation_num : Z := 7.

Definition initial_participation : Z :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
    (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
      initial_participation_num percent_mul) 10.

Definition pr_ema_weight : Z := 8.

Definition den : Z := 10.

Definition pr_num : Z :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus den
    pr_ema_weight.

Definition s_num : Z := 8.

Definition s_den : Z := 10.

Definition qr_min_num : Z := 2.

Definition qr_max_num : Z := 7.

Definition expected_qr_num {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star.

Definition protos {A : Type} : A :=
  op_star_t_y_p_e_minus_e_r_r_o_r_star
    (fun s =>
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.of_b58check_exn)
        s)
    ("ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx" % string,
      "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX" % string).

Definition mk_contracts_from_pkh
  (pkh_list : list Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  : list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract :=
  Tezos_protocol_environment_alpha__Environment.List.map
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.implicit_contract
    pkh_list.

Definition get_delegates_and_rolls_from_listings {A B : Type} (b : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) *
        (list B))) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star)
    (fun l =>
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        ((mk_contracts_from_pkh
          (Tezos_protocol_environment_alpha__Environment.List.map
            Tezos_protocol_environment_alpha__Environment.Pervasives.fst l)),
          (Tezos_protocol_environment_alpha__Environment.List.map
            Tezos_protocol_environment_alpha__Environment.Pervasives.snd l))).

Definition get_rolls {A B C D : Type} (b : A) (delegates : list B) (loc : C)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list D)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (op_star_t_y_p_e_minus_e_r_r_o_r_star op_star_t_y_p_e_minus_e_r_r_o_r_star)
    (fun l =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
        (fun delegate =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star delegate)
            (fun pkh =>
              match
                Tezos_protocol_environment_alpha__Environment.List.find_opt
                  (fun function_parameter =>
                    match function_parameter with
                    | (del, _) => op_star_t_y_p_e_minus_e_r_r_o_r_star del pkh
                    end) l with
              | None =>
                Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                  "%s - Missing delegate" % string loc
              | Some (_, rolls) =>
                Tezos_protocol_environment_alpha__Environment.Error_monad._return
                  rolls
              end)) delegates).

Definition test_successful_vote (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let min_proposal_quorum :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Int32.of_int
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div 10000
          num_delegates) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star min_proposal_quorum num_delegates)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                  (fun v =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                        ballots_equal "Unexpected ballots" % string ballots_pp v
                        ballots_zero)
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                              (fun function_parameter =>
                                match function_parameter with
                                | [] =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                | _ =>
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                    "%s - Unexpected ballot list" % string
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                end))
                            (fun function_parameter =>
                              match function_parameter with
                              | tt =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                  (fun v =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.equal
                                        "Unexpected period" % string
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.pp
                                        v
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.root)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | tt =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | _ =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                | _ =>
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                    "%s - Unexpected period kind"
                                                      % string
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                end))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              | tt =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    b)
                                                  (fun v =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                        initial_participation
                                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                          v))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | tt =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | [] =>
                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                    "%s - Unexpected empty listings"
                                                                      % string
                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                | _ =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                end))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              match
                                                                function_parameter
                                                                with
                                                              | tt =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (get_delegates_and_rolls_from_listings
                                                                    b)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    |
                                                                      (delegates_p1,
                                                                        rolls_p1)
                                                                      =>
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                        (fun ps
                                                                          =>
                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                            (if
                                                                              Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.is_empty
                                                                                ps
                                                                              then
                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                            else
                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                "%s - Unexpected proposals"
                                                                                  %
                                                                                  string
                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                tt
                                                                                =>
                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        None
                                                                                        =>
                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                      |
                                                                                        Some
                                                                                          _
                                                                                        =>
                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                          "%s - Unexpected proposal"
                                                                                            %
                                                                                            string
                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                      end))
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    match
                                                                                      function_parameter
                                                                                      with
                                                                                    |
                                                                                      tt
                                                                                      =>
                                                                                      let
                                                                                        del1 :=
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          delegates_p1
                                                                                          0
                                                                                        in
                                                                                      let
                                                                                        del2 :=
                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          delegates_p1
                                                                                          1
                                                                                        in
                                                                                      let
                                                                                        props :=
                                                                                        Tezos_protocol_environment_alpha__Environment.List.map
                                                                                          (fun
                                                                                            i
                                                                                            =>
                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              protos
                                                                                              i)
                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                            2
                                                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Constants.max_proposals_per_delegate)
                                                                                        in
                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                          del1
                                                                                          (cons
                                                                                            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                            props))
                                                                                        (fun
                                                                                          ops1
                                                                                          =>
                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                              del2
                                                                                              (cons
                                                                                                Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                []))
                                                                                            (fun
                                                                                              ops2
                                                                                              =>
                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                  (cons
                                                                                                    ops1
                                                                                                    (cons
                                                                                                      ops2
                                                                                                      []))
                                                                                                  b)
                                                                                                (fun
                                                                                                  b
                                                                                                  =>
                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                    (fun
                                                                                                      ps
                                                                                                      =>
                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                        (let
                                                                                                          weight :=
                                                                                                          Tezos_protocol_environment_alpha__Environment.Int32.add
                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              rolls_p1
                                                                                                              0)
                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              rolls_p1
                                                                                                              1)
                                                                                                          in
                                                                                                        match
                                                                                                          Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.find_opt
                                                                                                            Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.zero
                                                                                                            ps
                                                                                                          with
                                                                                                        |
                                                                                                          Some
                                                                                                            v
                                                                                                          =>
                                                                                                          if
                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                              v
                                                                                                              weight
                                                                                                            then
                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                          else
                                                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                              "%s - Wrong count %ld is not %ld"
                                                                                                                %
                                                                                                                string
                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                              v
                                                                                                              weight
                                                                                                        |
                                                                                                          None
                                                                                                          =>
                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                            "%s - Missing proposal"
                                                                                                              %
                                                                                                              string
                                                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                        end)
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          match
                                                                                                            function_parameter
                                                                                                            with
                                                                                                          |
                                                                                                            tt
                                                                                                            =>
                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                del1
                                                                                                                (cons
                                                                                                                  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                  props))
                                                                                                              (fun
                                                                                                                ops
                                                                                                                =>
                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    (cons
                                                                                                                      ops
                                                                                                                      [])
                                                                                                                    b)
                                                                                                                  (fun
                                                                                                                    res
                                                                                                                    =>
                                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                        res
                                                                                                                        (fun
                                                                                                                          function_parameter
                                                                                                                          =>
                                                                                                                          match
                                                                                                                            function_parameter
                                                                                                                            with
                                                                                                                          |
                                                                                                                            Amendment.Too_many_proposals
                                                                                                                            =>
                                                                                                                            true
                                                                                                                          |
                                                                                                                            _
                                                                                                                            =>
                                                                                                                            false
                                                                                                                          end))
                                                                                                                      (fun
                                                                                                                        function_parameter
                                                                                                                        =>
                                                                                                                        match
                                                                                                                          function_parameter
                                                                                                                          with
                                                                                                                        |
                                                                                                                          tt
                                                                                                                          =>
                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                              del1
                                                                                                                              [])
                                                                                                                            (fun
                                                                                                                              ops
                                                                                                                              =>
                                                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                  (cons
                                                                                                                                    ops
                                                                                                                                    [])
                                                                                                                                  b)
                                                                                                                                (fun
                                                                                                                                  res
                                                                                                                                  =>
                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                      res
                                                                                                                                      (fun
                                                                                                                                        function_parameter
                                                                                                                                        =>
                                                                                                                                        match
                                                                                                                                          function_parameter
                                                                                                                                          with
                                                                                                                                        |
                                                                                                                                          Amendment.Empty_proposal
                                                                                                                                          =>
                                                                                                                                          true
                                                                                                                                        |
                                                                                                                                          _
                                                                                                                                          =>
                                                                                                                                          false
                                                                                                                                        end))
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      match
                                                                                                                                        function_parameter
                                                                                                                                        with
                                                                                                                                      |
                                                                                                                                        tt
                                                                                                                                        =>
                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                                                                                                              (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                              2)
                                                                                                                                            b)
                                                                                                                                          (fun
                                                                                                                                            b
                                                                                                                                            =>
                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  match
                                                                                                                                                    function_parameter
                                                                                                                                                    with
                                                                                                                                                  |
                                                                                                                                                    _
                                                                                                                                                    =>
                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                  |
                                                                                                                                                    _
                                                                                                                                                    =>
                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                      "%s - Unexpected period kind"
                                                                                                                                                        %
                                                                                                                                                        string
                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                  end))
                                                                                                                                              (fun
                                                                                                                                                function_parameter
                                                                                                                                                =>
                                                                                                                                                match
                                                                                                                                                  function_parameter
                                                                                                                                                  with
                                                                                                                                                |
                                                                                                                                                  tt
                                                                                                                                                  =>
                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                    (fun
                                                                                                                                                      v
                                                                                                                                                      =>
                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.equal
                                                                                                                                                          "Unexpected period"
                                                                                                                                                            %
                                                                                                                                                            string
                                                                                                                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.pp
                                                                                                                                                          v
                                                                                                                                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.succ
                                                                                                                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.root))
                                                                                                                                                        (fun
                                                                                                                                                          function_parameter
                                                                                                                                                          =>
                                                                                                                                                          match
                                                                                                                                                            function_parameter
                                                                                                                                                            with
                                                                                                                                                          |
                                                                                                                                                            tt
                                                                                                                                                            =>
                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                (fun
                                                                                                                                                                  function_parameter
                                                                                                                                                                  =>
                                                                                                                                                                  match
                                                                                                                                                                    function_parameter
                                                                                                                                                                    with
                                                                                                                                                                  |
                                                                                                                                                                    []
                                                                                                                                                                    =>
                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                      "%s - Unexpected empty listings"
                                                                                                                                                                        %
                                                                                                                                                                        string
                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                  |
                                                                                                                                                                    _
                                                                                                                                                                    =>
                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                  end))
                                                                                                                                                              (fun
                                                                                                                                                                function_parameter
                                                                                                                                                                =>
                                                                                                                                                                match
                                                                                                                                                                  function_parameter
                                                                                                                                                                  with
                                                                                                                                                                |
                                                                                                                                                                  tt
                                                                                                                                                                  =>
                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                    (get_delegates_and_rolls_from_listings
                                                                                                                                                                      b)
                                                                                                                                                                    (fun
                                                                                                                                                                      function_parameter
                                                                                                                                                                      =>
                                                                                                                                                                      match
                                                                                                                                                                        function_parameter
                                                                                                                                                                        with
                                                                                                                                                                      |
                                                                                                                                                                        (delegates_p2,
                                                                                                                                                                          rolls_p2)
                                                                                                                                                                        =>
                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                          (fun
                                                                                                                                                                            ps
                                                                                                                                                                            =>
                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                              (if
                                                                                                                                                                                Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.is_empty
                                                                                                                                                                                  ps
                                                                                                                                                                                then
                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                              else
                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                  "%s - Unexpected proposals"
                                                                                                                                                                                    %
                                                                                                                                                                                    string
                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__)
                                                                                                                                                                              (fun
                                                                                                                                                                                function_parameter
                                                                                                                                                                                =>
                                                                                                                                                                                match
                                                                                                                                                                                  function_parameter
                                                                                                                                                                                  with
                                                                                                                                                                                |
                                                                                                                                                                                  tt
                                                                                                                                                                                  =>
                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                      (fun
                                                                                                                                                                                        function_parameter
                                                                                                                                                                                        =>
                                                                                                                                                                                        match
                                                                                                                                                                                          function_parameter
                                                                                                                                                                                          with
                                                                                                                                                                                        |
                                                                                                                                                                                          Some
                                                                                                                                                                                            v
                                                                                                                                                                                          =>
                                                                                                                                                                                          if
                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                                                              v
                                                                                                                                                                                            then
                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                          else
                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                              "%s - Wrong proposal"
                                                                                                                                                                                                %
                                                                                                                                                                                                string
                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                        |
                                                                                                                                                                                          None
                                                                                                                                                                                          =>
                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                            "%s - Missing proposal"
                                                                                                                                                                                              %
                                                                                                                                                                                              string
                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                        end))
                                                                                                                                                                                    (fun
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      =>
                                                                                                                                                                                      match
                                                                                                                                                                                        function_parameter
                                                                                                                                                                                        with
                                                                                                                                                                                      |
                                                                                                                                                                                        tt
                                                                                                                                                                                        =>
                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                                                                                                                                                            (fun
                                                                                                                                                                                              del
                                                                                                                                                                                              =>
                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                del
                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                                                                Vote.Yay)
                                                                                                                                                                                            delegates_p2)
                                                                                                                                                                                          (fun
                                                                                                                                                                                            operations
                                                                                                                                                                                            =>
                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                operations
                                                                                                                                                                                                b)
                                                                                                                                                                                              (fun
                                                                                                                                                                                                b
                                                                                                                                                                                                =>
                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                    del1
                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                                                                    Vote.Nay)
                                                                                                                                                                                                  (fun
                                                                                                                                                                                                    op
                                                                                                                                                                                                    =>
                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                        (cons
                                                                                                                                                                                                          op
                                                                                                                                                                                                          [])
                                                                                                                                                                                                        b)
                                                                                                                                                                                                      (fun
                                                                                                                                                                                                        res
                                                                                                                                                                                                        =>
                                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                            res
                                                                                                                                                                                                            (fun
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              match
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                with
                                                                                                                                                                                                              |
                                                                                                                                                                                                                Amendment.Unauthorized_ballot
                                                                                                                                                                                                                =>
                                                                                                                                                                                                                true
                                                                                                                                                                                                              |
                                                                                                                                                                                                                _
                                                                                                                                                                                                                =>
                                                                                                                                                                                                                false
                                                                                                                                                                                                              end))
                                                                                                                                                                                                          (fun
                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                            =>
                                                                                                                                                                                                            match
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              with
                                                                                                                                                                                                            |
                                                                                                                                                                                                              tt
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                    v
                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                    fun
                                                                                                                                                                                                                      acc
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                                                                                                                                                                                        (Tezos_protocol_environment_alpha__Environment.Int32.add
                                                                                                                                                                                                                          v
                                                                                                                                                                                                                          acc))
                                                                                                                                                                                                                  0
                                                                                                                                                                                                                  rolls_p2)
                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                  rolls_sum
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                      v
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                          ballots_equal
                                                                                                                                                                                                                          "Unexpected ballots"
                                                                                                                                                                                                                            %
                                                                                                                                                                                                                            string
                                                                                                                                                                                                                          ballots_pp
                                                                                                                                                                                                                          v
                                                                                                                                                                                                                          {|
                                                                                                                                                                                                                            yay :=
                                                                                                                                                                                                                              rolls_sum;
                                                                                                                                                                                                                            nay :=
                                                                                                                                                                                                                              0;
                                                                                                                                                                                                                            pass :=
                                                                                                                                                                                                                              0
                                                                                                                                                                                                                            |})
                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          match
                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                            with
                                                                                                                                                                                                                          |
                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                    []
                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                      "%s - Unexpected empty ballot list"
                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                    l
                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.iter_s
                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                        delegate
                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                            delegate)
                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                            pkh
                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.List.find_opt
                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                    (del,
                                                                                                                                                                                                                                                      _)
                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                      del
                                                                                                                                                                                                                                                      pkh
                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                l
                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                              None
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                "%s - Missing delegate"
                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                              Some
                                                                                                                                                                                                                                                (_,
                                                                                                                                                                                                                                                  Vote.Yay)
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                              Some
                                                                                                                                                                                                                                                _
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                "%s - Wrong ballot"
                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                            end))
                                                                                                                                                                                                                                      delegates_p2
                                                                                                                                                                                                                                  end))
                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                                                                                                                                                                                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                        1)
                                                                                                                                                                                                                                      b)
                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                      b
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                              _
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                              _
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                "%s - Unexpected period kind"
                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                            end))
                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                v
                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                    Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.equal
                                                                                                                                                                                                                                                    "Unexpected period"
                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                    Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.pp
                                                                                                                                                                                                                                                    v
                                                                                                                                                                                                                                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.succ
                                                                                                                                                                                                                                                      (Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.succ
                                                                                                                                                                                                                                                        Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.root)))
                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                          v
                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                              ballots_equal
                                                                                                                                                                                                                                                              "Unexpected ballots"
                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                              ballots_pp
                                                                                                                                                                                                                                                              v
                                                                                                                                                                                                                                                              ballots_zero)
                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                        []
                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                        _
                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                          "%s - Unexpected listings"
                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                      end))
                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                          (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                          b)
                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                          b
                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                  _
                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                  _
                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                                    "%s - Unexpected period kind"
                                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                end))
                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                    v
                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                        Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.equal
                                                                                                                                                                                                                                                                                        "Unexpected period"
                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                                        Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.pp
                                                                                                                                                                                                                                                                                        v
                                                                                                                                                                                                                                                                                        (Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.succ
                                                                                                                                                                                                                                                                                          (Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.succ
                                                                                                                                                                                                                                                                                            (Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.succ
                                                                                                                                                                                                                                                                                              Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.root))))
                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                        match
                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                          with
                                                                                                                                                                                                                                                                                        |
                                                                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                  []
                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                                                    "%s - Unexpected empty listings"
                                                                                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                                                                                      string
                                                                                                                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                  _
                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                                                                                end))
                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                  (get_delegates_and_rolls_from_listings
                                                                                                                                                                                                                                                                                                    b)
                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                                                      (delegates_p4,
                                                                                                                                                                                                                                                                                                        rolls_p4)
                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                          ps
                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                            (if
                                                                                                                                                                                                                                                                                                              Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.is_empty
                                                                                                                                                                                                                                                                                                                ps
                                                                                                                                                                                                                                                                                                              then
                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                                                                                            else
                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                                                                "%s - Unexpected proposals"
                                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__)
                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                                        Some
                                                                                                                                                                                                                                                                                                                          v
                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                        if
                                                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                                                                                                                                                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                                                                                                                                                                                            v
                                                                                                                                                                                                                                                                                                                          then
                                                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                                                                                                        else
                                                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                                                                            "%s - Wrong proposal"
                                                                                                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                                                                                                              string
                                                                                                                                                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                                                        None
                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                                                                          "%s - Missing proposal"
                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                                                      end))
                                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                                                                                      tt
                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                                                            del
                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                              del
                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                                                                                                                                                                                              Vote.Yay)
                                                                                                                                                                                                                                                                                                                          delegates_p4)
                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                          operations
                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                              operations
                                                                                                                                                                                                                                                                                                                              b)
                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                              b
                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                                (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                                                                                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                                                                                                    v
                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                    fun
                                                                                                                                                                                                                                                                                                                                      acc
                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                                                                                                                                                                                                                                                                                                                        (Tezos_protocol_environment_alpha__Environment.Int32.add
                                                                                                                                                                                                                                                                                                                                          v
                                                                                                                                                                                                                                                                                                                                          acc))
                                                                                                                                                                                                                                                                                                                                  0
                                                                                                                                                                                                                                                                                                                                  rolls_p4)
                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                  rolls_sum
                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                      v
                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                                                                          ballots_equal
                                                                                                                                                                                                                                                                                                                                          "Unexpected ballots"
                                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                                          ballots_pp
                                                                                                                                                                                                                                                                                                                                          v
                                                                                                                                                                                                                                                                                                                                          {|
                                                                                                                                                                                                                                                                                                                                            yay :=
                                                                                                                                                                                                                                                                                                                                              rolls_sum;
                                                                                                                                                                                                                                                                                                                                            nay :=
                                                                                                                                                                                                                                                                                                                                              0;
                                                                                                                                                                                                                                                                                                                                            pass :=
                                                                                                                                                                                                                                                                                                                                              0
                                                                                                                                                                                                                                                                                                                                            |})
                                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                          match
                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                            with
                                                                                                                                                                                                                                                                                                                                          |
                                                                                                                                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                                                    []
                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                                                                                                      "%s - Unexpected empty ballot list"
                                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                                                    l
                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.iter_s
                                                                                                                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                                                                                                                        delegate
                                                                                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                            delegate)
                                                                                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                                                                                            pkh
                                                                                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.List.find_opt
                                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                  match
                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                    with
                                                                                                                                                                                                                                                                                                                                                                  |
                                                                                                                                                                                                                                                                                                                                                                    (del,
                                                                                                                                                                                                                                                                                                                                                                      _)
                                                                                                                                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                                                                                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                                      del
                                                                                                                                                                                                                                                                                                                                                                      pkh
                                                                                                                                                                                                                                                                                                                                                                  end)
                                                                                                                                                                                                                                                                                                                                                                l
                                                                                                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                                                                              None
                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                                                                                                                "%s - Missing delegate"
                                                                                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                                                                              Some
                                                                                                                                                                                                                                                                                                                                                                (_,
                                                                                                                                                                                                                                                                                                                                                                  Vote.Yay)
                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                                                                                                              Some
                                                                                                                                                                                                                                                                                                                                                                _
                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                                                                                                                                                                                                                                                "%s - Wrong ballot"
                                                                                                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                                                                                            end))
                                                                                                                                                                                                                                                                                                                                                      delegates_p4
                                                                                                                                                                                                                                                                                                                                                  end))
                                                                                                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                match
                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                  with
                                                                                                                                                                                                                                                                                                                                                |
                                                                                                                                                                                                                                                                                                                                                  tt
                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                                                                                                                                                                                                                                                                                                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                                                                                                                                                                                                                                                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                                                                                                                                                                                                                                                        1)
                                                                                                                                                                                                                                                                                                                                                      b)
                                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                                      b
                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                                                                                                                                                                                                                                                                                                                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                          b)
                                                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                                                          p
                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                                                                                                                                                                                                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                                                                                                                                                                                                                                                                                                                                                              "Unexpected proposal"
                                                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.pp)
                                                                                                                                                                                                                                                                                                                                                              p
                                                                                                                                                                                                                                                                                                                                                              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero))
                                                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                              match
                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                with
                                                                                                                                                                                                                                                                                                                                                              |
                                                                                                                                                                                                                                                                                                                                                                tt
                                                                                                                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                                                                                                                                                                                                                                              end)))
                                                                                                                                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                                                                                                                                          end)))))
                                                                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                                                                              end))
                                                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                                                              end)
                                                                                                                                                                                                                                                                                        end))
                                                                                                                                                                                                                                                                              end))
                                                                                                                                                                                                                                                                    end)
                                                                                                                                                                                                                                                              end))
                                                                                                                                                                                                                                                    end))
                                                                                                                                                                                                                                          end))
                                                                                                                                                                                                                                end)
                                                                                                                                                                                                                          end)))
                                                                                                                                                                                                            end)))))
                                                                                                                                                                                      end)
                                                                                                                                                                                end))
                                                                                                                                                                      end)
                                                                                                                                                                end)
                                                                                                                                                          end))
                                                                                                                                                end))
                                                                                                                                      end)))
                                                                                                                        end)))
                                                                                                          end)))))
                                                                                    end)
                                                                              end))
                                                                    end)
                                                              end)
                                                        end))
                                              end)
                                        end))
                              end)
                        end))
              end)
        end)
  end.

Definition get_smallest_prefix_voters_for_quorum {A : Type}
  (active_delegates : list A) (active_rolls : list int32)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list A)) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
      (fun v =>
        fun acc =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (Tezos_protocol_environment_alpha__Environment.Int32.add v acc)) 0
      active_rolls)
    (fun active_rolls_sum =>
      let fix loop {B : Type}
        (delegates : list B) (rolls : list int32) (sum : Z) (selected : list B)
        : list B :=
        match (delegates, rolls) with
        | ([], []) => selected
        | (cons del delegates, cons del_rolls rolls) =>
          if
            op_star_t_y_p_e_minus_e_r_r_o_r_star
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
                den sum)
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                (op_star_t_y_p_e_minus_e_r_r_o_r_star expected_qr_num
                  (Tezos_protocol_environment_alpha__Environment.Int32.to_float
                    active_rolls_sum))) then
            loop delegates rolls
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
                sum
                (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                  del_rolls)) (cons del selected)
          else
            selected
        | (_, _) => []
        end in
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (loop active_delegates active_rolls 0 [])).

Definition get_expected_participation_ema
  (rolls : list int32) (voter_rolls : list int32)
  (old_participation_ema : int32)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  let get_updated_participation_ema
    (old_participation_ema : int32) (participation : Z) : Z :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
          pr_ema_weight
          (Tezos_protocol_environment_alpha__Environment.Int32.to_int
            old_participation_ema))
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star pr_num
          participation)) den in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
      (fun v =>
        fun acc =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (Tezos_protocol_environment_alpha__Environment.Int32.add v acc)) 0
      rolls)
    (fun rolls_sum =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
          (fun v =>
            fun acc =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                (Tezos_protocol_environment_alpha__Environment.Int32.add v acc))
          0 voter_rolls)
        (fun voter_rolls_sum =>
          let participation :=
            Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
                (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                  voter_rolls_sum) percent_mul)
              (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                rolls_sum) in
          Tezos_protocol_environment_alpha__Environment.Error_monad._return
            (get_updated_participation_ema old_participation_ema participation))).

Definition test_not_enough_quorum_in_testing_vote
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let min_proposal_quorum :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Int32.of_int
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div 10000
          num_delegates) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star min_proposal_quorum num_delegates)
      (fun function_parameter =>
        match function_parameter with
        | (b, delegates) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                    (fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                      | _ =>
                        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                          "%s - Unexpected period kind" % string
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      end))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      let proposer :=
                        op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 0 in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star proposer
                          (cons
                            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                            []))
                        (fun ops =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star (cons ops [])
                              b)
                            (fun b =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                    (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star) 2) b)
                                (fun b =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                        | _ =>
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                            "%s - Unexpected period kind" %
                                              string
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        end))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            b)
                                          (fun initial_participation_ema =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (get_delegates_and_rolls_from_listings
                                                b)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | (delegates_p2, rolls_p2) =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (get_smallest_prefix_voters_for_quorum
                                                      delegates_p2 rolls_p2)
                                                    (fun voters =>
                                                      let
                                                        voters_without_quorum :=
                                                        Tezos_protocol_environment_alpha__Environment.List.tl
                                                          voters in
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (get_rolls b
                                                          voters_without_quorum
                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__)
                                                        (fun
                                                          voters_rolls_in_testing_vote
                                                          =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                              (fun del =>
                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  del
                                                                  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                  Vote.Yay)
                                                              voters_without_quorum)
                                                            (fun operations =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  operations b)
                                                                (fun b =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                        1) b)
                                                                    (fun b =>
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            | _
                                                                              =>
                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                            | _
                                                                              =>
                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                "%s - Unexpected period kind"
                                                                                  %
                                                                                  string
                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                            end))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          match
                                                                            function_parameter
                                                                            with
                                                                          | tt
                                                                            =>
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                              (get_expected_participation_ema
                                                                                rolls_p2
                                                                                voters_rolls_in_testing_vote
                                                                                initial_participation_ema)
                                                                              (fun
                                                                                expected_participation_ema
                                                                                =>
                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                    b)
                                                                                  (fun
                                                                                    new_participation_ema
                                                                                    =>
                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                        expected_participation_ema
                                                                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                                          new_participation_ema))
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        match
                                                                                          function_parameter
                                                                                          with
                                                                                        |
                                                                                          tt
                                                                                          =>
                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                        end)))
                                                                          end))))))
                                                end))
                                      end))))
                    end)
              end)
        end)
  end.

Definition test_not_enough_quorum_in_promotion_vote
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let min_proposal_quorum :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Int32.of_int
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div 10000
          num_delegates) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star min_proposal_quorum num_delegates)
      (fun function_parameter =>
        match function_parameter with
        | (b, delegates) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                    (fun function_parameter =>
                      match function_parameter with
                      | _ =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                      | _ =>
                        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                          "%s - Unexpected period kind" % string
                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                      end))
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      let proposer :=
                        op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 0 in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star proposer
                          (cons
                            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                            []))
                        (fun ops =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star (cons ops [])
                              b)
                            (fun b =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                    (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star) 2) b)
                                (fun b =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                        | _ =>
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                            "%s - Unexpected period kind" %
                                              string
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        end))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (get_delegates_and_rolls_from_listings
                                            b)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (delegates_p2, rolls_p2) =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (get_smallest_prefix_voters_for_quorum
                                                  delegates_p2 rolls_p2)
                                                (fun voters =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                      (fun del =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          del
                                                          Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                          Vote.Yay) voters)
                                                    (fun operations =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          operations b)
                                                        (fun b =>
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                                (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                1) b)
                                                            (fun b =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | _ =>
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                    | _ =>
                                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                        "%s - Unexpected period kind"
                                                                          %
                                                                          string
                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                    end))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  | tt =>
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                        b)
                                                                      (fun b =>
                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              match
                                                                                function_parameter
                                                                                with
                                                                              |
                                                                                _
                                                                                =>
                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                              |
                                                                                _
                                                                                =>
                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                  "%s - Unexpected period kind"
                                                                                    %
                                                                                    string
                                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                              end))
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            | tt
                                                                              =>
                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                  b)
                                                                                (fun
                                                                                  initial_participation_ema
                                                                                  =>
                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                    (get_delegates_and_rolls_from_listings
                                                                                      b)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        (delegates_p4,
                                                                                          rolls_p4)
                                                                                        =>
                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                          (get_smallest_prefix_voters_for_quorum
                                                                                            delegates_p4
                                                                                            rolls_p4)
                                                                                          (fun
                                                                                            voters
                                                                                            =>
                                                                                            let
                                                                                              voters_without_quorum :=
                                                                                              Tezos_protocol_environment_alpha__Environment.List.tl
                                                                                                voters
                                                                                              in
                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                              (get_rolls
                                                                                                b
                                                                                                voters_without_quorum
                                                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__)
                                                                                              (fun
                                                                                                voter_rolls
                                                                                                =>
                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                                                                    (fun
                                                                                                      del
                                                                                                      =>
                                                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        del
                                                                                                        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                        Vote.Yay)
                                                                                                    voters_without_quorum)
                                                                                                  (fun
                                                                                                    operations
                                                                                                    =>
                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                        operations
                                                                                                        b)
                                                                                                      (fun
                                                                                                        b
                                                                                                        =>
                                                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                                                                              (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                              1)
                                                                                                            b)
                                                                                                          (fun
                                                                                                            b
                                                                                                            =>
                                                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                              (get_expected_participation_ema
                                                                                                                rolls_p4
                                                                                                                voter_rolls
                                                                                                                initial_participation_ema)
                                                                                                              (fun
                                                                                                                expected_participation_ema
                                                                                                                =>
                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                    b)
                                                                                                                  (fun
                                                                                                                    new_participation_ema
                                                                                                                    =>
                                                                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                        expected_participation_ema
                                                                                                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                                                                          new_participation_ema))
                                                                                                                      (fun
                                                                                                                        function_parameter
                                                                                                                        =>
                                                                                                                        match
                                                                                                                          function_parameter
                                                                                                                          with
                                                                                                                        |
                                                                                                                          tt
                                                                                                                          =>
                                                                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                                                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                                                                              (fun
                                                                                                                                function_parameter
                                                                                                                                =>
                                                                                                                                match
                                                                                                                                  function_parameter
                                                                                                                                  with
                                                                                                                                |
                                                                                                                                  _
                                                                                                                                  =>
                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                                |
                                                                                                                                  _
                                                                                                                                  =>
                                                                                                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                                                                                    "%s - Unexpected period kind"
                                                                                                                                      %
                                                                                                                                      string
                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                                                                                end))
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              match
                                                                                                                                function_parameter
                                                                                                                                with
                                                                                                                              |
                                                                                                                                tt
                                                                                                                                =>
                                                                                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                                                                              end)
                                                                                                                        end))))))))
                                                                                      end))
                                                                            end))
                                                                  end)))))
                                            end)
                                      end))))
                    end)
              end)
        end)
  end.

Definition test_multiple_identical_proposals_count_as_one
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star 1)
      (fun function_parameter =>
        match function_parameter with
        | (b, delegates) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                op_star_t_y_p_e_minus_e_r_r_o_r_star)
              (fun function_parameter =>
                match function_parameter with
                | _ =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                | _ =>
                  Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                    "%s - Unexpected period kind" % string
                    Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                end))
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                let proposer :=
                  Tezos_protocol_environment_alpha__Environment.List.hd
                    delegates in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star proposer
                    (cons
                      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                      (cons
                        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                        [])))
                  (fun ops =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star (cons ops []) b)
                      (fun b =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                          (fun ps =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (op_star_t_y_p_e_minus_e_r_r_o_r_star proposer)
                              (fun pkh =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                  (fun l =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      match
                                        Tezos_protocol_environment_alpha__Environment.List.find_opt
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (del, _) =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                del pkh
                                            end) l with
                                      | None =>
                                        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                          "%s - Missing delegate" % string
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                      | Some (_, proposer_rolls) =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad._return
                                          proposer_rolls
                                      end
                                      (fun proposer_rolls =>
                                        let expected_weight_proposer :=
                                          proposer_rolls in
                                        match
                                          Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.Map.find_opt
                                            Tezos_protocol_alpha.Protocol.Environment.Protocol_hash.zero
                                            ps with
                                        | Some v =>
                                          if
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              v expected_weight_proposer then
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                          else
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                              "%s - Wrong count %ld is not %ld; identical proposals count as one"
                                                % string
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                              v expected_weight_proposer
                                        | None =>
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                            "%s - Missing proposal" % string
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        end))))))
              end)
        end)
  end.

Definition test_supermajority_in_proposal {A : Type}
  (there_is_a_winner : bool) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  match function_parameter with
  | tt =>
    let min_proposal_quorum := 0 in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star min_proposal_quorum
        (cons 1 (cons 1 (cons 1 []))) 10)
      (fun function_parameter =>
        match function_parameter with
        | (b, delegates) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                let del1 := op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 0 in
                let del2 := op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 1 in
                let del3 := op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 2 in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                    (fun del => op_star_t_y_p_e_minus_e_r_r_o_r_star del)
                    (cons del1 (cons del2 (cons del3 []))))
                  (fun pkhs =>
                    let policy := op_star_t_y_p_e_minus_e_r_r_o_r_star in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 3) del1
                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                      (fun op1 =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 4)
                            del2 op_star_t_y_p_e_minus_e_r_r_o_r_star)
                          (fun op2 =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              (if there_is_a_winner then
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star 3
                              else
                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star 2)
                              (fun bal3 =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      delegates 5) del3 bal3)
                                  (fun op3 =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        policy
                                        (cons op1 (cons op2 (cons op3 []))) b)
                                      (fun b =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                            (fun b =>
                                              fun function_parameter =>
                                                match function_parameter with
                                                | _ =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                      (fun del =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            del)
                                                          (fun pkh =>
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              del (Some pkh)))
                                                      delegates)
                                                    (fun ops =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          policy ops b)
                                                        (fun b =>
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            policy b))
                                                end) b
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              1
                                              (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                (Tezos_protocol_environment_alpha__Environment.Int32.div
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star))))
                                          (fun b =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                del1
                                                (cons
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    protos 0) []))
                                              (fun ops1 =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    del2
                                                    (cons
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        protos 0) []))
                                                  (fun ops2 =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        del3
                                                        (cons
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            protos 1) []))
                                                      (fun ops3 =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            policy
                                                            (cons ops1
                                                              (cons ops2
                                                                (cons ops3 [])))
                                                            b)
                                                          (fun b =>
                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                policy
                                                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                                  (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                  1) b)
                                                              (fun b =>
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | _ =>
                                                                        if
                                                                          there_is_a_winner
                                                                          then
                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                        else
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                            "%s - Expected period kind Proposal, obtained Testing_vote"
                                                                              %
                                                                              string
                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                      | _ =>
                                                                        if
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.not
                                                                            there_is_a_winner
                                                                          then
                                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                        else
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                            "%s - Expected period kind Testing_vote, obtained Proposal"
                                                                              %
                                                                              string
                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                      | _ =>
                                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                          "%s - Unexpected period kind"
                                                                            %
                                                                            string
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                      end))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | tt =>
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                    end)))))))))))))
              end)
        end)
  end.

Definition test_quorum_in_proposal
  (has_quorum : bool) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let total_tokens := 32000000000000 in
    let half_tokens :=
      Tezos_protocol_environment_alpha__Environment.Int64.div total_tokens 2 in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        (cons 1 (cons half_tokens (cons half_tokens []))) 3)
      (fun function_parameter =>
        match function_parameter with
        | (b, delegates) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                let del1 := op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 0 in
                let del2 := op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 1 in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                    (fun del => op_star_t_y_p_e_minus_e_r_r_o_r_star del)
                    (cons del1 (cons del2 [])))
                  (fun pkhs =>
                    let policy := op_star_t_y_p_e_minus_e_r_r_o_r_star in
                    let quorum :=
                      if has_quorum then
                        Tezos_protocol_environment_alpha__Environment.Int64.of_int32
                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                      else
                        Tezos_protocol_environment_alpha__Environment.Int64.sub
                          (Tezos_protocol_environment_alpha__Environment.Int64.of_int32
                            op_star_t_y_p_e_minus_e_r_r_o_r_star) 10 in
                    let bal :=
                      Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                        (Tezos_protocol_environment_alpha__Environment.Int64.div
                          (Tezos_protocol_environment_alpha__Environment.Int64.mul
                            total_tokens quorum) 10000)
                        op_star_t_y_p_e_minus_e_r_r_o_r_star in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        op_star_t_y_p_e_minus_e_r_r_o_r_star del2 del1 bal)
                      (fun op2 =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star policy
                            (cons op2 []) b)
                          (fun b =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.fold_left_s
                                (fun b =>
                                  fun function_parameter =>
                                    match function_parameter with
                                    | _ =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                          (fun del =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                del)
                                              (fun pkh =>
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  del (Some pkh)))
                                          (cons del1 (cons del2 [])))
                                        (fun ops =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              policy ops b)
                                            (fun b =>
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                policy b))
                                    end) b
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star 1
                                  (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                    (Tezos_protocol_environment_alpha__Environment.Int32.div
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star))))
                              (fun b =>
                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                    op_star_t_y_p_e_minus_e_r_r_o_r_star del1
                                    (cons
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        protos 0) []))
                                  (fun ops =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        policy (cons ops []) b)
                                      (fun b =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            policy
                                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                              (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                              1) b)
                                          (fun b =>
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | _ =>
                                                    if has_quorum then
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                    else
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                        "%s - Expected period kind Proposal, obtained Testing_vote"
                                                          % string
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  | _ =>
                                                    if
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.not
                                                        has_quorum then
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                    else
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                        "%s - Expected period kind Testing_vote, obtained Proposal"
                                                          % string
                                                        Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  | _ =>
                                                    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                      "%s - Unexpected period kind"
                                                        % string
                                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                  end))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | tt =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                end))))))))
              end)
        end)
  end.

Definition test_supermajority_in_testing_vote
  (supermajority : bool) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let min_proposal_quorum :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Int32.of_int
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div 10000
          100) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star min_proposal_quorum 100)
      (fun function_parameter =>
        match function_parameter with
        | (b, delegates) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                let del1 := op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 0 in
                let proposal := op_star_t_y_p_e_minus_e_r_r_o_r_star protos 0 in
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    op_star_t_y_p_e_minus_e_r_r_o_r_star del1 (cons proposal []))
                  (fun ops1 =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star (cons ops1 []) b)
                      (fun b =>
                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                              (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                op_star_t_y_p_e_minus_e_r_r_o_r_star) 1) b)
                          (fun b =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | _ =>
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                  | _ =>
                                    Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                      "%s - Unexpected period kind" % string
                                      Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                  end))
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | Some v =>
                                          if
                                            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                                              proposal v then
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                          else
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                              "%s - Wrong proposal" % string
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        | None =>
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                            "%s - Missing proposal" % string
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        end))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (get_delegates_and_rolls_from_listings
                                            b)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | (delegates_p2, _olls_p2) =>
                                              let num_delegates :=
                                                Tezos_protocol_environment_alpha__Environment.List.length
                                                  delegates_p2 in
                                              let num_nays :=
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
                                                  num_delegates 5 in
                                              let num_yays :=
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.op_div
                                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_star
                                                    num_nays s_num)
                                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                    s_den s_num) in
                                              let num_yays :=
                                                if supermajority then
                                                  num_yays
                                                else
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                    num_yays 1 in
                                              match
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                  num_nays delegates_p2 with
                                              | (nays_delegates, rest) =>
                                                match
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    num_yays rest with
                                                | (yays_delegates, _) =>
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                      (fun del =>
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                          del proposal Vote.Yay)
                                                      yays_delegates)
                                                    (fun operations_yays =>
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                          (fun del =>
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              del proposal
                                                              Vote.Nay)
                                                          nays_delegates)
                                                        (fun operations_nays =>
                                                          let operations :=
                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.op_at
                                                              operations_yays
                                                              operations_nays in
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                              operations b)
                                                            (fun b =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                                    (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                                      op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                    1) b)
                                                                (fun b =>
                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        | _ =>
                                                                          if
                                                                            supermajority
                                                                            then
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                          else
                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                              "%s - Expected period kind Proposal, obtained Testing"
                                                                                %
                                                                                string
                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                        | _ =>
                                                                          if
                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.not
                                                                              supermajority
                                                                            then
                                                                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                          else
                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                              "%s - Expected period kind Testing_vote, obtained Proposal"
                                                                                %
                                                                                string
                                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                        | _ =>
                                                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                            "%s - Unexpected period kind"
                                                                              %
                                                                              string
                                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                                        end))
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      match
                                                                        function_parameter
                                                                        with
                                                                      | tt =>
                                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                                      end)))))
                                                end
                                              end
                                            end)
                                      end)
                                end))))
              end)
        end)
  end.

Definition test_no_winning_proposal
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let min_proposal_quorum :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Int32.of_int
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div 10000
          num_delegates) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star min_proposal_quorum num_delegates)
      (fun function_parameter =>
        match function_parameter with
        | (b, _) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              op_star_t_y_p_e_minus_e_r_r_o_r_star)
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (get_delegates_and_rolls_from_listings b)
                  (fun function_parameter =>
                    match function_parameter with
                    | (delegates_p1, _rolls_p1) =>
                      let props :=
                        Tezos_protocol_environment_alpha__Environment.List.map
                          (fun i =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star protos i)
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star 1
                            Tezos_protocol_alpha.Protocol.Alpha_context.Constants.max_proposals_per_delegate)
                        in
                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                          (fun del =>
                            op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star del props)
                          delegates_p1)
                        (fun ops_list =>
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star ops_list b)
                            (fun b =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                    (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                      op_star_t_y_p_e_minus_e_r_r_o_r_star) 2) b)
                                (fun b =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                        op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | _ =>
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                        | _ =>
                                          Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                            "%s - Unexpected period kind" %
                                              string
                                            Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                        end))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | tt =>
                                        Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                      end))))
                    end)
              end)
        end)
  end.

Definition test_quorum_capped_maximum
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let min_proposal_quorum :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Int32.of_int
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div 10000
          num_delegates) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star min_proposal_quorum num_delegates)
      (fun function_parameter =>
        match function_parameter with
        | (b, delegates) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b 10000)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                              "%s - Unexpected period kind" % string
                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          end))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let protocol :=
                            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                            in
                          let proposer :=
                            op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 0 in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star proposer
                              (cons protocol []))
                            (fun ops =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (cons ops []) b)
                                (fun b =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                        1) b)
                                    (fun b =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                "%s - Unexpected period kind" %
                                                  string
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            end))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            let minimum_to_pass :=
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (Tezos_protocol_environment_alpha__Environment.List.length
                                                          delegates))
                                                      (Tezos_protocol_environment_alpha__Environment.Int32.to_float
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                                    10000)
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              in
                                            let voters :=
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                minimum_to_pass delegates in
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                (fun del =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    del protocol Vote.Yay)
                                                voters)
                                              (fun operations =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    operations b)
                                                  (fun b =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                          (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                          1) b)
                                                      (fun b =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | _ =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                            | _ =>
                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                "%s - Unexpected period kind"
                                                                  % string
                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                            end))))
                                          end))))
                        end)
                  end))
        end)
  end.

Definition test_quorum_capped_minimum
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | tt =>
    let min_proposal_quorum :=
      Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
        Tezos_protocol_environment_alpha__Environment.Int32.of_int
        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_div 10000
          num_delegates) in
    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
      (op_star_t_y_p_e_minus_e_r_r_o_r_star min_proposal_quorum num_delegates)
      (fun function_parameter =>
        match function_parameter with
        | (b, delegates) =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (op_star_t_y_p_e_minus_e_r_r_o_r_star b 0)
            (fun b =>
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                (fun function_parameter =>
                  match function_parameter with
                  | _ =>
                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                        (fun function_parameter =>
                          match function_parameter with
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                          | _ =>
                            Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                              "%s - Unexpected period kind" % string
                              Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                          end))
                      (fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          let protocol :=
                            Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                            in
                          let proposer :=
                            op_star_t_y_p_e_minus_e_r_r_o_r_star delegates 0 in
                          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              op_star_t_y_p_e_minus_e_r_r_o_r_star proposer
                              (cons protocol []))
                            (fun ops =>
                              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                  (cons ops []) b)
                                (fun b =>
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                      (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                        (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                          op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                        1) b)
                                    (fun b =>
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                            | _ =>
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                "%s - Unexpected period kind" %
                                                  string
                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                            end))
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | tt =>
                                            let minimum_to_pass :=
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                                                (Tezos_protocol_environment_alpha__Environment.Pervasives.op_pipe_gt
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (Tezos_protocol_environment_alpha__Environment.List.length
                                                          delegates))
                                                      (Tezos_protocol_environment_alpha__Environment.Int32.to_float
                                                        op_star_t_y_p_e_minus_e_r_r_o_r_star))
                                                    10000)
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                op_star_t_y_p_e_minus_e_r_r_o_r_star
                                              in
                                            let voters :=
                                              op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                minimum_to_pass delegates in
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.map_s
                                                (fun del =>
                                                  op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    del protocol Vote.Yay)
                                                voters)
                                              (fun operations =>
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                    operations b)
                                                  (fun b =>
                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                        (Tezos_protocol_environment_alpha__Environment.Pervasives.op_minus
                                                          (Tezos_protocol_environment_alpha__Environment.Int32.to_int
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                          1) b)
                                                      (fun b =>
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                                                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                                                            op_star_t_y_p_e_minus_e_r_r_o_r_star)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | _ =>
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.return_unit
                                                            | _ =>
                                                              Tezos_protocol_environment_alpha__Environment.Pervasives.failwith
                                                                "%s - Unexpected period kind"
                                                                  % string
                                                                Tezos_protocol_environment_alpha__Environment.Pervasives.__LOC__
                                                            end))))
                                          end))))
                        end)
                  end))
        end)
  end.

Definition tests {A : Type} : list A :=
  cons
    (op_star_t_y_p_e_minus_e_r_r_o_r_star "voting successful_vote" % string
      variant (test_successful_vote 137))
    (cons
      (op_star_t_y_p_e_minus_e_r_r_o_r_star
        "voting testing vote, not enough quorum" % string variant
        (test_not_enough_quorum_in_testing_vote 245))
      (cons
        (op_star_t_y_p_e_minus_e_r_r_o_r_star
          "voting promotion vote, not enough quorum" % string variant
          (test_not_enough_quorum_in_promotion_vote 432))
        (cons
          (op_star_t_y_p_e_minus_e_r_r_o_r_star
            "voting counting double proposal" % string variant
            test_multiple_identical_proposals_count_as_one)
          (cons
            (op_star_t_y_p_e_minus_e_r_r_o_r_star
              "voting proposal, with supermajority" % string variant
              (test_supermajority_in_proposal true))
            (cons
              (op_star_t_y_p_e_minus_e_r_r_o_r_star
                "voting proposal, without supermajority" % string variant
                (test_supermajority_in_proposal false))
              (cons
                (op_star_t_y_p_e_minus_e_r_r_o_r_star
                  "voting proposal, with quorum" % string variant
                  (test_quorum_in_proposal true))
                (cons
                  (op_star_t_y_p_e_minus_e_r_r_o_r_star
                    "voting proposal, without quorum" % string variant
                    (test_quorum_in_proposal false))
                  (cons
                    (op_star_t_y_p_e_minus_e_r_r_o_r_star
                      "voting testing vote, with supermajority" % string variant
                      (test_supermajority_in_testing_vote true))
                    (cons
                      (op_star_t_y_p_e_minus_e_r_r_o_r_star
                        "voting testing vote, without supermajority" % string
                        variant (test_supermajority_in_testing_vote false))
                      (cons
                        (op_star_t_y_p_e_minus_e_r_r_o_r_star
                          "voting proposal, no winning proposal" % string
                          variant (test_no_winning_proposal 400))
                        (cons
                          (op_star_t_y_p_e_minus_e_r_r_o_r_star
                            "voting quorum, quorum capped maximum" % string
                            variant (test_quorum_capped_maximum 400))
                          (cons
                            (op_star_t_y_p_e_minus_e_r_r_o_r_star
                              "voting quorum, quorum capped minimum" % string
                              variant (test_quorum_capped_minimum 401)) [])))))))))))).
src/proto_alpha/lib_protocol/tez_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Qty_repr.Make (struct
  let id = "tez"
end)

type t = qty

type tez = qty

let encoding = Data_encoding.def "mutez" @@ encoding
src/proto_alpha/lib_protocol/tez_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := qty.

Definition tez := qty.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding qty :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.def
        "mutez" % string in
    fun eta => arg None None eta) encoding.
src/proto_alpha/lib_protocol/tez_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t

type tez = t

include Qty_repr.S with type qty := t
src/proto_alpha/lib_protocol/tez_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition tez := t.

include
src/proto_alpha/lib_protocol/time_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Time

type time = t

type error += Timestamp_add (* `Permanent *)

type error += Timestamp_sub (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"timestamp_add"
    ~title:"Timestamp add"
    ~description:"Overflow when adding timestamps."
    ~pp:(fun ppf () -> Format.fprintf ppf "Overflow when adding timestamps.")
    Data_encoding.empty
    (function Timestamp_add -> Some () | _ -> None)
    (fun () -> Timestamp_add) ;
  register_error_kind
    `Permanent
    ~id:"timestamp_sub"
    ~title:"Timestamp sub"
    ~description:"Substracting timestamps resulted in negative period."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Substracting timestamps resulted in negative period.")
    Data_encoding.empty
    (function Timestamp_sub -> Some () | _ -> None)
    (fun () -> Timestamp_sub)

let of_seconds s = try Some (of_seconds (Int64.of_string s)) with _ -> None

let to_seconds = to_seconds

let to_seconds_string s = Int64.to_string (to_seconds s)

let pp = pp_hum

let ( +? ) x y =
  try ok (add x (Period_repr.to_seconds y)) with _exn -> error Timestamp_add

let ( -? ) x y = record_trace Timestamp_sub (Period_repr.of_seconds (diff x y))
src/proto_alpha/lib_protocol/time_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition time := t.

Definition of_seconds (s : string) : option t := try.

Definition to_seconds : t -> int64 := to_seconds.

Definition to_seconds_string (s : t) : string :=
  Tezos_protocol_environment_alpha__Environment.Int64.to_string (to_seconds s).

Definition pp
  : Tezos_protocol_environment_alpha__Environment.Format.formatter -> t -> unit :=
  pp_hum.

Definition op_plus_question
  (x : t) (y : Tezos_raw_protocol_alpha.Period_repr.period)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t := try.

Definition op_minus_question (x : t) (y : t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_raw_protocol_alpha.Period_repr.period :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.record_trace
    Timestamp_sub (Tezos_raw_protocol_alpha.Period_repr.of_seconds (diff x y)).
src/proto_alpha/lib_protocol/time_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include module type of struct
  include Time
end

type time = t

val pp : Format.formatter -> t -> unit

val of_seconds : string -> time option

val to_seconds_string : time -> string

val ( +? ) : time -> Period_repr.t -> time tzresult

val ( -? ) : time -> time -> Period_repr.t tzresult
src/proto_alpha/lib_protocol/time_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include

Definition time := t.

Parameter pp :
Tezos_protocol_environment_alpha__Environment.Format.formatter -> t -> unit.

Parameter of_seconds : string -> option time.

Parameter to_seconds_string : time -> string.

Parameter op_plus_question :
time ->
  Tezos_raw_protocol_alpha.Period_repr.t ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult time.

Parameter op_minus_question :
time ->
  time ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Period_repr.t.
src/proto_alpha/lib_protocol/vote_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type proposal = Protocol_hash.t

type ballot = Yay | Nay | Pass

let ballot_encoding =
  let of_int8 = function
    | 0 ->
        Yay
    | 1 ->
        Nay
    | 2 ->
        Pass
    | _ ->
        invalid_arg "ballot_of_int8"
  in
  let to_int8 = function Yay -> 0 | Nay -> 1 | Pass -> 2 in
  let open Data_encoding in
  (* union *)
  splitted
    ~binary:(conv to_int8 of_int8 int8)
    ~json:(string_enum [("yay", Yay); ("nay", Nay); ("pass", Pass)])
src/proto_alpha/lib_protocol/vote_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition proposal :=
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).

Inductive ballot : Type :=
| Yay : ballot
| Nay : ballot
| Pass : ballot.

Definition ballot_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding ballot :=
  let of_int8 (function_parameter : Z) : ballot :=
    match function_parameter with
    | 0 => Yay
    | 1 => Nay
    | 2 => Pass
    | _ =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
        "ballot_of_int8" % string
    end in
  let to_int8 (function_parameter : ballot) : Z :=
    match function_parameter with
    | Yay => 0
    | Nay => 1
    | Pass => 2
    end in
  Tezos_protocol_environment_alpha__Environment.Data_encoding.splitted
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.string_enum
      (cons ("yay" % string, Yay)
        (cons ("nay" % string, Nay) (cons ("pass" % string, Pass) []))))
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.conv to_int8
      of_int8 None
      Tezos_protocol_environment_alpha__Environment.Data_encoding.int8).
src/proto_alpha/lib_protocol/vote_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** a protocol change proposal *)
type proposal = Protocol_hash.t

(** votes can be for, against or neutral.
    Neutral serves to count towards a quorum *)
type ballot = Yay | Nay | Pass

val ballot_encoding : ballot Data_encoding.t
src/proto_alpha/lib_protocol/vote_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition proposal :=
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).

Inductive ballot : Type :=
| Yay : ballot
| Nay : ballot
| Pass : ballot.

Parameter ballot_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t ballot.
src/proto_alpha/lib_protocol/vote_storage.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let recorded_proposal_count_for_delegate ctxt proposer =
  Storage.Vote.Proposals_count.get_option ctxt proposer
  >>=? function None -> return 0 | Some count -> return count

let record_proposal ctxt proposal proposer =
  recorded_proposal_count_for_delegate ctxt proposer
  >>=? fun count ->
  Storage.Vote.Proposals_count.init_set ctxt proposer (count + 1)
  >>= fun ctxt ->
  Storage.Vote.Proposals.add ctxt (proposal, proposer)
  >>= fun ctxt -> return ctxt

let get_proposals ctxt =
  Storage.Vote.Proposals.fold
    ctxt
    ~init:(ok Protocol_hash.Map.empty)
    ~f:(fun (proposal, delegate) acc ->
      (* Assuming the same listings is used at votings *)
      Storage.Vote.Listings.get ctxt delegate
      >>=? fun weight ->
      Lwt.return
        ( acc
        >>? fun acc ->
        let previous =
          match Protocol_hash.Map.find_opt proposal acc with
          | None ->
              0l
          | Some x ->
              x
        in
        ok (Protocol_hash.Map.add proposal (Int32.add weight previous) acc) ))

let clear_proposals ctxt =
  Storage.Vote.Proposals_count.clear ctxt
  >>= fun ctxt -> Storage.Vote.Proposals.clear ctxt

type ballots = {yay : int32; nay : int32; pass : int32}

let ballots_encoding =
  let open Data_encoding in
  conv
    (fun {yay; nay; pass} -> (yay, nay, pass))
    (fun (yay, nay, pass) -> {yay; nay; pass})
  @@ obj3 (req "yay" int32) (req "nay" int32) (req "pass" int32)

let has_recorded_ballot = Storage.Vote.Ballots.mem

let record_ballot = Storage.Vote.Ballots.init

let get_ballots ctxt =
  Storage.Vote.Ballots.fold
    ctxt
    ~f:(fun delegate ballot (ballots : ballots tzresult) ->
      (* Assuming the same listings is used at votings *)
      Storage.Vote.Listings.get ctxt delegate
      >>=? fun weight ->
      let count = Int32.add weight in
      Lwt.return
        ( ballots
        >>? fun ballots ->
        match ballot with
        | Yay ->
            ok {ballots with yay = count ballots.yay}
        | Nay ->
            ok {ballots with nay = count ballots.nay}
        | Pass ->
            ok {ballots with pass = count ballots.pass} ))
    ~init:(ok {yay = 0l; nay = 0l; pass = 0l})

let get_ballot_list = Storage.Vote.Ballots.bindings

let clear_ballots = Storage.Vote.Ballots.clear

let listings_encoding =
  Data_encoding.(
    list
      (obj2 (req "pkh" Signature.Public_key_hash.encoding) (req "rolls" int32)))

let freeze_listings ctxt =
  Roll_storage.fold ctxt (ctxt, 0l) ~f:(fun _roll delegate (ctxt, total) ->
      (* TODO use snapshots *)
      let delegate = Signature.Public_key.hash delegate in
      Storage.Vote.Listings.get_option ctxt delegate
      >>=? (function None -> return 0l | Some count -> return count)
      >>=? fun count ->
      Storage.Vote.Listings.init_set ctxt delegate (Int32.succ count)
      >>= fun ctxt -> return (ctxt, Int32.succ total))
  >>=? fun (ctxt, total) ->
  Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> return ctxt

let listing_size = Storage.Vote.Listings_size.get

let in_listings = Storage.Vote.Listings.mem

let get_listings = Storage.Vote.Listings.bindings

let clear_listings ctxt =
  Storage.Vote.Listings.clear ctxt
  >>= fun ctxt ->
  Storage.Vote.Listings_size.remove ctxt >>= fun ctxt -> return ctxt

let get_current_period_kind = Storage.Vote.Current_period_kind.get

let set_current_period_kind = Storage.Vote.Current_period_kind.set

let get_current_quorum ctxt =
  Storage.Vote.Participation_ema.get ctxt
  >>=? fun participation_ema ->
  let quorum_min = Constants_storage.quorum_min ctxt in
  let quorum_max = Constants_storage.quorum_max ctxt in
  let quorum_diff = Int32.sub quorum_max quorum_min in
  return
    Int32.(add quorum_min (div (mul participation_ema quorum_diff) 100_00l))

let get_participation_ema = Storage.Vote.Participation_ema.get

let set_participation_ema = Storage.Vote.Participation_ema.set

let get_current_proposal = Storage.Vote.Current_proposal.get

let init_current_proposal = Storage.Vote.Current_proposal.init

let clear_current_proposal = Storage.Vote.Current_proposal.delete

let init ctxt =
  (* participation EMA is in centile of a percentage *)
  let participation_ema = Constants_storage.quorum_max ctxt in
  Storage.Vote.Participation_ema.init ctxt participation_ema
  >>=? fun ctxt ->
  Storage.Vote.Current_period_kind.init ctxt Proposal
  >>=? fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/vote_storage.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition recorded_proposal_count_for_delegate
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
  (proposer : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.value) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.get_option ctxt
      proposer)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return 0
      | Some count =>
        Tezos_protocol_environment_alpha__Environment.Error_monad._return count
      end).

Definition record_proposal
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
  (proposal :
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (proposer : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (recorded_proposal_count_for_delegate ctxt proposer)
    (fun count =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.init_set ctxt
          proposer
          (Tezos_protocol_environment_alpha__Environment.Pervasives.op_plus
            count 1))
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
            (Tezos_raw_protocol_alpha.Storage.Vote.Proposals.add ctxt
              (proposal, proposer))
            (fun ctxt =>
              Tezos_protocol_environment_alpha__Environment.Error_monad._return
                ctxt))).

Definition get_proposals
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32)) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Proposals.fold ctxt
    (Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.empty)
    (fun function_parameter =>
      match function_parameter with
      | (proposal, delegate) =>
        fun acc =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Vote.Listings.get ctxt delegate)
            (fun weight =>
              Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  acc
                  (fun acc =>
                    let previous :=
                      match
                        Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.find_opt
                          proposal acc with
                      | None => 0
                      | Some x => x
                      end in
                    Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.add
                        proposal
                        (Tezos_protocol_environment_alpha__Environment.Int32.add
                          weight previous) acc))))
      end).

Definition clear_proposals
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    Tezos_raw_protocol_alpha.Raw_context.t :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.clear ctxt)
    (fun ctxt => Tezos_raw_protocol_alpha.Storage.Vote.Proposals.clear ctxt).

Record ballots := {
  yay : int32;
  nay : int32;
  pass : int32 }.

Definition ballots_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding ballots :=
  Tezos_protocol_environment_alpha__Environment.Pervasives.op_at_at
    (let arg :=
      Tezos_protocol_environment_alpha__Environment.Data_encoding.conv
        (fun function_parameter =>
          match function_parameter with
          | {| yay := yay; nay := nay; pass := pass |} => (yay, nay, pass)
          end)
        (fun function_parameter =>
          match function_parameter with
          | (yay, nay, pass) => {| yay := yay; nay := nay; pass := pass |}
          end) in
    fun eta => arg None eta)
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj3
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "yay" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "nay" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "pass" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)).

Definition has_recorded_ballot
  : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
  Tezos_raw_protocol_alpha.Storage.Vote.Ballots.mem.

Definition record_ballot
  : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key ->
      Tezos_raw_protocol_alpha.Storage.Vote.Ballots.value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Ballots.init.

Definition get_ballots
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult ballots) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Ballots.fold ctxt
    (Tezos_protocol_environment_alpha__Environment.Error_monad.ok
      {| yay := 0; nay := 0; pass := 0 |})
    (fun delegate =>
      fun ballot =>
        fun ballots =>
          Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_alpha.Storage.Vote.Listings.get ctxt delegate)
            (fun weight =>
              let count :=
                Tezos_protocol_environment_alpha__Environment.Int32.add weight
                in
              Tezos_protocol_environment_alpha__Environment.Lwt._return
                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_question
                  ballots
                  (fun ballots =>
                    match ballot with
                    | Yay =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                        record
                    | Nay =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                        record
                    | Pass =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.ok
                        record
                    end)))).

Definition get_ballot_list
  : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list
        (Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key *
          Tezos_raw_protocol_alpha.Storage.Vote.Ballots.value)) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Ballots.bindings.

Definition clear_ballots
  : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      Tezos_raw_protocol_alpha.Raw_context.t :=
  Tezos_raw_protocol_alpha.Storage.Vote.Ballots.clear.

Definition listings_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * int32)) :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "pkh" % string
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None None
        "rolls" % string
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)).

Definition freeze_listings (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Roll_storage.fold ctxt
      (fun _roll =>
        fun delegate =>
          fun function_parameter =>
            match function_parameter with
            | (ctxt, total) =>
              let delegate :=
                Tezos_protocol_environment_alpha__Environment.Signature.Public_key.hash
                  delegate in
              Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                (Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
                  (Tezos_raw_protocol_alpha.Storage.Vote.Listings.get_option
                    ctxt delegate)
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        0
                    | Some count =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        count
                    end))
                (fun count =>
                  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                    (Tezos_raw_protocol_alpha.Storage.Vote.Listings.init_set
                      ctxt delegate
                      (Tezos_protocol_environment_alpha__Environment.Int32.succ
                        count))
                    (fun ctxt =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad._return
                        (ctxt,
                          (Tezos_protocol_environment_alpha__Environment.Int32.succ
                            total))))
            end) (ctxt, 0))
    (fun function_parameter =>
      match function_parameter with
      | (ctxt, total) =>
        Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
          (Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.init ctxt total)
          (fun ctxt =>
            Tezos_protocol_environment_alpha__Environment.Error_monad._return
              ctxt)
      end).

Definition listing_size
  : Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.value) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.get.

Definition in_listings
  : Tezos_raw_protocol_alpha.Storage.Vote.Listings.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Listings.key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
  Tezos_raw_protocol_alpha.Storage.Vote.Listings.mem.

Definition get_listings
  : Tezos_raw_protocol_alpha.Storage.Vote.Listings.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list
        (Tezos_raw_protocol_alpha.Storage.Vote.Listings.key *
          Tezos_raw_protocol_alpha.Storage.Vote.Listings.value)) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Listings.bindings.

Definition clear_listings
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Listings.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
    (Tezos_raw_protocol_alpha.Storage.Vote.Listings.clear ctxt)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
        (Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.remove ctxt)
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt)).

Definition get_current_period_kind
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.value) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.get.

Definition set_current_period_kind
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.value ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.set.

Definition get_current_quorum
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32) :=
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.get ctxt)
    (fun participation_ema =>
      let quorum_min :=
        Tezos_raw_protocol_alpha.Constants_storage.quorum_min ctxt in
      let quorum_max :=
        Tezos_raw_protocol_alpha.Constants_storage.quorum_max ctxt in
      let quorum_diff :=
        Tezos_protocol_environment_alpha__Environment.Int32.sub quorum_max
          quorum_min in
      Tezos_protocol_environment_alpha__Environment.Error_monad._return
        (Tezos_protocol_environment_alpha__Environment.Int32.add quorum_min
          (Tezos_protocol_environment_alpha__Environment.Int32.div
            (Tezos_protocol_environment_alpha__Environment.Int32.mul
              participation_ema quorum_diff) 10000))).

Definition get_participation_ema
  : Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.value) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.get.

Definition set_participation_ema
  : Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.value ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.set.

Definition get_current_proposal
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.value) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.get.

Definition init_current_proposal
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.value ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.init.

Definition clear_current_proposal
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
  Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.delete.

Definition init (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let participation_ema :=
    Tezos_raw_protocol_alpha.Constants_storage.quorum_max ctxt in
  Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.init ctxt
      participation_ema)
    (fun ctxt =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq_question
        (Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.init ctxt
          Proposal)
        (fun ctxt =>
          Tezos_protocol_environment_alpha__Environment.Error_monad._return ctxt)).
src/proto_alpha/lib_protocol/vote_storage.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Manages all the voting related storage in Storage.Vote.  *)

(** Records a protocol proposal with the delegate that proposed it. *)
val record_proposal :
  Raw_context.t ->
  Protocol_hash.t ->
  Signature.Public_key_hash.t ->
  Raw_context.t tzresult Lwt.t

val recorded_proposal_count_for_delegate :
  Raw_context.t -> Signature.Public_key_hash.t -> int tzresult Lwt.t

(** Computes for each proposal how many delegates proposed it. *)
val get_proposals : Raw_context.t -> int32 Protocol_hash.Map.t tzresult Lwt.t

val clear_proposals : Raw_context.t -> Raw_context.t Lwt.t

(** Counts of the votes *)
type ballots = {yay : int32; nay : int32; pass : int32}

val ballots_encoding : ballots Data_encoding.t

val has_recorded_ballot :
  Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t

(** Records a vote for a delegate, returns a {!Storage_error Existing_key} if
    the vote was already registered *)
val record_ballot :
  Raw_context.t ->
  Signature.Public_key_hash.t ->
  Vote_repr.ballot ->
  Raw_context.t tzresult Lwt.t

(** Computes the sum of the current ballots weighted by stake. *)
val get_ballots : Raw_context.t -> ballots tzresult Lwt.t

val get_ballot_list :
  Raw_context.t -> (Signature.Public_key_hash.t * Vote_repr.ballot) list Lwt.t

val clear_ballots : Raw_context.t -> Raw_context.t Lwt.t

val listings_encoding :
  (Signature.Public_key_hash.t * int32) list Data_encoding.t

(** Populates [!Storage.Vote.Listings] using the currently existing rolls and
    sets Listings_size. Delegates without rolls are not included in the listing. *)
val freeze_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t

val clear_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t

(** Returns the sum of all rolls of all delegates. *)
val listing_size : Raw_context.t -> int32 tzresult Lwt.t

(** Verifies the presence of a delegate in the listing. *)
val in_listings : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t

val get_listings :
  Raw_context.t -> (Signature.Public_key_hash.t * int32) list Lwt.t

val get_current_quorum : Raw_context.t -> int32 tzresult Lwt.t

val get_participation_ema : Raw_context.t -> int32 tzresult Lwt.t

val set_participation_ema :
  Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t

val get_current_period_kind :
  Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t

val set_current_period_kind :
  Raw_context.t -> Voting_period_repr.kind -> Raw_context.t tzresult Lwt.t

val get_current_proposal : Raw_context.t -> Protocol_hash.t tzresult Lwt.t

val init_current_proposal :
  Raw_context.t -> Protocol_hash.t -> Raw_context.t tzresult Lwt.t

val clear_current_proposal : Raw_context.t -> Raw_context.t tzresult Lwt.t

(** Sets the initial quorum to 80% and period kind to proposal. *)
val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
src/proto_alpha/lib_protocol/vote_storage.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter record_proposal :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter recorded_proposal_count_for_delegate :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z).

Parameter get_proposals :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32)).

Parameter clear_proposals :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    Tezos_raw_protocol_alpha.Raw_context.t.

Record ballots := {
  yay : int32;
  nay : int32;
  pass : int32 }.

Parameter ballots_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t ballots.

Parameter has_recorded_ballot :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t bool.

Parameter record_ballot :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha.Vote_repr.ballot ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t).

Parameter get_ballots :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult ballots).

Parameter get_ballot_list :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Tezos_raw_protocol_alpha.Vote_repr.ballot)).

Parameter clear_ballots :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    Tezos_raw_protocol_alpha.Raw_context.t.

Parameter listings_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t
  (list
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t *
      int32)).

Parameter freeze_listings :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).

Parameter clear_listings :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).

Parameter listing_size :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32).

Parameter in_listings :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t bool.

Parameter get_listings :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * int32)).

Parameter get_current_quorum :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32).

Parameter get_participation_ema :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32).

Parameter set_participation_ema :
Tezos_raw_protocol_alpha.Raw_context.t ->
  int32 ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter get_current_period_kind :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Voting_period_repr.kind).

Parameter set_current_period_kind :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_raw_protocol_alpha.Voting_period_repr.kind ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter get_current_proposal :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)).

Parameter init_current_proposal :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t).

Parameter clear_current_proposal :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).

Parameter init :
Tezos_raw_protocol_alpha.Raw_context.t ->
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t).
src/proto_alpha/lib_protocol/voting_period_repr.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type voting_period = t

include (Compare.Int32 : Compare.S with type t := t)

let encoding = Data_encoding.int32

let pp ppf level = Format.fprintf ppf "%ld" level

let rpc_arg =
  let construct voting_period = Int32.to_string voting_period in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse voting period"
    | voting_period ->
        Ok voting_period
  in
  RPC_arg.make
    ~descr:"A voting period"
    ~name:"voting_period"
    ~construct
    ~destruct
    ()

let root = 0l

let succ = Int32.succ

let to_int32 l = l

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l
  else invalid_arg "Voting_period_repr.of_int32"

type kind = Proposal | Testing_vote | Testing | Promotion_vote

let kind_encoding =
  let open Data_encoding in
  union
    ~tag_size:`Uint8
    [ case
        (Tag 0)
        ~title:"Proposal"
        (constant "proposal")
        (function Proposal -> Some () | _ -> None)
        (fun () -> Proposal);
      case
        (Tag 1)
        ~title:"Testing_vote"
        (constant "testing_vote")
        (function Testing_vote -> Some () | _ -> None)
        (fun () -> Testing_vote);
      case
        (Tag 2)
        ~title:"Testing"
        (constant "testing")
        (function Testing -> Some () | _ -> None)
        (fun () -> Testing);
      case
        (Tag 3)
        ~title:"Promotion_vote"
        (constant "promotion_vote")
        (function Promotion_vote -> Some () | _ -> None)
        (fun () -> Promotion_vote) ]
src/proto_alpha/lib_protocol/voting_period_repr.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := int32.

Definition voting_period := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.int32.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (level : int32) : unit :=
  Tezos_protocol_environment_alpha__Environment.Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        CamlinternalFormatBasics.End_of_format) "%ld" % string) level.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
  let construct (voting_period : int32) : string :=
    Tezos_protocol_environment_alpha__Environment.Int32.to_string voting_period
    in
  let destruct (str : string)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
      string :=
    match Tezos_protocol_environment_alpha__Environment.Int32.of_string str with
    | voting_period => inl voting_period
    end in
  Tezos_protocol_environment_alpha__Environment.RPC_arg.make
    (Some "A voting period" % string) "voting_period" % string destruct
    construct tt.

Definition root : int32 := 0.

Definition succ : int32 -> int32 :=
  Tezos_protocol_environment_alpha__Environment.Int32.succ.

Definition to_int32 {A : Type} (l : A) : A := l.

Definition of_int32_exn
  (l :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt_eq)
      l 0 then
    l
  else
    Tezos_protocol_environment_alpha__Environment.Pervasives.invalid_arg
      "Voting_period_repr.of_int32" % string.

Inductive kind : Type :=
| Proposal : kind
| Testing_vote : kind
| Testing : kind
| Promotion_vote : kind.

Definition kind_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding kind :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.union
    (Some variant)
    (cons
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        "Proposal" % string None (Tag 0)
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
          "proposal" % string)
        (fun function_parameter =>
          match function_parameter with
          | Proposal => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          match function_parameter with
          | tt => Proposal
          end))
      (cons
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          "Testing_vote" % string None (Tag 1)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
            "testing_vote" % string)
          (fun function_parameter =>
            match function_parameter with
            | Testing_vote => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | tt => Testing_vote
            end))
        (cons
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            "Testing" % string None (Tag 2)
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
              "testing" % string)
            (fun function_parameter =>
              match function_parameter with
              | Testing => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | tt => Testing
              end))
          (cons
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.case
              "Promotion_vote" % string None (Tag 3)
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.constant
                "promotion_vote" % string)
              (fun function_parameter =>
                match function_parameter with
                | Promotion_vote => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | tt => Promotion_vote
                end)) [])))).
src/proto_alpha/lib_protocol/voting_period_repr.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** A voting period can be of 4 kinds and is uniquely identified as a counter
    since the root. *)

type t

type voting_period = t

val encoding : voting_period Data_encoding.t

val rpc_arg : voting_period RPC_arg.arg

val pp : Format.formatter -> voting_period -> unit

include Compare.S with type t := voting_period

val to_int32 : voting_period -> int32

val of_int32_exn : int32 -> voting_period

val root : voting_period

val succ : voting_period -> voting_period

type kind =
  | Proposal  (** protocols can be proposed *)
  | Testing_vote  (** a proposal can be voted *)
  | Testing  (** winning proposal is forked on a testnet *)
  | Promotion_vote  (** activation can be voted *)

val kind_encoding : kind Data_encoding.t
src/proto_alpha/lib_protocol/voting_period_repr.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter t : Type.

Definition voting_period := t.

Parameter encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t voting_period.

Parameter rpc_arg :
Tezos_protocol_environment_alpha__Environment.RPC_arg.arg voting_period.

Parameter pp :
Tezos_protocol_environment_alpha__Environment.Format.formatter ->
  voting_period -> unit.

include

Parameter to_int32 : voting_period -> int32.

Parameter of_int32_exn : int32 -> voting_period.

Parameter root : voting_period.

Parameter succ : voting_period -> voting_period.

Inductive kind : Type :=
| Proposal : kind
| Testing_vote : kind
| Testing : kind
| Promotion_vote : kind.

Parameter kind_encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.t kind.
src/proto_alpha/lib_protocol/voting_services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

module S = struct
  let path = RPC_path.(open_root / "votes")

  let ballots =
    RPC_service.get_service
      ~description:"Sum of ballots casted so far during a voting period."
      ~query:RPC_query.empty
      ~output:Vote.ballots_encoding
      RPC_path.(path / "ballots")

  let ballot_list =
    RPC_service.get_service
      ~description:"Ballots casted so far during a voting period."
      ~query:RPC_query.empty
      ~output:
        Data_encoding.(
          list
            (obj2
               (req "pkh" Signature.Public_key_hash.encoding)
               (req "ballot" Vote.ballot_encoding)))
      RPC_path.(path / "ballot_list")

  let current_period_kind =
    RPC_service.get_service
      ~description:"Current period kind."
      ~query:RPC_query.empty
      ~output:Voting_period.kind_encoding
      RPC_path.(path / "current_period_kind")

  let current_quorum =
    RPC_service.get_service
      ~description:"Current expected quorum."
      ~query:RPC_query.empty
      ~output:Data_encoding.int32
      RPC_path.(path / "current_quorum")

  let listings =
    RPC_service.get_service
      ~description:
        "List of delegates with their voting weight, in number of rolls."
      ~query:RPC_query.empty
      ~output:Vote.listings_encoding
      RPC_path.(path / "listings")

  let proposals =
    RPC_service.get_service
      ~description:"List of proposals with number of supporters."
      ~query:RPC_query.empty
      ~output:(Protocol_hash.Map.encoding Data_encoding.int32)
      RPC_path.(path / "proposals")

  let current_proposal =
    RPC_service.get_service
      ~description:"Current proposal under evaluation."
      ~query:RPC_query.empty
      ~output:(Data_encoding.option Protocol_hash.encoding)
      RPC_path.(path / "current_proposal")
end

let register () =
  let open Services_registration in
  register0 S.ballots (fun ctxt () () -> Vote.get_ballots ctxt) ;
  register0 S.ballot_list (fun ctxt () () -> Vote.get_ballot_list ctxt >|= ok) ;
  register0 S.current_period_kind (fun ctxt () () ->
      Vote.get_current_period_kind ctxt) ;
  register0 S.current_quorum (fun ctxt () () -> Vote.get_current_quorum ctxt) ;
  register0 S.proposals (fun ctxt () () -> Vote.get_proposals ctxt) ;
  register0 S.listings (fun ctxt () () -> Vote.get_listings ctxt >|= ok) ;
  register0 S.current_proposal (fun ctxt () () ->
      (* this would be better implemented using get_option in get_current_proposal *)
      Vote.get_current_proposal ctxt
      >>= function
      | Ok p ->
          return_some p
      | Error (Raw_context.Storage_error (Missing_key _) :: _) ->
          return_none
      | Error _ as e ->
          Lwt.return e)

let ballots ctxt block = RPC_context.make_call0 S.ballots ctxt block () ()

let ballot_list ctxt block =
  RPC_context.make_call0 S.ballot_list ctxt block () ()

let current_period_kind ctxt block =
  RPC_context.make_call0 S.current_period_kind ctxt block () ()

let current_quorum ctxt block =
  RPC_context.make_call0 S.current_quorum ctxt block () ()

let listings ctxt block = RPC_context.make_call0 S.listings ctxt block () ()

let proposals ctxt block = RPC_context.make_call0 S.proposals ctxt block () ()

let current_proposal ctxt block =
  RPC_context.make_call0 S.current_proposal ctxt block () ()
src/proto_alpha/lib_protocol/voting_services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_raw_protocol_alpha.Alpha_context.

Module S.
  Definition path
    : Tezos_protocol_environment_alpha__Environment.RPC_path.path
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
    Tezos_protocol_environment_alpha__Environment.RPC_path.op_div
      Tezos_protocol_environment_alpha__Environment.RPC_path.open_root
      "votes" % string.
  
  Definition ballots
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Sum of ballots casted so far during a voting period." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots_encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "ballots" % string).
  
  Definition ballot_list
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Ballots casted so far during a voting period." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.list None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.obj2
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "pkh" % string
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.encoding)
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.req None
            None "ballot" % string
            Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot_encoding)))
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "ballot_list" % string).
  
  Definition current_period_kind
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Current period kind." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind_encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "current_period_kind" % string).
  
  Definition current_quorum
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit int32 :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Current expected quorum." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_protocol_environment_alpha__Environment.Data_encoding.int32
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "current_quorum" % string).
  
  Definition listings
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * int32)) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some
        "List of delegates with their voting weight, in number of rolls." %
          string) Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      Tezos_raw_protocol_alpha.Alpha_context.Vote.listings_encoding
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "listings" % string).
  
  Definition proposals
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "List of proposals with number of supporters." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.encoding
        Tezos_protocol_environment_alpha__Environment.Data_encoding.int32)
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "proposals" % string).
  
  Definition current_proposal
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit
      (option
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)) :=
    Tezos_protocol_environment_alpha__Environment.RPC_service.get_service
      (Some "Current proposal under evaluation." % string)
      Tezos_protocol_environment_alpha__Environment.RPC_query.empty
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.option
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
      (Tezos_protocol_environment_alpha__Environment.RPC_path.op_div path
        "current_proposal" % string).
End S.

Definition register (function_parameter : unit) : unit :=
  match function_parameter with
  | tt =>
    Tezos_raw_protocol_alpha.Services_registration.register0 S.ballots
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_raw_protocol_alpha.Alpha_context.Vote.get_ballots ctxt
              end
          end);
    Tezos_raw_protocol_alpha.Services_registration.register0 S.ballot_list
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_eq
                  (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_ballot_list
                    ctxt)
                  Tezos_protocol_environment_alpha__Environment.Error_monad.ok
              end
          end);
    Tezos_raw_protocol_alpha.Services_registration.register0
      S.current_period_kind
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_period_kind
                  ctxt
              end
          end);
    Tezos_raw_protocol_alpha.Services_registration.register0 S.current_quorum
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_quorum
                  ctxt
              end
          end);
    Tezos_raw_protocol_alpha.Services_registration.register0 S.proposals
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_raw_protocol_alpha.Alpha_context.Vote.get_proposals ctxt
              end
          end);
    Tezos_raw_protocol_alpha.Services_registration.register0 S.listings
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_pipe_eq
                  (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_listings ctxt)
                  Tezos_protocol_environment_alpha__Environment.Error_monad.ok
              end
          end);
    Tezos_raw_protocol_alpha.Services_registration.register0 S.current_proposal
      (fun ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_alpha__Environment.Error_monad.op_gt_gt_eq
                  (Tezos_raw_protocol_alpha.Alpha_context.Vote.get_current_proposal
                    ctxt)
                  (fun function_parameter =>
                    match function_parameter with
                    | inl p =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_some
                        p
                    | inr (cons (Raw_context.Storage_error (Missing_key _ _)) _)
                      =>
                      Tezos_protocol_environment_alpha__Environment.Error_monad.return_none
                    | (inr _) as e =>
                      Tezos_protocol_environment_alpha__Environment.Lwt._return
                        e
                    end)
              end
          end)
  end.

Definition ballots {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0 S.ballots
    ctxt block tt tt.

Definition ballot_list {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot))) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
    S.ballot_list ctxt block tt tt.

Definition current_period_kind {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
    S.current_period_kind ctxt block tt tt.

Definition current_quorum {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      int32) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
    S.current_quorum ctxt block tt tt.

Definition listings {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * int32))) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
    S.listings ctxt block tt tt.

Definition proposals {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32)) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
    S.proposals ctxt block tt tt.

Definition current_proposal {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))) :=
  Tezos_protocol_environment_alpha__Environment.RPC_context.make_call0
    S.current_proposal ctxt block tt tt.
src/proto_alpha/lib_protocol/voting_services.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

val ballots : 'a #RPC_context.simple -> 'a -> Vote.ballots shell_tzresult Lwt.t

val ballot_list :
  'a #RPC_context.simple ->
  'a ->
  (Signature.Public_key_hash.t * Vote.ballot) list shell_tzresult Lwt.t

val current_period_kind :
  'a #RPC_context.simple -> 'a -> Voting_period.kind shell_tzresult Lwt.t

val current_quorum :
  'a #RPC_context.simple -> 'a -> Int32.t shell_tzresult Lwt.t

val listings :
  'a #RPC_context.simple ->
  'a ->
  (Signature.Public_key_hash.t * int32) list shell_tzresult Lwt.t

val proposals :
  'a #RPC_context.simple ->
  'a ->
  Int32.t Protocol_hash.Map.t shell_tzresult Lwt.t

val current_proposal :
  'a #RPC_context.simple -> 'a -> Protocol_hash.t option shell_tzresult Lwt.t

val register : unit -> unit
src/proto_alpha/lib_protocol/voting_services.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter ballots : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots).

Parameter ballot_list : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
            * Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot))).

Parameter current_period_kind : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind).

Parameter current_quorum : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.Int32.t).

Parameter listings : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
            * int32))).

Parameter proposals : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t
          Tezos_protocol_environment_alpha__Environment.Int32.t)).

Parameter current_proposal : forall {_ a b c i o q variant : Type},
(((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
  Tezos_protocol_environment_alpha__Environment.RPC_context.t
  Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
  a ->
    q ->
      i ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            o)) * (_ * q * i * o)) *
  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
    Tezos_protocol_environment_alpha__Environment.RPC_context.t
    (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o) ->
    a ->
      a ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (_ * a * q * i * o)) *
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b) q
      i o) ->
      a ->
        a ->
          b ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * b * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          * c) q i o) ->
        a ->
          a ->
            b ->
              c ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (_ * a * b * c * q * i * o)) * _)))) * _ * a) ->
  a ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (option
          Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))).

Parameter register : unit -> unit.
src/proto_demo_noops/lib_protocol/main.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let max_block_length = 100

let max_operation_data_length = 0

let validation_passes = []

let acceptable_passes _op = []

type block_header_data = string

let block_header_data_encoding =
  Data_encoding.(obj1 (req "block_header_data" string))

type block_header = {
  shell : Block_header.shell_header;
  protocol_data : block_header_data;
}

type block_header_metadata = unit

let block_header_metadata_encoding = Data_encoding.unit

type operation_data = unit

let operation_data_encoding = Data_encoding.unit

type operation_receipt = unit

let operation_receipt_encoding = Data_encoding.unit

let operation_data_and_receipt_encoding =
  Data_encoding.conv
    (function ((), ()) -> ())
    (fun () -> ((), ()))
    Data_encoding.unit

type operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

let compare_operations _ _ = 0

type validation_state = {context : Context.t; fitness : Fitness.t}

let current_context {context; _} = return context

let begin_application ~chain_id:_ ~predecessor_context:context
    ~predecessor_timestamp:_ ~predecessor_fitness (raw_block : block_header) =
  let fitness = raw_block.shell.fitness in
  Logging.log_notice
    "begin_application: pred_fitness = %a  block_fitness = %a%!"
    Fitness.pp
    predecessor_fitness
    Fitness.pp
    fitness ;
  (* Note: Logging is only available for debugging purposes and should
     not appear in a real protocol. *)
  return {context; fitness}

let begin_partial_application ~chain_id ~ancestor_context
    ~predecessor_timestamp ~predecessor_fitness block_header =
  Logging.log_notice "begin_partial_application%!" ;
  begin_application
    ~chain_id
    ~predecessor_context:ancestor_context
    ~predecessor_timestamp
    ~predecessor_fitness
    block_header

let version_number = "\001"

let int64_to_bytes i =
  let b = MBytes.create 8 in
  MBytes.set_int64 b 0 i ; b

let fitness_from_level level =
  [MBytes.of_string version_number; int64_to_bytes level]

let begin_construction ~chain_id:_ ~predecessor_context:context
    ~predecessor_timestamp:_ ~predecessor_level ~predecessor_fitness
    ~predecessor:_ ~timestamp:_ ?protocol_data () =
  let fitness = fitness_from_level Int64.(succ (of_int32 predecessor_level)) in
  let mode =
    match protocol_data with Some _ -> "block" | None -> "mempool"
  in
  Logging.log_notice
    "begin_construction (%s): pred_fitness = %a  constructed fitness = %a%!"
    mode
    Fitness.pp
    predecessor_fitness
    Fitness.pp
    fitness ;
  return {context; fitness}

let apply_operation _state _op = Lwt.return (Error [])

let finalize_block state =
  let fitness = state.fitness in
  Logging.log_notice "finalize_block: fitness = %a%!" Fitness.pp fitness ;
  return
    ( {
        Updater.message = None;
        context = state.context;
        fitness;
        max_operations_ttl = 0;
        last_allowed_fork_level = 0l;
      },
      () )

let init context block_header =
  let open Block_header in
  let fitness = block_header.fitness in
  Logging.log_notice "init: fitness = %a%!" Fitness.pp fitness ;
  return
    {
      Updater.message = None;
      context;
      fitness;
      max_operations_ttl = 0;
      last_allowed_fork_level = 0l;
    }

let rpc_services = RPC_directory.empty
src/proto_demo_noops/lib_protocol/main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition max_block_length : Z := 100.

Definition max_operation_data_length : Z := 0.

Definition validation_passes {A : Type} : list A := [].

Definition acceptable_passes {A B : Type} (_op : A) : list B := [].

Definition block_header_data := string.

Definition block_header_data_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    string :=
  Tezos_protocol_environment_demo_noops__Environment.Data_encoding.obj1
    (Tezos_protocol_environment_demo_noops__Environment.Data_encoding.req None
      None "block_header_data" % string
      Tezos_protocol_environment_demo_noops__Environment.Data_encoding.string).

Record block_header := {
  shell :
    Tezos_protocol_environment_demo_noops__Environment.Block_header.shell_header;
  protocol_data : block_header_data }.

Definition block_header_metadata := unit.

Definition block_header_metadata_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    unit :=
  Tezos_protocol_environment_demo_noops__Environment.Data_encoding.unit.

Definition operation_data := unit.

Definition operation_data_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    unit :=
  Tezos_protocol_environment_demo_noops__Environment.Data_encoding.unit.

Definition operation_receipt := unit.

Definition operation_receipt_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    unit :=
  Tezos_protocol_environment_demo_noops__Environment.Data_encoding.unit.

Definition operation_data_and_receipt_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    (unit * unit) :=
  Tezos_protocol_environment_demo_noops__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | (tt, tt) => tt
      end)
    (fun function_parameter =>
      match function_parameter with
      | tt => (tt, tt)
      end) None
    Tezos_protocol_environment_demo_noops__Environment.Data_encoding.unit.

Record operation := {
  shell :
    Tezos_protocol_environment_demo_noops__Environment.Operation.shell_header;
  protocol_data : operation_data }.

Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ => 0
      end
  end.

Record validation_state := {
  context : Tezos_protocol_environment_demo_noops__Environment.Context.t;
  fitness :
    Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
  }.

Definition current_context (function_parameter : validation_state)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
      Tezos_protocol_environment_demo_noops__Environment.Context.t) :=
  match function_parameter with
  | {| context := context |} =>
    Tezos_protocol_environment_demo_noops__Environment.Error_monad._return
      context
  end.

Definition begin_application {A B : Type} (function_parameter : A)
  : Tezos_protocol_environment_demo_noops__Environment.Context.t ->
    B ->
      Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
        ->
        block_header ->
          Tezos_protocol_environment_demo_noops__Environment.Lwt.t
            (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
              validation_state) :=
  match function_parameter with
  | _ =>
    fun context =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun predecessor_fitness =>
            fun raw_block =>
              let fitness := fitness (shell raw_block) in
              Tezos_protocol_environment_demo_noops__Environment.Logging.log_notice
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "begin_application: pred_fitness = " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        "  block_fitness = " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Flush
                            CamlinternalFormatBasics.End_of_format)))))
                  "begin_application: pred_fitness = %a  block_fitness = %a%!" %
                    string)
                Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
                predecessor_fitness
                Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
                fitness;
              Tezos_protocol_environment_demo_noops__Environment.Error_monad._return
                {| context := context; fitness := fitness |}
        end
  end.

Definition begin_partial_application {A B : Type}
  (chain_id : A)
  (ancestor_context :
    Tezos_protocol_environment_demo_noops__Environment.Context.t)
  (predecessor_timestamp : B)
  (predecessor_fitness :
    Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t))
  (block_header : block_header)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
      validation_state) :=
  Tezos_protocol_environment_demo_noops__Environment.Logging.log_notice
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal
        "begin_partial_application" % string
        (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
      "begin_partial_application%!" % string);
  begin_application chain_id ancestor_context predecessor_timestamp
    predecessor_fitness block_header.

Definition version_number : string := "" % string.

Definition int64_to_bytes (i : int64)
  : Tezos_protocol_environment_demo_noops__Environment.MBytes.t :=
  let b := Tezos_protocol_environment_demo_noops__Environment.MBytes.create 8 in
  Tezos_protocol_environment_demo_noops__Environment.MBytes.set_int64 b 0 i;
  b.

Definition fitness_from_level (level : int64)
  : list Tezos_protocol_environment_demo_noops__Environment.MBytes.t :=
  cons
    (Tezos_protocol_environment_demo_noops__Environment.MBytes.of_string
      version_number) (cons (int64_to_bytes level) []).

Definition begin_construction {A B C D E : Type} (function_parameter : A)
  : Tezos_protocol_environment_demo_noops__Environment.Context.t ->
    B ->
      int32 ->
        Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
          ->
          C ->
            D ->
              (option E) ->
                unit ->
                  Tezos_protocol_environment_demo_noops__Environment.Lwt.t
                    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
                      validation_state) :=
  match function_parameter with
  | _ =>
    fun context =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun predecessor_level =>
            fun predecessor_fitness =>
              fun function_parameter =>
                match function_parameter with
                | _ =>
                  fun function_parameter =>
                    match function_parameter with
                    | _ =>
                      fun protocol_data =>
                        fun function_parameter =>
                          match function_parameter with
                          | tt =>
                            let fitness :=
                              fitness_from_level
                                (Tezos_protocol_environment_demo_noops__Environment.Int64.succ
                                  (Tezos_protocol_environment_demo_noops__Environment.Int64.of_int32
                                    predecessor_level)) in
                            let mode :=
                              match protocol_data with
                              | Some _ => "block" % string
                              | None => "mempool" % string
                              end in
                            Tezos_protocol_environment_demo_noops__Environment.Logging.log_notice
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "begin_construction (" % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String_literal
                                      "): pred_fitness = " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          "  constructed fitness = " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Flush
                                              CamlinternalFormatBasics.End_of_format)))))))
                                "begin_construction (%s): pred_fitness = %a  constructed fitness = %a%!"
                                  % string) mode
                              Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
                              predecessor_fitness
                              Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
                              fitness;
                            Tezos_protocol_environment_demo_noops__Environment.Error_monad._return
                              {| context := context; fitness := fitness |}
                          end
                    end
                end
        end
  end.

Definition apply_operation {A B C D : Type} (_state : A) (_op : B)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Pervasives.result C
      (list D)) :=
  Tezos_protocol_environment_demo_noops__Environment.Lwt._return (inr []).

Definition finalize_block (state : validation_state)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_demo_noops__Environment.Updater.validation_result
        * unit)) :=
  let fitness := fitness state in
  Tezos_protocol_environment_demo_noops__Environment.Logging.log_notice
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal
        "finalize_block: fitness = " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format)))
      "finalize_block: fitness = %a%!" % string)
    Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
    fitness;
  Tezos_protocol_environment_demo_noops__Environment.Error_monad._return
    ({| Updater.context := context state; Updater.fitness := fitness;
      Updater.message := None; Updater.max_operations_ttl := 0;
      Updater.last_allowed_fork_level := 0 |}, tt).

Definition init
  (context : Tezos_protocol_environment_demo_noops__Environment.Context.t)
  (block_header :
    Tezos_protocol_environment_demo_noops__Environment.Block_header.shell_header)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
      Tezos_protocol_environment_demo_noops__Environment.Updater.validation_result) :=
  let fitness := fitness block_header in
  Tezos_protocol_environment_demo_noops__Environment.Logging.log_notice
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "init: fitness = " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format)))
      "init: fitness = %a%!" % string)
    Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
    fitness;
  Tezos_protocol_environment_demo_noops__Environment.Error_monad._return
    {| Updater.context := context; Updater.fitness := fitness;
      Updater.message := None; Updater.max_operations_ttl := 0;
      Updater.last_allowed_fork_level := 0 |}.

Definition rpc_services {A : Type}
  : Tezos_protocol_environment_demo_noops__Environment.RPC_directory.directory A :=
  Tezos_protocol_environment_demo_noops__Environment.RPC_directory.empty.
src/proto_demo_noops/lib_protocol/main.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Protocol Signature Instance *)

include Updater.PROTOCOL with type block_header_data = string
src/proto_demo_noops/lib_protocol/main.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

include
src/proto_genesis/lib_client/client_proto_main.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Protocol_client_context

let protocol =
  Protocol_hash.of_b58check_exn
    "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im"

let bake cctxt ?timestamp block command sk =
  let timestamp =
    match timestamp with
    | Some t ->
        t
    | None ->
        Time.System.(to_protocol (Tezos_stdlib_unix.Systime_os.now ()))
  in
  let protocol_data = {command; signature = Signature.zero} in
  Genesis_block_services.Helpers.Preapply.block
    cctxt
    ~block
    ~timestamp
    ~protocol_data
    []
  >>=? fun (shell_header, _) ->
  let blk = Data.Command.forge shell_header command in
  Shell_services.Chain.chain_id cctxt ~chain:`Main ()
  >>=? fun chain_id ->
  Client_keys.append cctxt sk ~watermark:(Block_header chain_id) blk
  >>=? fun signed_blk -> Shell_services.Injection.block cctxt signed_blk []

let int64_parameter =
  Clic.parameter (fun _ p ->
      try return (Int64.of_string p) with _ -> failwith "Cannot read int64")

let file_parameter =
  Clic.parameter (fun _ p ->
      if not (Sys.file_exists p) then failwith "File doesn't exist: '%s'" p
      else return p)

let fitness_from_int64 fitness =
  (* definition taken from src/proto_alpha/lib_protocol/src/constants_repr.ml *)
  let version_number = "\000" in
  (* definitions taken from src/proto_alpha/lib_protocol/src/fitness_repr.ml *)
  let int64_to_bytes i =
    let b = Bytes.create 8 in
    TzEndian.set_int64 b 0 i ; b
  in
  [Bytes.of_string version_number; int64_to_bytes fitness]

let timestamp_arg =
  Clic.arg
    ~long:"timestamp"
    ~placeholder:"date"
    ~doc:"Set the timestamp of the block (and initial time of the chain)"
    (Clic.parameter (fun _ t ->
         match Time.System.of_notation_opt t with
         | None ->
             Error_monad.failwith
               "Could not parse value provided to -timestamp option"
         | Some t ->
             return t))

let test_delay_arg =
  Clic.default_arg
    ~long:"delay"
    ~placeholder:"time"
    ~doc:"Set the life span of the test chain (in seconds)"
    ~default:(Int64.to_string (Int64.mul 24L 3600L))
    (Clic.parameter (fun _ t ->
         match Int64.of_string_opt t with
         | None ->
             Error_monad.failwith
               "Could not parse value provided to -delay option"
         | Some t ->
             return t))

let proto_param ~name ~desc t =
  Clic.param
    ~name
    ~desc
    (Clic.parameter (fun _ str -> Lwt.return (Protocol_hash.of_b58check str)))
    t

let commands () =
  let open Clic in
  let args =
    args1
      (arg
         ~long:"timestamp"
         ~placeholder:"date"
         ~doc:"Set the timestamp of the block (and initial time of the chain)"
         (parameter (fun _ t ->
              match Time.Protocol.of_notation t with
              | None ->
                  Error_monad.failwith
                    "Could not parse value provided to -timestamp option"
              | Some t ->
                  return t)))
  in
  [ command
      ~desc:"Activate a protocol"
      args
      ( prefixes ["activate"; "protocol"]
      @@ proto_param ~name:"version" ~desc:"Protocol version (b58check)"
      @@ prefixes ["with"; "fitness"]
      @@ param
           ~name:"fitness"
           ~desc:"Hardcoded fitness of the first block (integer)"
           int64_parameter
      @@ prefixes ["and"; "key"]
      @@ Client_keys.Secret_key.source_param
           ~name:"password"
           ~desc:"Activator's key"
      @@ prefixes ["and"; "parameters"]
      @@ param
           ~name:"parameters"
           ~desc:"Protocol parameters (as JSON file)"
           file_parameter
      @@ stop )
      (fun timestamp
           hash
           fitness
           sk
           param_json_file
           (cctxt : Client_context.full) ->
        let fitness = fitness_from_int64 fitness in
        Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file
        >>=? fun json ->
        let protocol_parameters =
          Data_encoding.Binary.to_bytes_exn Data_encoding.json json
        in
        bake
          cctxt
          ?timestamp
          cctxt#block
          (Activate {protocol = hash; fitness; protocol_parameters})
          sk
        >>=? fun hash ->
        cctxt#answer "Injected %a" Block_hash.pp_short hash
        >>= fun () -> return_unit);
    command
      ~desc:"Fork a test protocol"
      (args2 timestamp_arg test_delay_arg)
      ( prefixes ["fork"; "test"; "protocol"]
      @@ proto_param ~name:"version" ~desc:"Protocol version (b58check)"
      @@ prefixes ["with"; "fitness"]
      @@ param
           ~name:"fitness"
           ~desc:
             "Hardcoded fitness of the first block of the testchain (integer)"
           int64_parameter
      @@ prefixes ["and"; "key"]
      @@ Client_keys.Secret_key.source_param
           ~name:"password"
           ~desc:"Activator's key"
      @@ prefixes ["and"; "parameters"]
      @@ param
           ~name:"parameters"
           ~desc:"Testchain protocol parameters (as JSON file)"
           file_parameter
      @@ stop )
      (fun (timestamp, delay) hash fitness sk param_json_file cctxt ->
        let fitness = fitness_from_int64 fitness in
        Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file
        >>=? fun json ->
        let protocol_parameters =
          Data_encoding.Binary.to_bytes_exn Data_encoding.json json
        in
        let timestamp = Option.map ~f:Time.System.to_protocol timestamp in
        bake
          cctxt
          ?timestamp
          cctxt#block
          (Activate_testchain
             {protocol = hash; fitness; protocol_parameters; delay})
          sk
        >>=? fun hash ->
        cctxt#answer "Injected %a" Block_hash.pp_short hash
        >>= fun () -> return_unit) ]

let () = Client_commands.register protocol @@ fun _network -> commands ()
src/proto_genesis/lib_client/client_proto_main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_genesis.Protocol.

Import Tezos_client_genesis.Protocol_client_context.

Definition protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Tezos_base__TzPervasives.Protocol_hash.of_b58check_exn
    "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" % string.

Definition bake {E G a i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        ((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * G))))))
      *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        ((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * G))))))
  (timestamp : option Tezos_base__TzPervasives.Time.Protocol.t)
  (block : Tezos_shell_services__Block_services.block)
  (command : Tezos_raw_protocol_genesis.Data.Command.t)
  (sk : Tezos_client_base.Client_keys.sk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_hash.t) :=
  let timestamp :=
    match timestamp with
    | Some t => t
    | None =>
      Tezos_base__TzPervasives.Time.System.to_protocol
        (Tezos_stdlib_unix.Systime_os.now tt)
    end in
  let protocol_data :=
    {| command := command; signature := Tezos_base__TzPervasives.Signature.zero
      |} in
  Tezos_base__TzPervasives.op_gt_gt_eq_question
    (Tezos_client_genesis.Protocol_client_context.Genesis_block_services.Helpers.Preapply.block
      cctxt None (Some block) None (Some timestamp) protocol_data [])
    (fun function_parameter =>
      match function_parameter with
      | (shell_header, _) =>
        let blk :=
          Tezos_protocol_genesis.Protocol.Data.Command.forge shell_header
            command in
        Tezos_base__TzPervasives.op_gt_gt_eq_question
          (Tezos_shell_services.Shell_services.Chain.chain_id cctxt
            (Some variant) tt)
          (fun chain_id =>
            Tezos_base__TzPervasives.op_gt_gt_eq_question
              (Tezos_client_base.Client_keys.append cctxt
                (Some (Block_header chain_id)) sk blk)
              (fun signed_blk =>
                Tezos_shell_services.Shell_services.Injection.block cctxt None
                  None None signed_blk []))
      end).

Definition int64_parameter
  : Tezos_base__TzPervasives.Clic.parameter int64
    Tezos_client_base.Client_context.full :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ => fun p => try
      end).

Definition file_parameter
  : Tezos_base__TzPervasives.Clic.parameter string
    Tezos_client_base.Client_context.full :=
  Tezos_base__TzPervasives.Clic.parameter None
    (fun function_parameter =>
      match function_parameter with
      | _ =>
        fun p =>
          if negb (Stdlib.Sys.file_exists p) then
            Tezos_base__TzPervasives.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "File doesn't exist: '" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal "'" % char
                      CamlinternalFormatBasics.End_of_format)))
                "File doesn't exist: '%s'" % string) p
          else
            Tezos_base__TzPervasives._return p
      end).

Definition fitness_from_int64 (fitness : int64) : list string :=
  let version_number := "" % string in
  let int64_to_bytes (i : int64) : string :=
    let b := Stdlib.Bytes.create 8 in
    Tezos_base__TzPervasives.TzEndian.set_int64 b 0 i;
    b in
  cons (Stdlib.Bytes.of_string version_number)
    (cons (int64_to_bytes fitness) []).

Definition timestamp_arg
  : Tezos_base__TzPervasives.Clic.arg
    (option Tezos_base__TzPervasives.Time.System.t)
    Tezos_client_base.Client_context.full :=
  Tezos_base__TzPervasives.Clic.arg
    "Set the timestamp of the block (and initial time of the chain)" % string
    None "timestamp" % string "date" % string
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun t =>
            match Tezos_base__TzPervasives.Time.System.of_notation_opt t with
            | None =>
              Tezos_base__TzPervasives.Error_monad.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Could not parse value provided to -timestamp option" %
                      string CamlinternalFormatBasics.End_of_format)
                  "Could not parse value provided to -timestamp option" % string)
            | Some t => Tezos_base__TzPervasives._return t
            end
        end)).

Definition test_delay_arg
  : Tezos_base__TzPervasives.Clic.arg int64
    Tezos_client_base.Client_context.full :=
  Tezos_base__TzPervasives.Clic.default_arg
    "Set the life span of the test chain (in seconds)" % string None
    "delay" % string "time" % string
    (Stdlib.Int64.to_string (Stdlib.Int64.mul 24 3600))
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun t =>
            match Stdlib.Int64.of_string_opt t with
            | None =>
              Tezos_base__TzPervasives.Error_monad.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Could not parse value provided to -delay option" % string
                    CamlinternalFormatBasics.End_of_format)
                  "Could not parse value provided to -delay option" % string)
            | Some t => Tezos_base__TzPervasives._return t
            end
        end)).

Definition proto_param {A B : Type}
  (name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.Protocol_hash.t -> A) B :=
  Tezos_base__TzPervasives.Clic.param name desc
    (Tezos_base__TzPervasives.Clic.parameter None
      (fun function_parameter =>
        match function_parameter with
        | _ =>
          fun str =>
            Lwt._return (Tezos_base__TzPervasives.Protocol_hash.of_b58check str)
        end)) t.

Definition commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  match function_parameter with
  | tt =>
    let args :=
      Tezos_base__TzPervasives.Clic.args1
        (Tezos_base__TzPervasives.Clic.arg
          "Set the timestamp of the block (and initial time of the chain)" %
            string None "timestamp" % string "date" % string
          (Tezos_base__TzPervasives.Clic.parameter None
            (fun function_parameter =>
              match function_parameter with
              | _ =>
                fun t =>
                  match Tezos_base__TzPervasives.Time.Protocol.of_notation t
                    with
                  | None =>
                    Tezos_base__TzPervasives.Error_monad.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Could not parse value provided to -timestamp option"
                            % string CamlinternalFormatBasics.End_of_format)
                        "Could not parse value provided to -timestamp option" %
                          string)
                  | Some t => Tezos_base__TzPervasives._return t
                  end
              end))) in
    cons
      (Tezos_base__TzPervasives.Clic.command None "Activate a protocol" % string
        args
        (apply
          (Tezos_base__TzPervasives.Clic.prefixes
            (cons "activate" % string (cons "protocol" % string [])))
          (apply
            (proto_param "version" % string
              "Protocol version (b58check)" % string)
            (apply
              (Tezos_base__TzPervasives.Clic.prefixes
                (cons "with" % string (cons "fitness" % string [])))
              (apply
                (Tezos_base__TzPervasives.Clic.param "fitness" % string
                  "Hardcoded fitness of the first block (integer)" % string
                  int64_parameter)
                (apply
                  (Tezos_base__TzPervasives.Clic.prefixes
                    (cons "and" % string (cons "key" % string [])))
                  (apply
                    (Tezos_client_base.Client_keys.Secret_key.source_param
                      (Some "password" % string)
                      (Some "Activator's key" % string))
                    (apply
                      (Tezos_base__TzPervasives.Clic.prefixes
                        (cons "and" % string (cons "parameters" % string [])))
                      (apply
                        (Tezos_base__TzPervasives.Clic.param
                          "parameters" % string
                          "Protocol parameters (as JSON file)" % string
                          file_parameter) Tezos_base__TzPervasives.Clic.stop))))))))
        (fun timestamp =>
          fun hash =>
            fun fitness =>
              fun sk =>
                fun param_json_file =>
                  fun cctxt =>
                    let fitness := fitness_from_int64 fitness in
                    Tezos_base__TzPervasives.op_gt_gt_eq_question
                      (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file
                        param_json_file)
                      (fun json =>
                        let protocol_parameters :=
                          Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                            Tezos_base__TzPervasives.Data_encoding.json json in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (bake cctxt timestamp send
                            (Activate
                              {| protocol := hash; fitness := fitness;
                                protocol_parameters := protocol_parameters |})
                            sk)
                          (fun hash =>
                            Tezos_base__TzPervasives.op_gt_gt_eq
                              (send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Injected " % string
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format))
                                  "Injected %a" % string)
                                Tezos_base__TzPervasives.Block_hash.pp_short
                                hash)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt => Tezos_base__TzPervasives.return_unit
                                end)))))
      (cons
        (Tezos_base__TzPervasives.Clic.command None
          "Fork a test protocol" % string
          (Tezos_base__TzPervasives.Clic.args2 timestamp_arg test_delay_arg)
          (apply
            (Tezos_base__TzPervasives.Clic.prefixes
              (cons "fork" % string
                (cons "test" % string (cons "protocol" % string []))))
            (apply
              (proto_param "version" % string
                "Protocol version (b58check)" % string)
              (apply
                (Tezos_base__TzPervasives.Clic.prefixes
                  (cons "with" % string (cons "fitness" % string [])))
                (apply
                  (Tezos_base__TzPervasives.Clic.param "fitness" % string
                    "Hardcoded fitness of the first block of the testchain (integer)"
                      % string int64_parameter)
                  (apply
                    (Tezos_base__TzPervasives.Clic.prefixes
                      (cons "and" % string (cons "key" % string [])))
                    (apply
                      (Tezos_client_base.Client_keys.Secret_key.source_param
                        (Some "password" % string)
                        (Some "Activator's key" % string))
                      (apply
                        (Tezos_base__TzPervasives.Clic.prefixes
                          (cons "and" % string (cons "parameters" % string [])))
                        (apply
                          (Tezos_base__TzPervasives.Clic.param
                            "parameters" % string
                            "Testchain protocol parameters (as JSON file)" %
                              string file_parameter)
                          Tezos_base__TzPervasives.Clic.stop))))))))
          (fun function_parameter =>
            match function_parameter with
            | (timestamp, delay) =>
              fun hash =>
                fun fitness =>
                  fun sk =>
                    fun param_json_file =>
                      fun cctxt =>
                        let fitness := fitness_from_int64 fitness in
                        Tezos_base__TzPervasives.op_gt_gt_eq_question
                          (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file
                            param_json_file)
                          (fun json =>
                            let protocol_parameters :=
                              Tezos_base__TzPervasives.Data_encoding.Binary.to_bytes_exn
                                Tezos_base__TzPervasives.Data_encoding.json json
                              in
                            let timestamp :=
                              Tezos_base__TzPervasives.Option.map
                                Tezos_base__TzPervasives.Time.System.to_protocol
                                timestamp in
                            Tezos_base__TzPervasives.op_gt_gt_eq_question
                              (bake cctxt timestamp send
                                (Activate_testchain
                                  {| protocol := hash; fitness := fitness;
                                    protocol_parameters := protocol_parameters;
                                    delay := delay |}) sk)
                              (fun hash =>
                                Tezos_base__TzPervasives.op_gt_gt_eq
                                  (send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Injected " % string
                                        (CamlinternalFormatBasics.Alpha
                                          CamlinternalFormatBasics.End_of_format))
                                      "Injected %a" % string)
                                    Tezos_base__TzPervasives.Block_hash.pp_short
                                    hash)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | tt => Tezos_base__TzPervasives.return_unit
                                    end)))
            end)) [])
  end.
src/proto_genesis/lib_client/client_proto_main.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

val bake :
  #Client_context.full ->
  ?timestamp:Time.Protocol.t ->
  Shell_services.block ->
  Data.Command.t ->
  Client_keys.sk_uri ->
  Block_hash.t tzresult Lwt.t
src/proto_genesis/lib_client/client_proto_main.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter bake : forall {_ a b i o p q variant : Type},
(((float -> Lwt.t unit) *
  ((unit -> Ptime.t) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      (Uri.t *
        (Tezos_shell_services.Shell_services.block *
          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
            p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
            (_ * p * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t
                          (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
              * (_ * p * q * i * o)) *
              (Tezos_shell_services.Shell_services.chain *
                ((option Z) *
                  ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                    (a * b)) *
                    ((Tezos_rpc.RPC_service.meth ->
                      (option Tezos_data_encoding.Data_encoding.json) ->
                        Uri.t ->
                          Lwt.t
                            (Tezos_rpc.RPC_context.rest_result
                              Tezos_data_encoding.Data_encoding.json
                              (option Tezos_data_encoding.Data_encoding.json)))
                      *
                      (((string ->
                        a ->
                          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a))
                        *
                        ((option (Lwt_stream.t string)) *
                          (((string ->
                            (Tezos_client_base.Client_context.lwt_format a unit)
                              -> a) * (a)) *
                            ((((Tezos_client_base.Client_context.lwt_format a
                              unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                (Tezos_base__TzPervasives.tzresult string)) -> a)
                                * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a
                                  (Tezos_base__TzPervasives.tzresult Bigstring.t))
                                  -> a) * (a)) *
                                  ((string ->
                                    Lwt.t
                                      (Tezos_base__TzPervasives.tzresult string))
                                    *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                                        (((string ->
                                          a ->
                                            (Tezos_base__TzPervasives.Data_encoding.encoding
                                              a) ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  unit)) * (a)) * _)))))))))))))))))))))
  * _) ->
  (option Tezos_base__TzPervasives.Time.Protocol.t) ->
    Tezos_shell_services.Shell_services.block ->
      Tezos_protocol_genesis.Protocol.Data.Command.t ->
        Tezos_client_base.Client_keys.sk_uri ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_base__TzPervasives.Block_hash.t).
src/proto_genesis/lib_client/protocol_client_context.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Genesis_block_services = Block_services.Make (Protocol) (Protocol)
src/proto_genesis/lib_client/protocol_client_context.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
src/proto_genesis/lib_protocol/data.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Command = struct

  type t =
    (* Activate a protocol *)
    | Activate of {
        protocol: Protocol_hash.t ;
        fitness: Fitness.t ;
        protocol_parameters : MBytes.t ;
      }

    (* Activate a protocol as a testchain *)
    | Activate_testchain of {
        protocol: Protocol_hash.t ;
        fitness: Fitness.t ;
        protocol_parameters : MBytes.t ;
        delay: Int64.t ;
      }

  let mk_case name args =
    let open Data_encoding in
    conv
      (fun o -> ((), o))
      (fun ((), o) -> o)
      (merge_objs
         (obj1 (req "command" (constant name)))
         args)

  let encoding =
    let open Data_encoding in
    union ~tag_size:`Uint8 [
      case (Tag 0)
        ~title:"Activate"
        (mk_case "activate"
           (obj3
              (req "hash" Protocol_hash.encoding)
              (req "fitness" Fitness.encoding)
              (req "protocol_parameters" Variable.bytes)
           ))
        (function
          | Activate { protocol ; fitness ; protocol_parameters} ->
              Some (protocol, fitness, protocol_parameters)
          | _ -> None)
        (fun (protocol, fitness, protocol_parameters) ->
           Activate { protocol ; fitness ; protocol_parameters }) ;
      case (Tag 1)
        ~title:"Activate_testchain"
        (mk_case "activate_testchain"
           (obj4
              (req "hash" Protocol_hash.encoding)
              (req "fitness" Fitness.encoding)
              (req "protocol_parameters" Variable.bytes)
              (req "validity_time" int64)))
        (function
          | Activate_testchain { protocol ; fitness ; protocol_parameters ; delay } ->
              Some (protocol, fitness, protocol_parameters, delay)
          | _ -> None)
        (fun (protocol, fitness, protocol_parameters, delay) ->
           Activate_testchain { protocol ; fitness ; protocol_parameters ; delay }) ;
    ]

  let signed_encoding =
    let open Data_encoding in
    obj2
      (req "content" encoding)
      (req "signature" Signature.encoding)

  let forge shell command =
    Data_encoding.Binary.to_bytes_exn
      (Data_encoding.tup2 Block_header.shell_header_encoding encoding)
      (shell, command)

end

module Pubkey = struct

  let pubkey_key = ["genesis_key"]

  let default =
    Signature.Public_key.of_b58check_exn
      "edpkvVCdQtDJHPnkmfRZuuHWKzFetH9N9nGP8F7zkwM2BJpjbvAU1N"

  let get_pubkey ctxt =
    Context.get ctxt pubkey_key >>= function
    | None -> Lwt.return default
    | Some b ->
        match Data_encoding.Binary.of_bytes Signature.Public_key.encoding b with
        | None -> Lwt.return default
        | Some pk -> Lwt.return pk

  let set_pubkey ctxt v =
    Context.set ctxt pubkey_key @@
    Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding v

  let sandbox_encoding =
    let open Data_encoding in
    merge_objs
      (obj1 (req "genesis_pubkey" Signature.Public_key.encoding))
      Data_encoding.unit

  let may_change_default ctxt json =
    match Data_encoding.Json.destruct sandbox_encoding json with
    | exception _ ->
        Lwt.return ctxt
    | (pubkey, ()) ->
        set_pubkey ctxt pubkey >>= fun ctxt ->
        Lwt.return ctxt

end

module Init = struct

  type error += Incompatible_protocol_version

  let version_key = ["version"]

  (* This key should always be populated for every version of the
     protocol.  It's absence meaning that the context is empty. *)
  let version_value = "genesis"

  let check_inited ctxt =
    Context.get ctxt version_key >>= function
    | None -> failwith "Internal error: uninitialized context."
    | Some version ->
        if Compare.String.(version_value <> MBytes.to_string version) then
          failwith "Internal error: incompatible protocol version" ;
        return_unit

  let tag_first_block ctxt =
    Context.get ctxt version_key >>= function
    | None ->
        Context.set
          ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
        return ctxt
    | Some _version ->
        failwith "Internal error: previously initialized context." ;

end
src/proto_genesis/lib_protocol/data.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Command.
  Inductive t : Type :=
  | Activate :
    Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
    -> Tezos_protocol_environment_genesis__Environment.MBytes.t -> t
  | Activate_testchain :
    Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
    -> Tezos_protocol_environment_genesis__Environment.MBytes.t ->
    Tezos_protocol_environment_genesis__Environment.Int64.t -> t.
  
  Definition mk_case {A : Type}
    (name : string)
    (args :
      Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding A)
    : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding A :=
    Tezos_protocol_environment_genesis__Environment.Data_encoding.conv
      (fun o => (tt, o))
      (fun function_parameter =>
        match function_parameter with
        | (tt, o) => o
        end) None
      (Tezos_protocol_environment_genesis__Environment.Data_encoding.merge_objs
        (Tezos_protocol_environment_genesis__Environment.Data_encoding.obj1
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
            None None "command" % string
            (Tezos_protocol_environment_genesis__Environment.Data_encoding.constant
              name))) args).
  
  Definition encoding
    : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding t :=
    Tezos_protocol_environment_genesis__Environment.Data_encoding.union
      (Some variant)
      (cons
        (Tezos_protocol_environment_genesis__Environment.Data_encoding.case
          "Activate" % string None (Tag 0)
          (mk_case "activate" % string
            (Tezos_protocol_environment_genesis__Environment.Data_encoding.obj3
              (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
                None None "hash" % string
                Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
              (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
                None None "fitness" % string
                Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
              (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
                None None "protocol_parameters" % string
                Tezos_protocol_environment_genesis__Environment.Data_encoding.Variable.bytes)))
          (fun function_parameter =>
            match function_parameter with
            |
              Activate {|
                protocol := protocol;
                  fitness := fitness;
                  protocol_parameters := protocol_parameters
                  |} => Some (protocol, fitness, protocol_parameters)
            | _ => None
            end)
          (fun function_parameter =>
            match function_parameter with
            | (protocol, fitness, protocol_parameters) =>
              Activate
                {| protocol := protocol; fitness := fitness;
                  protocol_parameters := protocol_parameters |}
            end))
        (cons
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.case
            "Activate_testchain" % string None (Tag 1)
            (mk_case "activate_testchain" % string
              (Tezos_protocol_environment_genesis__Environment.Data_encoding.obj4
                (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
                  None None "hash" % string
                  Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
                (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
                  None None "fitness" % string
                  Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
                (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
                  None None "protocol_parameters" % string
                  Tezos_protocol_environment_genesis__Environment.Data_encoding.Variable.bytes)
                (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
                  None None "validity_time" % string
                  Tezos_protocol_environment_genesis__Environment.Data_encoding.int64)))
            (fun function_parameter =>
              match function_parameter with
              |
                Activate_testchain {|
                  protocol := protocol;
                    fitness := fitness;
                    protocol_parameters := protocol_parameters;
                    delay := delay
                    |} => Some (protocol, fitness, protocol_parameters, delay)
              | _ => None
              end)
            (fun function_parameter =>
              match function_parameter with
              | (protocol, fitness, protocol_parameters, delay) =>
                Activate_testchain
                  {| protocol := protocol; fitness := fitness;
                    protocol_parameters := protocol_parameters; delay := delay
                    |}
              end)) [])).
  
  Definition signed_encoding
    : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
      (t * Tezos_protocol_environment_genesis__Environment.Signature.t) :=
    Tezos_protocol_environment_genesis__Environment.Data_encoding.obj2
      (Tezos_protocol_environment_genesis__Environment.Data_encoding.req None
        None "content" % string encoding)
      (Tezos_protocol_environment_genesis__Environment.Data_encoding.req None
        None "signature" % string
        Tezos_protocol_environment_genesis__Environment.Signature.encoding).
  
  Definition forge
    (shell :
      Tezos_protocol_environment_genesis__Environment.Block_header.shell_header)
    (command : t) : Tezos_protocol_environment_genesis__Environment.MBytes.t :=
    Tezos_protocol_environment_genesis__Environment.Data_encoding.Binary.to_bytes_exn
      (Tezos_protocol_environment_genesis__Environment.Data_encoding.tup2
        Tezos_protocol_environment_genesis__Environment.Block_header.shell_header_encoding
        encoding) (shell, command).
End Command.

Module Pubkey.
  Definition pubkey_key : list string := cons "genesis_key" % string [].
  
  Definition default
    : Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t :=
    Tezos_protocol_environment_genesis__Environment.Signature.Public_key.of_b58check_exn
      "edpkvVCdQtDJHPnkmfRZuuHWKzFetH9N9nGP8F7zkwM2BJpjbvAU1N" % string.
  
  Definition get_pubkey
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t :=
    Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
      (Tezos_protocol_environment_genesis__Environment.Context.get ctxt
        pubkey_key)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_genesis__Environment.Lwt._return default
        | Some b =>
          match
            Tezos_protocol_environment_genesis__Environment.Data_encoding.Binary.of_bytes
              Tezos_protocol_environment_genesis__Environment.Signature.Public_key.encoding
              b with
          | None =>
            Tezos_protocol_environment_genesis__Environment.Lwt._return default
          | Some pk =>
            Tezos_protocol_environment_genesis__Environment.Lwt._return pk
          end
        end).
  
  Definition set_pubkey
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    (v : Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      Tezos_protocol_environment_genesis__Environment.Context.t :=
    Tezos_protocol_environment_genesis__Environment.Pervasives.op_at_at
      (Tezos_protocol_environment_genesis__Environment.Context.set ctxt
        pubkey_key)
      (Tezos_protocol_environment_genesis__Environment.Data_encoding.Binary.to_bytes_exn
        Tezos_protocol_environment_genesis__Environment.Signature.Public_key.encoding
        v).
  
  Definition sandbox_encoding
    : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
      (Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t *
        unit) :=
    Tezos_protocol_environment_genesis__Environment.Data_encoding.merge_objs
      (Tezos_protocol_environment_genesis__Environment.Data_encoding.obj1
        (Tezos_protocol_environment_genesis__Environment.Data_encoding.req None
          None "genesis_pubkey" % string
          Tezos_protocol_environment_genesis__Environment.Signature.Public_key.encoding))
      Tezos_protocol_environment_genesis__Environment.Data_encoding.unit.
  
  Definition may_change_default
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    (json : Tezos_protocol_environment_genesis__Environment.Data_encoding.json)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      Tezos_protocol_environment_genesis__Environment.Context.t :=
    match
      Tezos_protocol_environment_genesis__Environment.Data_encoding.Json.destruct
        sandbox_encoding json with
    | (pubkey, tt) =>
      Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
        (set_pubkey ctxt pubkey)
        (fun ctxt =>
          Tezos_protocol_environment_genesis__Environment.Lwt._return ctxt)
    end.
End Pubkey.

Module Init.
  Definition version_key : list string := cons "version" % string [].
  
  Definition version_value : string := "genesis" % string.
  
  Definition check_inited
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult unit) :=
    Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
      (Tezos_protocol_environment_genesis__Environment.Context.get ctxt
        version_key)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_genesis__Environment.Pervasives.failwith
            "Internal error: uninitialized context." % string
        | Some version =>
          if
            Tezos_protocol_environment_genesis__Environment.Compare.String.(Tezos_protocol_environment_genesis__Environment.S.Compare.op_lt_gt)
              version_value
              (Tezos_protocol_environment_genesis__Environment.MBytes.to_string
                version) then
            Tezos_protocol_environment_genesis__Environment.Pervasives.failwith
              "Internal error: incompatible protocol version" % string
          else
            tt;
          Tezos_protocol_environment_genesis__Environment.Error_monad.return_unit
        end).
  
  Definition tag_first_block
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
        Tezos_protocol_environment_genesis__Environment.Context.t) :=
    Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
      (Tezos_protocol_environment_genesis__Environment.Context.get ctxt
        version_key)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
            (Tezos_protocol_environment_genesis__Environment.Context.set ctxt
              version_key
              (Tezos_protocol_environment_genesis__Environment.MBytes.of_string
                version_value))
            (fun ctxt =>
              Tezos_protocol_environment_genesis__Environment.Error_monad._return
                ctxt)
        | Some _version =>
          Tezos_protocol_environment_genesis__Environment.Pervasives.failwith
            "Internal error: previously initialized context." % string
        end).
End Init.
src/proto_genesis/lib_protocol/main.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Parsing_error
type error += Invalid_signature

let () =
  register_error_kind
    `Permanent
    ~id:"parsing_error"
    ~title:"Parsing error"
    ~description:"Raised when a block header has not been parsed correctly"
    ~pp:(fun ppf () -> Format.fprintf ppf "Block header parsing error")
    Data_encoding.empty
    (function Parsing_error -> Some () | _ -> None)
    (fun () -> Parsing_error)

let () =
  register_error_kind
    `Permanent
    ~id:"invalid_signature"
    ~title:"Invalid signature"
    ~description:"Raised when the provided signature is invalid"
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid signature")
    Data_encoding.empty
    (function Invalid_signature -> Some () | _ -> None)
    (fun () -> Invalid_signature)

type operation_data = unit
let operation_data_encoding = Data_encoding.unit

type operation_receipt = unit
let operation_receipt_encoding = Data_encoding.unit

let operation_data_and_receipt_encoding =
  Data_encoding.conv
    (function ((), ()) -> ())
    (fun () -> ((), ()))
    Data_encoding.unit

type operation = {
  shell: Operation.shell_header ;
  protocol_data: operation_data ;
}

let acceptable_passes _op = []
let compare_operations _ _ = 0
let validation_passes = []

type block_header_data = {
  command: Data.Command.t ;
  signature: Signature.t ;
}
type block_header = {
  shell: Block_header.shell_header ;
  protocol_data: block_header_data ;
}

let block_header_data_encoding =
  Data_encoding.conv
    (fun { command ; signature } -> (command, signature))
    (fun (command, signature) ->  { command ; signature })
    Data.Command.signed_encoding

type block_header_metadata = unit
let block_header_metadata_encoding = Data_encoding.unit

let max_block_length =
  Data_encoding.Binary.length
    Data.Command.encoding
    (Activate_testchain { protocol = Protocol_hash.zero ;
                          fitness = [ MBytes.create 1 ] ;
                          protocol_parameters = MBytes.create 1 ;
                          delay = 0L })
  + Signature.size

let max_operation_data_length = 0

let check_signature ctxt ~chain_id { shell ; protocol_data = { command ; signature } } =
  let bytes = Data.Command.forge shell command in
  Data.Pubkey.get_pubkey ctxt >>= fun public_key ->
  fail_unless
    (Signature.check ~watermark:(Block_header chain_id) public_key signature bytes)
    Invalid_signature

type validation_state = Updater.validation_result

let current_context ({ context ; _ } : validation_state) =
  return context

(* temporary hardcoded key to be removed... *)
let protocol_parameters_key = [ "protocol_parameters" ]

let prepare_application ctxt command level timestamp _fitness =
  match command with
  | Data.Command.Activate { protocol = hash ; fitness ; protocol_parameters } ->
      let message =
        Some (Format.asprintf "activate %a" Protocol_hash.pp_short hash) in
      Context.set ctxt protocol_parameters_key protocol_parameters >>= fun ctxt ->
      Updater.activate ctxt hash >>= fun ctxt ->
      return { Updater.message ; context = ctxt ;
               fitness ; max_operations_ttl = 0 ;
               last_allowed_fork_level = level ;
             }
  | Activate_testchain { protocol = hash ; fitness ; protocol_parameters ; delay } ->
      let message =
        Some (Format.asprintf "activate testchain %a" Protocol_hash.pp_short hash) in
      Context.set ctxt protocol_parameters_key protocol_parameters >>= fun ctxt ->
      let expiration = Time.add timestamp delay in
      Updater.fork_test_chain ctxt ~protocol:hash ~expiration >>= fun ctxt ->
      return { Updater.message ; context = ctxt ; fitness ;
               max_operations_ttl = 0 ;
               last_allowed_fork_level = level ;
             }

let begin_application
    ~chain_id
    ~predecessor_context:ctxt
    ~predecessor_timestamp:_
    ~predecessor_fitness:_
    block_header =
  Data.Init.check_inited ctxt >>=? fun () ->
  check_signature ctxt ~chain_id block_header >>=? fun () ->
  prepare_application ctxt block_header.protocol_data.command
    block_header.shell.level block_header.shell.timestamp block_header.shell.fitness

let begin_partial_application
    ~chain_id
    ~ancestor_context
    ~predecessor_timestamp
    ~predecessor_fitness
    block_header =
  begin_application
    ~chain_id
    ~predecessor_context:ancestor_context
    ~predecessor_timestamp
    ~predecessor_fitness
    block_header

let begin_construction
    ~chain_id:_
    ~predecessor_context:ctxt
    ~predecessor_timestamp:_
    ~predecessor_level:level
    ~predecessor_fitness:fitness
    ~predecessor:_
    ~timestamp
    ?protocol_data
    () =
  match protocol_data with
  | None ->
      (* Dummy result. *)
      return { Updater.message = None ; context = ctxt ;
               fitness ; max_operations_ttl = 0 ;
               last_allowed_fork_level = 0l ;
             }
  | Some { command ; _ }->
      Data.Init.check_inited ctxt >>=? fun () ->
      prepare_application ctxt command level timestamp fitness

let apply_operation _vctxt _ =
  failwith "genesis.apply_operation" (* absurd *)

let finalize_block state = return (state, ())

let rpc_services = Services.rpc_services

(* temporary hardcoded key to be removed... *)
let sandbox_param_key = [ "sandbox_parameter" ]
let get_sandbox_param ctxt =
  Context.get ctxt sandbox_param_key >>= function
  | None -> return_none
  | Some bytes ->
      match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
      | None ->
          failwith "Internal error: failed to parse the sandbox parameter."
      | Some json -> return_some json

let init ctxt block_header =
  Data.Init.tag_first_block ctxt >>=? fun ctxt ->
  get_sandbox_param ctxt >>=? fun sandbox_param ->
  begin
    match sandbox_param with
    | None -> return ctxt
    | Some json ->
        Data.Pubkey.may_change_default ctxt json >>= fun ctxt ->
        return ctxt
  end >>=? fun ctxt ->
  return { Updater.message = None ; context = ctxt ;
           fitness = block_header.Block_header.fitness ;
           max_operations_ttl = 0 ;
           last_allowed_fork_level = block_header.level ;
         }
src/proto_genesis/lib_protocol/main.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition operation_data := unit.

Definition operation_data_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
  Tezos_protocol_environment_genesis__Environment.Data_encoding.unit.

Definition operation_receipt := unit.

Definition operation_receipt_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
  Tezos_protocol_environment_genesis__Environment.Data_encoding.unit.

Definition operation_data_and_receipt_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
    (unit * unit) :=
  Tezos_protocol_environment_genesis__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | (tt, tt) => tt
      end)
    (fun function_parameter =>
      match function_parameter with
      | tt => (tt, tt)
      end) None
    Tezos_protocol_environment_genesis__Environment.Data_encoding.unit.

Record operation := {
  shell : Tezos_protocol_environment_genesis__Environment.Operation.shell_header;
  protocol_data : operation_data }.

Definition acceptable_passes {A B : Type} (_op : A) : list B := [].

Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ => 0
      end
  end.

Definition validation_passes {A : Type} : list A := [].

Record block_header_data := {
  command : Tezos_raw_protocol_genesis.Data.Command.t;
  signature : Tezos_protocol_environment_genesis__Environment.Signature.t }.

Record block_header := {
  shell :
    Tezos_protocol_environment_genesis__Environment.Block_header.shell_header;
  protocol_data : block_header_data }.

Definition block_header_data_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
    block_header_data :=
  Tezos_protocol_environment_genesis__Environment.Data_encoding.conv
    (fun function_parameter =>
      match function_parameter with
      | {| command := command; signature := signature |} => (command, signature)
      end)
    (fun function_parameter =>
      match function_parameter with
      | (command, signature) => {| command := command; signature := signature |}
      end) None Tezos_raw_protocol_genesis.Data.Command.signed_encoding.

Definition block_header_metadata := unit.

Definition block_header_metadata_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
  Tezos_protocol_environment_genesis__Environment.Data_encoding.unit.

Definition max_block_length : Z :=
  Tezos_protocol_environment_genesis__Environment.Pervasives.op_plus
    (Tezos_protocol_environment_genesis__Environment.Data_encoding.Binary.length
      Tezos_raw_protocol_genesis.Data.Command.encoding
      (Activate_testchain
        {|
          protocol :=
            Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.zero);
          fitness :=
            cons
              (Tezos_protocol_environment_genesis__Environment.MBytes.create 1)
              [];
          protocol_parameters :=
            Tezos_protocol_environment_genesis__Environment.MBytes.create 1;
          delay := 0 |}))
    Tezos_protocol_environment_genesis__Environment.Signature.size.

Definition max_operation_data_length : Z := 0.

Definition check_signature
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  (chain_id :
    Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
  (function_parameter : block_header)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | {|
    shell := shell;
      protocol_data := {| command := command; signature := signature |}
      |} =>
    let bytes := Tezos_raw_protocol_genesis.Data.Command.forge shell command in
    Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
      (Tezos_raw_protocol_genesis.Data.Pubkey.get_pubkey ctxt)
      (fun public_key =>
        Tezos_protocol_environment_genesis__Environment.Error_monad.fail_unless
          (Tezos_protocol_environment_genesis__Environment.Signature.check
            (Some (Block_header chain_id)) public_key signature string)
          Invalid_signature)
  end.

Definition validation_state :=
  Tezos_protocol_environment_genesis__Environment.Updater.validation_result.

Definition current_context (function_parameter : validation_state)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      Tezos_protocol_environment_genesis__Environment.Context.t) :=
  match function_parameter with
  | {| context := context |} =>
    Tezos_protocol_environment_genesis__Environment.Error_monad._return context
  end.

Definition protocol_parameters_key : list string :=
  cons "protocol_parameters" % string [].

Definition prepare_application {A : Type}
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  (command : Tezos_raw_protocol_genesis.Data.Command.t)
  (level : Tezos_protocol_environment_genesis__Environment.Int32.t)
  (timestamp : Tezos_protocol_environment_genesis__Environment.Time.t)
  (_fitness : A)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  match command with
  |
    Data.Command.Activate {|
      protocol := hash;
        fitness := fitness;
        protocol_parameters := protocol_parameters
        |} =>
    let message :=
      Some
        (Tezos_protocol_environment_genesis__Environment.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "activate " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "activate %a" % string)
          Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.pp_short)
          hash) in
    Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
      (Tezos_protocol_environment_genesis__Environment.Context.set ctxt
        protocol_parameters_key protocol_parameters)
      (fun ctxt =>
        Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
          (Tezos_protocol_environment_genesis__Environment.Updater.activate ctxt
            hash)
          (fun ctxt =>
            Tezos_protocol_environment_genesis__Environment.Error_monad._return
              {| Updater.context := ctxt; Updater.fitness := fitness;
                Updater.message := message; Updater.max_operations_ttl := 0;
                Updater.last_allowed_fork_level := level |}))
  |
    Activate_testchain {|
      protocol := hash;
        fitness := fitness;
        protocol_parameters := protocol_parameters;
        delay := delay
        |} =>
    let message :=
      Some
        (Tezos_protocol_environment_genesis__Environment.Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "activate testchain " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "activate testchain %a" % string)
          Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.pp_short)
          hash) in
    Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
      (Tezos_protocol_environment_genesis__Environment.Context.set ctxt
        protocol_parameters_key protocol_parameters)
      (fun ctxt =>
        let expiration :=
          Tezos_protocol_environment_genesis__Environment.Time.add timestamp
            delay in
        Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
          (Tezos_protocol_environment_genesis__Environment.Updater.fork_test_chain
            ctxt hash expiration)
          (fun ctxt =>
            Tezos_protocol_environment_genesis__Environment.Error_monad._return
              {| Updater.context := ctxt; Updater.fitness := fitness;
                Updater.message := message; Updater.max_operations_ttl := 0;
                Updater.last_allowed_fork_level := level |}))
  end.

Definition begin_application {A B : Type}
  (chain_id :
    Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  (function_parameter : A)
  : B ->
    block_header ->
      Tezos_protocol_environment_genesis__Environment.Lwt.t
        (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
          Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  match function_parameter with
  | _ =>
    fun function_parameter =>
      match function_parameter with
      | _ =>
        fun block_header =>
          Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq_question
            (Tezos_raw_protocol_genesis.Data.Init.check_inited ctxt)
            (fun function_parameter =>
              match function_parameter with
              | tt =>
                Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq_question
                  (check_signature ctxt chain_id block_header)
                  (fun function_parameter =>
                    match function_parameter with
                    | tt =>
                      prepare_application ctxt
                        (command (protocol_data block_header))
                        (level (shell block_header))
                        (timestamp (shell block_header))
                        (fitness (shell block_header))
                    end)
              end)
      end
  end.

Definition begin_partial_application {A B : Type}
  (chain_id :
    Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
  (ancestor_context : Tezos_protocol_environment_genesis__Environment.Context.t)
  (predecessor_timestamp : A) (predecessor_fitness : B)
  (block_header : block_header)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  begin_application chain_id ancestor_context predecessor_timestamp
    predecessor_fitness block_header.

Definition begin_construction {A B C : Type} (function_parameter : A)
  : Tezos_protocol_environment_genesis__Environment.Context.t ->
    B ->
      Tezos_protocol_environment_genesis__Environment.Int32.t ->
        Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
          ->
          C ->
            Tezos_protocol_environment_genesis__Environment.Time.t ->
              (option block_header_data) ->
                unit ->
                  Tezos_protocol_environment_genesis__Environment.Lwt.t
                    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
                      Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  match function_parameter with
  | _ =>
    fun ctxt =>
      fun function_parameter =>
        match function_parameter with
        | _ =>
          fun level =>
            fun fitness =>
              fun function_parameter =>
                match function_parameter with
                | _ =>
                  fun timestamp =>
                    fun protocol_data =>
                      fun function_parameter =>
                        match function_parameter with
                        | tt =>
                          match protocol_data with
                          | None =>
                            Tezos_protocol_environment_genesis__Environment.Error_monad._return
                              {| Updater.context := ctxt;
                                Updater.fitness := fitness;
                                Updater.message := None;
                                Updater.max_operations_ttl := 0;
                                Updater.last_allowed_fork_level := 0 |}
                          | Some {| command := command |} =>
                            Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq_question
                              (Tezos_raw_protocol_genesis.Data.Init.check_inited
                                ctxt)
                              (fun function_parameter =>
                                match function_parameter with
                                | tt =>
                                  prepare_application ctxt command level
                                    timestamp fitness
                                end)
                          end
                        end
                end
        end
  end.

Definition apply_operation {A B C : Type} (_vctxt : A) (function_parameter : B)
  : C :=
  match function_parameter with
  | _ =>
    Tezos_protocol_environment_genesis__Environment.Pervasives.failwith
      "genesis.apply_operation" % string
  end.

Definition finalize_block {A : Type} (state : A)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      (A * unit)) :=
  Tezos_protocol_environment_genesis__Environment.Error_monad._return
    (state, tt).

Definition rpc_services
  : Tezos_protocol_environment_genesis__Environment.RPC_directory.t
    Tezos_protocol_environment_genesis__Environment.Updater.rpc_context :=
  Tezos_raw_protocol_genesis.Services.rpc_services.

Definition sandbox_param_key : list string :=
  cons "sandbox_parameter" % string [].

Definition get_sandbox_param
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      (option Tezos_protocol_environment_genesis__Environment.Data_encoding.json)) :=
  Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
    (Tezos_protocol_environment_genesis__Environment.Context.get ctxt
      sandbox_param_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Tezos_protocol_environment_genesis__Environment.Error_monad.return_none
      | Some bytes =>
        match
          Tezos_protocol_environment_genesis__Environment.Data_encoding.Binary.of_bytes
            Tezos_protocol_environment_genesis__Environment.Data_encoding.json
            string with
        | None =>
          Tezos_protocol_environment_genesis__Environment.Pervasives.failwith
            "Internal error: failed to parse the sandbox parameter." % string
        | Some json =>
          Tezos_protocol_environment_genesis__Environment.Error_monad.return_some
            json
        end
      end).

Definition init
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  (block_header :
    Tezos_protocol_environment_genesis__Environment.Block_header.shell_header)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq_question
    (Tezos_raw_protocol_genesis.Data.Init.tag_first_block ctxt)
    (fun ctxt =>
      Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq_question
        (get_sandbox_param ctxt)
        (fun sandbox_param =>
          Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq_question
            match sandbox_param with
            | None =>
              Tezos_protocol_environment_genesis__Environment.Error_monad._return
                ctxt
            | Some json =>
              Tezos_protocol_environment_genesis__Environment.Error_monad.op_gt_gt_eq
                (Tezos_raw_protocol_genesis.Data.Pubkey.may_change_default ctxt
                  json)
                (fun ctxt =>
                  Tezos_protocol_environment_genesis__Environment.Error_monad._return
                    ctxt)
            end
            (fun ctxt =>
              Tezos_protocol_environment_genesis__Environment.Error_monad._return
                {| Updater.context := ctxt;
                  Updater.fitness := Block_header.fitness block_header;
                  Updater.message := None; Updater.max_operations_ttl := 0;
                  Updater.last_allowed_fork_level := level block_header |}))).
src/proto_genesis/lib_protocol/main.mli 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Protocol Signature Instance *)

type block_header_data = {
  command: Data.Command.t ;
  signature: Signature.t ;
}

include Updater.PROTOCOL with type block_header_data := block_header_data
src/proto_genesis/lib_protocol/main.mli.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record block_header_data := {
  command : Tezos_raw_protocol_genesis.Data.Command.t;
  signature : Tezos_protocol_environment_genesis__Environment.Signature.t }.

include
src/proto_genesis/lib_protocol/services.ml 
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Forge = struct
  let block custom_root =
    let open Data_encoding in
    RPC_service.post_service
      ~description: "Forge a block"
      ~query: RPC_query.empty
      ~input:
        (merge_objs
           (obj6
              (req "level" int32)
              (req "proto_level" uint8)
              (req "predecessor" Block_hash.encoding)
              (req "timestamp" Time.encoding)
              (req "fitness" Fitness.encoding)
              (req "context" Context_hash.encoding))
           Data.Command.encoding)
      ~output: (obj1 (req "payload" bytes))
      RPC_path.(custom_root / "helpers" / "forge" / "block")
end

let int64_to_bytes i =
  let b = MBytes.create 8 in
  MBytes.set_int64 b 0 i;
  b

let operations_hash =
  Operation_list_list_hash.compute []

let rpc_services : Updater.rpc_context RPC_directory.t =
  let dir = RPC_directory.empty in
  let dir =
    RPC_directory.register
      dir
      (Forge.block RPC_path.open_root)
      (fun _ctxt () ((level, proto_level, predecessor,
                      timestamp, fitness, context), command) ->
        let shell = { Block_header.level ; proto_level ; predecessor ;
                      timestamp ; fitness ; validation_passes = 0 ;
                      operations_hash ; context } in
        let bytes = Data.Command.forge shell command in
        return bytes) in
  dir
src/proto_genesis/lib_protocol/services.ml.v 
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Forge.
  Definition block {A B : Type}
    (custom_root :
      Tezos_protocol_environment_genesis__Environment.RPC_path.path A B)
    : Tezos_protocol_environment_genesis__Environment.RPC_service.service
      variant A B unit
      ((int32 * Z *
        Tezos_protocol_environment_genesis__Environment.Block_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
        * Tezos_protocol_environment_genesis__Environment.Time.t *
        Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
        *
        Tezos_protocol_environment_genesis__Environment.Context_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
        * Tezos_raw_protocol_genesis.Data.Command.t)
      Tezos_protocol_environment_genesis__Environment.MBytes.t :=
    Tezos_protocol_environment_genesis__Environment.RPC_service.post_service
      (Some "Forge a block" % string)
      Tezos_protocol_environment_genesis__Environment.RPC_query.empty
      (Tezos_protocol_environment_genesis__Environment.Data_encoding.merge_objs
        (Tezos_protocol_environment_genesis__Environment.Data_encoding.obj6
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
            None None "level" % string
            Tezos_protocol_environment_genesis__Environment.Data_encoding.int32)
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
            None None "proto_level" % string
            Tezos_protocol_environment_genesis__Environment.Data_encoding.uint8)
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
            None None "predecessor" % string
            Tezos_protocol_environment_genesis__Environment.Block_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
            None None "timestamp" % string
            Tezos_protocol_environment_genesis__Environment.Time.encoding)
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
            None None "fitness" % string
            Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.req
            None None "context" % string
            Tezos_protocol_environment_genesis__Environment.Context_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding)))
        Tezos_raw_protocol_genesis.Data.Command.encoding)
      (Tezos_protocol_environment_genesis__Environment.Data_encoding.obj1
        (Tezos_protocol_environment_genesis__Environment.Data_encoding.req None
          None "payload" % string
          Tezos_protocol_environment_genesis__Environment.Data_encoding.bytes))
      (Tezos_protocol_environment_genesis__Environment.RPC_path.op_div
        (Tezos_protocol_environment_genesis__Environment.RPC_path.op_div
          (Tezos_protocol_environment_genesis__Environment.RPC_path.op_div
            custom_root "helpers" % string) "forge" % string) "block" % string).
End Forge.

Definition int64_to_bytes (i : int64)
  : Tezos_protocol_environment_genesis__Environment.MBytes.t :=
  let b := Tezos_protocol_environment_genesis__Environment.MBytes.create 8 in
  Tezos_protocol_environment_genesis__Environment.MBytes.set_int64 b 0 i;
  b.

Definition operations_hash
  : Tezos_protocol_environment_genesis__Environment.Operation_list_list_hash.(Tezos_protocol_environment_genesis__Environment.MERKLE_TREE.S.t) :=
  Tezos_protocol_environment_genesis__Environment.Operation_list_list_hash.(Tezos_protocol_environment_genesis__Environment.MERKLE_TREE.S.compute)
    [].

Definition rpc_services
  : Tezos_protocol_environment_genesis__Environment.RPC_directory.t
    Tezos_protocol_environment_genesis__Environment.Updater.rpc_context :=
  let dir := Tezos_protocol_environment_genesis__Environment.RPC_directory.empty
    in
  let dir :=
    Tezos_protocol_environment_genesis__Environment.RPC_directory.register dir
      (Forge.block
        Tezos_protocol_environment_genesis__Environment.RPC_path.open_root)
      (fun _ctxt =>
        fun function_parameter =>
          match function_parameter with
          | tt =>
            fun function_parameter =>
              match function_parameter with
              |
                ((level, proto_level, predecessor, timestamp, fitness, context),
                  command) =>
                let shell :=
                  {| Block_header.level := level;
                    Block_header.proto_level := proto_level;
                    Block_header.predecessor := predecessor;
                    Block_header.timestamp := timestamp;
                    Block_header.validation_passes := 0;
                    Block_header.operations_hash := operations_hash;
                    Block_header.fitness := fitness;
                    Block_header.context := context |} in
                let bytes :=
                  Tezos_raw_protocol_genesis.Data.Command.forge shell command in
                Tezos_protocol_environment_genesis__Environment.Error_monad._return
                  string
              end
          end) in
  dir.

Sources are on GitHub. © Guillaume Claret.